packages feed

ghc-lib (empty) → 0.1.0

raw patch · 437 files changed

+263015/−0 lines, 437 filesdep +Win32dep +arraydep +basesetup-changed

Dependencies added: Win32, array, base, binary, bytestring, containers, deepseq, directory, filepath, ghc-lib, ghc-lib-parser, ghc-prim, haskeline, hpc, pretty, process, time, transformers, unix

Files

+ LICENSE view
@@ -0,0 +1,31 @@+The Glasgow Haskell Compiler License++Copyright 2002, The University Court of the University of Glasgow. +All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +- Neither name of the University nor the names of its contributors may be+used to endorse or promote products derived from this software without+specific prior written permission. ++THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF+GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,+INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND+FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH+DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ compiler/HsVersions.h view
@@ -0,0 +1,65 @@+#pragma once++#if 0++IMPORTANT!  If you put extra tabs/spaces in these macro definitions,+you will screw up the layout where they are used in case expressions!++(This is cpp-dependent, of course)++#endif++/* Useful in the headers that we share with the RTS */+#define COMPILING_GHC 1++/* Pull in all the platform defines for this build (foo_TARGET_ARCH etc.) */+#include "ghc_boot_platform.h"++/* Pull in the autoconf defines (HAVE_FOO), but don't include+ * ghcconfig.h, because that will include ghcplatform.h which has the+ * wrong platform settings for the compiler (it has the platform+ * settings for the target plat instead). */+#include "ghcautoconf.h"++#define GLOBAL_VAR(name,value,ty)  \+{-# NOINLINE name #-};             \+name :: IORef (ty);                \+name = Util.global (value);++#define GLOBAL_VAR_M(name,value,ty) \+{-# NOINLINE name #-};              \+name :: IORef (ty);                 \+name = Util.globalM (value);+++#define SHARED_GLOBAL_VAR(name,accessor,saccessor,value,ty) \+{-# NOINLINE name #-};                                      \+name :: IORef (ty);                                         \+name = Util.sharedGlobal (value) (accessor);                \+foreign import ccall unsafe saccessor                       \+  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));++#define SHARED_GLOBAL_VAR_M(name,accessor,saccessor,value,ty)  \+{-# NOINLINE name #-};                                         \+name :: IORef (ty);                                            \+name = Util.sharedGlobalM (value) (accessor);                  \+foreign import ccall unsafe saccessor                          \+  accessor :: Ptr (IORef a) -> IO (Ptr (IORef a));+++#define ASSERT(e)      if debugIsOn && not (e) then (assertPanic __FILE__ __LINE__) else+#define ASSERT2(e,msg) if debugIsOn && not (e) then (assertPprPanic __FILE__ __LINE__ (msg)) else+#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $++-- Examples:   Assuming   flagSet :: String -> m Bool+--+--    do { c   <- getChar; MASSERT( isUpper c ); ... }+--    do { c   <- getChar; MASSERT2( isUpper c, text "Bad" ); ... }+--    do { str <- getStr;  ASSERTM( flagSet str ); .. }+--    do { str <- getStr;  ASSERTM2( flagSet str, text "Bad" ); .. }+--    do { str <- getStr;  WARNM2( flagSet str, text "Flag is set" ); .. }+#define MASSERT(e)      ASSERT(e) return ()+#define MASSERT2(e,msg) ASSERT2(e,msg) return ()+#define ASSERTM(e)      do { bool <- e; MASSERT(bool) }+#define ASSERTM2(e,msg) do { bool <- e; MASSERT2(bool,msg) }+#define WARNM2(e,msg)   do { bool <- e; WARN(bool, msg) return () }
+ compiler/Unique.h view
@@ -0,0 +1,5 @@+/* unique has the following structure:+ * HsInt unique =+ *    (unique_tag << (sizeof (HsInt) - UNIQUE_TAG_BITS)) | unique_number+ */+#define UNIQUE_TAG_BITS 8
+ compiler/backpack/DriverBkp.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 DriverBkp (doBackpack) where++#include "HsVersions.h"++import GhcPrelude++-- In a separate module because it hooks into the parser.+import BkpSyn++import GHC hiding (Failed, Succeeded)+import Packages+import Parser+import Lexer+import GhcMonad+import DynFlags+import TcRnMonad+import TcRnDriver+import Module+import HscTypes+import StringBuffer+import FastString+import ErrUtils+import SrcLoc+import HscMain+import UniqFM+import UniqDFM+import Outputable+import Maybes+import HeaderInfo+import MkIface+import GhcMake+import UniqDSet+import PrelNames+import BasicTypes hiding (SuccessFlag(..))+import Finder+import Util++import qualified GHC.LanguageExtensions as LangExt++import Panic+import Data.List+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 SignatureD (L _ modname) _) = unitUniqDSet modname+    get_reqs (DeclD ModuleD _ _) = emptyUniqDSet+    get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) =+        unitIdFreeHoles (convertHsUnitId hsuid)++-- | Tiny enum for all types of Backpack operations we may do.+data SessionType+    -- | A compilation operation which will result in a+    -- runnable executable being produced.+    = ExeSession+    -- | A type-checking operation which produces only+    -- interface files, no object files.+    | TcSession+    -- | A compilation operation which produces both+    -- interface files and object files.+    | CompSession+    deriving (Eq)++-- | Create a temporary Session to do some sort of type checking or+-- compilation.+withBkpSession :: ComponentId+               -> [(ModuleName, Module)]+               -> [(UnitId, ModRenaming)]+               -> SessionType   -- what kind of session are we doing+               -> BkpM a        -- actual action to run+               -> BkpM a+withBkpSession cid insts deps session_type do_this = do+    dflags <- getDynFlags+    let (ComponentId cid_fs) = cid+        is_primary = False+        uid_str = unpackFS (hashUnitId cid insts)+        cid_str = unpackFS cid_fs+        -- There are multiple units in a single Backpack file, so we+        -- need to separate out the results in those cases.  Right now,+        -- we follow this hierarchy:+        --      $outputdir/$compid          --> typecheck results+        --      $outputdir/$compid/$unitid  --> compile results+        key_base p | Just f <- p dflags = f+                   | otherwise          = "."+        sub_comp p | is_primary = p+                   | otherwise = p </> cid_str+        outdir p | CompSession <- session_type+                 -- Special case when package is definite+                 , not (null insts) = sub_comp (key_base p) </> uid_str+                 | otherwise = sub_comp (key_base p)+    withTempSession (overHscDynFlags (\dflags ->+      -- If we're type-checking an indefinite package, we want to+      -- turn on interface writing.  However, if the user also+      -- explicitly passed in `-fno-code`, we DON'T want to write+      -- interfaces unless the user also asked for `-fwrite-interface`.+      -- See Note [-fno-code mode]+      (case session_type of+        -- Make sure to write interfaces when we are type-checking+        -- indefinite packages.+        TcSession | hscTarget dflags /= HscNothing+                  -> flip gopt_set Opt_WriteInterface+                  | otherwise -> id+        CompSession -> id+        ExeSession -> id) $+      dflags {+        hscTarget   = case session_type of+                        TcSession -> HscNothing+                        _ -> hscTarget dflags,+        thisUnitIdInsts_ = Just insts,+        thisComponentId_ = Just cid,+        thisInstalledUnitId =+            case session_type of+                TcSession -> newInstalledUnitId cid Nothing+                -- No hash passed if no instances+                _ | null insts -> newInstalledUnitId cid Nothing+                  | otherwise  -> newInstalledUnitId cid (Just (hashUnitId cid insts)),+        -- Setup all of the output directories according to our hierarchy+        objectDir   = Just (outdir objectDir),+        hiDir       = Just (outdir hiDir),+        stubDir     = Just (outdir stubDir),+        -- Unset output-file for non exe builds+        outputFile  = if session_type == ExeSession+                        then outputFile dflags+                        else Nothing,+        -- Clear the import path so we don't accidentally grab anything+        importPaths = [],+        -- Synthesized the flags+        packageFlags = packageFlags dflags ++ map (\(uid0, rn) ->+          let uid = unwireUnitId dflags (improveUnitId (getPackageConfigMap dflags) $ renameHoleUnitId dflags (listToUFM insts) uid0)+          in ExposePackage+            (showSDoc dflags+                (text "-unit-id" <+> ppr uid <+> ppr rn))+            (UnitIdArg uid) rn) deps+      } )) $ do+        dflags <- getSessionDynFlags+        -- pprTrace "flags" (ppr insts <> ppr deps) $ return ()+        -- Calls initPackages+        _ <- setSessionDynFlags dflags+        do_this++withBkpExeSession :: [(UnitId, ModRenaming)] -> BkpM a -> BkpM a+withBkpExeSession deps do_this = do+    withBkpSession (ComponentId (fsLit "main")) [] deps ExeSession do_this++getSource :: ComponentId -> BkpM (LHsUnit HsComponentId)+getSource cid = do+    bkp_env <- getBkpEnv+    case Map.lookup cid (bkp_table bkp_env) of+        Nothing -> pprPanic "missing needed dependency" (ppr cid)+        Just lunit -> return lunit++typecheckUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()+typecheckUnit cid insts = do+    lunit <- getSource cid+    buildUnit TcSession cid insts lunit++compileUnit :: ComponentId -> [(ModuleName, Module)] -> BkpM ()+compileUnit cid insts = do+    -- Let everyone know we're building this unit ID+    msgUnitId (newUnitId cid insts)+    lunit <- getSource cid+    buildUnit CompSession cid insts lunit++-- | Compute the dependencies with instantiations of a syntactic+-- HsUnit; e.g., wherever you see @dependency p[A=<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 (getPackageConfigMap dflags)) deps0++    mb_old_eps <- case session of+                    TcSession -> fmap Just getEpsGhc+                    _ -> return Nothing++    conf <- withBkpSession cid insts deps_w_rns session $ do++        dflags <- getDynFlags+        mod_graph <- hsunitModuleGraph dflags (unLoc lunit)+        -- pprTrace "mod_graph" (ppr mod_graph) $ return ()++        msg <- mkBackpackMsg+        ok <- load' LoadAllTargets (Just msg) mod_graph+        when (failed ok) (liftIO $ exitWith (ExitFailure 1))++        let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags+            export_mod ms = (ms_mod_name ms, ms_mod ms)+            -- Export everything!+            mods = [ export_mod ms | ms <- mgModSummaries mod_graph+                                   , ms_hsc_src ms == HsSrcFile ]++        -- Compile relevant only+        hsc_env <- getSession+        let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)+            linkables = map (expectJust "bkp link" . hm_linkable)+                      . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)+                      $ home_mod_infos+            getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)+            obj_files = concatMap getOfiles linkables++        let compat_fs = (case cid of ComponentId fs -> fs)+            compat_pn = PackageName compat_fs++        return InstalledPackageInfo {+            -- Stub data+            abiHash = "",+            sourcePackageId = SourcePackageId compat_fs,+            packageName = compat_pn,+            packageVersion = makeVersion [0],+            unitId = toInstalledUnitId (thisPackage dflags),+            sourceLibName = Nothing,+            componentId = cid,+            instantiatedWith = insts,+            -- Slight inefficiency here haha+            exposedModules = map (\(m,n) -> (m,Just n)) mods,+            hiddenModules = [], -- TODO: doc only+            depends = case session of+                        -- Technically, we should state that we depend+                        -- on all the indefinite libraries we used to+                        -- typecheck this.  However, this field isn't+                        -- really used for anything, so we leave it+                        -- blank for now.+                        TcSession -> []+                        _ -> map (toInstalledUnitId . unwireUnitId dflags)+                                $ deps ++ [ moduleUnitId mod+                                          | (_, mod) <- insts+                                          , not (isHoleModule mod) ],+            abiDepends = [],+            ldOptions = case session of+                            TcSession -> []+                            _ -> obj_files,+            importDirs = [ hi_dir ],+            exposed = False,+            indefinite = case session of+                            TcSession -> True+                            _ -> False,+            -- nope+            hsLibraries = [],+            extraLibraries = [],+            extraGHCiLibraries = [],+            libraryDynDirs = [],+            libraryDirs = [],+            frameworks = [],+            frameworkDirs = [],+            ccOptions = [],+            includes = [],+            includeDirs = [],+            haddockInterfaces = [],+            haddockHTMLs = [],+            trusted = False+            }+++    addPackage conf+    case mb_old_eps of+        Just old_eps -> updateEpsGhc_ (const old_eps)+        _ -> return ()++compileExe :: LHsUnit HsComponentId -> BkpM ()+compileExe lunit = do+    msgUnitId mainUnitId+    let deps_w_rns = hsunitDeps False (unLoc lunit)+        deps = map fst deps_w_rns+        -- no renaming necessary+    forM_ (zip [1..] deps) $ \(i, dep) ->+        compileInclude (length deps) (i, dep)+    withBkpExeSession deps_w_rns $ do+        dflags <- getDynFlags+        mod_graph <- hsunitModuleGraph dflags (unLoc lunit)+        msg <- mkBackpackMsg+        ok <- load' LoadAllTargets (Just msg) mod_graph+        when (failed ok) (liftIO $ exitWith (ExitFailure 1))++addPackage :: GhcMonad m => PackageConfig -> m ()+addPackage pkg = do+    dflags0 <- GHC.getSessionDynFlags+    case pkgDatabase dflags0 of+        Nothing -> panic "addPackage: called too early"+        Just pkgs -> do let dflags = dflags0 { pkgDatabase =+                            Just (pkgs ++ [("(in memory " ++ showSDoc dflags0 (ppr (unitId pkg)) ++ ")", [pkg])]) }+                        _ <- GHC.setSessionDynFlags dflags+                        -- By this time, the global ref has probably already+                        -- been forced, in which case doing this isn't actually+                        -- going to do you any good.+                        -- dflags <- GHC.getSessionDynFlags+                        -- liftIO $ setUnsafeGlobalDynFlags dflags+                        return ()++-- Precondition: UnitId is NOT InstalledUnitId+compileInclude :: Int -> (Int, UnitId) -> BkpM ()+compileInclude n (i, uid) = do+    hsc_env <- getSession+    let dflags = hsc_dflags hsc_env+    msgInclude (i, n) uid+    -- Check if we've compiled it already+    case lookupPackage dflags uid of+        Nothing -> do+            case splitUnitIdInsts uid of+                (_, Just indef) ->+                    innerBkpM $ compileUnit (indefUnitIdComponentId indef)+                                            (indefUnitIdInsts indef)+                _ -> return ()+        Just _ -> return ()++-- ----------------------------------------------------------------------------+-- Backpack monad++-- | Backpack monad is a 'GhcMonad' which also maintains a little extra state+-- beyond the 'Session', c.f. 'BkpEnv'.+type BkpM = IOEnv BkpEnv++-- | Backpack environment.  NB: this has a 'Session' and not an 'HscEnv',+-- because we are going to update the 'HscEnv' as we go.+data BkpEnv+    = BkpEnv {+        -- | The session+        bkp_session :: Session,+        -- | The filename of the bkp file we're compiling+        bkp_filename :: FilePath,+        -- | Table of source units which we know how to compile+        bkp_table :: Map ComponentId (LHsUnit HsComponentId),+        -- | When a package we are compiling includes another package+        -- which has not been compiled, we bump the level and compile+        -- that.+        bkp_level :: Int+    }++-- Blah, to get rid of the default instance for IOEnv+-- TODO: just make a proper new monad for BkpM, rather than use IOEnv+instance {-# OVERLAPPING #-} HasDynFlags BkpM where+    getDynFlags = fmap hsc_dflags getSession++instance GhcMonad BkpM where+    getSession = do+        Session s <- fmap bkp_session getEnv+        readMutVar s+    setSession hsc_env = do+        Session s <- fmap bkp_session getEnv+        writeMutVar s hsc_env++-- | Get the current 'BkpEnv'.+getBkpEnv :: BkpM BkpEnv+getBkpEnv = getEnv++-- | Get the nesting level, when recursively compiling modules.+getBkpLevel :: BkpM Int+getBkpLevel = bkp_level `fmap` getBkpEnv++-- | Apply a function on 'DynFlags' on an 'HscEnv'+overHscDynFlags :: (DynFlags -> DynFlags) -> HscEnv -> HscEnv+overHscDynFlags f hsc_env = hsc_env { hsc_dflags = f (hsc_dflags hsc_env) }++-- | Run a 'BkpM' computation, with the nesting level bumped one.+innerBkpM :: BkpM a -> BkpM a+innerBkpM do_this = do+    -- NB: withTempSession mutates, so we don't have to worry+    -- about bkp_session being stale.+    updEnv (\env -> env { bkp_level = bkp_level env + 1 }) do_this++-- | Update the EPS from a 'GhcMonad'. TODO move to appropriate library spot.+updateEpsGhc_ :: GhcMonad m => (ExternalPackageState -> ExternalPackageState) -> m ()+updateEpsGhc_ f = do+    hsc_env <- getSession+    liftIO $ atomicModifyIORef' (hsc_EPS hsc_env) (\x -> (f x, ()))++-- | Get the EPS from a 'GhcMonad'.+getEpsGhc :: GhcMonad m => m ExternalPackageState+getEpsGhc = do+    hsc_env <- getSession+    liftIO $ readIORef (hsc_EPS hsc_env)++-- | Run 'BkpM' in 'Ghc'.+initBkpM :: FilePath -> [LHsUnit HsComponentId] -> BkpM a -> Ghc a+initBkpM file bkp m = do+    reifyGhc $ \session -> do+    let env = BkpEnv {+                    bkp_session = session,+                    bkp_table = Map.fromList [(hsComponentId (unLoc (hsunitName (unLoc u))), u) | u <- bkp],+                    bkp_filename = file,+                    bkp_level = 0+                }+    runIOEnv env m++-- ----------------------------------------------------------------------------+-- Messaging++-- | Print a compilation progress message, but with indentation according+-- to @level@ (for nested compilation).+backpackProgressMsg :: Int -> DynFlags -> String -> IO ()+backpackProgressMsg level dflags msg =+    compilationProgressMsg dflags $ replicate (level * 2) ' ' ++ msg++-- | Creates a 'Messager' for Backpack compilation; this is basically+-- a carbon copy of 'batchMsg' but calling 'backpackProgressMsg', which+-- handles indentation.+mkBackpackMsg :: BkpM Messager+mkBackpackMsg = do+    level <- getBkpLevel+    return $ \hsc_env mod_index recomp mod_summary ->+      let dflags = hsc_dflags hsc_env+          showMsg msg reason =+            backpackProgressMsg level dflags $+                showModuleIndex mod_index +++                msg ++ showModMsg dflags (hscTarget dflags)+                                  (recompileRequired recomp) mod_summary+                    ++ reason+      in case recomp of+            MustCompile -> showMsg "Compiling " ""+            UpToDate+                | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping  " ""+                | otherwise -> return ()+            RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")++-- | 'PprStyle' for Backpack messages; here we usually want the module to+-- be qualified (so we can tell how it was instantiated.) But we try not+-- to qualify packages so we can use simple names for them.+backpackStyle :: DynFlags -> PprStyle+backpackStyle dflags =+    mkUserStyle dflags+        (QueryQualify neverQualifyNames+                      alwaysQualifyModules+                      neverQualifyPackages) AllTheWay++-- | Message when we initially process a Backpack unit.+msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()+msgTopPackage (i,n) (HsComponentId (PackageName fs_pn) _) = do+    dflags <- getDynFlags+    level <- getBkpLevel+    liftIO . backpackProgressMsg level dflags+        $ showModuleIndex (i, n) ++ "Processing " ++ unpackFS fs_pn++-- | Message when we instantiate a Backpack unit.+msgUnitId :: UnitId -> BkpM ()+msgUnitId pk = do+    dflags <- getDynFlags+    level <- getBkpLevel+    liftIO . backpackProgressMsg level dflags+        $ "Instantiating " ++ renderWithStyle dflags (ppr pk)+                                (backpackStyle dflags)++-- | Message when we include a Backpack unit.+msgInclude :: (Int,Int) -> UnitId -> BkpM ()+msgInclude (i,n) uid = do+    dflags <- getDynFlags+    level <- getBkpLevel+    liftIO . backpackProgressMsg level dflags+        $ showModuleIndex (i, n) ++ "Including " +++          renderWithStyle dflags (ppr uid) (backpackStyle dflags)++-- ----------------------------------------------------------------------------+-- Conversion from PackageName to HsComponentId++type PackageNameMap a = Map PackageName a++-- For now, something really simple, since we're not actually going+-- to use this for anything+unitDefines :: LHsUnit PackageName -> (PackageName, HsComponentId)+unitDefines (L _ HsUnit{ hsunitName = L _ pn@(PackageName fs) })+    = (pn, HsComponentId pn (ComponentId fs))++packageNameMap :: [LHsUnit PackageName] -> PackageNameMap HsComponentId+packageNameMap units = Map.fromList (map unitDefines units)++renameHsUnits :: DynFlags -> PackageNameMap HsComponentId -> [LHsUnit PackageName] -> [LHsUnit HsComponentId]+renameHsUnits dflags m units = map (fmap renameHsUnit) units+  where++    renamePackageName :: PackageName -> HsComponentId+    renamePackageName pn =+        case Map.lookup pn m of+            Nothing ->+                case lookupPackageName dflags pn of+                    Nothing -> error "no package name"+                    Just cid -> HsComponentId pn cid+            Just hscid -> hscid++    renameHsUnit :: HsUnit PackageName -> HsUnit HsComponentId+    renameHsUnit u =+        HsUnit {+            hsunitName = fmap renamePackageName (hsunitName u),+            hsunitBody = map (fmap renameHsUnitDecl) (hsunitBody u)+        }++    renameHsUnitDecl :: HsUnitDecl PackageName -> HsUnitDecl HsComponentId+    renameHsUnitDecl (DeclD a b c) = DeclD a b c+    renameHsUnitDecl (IncludeD idecl) =+        IncludeD IncludeDecl {+            idUnitId = fmap renameHsUnitId (idUnitId idecl),+            idModRenaming = idModRenaming idecl,+            idSignatureInclude = idSignatureInclude idecl+        }++    renameHsUnitId :: HsUnitId PackageName -> HsUnitId HsComponentId+    renameHsUnitId (HsUnitId ln subst)+        = HsUnitId (fmap renamePackageName ln) (map (fmap renameHsModuleSubst) subst)++    renameHsModuleSubst :: HsModuleSubst PackageName -> HsModuleSubst HsComponentId+    renameHsModuleSubst (lk, lm)+        = (lk, fmap renameHsModuleId lm)++    renameHsModuleId :: HsModuleId PackageName -> HsModuleId HsComponentId+    renameHsModuleId (HsModuleVar lm) = HsModuleVar lm+    renameHsModuleId (HsModuleId luid lm) = HsModuleId (fmap renameHsUnitId luid) lm++convertHsUnitId :: HsUnitId HsComponentId -> UnitId+convertHsUnitId (HsUnitId (L _ hscid) subst)+    = newUnitId (hsComponentId hscid) (map (convertHsModuleSubst . unLoc) subst)++convertHsModuleSubst :: HsModuleSubst HsComponentId -> (ModuleName, Module)+convertHsModuleSubst (L _ modname, L _ m) = (modname, convertHsModuleId m)++convertHsModuleId :: HsModuleId HsComponentId -> Module+convertHsModuleId (HsModuleVar (L _ modname)) = mkHoleModule modname+convertHsModuleId (HsModuleId (L _ hsuid) (L _ modname)) = mkModule (convertHsUnitId hsuid) modname++++{-+************************************************************************+*                                                                      *+                        Module graph construction+*                                                                      *+************************************************************************+-}++-- | This is our version of GhcMake.downsweep, but with a few modifications:+--+--  1. Every module is required to be mentioned, so we don't do any funny+--     business with targets or recursively grabbing dependencies.  (We+--     could support this in principle).+--  2. We support inline modules, whose summary we have to synthesize ourself.+--+-- We don't bother trying to support GhcMake for now, it's more trouble+-- than it's worth for inline modules.+hsunitModuleGraph :: DynFlags -> HsUnit HsComponentId -> BkpM ModuleGraph+hsunitModuleGraph dflags unit = do+    let decls = hsunitBody unit+        pn = hsPackageName (unLoc (hsunitName unit))++    --  1. Create a HsSrcFile/HsigFile summary for every+    --  explicitly mentioned module/signature.+    let get_decl (L _ (DeclD dt lmodname mb_hsmod)) = do+          let hsc_src = case dt of+                          ModuleD    -> HsSrcFile+                          SignatureD -> HsigFile+          Just `fmap` summariseDecl pn hsc_src lmodname mb_hsmod+        get_decl _ = return Nothing+    nodes <- catMaybes `fmap` mapM get_decl decls++    --  2. For each hole which does not already have an hsig file,+    --  create an "empty" hsig file to induce compilation for the+    --  requirement.+    let node_map = Map.fromList [ ((ms_mod_name n, ms_hsc_src n == HsigFile), n)+                                | n <- nodes ]+    req_nodes <- fmap catMaybes . forM (thisUnitIdInsts dflags) $ \(mod_name, _) ->+        let has_local = Map.member (mod_name, True) node_map+        in if has_local+            then return Nothing+            else fmap Just $ summariseRequirement pn mod_name++    -- 3. Return the kaboodle+    return $ mkModuleGraph $ nodes ++ req_nodes++summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary+summariseRequirement pn mod_name = do+    hsc_env <- getSession+    let dflags = hsc_dflags hsc_env++    let PackageName pn_fs = pn+    location <- liftIO $ mkHomeModLocation2 dflags mod_name+                 (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"++    env <- getBkpEnv+    time <- liftIO $ getModificationUTCTime (bkp_filename env)+    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)+    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)+    let loc = srcLocSpan (mkSrcLoc (mkFastString (bkp_filename env)) 1 1)++    mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location++    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name++    return ModSummary {+        ms_mod = mod,+        ms_hsc_src = HsigFile,+        ms_location = location,+        ms_hs_date = time,+        ms_obj_date = Nothing,+        ms_iface_date = hi_timestamp,+        ms_hie_date = hie_timestamp,+        ms_srcimps = [],+        ms_textual_imps = extra_sig_imports,+        ms_parsed_mod = Just (HsParsedModule {+                hpm_module = L loc (HsModule {+                        hsmodName = Just (L loc mod_name),+                        hsmodExports = Nothing,+                        hsmodImports = [],+                        hsmodDecls = [],+                        hsmodDeprecMessage = Nothing,+                        hsmodHaddockModHeader = Nothing+                    }),+                hpm_src_files = [],+                hpm_annotations = (Map.empty, Map.empty)+            }),+        ms_hspp_file = "", -- none, it came inline+        ms_hspp_opts = dflags,+        ms_hspp_buf = Nothing+        }++summariseDecl :: PackageName+              -> HscSource+              -> Located ModuleName+              -> Maybe (Located (HsModule GhcPs))+              -> BkpM ModSummary+summariseDecl pn hsc_src (L _ modname) (Just hsmod) = hsModuleToModSummary pn hsc_src modname hsmod+summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing+    = do hsc_env <- getSession+         let dflags = hsc_dflags hsc_env+         -- TODO: this looks for modules in the wrong place+         r <- liftIO $ summariseModule hsc_env+                         Map.empty -- GHC API recomp not supported+                         (hscSourceToIsBoot hsc_src)+                         lmodname+                         True -- Target lets you disallow, but not here+                         Nothing -- GHC API buffer support not supported+                         [] -- No exclusions+         case r of+            Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found"))+            Just (Left err) -> throwOneError err+            Just (Right summary) -> return summary++-- | Up until now, GHC has assumed a single compilation target per source file.+-- Backpack files with inline modules break this model, since a single file+-- may generate multiple output files.  How do we decide to name these files?+-- Should there only be one output file? This function our current heuristic,+-- which is we make a "fake" module and use that.+hsModuleToModSummary :: PackageName+                     -> HscSource+                     -> ModuleName+                     -> Located (HsModule GhcPs)+                     -> BkpM ModSummary+hsModuleToModSummary pn hsc_src modname+                     hsmod = do+    let imps = hsmodImports (unLoc hsmod)+        loc  = getLoc hsmod+    hsc_env <- getSession+    -- Sort of the same deal as in DriverPipeline's getLocation+    -- Use the PACKAGE NAME to find the location+    let PackageName unit_fs = pn+        dflags = hsc_dflags hsc_env+    -- Unfortunately, we have to define a "fake" location in+    -- order to appease the various code which uses the file+    -- name to figure out where to put, e.g. object files.+    -- To add insult to injury, we don't even actually use+    -- these filenames to figure out where the hi files go.+    -- A travesty!+    location0 <- liftIO $ mkHomeModLocation2 dflags modname+                             (unpackFS unit_fs </>+                              moduleNameSlashes modname)+                              (case hsc_src of+                                HsigFile -> "hsig"+                                HsBootFile -> "hs-boot"+                                HsSrcFile -> "hs")+    -- DANGEROUS: bootifying can POISON the module finder cache+    let location = case hsc_src of+                        HsBootFile -> addBootSuffixLocnOut location0+                        _ -> location0+    -- This duplicates a pile of logic in GhcMake+    env <- getBkpEnv+    time <- liftIO $ getModificationUTCTime (bkp_filename env)+    hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)+    hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)++    -- Also copied from 'getImports'+    let (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps++             -- GHC.Prim doesn't exist physically, so don't go looking for it.+        ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)+                               ord_idecls++        implicit_prelude = xopt LangExt.ImplicitPrelude dflags+        implicit_imports = mkPrelImports modname loc+                                         implicit_prelude imps+        convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)++    extra_sig_imports <- liftIO $ findExtraSigImports hsc_env hsc_src modname++    let normal_imports = map convImport (implicit_imports ++ ordinary_imps)+    required_by_imports <- liftIO $ implicitRequirements hsc_env normal_imports++    -- So that Finder can find it, even though it doesn't exist...+    this_mod <- liftIO $ addHomeModuleToFinder hsc_env modname location+    return ModSummary {+            ms_mod = this_mod,+            ms_hsc_src = hsc_src,+            ms_location = location,+            ms_hspp_file = (case hiDir dflags of+                            Nothing -> ""+                            Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi",+            ms_hspp_opts = dflags,+            ms_hspp_buf = Nothing,+            ms_srcimps = map convImport src_idecls,+            ms_textual_imps = normal_imports+                           -- We have to do something special here:+                           -- due to merging, requirements may end up with+                           -- extra imports+                           ++ extra_sig_imports+                           ++ required_by_imports,+            -- This is our hack to get the parse tree to the right spot+            ms_parsed_mod = Just (HsParsedModule {+                    hpm_module = hsmod,+                    hpm_src_files = [], -- TODO if we preprocessed it+                    hpm_annotations = (Map.empty, Map.empty) -- BOGUS+                }),+            ms_hs_date = time,+            ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS+            ms_iface_date = hi_timestamp,+            ms_hie_date = hie_timestamp+        }++-- | Create a new, externally provided hashed unit id from+-- a hash.+newInstalledUnitId :: ComponentId -> Maybe FastString -> InstalledUnitId+newInstalledUnitId (ComponentId cid_fs) (Just fs)+    = InstalledUnitId (cid_fs `appendFS` mkFastString "+" `appendFS` fs)+newInstalledUnitId (ComponentId cid_fs) Nothing+    = InstalledUnitId cid_fs
+ compiler/backpack/NameShape.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE CPP #-}++module NameShape(+    NameShape(..),+    emptyNameShape,+    mkNameShape,+    extendNameShape,+    nameShapeExports,+    substNameShape,+    maybeSubstNameShape,+    ) where++#include "HsVersions.h"++import GhcPrelude++import Outputable+import HscTypes+import Module+import UniqFM+import Avail+import FieldLabel++import Name+import NameEnv+import TcRnMonad+import Util+import IfaceEnv++import Control.Monad++-- Note [NameShape]+-- ~~~~~~~~~~~~~~~~+-- When we write a declaration in a signature, e.g., data T, we+-- ascribe to it a *name variable*, e.g., {m.T}.  This+-- name variable may be substituted with an actual original+-- name when the signature is implemented (or even if we+-- merge the signature with one which reexports this entity+-- from another module).++-- When we instantiate a signature m with a module M,+-- we also need to substitute over names.  To do so, we must+-- compute the *name substitution* induced by the *exports*+-- of the module in question.  A NameShape represents+-- such a name substitution for a single module instantiation.+-- The "shape" in the name comes from the fact that the computation+-- of a name substitution is essentially the *shaping pass* from+-- Backpack'14, but in a far more restricted form.++-- The name substitution for an export list is easy to explain.  If we are+-- filling the module variable <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/RnModIface.hs view
@@ -0,0 +1,743 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}++-- | This module implements interface renaming, which is+-- used to rewrite interface files on the fly when we+-- are doing indefinite typechecking and need instantiations+-- of modules which do not necessarily exist yet.++module RnModIface(+    rnModIface,+    rnModExports,+    tcRnModIface,+    tcRnModExports,+    ) where++#include "HsVersions.h"++import GhcPrelude++import SrcLoc+import Outputable+import HscTypes+import Module+import UniqFM+import Avail+import IfaceSyn+import FieldLabel+import Var+import ErrUtils++import Name+import TcRnMonad+import Util+import Fingerprint+import BasicTypes++-- a bit vexing+import {-# SOURCE #-} LoadIface+import DynFlags++import qualified Data.Traversable as T++import Bag+import Data.IORef+import NameShape+import IfaceEnv++tcRnMsgMaybe :: IO (Either ErrorMessages a) -> TcM a+tcRnMsgMaybe do_this = do+    r <- liftIO $ do_this+    case r of+        Left errs -> do+            addMessages (emptyBag, errs)+            failM+        Right x -> return x++tcRnModIface :: [(ModuleName, Module)] -> Maybe NameShape -> ModIface -> TcM ModIface+tcRnModIface x y z = do+    hsc_env <- getTopEnv+    tcRnMsgMaybe $ rnModIface hsc_env x y z++tcRnModExports :: [(ModuleName, Module)] -> ModIface -> TcM [AvailInfo]+tcRnModExports x y = do+    hsc_env <- getTopEnv+    tcRnMsgMaybe $ rnModExports hsc_env x y++failWithRn :: SDoc -> ShIfM a+failWithRn doc = do+    errs_var <- fmap sh_if_errs getGblEnv+    dflags <- getDynFlags+    errs <- readTcRef errs_var+    -- TODO: maybe associate this with a source location?+    writeTcRef errs_var (errs `snocBag` mkPlainErrMsg dflags noSrcSpan doc)+    failM++-- | What we have is a generalized ModIface, which corresponds to+-- a module that looks like p[A=<A>]:B.  We need a *specific* ModIface, e.g.+-- p[A=q():A]:B (or maybe even p[A=<B>]:B) which we load+-- up (either to merge it, or to just use during typechecking).+--+-- Suppose we have:+--+--  p[A=<A>]:M  ==>  p[A=q():A]:M+--+-- Substitute all occurrences of <A> with q():A (renameHoleModule).+-- Then, for any Name of form {A.T}, replace the Name with+-- the Name according to the exports of the implementing module.+-- This works even for p[A=<B>]:M, since we just read in the+-- exports of B.hi, which is assumed to be ready now.+--+-- This function takes an optional 'NameShape', which can be used+-- to further refine the identities in this interface: suppose+-- we read a declaration for {H.T} but we actually know that this+-- should be Foo.T; then we'll also rename this (this is used+-- when loading an interface to merge it into a requirement.)+rnModIface :: HscEnv -> [(ModuleName, Module)] -> Maybe NameShape+           -> ModIface -> IO (Either ErrorMessages ModIface)+rnModIface hsc_env insts nsubst iface = do+    initRnIface hsc_env iface insts nsubst $ do+        mod <- rnModule (mi_module iface)+        sig_of <- case mi_sig_of iface of+                    Nothing -> return Nothing+                    Just x  -> fmap Just (rnModule x)+        exports <- mapM rnAvailInfo (mi_exports iface)+        decls <- mapM rnIfaceDecl' (mi_decls iface)+        insts <- mapM rnIfaceClsInst (mi_insts iface)+        fams <- mapM rnIfaceFamInst (mi_fam_insts iface)+        deps <- rnDependencies (mi_deps iface)+        -- TODO:+        -- mi_rules+        return iface { mi_module = mod+                     , mi_sig_of = sig_of+                     , mi_insts = insts+                     , mi_fam_insts = fams+                     , mi_exports = exports+                     , mi_decls = decls+                     , mi_deps = deps }++-- | Rename just the exports of a 'ModIface'.  Useful when we're doing+-- shaping prior to signature merging.+rnModExports :: HscEnv -> [(ModuleName, Module)] -> ModIface -> IO (Either ErrorMessages [AvailInfo])+rnModExports hsc_env insts iface+    = initRnIface hsc_env iface insts Nothing+    $ mapM rnAvailInfo (mi_exports iface)++rnDependencies :: Rename Dependencies+rnDependencies deps = do+    orphs  <- rnDepModules dep_orphs deps+    finsts <- rnDepModules dep_finsts deps+    return deps { dep_orphs = orphs, dep_finsts = finsts }++rnDepModules :: (Dependencies -> [Module]) -> Dependencies -> ShIfM [Module]+rnDepModules sel deps = do+    hsc_env <- getTopEnv+    hmap <- getHoleSubst+    -- NB: It's not necessary to test if we're doing signature renaming,+    -- because ModIface will never contain module reference for itself+    -- in these dependencies.+    fmap (nubSort . concat) . T.forM (sel deps) $ \mod -> do+        dflags <- getDynFlags+        -- For holes, its necessary to "see through" the instantiation+        -- of the hole to get accurate family instance dependencies.+        -- For example, if B imports <A>, and <A> is instantiated with+        -- F, we must grab and include all of the dep_finsts from+        -- F to have an accurate transitive dep_finsts list.+        --+        -- However, we MUST NOT do this for regular modules.+        -- First, for efficiency reasons, doing this+        -- bloats the the dep_finsts list, because we *already* had+        -- those modules in the list (it wasn't a hole module, after+        -- all). But there's a second, more important correctness+        -- consideration: we perform module renaming when running+        -- --abi-hash.  In this case, GHC's contract to the user is that+        -- it will NOT go and read out interfaces of any dependencies+        -- (https://github.com/haskell/cabal/issues/3633); the point of+        -- --abi-hash is just to get a hash of the on-disk interfaces+        -- for this *specific* package.  If we go off and tug on the+        -- interface for /everything/ in dep_finsts, we're gonna have a+        -- bad time.  (It's safe to do do this for hole modules, though,+        -- because the hmap for --abi-hash is always trivial, so the+        -- interface we request is local.  Though, maybe we ought+        -- not to do it in this case either...)+        --+        -- This mistake was bug #15594.+        let mod' = renameHoleModule dflags hmap mod+        if isHoleModule mod+          then do iface <- liftIO . initIfaceCheck (text "rnDepModule") hsc_env+                                  $ loadSysInterface (text "rnDepModule") mod'+                  return (mod' : sel (mi_deps iface))+          else return [mod']++{-+************************************************************************+*                                                                      *+                        ModIface substitution+*                                                                      *+************************************************************************+-}++-- | Run a computation in the 'ShIfM' monad.+initRnIface :: HscEnv -> ModIface -> [(ModuleName, Module)] -> Maybe NameShape+            -> ShIfM a -> IO (Either ErrorMessages a)+initRnIface hsc_env iface insts nsubst do_this = do+    errs_var <- newIORef emptyBag+    let dflags = hsc_dflags hsc_env+        hsubst = listToUFM insts+        rn_mod = renameHoleModule dflags hsubst+        env = ShIfEnv {+            sh_if_module = rn_mod (mi_module iface),+            sh_if_semantic_module = rn_mod (mi_semantic_module iface),+            sh_if_hole_subst = listToUFM insts,+            sh_if_shape = nsubst,+            sh_if_errs = errs_var+        }+    -- Modeled off of 'initTc'+    res <- initTcRnIf 'c' hsc_env env () $ tryM do_this+    msgs <- readIORef errs_var+    case res of+        Left _                          -> return (Left msgs)+        Right r | not (isEmptyBag msgs) -> return (Left msgs)+                | otherwise             -> return (Right r)++-- | Environment for 'ShIfM' monads.+data ShIfEnv = ShIfEnv {+        -- What we are renaming the ModIface to.  It assumed that+        -- the original mi_module of the ModIface is+        -- @generalizeModule (mi_module iface)@.+        sh_if_module :: Module,+        -- The semantic module that we are renaming to+        sh_if_semantic_module :: Module,+        -- Cached hole substitution, e.g.+        -- @sh_if_hole_subst == listToUFM . unitIdInsts . moduleUnitId . sh_if_module@+        sh_if_hole_subst :: ShHoleSubst,+        -- An optional name substitution to be applied when renaming+        -- the names in the interface.  If this is 'Nothing', then+        -- we just load the target interface and look at the export+        -- list to determine the renaming.+        sh_if_shape :: Maybe NameShape,+        -- Mutable reference to keep track of errors (similar to 'tcl_errs')+        sh_if_errs :: IORef ErrorMessages+    }++getHoleSubst :: ShIfM ShHoleSubst+getHoleSubst = fmap sh_if_hole_subst getGblEnv++type ShIfM = TcRnIf ShIfEnv ()+type Rename a = a -> ShIfM a+++rnModule :: Rename Module+rnModule mod = do+    hmap <- getHoleSubst+    dflags <- getDynFlags+    return (renameHoleModule dflags hmap mod)++rnAvailInfo :: Rename AvailInfo+rnAvailInfo (Avail n) = Avail <$> rnIfaceGlobal n+rnAvailInfo (AvailTC n ns fs) = do+    -- Why don't we rnIfaceGlobal the availName itself?  It may not+    -- actually be exported by the module it putatively is from, in+    -- which case we won't be able to tell what the name actually+    -- is.  But for the availNames they MUST be exported, so they+    -- will rename fine.+    ns' <- mapM rnIfaceGlobal ns+    fs' <- mapM rnFieldLabel fs+    case ns' ++ map flSelector fs' of+        [] -> panic "rnAvailInfoEmpty AvailInfo"+        (rep:rest) -> ASSERT2( all ((== nameModule rep) . nameModule) rest, ppr rep $$ hcat (map ppr rest) ) do+                         n' <- setNameModule (Just (nameModule rep)) n+                         return (AvailTC n' ns' fs')++rnFieldLabel :: Rename FieldLabel+rnFieldLabel (FieldLabel l b sel) = do+    sel' <- rnIfaceGlobal sel+    return (FieldLabel l b sel')+++++-- | The key function.  This gets called on every Name embedded+-- inside a ModIface.  Our job is to take a Name from some+-- generalized unit ID p[A=<A>, B=<B>], and change+-- it to the correct name for a (partially) instantiated unit+-- ID, e.g. p[A=q[]:A, B=<B>].+--+-- There are two important things to do:+--+-- If a hole is substituted with a real module implementation,+-- we need to look at that actual implementation to determine what+-- the true identity of this name should be.  We'll do this by+-- loading that module's interface and looking at the mi_exports.+--+-- However, there is one special exception: when we are loading+-- the interface of a requirement.  In this case, we may not have+-- the "implementing" interface, because we are reading this+-- interface precisely to "merge it in".+--+--     External case:+--         p[A=<B>]:A (and thisUnitId is something else)+--     We are loading this in order to determine B.hi!  So+--     don't load B.hi to find the exports.+--+--     Local case:+--         p[A=<A>]:A (and thisUnitId is p[A=<A>])+--     This should not happen, because the rename is not necessary+--     in this case, but if it does we shouldn't load A.hi!+--+-- Compare me with 'tcIfaceGlobal'!++-- In effect, this function needs compute the name substitution on the+-- fly.  What it has is the name that we would like to substitute.+-- If the name is not a hole name {M.x} (e.g. isHoleModule) then+-- no renaming can take place (although the inner hole structure must+-- be updated to account for the hole module renaming.)+rnIfaceGlobal :: Name -> ShIfM Name+rnIfaceGlobal n = do+    hsc_env <- getTopEnv+    let dflags = hsc_dflags hsc_env+    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv+    mb_nsubst <- fmap sh_if_shape getGblEnv+    hmap <- getHoleSubst+    let m = nameModule n+        m' = renameHoleModule dflags hmap m+    case () of+       -- Did we encounter {A.T} while renaming p[A=<B>]:A? If so,+       -- do NOT assume B.hi is available.+       -- In this case, rename {A.T} to {B.T} but don't look up exports.+     _ | m' == iface_semantic_mod+       , isHoleModule m'+      -- NB: this could be Nothing for computeExports, we have+      -- nothing to say.+      -> do n' <- setNameModule (Just m') n+            case mb_nsubst of+                Nothing -> return n'+                Just nsubst ->+                    case maybeSubstNameShape nsubst n' of+                        -- TODO: would love to have context+                        -- TODO: This will give an unpleasant message if n'+                        -- is a constructor; then we'll suggest adding T+                        -- but it won't work.+                        Nothing -> failWithRn $ vcat [+                            text "The identifier" <+> ppr (occName n') <+>+                                text "does not exist in the local signature.",+                            parens (text "Try adding it to the export list of the hsig file.")+                            ]+                        Just n'' -> return n''+       -- Fastpath: we are renaming p[H=<H>]:A.T, in which case the+       -- export list is irrelevant.+       | not (isHoleModule m)+      -> setNameModule (Just m') n+       -- The substitution was from <A> to p[]:A.+       -- But this does not mean {A.T} goes to p[]:A.T:+       -- p[]:A may reexport T from somewhere else.  Do the name+       -- substitution.  Furthermore, we need+       -- to make sure we pick the accurate name NOW,+       -- or we might accidentally reject a merge.+       | otherwise+      -> do -- Make sure we look up the local interface if substitution+            -- went from <A> to <B>.+            let m'' = if isHoleModule m'+                        -- Pull out the local guy!!+                        then mkModule (thisPackage dflags) (moduleName m')+                        else m'+            iface <- liftIO . initIfaceCheck (text "rnIfaceGlobal") hsc_env+                            $ loadSysInterface (text "rnIfaceGlobal") m''+            let nsubst = mkNameShape (moduleName m) (mi_exports iface)+            case maybeSubstNameShape nsubst n of+                Nothing -> failWithRn $ vcat [+                    text "The identifier" <+> ppr (occName n) <+>+                        -- NB: report m' because it's more user-friendly+                        text "does not exist in the signature for" <+> ppr m',+                    parens (text "Try adding it to the export list in that hsig file.")+                    ]+                Just n' -> return n'++-- | Rename an implicit name, e.g., a DFun or coercion axiom.+-- Here is where we ensure that DFuns have the correct module as described in+-- Note [rnIfaceNeverExported].+rnIfaceNeverExported :: Name -> ShIfM Name+rnIfaceNeverExported name = do+    hmap <- getHoleSubst+    dflags <- getDynFlags+    iface_semantic_mod <- fmap sh_if_semantic_module getGblEnv+    let m = renameHoleModule dflags hmap $ nameModule name+    -- Doublecheck that this DFun/coercion axiom was, indeed, locally defined.+    MASSERT2( iface_semantic_mod == m, ppr iface_semantic_mod <+> ppr m )+    setNameModule (Just m) name++-- Note [rnIfaceNeverExported]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- For the high-level overview, see+-- Note [Handling never-exported TyThings under Backpack]+--+-- When we see a reference to an entity that was defined in a signature,+-- 'rnIfaceGlobal' relies on the identifier in question being part of the+-- exports of the implementing 'ModIface', so that we can use the exports to+-- decide how to rename the identifier.  Unfortunately, references to 'DFun's+-- and 'CoAxiom's will run into trouble under this strategy, because they are+-- never exported.+--+-- Let us consider first what should happen in the absence of promotion.  In+-- this setting, a reference to a 'DFun' or a 'CoAxiom' can only occur inside+-- the signature *that is defining it* (as there are no Core terms in+-- typechecked-only interface files, there's no way for a reference to occur+-- besides from the defining 'ClsInst' or closed type family).  Thus,+-- it doesn't really matter what names we give the DFun/CoAxiom, as long+-- as it's consistent between the declaration site and the use site.+--+-- We have to make sure that these bogus names don't get propagated,+-- but it is fine: see Note [Signature merging DFuns] for the fixups+-- to the names we do before writing out the merged interface.+-- (It's even easier for instantiation, since the DFuns all get+-- dropped entirely; the instances are reexported implicitly.)+--+-- Unfortunately, this strategy is not enough in the presence of promotion+-- (see bug #13149), where modules which import the signature may make+-- reference to their coercions.  It's not altogether clear how to+-- fix this case, but it is definitely a bug!++-- PILES AND PILES OF BOILERPLATE++-- | Rename an 'IfaceClsInst', with special handling for an associated+-- dictionary function.+rnIfaceClsInst :: Rename IfaceClsInst+rnIfaceClsInst cls_inst = do+    n <- rnIfaceGlobal (ifInstCls cls_inst)+    tys <- mapM rnMaybeIfaceTyCon (ifInstTys cls_inst)++    dfun <- rnIfaceNeverExported (ifDFun cls_inst)+    return cls_inst { ifInstCls = n+                    , ifInstTys = tys+                    , ifDFun = dfun+                    }++rnMaybeIfaceTyCon :: Rename (Maybe IfaceTyCon)+rnMaybeIfaceTyCon Nothing = return Nothing+rnMaybeIfaceTyCon (Just tc) = Just <$> rnIfaceTyCon tc++rnIfaceFamInst :: Rename IfaceFamInst+rnIfaceFamInst d = do+    fam <- rnIfaceGlobal (ifFamInstFam d)+    tys <- mapM rnMaybeIfaceTyCon (ifFamInstTys d)+    axiom <- rnIfaceGlobal (ifFamInstAxiom d)+    return d { ifFamInstFam = fam, ifFamInstTys = tys, ifFamInstAxiom = axiom }++rnIfaceDecl' :: Rename (Fingerprint, IfaceDecl)+rnIfaceDecl' (fp, decl) = (,) fp <$> rnIfaceDecl decl++rnIfaceDecl :: Rename IfaceDecl+rnIfaceDecl d@IfaceId{} = do+            name <- case ifIdDetails d of+                      IfDFunId -> rnIfaceNeverExported (ifName d)+                      _ | isDefaultMethodOcc (occName (ifName d))+                        -> rnIfaceNeverExported (ifName d)+                      -- Typeable bindings. See Note [Grand plan for Typeable].+                      _ | isTypeableBindOcc (occName (ifName d))+                        -> rnIfaceNeverExported (ifName d)+                        | otherwise -> rnIfaceGlobal (ifName d)+            ty <- rnIfaceType (ifType d)+            details <- rnIfaceIdDetails (ifIdDetails d)+            info <- rnIfaceIdInfo (ifIdInfo d)+            return d { ifName = name+                     , ifType = ty+                     , ifIdDetails = details+                     , ifIdInfo = info+                     }+rnIfaceDecl d@IfaceData{} = do+            name <- rnIfaceGlobal (ifName d)+            binders <- mapM rnIfaceTyConBinder (ifBinders d)+            ctxt <- mapM rnIfaceType (ifCtxt d)+            cons <- rnIfaceConDecls (ifCons d)+            res_kind <- rnIfaceType (ifResKind d)+            parent <- rnIfaceTyConParent (ifParent d)+            return d { ifName = name+                     , ifBinders = binders+                     , ifCtxt = ctxt+                     , ifCons = cons+                     , ifResKind = res_kind+                     , ifParent = parent+                     }+rnIfaceDecl d@IfaceSynonym{} = do+            name <- rnIfaceGlobal (ifName d)+            binders <- mapM rnIfaceTyConBinder (ifBinders d)+            syn_kind <- rnIfaceType (ifResKind d)+            syn_rhs <- rnIfaceType (ifSynRhs d)+            return d { ifName = name+                     , ifBinders = binders+                     , ifResKind = syn_kind+                     , ifSynRhs = syn_rhs+                     }+rnIfaceDecl d@IfaceFamily{} = do+            name <- rnIfaceGlobal (ifName d)+            binders <- mapM rnIfaceTyConBinder (ifBinders d)+            fam_kind <- rnIfaceType (ifResKind d)+            fam_flav <- rnIfaceFamTyConFlav (ifFamFlav d)+            return d { ifName = name+                     , ifBinders = binders+                     , ifResKind = fam_kind+                     , ifFamFlav = fam_flav+                     }+rnIfaceDecl d@IfaceClass{} = do+            name <- rnIfaceGlobal (ifName d)+            binders <- mapM rnIfaceTyConBinder (ifBinders d)+            body <- rnIfaceClassBody (ifBody d)+            return d { ifName    = name+                     , ifBinders = binders+                     , ifBody    = body+                     }+rnIfaceDecl d@IfaceAxiom{} = do+            name <- rnIfaceNeverExported (ifName d)+            tycon <- rnIfaceTyCon (ifTyCon d)+            ax_branches <- mapM rnIfaceAxBranch (ifAxBranches d)+            return d { ifName = name+                     , ifTyCon = tycon+                     , ifAxBranches = ax_branches+                     }+rnIfaceDecl d@IfacePatSyn{} =  do+            name <- rnIfaceGlobal (ifName d)+            let rnPat (n, b) = (,) <$> rnIfaceGlobal n <*> pure b+            pat_matcher <- rnPat (ifPatMatcher d)+            pat_builder <- T.traverse rnPat (ifPatBuilder d)+            pat_univ_bndrs <- mapM rnIfaceForAllBndr (ifPatUnivBndrs d)+            pat_ex_bndrs <- mapM rnIfaceForAllBndr (ifPatExBndrs d)+            pat_prov_ctxt <- mapM rnIfaceType (ifPatProvCtxt d)+            pat_req_ctxt <- mapM rnIfaceType (ifPatReqCtxt d)+            pat_args <- mapM rnIfaceType (ifPatArgs d)+            pat_ty <- rnIfaceType (ifPatTy d)+            return d { ifName = name+                     , ifPatMatcher = pat_matcher+                     , ifPatBuilder = pat_builder+                     , ifPatUnivBndrs = pat_univ_bndrs+                     , ifPatExBndrs = pat_ex_bndrs+                     , ifPatProvCtxt = pat_prov_ctxt+                     , ifPatReqCtxt = pat_req_ctxt+                     , ifPatArgs = pat_args+                     , ifPatTy = pat_ty+                     }++rnIfaceClassBody :: Rename IfaceClassBody+rnIfaceClassBody IfAbstractClass = return IfAbstractClass+rnIfaceClassBody d@IfConcreteClass{} = do+    ctxt <- mapM rnIfaceType (ifClassCtxt d)+    ats <- mapM rnIfaceAT (ifATs d)+    sigs <- mapM rnIfaceClassOp (ifSigs d)+    return d { ifClassCtxt = ctxt, ifATs = ats, ifSigs = sigs }++rnIfaceFamTyConFlav :: Rename IfaceFamTyConFlav+rnIfaceFamTyConFlav (IfaceClosedSynFamilyTyCon (Just (n, axs)))+    = IfaceClosedSynFamilyTyCon . Just <$> ((,) <$> rnIfaceNeverExported n+                                                <*> mapM rnIfaceAxBranch axs)+rnIfaceFamTyConFlav flav = pure flav++rnIfaceAT :: Rename IfaceAT+rnIfaceAT (IfaceAT decl mb_ty)+    = IfaceAT <$> rnIfaceDecl decl <*> T.traverse rnIfaceType mb_ty++rnIfaceTyConParent :: Rename IfaceTyConParent+rnIfaceTyConParent (IfDataInstance n tc args)+    = IfDataInstance <$> rnIfaceGlobal n+                     <*> rnIfaceTyCon tc+                     <*> rnIfaceAppArgs args+rnIfaceTyConParent IfNoParent = pure IfNoParent++rnIfaceConDecls :: Rename IfaceConDecls+rnIfaceConDecls (IfDataTyCon ds)+    = IfDataTyCon <$> mapM rnIfaceConDecl ds+rnIfaceConDecls (IfNewTyCon d) = IfNewTyCon <$> rnIfaceConDecl d+rnIfaceConDecls IfAbstractTyCon = pure IfAbstractTyCon++rnIfaceConDecl :: Rename IfaceConDecl+rnIfaceConDecl d = do+    con_name <- rnIfaceGlobal (ifConName d)+    con_ex_tvs <- mapM rnIfaceBndr (ifConExTCvs d)+    con_user_tvbs <- mapM rnIfaceForAllBndr (ifConUserTvBinders d)+    let rnIfConEqSpec (n,t) = (,) n <$> rnIfaceType t+    con_eq_spec <- mapM rnIfConEqSpec (ifConEqSpec d)+    con_ctxt <- mapM rnIfaceType (ifConCtxt d)+    con_arg_tys <- mapM rnIfaceType (ifConArgTys d)+    con_fields <- mapM rnFieldLabel (ifConFields d)+    let rnIfaceBang (IfUnpackCo co) = IfUnpackCo <$> rnIfaceCo co+        rnIfaceBang bang = pure bang+    con_stricts <- mapM rnIfaceBang (ifConStricts d)+    return d { ifConName = con_name+             , ifConExTCvs = con_ex_tvs+             , ifConUserTvBinders = con_user_tvbs+             , ifConEqSpec = con_eq_spec+             , ifConCtxt = con_ctxt+             , ifConArgTys = con_arg_tys+             , ifConFields = con_fields+             , ifConStricts = con_stricts+             }++rnIfaceClassOp :: Rename IfaceClassOp+rnIfaceClassOp (IfaceClassOp n ty dm) =+    IfaceClassOp <$> rnIfaceGlobal n+                 <*> rnIfaceType ty+                 <*> rnMaybeDefMethSpec dm++rnMaybeDefMethSpec :: Rename (Maybe (DefMethSpec IfaceType))+rnMaybeDefMethSpec (Just (GenericDM ty)) = Just . GenericDM <$> rnIfaceType ty+rnMaybeDefMethSpec mb = return mb++rnIfaceAxBranch :: Rename IfaceAxBranch+rnIfaceAxBranch d = do+    ty_vars <- mapM rnIfaceTvBndr (ifaxbTyVars d)+    lhs <- rnIfaceAppArgs (ifaxbLHS d)+    rhs <- rnIfaceType (ifaxbRHS d)+    return d { ifaxbTyVars = ty_vars+             , ifaxbLHS = lhs+             , ifaxbRHS = rhs }++rnIfaceIdInfo :: Rename IfaceIdInfo+rnIfaceIdInfo NoInfo = pure NoInfo+rnIfaceIdInfo (HasInfo is) = HasInfo <$> mapM rnIfaceInfoItem is++rnIfaceInfoItem :: Rename IfaceInfoItem+rnIfaceInfoItem (HsUnfold lb if_unf)+    = HsUnfold lb <$> rnIfaceUnfolding if_unf+rnIfaceInfoItem i+    = pure i++rnIfaceUnfolding :: Rename IfaceUnfolding+rnIfaceUnfolding (IfCoreUnfold stable if_expr)+    = IfCoreUnfold stable <$> rnIfaceExpr if_expr+rnIfaceUnfolding (IfCompulsory if_expr)+    = IfCompulsory <$> rnIfaceExpr if_expr+rnIfaceUnfolding (IfInlineRule arity unsat_ok boring_ok if_expr)+    = IfInlineRule arity unsat_ok boring_ok <$> rnIfaceExpr if_expr+rnIfaceUnfolding (IfDFunUnfold bs ops)+    = IfDFunUnfold <$> rnIfaceBndrs bs <*> mapM rnIfaceExpr ops++rnIfaceExpr :: Rename IfaceExpr+rnIfaceExpr (IfaceLcl name) = pure (IfaceLcl name)+rnIfaceExpr (IfaceExt gbl) = IfaceExt <$> rnIfaceGlobal gbl+rnIfaceExpr (IfaceType ty) = IfaceType <$> rnIfaceType ty+rnIfaceExpr (IfaceCo co) = IfaceCo <$> rnIfaceCo co+rnIfaceExpr (IfaceTuple sort args) = IfaceTuple sort <$> rnIfaceExprs args+rnIfaceExpr (IfaceLam lam_bndr expr)+    = IfaceLam <$> rnIfaceLamBndr lam_bndr <*> rnIfaceExpr expr+rnIfaceExpr (IfaceApp fun arg)+    = IfaceApp <$> rnIfaceExpr fun <*> rnIfaceExpr arg+rnIfaceExpr (IfaceCase scrut case_bndr alts)+    = IfaceCase <$> rnIfaceExpr scrut+                <*> pure case_bndr+                <*> mapM rnIfaceAlt alts+rnIfaceExpr (IfaceECase scrut ty)+    = IfaceECase <$> rnIfaceExpr scrut <*> rnIfaceType ty+rnIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)+    = IfaceLet <$> (IfaceNonRec <$> rnIfaceLetBndr bndr <*> rnIfaceExpr rhs)+               <*> rnIfaceExpr body+rnIfaceExpr (IfaceLet (IfaceRec pairs) body)+    = IfaceLet <$> (IfaceRec <$> mapM (\(bndr, rhs) ->+                                        (,) <$> rnIfaceLetBndr bndr+                                            <*> rnIfaceExpr rhs) pairs)+               <*> rnIfaceExpr body+rnIfaceExpr (IfaceCast expr co)+    = IfaceCast <$> rnIfaceExpr expr <*> rnIfaceCo co+rnIfaceExpr (IfaceLit lit) = pure (IfaceLit lit)+rnIfaceExpr (IfaceFCall cc ty) = IfaceFCall cc <$> rnIfaceType ty+rnIfaceExpr (IfaceTick tickish expr) = IfaceTick tickish <$> rnIfaceExpr expr++rnIfaceBndrs :: Rename [IfaceBndr]+rnIfaceBndrs = mapM rnIfaceBndr++rnIfaceBndr :: Rename IfaceBndr+rnIfaceBndr (IfaceIdBndr (fs, ty)) = IfaceIdBndr <$> ((,) fs <$> rnIfaceType ty)+rnIfaceBndr (IfaceTvBndr tv_bndr) = IfaceTvBndr <$> rnIfaceTvBndr tv_bndr++rnIfaceTvBndr :: Rename IfaceTvBndr+rnIfaceTvBndr (fs, kind) = (,) fs <$> rnIfaceType kind++rnIfaceTyConBinder :: Rename IfaceTyConBinder+rnIfaceTyConBinder (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis++rnIfaceAlt :: Rename IfaceAlt+rnIfaceAlt (conalt, names, rhs)+     = (,,) <$> rnIfaceConAlt conalt <*> pure names <*> rnIfaceExpr rhs++rnIfaceConAlt :: Rename IfaceConAlt+rnIfaceConAlt (IfaceDataAlt data_occ) = IfaceDataAlt <$> rnIfaceGlobal data_occ+rnIfaceConAlt alt = pure alt++rnIfaceLetBndr :: Rename IfaceLetBndr+rnIfaceLetBndr (IfLetBndr fs ty info jpi)+    = IfLetBndr fs <$> rnIfaceType ty <*> rnIfaceIdInfo info <*> pure jpi++rnIfaceLamBndr :: Rename IfaceLamBndr+rnIfaceLamBndr (bndr, oneshot) = (,) <$> rnIfaceBndr bndr <*> pure oneshot++rnIfaceMCo :: Rename IfaceMCoercion+rnIfaceMCo IfaceMRefl    = pure IfaceMRefl+rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co++rnIfaceCo :: Rename IfaceCoercion+rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty+rnIfaceCo (IfaceGReflCo role ty mco)+  = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco+rnIfaceCo (IfaceFunCo role co1 co2)+    = IfaceFunCo role <$> rnIfaceCo co1 <*> rnIfaceCo co2+rnIfaceCo (IfaceTyConAppCo role tc cos)+    = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos+rnIfaceCo (IfaceAppCo co1 co2)+    = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2+rnIfaceCo (IfaceForAllCo bndr co1 co2)+    = IfaceForAllCo <$> rnIfaceBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2+rnIfaceCo (IfaceFreeCoVar c) = pure (IfaceFreeCoVar c)+rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl+rnIfaceCo (IfaceHoleCo lcl)  = IfaceHoleCo  <$> pure lcl+rnIfaceCo (IfaceAxiomInstCo n i cs)+    = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs+rnIfaceCo (IfaceUnivCo s r t1 t2)+    = IfaceUnivCo s r <$> rnIfaceType t1 <*> rnIfaceType t2+rnIfaceCo (IfaceSymCo c)+    = IfaceSymCo <$> rnIfaceCo c+rnIfaceCo (IfaceTransCo c1 c2)+    = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2+rnIfaceCo (IfaceInstCo c1 c2)+    = IfaceInstCo <$> rnIfaceCo c1 <*> rnIfaceCo c2+rnIfaceCo (IfaceNthCo d c) = IfaceNthCo d <$> rnIfaceCo c+rnIfaceCo (IfaceLRCo lr c) = IfaceLRCo lr <$> rnIfaceCo c+rnIfaceCo (IfaceSubCo c) = IfaceSubCo <$> rnIfaceCo c+rnIfaceCo (IfaceAxiomRuleCo ax cos)+    = IfaceAxiomRuleCo ax <$> mapM rnIfaceCo cos+rnIfaceCo (IfaceKindCo c) = IfaceKindCo <$> rnIfaceCo c++rnIfaceTyCon :: Rename IfaceTyCon+rnIfaceTyCon (IfaceTyCon n info)+    = IfaceTyCon <$> rnIfaceGlobal n <*> pure info++rnIfaceExprs :: Rename [IfaceExpr]+rnIfaceExprs = mapM rnIfaceExpr++rnIfaceIdDetails :: Rename IfaceIdDetails+rnIfaceIdDetails (IfRecSelId (Left tc) b) = IfRecSelId <$> fmap Left (rnIfaceTyCon tc) <*> pure b+rnIfaceIdDetails (IfRecSelId (Right decl) b) = IfRecSelId <$> fmap Right (rnIfaceDecl decl) <*> pure b+rnIfaceIdDetails details = pure details++rnIfaceType :: Rename IfaceType+rnIfaceType (IfaceFreeTyVar n) = pure (IfaceFreeTyVar n)+rnIfaceType (IfaceTyVar   n)   = pure (IfaceTyVar n)+rnIfaceType (IfaceAppTy t1 t2)+    = IfaceAppTy <$> rnIfaceType t1 <*> rnIfaceAppArgs t2+rnIfaceType (IfaceLitTy l)         = return (IfaceLitTy l)+rnIfaceType (IfaceFunTy af t1 t2)+    = IfaceFunTy af <$> rnIfaceType t1 <*> rnIfaceType t2+rnIfaceType (IfaceTupleTy s i tks)+    = IfaceTupleTy s i <$> rnIfaceAppArgs tks+rnIfaceType (IfaceTyConApp tc tks)+    = IfaceTyConApp <$> rnIfaceTyCon tc <*> rnIfaceAppArgs tks+rnIfaceType (IfaceForAllTy tv t)+    = IfaceForAllTy <$> rnIfaceForAllBndr tv <*> rnIfaceType t+rnIfaceType (IfaceCoercionTy co)+    = IfaceCoercionTy <$> rnIfaceCo co+rnIfaceType (IfaceCastTy ty co)+    = IfaceCastTy <$> rnIfaceType ty <*> rnIfaceCo co++rnIfaceForAllBndr :: Rename IfaceForAllBndr+rnIfaceForAllBndr (Bndr tv vis) = Bndr <$> rnIfaceBndr tv <*> pure vis++rnIfaceAppArgs :: Rename IfaceAppArgs+rnIfaceAppArgs (IA_Arg t a ts) = IA_Arg <$> rnIfaceType t <*> pure a+                                        <*> rnIfaceAppArgs ts+rnIfaceAppArgs IA_Nil = pure IA_Nil
+ compiler/cmm/Bitmap.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE BangPatterns #-}++--+-- (c) The University of Glasgow 2003-2006+--++-- Functions for constructing bitmaps, which are used in various+-- places in generated code (stack frame liveness masks, function+-- argument liveness masks, SRT bitmaps).++module Bitmap (+        Bitmap, mkBitmap,+        intsToBitmap, intsToReverseBitmap,+        mAX_SMALL_BITMAP_SIZE,+        seqBitmap,+  ) where++import GhcPrelude++import SMRep+import DynFlags+import Util++import Data.Bits++{-|+A bitmap represented by a sequence of 'StgWord's on the /target/+architecture.  These are used for bitmaps in info tables and other+generated code which need to be emitted as sequences of StgWords.+-}+type Bitmap = [StgWord]++-- | Make a bitmap from a sequence of bits+mkBitmap :: DynFlags -> [Bool] -> Bitmap+mkBitmap _ [] = []+mkBitmap dflags stuff = chunkToBitmap dflags chunk : mkBitmap dflags rest+  where (chunk, rest) = splitAt (wORD_SIZE_IN_BITS dflags) stuff++chunkToBitmap :: DynFlags -> [Bool] -> StgWord+chunkToBitmap dflags chunk =+  foldl' (.|.) (toStgWord dflags 0) [ oneAt n | (True,n) <- zip chunk [0..] ]+  where+    oneAt :: Int -> StgWord+    oneAt i = toStgWord dflags 1 `shiftL` i++-- | Make a bitmap where the slots specified are the /ones/ in the bitmap.+-- eg. @[0,1,3], size 4 ==> 0xb@.+--+-- The list of @Int@s /must/ be already sorted.+intsToBitmap :: DynFlags+             -> Int        -- ^ size in bits+             -> [Int]      -- ^ sorted indices of ones+             -> Bitmap+intsToBitmap dflags size = go 0+  where+    word_sz = wORD_SIZE_IN_BITS dflags+    oneAt :: Int -> StgWord+    oneAt i = toStgWord dflags 1 `shiftL` i++    -- It is important that we maintain strictness here.+    -- See Note [Strictness when building Bitmaps].+    go :: Int -> [Int] -> Bitmap+    go !pos slots+      | size <= pos = []+      | otherwise =+        (foldl' (.|.) (toStgWord dflags 0) (map (\i->oneAt (i - pos)) these)) :+          go (pos + word_sz) rest+      where+        (these,rest) = span (< (pos + word_sz)) slots++-- | Make a bitmap where the slots specified are the /zeros/ in the bitmap.+-- eg. @[0,1,3], size 4 ==> 0x4@  (we leave any bits outside the size as zero,+-- just to make the bitmap easier to read).+--+-- The list of @Int@s /must/ be already sorted and duplicate-free.+intsToReverseBitmap :: DynFlags+                    -> Int      -- ^ size in bits+                    -> [Int]    -- ^ sorted indices of zeros free of duplicates+                    -> Bitmap+intsToReverseBitmap dflags size = go 0+  where+    word_sz = wORD_SIZE_IN_BITS dflags+    oneAt :: Int -> StgWord+    oneAt i = toStgWord dflags 1 `shiftL` i++    -- It is important that we maintain strictness here.+    -- See Note [Strictness when building Bitmaps].+    go :: Int -> [Int] -> Bitmap+    go !pos slots+      | size <= pos = []+      | otherwise =+        (foldl' xor (toStgWord dflags init) (map (\i->oneAt (i - pos)) these)) :+          go (pos + word_sz) rest+      where+        (these,rest) = span (< (pos + word_sz)) slots+        remain = size - pos+        init+          | remain >= word_sz = -1+          | otherwise         = (1 `shiftL` remain) - 1++{-++Note [Strictness when building Bitmaps]+========================================++One of the places where @Bitmap@ is used is in in building Static Reference+Tables (SRTs) (in @CmmBuildInfoTables.procpointSRT@). In #7450 it was noticed+that some test cases (particularly those whose C-- have large numbers of CAFs)+produced large quantities of allocations from this function.++The source traced back to 'intsToBitmap', which was lazily subtracting the word+size from the elements of the tail of the @slots@ list and recursively invoking+itself with the result. This resulted in large numbers of subtraction thunks+being built up. Here we take care to avoid passing new thunks to the recursive+call. Instead we pass the unmodified tail along with an explicit position+accumulator, which get subtracted in the fold when we compute the Word.++-}++{- |+Magic number, must agree with @BITMAP_BITS_SHIFT@ in InfoTables.h.+Some kinds of bitmap pack a size\/bitmap into a single word if+possible, or fall back to an external pointer when the bitmap is too+large.  This value represents the largest size of bitmap that can be+packed into a single word.+-}+mAX_SMALL_BITMAP_SIZE :: DynFlags -> Int+mAX_SMALL_BITMAP_SIZE dflags+ | wORD_SIZE dflags == 4 = 27+ | otherwise             = 58++seqBitmap :: Bitmap -> a -> a+seqBitmap = seqList+
+ compiler/cmm/BlockId.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++{- BlockId module should probably go away completely, being superseded by Label -}+module BlockId+  ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet+  , newBlockId+  , blockLbl, infoTblLbl+  ) where++import GhcPrelude++import CLabel+import IdInfo+import Name+import Unique+import UniqSupply++import Hoopl.Label (Label, mkHooplLabel)++----------------------------------------------------------------+--- Block Ids, their environments, and their sets++{- Note [Unique BlockId]+~~~~~~~~~~~~~~~~~~~~~~~~+Although a 'BlockId' is a local label, for reasons of implementation,+'BlockId's must be unique within an entire compilation unit.  The reason+is that each local label is mapped to an assembly-language label, and in+most assembly languages allow, a label is visible throughout the entire+compilation unit in which it appears.+-}++type BlockId = Label++mkBlockId :: Unique -> BlockId+mkBlockId unique = mkHooplLabel $ getKey unique++newBlockId :: MonadUnique m => m BlockId+newBlockId = mkBlockId <$> getUniqueM++blockLbl :: BlockId -> CLabel+blockLbl label = mkLocalBlockLabel (getUnique label)++infoTblLbl :: BlockId -> CLabel+infoTblLbl label+  = mkBlockInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs
+ compiler/cmm/BlockId.hs-boot view
@@ -0,0 +1,8 @@+module BlockId (BlockId, mkBlockId) where++import Hoopl.Label (Label)+import Unique (Unique)++type BlockId = Label++mkBlockId :: Unique -> BlockId
+ compiler/cmm/CLabel.hs view
@@ -0,0 +1,1567 @@+-----------------------------------------------------------------------------+--+-- Object-file symbols (called CLabel for histerical raisins).+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++{-# LANGUAGE CPP #-}++module CLabel (+        CLabel, -- abstract type+        ForeignLabelSource(..),+        pprDebugCLabel,++        mkClosureLabel,+        mkSRTLabel,+        mkInfoTableLabel,+        mkEntryLabel,+        mkRednCountsLabel,+        mkConInfoTableLabel,+        mkApEntryLabel,+        mkApInfoTableLabel,+        mkClosureTableLabel,+        mkBytesLabel,++        mkLocalBlockLabel,+        mkLocalClosureLabel,+        mkLocalInfoTableLabel,+        mkLocalClosureTableLabel,++        mkBlockInfoTableLabel,++        mkBitmapLabel,+        mkStringLitLabel,++        mkAsmTempLabel,+        mkAsmTempDerivedLabel,+        mkAsmTempEndLabel,+        mkAsmTempDieLabel,++        mkDirty_MUT_VAR_Label,+        mkUpdInfoLabel,+        mkBHUpdInfoLabel,+        mkIndStaticInfoLabel,+        mkMainCapabilityLabel,+        mkMAP_FROZEN_CLEAN_infoLabel,+        mkMAP_FROZEN_DIRTY_infoLabel,+        mkMAP_DIRTY_infoLabel,+        mkSMAP_FROZEN_CLEAN_infoLabel,+        mkSMAP_FROZEN_DIRTY_infoLabel,+        mkSMAP_DIRTY_infoLabel,+        mkBadAlignmentLabel,+        mkArrWords_infoLabel,+        mkSRTInfoLabel,++        mkTopTickyCtrLabel,+        mkCAFBlackHoleInfoTableLabel,+        mkRtsPrimOpLabel,+        mkRtsSlowFastTickyCtrLabel,++        mkSelectorInfoLabel,+        mkSelectorEntryLabel,++        mkCmmInfoLabel,+        mkCmmEntryLabel,+        mkCmmRetInfoLabel,+        mkCmmRetLabel,+        mkCmmCodeLabel,+        mkCmmDataLabel,+        mkCmmClosureLabel,++        mkRtsApFastLabel,++        mkPrimCallLabel,++        mkForeignLabel,+        addLabelSize,++        foreignLabelStdcallInfo,+        isBytesLabel,+        isForeignLabel,+        isSomeRODataLabel,+        isStaticClosureLabel,+        mkCCLabel, mkCCSLabel,++        DynamicLinkerLabelInfo(..),+        mkDynamicLinkerLabel,+        dynamicLinkerLabelInfo,++        mkPicBaseLabel,+        mkDeadStripPreventer,++        mkHpcTicksLabel,++        -- * Predicates+        hasCAF,+        needsCDecl, maybeLocalBlockLabel, externallyVisibleCLabel,+        isMathFun,+        isCFunctionLabel, isGcPtrLabel, labelDynamic,+        isLocalCLabel, mayRedirectTo,++        -- * Conversions+        toClosureLbl, toSlowEntryLbl, toEntryLbl, toInfoLbl, hasHaskellName,++        pprCLabel,+        isInfoTableLabel,+        isConInfoTableLabel+    ) where++#include "HsVersions.h"++import GhcPrelude++import IdInfo+import BasicTypes+import {-# SOURCE #-} BlockId (BlockId, mkBlockId)+import Packages+import Module+import Name+import Unique+import PrimOp+import CostCentre+import Outputable+import FastString+import DynFlags+import Platform+import UniqSet+import Util+import PprCore ( {- instances -} )++-- -----------------------------------------------------------------------------+-- The CLabel type++{- |+  'CLabel' is an abstract type that supports the following operations:++  - Pretty printing++  - In a C file, does it need to be declared before use?  (i.e. is it+    guaranteed to be already in scope in the places we need to refer to it?)++  - If it needs to be declared, what type (code or data) should it be+    declared to have?++  - Is it visible outside this object file or not?++  - Is it "dynamic" (see details below)++  - Eq and Ord, so that we can make sets of CLabels (currently only+    used in outputting C as far as I can tell, to avoid generating+    more than one declaration for any given label).++  - Converting an info table label into an entry label.++  CLabel usage is a bit messy in GHC as they are used in a number of different+  contexts:++  - By the C-- AST to identify labels++  - By the unregisterised C code generator ("PprC") for naming functions (hence+    the name 'CLabel')++  - By the native and LLVM code generators to identify labels++  For extra fun, each of these uses a slightly different subset of constructors+  (e.g. 'AsmTempLabel' and 'AsmTempDerivedLabel' are used only in the NCG and+  LLVM backends).++  In general, we use 'IdLabel' to represent Haskell things early in the+  pipeline. However, later optimization passes will often represent blocks they+  create with 'LocalBlockLabel' where there is no obvious 'Name' to hang off the+  label.+-}++data CLabel+  = -- | A label related to the definition of a particular Id or Con in a .hs file.+    IdLabel+        Name+        CafInfo+        IdLabelInfo             -- encodes the suffix of the label++  -- | A label from a .cmm file that is not associated with a .hs level Id.+  | CmmLabel+        UnitId               -- what package the label belongs to.+        FastString              -- identifier giving the prefix of the label+        CmmLabelInfo            -- encodes the suffix of the label++  -- | A label with a baked-in \/ algorithmically generated name that definitely+  --    comes from the RTS. The code for it must compile into libHSrts.a \/ libHSrts.so+  --    If it doesn't have an algorithmically generated name then use a CmmLabel+  --    instead and give it an appropriate UnitId argument.+  | RtsLabel+        RtsLabelInfo++  -- | A label associated with a block. These aren't visible outside of the+  -- compilation unit in which they are defined. These are generally used to+  -- name blocks produced by Cmm-to-Cmm passes and the native code generator,+  -- where we don't have a 'Name' to associate the label to and therefore can't+  -- use 'IdLabel'.+  | LocalBlockLabel+        {-# UNPACK #-} !Unique++  -- | A 'C' (or otherwise foreign) label.+  --+  | ForeignLabel+        FastString              -- name of the imported label.++        (Maybe Int)             -- possible '@n' suffix for stdcall functions+                                -- When generating C, the '@n' suffix is omitted, but when+                                -- generating assembler we must add it to the label.++        ForeignLabelSource      -- what package the foreign label is in.++        FunctionOrData++  -- | Local temporary label used for native (or LLVM) code generation; must not+  -- appear outside of these contexts. Use primarily for debug information+  | AsmTempLabel+        {-# UNPACK #-} !Unique++  -- | A label \"derived\" from another 'CLabel' by the addition of a suffix.+  -- Must not occur outside of the NCG or LLVM code generators.+  | AsmTempDerivedLabel+        CLabel+        FastString              -- suffix++  | StringLitLabel+        {-# UNPACK #-} !Unique++  | CC_Label  CostCentre+  | CCS_Label CostCentreStack+++  -- | These labels are generated and used inside the NCG only.+  --    They are special variants of a label used for dynamic linking+  --    see module PositionIndependentCode for details.+  | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel++  -- | This label is generated and used inside the NCG only.+  --    It is used as a base for PIC calculations on some platforms.+  --    It takes the form of a local numeric assembler label '1'; and+  --    is pretty-printed as 1b, referring to the previous definition+  --    of 1: in the assembler source file.+  | PicBaseLabel++  -- | A label before an info table to prevent excessive dead-stripping on darwin+  | DeadStripPreventer CLabel+++  -- | Per-module table of tick locations+  | HpcTicksLabel Module++  -- | Static reference table+  | SRTLabel+        {-# UNPACK #-} !Unique++  -- | A bitmap (function or case return)+  | LargeBitmapLabel+        {-# UNPACK #-} !Unique++  deriving Eq++-- This is laborious, but necessary. We can't derive Ord because+-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the+-- implementation. See Note [No Ord for Unique]+-- This is non-deterministic but we do not currently support deterministic+-- code-generation. See Note [Unique Determinism and code generation]+instance Ord CLabel where+  compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) =+    compare a1 a2 `thenCmp`+    compare b1 b2 `thenCmp`+    compare c1 c2+  compare (CmmLabel a1 b1 c1) (CmmLabel a2 b2 c2) =+    compare a1 a2 `thenCmp`+    compare b1 b2 `thenCmp`+    compare c1 c2+  compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2+  compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2+  compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =+    compare a1 a2 `thenCmp`+    compare b1 b2 `thenCmp`+    compare c1 c2 `thenCmp`+    compare d1 d2+  compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2+  compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) =+    compare a1 a2 `thenCmp`+    compare b1 b2+  compare (StringLitLabel u1) (StringLitLabel u2) =+    nonDetCmpUnique u1 u2+  compare (CC_Label a1) (CC_Label a2) =+    compare a1 a2+  compare (CCS_Label a1) (CCS_Label a2) =+    compare a1 a2+  compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) =+    compare a1 a2 `thenCmp`+    compare b1 b2+  compare PicBaseLabel PicBaseLabel = EQ+  compare (DeadStripPreventer a1) (DeadStripPreventer a2) =+    compare a1 a2+  compare (HpcTicksLabel a1) (HpcTicksLabel a2) =+    compare a1 a2+  compare (SRTLabel u1) (SRTLabel u2) =+    nonDetCmpUnique u1 u2+  compare (LargeBitmapLabel u1) (LargeBitmapLabel u2) =+    nonDetCmpUnique u1 u2+  compare IdLabel{} _ = LT+  compare _ IdLabel{} = GT+  compare CmmLabel{} _ = LT+  compare _ CmmLabel{} = GT+  compare RtsLabel{} _ = LT+  compare _ RtsLabel{} = GT+  compare LocalBlockLabel{} _ = LT+  compare _ LocalBlockLabel{} = GT+  compare ForeignLabel{} _ = LT+  compare _ ForeignLabel{} = GT+  compare AsmTempLabel{} _ = LT+  compare _ AsmTempLabel{} = GT+  compare AsmTempDerivedLabel{} _ = LT+  compare _ AsmTempDerivedLabel{} = GT+  compare StringLitLabel{} _ = LT+  compare _ StringLitLabel{} = GT+  compare CC_Label{} _ = LT+  compare _ CC_Label{} = GT+  compare CCS_Label{} _ = LT+  compare _ CCS_Label{} = GT+  compare DynamicLinkerLabel{} _ = LT+  compare _ DynamicLinkerLabel{} = GT+  compare PicBaseLabel{} _ = LT+  compare _ PicBaseLabel{} = GT+  compare DeadStripPreventer{} _ = LT+  compare _ DeadStripPreventer{} = GT+  compare HpcTicksLabel{} _ = LT+  compare _ HpcTicksLabel{} = GT+  compare SRTLabel{} _ = LT+  compare _ SRTLabel{} = GT++-- | Record where a foreign label is stored.+data ForeignLabelSource++   -- | Label is in a named package+   = ForeignLabelInPackage      UnitId++   -- | Label is in some external, system package that doesn't also+   --   contain compiled Haskell code, and is not associated with any .hi files.+   --   We don't have to worry about Haskell code being inlined from+   --   external packages. It is safe to treat the RTS package as "external".+   | ForeignLabelInExternalPackage++   -- | Label is in the package currenly being compiled.+   --   This is only used for creating hacky tmp labels during code generation.+   --   Don't use it in any code that might be inlined across a package boundary+   --   (ie, core code) else the information will be wrong relative to the+   --   destination module.+   | ForeignLabelInThisPackage++   deriving (Eq, Ord)+++-- | For debugging problems with the CLabel representation.+--      We can't make a Show instance for CLabel because lots of its components don't have instances.+--      The regular Outputable instance only shows the label name, and not its other info.+--+pprDebugCLabel :: CLabel -> SDoc+pprDebugCLabel lbl+ = case lbl of+        IdLabel _ _ info-> ppr lbl <> (parens $ text "IdLabel"+                                       <> whenPprDebug (text ":" <> text (show info)))+        CmmLabel pkg _name _info+         -> ppr lbl <> (parens $ text "CmmLabel" <+> ppr pkg)++        RtsLabel{}      -> ppr lbl <> (parens $ text "RtsLabel")++        ForeignLabel _name mSuffix src funOrData+            -> ppr lbl <> (parens $ text "ForeignLabel"+                                <+> ppr mSuffix+                                <+> ppr src+                                <+> ppr funOrData)++        _               -> ppr lbl <> (parens $ text "other CLabel")+++data IdLabelInfo+  = Closure             -- ^ Label for closure+  | InfoTable           -- ^ Info tables for closures; always read-only+  | Entry               -- ^ Entry point+  | Slow                -- ^ Slow entry point++  | LocalInfoTable      -- ^ Like InfoTable but not externally visible+  | LocalEntry          -- ^ Like Entry but not externally visible++  | RednCounts          -- ^ Label of place to keep Ticky-ticky  info for this Id++  | ConEntry            -- ^ Constructor entry point+  | ConInfoTable        -- ^ Corresponding info table++  | ClosureTable        -- ^ Table of closures for Enum tycons++  | Bytes               -- ^ Content of a string literal. See+                        -- Note [Bytes label].+  | BlockInfoTable      -- ^ Like LocalInfoTable but for a proc-point block+                        -- instead of a closure entry-point.+                        -- See Note [Proc-point local block entry-point].++  deriving (Eq, Ord, Show)+++data RtsLabelInfo+  = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-}  -- ^ Selector thunks+  | RtsSelectorEntry     Bool{-updatable-} Int{-offset-}++  | RtsApInfoTable       Bool{-updatable-} Int{-arity-}    -- ^ AP thunks+  | RtsApEntry           Bool{-updatable-} Int{-arity-}++  | RtsPrimOp PrimOp+  | RtsApFast     FastString    -- ^ _fast versions of generic apply+  | RtsSlowFastTickyCtr String++  deriving (Eq, Ord)+  -- NOTE: Eq on PtrString compares the pointer only, so this isn't+  -- a real equality.+++-- | What type of Cmm label we're dealing with.+--      Determines the suffix appended to the name when a CLabel.CmmLabel+--      is pretty printed.+data CmmLabelInfo+  = CmmInfo                     -- ^ misc rts info tables,      suffix _info+  | CmmEntry                    -- ^ misc rts entry points,     suffix _entry+  | CmmRetInfo                  -- ^ misc rts ret info tables,  suffix _info+  | CmmRet                      -- ^ misc rts return points,    suffix _ret+  | CmmData                     -- ^ misc rts data bits, eg CHARLIKE_closure+  | CmmCode                     -- ^ misc rts code+  | CmmClosure                  -- ^ closures eg CHARLIKE_closure+  | CmmPrimCall                 -- ^ a prim call to some hand written Cmm code+  deriving (Eq, Ord)++data DynamicLinkerLabelInfo+  = CodeStub                    -- MachO: Lfoo$stub, ELF: foo@plt+  | SymbolPtr                   -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo+  | GotSymbolPtr                -- ELF: foo@got+  | GotSymbolOffset             -- ELF: foo@gotoff++  deriving (Eq, Ord)+++-- -----------------------------------------------------------------------------+-- Constructing CLabels+-- -----------------------------------------------------------------------------++-- Constructing IdLabels+-- These are always local:++mkSRTLabel     :: Unique -> CLabel+mkSRTLabel u = SRTLabel u++mkRednCountsLabel :: Name -> CLabel+mkRednCountsLabel       name    =+  IdLabel name NoCafRefs RednCounts  -- Note [ticky for LNE]++-- These have local & (possibly) external variants:+mkLocalClosureLabel      :: Name -> CafInfo -> CLabel+mkLocalInfoTableLabel    :: Name -> CafInfo -> CLabel+mkLocalClosureTableLabel :: Name -> CafInfo -> CLabel+mkLocalClosureLabel     name c  = IdLabel name  c Closure+mkLocalInfoTableLabel   name c  = IdLabel name  c LocalInfoTable+mkLocalClosureTableLabel name c = IdLabel name  c ClosureTable++mkClosureLabel              :: Name -> CafInfo -> CLabel+mkInfoTableLabel            :: Name -> CafInfo -> CLabel+mkEntryLabel                :: Name -> CafInfo -> CLabel+mkClosureTableLabel         :: Name -> CafInfo -> CLabel+mkConInfoTableLabel         :: Name -> CafInfo -> CLabel+mkBytesLabel                :: Name -> CLabel+mkClosureLabel name         c     = IdLabel name c Closure+mkInfoTableLabel name       c     = IdLabel name c InfoTable+mkEntryLabel name           c     = IdLabel name c Entry+mkClosureTableLabel name    c     = IdLabel name c ClosureTable+mkConInfoTableLabel name    c     = IdLabel name c ConInfoTable+mkBytesLabel name                 = IdLabel name NoCafRefs Bytes++mkBlockInfoTableLabel :: Name -> CafInfo -> CLabel+mkBlockInfoTableLabel name c = IdLabel name c BlockInfoTable+                               -- See Note [Proc-point local block entry-point].++-- Constructing Cmm Labels+mkDirty_MUT_VAR_Label, mkUpdInfoLabel,+    mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,+    mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel,+    mkMAP_DIRTY_infoLabel,+    mkArrWords_infoLabel,+    mkTopTickyCtrLabel,+    mkCAFBlackHoleInfoTableLabel,+    mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,+    mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel :: CLabel+mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction+mkUpdInfoLabel                  = CmmLabel rtsUnitId (fsLit "stg_upd_frame")         CmmInfo+mkBHUpdInfoLabel                = CmmLabel rtsUnitId (fsLit "stg_bh_upd_frame" )     CmmInfo+mkIndStaticInfoLabel            = CmmLabel rtsUnitId (fsLit "stg_IND_STATIC")        CmmInfo+mkMainCapabilityLabel           = CmmLabel rtsUnitId (fsLit "MainCapability")        CmmData+mkMAP_FROZEN_CLEAN_infoLabel    = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo+mkMAP_FROZEN_DIRTY_infoLabel    = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo+mkMAP_DIRTY_infoLabel           = CmmLabel rtsUnitId (fsLit "stg_MUT_ARR_PTRS_DIRTY") CmmInfo+mkTopTickyCtrLabel              = CmmLabel rtsUnitId (fsLit "top_ct")                CmmData+mkCAFBlackHoleInfoTableLabel    = CmmLabel rtsUnitId (fsLit "stg_CAF_BLACKHOLE")     CmmInfo+mkArrWords_infoLabel            = CmmLabel rtsUnitId (fsLit "stg_ARR_WORDS")         CmmInfo+mkSMAP_FROZEN_CLEAN_infoLabel   = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_CLEAN") CmmInfo+mkSMAP_FROZEN_DIRTY_infoLabel   = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo+mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo+mkBadAlignmentLabel             = CmmLabel rtsUnitId (fsLit "stg_badAlignment")      CmmEntry++mkSRTInfoLabel :: Int -> CLabel+mkSRTInfoLabel n = CmmLabel rtsUnitId lbl CmmInfo+ where+   lbl =+     case n of+       1 -> fsLit "stg_SRT_1"+       2 -> fsLit "stg_SRT_2"+       3 -> fsLit "stg_SRT_3"+       4 -> fsLit "stg_SRT_4"+       5 -> fsLit "stg_SRT_5"+       6 -> fsLit "stg_SRT_6"+       7 -> fsLit "stg_SRT_7"+       8 -> fsLit "stg_SRT_8"+       9 -> fsLit "stg_SRT_9"+       10 -> fsLit "stg_SRT_10"+       11 -> fsLit "stg_SRT_11"+       12 -> fsLit "stg_SRT_12"+       13 -> fsLit "stg_SRT_13"+       14 -> fsLit "stg_SRT_14"+       15 -> fsLit "stg_SRT_15"+       16 -> fsLit "stg_SRT_16"+       _ -> panic "mkSRTInfoLabel"++-----+mkCmmInfoLabel,   mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,+  mkCmmCodeLabel, mkCmmDataLabel,  mkCmmClosureLabel+        :: UnitId -> FastString -> CLabel++mkCmmInfoLabel      pkg str     = CmmLabel pkg str CmmInfo+mkCmmEntryLabel     pkg str     = CmmLabel pkg str CmmEntry+mkCmmRetInfoLabel   pkg str     = CmmLabel pkg str CmmRetInfo+mkCmmRetLabel       pkg str     = CmmLabel pkg str CmmRet+mkCmmCodeLabel      pkg str     = CmmLabel pkg str CmmCode+mkCmmDataLabel      pkg str     = CmmLabel pkg str CmmData+mkCmmClosureLabel   pkg str     = CmmLabel pkg str CmmClosure++mkLocalBlockLabel :: Unique -> CLabel+mkLocalBlockLabel u = LocalBlockLabel u++-- Constructing RtsLabels+mkRtsPrimOpLabel :: PrimOp -> CLabel+mkRtsPrimOpLabel primop         = RtsLabel (RtsPrimOp primop)++mkSelectorInfoLabel  :: Bool -> Int -> CLabel+mkSelectorEntryLabel :: Bool -> Int -> CLabel+mkSelectorInfoLabel  upd off    = RtsLabel (RtsSelectorInfoTable upd off)+mkSelectorEntryLabel upd off    = RtsLabel (RtsSelectorEntry     upd off)++mkApInfoTableLabel :: Bool -> Int -> CLabel+mkApEntryLabel     :: Bool -> Int -> CLabel+mkApInfoTableLabel   upd off    = RtsLabel (RtsApInfoTable       upd off)+mkApEntryLabel       upd off    = RtsLabel (RtsApEntry           upd off)+++-- A call to some primitive hand written Cmm code+mkPrimCallLabel :: PrimCall -> CLabel+mkPrimCallLabel (PrimCall str pkg)+        = CmmLabel pkg str CmmPrimCall+++-- Constructing ForeignLabels++-- | Make a foreign label+mkForeignLabel+        :: FastString           -- name+        -> Maybe Int            -- size prefix+        -> ForeignLabelSource   -- what package it's in+        -> FunctionOrData+        -> CLabel++mkForeignLabel str mb_sz src fod+    = ForeignLabel str mb_sz src  fod+++-- | Update the label size field in a ForeignLabel+addLabelSize :: CLabel -> Int -> CLabel+addLabelSize (ForeignLabel str _ src  fod) sz+    = ForeignLabel str (Just sz) src fod+addLabelSize label _+    = label++-- | Whether label is a top-level string literal+isBytesLabel :: CLabel -> Bool+isBytesLabel (IdLabel _ _ Bytes) = True+isBytesLabel _lbl = False++-- | Whether label is a non-haskell label (defined in C code)+isForeignLabel :: CLabel -> Bool+isForeignLabel (ForeignLabel _ _ _ _) = True+isForeignLabel _lbl = False++-- | Whether label is a static closure label (can come from haskell or cmm)+isStaticClosureLabel :: CLabel -> Bool+-- Closure defined in haskell (.hs)+isStaticClosureLabel (IdLabel _ _ Closure) = True+-- Closure defined in cmm+isStaticClosureLabel (CmmLabel _ _ CmmClosure) = True+isStaticClosureLabel _lbl = False++-- | Whether label is a .rodata label+isSomeRODataLabel :: CLabel -> Bool+-- info table defined in haskell (.hs)+isSomeRODataLabel (IdLabel _ _ ClosureTable) = True+isSomeRODataLabel (IdLabel _ _ ConInfoTable) = True+isSomeRODataLabel (IdLabel _ _ InfoTable) = True+isSomeRODataLabel (IdLabel _ _ LocalInfoTable) = True+isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True+-- info table defined in cmm (.cmm)+isSomeRODataLabel (CmmLabel _ _ CmmInfo) = True+isSomeRODataLabel _lbl = False++-- | Whether label is points to some kind of info table+isInfoTableLabel :: CLabel -> Bool+isInfoTableLabel (IdLabel _ _ InfoTable)      = True+isInfoTableLabel (IdLabel _ _ LocalInfoTable) = True+isInfoTableLabel (IdLabel _ _ ConInfoTable)   = True+isInfoTableLabel (IdLabel _ _ BlockInfoTable) = True+isInfoTableLabel _                            = False++-- | Whether label is points to constructor info table+isConInfoTableLabel :: CLabel -> Bool+isConInfoTableLabel (IdLabel _ _ ConInfoTable)   = True+isConInfoTableLabel _                            = False++-- | Get the label size field from a ForeignLabel+foreignLabelStdcallInfo :: CLabel -> Maybe Int+foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info+foreignLabelStdcallInfo _lbl = Nothing+++-- Constructing Large*Labels+mkBitmapLabel   :: Unique -> CLabel+mkBitmapLabel   uniq            = LargeBitmapLabel uniq++-- Constructing Cost Center Labels+mkCCLabel  :: CostCentre      -> CLabel+mkCCSLabel :: CostCentreStack -> CLabel+mkCCLabel           cc          = CC_Label cc+mkCCSLabel          ccs         = CCS_Label ccs++mkRtsApFastLabel :: FastString -> CLabel+mkRtsApFastLabel str = RtsLabel (RtsApFast str)++mkRtsSlowFastTickyCtrLabel :: String -> CLabel+mkRtsSlowFastTickyCtrLabel pat = RtsLabel (RtsSlowFastTickyCtr pat)+++-- Constructing Code Coverage Labels+mkHpcTicksLabel :: Module -> CLabel+mkHpcTicksLabel                = HpcTicksLabel+++-- Constructing labels used for dynamic linking+mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel+mkDynamicLinkerLabel            = DynamicLinkerLabel++dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel)+dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl)+dynamicLinkerLabelInfo _        = Nothing++mkPicBaseLabel :: CLabel+mkPicBaseLabel                  = PicBaseLabel+++-- Constructing miscellaneous other labels+mkDeadStripPreventer :: CLabel -> CLabel+mkDeadStripPreventer lbl        = DeadStripPreventer lbl++mkStringLitLabel :: Unique -> CLabel+mkStringLitLabel                = StringLitLabel++mkAsmTempLabel :: Uniquable a => a -> CLabel+mkAsmTempLabel a                = AsmTempLabel (getUnique a)++mkAsmTempDerivedLabel :: CLabel -> FastString -> CLabel+mkAsmTempDerivedLabel = AsmTempDerivedLabel++mkAsmTempEndLabel :: CLabel -> CLabel+mkAsmTempEndLabel l = mkAsmTempDerivedLabel l (fsLit "_end")++-- | Construct a label for a DWARF Debug Information Entity (DIE)+-- describing another symbol.+mkAsmTempDieLabel :: CLabel -> CLabel+mkAsmTempDieLabel l = mkAsmTempDerivedLabel l (fsLit "_die")++-- -----------------------------------------------------------------------------+-- Convert between different kinds of label++toClosureLbl :: CLabel -> CLabel+toClosureLbl (IdLabel n c _) = IdLabel n c Closure+toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure+toClosureLbl l = pprPanic "toClosureLbl" (ppr l)++toSlowEntryLbl :: CLabel -> CLabel+toSlowEntryLbl (IdLabel n _ BlockInfoTable)+  = pprPanic "toSlowEntryLbl" (ppr n)+toSlowEntryLbl (IdLabel n c _) = IdLabel n c Slow+toSlowEntryLbl l = pprPanic "toSlowEntryLbl" (ppr l)++toEntryLbl :: CLabel -> CLabel+toEntryLbl (IdLabel n c LocalInfoTable)  = IdLabel n c LocalEntry+toEntryLbl (IdLabel n c ConInfoTable)    = IdLabel n c ConEntry+toEntryLbl (IdLabel n _ BlockInfoTable)  = mkLocalBlockLabel (nameUnique n)+                              -- See Note [Proc-point local block entry-point].+toEntryLbl (IdLabel n c _)               = IdLabel n c Entry+toEntryLbl (CmmLabel m str CmmInfo)      = CmmLabel m str CmmEntry+toEntryLbl (CmmLabel m str CmmRetInfo)   = CmmLabel m str CmmRet+toEntryLbl l = pprPanic "toEntryLbl" (ppr l)++toInfoLbl :: CLabel -> CLabel+toInfoLbl (IdLabel n c LocalEntry)     = IdLabel n c LocalInfoTable+toInfoLbl (IdLabel n c ConEntry)       = IdLabel n c ConInfoTable+toInfoLbl (IdLabel n c _)              = IdLabel n c InfoTable+toInfoLbl (CmmLabel m str CmmEntry)    = CmmLabel m str CmmInfo+toInfoLbl (CmmLabel m str CmmRet)      = CmmLabel m str CmmRetInfo+toInfoLbl l = pprPanic "CLabel.toInfoLbl" (ppr l)++hasHaskellName :: CLabel -> Maybe Name+hasHaskellName (IdLabel n _ _) = Just n+hasHaskellName _               = Nothing++-- -----------------------------------------------------------------------------+-- Does a CLabel's referent itself refer to a CAF?+hasCAF :: CLabel -> Bool+hasCAF (IdLabel _ _ RednCounts) = False -- Note [ticky for LNE]+hasCAF (IdLabel _ MayHaveCafRefs _) = True+hasCAF _                            = False++-- Note [ticky for LNE]+-- ~~~~~~~~~~~~~~~~~~~~~++-- Until 14 Feb 2013, every ticky counter was associated with a+-- closure. Thus, ticky labels used IdLabel. It is odd that+-- CmmBuildInfoTables.cafTransfers would consider such a ticky label+-- reason to add the name to the CAFEnv (and thus eventually the SRT),+-- but it was harmless because the ticky was only used if the closure+-- was also.+--+-- Since we now have ticky counters for LNEs, it is no longer the case+-- that every ticky counter has an actual closure. So I changed the+-- generation of ticky counters' CLabels to not result in their+-- associated id ending up in the SRT.+--+-- NB IdLabel is still appropriate for ticky ids (as opposed to+-- CmmLabel) because the LNE's counter is still related to an .hs Id,+-- that Id just isn't for a proper closure.++-- -----------------------------------------------------------------------------+-- Does a CLabel need declaring before use or not?+--+-- See wiki:commentary/compiler/backends/ppr-c#prototypes++needsCDecl :: CLabel -> Bool+  -- False <=> it's pre-declared; don't bother+  -- don't bother declaring Bitmap labels, we always make sure+  -- they are defined before use.+needsCDecl (SRTLabel _)                 = True+needsCDecl (LargeBitmapLabel _)         = False+needsCDecl (IdLabel _ _ _)              = True+needsCDecl (LocalBlockLabel _)          = True++needsCDecl (StringLitLabel _)           = False+needsCDecl (AsmTempLabel _)             = False+needsCDecl (AsmTempDerivedLabel _ _)    = False+needsCDecl (RtsLabel _)                 = False++needsCDecl (CmmLabel pkgId _ _)+        -- Prototypes for labels defined in the runtime system are imported+        --      into HC files via includes/Stg.h.+        | pkgId == rtsUnitId         = False++        -- For other labels we inline one into the HC file directly.+        | otherwise                     = True++needsCDecl l@(ForeignLabel{})           = not (isMathFun l)+needsCDecl (CC_Label _)                 = True+needsCDecl (CCS_Label _)                = True+needsCDecl (HpcTicksLabel _)            = True+needsCDecl (DynamicLinkerLabel {})      = panic "needsCDecl DynamicLinkerLabel"+needsCDecl PicBaseLabel                 = panic "needsCDecl PicBaseLabel"+needsCDecl (DeadStripPreventer {})      = panic "needsCDecl DeadStripPreventer"++-- | If a label is a local block label then return just its 'BlockId', otherwise+-- 'Nothing'.+maybeLocalBlockLabel :: CLabel -> Maybe BlockId+maybeLocalBlockLabel (LocalBlockLabel uq)  = Just $ mkBlockId uq+maybeLocalBlockLabel _                     = Nothing+++-- | Check whether a label corresponds to a C function that has+--      a prototype in a system header somehere, or is built-in+--      to the C compiler. For these labels we avoid generating our+--      own C prototypes.+isMathFun :: CLabel -> Bool+isMathFun (ForeignLabel fs _ _ _)       = fs `elementOfUniqSet` math_funs+isMathFun _ = False++math_funs :: UniqSet FastString+math_funs = mkUniqSet [+        -- _ISOC99_SOURCE+        (fsLit "acos"),         (fsLit "acosf"),        (fsLit "acosh"),+        (fsLit "acoshf"),       (fsLit "acoshl"),       (fsLit "acosl"),+        (fsLit "asin"),         (fsLit "asinf"),        (fsLit "asinl"),+        (fsLit "asinh"),        (fsLit "asinhf"),       (fsLit "asinhl"),+        (fsLit "atan"),         (fsLit "atanf"),        (fsLit "atanl"),+        (fsLit "atan2"),        (fsLit "atan2f"),       (fsLit "atan2l"),+        (fsLit "atanh"),        (fsLit "atanhf"),       (fsLit "atanhl"),+        (fsLit "cbrt"),         (fsLit "cbrtf"),        (fsLit "cbrtl"),+        (fsLit "ceil"),         (fsLit "ceilf"),        (fsLit "ceill"),+        (fsLit "copysign"),     (fsLit "copysignf"),    (fsLit "copysignl"),+        (fsLit "cos"),          (fsLit "cosf"),         (fsLit "cosl"),+        (fsLit "cosh"),         (fsLit "coshf"),        (fsLit "coshl"),+        (fsLit "erf"),          (fsLit "erff"),         (fsLit "erfl"),+        (fsLit "erfc"),         (fsLit "erfcf"),        (fsLit "erfcl"),+        (fsLit "exp"),          (fsLit "expf"),         (fsLit "expl"),+        (fsLit "exp2"),         (fsLit "exp2f"),        (fsLit "exp2l"),+        (fsLit "expm1"),        (fsLit "expm1f"),       (fsLit "expm1l"),+        (fsLit "fabs"),         (fsLit "fabsf"),        (fsLit "fabsl"),+        (fsLit "fdim"),         (fsLit "fdimf"),        (fsLit "fdiml"),+        (fsLit "floor"),        (fsLit "floorf"),       (fsLit "floorl"),+        (fsLit "fma"),          (fsLit "fmaf"),         (fsLit "fmal"),+        (fsLit "fmax"),         (fsLit "fmaxf"),        (fsLit "fmaxl"),+        (fsLit "fmin"),         (fsLit "fminf"),        (fsLit "fminl"),+        (fsLit "fmod"),         (fsLit "fmodf"),        (fsLit "fmodl"),+        (fsLit "frexp"),        (fsLit "frexpf"),       (fsLit "frexpl"),+        (fsLit "hypot"),        (fsLit "hypotf"),       (fsLit "hypotl"),+        (fsLit "ilogb"),        (fsLit "ilogbf"),       (fsLit "ilogbl"),+        (fsLit "ldexp"),        (fsLit "ldexpf"),       (fsLit "ldexpl"),+        (fsLit "lgamma"),       (fsLit "lgammaf"),      (fsLit "lgammal"),+        (fsLit "llrint"),       (fsLit "llrintf"),      (fsLit "llrintl"),+        (fsLit "llround"),      (fsLit "llroundf"),     (fsLit "llroundl"),+        (fsLit "log"),          (fsLit "logf"),         (fsLit "logl"),+        (fsLit "log10l"),       (fsLit "log10"),        (fsLit "log10f"),+        (fsLit "log1pl"),       (fsLit "log1p"),        (fsLit "log1pf"),+        (fsLit "log2"),         (fsLit "log2f"),        (fsLit "log2l"),+        (fsLit "logb"),         (fsLit "logbf"),        (fsLit "logbl"),+        (fsLit "lrint"),        (fsLit "lrintf"),       (fsLit "lrintl"),+        (fsLit "lround"),       (fsLit "lroundf"),      (fsLit "lroundl"),+        (fsLit "modf"),         (fsLit "modff"),        (fsLit "modfl"),+        (fsLit "nan"),          (fsLit "nanf"),         (fsLit "nanl"),+        (fsLit "nearbyint"),    (fsLit "nearbyintf"),   (fsLit "nearbyintl"),+        (fsLit "nextafter"),    (fsLit "nextafterf"),   (fsLit "nextafterl"),+        (fsLit "nexttoward"),   (fsLit "nexttowardf"),  (fsLit "nexttowardl"),+        (fsLit "pow"),          (fsLit "powf"),         (fsLit "powl"),+        (fsLit "remainder"),    (fsLit "remainderf"),   (fsLit "remainderl"),+        (fsLit "remquo"),       (fsLit "remquof"),      (fsLit "remquol"),+        (fsLit "rint"),         (fsLit "rintf"),        (fsLit "rintl"),+        (fsLit "round"),        (fsLit "roundf"),       (fsLit "roundl"),+        (fsLit "scalbln"),      (fsLit "scalblnf"),     (fsLit "scalblnl"),+        (fsLit "scalbn"),       (fsLit "scalbnf"),      (fsLit "scalbnl"),+        (fsLit "sin"),          (fsLit "sinf"),         (fsLit "sinl"),+        (fsLit "sinh"),         (fsLit "sinhf"),        (fsLit "sinhl"),+        (fsLit "sqrt"),         (fsLit "sqrtf"),        (fsLit "sqrtl"),+        (fsLit "tan"),          (fsLit "tanf"),         (fsLit "tanl"),+        (fsLit "tanh"),         (fsLit "tanhf"),        (fsLit "tanhl"),+        (fsLit "tgamma"),       (fsLit "tgammaf"),      (fsLit "tgammal"),+        (fsLit "trunc"),        (fsLit "truncf"),       (fsLit "truncl"),+        -- ISO C 99 also defines these function-like macros in math.h:+        -- fpclassify, isfinite, isinf, isnormal, signbit, isgreater,+        -- isgreaterequal, isless, islessequal, islessgreater, isunordered++        -- additional symbols from _BSD_SOURCE+        (fsLit "drem"),         (fsLit "dremf"),        (fsLit "dreml"),+        (fsLit "finite"),       (fsLit "finitef"),      (fsLit "finitel"),+        (fsLit "gamma"),        (fsLit "gammaf"),       (fsLit "gammal"),+        (fsLit "isinf"),        (fsLit "isinff"),       (fsLit "isinfl"),+        (fsLit "isnan"),        (fsLit "isnanf"),       (fsLit "isnanl"),+        (fsLit "j0"),           (fsLit "j0f"),          (fsLit "j0l"),+        (fsLit "j1"),           (fsLit "j1f"),          (fsLit "j1l"),+        (fsLit "jn"),           (fsLit "jnf"),          (fsLit "jnl"),+        (fsLit "lgamma_r"),     (fsLit "lgammaf_r"),    (fsLit "lgammal_r"),+        (fsLit "scalb"),        (fsLit "scalbf"),       (fsLit "scalbl"),+        (fsLit "significand"),  (fsLit "significandf"), (fsLit "significandl"),+        (fsLit "y0"),           (fsLit "y0f"),          (fsLit "y0l"),+        (fsLit "y1"),           (fsLit "y1f"),          (fsLit "y1l"),+        (fsLit "yn"),           (fsLit "ynf"),          (fsLit "ynl"),++        -- These functions are described in IEEE Std 754-2008 -+        -- Standard for Floating-Point Arithmetic and ISO/IEC TS 18661+        (fsLit "nextup"),       (fsLit "nextupf"),      (fsLit "nextupl"),+        (fsLit "nextdown"),     (fsLit "nextdownf"),    (fsLit "nextdownl")+    ]++-- -----------------------------------------------------------------------------+-- | Is a CLabel visible outside this object file or not?+--      From the point of view of the code generator, a name is+--      externally visible if it has to be declared as exported+--      in the .o file's symbol table; that is, made non-static.+externallyVisibleCLabel :: CLabel -> Bool -- not C "static"+externallyVisibleCLabel (StringLitLabel _)      = False+externallyVisibleCLabel (AsmTempLabel _)        = False+externallyVisibleCLabel (AsmTempDerivedLabel _ _)= False+externallyVisibleCLabel (RtsLabel _)            = True+externallyVisibleCLabel (LocalBlockLabel _)     = False+externallyVisibleCLabel (CmmLabel _ _ _)        = True+externallyVisibleCLabel (ForeignLabel{})        = True+externallyVisibleCLabel (IdLabel name _ info)   = isExternalName name && externallyVisibleIdLabel info+externallyVisibleCLabel (CC_Label _)            = True+externallyVisibleCLabel (CCS_Label _)           = True+externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False+externallyVisibleCLabel (HpcTicksLabel _)       = True+externallyVisibleCLabel (LargeBitmapLabel _)    = False+externallyVisibleCLabel (SRTLabel _)            = False+externallyVisibleCLabel (PicBaseLabel {}) = panic "externallyVisibleCLabel PicBaseLabel"+externallyVisibleCLabel (DeadStripPreventer {}) = panic "externallyVisibleCLabel DeadStripPreventer"++externallyVisibleIdLabel :: IdLabelInfo -> Bool+externallyVisibleIdLabel LocalInfoTable  = False+externallyVisibleIdLabel LocalEntry      = False+externallyVisibleIdLabel BlockInfoTable  = False+externallyVisibleIdLabel _               = True++-- -----------------------------------------------------------------------------+-- Finding the "type" of a CLabel++-- For generating correct types in label declarations:++data CLabelType+  = CodeLabel   -- Address of some executable instructions+  | DataLabel   -- Address of data, not a GC ptr+  | GcPtrLabel  -- Address of a (presumably static) GC object++isCFunctionLabel :: CLabel -> Bool+isCFunctionLabel lbl = case labelType lbl of+                        CodeLabel -> True+                        _other    -> False++isGcPtrLabel :: CLabel -> Bool+isGcPtrLabel lbl = case labelType lbl of+                        GcPtrLabel -> True+                        _other     -> False+++-- | Work out the general type of data at the address of this label+--    whether it be code, data, or static GC object.+labelType :: CLabel -> CLabelType+labelType (IdLabel _ _ info)                    = idInfoLabelType info+labelType (CmmLabel _ _ CmmData)                = DataLabel+labelType (CmmLabel _ _ CmmClosure)             = GcPtrLabel+labelType (CmmLabel _ _ CmmCode)                = CodeLabel+labelType (CmmLabel _ _ CmmInfo)                = DataLabel+labelType (CmmLabel _ _ CmmEntry)               = CodeLabel+labelType (CmmLabel _ _ CmmPrimCall)            = CodeLabel+labelType (CmmLabel _ _ CmmRetInfo)             = DataLabel+labelType (CmmLabel _ _ CmmRet)                 = CodeLabel+labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel+labelType (RtsLabel (RtsApInfoTable _ _))       = DataLabel+labelType (RtsLabel (RtsApFast _))              = CodeLabel+labelType (RtsLabel _)                          = DataLabel+labelType (LocalBlockLabel _)                   = CodeLabel+labelType (SRTLabel _)                          = DataLabel+labelType (ForeignLabel _ _ _ IsFunction)       = CodeLabel+labelType (ForeignLabel _ _ _ IsData)           = DataLabel+labelType (AsmTempLabel _)                      = panic "labelType(AsmTempLabel)"+labelType (AsmTempDerivedLabel _ _)             = panic "labelType(AsmTempDerivedLabel)"+labelType (StringLitLabel _)                    = DataLabel+labelType (CC_Label _)                          = DataLabel+labelType (CCS_Label _)                         = DataLabel+labelType (DynamicLinkerLabel _ _)              = DataLabel -- Is this right?+labelType PicBaseLabel                          = DataLabel+labelType (DeadStripPreventer _)                = DataLabel+labelType (HpcTicksLabel _)                     = DataLabel+labelType (LargeBitmapLabel _)                  = DataLabel++idInfoLabelType :: IdLabelInfo -> CLabelType+idInfoLabelType info =+  case info of+    InfoTable     -> DataLabel+    LocalInfoTable -> DataLabel+    BlockInfoTable -> DataLabel+    Closure       -> GcPtrLabel+    ConInfoTable  -> DataLabel+    ClosureTable  -> DataLabel+    RednCounts    -> DataLabel+    Bytes         -> DataLabel+    _             -> CodeLabel+++-- -----------------------------------------------------------------------------++-- | Is a 'CLabel' defined in the current module being compiled?+--+-- Sometimes we can optimise references within a compilation unit in ways that+-- we couldn't for inter-module references. This provides a conservative+-- estimate of whether a 'CLabel' lives in the current module.+isLocalCLabel :: Module -> CLabel -> Bool+isLocalCLabel this_mod lbl =+  case lbl of+    IdLabel name _ _+      | isInternalName name -> True+      | otherwise           -> nameModule name == this_mod+    LocalBlockLabel _       -> True+    _                       -> False++-- -----------------------------------------------------------------------------++-- | Does a 'CLabel' need dynamic linkage?+--+-- When referring to data in code, we need to know whether+-- that data resides in a DLL or not. [Win32 only.]+-- @labelDynamic@ returns @True@ if the label is located+-- in a DLL, be it a data reference or not.+labelDynamic :: DynFlags -> Module -> CLabel -> Bool+labelDynamic dflags this_mod lbl =+  case lbl of+   -- is the RTS in a DLL or not?+   RtsLabel _ ->+     externalDynamicRefs && (this_pkg /= rtsUnitId)++   IdLabel n _ _ ->+     isDllName dflags this_mod n++   -- When compiling in the "dyn" way, each package is to be linked into+   -- its own shared library.+   CmmLabel pkg _ _+    | os == OSMinGW32 ->+       externalDynamicRefs && (this_pkg /= pkg)+    | otherwise ->+       gopt Opt_ExternalDynamicRefs dflags++   LocalBlockLabel _    -> False++   ForeignLabel _ _ source _  ->+       if os == OSMinGW32+       then case source of+            -- Foreign label is in some un-named foreign package (or DLL).+            ForeignLabelInExternalPackage -> True++            -- Foreign label is linked into the same package as the+            -- source file currently being compiled.+            ForeignLabelInThisPackage -> False++            -- Foreign label is in some named package.+            -- When compiling in the "dyn" way, each package is to be+            -- linked into its own DLL.+            ForeignLabelInPackage pkgId ->+                externalDynamicRefs && (this_pkg /= pkgId)++       else -- On Mac OS X and on ELF platforms, false positives are OK,+            -- so we claim that all foreign imports come from dynamic+            -- libraries+            True++   CC_Label cc ->+     externalDynamicRefs && not (ccFromThisModule cc this_mod)++   -- CCS_Label always contains a CostCentre defined in the current module+   CCS_Label _ -> False++   HpcTicksLabel m ->+     externalDynamicRefs && this_mod /= m++   -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.+   _                 -> False+  where+    externalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags+    os = platformOS (targetPlatform dflags)+    this_pkg = moduleUnitId this_mod+++-----------------------------------------------------------------------------+-- Printing out CLabels.++{-+Convention:++      <name>_<type>++where <name> is <Module>_<name> for external names and <unique> for+internal names. <type> is one of the following:++         info                   Info table+         srt                    Static reference table+         entry                  Entry code (function, closure)+         slow                   Slow entry code (if any)+         ret                    Direct return address+         vtbl                   Vector table+         <n>_alt                Case alternative (tag n)+         dflt                   Default case alternative+         btm                    Large bitmap vector+         closure                Static closure+         con_entry              Dynamic Constructor entry code+         con_info               Dynamic Constructor info table+         static_entry           Static Constructor entry code+         static_info            Static Constructor info table+         sel_info               Selector info table+         sel_entry              Selector entry code+         cc                     Cost centre+         ccs                    Cost centre stack++Many of these distinctions are only for documentation reasons.  For+example, _ret is only distinguished from _entry to make it easy to+tell whether a code fragment is a return point or a closure/function+entry.++Note [Closure and info labels]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For a function 'foo, we have:+   foo_info    : Points to the info table describing foo's closure+                 (and entry code for foo with tables next to code)+   foo_closure : Static (no-free-var) closure only:+                 points to the statically-allocated closure++For a data constructor (such as Just or Nothing), we have:+    Just_con_info: Info table for the data constructor itself+                   the first word of a heap-allocated Just+    Just_info:     Info table for the *worker function*, an+                   ordinary Haskell function of arity 1 that+                   allocates a (Just x) box:+                      Just = \x -> Just x+    Just_closure:  The closure for this worker++    Nothing_closure: a statically allocated closure for Nothing+    Nothing_static_info: info table for Nothing_closure++All these must be exported symbol, EXCEPT Just_info.  We don't need to+export this because in other modules we either have+       * A reference to 'Just'; use Just_closure+       * A saturated call 'Just x'; allocate using Just_con_info+Not exporting these Just_info labels reduces the number of symbols+somewhat.++Note [Bytes label]+~~~~~~~~~~~~~~~~~~+For a top-level string literal 'foo', we have just one symbol 'foo_bytes', which+points to a static data block containing the content of the literal.++Note [Proc-point local block entry-points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A label for a proc-point local block entry-point has no "_entry" suffix. With+`infoTblLbl` we derive an info table label from a proc-point block ID. If+we convert such an info table label into an entry label we must produce+the label without an "_entry" suffix. So an info table label records+the fact that it was derived from a block ID in `IdLabelInfo` as+`BlockInfoTable`.++The info table label and the local block label are both local labels+and are not externally visible.+-}++instance Outputable CLabel where+  ppr c = sdocWithDynFlags $ \dynFlags -> pprCLabel dynFlags c++pprCLabel :: DynFlags -> CLabel -> SDoc++pprCLabel _ (LocalBlockLabel u)+  =  tempLabelPrefixOrUnderscore <> pprUniqueAlways u++pprCLabel dynFlags (AsmTempLabel u)+ | not (platformUnregisterised $ targetPlatform dynFlags)+  =  tempLabelPrefixOrUnderscore <> pprUniqueAlways u++pprCLabel dynFlags (AsmTempDerivedLabel l suf)+ | sGhcWithNativeCodeGen $ settings dynFlags+   = ptext (asmTempLabelPrefix $ targetPlatform dynFlags)+     <> case l of AsmTempLabel u    -> pprUniqueAlways u+                  LocalBlockLabel u -> pprUniqueAlways u+                  _other            -> pprCLabel dynFlags l+     <> ftext suf++pprCLabel dynFlags (DynamicLinkerLabel info lbl)+ | sGhcWithNativeCodeGen $ settings dynFlags+   = pprDynamicLinkerAsmLabel (targetPlatform dynFlags) info lbl++pprCLabel dynFlags PicBaseLabel+ | sGhcWithNativeCodeGen $ settings dynFlags+   = text "1b"++pprCLabel dynFlags (DeadStripPreventer lbl)+ | sGhcWithNativeCodeGen $ settings dynFlags+   =+   {-+      `lbl` can be temp one but we need to ensure that dsp label will stay+      in the final binary so we prepend non-temp prefix ("dsp_") and+      optional `_` (underscore) because this is how you mark non-temp symbols+      on some platforms (Darwin)+   -}+   maybe_underscore dynFlags $ text "dsp_"+   <> pprCLabel dynFlags lbl <> text "_dsp"++pprCLabel dynFlags (StringLitLabel u)+ | sGhcWithNativeCodeGen $ settings dynFlags+  = pprUniqueAlways u <> ptext (sLit "_str")++pprCLabel dynFlags lbl+   = getPprStyle $ \ sty ->+     if sGhcWithNativeCodeGen (settings dynFlags) && asmStyle sty+     then maybe_underscore dynFlags $ pprAsmCLbl (targetPlatform dynFlags) lbl+     else pprCLbl lbl++maybe_underscore :: DynFlags -> SDoc -> SDoc+maybe_underscore dynFlags doc =+  if sLeadingUnderscore $ settings dynFlags+  then pp_cSEP <> doc+  else doc++pprAsmCLbl :: Platform -> CLabel -> SDoc+pprAsmCLbl platform (ForeignLabel fs (Just sz) _ _)+ | platformOS platform == OSMinGW32+    -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.+    -- (The C compiler does this itself).+    = ftext fs <> char '@' <> int sz+pprAsmCLbl _ lbl+   = pprCLbl lbl++pprCLbl :: CLabel -> SDoc+pprCLbl (StringLitLabel u)+  = pprUniqueAlways u <> text "_str"++pprCLbl (SRTLabel u)+  = tempLabelPrefixOrUnderscore <> pprUniqueAlways u <> pp_cSEP <> text "srt"++pprCLbl (LargeBitmapLabel u)  =+  tempLabelPrefixOrUnderscore+  <> char 'b' <> pprUniqueAlways u <> pp_cSEP <> text "btm"+-- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')+-- until that gets resolved we'll just force them to start+-- with a letter so the label will be legal assembly code.+++pprCLbl (CmmLabel _ str CmmCode)        = ftext str+pprCLbl (CmmLabel _ str CmmData)        = ftext str+pprCLbl (CmmLabel _ str CmmPrimCall)    = ftext str++pprCLbl (LocalBlockLabel u)             =+    tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u++pprCLbl (RtsLabel (RtsApFast str))   = ftext str <> text "_fast"++pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))+  = sdocWithDynFlags $ \dflags ->+    ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)+    hcat [text "stg_sel_", text (show offset),+          ptext (if upd_reqd+                 then (sLit "_upd_info")+                 else (sLit "_noupd_info"))+        ]++pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))+  = sdocWithDynFlags $ \dflags ->+    ASSERT(offset >= 0 && offset <= mAX_SPEC_SELECTEE_SIZE dflags)+    hcat [text "stg_sel_", text (show offset),+                ptext (if upd_reqd+                        then (sLit "_upd_entry")+                        else (sLit "_noupd_entry"))+        ]++pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity))+  = sdocWithDynFlags $ \dflags ->+    ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)+    hcat [text "stg_ap_", text (show arity),+                ptext (if upd_reqd+                        then (sLit "_upd_info")+                        else (sLit "_noupd_info"))+        ]++pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))+  = sdocWithDynFlags $ \dflags ->+    ASSERT(arity > 0 && arity <= mAX_SPEC_AP_SIZE dflags)+    hcat [text "stg_ap_", text (show arity),+                ptext (if upd_reqd+                        then (sLit "_upd_entry")+                        else (sLit "_noupd_entry"))+        ]++pprCLbl (CmmLabel _ fs CmmInfo)+  = ftext fs <> text "_info"++pprCLbl (CmmLabel _ fs CmmEntry)+  = ftext fs <> text "_entry"++pprCLbl (CmmLabel _ fs CmmRetInfo)+  = ftext fs <> text "_info"++pprCLbl (CmmLabel _ fs CmmRet)+  = ftext fs <> text "_ret"++pprCLbl (CmmLabel _ fs CmmClosure)+  = ftext fs <> text "_closure"++pprCLbl (RtsLabel (RtsPrimOp primop))+  = text "stg_" <> ppr primop++pprCLbl (RtsLabel (RtsSlowFastTickyCtr pat))+  = text "SLOW_CALL_fast_" <> text pat <> ptext (sLit "_ctr")++pprCLbl (ForeignLabel str _ _ _)+  = ftext str++pprCLbl (IdLabel name _cafs flavor) =+  internalNamePrefix name <> ppr name <> ppIdFlavor flavor++pprCLbl (CC_Label cc)           = ppr cc+pprCLbl (CCS_Label ccs)         = ppr ccs++pprCLbl (HpcTicksLabel mod)+  = text "_hpc_tickboxes_"  <> ppr mod <> ptext (sLit "_hpc")++pprCLbl (AsmTempLabel {})       = panic "pprCLbl AsmTempLabel"+pprCLbl (AsmTempDerivedLabel {})= panic "pprCLbl AsmTempDerivedLabel"+pprCLbl (DynamicLinkerLabel {}) = panic "pprCLbl DynamicLinkerLabel"+pprCLbl (PicBaseLabel {})       = panic "pprCLbl PicBaseLabel"+pprCLbl (DeadStripPreventer {}) = panic "pprCLbl DeadStripPreventer"++ppIdFlavor :: IdLabelInfo -> SDoc+ppIdFlavor x = pp_cSEP <> text+               (case x of+                       Closure          -> "closure"+                       InfoTable        -> "info"+                       LocalInfoTable   -> "info"+                       Entry            -> "entry"+                       LocalEntry       -> "entry"+                       Slow             -> "slow"+                       RednCounts       -> "ct"+                       ConEntry         -> "con_entry"+                       ConInfoTable     -> "con_info"+                       ClosureTable     -> "closure_tbl"+                       Bytes            -> "bytes"+                       BlockInfoTable   -> "info"+                      )+++pp_cSEP :: SDoc+pp_cSEP = char '_'+++instance Outputable ForeignLabelSource where+ ppr fs+  = case fs of+        ForeignLabelInPackage pkgId     -> parens $ text "package: " <> ppr pkgId+        ForeignLabelInThisPackage       -> parens $ text "this package"+        ForeignLabelInExternalPackage   -> parens $ text "external package"++internalNamePrefix :: Name -> SDoc+internalNamePrefix name = getPprStyle $ \ sty ->+  if asmStyle sty && isRandomGenerated then+    sdocWithPlatform $ \platform ->+      ptext (asmTempLabelPrefix platform)+  else+    empty+  where+    isRandomGenerated = not $ isExternalName name++tempLabelPrefixOrUnderscore :: SDoc+tempLabelPrefixOrUnderscore = sdocWithPlatform $ \platform ->+  getPprStyle $ \ sty ->+   if asmStyle sty then+      ptext (asmTempLabelPrefix platform)+   else+      char '_'++-- -----------------------------------------------------------------------------+-- Machine-dependent knowledge about labels.++asmTempLabelPrefix :: Platform -> PtrString  -- for formatting labels+asmTempLabelPrefix platform = case platformOS platform of+    OSDarwin -> sLit "L"+    OSAIX    -> sLit "__L" -- follow IBM XL C's convention+    _        -> sLit ".L"++pprDynamicLinkerAsmLabel :: Platform -> DynamicLinkerLabelInfo -> CLabel -> SDoc+pprDynamicLinkerAsmLabel platform dllInfo lbl =+    case platformOS platform of+      OSDarwin+        | platformArch platform == ArchX86_64 ->+          case dllInfo of+            CodeStub        -> char 'L' <> ppr lbl <> text "$stub"+            SymbolPtr       -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"+            GotSymbolPtr    -> ppr lbl <> text "@GOTPCREL"+            GotSymbolOffset -> ppr lbl+        | otherwise ->+          case dllInfo of+            CodeStub  -> char 'L' <> ppr lbl <> text "$stub"+            SymbolPtr -> char 'L' <> ppr lbl <> text "$non_lazy_ptr"+            _         -> panic "pprDynamicLinkerAsmLabel"++      OSAIX ->+          case dllInfo of+            SymbolPtr -> text "LC.." <> ppr lbl -- GCC's naming convention+            _         -> panic "pprDynamicLinkerAsmLabel"++      _ | osElfTarget (platformOS platform) -> elfLabel++      OSMinGW32 ->+          case dllInfo of+            SymbolPtr -> text "__imp_" <> ppr lbl+            _         -> panic "pprDynamicLinkerAsmLabel"++      _ -> panic "pprDynamicLinkerAsmLabel"+  where+    elfLabel+      | platformArch platform == ArchPPC+      = case dllInfo of+          CodeStub  -> -- See Note [.LCTOC1 in PPC PIC code]+                       ppr lbl <> text "+32768@plt"+          SymbolPtr -> text ".LC_" <> ppr lbl+          _         -> panic "pprDynamicLinkerAsmLabel"++      | platformArch platform == ArchX86_64+      = case dllInfo of+          CodeStub        -> ppr lbl <> text "@plt"+          GotSymbolPtr    -> ppr lbl <> text "@gotpcrel"+          GotSymbolOffset -> ppr lbl+          SymbolPtr       -> text ".LC_" <> ppr lbl++      | platformArch platform == ArchPPC_64 ELF_V1+        || platformArch platform == ArchPPC_64 ELF_V2+      = case dllInfo of+          GotSymbolPtr    -> text ".LC_"  <> ppr lbl+                                  <> text "@toc"+          GotSymbolOffset -> ppr lbl+          SymbolPtr       -> text ".LC_" <> ppr lbl+          _               -> panic "pprDynamicLinkerAsmLabel"++      | otherwise+      = case dllInfo of+          CodeStub        -> ppr lbl <> text "@plt"+          SymbolPtr       -> text ".LC_" <> ppr lbl+          GotSymbolPtr    -> ppr lbl <> text "@got"+          GotSymbolOffset -> ppr lbl <> text "@gotoff"++-- Figure out whether `symbol` may serve as an alias+-- to `target` within one compilation unit.+--+-- This is true if any of these holds:+-- * `target` is a module-internal haskell name.+-- * `target` is an exported name, but comes from the same+--   module as `symbol`+--+-- These are sufficient conditions for establishing e.g. a+-- GNU assembly alias ('.equiv' directive). Sadly, there is+-- no such thing as an alias to an imported symbol (conf.+-- http://blog.omega-prime.co.uk/2011/07/06/the-sad-state-of-symbol-aliases/)+-- See note [emit-time elimination of static indirections].+--+-- Precondition is that both labels represent the+-- same semantic value.++mayRedirectTo :: CLabel -> CLabel -> Bool+mayRedirectTo symbol target+ | Just nam <- haskellName+ , staticClosureLabel+ , isExternalName nam+ , Just mod <- nameModule_maybe nam+ , Just anam <- hasHaskellName symbol+ , Just amod <- nameModule_maybe anam+ = amod == mod++ | Just nam <- haskellName+ , staticClosureLabel+ , isInternalName nam+ = True++ | otherwise = False+   where staticClosureLabel = isStaticClosureLabel target+         haskellName = hasHaskellName target+++{-+Note [emit-time elimination of static indirections]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As described in #15155, certain static values are repesentationally+equivalent, e.g. 'cast'ed values (when created by 'newtype' wrappers).++             newtype A = A Int+             {-# NOINLINE a #-}+             a = A 42++a1_rYB :: Int+[GblId, Caf=NoCafRefs, Unf=OtherCon []]+a1_rYB = GHC.Types.I# 42#++a [InlPrag=NOINLINE] :: A+[GblId, Unf=OtherCon []]+a = a1_rYB `cast` (Sym (T15155.N:A[0]) :: Int ~R# A)++Formerly we created static indirections for these (IND_STATIC), which+consist of a statically allocated forwarding closure that contains+the (possibly tagged) indirectee. (See CMM/assembly below.)+This approach is suboptimal for two reasons:+  (a) they occupy extra space,+  (b) they need to be entered in order to obtain the indirectee,+      thus they cannot be tagged.++Fortunately there is a common case where static indirections can be+eliminated while emitting assembly (native or LLVM), viz. when the+indirectee is in the same module (object file) as the symbol that+points to it. In this case an assembly-level identification can+be created ('.equiv' directive), and as such the same object will+be assigned two names in the symbol table. Any of the identified+symbols can be referenced by a tagged pointer.++Currently the 'mayRedirectTo' predicate will+give a clue whether a label can be equated with another, already+emitted, label (which can in turn be an alias). The general mechanics+is that we identify data (IND_STATIC closures) that are amenable+to aliasing while pretty-printing of assembly output, and emit the+'.equiv' directive instead of static data in such a case.++Here is a sketch how the output is massaged:++                     Consider+newtype A = A Int+{-# NOINLINE a #-}+a = A 42                                -- I# 42# is the indirectee+                                        -- 'a' is exported++                 results in STG++a1_rXq :: GHC.Types.Int+[GblId, Caf=NoCafRefs, Unf=OtherCon []] =+    CCS_DONT_CARE GHC.Types.I#! [42#];++T15155.a [InlPrag=NOINLINE] :: T15155.A+[GblId, Unf=OtherCon []] =+    CAF_ccs  \ u  []  a1_rXq;++                 and CMM++[section ""data" . a1_rXq_closure" {+     a1_rXq_closure:+         const GHC.Types.I#_con_info;+         const 42;+ }]++[section ""data" . T15155.a_closure" {+     T15155.a_closure:+         const stg_IND_STATIC_info;+         const a1_rXq_closure+1;+         const 0;+         const 0;+ }]++The emitted assembly is++#### INDIRECTEE+a1_rXq_closure:                         -- module local haskell value+        .quad   GHC.Types.I#_con_info   -- an Int+        .quad   42++#### BEFORE+.globl T15155.a_closure                 -- exported newtype wrapped value+T15155.a_closure:+        .quad   stg_IND_STATIC_info     -- the closure info+        .quad   a1_rXq_closure+1        -- indirectee ('+1' being the tag)+        .quad   0+        .quad   0++#### AFTER+.globl T15155.a_closure                 -- exported newtype wrapped value+.equiv a1_rXq_closure,T15155.a_closure  -- both are shared++The transformation is performed because+     T15155.a_closure `mayRedirectTo` a1_rXq_closure+1+returns True.+-}
+ compiler/cmm/Cmm.hs view
@@ -0,0 +1,229 @@+-- Cmm representations using Hoopl's Graph CmmNode e x.+{-# LANGUAGE GADTs #-}++module Cmm (+     -- * Cmm top-level datatypes+     CmmProgram, CmmGroup, GenCmmGroup,+     CmmDecl, GenCmmDecl(..),+     CmmGraph, GenCmmGraph(..),+     CmmBlock,+     RawCmmDecl, RawCmmGroup,+     Section(..), SectionType(..), CmmStatics(..), CmmStatic(..),+     isSecConstant,++     -- ** Blocks containing lists+     GenBasicBlock(..), blockId,+     ListGraph(..), pprBBlock,++     -- * Info Tables+     CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,+     ClosureTypeInfo(..),+     ProfilingInfo(..), ConstrDescription,++     -- * Statements, expressions and types+     module CmmNode,+     module CmmExpr,+  ) where++import GhcPrelude++import Id+import CostCentre+import CLabel+import BlockId+import CmmNode+import SMRep+import CmmExpr+import Hoopl.Block+import Hoopl.Collections+import Hoopl.Graph+import Hoopl.Label+import Outputable+import Data.ByteString (ByteString)++-----------------------------------------------------------------------------+--  Cmm, GenCmm+-----------------------------------------------------------------------------++-- A CmmProgram is a list of CmmGroups+-- A CmmGroup is a list of top-level declarations++-- When object-splitting is on, each group is compiled into a separate+-- .o file. So typically we put closely related stuff in a CmmGroup.+-- Section-splitting follows suit and makes one .text subsection for each+-- CmmGroup.++type CmmProgram = [CmmGroup]++type GenCmmGroup d h g = [GenCmmDecl d h g]+type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph+type RawCmmGroup = GenCmmGroup CmmStatics (LabelMap CmmStatics) CmmGraph++-----------------------------------------------------------------------------+--  CmmDecl, GenCmmDecl+-----------------------------------------------------------------------------++-- GenCmmDecl is abstracted over+--   d, the type of static data elements in CmmData+--   h, the static info preceding the code of a CmmProc+--   g, the control-flow graph of a CmmProc+--+-- We expect there to be two main instances of this type:+--   (a) C--, i.e. populated with various C-- constructs+--   (b) Native code, populated with data/instructions++-- | A top-level chunk, abstracted over the type of the contents of+-- the basic blocks (Cmm or instructions are the likely instantiations).+data GenCmmDecl d h g+  = CmmProc     -- A procedure+     h                 -- Extra header such as the info table+     CLabel            -- Entry label+     [GlobalReg]       -- Registers live on entry. Note that the set of live+                       -- registers will be correct in generated C-- code, but+                       -- not in hand-written C-- code. However,+                       -- splitAtProcPoints calculates correct liveness+                       -- information for CmmProcs.+     g                 -- Control-flow graph for the procedure's code++  | CmmData     -- Static data+        Section+        d++type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph++type RawCmmDecl+   = GenCmmDecl+        CmmStatics+        (LabelMap CmmStatics)+        CmmGraph++-----------------------------------------------------------------------------+--     Graphs+-----------------------------------------------------------------------------++type CmmGraph = GenCmmGraph CmmNode+data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }+type CmmBlock = Block CmmNode C C++-----------------------------------------------------------------------------+--     Info Tables+-----------------------------------------------------------------------------++data CmmTopInfo   = TopInfo { info_tbls  :: LabelMap CmmInfoTable+                            , stack_info :: CmmStackInfo }++topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable+topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos)+topInfoTable _                     = Nothing++data CmmStackInfo+   = StackInfo {+       arg_space :: ByteOff,+               -- number of bytes of arguments on the stack on entry to the+               -- the proc.  This is filled in by StgCmm.codeGen, and used+               -- by the stack allocator later.+       updfr_space :: Maybe ByteOff,+               -- XXX: this never contains anything useful, but it should.+               -- See comment in CmmLayoutStack.+       do_layout :: Bool+               -- Do automatic stack layout for this proc.  This is+               -- True for all code generated by the code generator,+               -- but is occasionally False for hand-written Cmm where+               -- we want to do the stack manipulation manually.+  }++-- | Info table as a haskell data type+data CmmInfoTable+  = CmmInfoTable {+      cit_lbl  :: CLabel, -- Info table label+      cit_rep  :: SMRep,+      cit_prof :: ProfilingInfo,+      cit_srt  :: Maybe CLabel,   -- empty, or a closure address+      cit_clo  :: Maybe (Id, CostCentreStack)+        -- Just (id,ccs) <=> build a static closure later+        -- Nothing <=> don't build a static closure+        --+        -- Static closures for FUNs and THUNKs are *not* generated by+        -- the code generator, because we might want to add SRT+        -- entries to them later (for FUNs at least; THUNKs are+        -- treated the same for consistency). See Note [SRTs] in+        -- CmmBuildInfoTables, in particular the [FUN] optimisation.+        --+        -- This is strictly speaking not a part of the info table that+        -- will be finally generated, but it's the only convenient+        -- place to convey this information from the code generator to+        -- where we build the static closures in+        -- CmmBuildInfoTables.doSRTs.+    }++data ProfilingInfo+  = NoProfilingInfo+  | ProfilingInfo ByteString ByteString -- closure_type, closure_desc++-----------------------------------------------------------------------------+--              Static Data+-----------------------------------------------------------------------------++data SectionType+  = Text+  | Data+  | ReadOnlyData+  | RelocatableReadOnlyData+  | UninitialisedData+  | ReadOnlyData16      -- .rodata.cst16 on x86_64, 16-byte aligned+  | CString+  | OtherSection String+  deriving (Show)++-- | Should a data in this section be considered constant+isSecConstant :: Section -> Bool+isSecConstant (Section t _) = case t of+    Text                    -> True+    ReadOnlyData            -> True+    RelocatableReadOnlyData -> True+    ReadOnlyData16          -> True+    CString                 -> True+    Data                    -> False+    UninitialisedData       -> False+    (OtherSection _)        -> False++data Section = Section SectionType CLabel++data CmmStatic+  = CmmStaticLit CmmLit+        -- a literal value, size given by cmmLitRep of the literal.+  | CmmUninitialised Int+        -- uninitialised data, N bytes long+  | CmmString ByteString+        -- string of 8-bit values only, not zero terminated.++data CmmStatics+   = Statics+       CLabel      -- Label of statics+       [CmmStatic] -- The static data itself++-- -----------------------------------------------------------------------------+-- Basic blocks consisting of lists++-- These are used by the LLVM and NCG backends, when populating Cmm+-- with lists of instructions.++data GenBasicBlock i = BasicBlock BlockId [i]++-- | The branch block id is that of the first block in+-- the branch, which is that branch's entry point+blockId :: GenBasicBlock i -> BlockId+blockId (BasicBlock blk_id _ ) = blk_id++newtype ListGraph i = ListGraph [GenBasicBlock i]++instance Outputable instr => Outputable (ListGraph instr) where+    ppr (ListGraph blocks) = vcat (map ppr blocks)++instance Outputable instr => Outputable (GenBasicBlock instr) where+    ppr = pprBBlock++pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc+pprBBlock (BasicBlock ident stmts) =+    hang (ppr ident <> colon) 4 (vcat (map ppr stmts))+
+ compiler/cmm/CmmBuildInfoTables.hs view
@@ -0,0 +1,896 @@+{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,+    GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections #-}++module CmmBuildInfoTables+  ( CAFSet, CAFEnv, cafAnal+  , doSRTs, ModuleSRTInfo, emptySRT+  ) where++import GhcPrelude hiding (succ)++import Id+import BlockId+import Hoopl.Block+import Hoopl.Graph+import Hoopl.Label+import Hoopl.Collections+import Hoopl.Dataflow+import Module+import Platform+import Digraph+import CLabel+import PprCmmDecl ()+import Cmm+import CmmUtils+import DynFlags+import Maybes+import Outputable+import SMRep+import UniqSupply+import CostCentre+import StgCmmHeap++import PprCmm()+import Control.Monad+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Tuple+import Control.Monad.Trans.State+import Control.Monad.Trans.Class+++{- Note [SRTs]++SRTs are the mechanism by which the garbage collector can determine+the live CAFs in the program.++Representation+^^^^^^^^^^^^^^+++------++| info |+|      |     +-----+---+---+---++|   -------->|SRT_2| | | | | 0 |+|------|     +-----+-|-+-|-+---++|      |             |   |+| code |             |   |+|      |             v   v++An SRT is simply an object in the program's data segment. It has the+same representation as a static constructor.  There are 16+pre-compiled SRT info tables: stg_SRT_1_info, .. stg_SRT_16_info,+representing SRT objects with 1-16 pointers, respectively.++The entries of an SRT object point to static closures, which are either+- FUN_STATIC, THUNK_STATIC or CONSTR+- Another SRT (actually just a CONSTR)++The final field of the SRT is the static link field, used by the+garbage collector to chain together static closures that it visits and+to determine whether a static closure has been visited or not. (see+Note [STATIC_LINK fields])++By traversing the transitive closure of an SRT, the GC will reach all+of the CAFs that are reachable from the code associated with this SRT.++If we need to create an SRT with more than 16 entries, we build a+chain of SRT objects with all but the last having 16 entries.+++-----+---+- -+---+---++|SRT16| | |   | | | 0 |++-----+-|-+- -+-|-+---++        |       |+        v       v+              +----+---+---+---++              |SRT2| | | | | 0 |+              +----+-|-+-|-+---++                     |   |+                     |   |+                     v   v++Referring to an SRT from the info table+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^++The following things have SRTs:++- Static functions (FUN)+- Static thunks (THUNK), ie. CAFs+- Continuations (RET_SMALL, etc.)++In each case, the info table points to the SRT.++- info->srt is zero if there's no SRT, otherwise:+- info->srt == 1 and info->f.srt_offset points to the SRT++e.g. for a FUN with an SRT:++StgFunInfoTable       +------++  info->f.srt_offset  |  ------------> offset to SRT object+StgStdInfoTable       +------++  info->layout.ptrs   | ...  |+  info->layout.nptrs  | ...  |+  info->srt           |  1   |+  info->type          | ...  |+                      |------|++On x86_64, we optimise the info table representation further.  The+offset to the SRT can be stored in 32 bits (all code lives within a+2GB region in x86_64's small memory model), so we can save a word in+the info table by storing the srt_offset in the srt field, which is+half a word.++On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169):++- info->srt is zero if there's no SRT, otherwise:+- info->srt is an offset from the info pointer to the SRT object++StgStdInfoTable       +------++  info->layout.ptrs   |      |+  info->layout.nptrs  |      |+  info->srt           |  ------------> offset to SRT object+                      |------|+++EXAMPLE+^^^^^^^++f = \x. ... g ...+  where+    g = \y. ... h ... c1 ...+    h = \z. ... c2 ...++c1 & c2 are CAFs++g and h are local functions, but they have no static closures.  When+we generate code for f, we start with a CmmGroup of four CmmDecls:++   [ f_closure, f_entry, g_entry, h_entry ]++we process each CmmDecl separately in cpsTop, giving us a list of+CmmDecls. e.g. for f_entry, we might end up with++   [ f_entry, f1_ret, f2_proc ]++where f1_ret is a return point, and f2_proc is a proc-point.  We have+a CAFSet for each of these CmmDecls, let's suppose they are++   [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ]+   [ g_entry{h_info, c1_closure} ]+   [ h_entry{c2_closure} ]++Next, we make an SRT for each of these functions:++  f_srt : [g_info]+  g_srt : [h_info, c1_closure]+  h_srt : [c2_closure]++Now, for g_info and h_info, we want to refer to the SRTs for g and h+respectively, which we'll label g_srt and h_srt:++  f_srt : [g_srt]+  g_srt : [h_srt, c1_closure]+  h_srt : [c2_closure]++Now, when an SRT has a single entry, we don't actually generate an SRT+closure for it, instead we just replace references to it with its+single element.  So, since h_srt == c2_closure, we have++  f_srt : [g_srt]+  g_srt : [c2_closure, c1_closure]+  h_srt : [c2_closure]++and the only SRT closure we generate is++  g_srt = SRT_2 [c2_closure, c1_closure]+++Optimisations+^^^^^^^^^^^^^++To reduce the code size overhead and the cost of traversing SRTs in+the GC, we want to simplify SRTs where possible. We therefore apply+the following optimisations.  Each has a [keyword]; search for the+keyword in the code below to see where the optimisation is+implemented.++1. [Inline] we never create an SRT with a single entry, instead we+   point to the single entry directly from the info table.++   i.e. instead of++    +------++    | info |+    |      |     +-----+---+---++    |   -------->|SRT_1| | | 0 |+    |------|     +-----+-|-+---++    |      |             |+    | code |             |+    |      |             v+                         C++   we can point directly to the closure:++    +------++    | info |+    |      |+    |   -------->C+    |------|+    |      |+    | code |+    |      |+++   Furthermore, the SRT for any code that refers to this info table+   can point directly to C.++   The exception to this is when we're doing dynamic linking. In that+   case, if the closure is not locally defined then we can't point to+   it directly from the info table, because this is the text section+   which cannot contain runtime relocations. In this case we skip this+   optimisation and generate the singleton SRT, becase SRTs are in the+   data section and *can* have relocatable references.++2. [FUN] A static function closure can also be an SRT, we simply put+   the SRT entries as fields in the static closure.  This makes a lot+   of sense: the static references are just like the free variables of+   the FUN closure.++   i.e. instead of++   f_closure:+   +-----+---++   |  |  | 0 |+   +- |--+---++      |            +------++      |            | info |     f_srt:+      |            |      |     +-----+---+---+---++      |            |   -------->|SRT_2| | | | + 0 |+      `----------->|------|     +-----+-|-+-|-+---++                   |      |             |   |+                   | code |             |   |+                   |      |             v   v+++   We can generate:++   f_closure:+   +-----+---+---+---++   |  |  | | | | | 0 |+   +- |--+-|-+-|-+---++      |    |   |   +------++      |    v   v   | info |+      |            |      |+      |            |   0  |+      `----------->|------|+                   |      |+                   | code |+                   |      |+++   (note: we can't do this for THUNKs, because the thunk gets+   overwritten when it is entered, so we wouldn't be able to share+   this SRT with other info tables that want to refer to it (see+   [Common] below). FUNs are immutable so don't have this problem.)++3. [Common] Identical SRTs can be commoned up.++4. [Filter] If an SRT A refers to an SRT B and a closure C, and B also+   refers to C (perhaps transitively), then we can omit the reference+   to C from A.+++Note that there are many other optimisations that we could do, but+aren't implemented. In general, we could omit any reference from an+SRT if everything reachable from it is also reachable from the other+fields in the SRT. Our [Filter] optimisation is a special case of+this.++Another opportunity we don't exploit is this:++A = {X,Y,Z}+B = {Y,Z}+C = {X,B}++Here we could use C = {A} and therefore [Inline] C = A.+-}++-- ---------------------------------------------------------------------+{- Note [Invalid optimisation: shortcutting]++You might think that if we have something like++A's SRT = {B}+B's SRT = {X}++that we could replace the reference to B in A's SRT with X.++A's SRT = {X}+B's SRT = {X}++and thereby perhaps save a little work at runtime, because we don't+have to visit B.++But this is NOT valid.++Consider these cases:++0. B can't be a constructor, because constructors don't have SRTs++1. B is a CAF. This is the easy one. Obviously we want A's SRT to+   point to B, so that it keeps B alive.++2. B is a function.  This is the tricky one. The reason we can't+shortcut in this case is that we aren't allowed to resurrect static+objects.++== How does this cause a problem? ==++The particular case that cropped up when we tried this was #15544.+- A is a thunk+- B is a static function+- X is a CAF+- suppose we GC when A is alive, and B is not otherwise reachable.+- B is "collected", meaning that it doesn't make it onto the static+  objects list during this GC, but nothing bad happens yet.+- Next, suppose we enter A, and then call B. (remember that A refers to B)+  At the entry point to B, we GC. This puts B on the stack, as part of the+  RET_FUN stack frame that gets pushed when we GC at a function entry point.+- This GC will now reach B+- But because B was previous "collected", it breaks the assumption+  that static objects are never resurrected. See Note [STATIC_LINK+  fields] in rts/sm/Storage.h for why this is bad.+- In practice, the GC thinks that B has already been visited, and so+  doesn't visit X, and catastrophe ensues.++== Isn't this caused by the RET_FUN business? ==++Maybe, but could you prove that RET_FUN is the only way that+resurrection can occur?++So, no shortcutting.+-}++-- ---------------------------------------------------------------------+-- Label types++-- Labels that come from cafAnal can be:+--   - _closure labels for static functions or CAFs+--   - _info labels for dynamic functions, thunks, or continuations+--   - _entry labels for functions or thunks+--+-- Meanwhile the labels on top-level blocks are _entry labels.+--+-- To put everything in the same namespace we convert all labels to+-- closure labels using toClosureLbl.  Note that some of these+-- labels will not actually exist; that's ok because we're going to+-- map them to SRTEntry later, which ranges over labels that do exist.+--+newtype CAFLabel = CAFLabel CLabel+  deriving (Eq,Ord,Outputable)++type CAFSet = Set CAFLabel+type CAFEnv = LabelMap CAFSet++mkCAFLabel :: CLabel -> CAFLabel+mkCAFLabel lbl = CAFLabel (toClosureLbl lbl)++-- This is a label that we can put in an SRT.  It *must* be a closure label,+-- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.+newtype SRTEntry = SRTEntry CLabel+  deriving (Eq, Ord, Outputable)++-- ---------------------------------------------------------------------+-- CAF analysis++-- |+-- For each code block:+--   - collect the references reachable from this code block to FUN,+--     THUNK or RET labels for which hasCAF == True+--+-- This gives us a `CAFEnv`: a mapping from code block to sets of labels+--+cafAnal+  :: LabelSet   -- The blocks representing continuations, ie. those+                -- that will get RET info tables.  These labels will+                -- get their own SRTs, so we don't aggregate CAFs from+                -- references to these labels, we just use the label.+  -> CLabel     -- The top label of the proc+  -> CmmGraph+  -> CAFEnv+cafAnal contLbls topLbl cmmGraph =+  analyzeCmmBwd cafLattice+    (cafTransfers contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty+++cafLattice :: DataflowLattice CAFSet+cafLattice = DataflowLattice Set.empty add+  where+    add (OldFact old) (NewFact new) =+        let !new' = old `Set.union` new+        in changedIf (Set.size new' > Set.size old) new'+++cafTransfers :: LabelSet -> Label -> CLabel -> TransferFun CAFSet+cafTransfers contLbls entry topLbl+  (BlockCC eNode middle xNode) fBase =+    let joined = cafsInNode xNode $! live'+        !result = foldNodesBwdOO cafsInNode middle joined++        facts = mapMaybe successorFact (successors xNode)+        live' = joinFacts cafLattice facts++        successorFact s+          -- If this is a loop back to the entry, we can refer to the+          -- entry label.+          | s == entry = Just (add topLbl Set.empty)+          -- If this is a continuation, we want to refer to the+          -- SRT for the continuation's info table+          | s `setMember` contLbls+          = Just (Set.singleton (mkCAFLabel (infoTblLbl s)))+          -- Otherwise, takes the CAF references from the destination+          | otherwise+          = lookupFact s fBase++        cafsInNode :: CmmNode e x -> CAFSet -> CAFSet+        cafsInNode node set = foldExpDeep addCaf node set++        addCaf expr !set =+          case expr of+              CmmLit (CmmLabel c) -> add c set+              CmmLit (CmmLabelOff c _) -> add c set+              CmmLit (CmmLabelDiffOff c1 c2 _ _) -> add c1 $! add c2 set+              _ -> set+        add l s | hasCAF l  = Set.insert (mkCAFLabel l) s+                | otherwise = s++    in mapSingleton (entryLabel eNode) result+++-- -----------------------------------------------------------------------------+-- ModuleSRTInfo++data ModuleSRTInfo = ModuleSRTInfo+  { thisModule :: Module+    -- ^ Current module being compiled. Required for calling labelDynamic.+  , dedupSRTs :: Map (Set SRTEntry) SRTEntry+    -- ^ previous SRTs we've emitted, so we can de-duplicate.+    -- Used to implement the [Common] optimisation.+  , flatSRTs :: Map SRTEntry (Set SRTEntry)+    -- ^ The reverse mapping, so that we can remove redundant+    -- entries. e.g.  if we have an SRT [a,b,c], and we know that b+    -- points to [c,d], we can omit c and emit [a,b].+    -- Used to implement the [Filter] optimisation.+  }+instance Outputable ModuleSRTInfo where+  ppr ModuleSRTInfo{..} =+    text "ModuleSRTInfo:" <+> ppr dedupSRTs <+> ppr flatSRTs++emptySRT :: Module -> ModuleSRTInfo+emptySRT mod =+  ModuleSRTInfo+    { thisModule = mod+    , dedupSRTs = Map.empty+    , flatSRTs = Map.empty }++-- -----------------------------------------------------------------------------+-- Constructing SRTs++{- Implementation notes++- In each CmmDecl there is a mapping info_tbls from Label -> CmmInfoTable++- The entry in info_tbls corresponding to g_entry is the closure info+  table, the rest are continuations.++- Each entry in info_tbls possibly needs an SRT.  We need to make a+  label for each of these.++- We get the CAFSet for each entry from the CAFEnv++-}++-- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl,+--   where the label is+--   - the info label for a continuation or dynamic closure+--   - the closure label for a top-level function (not a CAF)+getLabelledBlocks :: CmmDecl -> [(Label, CAFLabel)]+getLabelledBlocks (CmmData _ _) = []+getLabelledBlocks (CmmProc top_info _ _ _) =+  [ (blockId, mkCAFLabel (cit_lbl info))+  | (blockId, info) <- mapToList (info_tbls top_info)+  , let rep = cit_rep info+  , not (isStaticRep rep) || not (isThunkRep rep)+  ]+++-- | Put the labelled blocks that we will be annotating with SRTs into+-- dependency order.  This is so that we can process them one at a+-- time, resolving references to earlier blocks to point to their+-- SRTs. CAFs themselves are not included here; see getCAFs below.+depAnalSRTs+  :: CAFEnv+  -> [CmmDecl]+  -> [SCC (Label, CAFLabel, Set CAFLabel)]+depAnalSRTs cafEnv decls =+  srtTrace "depAnalSRTs" (ppr graph) graph+ where+  labelledBlocks = concatMap getLabelledBlocks decls+  labelToBlock = Map.fromList (map swap labelledBlocks)+  graph = stronglyConnCompFromEdgedVerticesOrd+             [ let cafs' = Set.delete lbl cafs in+               DigraphNode (l,lbl,cafs') l+                 (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))+             | (l, lbl) <- labelledBlocks+             , Just cafs <- [mapLookup l cafEnv] ]+++-- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF.+-- These are treated differently from other labelled blocks:+--  - we never shortcut a reference to a CAF to the contents of its+--    SRT, since the point of SRTs is to keep CAFs alive.+--  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.+--    instead we generate their SRTs after everything else.+getCAFs :: CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]+getCAFs cafEnv decls =+  [ (g_entry g, mkCAFLabel topLbl, cafs)+  | CmmProc top_info topLbl _ g <- decls+  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]+  , let rep = cit_rep info+  , isStaticRep rep && isThunkRep rep+  , Just cafs <- [mapLookup (g_entry g) cafEnv]+  ]+++-- | Get the list of blocks that correspond to the entry points for+-- FUN_STATIC closures.  These are the blocks for which if we have an+-- SRT we can merge it with the static closure. [FUN]+getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)]+getStaticFuns decls =+  [ (g_entry g, lbl)+  | CmmProc top_info _ _ g <- decls+  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]+  , Just (id, _) <- [cit_clo info]+  , let rep = cit_rep info+  , isStaticRep rep && isFunRep rep+  , let lbl = mkLocalClosureLabel (idName id) (idCafInfo id)+  ]+++-- | Maps labels from 'cafAnal' to the final CLabel that will appear+-- in the SRT.+--   - closures with singleton SRTs resolve to their single entry+--   - closures with larger SRTs map to the label for that SRT+--   - CAFs must not map to anything!+--   - if a labels maps to Nothing, we found that this label's SRT+--     is empty, so we don't need to refer to it from other SRTs.+type SRTMap = Map CAFLabel (Maybe SRTEntry)++-- | resolve a CAFLabel to its SRTEntry using the SRTMap+resolveCAF :: SRTMap -> CAFLabel -> Maybe SRTEntry+resolveCAF srtMap lbl@(CAFLabel l) =+  Map.findWithDefault (Just (SRTEntry (toClosureLbl l))) lbl srtMap+++-- | Attach SRTs to all info tables in the CmmDecls, and add SRT+-- declarations to the ModuleSRTInfo.+--+doSRTs+  :: DynFlags+  -> ModuleSRTInfo+  -> [(CAFEnv, [CmmDecl])]+  -> IO (ModuleSRTInfo, [CmmDecl])++doSRTs dflags moduleSRTInfo tops = do+  us <- mkSplitUniqSupply 'u'++  -- Ignore the original grouping of decls, and combine all the+  -- CAFEnvs into a single CAFEnv.+  let (cafEnvs, declss) = unzip tops+      cafEnv = mapUnions cafEnvs+      decls = concat declss+      staticFuns = mapFromList (getStaticFuns decls)++  -- Put the decls in dependency order. Why? So that we can implement+  -- [Inline] and [Filter].  If we need to refer to an SRT that has+  -- a single entry, we use the entry itself, which means that we+  -- don't need to generate the singleton SRT in the first place.  But+  -- to do this we need to process blocks before things that depend on+  -- them.+  let+    sccs = depAnalSRTs cafEnv decls+    cafsWithSRTs = getCAFs cafEnv decls++  -- On each strongly-connected group of decls, construct the SRT+  -- closures and the SRT fields for info tables.+  let result ::+        [ ( [CmmDecl]              -- generated SRTs+          , [(Label, CLabel)]      -- SRT fields for info tables+          , [(Label, [SRTEntry])]  -- SRTs to attach to static functions+          ) ]+      ((result, _srtMap), moduleSRTInfo') =+        initUs_ us $+        flip runStateT moduleSRTInfo $+        flip runStateT Map.empty $ do+          nonCAFs <- mapM (doSCC dflags staticFuns) sccs+          cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->+            oneSRT dflags staticFuns [l] [cafLbl] True{-is a CAF-} cafs+          return (nonCAFs ++ cAFs)++      (declss, pairs, funSRTs) = unzip3 result++  -- Next, update the info tables with the SRTs+  let+    srtFieldMap = mapFromList (concat pairs)+    funSRTMap = mapFromList (concat funSRTs)+    decls' = concatMap (updInfoSRTs dflags srtFieldMap funSRTMap) decls++  return (moduleSRTInfo', concat declss ++ decls')+++-- | Build the SRT for a strongly-connected component of blocks+doSCC+  :: DynFlags+  -> LabelMap CLabel           -- which blocks are static function entry points+  -> SCC (Label, CAFLabel, Set CAFLabel)+  -> StateT SRTMap+        (StateT ModuleSRTInfo UniqSM)+        ( [CmmDecl]              -- generated SRTs+        , [(Label, CLabel)]      -- SRT fields for info tables+        , [(Label, [SRTEntry])]  -- SRTs to attach to static functions+        )++doSCC dflags staticFuns  (AcyclicSCC (l, cafLbl, cafs)) =+  oneSRT dflags staticFuns [l] [cafLbl] False cafs++doSCC dflags staticFuns (CyclicSCC nodes) = do+  -- build a single SRT for the whole cycle, see Note [recursive SRTs]+  let (blockids, lbls, cafsets) = unzip3 nodes+      cafs = Set.unions cafsets+  oneSRT dflags staticFuns blockids lbls False cafs+++{- Note [recursive SRTs]++If the dependency analyser has found us a recursive group of+declarations, then we build a single SRT for the whole group, on the+grounds that everything in the group is reachable from everything+else, so we lose nothing by having a single SRT.++However, there are a couple of wrinkles to be aware of.++* The Set CAFLabel for this SRT will contain labels in the group+itself. The SRTMap will therefore not contain entries for these labels+yet, so we can't turn them into SRTEntries using resolveCAF. BUT we+can just remove recursive references from the Set CAFLabel before+generating the SRT - the SRT will still contain all the CAFLabels that+we need to refer to from this group's SRT.++* That is, EXCEPT for static function closures. For the same reason+described in Note [Invalid optimisation: shortcutting], we cannot omit+references to static function closures.+  - But, since we will merge the SRT with one of the static function+    closures (see [FUN]), we can omit references to *that* static+    function closure from the SRT.+-}++-- | Build an SRT for a set of blocks+oneSRT+  :: DynFlags+  -> LabelMap CLabel            -- which blocks are static function entry points+  -> [Label]                    -- blocks in this set+  -> [CAFLabel]                 -- labels for those blocks+  -> Bool                       -- True <=> this SRT is for a CAF+  -> Set CAFLabel               -- SRT for this set+  -> StateT SRTMap+       (StateT ModuleSRTInfo UniqSM)+       ( [CmmDecl]                    -- SRT objects we built+       , [(Label, CLabel)]            -- SRT fields for these blocks' itbls+       , [(Label, [SRTEntry])]        -- SRTs to attach to static functions+       )++oneSRT dflags staticFuns blockids lbls isCAF cafs = do+  srtMap <- get+  topSRT <- lift get+  let+    -- Can we merge this SRT with a FUN_STATIC closure?+    (maybeFunClosure, otherFunLabels) =+      case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of+        [] -> (Nothing, [])+        ((l,b):xs) -> (Just (l,b), map (mkCAFLabel . fst) xs)++    -- Remove recursive references from the SRT, except for (all but+    -- one of the) static functions. See Note [recursive SRTs].+    nonRec = cafs `Set.difference`+      (Set.fromList lbls `Set.difference` Set.fromList otherFunLabels)++    -- First resolve all the CAFLabels to SRTEntries+    -- Implements the [Inline] optimisation.+    resolved =+       Set.fromList $+       catMaybes (map (resolveCAF srtMap) (Set.toList nonRec))++    -- The set of all SRTEntries in SRTs that we refer to from here.+    allBelow =+      Set.unions [ lbls | caf <- Set.toList resolved+                        , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ]++    -- Remove SRTEntries that are also in an SRT that we refer to.+    -- Implements the [Filter] optimisation.+    filtered = Set.difference resolved allBelow++  srtTrace "oneSRT:"+     (ppr cafs <+> ppr resolved <+> ppr allBelow <+> ppr filtered) $ return ()++  let+    isStaticFun = isJust maybeFunClosure++    -- For a label without a closure (e.g. a continuation), we must+    -- update the SRTMap for the label to point to a closure. It's+    -- important that we don't do this for static functions or CAFs,+    -- see Note [Invalid optimisation: shortcutting].+    updateSRTMap srtEntry =+      when (not isCAF && not isStaticFun) $ do+        let newSRTMap = Map.fromList [(cafLbl, srtEntry) | cafLbl <- lbls]+        put (Map.union newSRTMap srtMap)++    this_mod = thisModule topSRT++  case Set.toList filtered of+    [] -> do+      srtTrace "oneSRT: empty" (ppr lbls) $ return ()+      updateSRTMap Nothing+      return ([], [], [])++    -- [Inline] - when we have only one entry there is no need to+    -- build an SRT object at all, instead we put the singleton SRT+    -- entry in the info table.+    [one@(SRTEntry lbl)]+      | -- Info tables refer to SRTs by offset (as noted in the section+        -- "Referring to an SRT from the info table" of Note [SRTs]). However,+        -- when dynamic linking is used we cannot guarantee that the offset+        -- between the SRT and the info table will fit in the offset field.+        -- Consequently we build a singleton SRT in in this case.+        not (labelDynamic dflags this_mod lbl)++        -- MachO relocations can't express offsets between compilation units at+        -- all, so we are always forced to build a singleton SRT in this case.+          && (not (osMachOTarget $ platformOS $ targetPlatform dflags)+             || isLocalCLabel this_mod lbl) -> do++        -- If we have a static function closure, then it becomes the+        -- SRT object, and everything else points to it. (the only way+        -- we could have multiple labels here is if this is a+        -- recursive group, see Note [recursive SRTs])+        case maybeFunClosure of+          Just (staticFunLbl,staticFunBlock) -> return ([], withLabels, [])+            where+              withLabels =+                [ (b, if b == staticFunBlock then lbl else staticFunLbl)+                | b <- blockids ]+          Nothing -> do+            updateSRTMap (Just one)+            return ([], map (,lbl) blockids, [])++    cafList ->+      -- Check whether an SRT with the same entries has been emitted already.+      -- Implements the [Common] optimisation.+      case Map.lookup filtered (dedupSRTs topSRT) of+        Just srtEntry@(SRTEntry srtLbl)  -> do+          srtTrace "oneSRT [Common]" (ppr lbls <+> ppr srtLbl) $ return ()+          updateSRTMap (Just srtEntry)+          return ([], map (,srtLbl) blockids, [])+        Nothing -> do+          -- No duplicates: we have to build a new SRT object+          srtTrace "oneSRT: new" (ppr lbls <+> ppr filtered) $ return ()+          (decls, funSRTs, srtEntry) <-+            case maybeFunClosure of+              Just (fun,block) ->+                return ( [], [(block, cafList)], SRTEntry fun )+              Nothing -> do+                (decls, entry) <- lift . lift $ buildSRTChain dflags cafList+                return (decls, [], entry)+          updateSRTMap (Just srtEntry)+          let allBelowThis = Set.union allBelow filtered+              oldFlatSRTs = flatSRTs topSRT+              newFlatSRTs = Map.insert srtEntry allBelowThis oldFlatSRTs+              newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT)+          lift (put (topSRT { dedupSRTs = newDedupSRTs+                            , flatSRTs = newFlatSRTs }))+          let SRTEntry lbl = srtEntry+          return (decls, map (,lbl) blockids, funSRTs)+++-- | build a static SRT object (or a chain of objects) from a list of+-- SRTEntries.+buildSRTChain+   :: DynFlags+   -> [SRTEntry]+   -> UniqSM+        ( [CmmDecl]    -- The SRT object(s)+        , SRTEntry     -- label to use in the info table+        )+buildSRTChain _ [] = panic "buildSRT: empty"+buildSRTChain dflags cafSet =+  case splitAt mAX_SRT_SIZE cafSet of+    (these, []) -> do+      (decl,lbl) <- buildSRT dflags these+      return ([decl], lbl)+    (these,those) -> do+      (rest, rest_lbl) <- buildSRTChain dflags (head these : those)+      (decl,lbl) <- buildSRT dflags (rest_lbl : tail these)+      return (decl:rest, lbl)+  where+    mAX_SRT_SIZE = 16+++buildSRT :: DynFlags -> [SRTEntry] -> UniqSM (CmmDecl, SRTEntry)+buildSRT dflags refs = do+  id <- getUniqueM+  let+    lbl = mkSRTLabel id+    srt_n_info = mkSRTInfoLabel (length refs)+    fields =+      mkStaticClosure dflags srt_n_info dontCareCCS+        [ CmmLabel lbl | SRTEntry lbl <- refs ]+        [] -- no padding+        [mkIntCLit dflags 0] -- link field+        [] -- no saved info+  return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)+++-- | Update info tables with references to their SRTs. Also generate+-- static closures, splicing in SRT fields as necessary.+updInfoSRTs+  :: DynFlags+  -> LabelMap CLabel               -- SRT labels for each block+  -> LabelMap [SRTEntry]           -- SRTs to merge into FUN_STATIC closures+  -> CmmDecl+  -> [CmmDecl]++updInfoSRTs dflags srt_env funSRTEnv (CmmProc top_info top_l live g)+  | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]+  | otherwise = [ proc ]+  where+    proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g+    newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info)+    updInfoTbl l info_tbl+      | l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf+      | otherwise  = info_tbl { cit_srt = mapLookup l srt_env }++    -- Generate static closures [FUN].  Note that this also generates+    -- static closures for thunks (CAFs), because it's easier to treat+    -- them uniformly in the code generator.+    maybeStaticClosure :: Maybe (CmmInfoTable, CmmDecl)+    maybeStaticClosure+      | Just info_tbl@CmmInfoTable{..} <-+           mapLookup (g_entry g) (info_tbls top_info)+      , Just (id, ccs) <- cit_clo+      , isStaticRep cit_rep =+        let+          (newInfo, srtEntries) = case mapLookup (g_entry g) funSRTEnv of+            Nothing ->+              -- if we don't add SRT entries to this closure, then we+              -- want to set the srt field in its info table as usual+              (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, [])+            Just srtEntries -> srtTrace "maybeStaticFun" (ppr res)+              (info_tbl { cit_rep = new_rep }, res)+              where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]+          fields = mkStaticClosureFields dflags info_tbl ccs (idCafInfo id)+            srtEntries+          new_rep = case cit_rep of+             HeapRep sta ptrs nptrs ty ->+               HeapRep sta (ptrs + length srtEntries) nptrs ty+             _other -> panic "maybeStaticFun"+          lbl = mkLocalClosureLabel (idName id) (idCafInfo id)+        in+          Just (newInfo, mkDataLits (Section Data lbl) lbl fields)+      | otherwise = Nothing++updInfoSRTs _ _ _ t = [t]+++srtTrace :: String -> SDoc -> b -> b+-- srtTrace = pprTrace+srtTrace _ _ b = b
+ compiler/cmm/CmmCallConv.hs view
@@ -0,0 +1,212 @@+module CmmCallConv (+  ParamLocation(..),+  assignArgumentsPos,+  assignStack,+  realArgRegsCover+) where++import GhcPrelude++import CmmExpr+import SMRep+import Cmm (Convention(..))+import PprCmm ()++import DynFlags+import Platform+import Outputable++-- Calculate the 'GlobalReg' or stack locations for function call+-- parameters as used by the Cmm calling convention.++data ParamLocation+  = RegisterParam GlobalReg+  | StackParam ByteOff++instance Outputable ParamLocation where+  ppr (RegisterParam g) = ppr g+  ppr (StackParam p)    = ppr p++-- |+-- Given a list of arguments, and a function that tells their types,+-- return a list showing where each argument is passed+--+assignArgumentsPos :: DynFlags+                   -> ByteOff           -- stack offset to start with+                   -> Convention+                   -> (a -> CmmType)    -- how to get a type from an arg+                   -> [a]               -- args+                   -> (+                        ByteOff              -- bytes of stack args+                      , [(a, ParamLocation)] -- args and locations+                      )++assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)+    where+      regs = case (reps, conv) of+               (_,   NativeNodeCall)   -> getRegsWithNode dflags+               (_,   NativeDirectCall) -> getRegsWithoutNode dflags+               ([_], NativeReturn)     -> allRegs dflags+               (_,   NativeReturn)     -> getRegsWithNode dflags+               -- GC calling convention *must* put values in registers+               (_,   GC)               -> allRegs dflags+               (_,   Slow)             -> nodeOnly+      -- The calling conventions first assign arguments to registers,+      -- then switch to the stack when we first run out of registers+      -- (even if there are still available registers for args of a+      -- different type).  When returning an unboxed tuple, we also+      -- separate the stack arguments by pointerhood.+      (reg_assts, stk_args)  = assign_regs [] reps regs+      (stk_off,   stk_assts) = assignStack dflags off arg_ty stk_args+      assignments = reg_assts ++ stk_assts++      assign_regs assts []     _    = (assts, [])+      assign_regs assts (r:rs) regs | isVecType ty   = vec+                                    | isFloatType ty = float+                                    | otherwise      = int+        where vec = case (w, regs) of+                      (W128, (vs, fs, ds, ls, s:ss))+                          | passVectorInReg W128 dflags -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))+                      (W256, (vs, fs, ds, ls, s:ss))+                          | passVectorInReg W256 dflags -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))+                      (W512, (vs, fs, ds, ls, s:ss))+                          | passVectorInReg W512 dflags -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))+                      _ -> (assts, (r:rs))+              float = case (w, regs) of+                        (W32, (vs, fs, ds, ls, s:ss))+                            | passFloatInXmm          -> k (RegisterParam (FloatReg s), (vs, fs, ds, ls, ss))+                        (W32, (vs, f:fs, ds, ls, ss))+                            | not passFloatInXmm      -> k (RegisterParam f, (vs, fs, ds, ls, ss))+                        (W64, (vs, fs, ds, ls, s:ss))+                            | passFloatInXmm          -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss))+                        (W64, (vs, fs, d:ds, ls, ss))+                            | not passFloatInXmm      -> k (RegisterParam d, (vs, fs, ds, ls, ss))+                        _ -> (assts, (r:rs))+              int = case (w, regs) of+                      (W128, _) -> panic "W128 unsupported register type"+                      (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth dflags)+                          -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss))+                      (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags)+                          -> k (RegisterParam l, (vs, fs, ds, ls, ss))+                      _   -> (assts, (r:rs))+              k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'+              ty = arg_ty r+              w  = typeWidth ty+              gcp | isGcPtrType ty = VGcPtr+                  | otherwise      = VNonGcPtr+              passFloatInXmm = passFloatArgsInXmm dflags++passFloatArgsInXmm :: DynFlags -> Bool+passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of+                              ArchX86_64 -> True+                              ArchX86    -> False+                              _          -> False++-- We used to spill vector registers to the stack since the LLVM backend didn't+-- support vector registers in its calling convention. However, this has now+-- been fixed. This function remains only as a convenient way to re-enable+-- spilling when debugging code generation.+passVectorInReg :: Width -> DynFlags -> Bool+passVectorInReg _ _ = True++assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a]+            -> (+                 ByteOff              -- bytes of stack args+               , [(a, ParamLocation)] -- args and locations+               )+assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)+ where+      assign_stk offset assts [] = (offset, assts)+      assign_stk offset assts (r:rs)+        = assign_stk off' ((r, StackParam off') : assts) rs+        where w    = typeWidth (arg_ty r)+              off' = offset + size+              -- Stack arguments always take a whole number of words, we never+              -- pack them unlike constructor fields.+              size = roundUpToWords dflags (widthInBytes w)++-----------------------------------------------------------------------------+-- Local information about the registers available++type AvailRegs = ( [VGcPtr -> GlobalReg]   -- available vanilla regs.+                 , [GlobalReg]   -- floats+                 , [GlobalReg]   -- doubles+                 , [GlobalReg]   -- longs (int64 and word64)+                 , [Int]         -- XMM (floats and doubles)+                 )++-- Vanilla registers can contain pointers, Ints, Chars.+-- Floats and doubles have separate register supplies.+--+-- We take these register supplies from the *real* registers, i.e. those+-- that are guaranteed to map to machine registers.++getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs+getRegsWithoutNode dflags =+  ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)+  , realFloatRegs dflags+  , realDoubleRegs dflags+  , realLongRegs dflags+  , realXmmRegNos dflags)++-- getRegsWithNode uses R1/node even if it isn't a register+getRegsWithNode dflags =+  ( if null (realVanillaRegs dflags)+    then [VanillaReg 1]+    else realVanillaRegs dflags+  , realFloatRegs dflags+  , realDoubleRegs dflags+  , realLongRegs dflags+  , realXmmRegNos dflags)++allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]+allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]+allXmmRegs :: DynFlags -> [Int]++allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags)+allFloatRegs   dflags = map FloatReg   $ regList (mAX_Float_REG   dflags)+allDoubleRegs  dflags = map DoubleReg  $ regList (mAX_Double_REG  dflags)+allLongRegs    dflags = map LongReg    $ regList (mAX_Long_REG    dflags)+allXmmRegs     dflags =                  regList (mAX_XMM_REG     dflags)++realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]+realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]+realXmmRegNos :: DynFlags -> [Int]++realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags)+realFloatRegs   dflags = map FloatReg   $ regList (mAX_Real_Float_REG   dflags)+realDoubleRegs  dflags = map DoubleReg  $ regList (mAX_Real_Double_REG  dflags)+realLongRegs    dflags = map LongReg    $ regList (mAX_Real_Long_REG    dflags)++realXmmRegNos dflags+    | isSse2Enabled dflags = regList (mAX_Real_XMM_REG     dflags)+    | otherwise            = []++regList :: Int -> [Int]+regList n = [1 .. n]++allRegs :: DynFlags -> AvailRegs+allRegs dflags = (allVanillaRegs dflags,+                  allFloatRegs dflags,+                  allDoubleRegs dflags,+                  allLongRegs dflags,+                  allXmmRegs dflags)++nodeOnly :: AvailRegs+nodeOnly = ([VanillaReg 1], [], [], [], [])++-- This returns the set of global registers that *cover* the machine registers+-- used for argument passing. On platforms where registers can overlap---right+-- now just x86-64, where Float and Double registers overlap---passing this set+-- of registers is guaranteed to preserve the contents of all live registers. We+-- only use this functionality in hand-written C-- code in the RTS.+realArgRegsCover :: DynFlags -> [GlobalReg]+realArgRegsCover dflags+    | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) +++                                  realLongRegs dflags +++                                  map XmmReg (realXmmRegNos dflags)+    | otherwise                 = map ($VGcPtr) (realVanillaRegs dflags) +++                                  realFloatRegs dflags +++                                  realDoubleRegs dflags +++                                  realLongRegs dflags +++                                  map XmmReg (realXmmRegNos dflags)
+ compiler/cmm/CmmCommonBlockElim.hs view
@@ -0,0 +1,321 @@+{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-}++module CmmCommonBlockElim+  ( elimCommonBlocks+  )+where+++import GhcPrelude hiding (iterate, succ, unzip, zip)++import BlockId+import Cmm+import CmmUtils+import CmmSwitch (eqSwitchTargetWith)+import CmmContFlowOpt+-- import PprCmm ()++import Hoopl.Block+import Hoopl.Graph+import Hoopl.Label+import Hoopl.Collections+import Data.Bits+import Data.Maybe (mapMaybe)+import qualified Data.List as List+import Data.Word+import qualified Data.Map as M+import Outputable+import qualified TrieMap as TM+import UniqFM+import Unique+import Control.Arrow (first, second)++-- -----------------------------------------------------------------------------+-- Eliminate common blocks++-- If two blocks are identical except for the label on the first node,+-- then we can eliminate one of the blocks. To ensure that the semantics+-- of the program are preserved, we have to rewrite each predecessor of the+-- eliminated block to proceed with the block we keep.++-- The algorithm iterates over the blocks in the graph,+-- checking whether it has seen another block that is equal modulo labels.+-- If so, then it adds an entry in a map indicating that the new block+-- is made redundant by the old block.+-- Otherwise, it is added to the useful blocks.++-- To avoid comparing every block with every other block repeatedly, we group+-- them by+--   * a hash of the block, ignoring labels (explained below)+--   * the list of outgoing labels+-- The hash is invariant under relabeling, so we only ever compare within+-- the same group of blocks.+--+-- The list of outgoing labels is updated as we merge blocks (that is why they+-- are not included in the hash, which we want to calculate only once).+--+-- All in all, two blocks should never be compared if they have different+-- hashes, and at most once otherwise. Previously, we were slower, and people+-- rightfully complained: #10397++-- TODO: Use optimization fuel+elimCommonBlocks :: CmmGraph -> CmmGraph+elimCommonBlocks g = replaceLabels env $ copyTicks env g+  where+     env = iterate mapEmpty blocks_with_key+     -- The order of blocks doesn't matter here. While we could use+     -- revPostorder which drops unreachable blocks this is done in+     -- ContFlowOpt already which runs before this pass. So we use+     -- toBlockList since it is faster.+     groups = groupByInt hash_block (toBlockList g) :: [[CmmBlock]]+     blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]++-- Invariant: The blocks in the list are pairwise distinct+-- (so avoid comparing them again)+type DistinctBlocks = [CmmBlock]+type Key = [Label]+type Subst = LabelMap BlockId++-- The outer list groups by hash. We retain this grouping throughout.+iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst+iterate subst blocks+    | mapNull new_substs = subst+    | otherwise = iterate subst' updated_blocks+  where+    grouped_blocks :: [[(Key, [DistinctBlocks])]]+    grouped_blocks = map groupByLabel blocks++    merged_blocks :: [[(Key, DistinctBlocks)]]+    (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks+      where+        go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db))+          where+            (new_subst2, db) = mergeBlockList subst dbs++    subst' = subst `mapUnion` new_substs+    updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks++-- Combine two lists of blocks.+-- While they are internally distinct they can still share common blocks.+mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)+mergeBlocks subst existing new = go new+  where+    go [] = (mapEmpty, existing)+    go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of+        -- This block is a duplicate. Drop it, and add it to the substitution+        Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs+        -- This block is not a duplicate, keep it.+        Nothing -> second (b:) $ go bs++mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks)+mergeBlockList _ [] = pprPanic "mergeBlockList" empty+mergeBlockList subst (b:bs) = go mapEmpty b bs+  where+    go !new_subst1 b [] = (new_subst1, b)+    go !new_subst1 b1 (b2:bs) = go new_subst b bs+      where+        (new_subst2, b) =  mergeBlocks subst b1 b2+        new_subst = new_subst1 `mapUnion` new_subst2+++-- -----------------------------------------------------------------------------+-- Hashing and equality on blocks++-- Below here is mostly boilerplate: hashing blocks ignoring labels,+-- and comparing blocks modulo a label mapping.++-- To speed up comparisons, we hash each basic block modulo jump labels.+-- The hashing is a bit arbitrary (the numbers are completely arbitrary),+-- but it should be fast and good enough.++-- We want to get as many small buckets as possible, as comparing blocks is+-- expensive. So include as much as possible in the hash. Ideally everything+-- that is compared with (==) in eqBlockBodyWith.++type HashCode = Int++hash_block :: CmmBlock -> HashCode+hash_block block =+  fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))+  -- UniqFM doesn't like negative Ints+  where hash_fst _ h = h+        hash_mid m h = hash_node m + h `shiftL` 1+        hash_lst m h = hash_node m + h `shiftL` 1++        hash_node :: CmmNode O x -> Word32+        hash_node n | dont_care n = 0 -- don't care+        hash_node (CmmAssign r e) = hash_reg r + hash_e e+        hash_node (CmmStore e e') = hash_e e + hash_e e'+        hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as+        hash_node (CmmBranch _) = 23 -- NB. ignore the label+        hash_node (CmmCondBranch p _ _ _) = hash_e p+        hash_node (CmmCall e _ _ _ _ _) = hash_e e+        hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t+        hash_node (CmmSwitch e _) = hash_e e+        hash_node _ = error "hash_node: unknown Cmm node!"++        hash_reg :: CmmReg -> Word32+        hash_reg   (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397+        hash_reg   (CmmGlobal _)    = 19++        hash_e :: CmmExpr -> Word32+        hash_e (CmmLit l) = hash_lit l+        hash_e (CmmLoad e _) = 67 + hash_e e+        hash_e (CmmReg r) = hash_reg r+        hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check+        hash_e (CmmRegOff r i) = hash_reg r + cvt i+        hash_e (CmmStackSlot _ _) = 13++        hash_lit :: CmmLit -> Word32+        hash_lit (CmmInt i _) = fromInteger i+        hash_lit (CmmFloat r _) = truncate r+        hash_lit (CmmVec ls) = hash_list hash_lit ls+        hash_lit (CmmLabel _) = 119 -- ugh+        hash_lit (CmmLabelOff _ i) = cvt $ 199 + i+        hash_lit (CmmLabelDiffOff _ _ i _) = cvt $ 299 + i+        hash_lit (CmmBlock _) = 191 -- ugh+        hash_lit (CmmHighStackMark) = cvt 313++        hash_tgt (ForeignTarget e _) = hash_e e+        hash_tgt (PrimTarget _) = 31 -- lots of these++        hash_list f = foldl' (\z x -> f x + z) (0::Word32)++        cvt = fromInteger . toInteger++        hash_unique :: Uniquable a => a -> Word32+        hash_unique = cvt . getKey . getUnique++-- | Ignore these node types for equality+dont_care :: CmmNode O x -> Bool+dont_care CmmComment {}  = True+dont_care CmmTick {}     = True+dont_care CmmUnwind {}   = True+dont_care _other         = False++-- Utilities: equality and substitution on the graph.++-- Given a map ``subst'' from BlockID -> BlockID, we define equality.+eqBid :: LabelMap BlockId -> BlockId -> BlockId -> Bool+eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'+lookupBid :: LabelMap BlockId -> BlockId -> BlockId+lookupBid subst bid = case mapLookup bid subst of+                        Just bid  -> lookupBid subst bid+                        Nothing -> bid++-- Middle nodes and expressions can contain BlockIds, in particular in+-- CmmStackSlot and CmmBlock, so we have to use a special equality for+-- these.+--+eqMiddleWith :: (BlockId -> BlockId -> Bool)+             -> CmmNode O O -> CmmNode O O -> Bool+eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)+  = r1 == r2 && eqExprWith eqBid e1 e2+eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)+  = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2+eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)+                   (CmmUnsafeForeignCall t2 r2 a2)+  = t1 == t2 && r1 == r2 && eqListWith (eqExprWith eqBid) a1 a2+eqMiddleWith _ _ _ = False++eqExprWith :: (BlockId -> BlockId -> Bool)+           -> CmmExpr -> CmmExpr -> Bool+eqExprWith eqBid = eq+ where+  CmmLit l1          `eq` CmmLit l2          = eqLit l1 l2+  CmmLoad e1 _       `eq` CmmLoad e2 _       = e1 `eq` e2+  CmmReg r1          `eq` CmmReg r2          = r1==r2+  CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1==r2 && i1==i2+  CmmMachOp op1 es1  `eq` CmmMachOp op2 es2  = op1==op2 && es1 `eqs` es2+  CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2+  _e1                `eq` _e2                = False++  xs `eqs` ys = eqListWith eq xs ys++  eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2+  eqLit l1 l2 = l1 == l2++  eqArea Old Old = True+  eqArea (Young id1) (Young id2) = eqBid id1 id2+  eqArea _ _ = False++-- Equality on the body of a block, modulo a function mapping block+-- IDs to block IDs.+eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool+eqBlockBodyWith eqBid block block'+  {-+  | equal     = pprTrace "equal" (vcat [ppr block, ppr block']) True+  | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False+  -}+  = equal+  where (_,m,l)   = blockSplit block+        nodes     = filter (not . dont_care) (blockToList m)+        (_,m',l') = blockSplit block'+        nodes'    = filter (not . dont_care) (blockToList m')++        equal = eqListWith (eqMiddleWith eqBid) nodes nodes' &&+                eqLastWith eqBid l l'+++eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool+eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2+eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) =+  c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2+eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =+  t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2+eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =+  e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2+eqLastWith _ _ _ = False++eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool+eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'+eqMaybeWith _ Nothing Nothing = True+eqMaybeWith _ _ _ = False++eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool+eqListWith f (a : as) (b : bs) = f a b && eqListWith f as bs+eqListWith _ []       []       = True+eqListWith _ _        _        = False++-- | Given a block map, ensure that all "target" blocks are covered by+-- the same ticks as the respective "source" blocks. This not only+-- means copying ticks, but also adjusting tick scopes where+-- necessary.+copyTicks :: LabelMap BlockId -> CmmGraph -> CmmGraph+copyTicks env g+  | mapNull env = g+  | otherwise   = ofBlockMap (g_entry g) $ mapMap copyTo blockMap+  where -- Reverse block merge map+        blockMap = toBlockMap g+        revEnv = mapFoldlWithKey insertRev M.empty env+        insertRev m k x = M.insertWith (const (k:)) x [k] m+        -- Copy ticks and scopes into the given block+        copyTo block = case M.lookup (entryLabel block) revEnv of+          Nothing -> block+          Just ls -> foldr copy block $ mapMaybe (flip mapLookup blockMap) ls+        copy from to =+          let ticks = blockTicks from+              CmmEntry  _   scp0        = firstNode from+              (CmmEntry lbl scp1, code) = blockSplitHead to+          in CmmEntry lbl (combineTickScopes scp0 scp1) `blockJoinHead`+             foldr blockCons code (map CmmTick ticks)++-- Group by [Label]+-- See Note [Compressed TrieMap] in coreSyn/TrieMap about the usage of GenMap.+groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])]+groupByLabel =+  go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks]))+    where+      go !m [] = TM.foldTM (:) m []+      go !m ((k,v) : entries) = go (TM.alterTM k adjust m) entries+        where --k' = map (getKey . getUnique) k+              adjust Nothing       = Just (k,[v])+              adjust (Just (_,vs)) = Just (k,v:vs)++groupByInt :: (a -> Int) -> [a] -> [[a]]+groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs+   -- See Note [Unique Determinism and code generation]+  where+    go m x = alterUFM addEntry m (f x)+      where+        addEntry xs = Just $! maybe [x] (x:) xs
+ compiler/cmm/CmmContFlowOpt.hs view
@@ -0,0 +1,444 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}+module CmmContFlowOpt+    ( cmmCfgOpts+    , cmmCfgOptsProc+    , removeUnreachableBlocksProc+    , replaceLabels+    )+where++import GhcPrelude hiding (succ, unzip, zip)++import Hoopl.Block+import Hoopl.Collections+import Hoopl.Graph+import Hoopl.Label+import BlockId+import Cmm+import CmmUtils+import CmmSwitch (mapSwitchTargets)+import Maybes+import Panic+import Util++import Control.Monad+++-- Note [What is shortcutting]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Consider this Cmm code:+--+-- L1: ...+--     goto L2;+-- L2: goto L3;+-- L3: ...+--+-- Here L2 is an empty block and contains only an unconditional branch+-- to L3. In this situation any block that jumps to L2 can jump+-- directly to L3:+--+-- L1: ...+--     goto L3;+-- L2: goto L3;+-- L3: ...+--+-- In this situation we say that we shortcut L2 to L3. One of+-- consequences of shortcutting is that some blocks of code may become+-- unreachable (in the example above this is true for L2).+++-- Note [Control-flow optimisations]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- This optimisation does three things:+--+--   - If a block finishes in an unconditional branch to another block+--     and that is the only jump to that block we concatenate the+--     destination block at the end of the current one.+--+--   - If a block finishes in a call whose continuation block is a+--     goto, then we can shortcut the destination, making the+--     continuation block the destination of the goto - but see Note+--     [Shortcut call returns].+--+--   - For any block that is not a call we try to shortcut the+--     destination(s). Additionally, if a block ends with a+--     conditional branch we try to invert the condition.+--+-- Blocks are processed using postorder DFS traversal. A side effect+-- of determining traversal order with a graph search is elimination+-- of any blocks that are unreachable.+--+-- Transformations are improved by working from the end of the graph+-- towards the beginning, because we may be able to perform many+-- shortcuts in one go.+++-- Note [Shortcut call returns]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We are going to maintain the "current" graph (LabelMap CmmBlock) as+-- we go, and also a mapping from BlockId to BlockId, representing+-- continuation labels that we have renamed.  This latter mapping is+-- important because we might shortcut a CmmCall continuation.  For+-- example:+--+--    Sp[0] = L+--    call g returns to L+--    L: goto M+--    M: ...+--+-- So when we shortcut the L block, we need to replace not only+-- the continuation of the call, but also references to L in the+-- code (e.g. the assignment Sp[0] = L):+--+--    Sp[0] = M+--    call g returns to M+--    M: ...+--+-- So we keep track of which labels we have renamed and apply the mapping+-- at the end with replaceLabels.+++-- Note [Shortcut call returns and proc-points]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Consider this code that you might get from a recursive+-- let-no-escape:+--+--       goto L1+--      L1:+--       if (Hp > HpLim) then L2 else L3+--      L2:+--       call stg_gc_noregs returns to L4+--      L4:+--       goto L1+--      L3:+--       ...+--       goto L1+--+-- Then the control-flow optimiser shortcuts L4.  But that turns L1+-- into the call-return proc point, and every iteration of the loop+-- has to shuffle variables to and from the stack.  So we must *not*+-- shortcut L4.+--+-- Moreover not shortcutting call returns is probably fine.  If L4 can+-- concat with its branch target then it will still do so.  And we+-- save some compile time because we don't have to traverse all the+-- code in replaceLabels.+--+-- However, we probably do want to do this if we are splitting proc+-- points, because L1 will be a proc-point anyway, so merging it with+-- L4 reduces the number of proc points.  Unfortunately recursive+-- let-no-escapes won't generate very good code with proc-point+-- splitting on - we should probably compile them to explicitly use+-- the native calling convention instead.++cmmCfgOpts :: Bool -> CmmGraph -> CmmGraph+cmmCfgOpts split g = fst (blockConcat split g)++cmmCfgOptsProc :: Bool -> CmmDecl -> CmmDecl+cmmCfgOptsProc split (CmmProc info lbl live g) = CmmProc info' lbl live g'+    where (g', env) = blockConcat split g+          info' = info{ info_tbls = new_info_tbls }+          new_info_tbls = mapFromList (map upd_info (mapToList (info_tbls info)))++          -- If we changed any labels, then we have to update the info tables+          -- too, except for the top-level info table because that might be+          -- referred to by other procs.+          upd_info (k,info)+             | Just k' <- mapLookup k env+             = (k', if k' == g_entry g'+                       then info+                       else info{ cit_lbl = infoTblLbl k' })+             | otherwise+             = (k,info)+cmmCfgOptsProc _ top = top+++blockConcat :: Bool -> CmmGraph -> (CmmGraph, LabelMap BlockId)+blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }+  = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map')+  where+     -- We might be able to shortcut the entry BlockId itself.+     -- Remember to update the shortcut_map, since we also have to+     -- update the info_tbls mapping now.+     (new_entry, shortcut_map')+       | Just entry_blk <- mapLookup entry_id new_blocks+       , Just dest      <- canShortcut entry_blk+       = (dest, mapInsert entry_id dest shortcut_map)+       | otherwise+       = (entry_id, shortcut_map)++     -- blocks are sorted in reverse postorder, but we want to go from the exit+     -- towards beginning, so we use foldr below.+     blocks = revPostorder g+     blockmap = foldl' (flip addBlock) emptyBody blocks++     -- Accumulator contains three components:+     --  * map of blocks in a graph+     --  * map of shortcut labels. See Note [Shortcut call returns]+     --  * map containing number of predecessors for each block. We discard+     --    it after we process all blocks.+     (new_blocks, shortcut_map, _) =+           foldr maybe_concat (blockmap, mapEmpty, initialBackEdges) blocks++     -- Map of predecessors for initial graph. We increase number of+     -- predecessors for entry block by one to denote that it is+     -- target of a jump, even if no block in the current graph jumps+     -- to it.+     initialBackEdges = incPreds entry_id (predMap blocks)++     maybe_concat :: CmmBlock+                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)+                  -> (LabelMap CmmBlock, LabelMap BlockId, LabelMap Int)+     maybe_concat block (!blocks, !shortcut_map, !backEdges)+        -- If:+        --   (1) current block ends with unconditional branch to b' and+        --   (2) it has exactly one predecessor (namely, current block)+        --+        -- Then:+        --   (1) append b' block at the end of current block+        --   (2) remove b' from the map of blocks+        --   (3) remove information about b' from predecessors map+        --+        -- Since we know that the block has only one predecessor we call+        -- mapDelete directly instead of calling decPreds.+        --+        -- Note that we always maintain an up-to-date list of predecessors, so+        -- we can ignore the contents of shortcut_map+        | CmmBranch b' <- last+        , hasOnePredecessor b'+        , Just blk' <- mapLookup b' blocks+        = let bid' = entryLabel blk'+          in ( mapDelete bid' $ mapInsert bid (splice head blk') blocks+             , shortcut_map+             , mapDelete b' backEdges )++        -- If:+        --   (1) we are splitting proc points (see Note+        --       [Shortcut call returns and proc-points]) and+        --   (2) current block is a CmmCall or CmmForeignCall with+        --       continuation b' and+        --   (3) we can shortcut that continuation to dest+        -- Then:+        --   (1) we change continuation to point to b'+        --   (2) create mapping from b' to dest+        --   (3) increase number of predecessors of dest by 1+        --   (4) decrease number of predecessors of b' by 1+        --+        -- Later we will use replaceLabels to substitute all occurrences of b'+        -- with dest.+        | splitting_procs+        , Just b'   <- callContinuation_maybe last+        , Just blk' <- mapLookup b' blocks+        , Just dest <- canShortcut blk'+        = ( mapInsert bid (blockJoinTail head (update_cont dest)) blocks+          , mapInsert b' dest shortcut_map+          , decPreds b' $ incPreds dest backEdges )++        -- If:+        --   (1) a block does not end with a call+        -- Then:+        --   (1) if it ends with a conditional attempt to invert the+        --       conditional+        --   (2) attempt to shortcut all destination blocks+        --   (3) if new successors of a block are different from the old ones+        --       update the of predecessors accordingly+        --+        -- A special case of this is a situation when a block ends with an+        -- unconditional jump to a block that can be shortcut.+        | Nothing <- callContinuation_maybe last+        = let oldSuccs = successors last+              newSuccs = successors rewrite_last+          in ( mapInsert bid (blockJoinTail head rewrite_last) blocks+             , shortcut_map+             , if oldSuccs == newSuccs+               then backEdges+               else foldr incPreds (foldr decPreds backEdges oldSuccs) newSuccs )++        -- Otherwise don't do anything+        | otherwise+        = ( blocks, shortcut_map, backEdges )+        where+          (head, last) = blockSplitTail block+          bid = entryLabel block++          -- Changes continuation of a call to a specified label+          update_cont dest =+              case last of+                CmmCall{}        -> last { cml_cont = Just dest }+                CmmForeignCall{} -> last { succ = dest }+                _                -> panic "Can't shortcut continuation."++          -- Attempts to shortcut successors of last node+          shortcut_last = mapSuccessors shortcut last+            where+              shortcut l =+                 case mapLookup l blocks of+                   Just b | Just dest <- canShortcut b -> dest+                   _otherwise -> l++          rewrite_last+            -- Sometimes we can get rid of the conditional completely.+            | CmmCondBranch _cond t f _l <- shortcut_last+            , t == f+            = CmmBranch t++            -- See Note [Invert Cmm conditionals]+            | CmmCondBranch cond t f l <- shortcut_last+            , hasOnePredecessor t -- inverting will make t a fallthrough+            , likelyTrue l || (numPreds f > 1)+            , Just cond' <- maybeInvertCmmExpr cond+            = CmmCondBranch cond' f t (invertLikeliness l)++            | otherwise+            = shortcut_last++          likelyTrue (Just True)   = True+          likelyTrue _             = False++          invertLikeliness :: Maybe Bool -> Maybe Bool+          invertLikeliness         = fmap not++          -- Number of predecessors for a block+          numPreds bid = mapLookup bid backEdges `orElse` 0++          hasOnePredecessor b = numPreds b == 1++{-+  Note [Invert Cmm conditionals]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  The native code generator always produces jumps to the true branch.+  Falling through to the false branch is however faster. So we try to+  arrange for that to happen.+  This means we invert the condition if:+  * The likely path will become a fallthrough.+  * We can't guarantee a fallthrough for the false branch but for the+    true branch.++  In some cases it's faster to avoid inverting when the false branch is likely.+  However determining when that is the case is neither easy nor cheap so for+  now we always invert as this produces smaller binaries and code that is+  equally fast on average. (On an i7-6700K)++  TODO:+  There is also the edge case when both branches have multiple predecessors.+  In this case we could assume that we will end up with a jump for BOTH+  branches. In this case it might be best to put the likely path in the true+  branch especially if there are large numbers of predecessors as this saves+  us the jump thats not taken. However I haven't tested this and as of early+  2018 we almost never generate cmm where this would apply.+-}++-- Functions for incrementing and decrementing number of predecessors. If+-- decrementing would set the predecessor count to 0, we remove entry from the+-- map.+-- Invariant: if a block has no predecessors it should be dropped from the+-- graph because it is unreachable. maybe_concat is constructed to maintain+-- that invariant, but calling replaceLabels may introduce unreachable blocks.+-- We rely on subsequent passes in the Cmm pipeline to remove unreachable+-- blocks.+incPreds, decPreds :: BlockId -> LabelMap Int -> LabelMap Int+incPreds bid edges = mapInsertWith (+) bid 1 edges+decPreds bid edges = case mapLookup bid edges of+                       Just preds | preds > 1 -> mapInsert bid (preds - 1) edges+                       Just _                 -> mapDelete bid edges+                       _                      -> edges+++-- Checks if a block consists only of "goto dest". If it does than we return+-- "Just dest" label. See Note [What is shortcutting]+canShortcut :: CmmBlock -> Maybe BlockId+canShortcut block+    | (_, middle, CmmBranch dest) <- blockSplit block+    , all dont_care $ blockToList middle+    = Just dest+    | otherwise+    = Nothing+    where dont_care CmmComment{} = True+          dont_care CmmTick{}    = True+          dont_care _other       = False++-- Concatenates two blocks. First one is assumed to be open on exit, the second+-- is assumed to be closed on entry (i.e. it has a label attached to it, which+-- the splice function removes by calling snd on result of blockSplitHead).+splice :: Block CmmNode C O -> CmmBlock -> CmmBlock+splice head rest = entry `blockJoinHead` code0 `blockAppend` code1+  where (CmmEntry lbl sc0, code0) = blockSplitHead head+        (CmmEntry _   sc1, code1) = blockSplitHead rest+        entry = CmmEntry lbl (combineTickScopes sc0 sc1)++-- If node is a call with continuation call return Just label of that+-- continuation. Otherwise return Nothing.+callContinuation_maybe :: CmmNode O C -> Maybe BlockId+callContinuation_maybe (CmmCall { cml_cont = Just b }) = Just b+callContinuation_maybe (CmmForeignCall { succ = b })   = Just b+callContinuation_maybe _ = Nothing+++-- Map over the CmmGraph, replacing each label with its mapping in the+-- supplied LabelMap.+replaceLabels :: LabelMap BlockId -> CmmGraph -> CmmGraph+replaceLabels env g+  | mapNull env = g+  | otherwise   = replace_eid $ mapGraphNodes1 txnode g+   where+     replace_eid g = g {g_entry = lookup (g_entry g)}+     lookup id = mapLookup id env `orElse` id++     txnode :: CmmNode e x -> CmmNode e x+     txnode (CmmBranch bid) = CmmBranch (lookup bid)+     txnode (CmmCondBranch p t f l) =+       mkCmmCondBranch (exp p) (lookup t) (lookup f) l+     txnode (CmmSwitch e ids) =+       CmmSwitch (exp e) (mapSwitchTargets lookup ids)+     txnode (CmmCall t k rg a res r) =+       CmmCall (exp t) (liftM lookup k) rg a res r+     txnode fc@CmmForeignCall{} =+       fc{ args = map exp (args fc), succ = lookup (succ fc) }+     txnode other = mapExpDeep exp other++     exp :: CmmExpr -> CmmExpr+     exp (CmmLit (CmmBlock bid))                = CmmLit (CmmBlock (lookup bid))+     exp (CmmStackSlot (Young id) i) = CmmStackSlot (Young (lookup id)) i+     exp e                                      = e++mkCmmCondBranch :: CmmExpr -> Label -> Label -> Maybe Bool -> CmmNode O C+mkCmmCondBranch p t f l =+  if t == f then CmmBranch t else CmmCondBranch p t f l++-- Build a map from a block to its set of predecessors.+predMap :: [CmmBlock] -> LabelMap Int+predMap blocks = foldr add_preds mapEmpty blocks+  where+    add_preds block env = foldr add env (successors block)+      where add lbl env = mapInsertWith (+) lbl 1 env++-- Removing unreachable blocks+removeUnreachableBlocksProc :: CmmDecl -> CmmDecl+removeUnreachableBlocksProc proc@(CmmProc info lbl live g)+   | used_blocks `lengthLessThan` mapSize (toBlockMap g)+   = CmmProc info' lbl live g'+   | otherwise+   = proc+   where+     g'    = ofBlockList (g_entry g) used_blocks+     info' = info { info_tbls = keep_used (info_tbls info) }+             -- Remove any info_tbls for unreachable++     keep_used :: LabelMap CmmInfoTable -> LabelMap CmmInfoTable+     keep_used bs = mapFoldlWithKey keep mapEmpty bs++     keep :: LabelMap CmmInfoTable -> Label -> CmmInfoTable -> LabelMap CmmInfoTable+     keep env l i | l `setMember` used_lbls = mapInsert l i env+                  | otherwise               = env++     used_blocks :: [CmmBlock]+     used_blocks = revPostorder g++     used_lbls :: LabelSet+     used_lbls = setFromList $ map entryLabel used_blocks
+ compiler/cmm/CmmExpr.hs view
@@ -0,0 +1,619 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}++module CmmExpr+    ( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr+    , CmmReg(..), cmmRegType, cmmRegWidth+    , CmmLit(..), cmmLitType+    , LocalReg(..), localRegType+    , GlobalReg(..), isArgReg, globalRegType+    , spReg, hpReg, spLimReg, hpLimReg, nodeReg+    , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg+    , node, baseReg+    , VGcPtr(..)++    , DefinerOfRegs, UserOfRegs+    , foldRegsDefd, foldRegsUsed+    , foldLocalRegsDefd, foldLocalRegsUsed++    , RegSet, LocalRegSet, GlobalRegSet+    , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet+    , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet+    , regSetToList++    , Area(..)+    , module CmmMachOp+    , module CmmType+    )+where++import GhcPrelude++import BlockId+import CLabel+import CmmMachOp+import CmmType+import DynFlags+import Outputable (panic)+import Unique++import Data.Set (Set)+import qualified Data.Set as Set++import BasicTypes (Alignment, mkAlignment, alignmentOf)++-----------------------------------------------------------------------------+--              CmmExpr+-- An expression.  Expressions have no side effects.+-----------------------------------------------------------------------------++data CmmExpr+  = CmmLit CmmLit               -- Literal+  | CmmLoad !CmmExpr !CmmType   -- Read memory location+  | CmmReg !CmmReg              -- Contents of register+  | CmmMachOp MachOp [CmmExpr]  -- Machine operation (+, -, *, etc.)+  | CmmStackSlot Area {-# UNPACK #-} !Int+                                -- addressing expression of a stack slot+                                -- See Note [CmmStackSlot aliasing]+  | CmmRegOff !CmmReg Int+        -- CmmRegOff reg i+        --        ** is shorthand only, meaning **+        -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]+        --      where rep = typeWidth (cmmRegType reg)++instance Eq CmmExpr where       -- Equality ignores the types+  CmmLit l1          == CmmLit l2          = l1==l2+  CmmLoad e1 _       == CmmLoad e2 _       = e1==e2+  CmmReg r1          == CmmReg r2          = r1==r2+  CmmRegOff r1 i1    == CmmRegOff r2 i2    = r1==r2 && i1==i2+  CmmMachOp op1 es1  == CmmMachOp op2 es2  = op1==op2 && es1==es2+  CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2+  _e1                == _e2                = False++data CmmReg+  = CmmLocal  {-# UNPACK #-} !LocalReg+  | CmmGlobal GlobalReg+  deriving( Eq, Ord )++-- | A stack area is either the stack slot where a variable is spilled+-- or the stack space where function arguments and results are passed.+data Area+  = Old            -- See Note [Old Area]+  | Young {-# UNPACK #-} !BlockId  -- Invariant: must be a continuation BlockId+                   -- See Note [Continuation BlockId] in CmmNode.+  deriving (Eq, Ord)++{- Note [Old Area]+~~~~~~~~~~~~~~~~~~+There is a single call area 'Old', allocated at the extreme old+end of the stack frame (ie just younger than the return address)+which holds:+  * incoming (overflow) parameters,+  * outgoing (overflow) parameter to tail calls,+  * outgoing (overflow) result values+  * the update frame (if any)++Its size is the max of all these requirements.  On entry, the stack+pointer will point to the youngest incoming parameter, which is not+necessarily at the young end of the Old area.++End of note -}+++{- Note [CmmStackSlot aliasing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When do two CmmStackSlots alias?++ - T[old+N] aliases with U[young(L)+M] for all T, U, L, N and M+ - T[old+N] aliases with U[old+M] only if the areas actually overlap++Or more informally, different Areas may overlap with each other.++An alternative semantics, that we previously had, was that different+Areas do not overlap.  The problem that lead to redefining the+semantics of stack areas is described below.++e.g. if we had++    x = Sp[old + 8]+    y = Sp[old + 16]++    Sp[young(L) + 8]  = L+    Sp[young(L) + 16] = y+    Sp[young(L) + 24] = x+    call f() returns to L++if areas semantically do not overlap, then we might optimise this to++    Sp[young(L) + 8]  = L+    Sp[young(L) + 16] = Sp[old + 8]+    Sp[young(L) + 24] = Sp[old + 16]+    call f() returns to L++and now young(L) cannot be allocated at the same place as old, and we+are doomed to use more stack.++  - old+8  conflicts with young(L)+8+  - old+16 conflicts with young(L)+16 and young(L)+8++so young(L)+8 == old+24 and we get++    Sp[-8]  = L+    Sp[-16] = Sp[8]+    Sp[-24] = Sp[0]+    Sp -= 24+    call f() returns to L++However, if areas are defined to be "possibly overlapping" in the+semantics, then we cannot commute any loads/stores of old with+young(L), and we will be able to re-use both old+8 and old+16 for+young(L).++    x = Sp[8]+    y = Sp[0]++    Sp[8] = L+    Sp[0] = y+    Sp[-8] = x+    Sp = Sp - 8+    call f() returns to L++Now, the assignments of y go away,++    x = Sp[8]+    Sp[8] = L+    Sp[-8] = x+    Sp = Sp - 8+    call f() returns to L+-}++data CmmLit+  = CmmInt !Integer  Width+        -- Interpretation: the 2's complement representation of the value+        -- is truncated to the specified size.  This is easier than trying+        -- to keep the value within range, because we don't know whether+        -- it will be used as a signed or unsigned value (the CmmType doesn't+        -- distinguish between signed & unsigned).+  | CmmFloat  Rational Width+  | CmmVec [CmmLit]                     -- Vector literal+  | CmmLabel    CLabel                  -- Address of label+  | CmmLabelOff CLabel Int              -- Address of label + byte offset++        -- Due to limitations in the C backend, the following+        -- MUST ONLY be used inside the info table indicated by label2+        -- (label2 must be the info label), and label1 must be an+        -- SRT, a slow entrypoint or a large bitmap (see the Mangler)+        -- Don't use it at all unless tablesNextToCode.+        -- It is also used inside the NCG during when generating+        -- position-independent code.+  | CmmLabelDiffOff CLabel CLabel Int Width -- label1 - label2 + offset+        -- In an expression, the width just has the effect of MO_SS_Conv+        -- from wordWidth to the desired width.+        --+        -- In a static literal, the supported Widths depend on the+        -- architecture: wordWidth is supported on all+        -- architectures. Additionally W32 is supported on x86_64 when+        -- using the small memory model.++  | CmmBlock {-# UNPACK #-} !BlockId     -- Code label+        -- Invariant: must be a continuation BlockId+        -- See Note [Continuation BlockId] in CmmNode.++  | CmmHighStackMark -- A late-bound constant that stands for the max+                     -- #bytes of stack space used during a procedure.+                     -- During the stack-layout pass, CmmHighStackMark+                     -- is replaced by a CmmInt for the actual number+                     -- of bytes used+  deriving Eq++cmmExprType :: DynFlags -> CmmExpr -> CmmType+cmmExprType dflags (CmmLit lit)        = cmmLitType dflags lit+cmmExprType _      (CmmLoad _ rep)     = rep+cmmExprType dflags (CmmReg reg)        = cmmRegType dflags reg+cmmExprType dflags (CmmMachOp op args) = machOpResultType dflags op (map (cmmExprType dflags) args)+cmmExprType dflags (CmmRegOff reg _)   = cmmRegType dflags reg+cmmExprType dflags (CmmStackSlot _ _)  = bWord dflags -- an address+-- Careful though: what is stored at the stack slot may be bigger than+-- an address++cmmLitType :: DynFlags -> CmmLit -> CmmType+cmmLitType _      (CmmInt _ width)     = cmmBits  width+cmmLitType _      (CmmFloat _ width)   = cmmFloat width+cmmLitType _      (CmmVec [])          = panic "cmmLitType: CmmVec []"+cmmLitType cflags (CmmVec (l:ls))      = let ty = cmmLitType cflags l+                                         in if all (`cmmEqType` ty) (map (cmmLitType cflags) ls)+                                            then cmmVec (1+length ls) ty+                                            else panic "cmmLitType: CmmVec"+cmmLitType dflags (CmmLabel lbl)       = cmmLabelType dflags lbl+cmmLitType dflags (CmmLabelOff lbl _)  = cmmLabelType dflags lbl+cmmLitType _      (CmmLabelDiffOff _ _ _ width) = cmmBits width+cmmLitType dflags (CmmBlock _)         = bWord dflags+cmmLitType dflags (CmmHighStackMark)   = bWord dflags++cmmLabelType :: DynFlags -> CLabel -> CmmType+cmmLabelType dflags lbl+ | isGcPtrLabel lbl = gcWord dflags+ | otherwise        = bWord dflags++cmmExprWidth :: DynFlags -> CmmExpr -> Width+cmmExprWidth dflags e = typeWidth (cmmExprType dflags e)++-- | Returns an alignment in bytes of a CmmExpr when it's a statically+-- known integer constant, otherwise returns an alignment of 1 byte.+-- The caller is responsible for using with a sensible CmmExpr+-- argument.+cmmExprAlignment :: CmmExpr -> Alignment+cmmExprAlignment (CmmLit (CmmInt intOff _)) = alignmentOf (fromInteger intOff)+cmmExprAlignment _                          = mkAlignment 1+--------+--- Negation for conditional branches++maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr+maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op+                                            return (CmmMachOp op' args)+maybeInvertCmmExpr _ = Nothing++-----------------------------------------------------------------------------+--              Local registers+-----------------------------------------------------------------------------++data LocalReg+  = LocalReg {-# UNPACK #-} !Unique CmmType+    -- ^ Parameters:+    --   1. Identifier+    --   2. Type++instance Eq LocalReg where+  (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2++-- This is non-deterministic but we do not currently support deterministic+-- code-generation. See Note [Unique Determinism and code generation]+-- See Note [No Ord for Unique]+instance Ord LocalReg where+  compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2++instance Uniquable LocalReg where+  getUnique (LocalReg uniq _) = uniq++cmmRegType :: DynFlags -> CmmReg -> CmmType+cmmRegType _      (CmmLocal  reg) = localRegType reg+cmmRegType dflags (CmmGlobal reg) = globalRegType dflags reg++cmmRegWidth :: DynFlags -> CmmReg -> Width+cmmRegWidth dflags = typeWidth . cmmRegType dflags++localRegType :: LocalReg -> CmmType+localRegType (LocalReg _ rep) = rep++-----------------------------------------------------------------------------+--    Register-use information for expressions and other types+-----------------------------------------------------------------------------++-- | Sets of registers++-- These are used for dataflow facts, and a common operation is taking+-- the union of two RegSets and then asking whether the union is the+-- same as one of the inputs.  UniqSet isn't good here, because+-- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary+-- Sets.++type RegSet r     = Set r+type LocalRegSet  = RegSet LocalReg+type GlobalRegSet = RegSet GlobalReg++emptyRegSet             :: RegSet r+nullRegSet              :: RegSet r -> Bool+elemRegSet              :: Ord r => r -> RegSet r -> Bool+extendRegSet            :: Ord r => RegSet r -> r -> RegSet r+deleteFromRegSet        :: Ord r => RegSet r -> r -> RegSet r+mkRegSet                :: Ord r => [r] -> RegSet r+minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r+sizeRegSet              :: RegSet r -> Int+regSetToList            :: RegSet r -> [r]++emptyRegSet      = Set.empty+nullRegSet       = Set.null+elemRegSet       = Set.member+extendRegSet     = flip Set.insert+deleteFromRegSet = flip Set.delete+mkRegSet         = Set.fromList+minusRegSet      = Set.difference+plusRegSet       = Set.union+timesRegSet      = Set.intersection+sizeRegSet       = Set.size+regSetToList     = Set.toList++class Ord r => UserOfRegs r a where+  foldRegsUsed :: DynFlags -> (b -> r -> b) -> b -> a -> b++foldLocalRegsUsed :: UserOfRegs LocalReg a+                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b+foldLocalRegsUsed = foldRegsUsed++class Ord r => DefinerOfRegs r a where+  foldRegsDefd :: DynFlags -> (b -> r -> b) -> b -> a -> b++foldLocalRegsDefd :: DefinerOfRegs LocalReg a+                  => DynFlags -> (b -> LocalReg -> b) -> b -> a -> b+foldLocalRegsDefd = foldRegsDefd++instance UserOfRegs LocalReg CmmReg where+    foldRegsUsed _ f z (CmmLocal reg) = f z reg+    foldRegsUsed _ _ z (CmmGlobal _)  = z++instance DefinerOfRegs LocalReg CmmReg where+    foldRegsDefd _ f z (CmmLocal reg) = f z reg+    foldRegsDefd _ _ z (CmmGlobal _)  = z++instance UserOfRegs GlobalReg CmmReg where+    foldRegsUsed _ _ z (CmmLocal _)    = z+    foldRegsUsed _ f z (CmmGlobal reg) = f z reg++instance DefinerOfRegs GlobalReg CmmReg where+    foldRegsDefd _ _ z (CmmLocal _)    = z+    foldRegsDefd _ f z (CmmGlobal reg) = f z reg++instance Ord r => UserOfRegs r r where+    foldRegsUsed _ f z r = f z r++instance Ord r => DefinerOfRegs r r where+    foldRegsDefd _ f z r = f z r++instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where+  -- The (Ord r) in the context is necessary here+  -- See Note [Recursive superclasses] in TcInstDcls+  foldRegsUsed dflags f !z e = expr z e+    where expr z (CmmLit _)          = z+          expr z (CmmLoad addr _)    = foldRegsUsed dflags f z addr+          expr z (CmmReg r)          = foldRegsUsed dflags f z r+          expr z (CmmMachOp _ exprs) = foldRegsUsed dflags f z exprs+          expr z (CmmRegOff r _)     = foldRegsUsed dflags f z r+          expr z (CmmStackSlot _ _)  = z++instance UserOfRegs r a => UserOfRegs r [a] where+  foldRegsUsed dflags f set as = foldl' (foldRegsUsed dflags f) set as+  {-# INLINABLE foldRegsUsed #-}++instance DefinerOfRegs r a => DefinerOfRegs r [a] where+  foldRegsDefd dflags f set as = foldl' (foldRegsDefd dflags f) set as+  {-# INLINABLE foldRegsDefd #-}++-----------------------------------------------------------------------------+--              Global STG registers+-----------------------------------------------------------------------------++data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )++-----------------------------------------------------------------------------+--              Global STG registers+-----------------------------------------------------------------------------+{-+Note [Overlapping global registers]++The backend might not faithfully implement the abstraction of the STG+machine with independent registers for different values of type+GlobalReg. Specifically, certain pairs of registers (r1, r2) may+overlap in the sense that a store to r1 invalidates the value in r2,+and vice versa.++Currently this occurs only on the x86_64 architecture where FloatReg n+and DoubleReg n are assigned the same microarchitectural register, in+order to allow functions to receive more Float# or Double# arguments+in registers (as opposed to on the stack).++There are no specific rules about which registers might overlap with+which other registers, but presumably it's safe to assume that nothing+will overlap with special registers like Sp or BaseReg.++Use CmmUtils.regsOverlap to determine whether two GlobalRegs overlap+on a particular platform. The instance Eq GlobalReg is syntactic+equality of STG registers and does not take overlap into+account. However it is still used in UserOfRegs/DefinerOfRegs and+there are likely still bugs there, beware!+-}++data GlobalReg+  -- Argument and return registers+  = VanillaReg                  -- pointers, unboxed ints and chars+        {-# UNPACK #-} !Int     -- its number+        VGcPtr++  | FloatReg            -- single-precision floating-point registers+        {-# UNPACK #-} !Int     -- its number++  | DoubleReg           -- double-precision floating-point registers+        {-# UNPACK #-} !Int     -- its number++  | LongReg             -- long int registers (64-bit, really)+        {-# UNPACK #-} !Int     -- its number++  | XmmReg                      -- 128-bit SIMD vector register+        {-# UNPACK #-} !Int     -- its number++  | YmmReg                      -- 256-bit SIMD vector register+        {-# UNPACK #-} !Int     -- its number++  | ZmmReg                      -- 512-bit SIMD vector register+        {-# UNPACK #-} !Int     -- its number++  -- STG registers+  | Sp                  -- Stack ptr; points to last occupied stack location.+  | SpLim               -- Stack limit+  | Hp                  -- Heap ptr; points to last occupied heap location.+  | HpLim               -- Heap limit register+  | CCCS                -- Current cost-centre stack+  | CurrentTSO          -- pointer to current thread's TSO+  | CurrentNursery      -- pointer to allocation area+  | HpAlloc             -- allocation count for heap check failure++                -- We keep the address of some commonly-called+                -- functions in the register table, to keep code+                -- size down:+  | EagerBlackholeInfo  -- stg_EAGER_BLACKHOLE_info+  | GCEnter1            -- stg_gc_enter_1+  | GCFun               -- stg_gc_fun++  -- Base offset for the register table, used for accessing registers+  -- which do not have real registers assigned to them.  This register+  -- will only appear after we have expanded GlobalReg into memory accesses+  -- (where necessary) in the native code generator.+  | BaseReg++  -- The register used by the platform for the C stack pointer. This is+  -- a break in the STG abstraction used exclusively to setup stack unwinding+  -- information.+  | MachSp++  -- The is a dummy register used to indicate to the stack unwinder where+  -- a routine would return to.+  | UnwindReturnReg++  -- Base Register for PIC (position-independent code) calculations+  -- Only used inside the native code generator. It's exact meaning differs+  -- from platform to platform (see module PositionIndependentCode).+  | PicBaseReg++  deriving( Show )++instance Eq GlobalReg where+   VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes+   FloatReg i == FloatReg j = i==j+   DoubleReg i == DoubleReg j = i==j+   LongReg i == LongReg j = i==j+   -- NOTE: XMM, YMM, ZMM registers actually are the same registers+   -- at least with respect to store at YMM i and then read from XMM i+   -- and similarly for ZMM etc.+   XmmReg i == XmmReg j = i==j+   YmmReg i == YmmReg j = i==j+   ZmmReg i == ZmmReg j = i==j+   Sp == Sp = True+   SpLim == SpLim = True+   Hp == Hp = True+   HpLim == HpLim = True+   CCCS == CCCS = True+   CurrentTSO == CurrentTSO = True+   CurrentNursery == CurrentNursery = True+   HpAlloc == HpAlloc = True+   EagerBlackholeInfo == EagerBlackholeInfo = True+   GCEnter1 == GCEnter1 = True+   GCFun == GCFun = True+   BaseReg == BaseReg = True+   MachSp == MachSp = True+   UnwindReturnReg == UnwindReturnReg = True+   PicBaseReg == PicBaseReg = True+   _r1 == _r2 = False++instance Ord GlobalReg where+   compare (VanillaReg i _) (VanillaReg j _) = compare i j+     -- Ignore type when seeking clashes+   compare (FloatReg i)  (FloatReg  j) = compare i j+   compare (DoubleReg i) (DoubleReg j) = compare i j+   compare (LongReg i)   (LongReg   j) = compare i j+   compare (XmmReg i)    (XmmReg    j) = compare i j+   compare (YmmReg i)    (YmmReg    j) = compare i j+   compare (ZmmReg i)    (ZmmReg    j) = compare i j+   compare Sp Sp = EQ+   compare SpLim SpLim = EQ+   compare Hp Hp = EQ+   compare HpLim HpLim = EQ+   compare CCCS CCCS = EQ+   compare CurrentTSO CurrentTSO = EQ+   compare CurrentNursery CurrentNursery = EQ+   compare HpAlloc HpAlloc = EQ+   compare EagerBlackholeInfo EagerBlackholeInfo = EQ+   compare GCEnter1 GCEnter1 = EQ+   compare GCFun GCFun = EQ+   compare BaseReg BaseReg = EQ+   compare MachSp MachSp = EQ+   compare UnwindReturnReg UnwindReturnReg = EQ+   compare PicBaseReg PicBaseReg = EQ+   compare (VanillaReg _ _) _ = LT+   compare _ (VanillaReg _ _) = GT+   compare (FloatReg _) _     = LT+   compare _ (FloatReg _)     = GT+   compare (DoubleReg _) _    = LT+   compare _ (DoubleReg _)    = GT+   compare (LongReg _) _      = LT+   compare _ (LongReg _)      = GT+   compare (XmmReg _) _       = LT+   compare _ (XmmReg _)       = GT+   compare (YmmReg _) _       = LT+   compare _ (YmmReg _)       = GT+   compare (ZmmReg _) _       = LT+   compare _ (ZmmReg _)       = GT+   compare Sp _ = LT+   compare _ Sp = GT+   compare SpLim _ = LT+   compare _ SpLim = GT+   compare Hp _ = LT+   compare _ Hp = GT+   compare HpLim _ = LT+   compare _ HpLim = GT+   compare CCCS _ = LT+   compare _ CCCS = GT+   compare CurrentTSO _ = LT+   compare _ CurrentTSO = GT+   compare CurrentNursery _ = LT+   compare _ CurrentNursery = GT+   compare HpAlloc _ = LT+   compare _ HpAlloc = GT+   compare GCEnter1 _ = LT+   compare _ GCEnter1 = GT+   compare GCFun _ = LT+   compare _ GCFun = GT+   compare BaseReg _ = LT+   compare _ BaseReg = GT+   compare MachSp _ = LT+   compare _ MachSp = GT+   compare UnwindReturnReg _ = LT+   compare _ UnwindReturnReg = GT+   compare EagerBlackholeInfo _ = LT+   compare _ EagerBlackholeInfo = GT++-- convenient aliases+baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,+  currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg  :: CmmReg+baseReg = CmmGlobal BaseReg+spReg = CmmGlobal Sp+hpReg = CmmGlobal Hp+hpLimReg = CmmGlobal HpLim+spLimReg = CmmGlobal SpLim+nodeReg = CmmGlobal node+currentTSOReg = CmmGlobal CurrentTSO+currentNurseryReg = CmmGlobal CurrentNursery+hpAllocReg = CmmGlobal HpAlloc+cccsReg = CmmGlobal CCCS++node :: GlobalReg+node = VanillaReg 1 VGcPtr++globalRegType :: DynFlags -> GlobalReg -> CmmType+globalRegType dflags (VanillaReg _ VGcPtr)    = gcWord dflags+globalRegType dflags (VanillaReg _ VNonGcPtr) = bWord dflags+globalRegType _      (FloatReg _)      = cmmFloat W32+globalRegType _      (DoubleReg _)     = cmmFloat W64+globalRegType _      (LongReg _)       = cmmBits W64+-- TODO: improve the internal model of SIMD/vectorized registers+-- the right design SHOULd improve handling of float and double code too.+-- see remarks in "NOTE [SIMD Design for the future]"" in StgCmmPrim+globalRegType _      (XmmReg _)        = cmmVec 4 (cmmBits W32)+globalRegType _      (YmmReg _)        = cmmVec 8 (cmmBits W32)+globalRegType _      (ZmmReg _)        = cmmVec 16 (cmmBits W32)++globalRegType dflags Hp                = gcWord dflags+                                            -- The initialiser for all+                                            -- dynamically allocated closures+globalRegType dflags _                 = bWord dflags++isArgReg :: GlobalReg -> Bool+isArgReg (VanillaReg {}) = True+isArgReg (FloatReg {})   = True+isArgReg (DoubleReg {})  = True+isArgReg (LongReg {})    = True+isArgReg (XmmReg {})     = True+isArgReg (YmmReg {})     = True+isArgReg (ZmmReg {})     = True+isArgReg _               = False
+ compiler/cmm/CmmImplementSwitchPlans.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE GADTs #-}+module CmmImplementSwitchPlans+  ( cmmImplementSwitchPlans+  )+where++import GhcPrelude++import Hoopl.Block+import BlockId+import Cmm+import CmmUtils+import CmmSwitch+import UniqSupply+import DynFlags++--+-- This module replaces Switch statements as generated by the Stg -> Cmm+-- transformation, which might be huge and sparse and hence unsuitable for+-- assembly code, by proper constructs (if-then-else trees, dense jump tables).+--+-- The actual, abstract strategy is determined by createSwitchPlan in+-- CmmSwitch and returned as a SwitchPlan; here is just the implementation in+-- terms of Cmm code. See Note [Cmm Switches, the general plan] in CmmSwitch.+--+-- This division into different modules is both to clearly separate concerns,+-- but also because createSwitchPlan needs access to the constructors of+-- SwitchTargets, a data type exported abstractly by CmmSwitch.+--++-- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for+-- code generation.+cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph+cmmImplementSwitchPlans dflags g+    | targetSupportsSwitch (hscTarget dflags) = return g+    | otherwise = do+    blocks' <- concat `fmap` mapM (visitSwitches dflags) (toBlockList g)+    return $ ofBlockList (g_entry g) blocks'++visitSwitches :: DynFlags -> CmmBlock -> UniqSM [CmmBlock]+visitSwitches dflags block+  | (entry@(CmmEntry _ scope), middle, CmmSwitch expr ids) <- blockSplit block+  = do+    let plan = createSwitchPlan ids++    (newTail, newBlocks) <- implementSwitchPlan dflags scope expr plan++    let block' = entry `blockJoinHead` middle `blockAppend` newTail++    return $ block' : newBlocks++  | otherwise+  = return [block]+++-- Implementing a switch plan (returning a tail block)+implementSwitchPlan :: DynFlags -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])+implementSwitchPlan dflags scope expr = go+  where+    go (Unconditionally l)+      = return (emptyBlock `blockJoinTail` CmmBranch l, [])+    go (JumpTable ids)+      = return (emptyBlock `blockJoinTail` CmmSwitch expr ids, [])+    go (IfLT signed i ids1 ids2)+      = do+        (bid1, newBlocks1) <- go' ids1+        (bid2, newBlocks2) <- go' ids2++        let lt | signed    = cmmSLtWord+               | otherwise = cmmULtWord+            scrut = lt dflags expr $ CmmLit $ mkWordCLit dflags i+            lastNode = CmmCondBranch scrut bid1 bid2 Nothing+            lastBlock = emptyBlock `blockJoinTail` lastNode+        return (lastBlock, newBlocks1++newBlocks2)+    go (IfEqual i l ids2)+      = do+        (bid2, newBlocks2) <- go' ids2++        let scrut = cmmNeWord dflags expr $ CmmLit $ mkWordCLit dflags i+            lastNode = CmmCondBranch scrut bid2 l Nothing+            lastBlock = emptyBlock `blockJoinTail` lastNode+        return (lastBlock, newBlocks2)++    -- Same but returning a label to branch to+    go' (Unconditionally l)+      = return (l, [])+    go' p+      = do+        bid <- mkBlockId `fmap` getUniqueM+        (last, newBlocks) <- go p+        let block = CmmEntry bid scope `blockJoinHead` last+        return (bid, block: newBlocks)
+ compiler/cmm/CmmInfo.hs view
@@ -0,0 +1,586 @@+{-# LANGUAGE CPP #-}+module CmmInfo (+  mkEmptyContInfoTable,+  cmmToRawCmm,+  mkInfoTable,+  srtEscape,++  -- info table accessors+  closureInfoPtr,+  entryCode,+  getConstrTag,+  cmmGetClosureType,+  infoTable,+  infoTableConstrTag,+  infoTableSrtBitmap,+  infoTableClosureType,+  infoTablePtrs,+  infoTableNonPtrs,+  funInfoTable,+  funInfoArity,++  -- info table sizes and offsets+  stdInfoTableSizeW,+  fixedInfoTableSizeW,+  profInfoTableSizeW,+  maxStdInfoTableSizeW,+  maxRetInfoTableSizeW,+  stdInfoTableSizeB,+  conInfoTableSizeB,+  stdSrtBitmapOffset,+  stdClosureTypeOffset,+  stdPtrsOffset, stdNonPtrsOffset,+) where++#include "HsVersions.h"++import GhcPrelude++import Cmm+import CmmUtils+import CLabel+import SMRep+import Bitmap+import Stream (Stream)+import qualified Stream+import Hoopl.Collections++import Platform+import Maybes+import DynFlags+import Panic+import UniqSupply+import MonadUtils+import Util+import Outputable++import Data.ByteString (ByteString)+import Data.Bits++-- When we split at proc points, we need an empty info table.+mkEmptyContInfoTable :: CLabel -> CmmInfoTable+mkEmptyContInfoTable info_lbl+  = CmmInfoTable { cit_lbl  = info_lbl+                 , cit_rep  = mkStackRep []+                 , cit_prof = NoProfilingInfo+                 , cit_srt  = Nothing+                 , cit_clo  = Nothing }++cmmToRawCmm :: DynFlags -> Stream IO CmmGroup ()+            -> IO (Stream IO RawCmmGroup ())+cmmToRawCmm dflags cmms+  = do { uniqs <- mkSplitUniqSupply 'i'+       ; let do_one uniqs cmm = do+                case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of+                  (b,uniqs') -> return (uniqs',b)+                  -- NB. strictness fixes a space leak.  DO NOT REMOVE.+       ; return (Stream.mapAccumL do_one uniqs cmms >> return ())+       }++-- Make a concrete info table, represented as a list of CmmStatic+-- (it can't be simply a list of Word, because the SRT field is+-- represented by a label+offset expression).+--+-- With tablesNextToCode, the layout is+--      <reversed variable part>+--      <normal forward StgInfoTable, but without+--              an entry point at the front>+--      <code>+--+-- Without tablesNextToCode, the layout of an info table is+--      <entry label>+--      <normal forward rest of StgInfoTable>+--      <forward variable part>+--+--      See includes/rts/storage/InfoTables.h+--+-- For return-points these are as follows+--+-- Tables next to code:+--+--                      <srt slot>+--                      <standard info table>+--      ret-addr -->    <entry code (if any)>+--+-- Not tables-next-to-code:+--+--      ret-addr -->    <ptr to entry code>+--                      <standard info table>+--                      <srt slot>+--+--  * The SRT slot is only there if there is SRT info to record++mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]+mkInfoTable _ (CmmData sec dat)+  = return [CmmData sec dat]++mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)+  --+  -- in the non-tables-next-to-code case, procs can have at most a+  -- single info table associated with the entry label of the proc.+  --+  | not (tablesNextToCode dflags)+  = case topInfoTable proc of   --  must be at most one+      -- no info table+      Nothing ->+         return [CmmProc mapEmpty entry_lbl live blocks]++      Just info@CmmInfoTable { cit_lbl = info_lbl } -> do+        (top_decls, (std_info, extra_bits)) <-+             mkInfoTableContents dflags info Nothing+        let+          rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info+          rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits+        --+        -- Separately emit info table (with the function entry+        -- point as first entry) and the entry code+        --+        return (top_decls +++                [CmmProc mapEmpty entry_lbl live blocks,+                 mkRODataLits info_lbl+                    (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])++  --+  -- With tables-next-to-code, we can have many info tables,+  -- associated with some of the BlockIds of the proc.  For each info+  -- table we need to turn it into CmmStatics, and collect any new+  -- CmmDecls that arise from doing so.+  --+  | otherwise+  = do+    (top_declss, raw_infos) <-+       unzip `fmap` mapM do_one_info (mapToList (info_tbls infos))+    return (concat top_declss +++            [CmmProc (mapFromList raw_infos) entry_lbl live blocks])++  where+   do_one_info (lbl,itbl) = do+     (top_decls, (std_info, extra_bits)) <-+         mkInfoTableContents dflags itbl Nothing+     let+        info_lbl = cit_lbl itbl+        rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info+        rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits+     --+     return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $+                              reverse rel_extra_bits ++ rel_std_info))++-----------------------------------------------------+type InfoTableContents = ( [CmmLit]          -- The standard part+                         , [CmmLit] )        -- The "extra bits"+-- These Lits have *not* had mkRelativeTo applied to them++mkInfoTableContents :: DynFlags+                    -> CmmInfoTable+                    -> Maybe Int               -- Override default RTS type tag?+                    -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls+                               InfoTableContents)       -- Info tbl + extra bits++mkInfoTableContents dflags+                    info@(CmmInfoTable { cit_lbl  = info_lbl+                                       , cit_rep  = smrep+                                       , cit_prof = prof+                                       , cit_srt = srt })+                    mb_rts_tag+  | RTSRep rts_tag rep <- smrep+  = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag)+    -- Completely override the rts_tag that mkInfoTableContents would+    -- otherwise compute, with the rts_tag stored in the RTSRep+    -- (which in turn came from a handwritten .cmm file)++  | StackRep frame <- smrep+  = do { (prof_lits, prof_data) <- mkProfLits dflags prof+       ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt+       ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame+       ; let+             std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit+             rts_tag | Just tag <- mb_rts_tag = tag+                     | null liveness_data     = rET_SMALL -- Fits in extra_bits+                     | otherwise              = rET_BIG   -- Does not; extra_bits is+                                                          -- a label+       ; return (prof_data ++ liveness_data, (std_info, srt_label)) }++  | HeapRep _ ptrs nonptrs closure_type <- smrep+  = do { let layout  = packIntsCLit dflags ptrs nonptrs+       ; (prof_lits, prof_data) <- mkProfLits dflags prof+       ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt+       ; (mb_srt_field, mb_layout, extra_bits, ct_data)+                                <- mk_pieces closure_type srt_label+       ; let std_info = mkStdInfoTable dflags prof_lits+                                       (mb_rts_tag   `orElse` rtsClosureType smrep)+                                       (mb_srt_field `orElse` srt_bitmap)+                                       (mb_layout    `orElse` layout)+       ; return (prof_data ++ ct_data, (std_info, extra_bits)) }+  where+    mk_pieces :: ClosureTypeInfo -> [CmmLit]+              -> UniqSM ( Maybe CmmLit  -- Override the SRT field with this+                        , Maybe CmmLit  -- Override the layout field with this+                        , [CmmLit]           -- "Extra bits" for info table+                        , [RawCmmDecl])      -- Auxiliary data decls+    mk_pieces (Constr con_tag con_descr) _no_srt    -- A data constructor+      = do { (descr_lit, decl) <- newStringLit con_descr+           ; return ( Just (CmmInt (fromIntegral con_tag)+                                   (halfWordWidth dflags))+                    , Nothing, [descr_lit], [decl]) }++    mk_pieces Thunk srt_label+      = return (Nothing, Nothing, srt_label, [])++    mk_pieces (ThunkSelector offset) _no_srt+      = return (Just (CmmInt 0 (halfWordWidth dflags)),+                Just (mkWordCLit dflags (fromIntegral offset)), [], [])+         -- Layout known (one free var); we use the layout field for offset++    mk_pieces (Fun arity (ArgSpec fun_type)) srt_label+      = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label+           ; return (Nothing, Nothing,  extra_bits, []) }++    mk_pieces (Fun arity (ArgGen arg_bits)) srt_label+      = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits+           ; let fun_type | null liveness_data = aRG_GEN+                          | otherwise          = aRG_GEN_BIG+                 extra_bits = [ packIntsCLit dflags fun_type arity ]+                           ++ (if inlineSRT dflags then [] else [ srt_lit ])+                           ++ [ liveness_lit, slow_entry ]+           ; return (Nothing, Nothing, extra_bits, liveness_data) }+      where+        slow_entry = CmmLabel (toSlowEntryLbl info_lbl)+        srt_lit = case srt_label of+                    []          -> mkIntCLit dflags 0+                    (lit:_rest) -> ASSERT( null _rest ) lit++    mk_pieces other _ = pprPanic "mk_pieces" (ppr other)++mkInfoTableContents _ _ _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier++packIntsCLit :: DynFlags -> Int -> Int -> CmmLit+packIntsCLit dflags a b = packHalfWordsCLit dflags+                           (toStgHalfWord dflags (fromIntegral a))+                           (toStgHalfWord dflags (fromIntegral b))+++mkSRTLit :: DynFlags+         -> CLabel+         -> Maybe CLabel+         -> ([CmmLit],    -- srt_label, if any+             CmmLit)      -- srt_bitmap+mkSRTLit dflags info_lbl (Just lbl)+  | inlineSRT dflags+  = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth dflags))+mkSRTLit dflags _ Nothing    = ([], CmmInt 0 (halfWordWidth dflags))+mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth dflags))+++-- | Is the SRT offset field inline in the info table on this platform?+--+-- See the section "Referring to an SRT from the info table" in+-- Note [SRTs] in CmmBuildInfoTables.hs+inlineSRT :: DynFlags -> Bool+inlineSRT dflags = platformArch (targetPlatform dflags) == ArchX86_64+  && tablesNextToCode dflags++-------------------------------------------------------------------------+--+--      Lay out the info table and handle relative offsets+--+-------------------------------------------------------------------------++-- This function takes+--   * the standard info table portion (StgInfoTable)+--   * the "extra bits" (StgFunInfoExtraRev etc.)+--   * the entry label+--   * the code+-- and lays them out in memory, producing a list of RawCmmDecl++-------------------------------------------------------------------------+--+--      Position independent code+--+-------------------------------------------------------------------------+-- In order to support position independent code, we mustn't put absolute+-- references into read-only space. Info tables in the tablesNextToCode+-- case must be in .text, which is read-only, so we doctor the CmmLits+-- to use relative offsets instead.++-- Note that this is done even when the -fPIC flag is not specified,+-- as we want to keep binary compatibility between PIC and non-PIC.++makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit++makeRelativeRefTo dflags info_lbl (CmmLabel lbl)+  | tablesNextToCode dflags+  = CmmLabelDiffOff lbl info_lbl 0 (wordWidth dflags)+makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)+  | tablesNextToCode dflags+  = CmmLabelDiffOff lbl info_lbl off (wordWidth dflags)+makeRelativeRefTo _ _ lit = lit+++-------------------------------------------------------------------------+--+--              Build a liveness mask for the stack layout+--+-------------------------------------------------------------------------++-- There are four kinds of things on the stack:+--+--      - pointer variables (bound in the environment)+--      - non-pointer variables (bound in the environment)+--      - free slots (recorded in the stack free list)+--      - non-pointer data slots (recorded in the stack free list)+--+-- The first two are represented with a 'Just' of a 'LocalReg'.+-- The last two with one or more 'Nothing' constructors.+-- Each 'Nothing' represents one used word.+--+-- The head of the stack layout is the top of the stack and+-- the least-significant bit.++mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])+              -- ^ Returns:+              --   1. The bitmap (literal value or label)+              --   2. Large bitmap CmmData if needed++mkLivenessBits dflags liveness+  | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word+  = do { uniq <- getUniqueM+       ; let bitmap_lbl = mkBitmapLabel uniq+       ; return (CmmLabel bitmap_lbl,+                 [mkRODataLits bitmap_lbl lits]) }++  | otherwise -- Fits in one word+  = return (mkStgWordCLit dflags bitmap_word, [])+  where+    n_bits = length liveness++    bitmap :: Bitmap+    bitmap = mkBitmap dflags liveness++    small_bitmap = case bitmap of+                     []  -> toStgWord dflags 0+                     [b] -> b+                     _   -> panic "mkLiveness"+    bitmap_word = toStgWord dflags (fromIntegral n_bits)+              .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)++    lits = mkWordCLit dflags (fromIntegral n_bits)+         : map (mkStgWordCLit dflags) bitmap+      -- The first word is the size.  The structure must match+      -- StgLargeBitmap in includes/rts/storage/InfoTable.h++-------------------------------------------------------------------------+--+--      Generating a standard info table+--+-------------------------------------------------------------------------++-- The standard bits of an info table.  This part of the info table+-- corresponds to the StgInfoTable type defined in+-- includes/rts/storage/InfoTables.h.+--+-- Its shape varies with ticky/profiling/tables next to code etc+-- so we can't use constant offsets from Constants++mkStdInfoTable+   :: DynFlags+   -> (CmmLit,CmmLit)   -- Closure type descr and closure descr  (profiling)+   -> Int               -- Closure RTS tag+   -> CmmLit            -- SRT length+   -> CmmLit            -- layout field+   -> [CmmLit]++mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit+ =      -- Parallel revertible-black hole field+    prof_info+        -- Ticky info (none at present)+        -- Debug info (none at present)+ ++ [layout_lit, tag, srt]++ where+    prof_info+        | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]+        | otherwise = []++    tag = CmmInt (fromIntegral cl_type) (halfWordWidth dflags)++-------------------------------------------------------------------------+--+--      Making string literals+--+-------------------------------------------------------------------------++mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])+mkProfLits dflags NoProfilingInfo       = return ((zeroCLit dflags, zeroCLit dflags), [])+mkProfLits _ (ProfilingInfo td cd)+  = do { (td_lit, td_decl) <- newStringLit td+       ; (cd_lit, cd_decl) <- newStringLit cd+       ; return ((td_lit,cd_lit), [td_decl,cd_decl]) }++newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)+newStringLit bytes+  = do { uniq <- getUniqueM+       ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }+++-- Misc utils++-- | Value of the srt field of an info table when using an StgLargeSRT+srtEscape :: DynFlags -> StgHalfWord+srtEscape dflags = toStgHalfWord dflags (-1)++-------------------------------------------------------------------------+--+--      Accessing fields of an info table+--+-------------------------------------------------------------------------++-- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is+-- enabled.+wordAligned :: DynFlags -> CmmExpr -> CmmExpr+wordAligned dflags e+  | gopt Opt_AlignmentSanitisation dflags+  = CmmMachOp (MO_AlignmentCheck (wORD_SIZE dflags) (wordWidth dflags)) [e]+  | otherwise+  = e++closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr+-- Takes a closure pointer and returns the info table pointer+closureInfoPtr dflags e =+    CmmLoad (wordAligned dflags e) (bWord dflags)++entryCode :: DynFlags -> CmmExpr -> CmmExpr+-- Takes an info pointer (the first word of a closure)+-- and returns its entry code+entryCode dflags e+ | tablesNextToCode dflags = e+ | otherwise               = CmmLoad e (bWord dflags)++getConstrTag :: DynFlags -> CmmExpr -> CmmExpr+-- Takes a closure pointer, and return the *zero-indexed*+-- constructor tag obtained from the info table+-- This lives in the SRT field of the info table+-- (constructors don't need SRTs).+getConstrTag dflags closure_ptr+  = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]+  where+    info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)++cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr+-- Takes a closure pointer, and return the closure type+-- obtained from the info table+cmmGetClosureType dflags closure_ptr+  = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]+  where+    info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)++infoTable :: DynFlags -> CmmExpr -> CmmExpr+-- Takes an info pointer (the first word of a closure)+-- and returns a pointer to the first word of the standard-form+-- info table, excluding the entry-code word (if present)+infoTable dflags info_ptr+  | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)+  | otherwise               = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer++infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr+-- Takes an info table pointer (from infoTable) and returns the constr tag+-- field of the info table (same as the srt_bitmap field)+infoTableConstrTag = infoTableSrtBitmap++infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr+-- Takes an info table pointer (from infoTable) and returns the srt_bitmap+-- field of the info table+infoTableSrtBitmap dflags info_tbl+  = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)++infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr+-- Takes an info table pointer (from infoTable) and returns the closure type+-- field of the info table.+infoTableClosureType dflags info_tbl+  = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)++infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr+infoTablePtrs dflags info_tbl+  = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)++infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr+infoTableNonPtrs dflags info_tbl+  = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)++funInfoTable :: DynFlags -> CmmExpr -> CmmExpr+-- Takes the info pointer of a function,+-- and returns a pointer to the first word of the StgFunInfoExtra struct+-- in the info table.+funInfoTable dflags info_ptr+  | tablesNextToCode dflags+  = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)+  | otherwise+  = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)+                                -- Past the entry code pointer++-- Takes the info pointer of a function, returns the function's arity+funInfoArity :: DynFlags -> CmmExpr -> CmmExpr+funInfoArity dflags iptr+  = cmmToWord dflags (cmmLoadIndex dflags rep fun_info (offset `div` rep_bytes))+  where+   fun_info = funInfoTable dflags iptr+   rep = cmmBits (widthFromBytes rep_bytes)++   (rep_bytes, offset)+    | tablesNextToCode dflags = ( pc_REP_StgFunInfoExtraRev_arity pc+                                , oFFSET_StgFunInfoExtraRev_arity dflags )+    | otherwise               = ( pc_REP_StgFunInfoExtraFwd_arity pc+                                , oFFSET_StgFunInfoExtraFwd_arity dflags )++   pc = sPlatformConstants (settings dflags)++-----------------------------------------------------------------------------+--+--      Info table sizes & offsets+--+-----------------------------------------------------------------------------++stdInfoTableSizeW :: DynFlags -> WordOff+-- The size of a standard info table varies with profiling/ticky etc,+-- so we can't get it from Constants+-- It must vary in sync with mkStdInfoTable+stdInfoTableSizeW dflags+  = fixedInfoTableSizeW+  + if gopt Opt_SccProfilingOn dflags+       then profInfoTableSizeW+       else 0++fixedInfoTableSizeW :: WordOff+fixedInfoTableSizeW = 2 -- layout, type++profInfoTableSizeW :: WordOff+profInfoTableSizeW = 2++maxStdInfoTableSizeW :: WordOff+maxStdInfoTableSizeW =+  1 {- entry, when !tablesNextToCode -}+  + fixedInfoTableSizeW+  + profInfoTableSizeW++maxRetInfoTableSizeW :: WordOff+maxRetInfoTableSizeW =+  maxStdInfoTableSizeW+  + 1 {- srt label -}++stdInfoTableSizeB  :: DynFlags -> ByteOff+stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags++stdSrtBitmapOffset :: DynFlags -> ByteOff+-- Byte offset of the SRT bitmap half-word which is+-- in the *higher-addressed* part of the type_lit+stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags++stdClosureTypeOffset :: DynFlags -> ByteOff+-- Byte offset of the closure type half-word+stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags++stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff+stdPtrsOffset    dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags+stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags++conInfoTableSizeB :: DynFlags -> Int+conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags
+ compiler/cmm/CmmLayoutStack.hs view
@@ -0,0 +1,1237 @@+{-# LANGUAGE BangPatterns, RecordWildCards, GADTs #-}+module CmmLayoutStack (+       cmmLayoutStack, setInfoTableStackMap+  ) where++import GhcPrelude hiding ((<*>))++import StgCmmUtils      ( callerSaveVolatileRegs ) -- XXX layering violation+import StgCmmForeign    ( saveThreadState, loadThreadState ) -- XXX layering violation++import BasicTypes+import Cmm+import CmmInfo+import BlockId+import CLabel+import CmmUtils+import MkGraph+import ForeignCall+import CmmLive+import CmmProcPoint+import SMRep+import Hoopl.Block+import Hoopl.Collections+import Hoopl.Dataflow+import Hoopl.Graph+import Hoopl.Label+import UniqSupply+import StgCmmUtils      ( newTemp )+import Maybes+import UniqFM+import Util++import DynFlags+import FastString+import Outputable hiding ( isEmpty )+import qualified Data.Set as Set+import Control.Monad.Fix+import Data.Array as Array+import Data.Bits+import Data.List (nub)++{- Note [Stack Layout]++The job of this pass is to++ - replace references to abstract stack Areas with fixed offsets from Sp.++ - replace the CmmHighStackMark constant used in the stack check with+   the maximum stack usage of the proc.++ - save any variables that are live across a call, and reload them as+   necessary.++Before stack allocation, local variables remain live across native+calls (CmmCall{ cmm_cont = Just _ }), and after stack allocation local+variables are clobbered by native calls.++We want to do stack allocation so that as far as possible+ - stack use is minimized, and+ - unnecessary stack saves and loads are avoided.++The algorithm we use is a variant of linear-scan register allocation,+where the stack is our register file.++We proceed in two passes, see Note [Two pass approach] for why they are not easy+to merge into one.++Pass 1:++ - First, we do a liveness analysis, which annotates every block with+   the variables live on entry to the block.++ - We traverse blocks in reverse postorder DFS; that is, we visit at+   least one predecessor of a block before the block itself.  The+   stack layout flowing from the predecessor of the block will+   determine the stack layout on entry to the block.++ - We maintain a data structure++     Map Label StackMap++   which describes the contents of the stack and the stack pointer on+   entry to each block that is a successor of a block that we have+   visited.++ - For each block we visit:++    - Look up the StackMap for this block.++    - If this block is a proc point (or a call continuation, if we aren't+      splitting proc points), we need to reload all the live variables from the+      stack - but this is done in Pass 2, which calculates more precise liveness+      information (see description of Pass 2).++    - Walk forwards through the instructions:+      - At an assignment  x = Sp[loc]+        - Record the fact that Sp[loc] contains x, so that we won't+          need to save x if it ever needs to be spilled.+      - At an assignment  x = E+        - If x was previously on the stack, it isn't any more+      - At the last node, if it is a call or a jump to a proc point+        - Lay out the stack frame for the call (see setupStackFrame)+        - emit instructions to save all the live variables+        - Remember the StackMaps for all the successors+        - emit an instruction to adjust Sp+      - If the last node is a branch, then the current StackMap is the+        StackMap for the successors.++    - Manifest Sp: replace references to stack areas in this block+      with real Sp offsets. We cannot do this until we have laid out+      the stack area for the successors above.++      In this phase we also eliminate redundant stores to the stack;+      see elimStackStores.++  - There is one important gotcha: sometimes we'll encounter a control+    transfer to a block that we've already processed (a join point),+    and in that case we might need to rearrange the stack to match+    what the block is expecting. (exactly the same as in linear-scan+    register allocation, except here we have the luxury of an infinite+    supply of temporary variables).++  - Finally, we update the magic CmmHighStackMark constant with the+    stack usage of the function, and eliminate the whole stack check+    if there was no stack use. (in fact this is done as part of the+    main traversal, by feeding the high-water-mark output back in as+    an input. I hate cyclic programming, but it's just too convenient+    sometimes.)++  There are plenty of tricky details: update frames, proc points, return+  addresses, foreign calls, and some ad-hoc optimisations that are+  convenient to do here and effective in common cases.  Comments in the+  code below explain these.++Pass 2:++- Calculate live registers, but taking into account that nothing is live at the+  entry to a proc point.++- At each proc point and call continuation insert reloads of live registers from+  the stack (they were saved by Pass 1).+++Note [Two pass approach]++The main reason for Pass 2 is being able to insert only the reloads that are+needed and the fact that the two passes need different liveness information.+Let's consider an example:++  .....+   \ /+    D   <- proc point+   / \+  E   F+   \ /+    G   <- proc point+    |+    X++Pass 1 needs liveness assuming that local variables are preserved across calls.+This is important because it needs to save any local registers to the stack+(e.g., if register a is used in block X, it must be saved before any native+call).+However, for Pass 2, where we want to reload registers from stack (in a proc+point), this is overly conservative and would lead us to generate reloads in D+for things used in X, even though we're going to generate reloads in G anyway+(since it's also a proc point).+So Pass 2 calculates liveness knowing that nothing is live at the entry to a+proc point. This means that in D we only need to reload things used in E or F.+This can be quite important, for an extreme example see testcase for #3294.++Merging the two passes is not trivial - Pass 2 is a backward rewrite and Pass 1+is a forward one. Furthermore, Pass 1 is creating code that uses local registers+(saving them before a call), which the liveness analysis for Pass 2 must see to+be correct.++-}+++-- All stack locations are expressed as positive byte offsets from the+-- "base", which is defined to be the address above the return address+-- on the stack on entry to this CmmProc.+--+-- Lower addresses have higher StackLocs.+--+type StackLoc = ByteOff++{-+ A StackMap describes the stack at any given point.  At a continuation+ it has a particular layout, like this:++         |             | <- base+         |-------------|+         |     ret0    | <- base + 8+         |-------------|+         .  upd frame  . <- base + sm_ret_off+         |-------------|+         |             |+         .    vars     .+         . (live/dead) .+         |             | <- base + sm_sp - sm_args+         |-------------|+         |    ret1     |+         .  ret vals   . <- base + sm_sp    (<--- Sp points here)+         |-------------|++Why do we include the final return address (ret0) in our stack map?  I+have absolutely no idea, but it seems to be done that way consistently+in the rest of the code generator, so I played along here. --SDM++Note that we will be constructing an info table for the continuation+(ret1), which needs to describe the stack down to, but not including,+the update frame (or ret0, if there is no update frame).+-}++data StackMap = StackMap+ {  sm_sp   :: StackLoc+       -- ^ the offset of Sp relative to the base on entry+       -- to this block.+ ,  sm_args :: ByteOff+       -- ^ the number of bytes of arguments in the area for this block+       -- Defn: the offset of young(L) relative to the base is given by+       -- (sm_sp - sm_args) of the StackMap for block L.+ ,  sm_ret_off :: ByteOff+       -- ^ Number of words of stack that we do not describe with an info+       -- table, because it contains an update frame.+ ,  sm_regs :: UniqFM (LocalReg,StackLoc)+       -- ^ regs on the stack+ }++instance Outputable StackMap where+  ppr StackMap{..} =+     text "Sp = " <> int sm_sp $$+     text "sm_args = " <> int sm_args $$+     text "sm_ret_off = " <> int sm_ret_off $$+     text "sm_regs = " <> pprUFM sm_regs ppr+++cmmLayoutStack :: DynFlags -> ProcPointSet -> ByteOff -> CmmGraph+               -> UniqSM (CmmGraph, LabelMap StackMap)+cmmLayoutStack dflags procpoints entry_args+               graph@(CmmGraph { g_entry = entry })+  = do+    -- We need liveness info. Dead assignments are removed later+    -- by the sinking pass.+    let liveness = cmmLocalLiveness dflags graph+        blocks = revPostorder graph++    (final_stackmaps, _final_high_sp, new_blocks) <-+          mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->+            layout dflags procpoints liveness entry entry_args+                   rec_stackmaps rec_high_sp blocks++    blocks_with_reloads <-+        insertReloadsAsNeeded dflags procpoints final_stackmaps entry new_blocks+    new_blocks' <- mapM (lowerSafeForeignCall dflags) blocks_with_reloads+    return (ofBlockList entry new_blocks', final_stackmaps)++-- -----------------------------------------------------------------------------+-- Pass 1+-- -----------------------------------------------------------------------------++layout :: DynFlags+       -> LabelSet                      -- proc points+       -> LabelMap CmmLocalLive         -- liveness+       -> BlockId                       -- entry+       -> ByteOff                       -- stack args on entry++       -> LabelMap StackMap             -- [final] stack maps+       -> ByteOff                       -- [final] Sp high water mark++       -> [CmmBlock]                    -- [in] blocks++       -> UniqSM+          ( LabelMap StackMap           -- [out] stack maps+          , ByteOff                     -- [out] Sp high water mark+          , [CmmBlock]                  -- [out] new blocks+          )++layout dflags procpoints liveness entry entry_args final_stackmaps final_sp_high blocks+  = go blocks init_stackmap entry_args []+  where+    (updfr, cont_info)  = collectContInfo blocks++    init_stackmap = mapSingleton entry StackMap{ sm_sp   = entry_args+                                               , sm_args = entry_args+                                               , sm_ret_off = updfr+                                               , sm_regs = emptyUFM+                                               }++    go [] acc_stackmaps acc_hwm acc_blocks+      = return (acc_stackmaps, acc_hwm, acc_blocks)++    go (b0 : bs) acc_stackmaps acc_hwm acc_blocks+      = do+       let (entry0@(CmmEntry entry_lbl tscope), middle0, last0) = blockSplit b0++       let stack0@StackMap { sm_sp = sp0 }+               = mapFindWithDefault+                     (pprPanic "no stack map for" (ppr entry_lbl))+                     entry_lbl acc_stackmaps++       -- (a) Update the stack map to include the effects of+       --     assignments in this block+       let stack1 = foldBlockNodesF (procMiddle acc_stackmaps) middle0 stack0++       -- (b) Look at the last node and if we are making a call or+       --     jumping to a proc point, we must save the live+       --     variables, adjust Sp, and construct the StackMaps for+       --     each of the successor blocks.  See handleLastNode for+       --     details.+       (middle1, sp_off, last1, fixup_blocks, out)+           <- handleLastNode dflags procpoints liveness cont_info+                             acc_stackmaps stack1 tscope middle0 last0++       -- (c) Manifest Sp: run over the nodes in the block and replace+       --     CmmStackSlot with CmmLoad from Sp with a concrete offset.+       --+       -- our block:+       --    middle0          -- the original middle nodes+       --    middle1          -- live variable saves from handleLastNode+       --    Sp = Sp + sp_off -- Sp adjustment goes here+       --    last1            -- the last node+       --+       let middle_pre = blockToList $ foldl' blockSnoc middle0 middle1++       let final_blocks =+               manifestSp dflags final_stackmaps stack0 sp0 final_sp_high+                          entry0 middle_pre sp_off last1 fixup_blocks++       let acc_stackmaps' = mapUnion acc_stackmaps out++           -- If this block jumps to the GC, then we do not take its+           -- stack usage into account for the high-water mark.+           -- Otherwise, if the only stack usage is in the stack-check+           -- failure block itself, we will do a redundant stack+           -- check.  The stack has a buffer designed to accommodate+           -- the largest amount of stack needed for calling the GC.+           --+           this_sp_hwm | isGcJump last0 = 0+                       | otherwise      = sp0 - sp_off++           hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out))++       go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks)+++-- -----------------------------------------------------------------------------++-- Not foolproof, but GCFun is the culprit we most want to catch+isGcJump :: CmmNode O C -> Bool+isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) })+  = l == GCFun || l == GCEnter1+isGcJump _something_else = False++-- -----------------------------------------------------------------------------++-- This doesn't seem right somehow.  We need to find out whether this+-- proc will push some update frame material at some point, so that we+-- can avoid using that area of the stack for spilling.  The+-- updfr_space field of the CmmProc *should* tell us, but it doesn't+-- (I think maybe it gets filled in later when we do proc-point+-- splitting).+--+-- So we'll just take the max of all the cml_ret_offs.  This could be+-- unnecessarily pessimistic, but probably not in the code we+-- generate.++collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff)+collectContInfo blocks+  = (maximum ret_offs, mapFromList (catMaybes mb_argss))+ where+  (mb_argss, ret_offs) = mapAndUnzip get_cont blocks++  get_cont :: Block CmmNode x C -> (Maybe (Label, ByteOff), ByteOff)+  get_cont b =+     case lastNode b of+        CmmCall { cml_cont = Just l, .. }+           -> (Just (l, cml_ret_args), cml_ret_off)+        CmmForeignCall { .. }+           -> (Just (succ, ret_args), ret_off)+        _other -> (Nothing, 0)+++-- -----------------------------------------------------------------------------+-- Updating the StackMap from middle nodes++-- Look for loads from stack slots, and update the StackMap.  This is+-- purely for optimisation reasons, so that we can avoid saving a+-- variable back to a different stack slot if it is already on the+-- stack.+--+-- This happens a lot: for example when function arguments are passed+-- on the stack and need to be immediately saved across a call, we+-- want to just leave them where they are on the stack.+--+procMiddle :: LabelMap StackMap -> CmmNode e x -> StackMap -> StackMap+procMiddle stackmaps node sm+  = case node of+     CmmAssign (CmmLocal r) (CmmLoad (CmmStackSlot area off) _)+       -> sm { sm_regs = addToUFM (sm_regs sm) r (r,loc) }+        where loc = getStackLoc area off stackmaps+     CmmAssign (CmmLocal r) _other+       -> sm { sm_regs = delFromUFM (sm_regs sm) r }+     _other+       -> sm++getStackLoc :: Area -> ByteOff -> LabelMap StackMap -> StackLoc+getStackLoc Old       n _         = n+getStackLoc (Young l) n stackmaps =+  case mapLookup l stackmaps of+    Nothing -> pprPanic "getStackLoc" (ppr l)+    Just sm -> sm_sp sm - sm_args sm + n+++-- -----------------------------------------------------------------------------+-- Handling stack allocation for a last node++-- We take a single last node and turn it into:+--+--    C1 (some statements)+--    Sp = Sp + N+--    C2 (some more statements)+--    call f()          -- the actual last node+--+-- plus possibly some more blocks (we may have to add some fixup code+-- between the last node and the continuation).+--+-- C1: is the code for saving the variables across this last node onto+-- the stack, if the continuation is a call or jumps to a proc point.+--+-- C2: if the last node is a safe foreign call, we have to inject some+-- extra code that goes *after* the Sp adjustment.++handleLastNode+   :: DynFlags -> ProcPointSet -> LabelMap CmmLocalLive -> LabelMap ByteOff+   -> LabelMap StackMap -> StackMap -> CmmTickScope+   -> Block CmmNode O O+   -> CmmNode O C+   -> UniqSM+      ( [CmmNode O O]      -- nodes to go *before* the Sp adjustment+      , ByteOff            -- amount to adjust Sp+      , CmmNode O C        -- new last node+      , [CmmBlock]         -- new blocks+      , LabelMap StackMap  -- stackmaps for the continuations+      )++handleLastNode dflags procpoints liveness cont_info stackmaps+               stack0@StackMap { sm_sp = sp0 } tscp middle last+ = case last of+    --  At each return / tail call,+    --  adjust Sp to point to the last argument pushed, which+    --  is cml_args, after popping any other junk from the stack.+    CmmCall{ cml_cont = Nothing, .. } -> do+      let sp_off = sp0 - cml_args+      return ([], sp_off, last, [], mapEmpty)++    --  At each CmmCall with a continuation:+    CmmCall{ cml_cont = Just cont_lbl, .. } ->+       return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off++    CmmForeignCall{ succ = cont_lbl, .. } -> do+       return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off+            -- one word of args: the return address++    CmmBranch {}     ->  handleBranches+    CmmCondBranch {} ->  handleBranches+    CmmSwitch {}     ->  handleBranches++  where+     -- Calls and ForeignCalls are handled the same way:+     lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff+              -> ( [CmmNode O O]+                 , ByteOff+                 , CmmNode O C+                 , [CmmBlock]+                 , LabelMap StackMap+                 )+     lastCall lbl cml_args cml_ret_args cml_ret_off+      =  ( assignments+         , spOffsetForCall sp0 cont_stack cml_args+         , last+         , [] -- no new blocks+         , mapSingleton lbl cont_stack )+      where+         (assignments, cont_stack) = prepareStack lbl cml_ret_args cml_ret_off+++     prepareStack lbl cml_ret_args cml_ret_off+       | Just cont_stack <- mapLookup lbl stackmaps+             -- If we have already seen this continuation before, then+             -- we just have to make the stack look the same:+       = (fixupStack stack0 cont_stack, cont_stack)+             -- Otherwise, we have to allocate the stack frame+       | otherwise+       = (save_assignments, new_cont_stack)+       where+        (new_cont_stack, save_assignments)+           = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0+++     -- For other last nodes (branches), if any of the targets is a+     -- proc point, we have to set up the stack to match what the proc+     -- point is expecting.+     --+     handleBranches :: UniqSM ( [CmmNode O O]+                                , ByteOff+                                , CmmNode O C+                                , [CmmBlock]+                                , LabelMap StackMap )++     handleBranches+         -- Note [diamond proc point]+       | Just l <- futureContinuation middle+       , (nub $ filter (`setMember` procpoints) $ successors last) == [l]+       = do+         let cont_args = mapFindWithDefault 0 l cont_info+             (assigs, cont_stack) = prepareStack l cont_args (sm_ret_off stack0)+             out = mapFromList [ (l', cont_stack)+                               | l' <- successors last ]+         return ( assigs+                , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags)+                , last+                , []+                , out)++        | otherwise = do+          pps <- mapM handleBranch (successors last)+          let lbl_map :: LabelMap Label+              lbl_map = mapFromList [ (l,tmp) | (l,tmp,_,_) <- pps ]+              fix_lbl l = mapFindWithDefault l l lbl_map+          return ( []+                 , 0+                 , mapSuccessors fix_lbl last+                 , concat [ blk | (_,_,_,blk) <- pps ]+                 , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] )++     -- For each successor of this block+     handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])+     handleBranch l+        --   (a) if the successor already has a stackmap, we need to+        --       shuffle the current stack to make it look the same.+        --       We have to insert a new block to make this happen.+        | Just stack2 <- mapLookup l stackmaps+        = do+             let assigs = fixupStack stack0 stack2+             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs+             return (l, tmp_lbl, stack2, block)++        --   (b) if the successor is a proc point, save everything+        --       on the stack.+        | l `setMember` procpoints+        = do+             let cont_args = mapFindWithDefault 0 l cont_info+                 (stack2, assigs) =+                      setupStackFrame dflags l liveness (sm_ret_off stack0)+                                                        cont_args stack0+             (tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs+             return (l, tmp_lbl, stack2, block)++        --   (c) otherwise, the current StackMap is the StackMap for+        --       the continuation.  But we must remember to remove any+        --       variables from the StackMap that are *not* live at+        --       the destination, because this StackMap might be used+        --       by fixupStack if this is a join point.+        | otherwise = return (l, l, stack1, [])+        where live = mapFindWithDefault (panic "handleBranch") l liveness+              stack1 = stack0 { sm_regs = filterUFM is_live (sm_regs stack0) }+              is_live (r,_) = r `elemRegSet` live+++makeFixupBlock :: DynFlags -> ByteOff -> Label -> StackMap+               -> CmmTickScope -> [CmmNode O O]+               -> UniqSM (Label, [CmmBlock])+makeFixupBlock dflags sp0 l stack tscope assigs+  | null assigs && sp0 == sm_sp stack = return (l, [])+  | otherwise = do+    tmp_lbl <- newBlockId+    let sp_off = sp0 - sm_sp stack+        block = blockJoin (CmmEntry tmp_lbl tscope)+                          ( maybeAddSpAdj dflags sp0 sp_off+                           $ blockFromList assigs )+                          (CmmBranch l)+    return (tmp_lbl, [block])+++-- Sp is currently pointing to current_sp,+-- we want it to point to+--    (sm_sp cont_stack - sm_args cont_stack + args)+-- so the difference is+--    sp0 - (sm_sp cont_stack - sm_args cont_stack + args)+spOffsetForCall :: ByteOff -> StackMap -> ByteOff -> ByteOff+spOffsetForCall current_sp cont_stack args+  = current_sp - (sm_sp cont_stack - sm_args cont_stack + args)+++-- | create a sequence of assignments to establish the new StackMap,+-- given the old StackMap.+fixupStack :: StackMap -> StackMap -> [CmmNode O O]+fixupStack old_stack new_stack = concatMap move new_locs+ where+     old_map  = sm_regs old_stack+     new_locs = stackSlotRegs new_stack++     move (r,n)+       | Just (_,m) <- lookupUFM old_map r, n == m = []+       | otherwise = [CmmStore (CmmStackSlot Old n)+                               (CmmReg (CmmLocal r))]++++setupStackFrame+             :: DynFlags+             -> BlockId                 -- label of continuation+             -> LabelMap CmmLocalLive   -- liveness+             -> ByteOff      -- updfr+             -> ByteOff      -- bytes of return values on stack+             -> StackMap     -- current StackMap+             -> (StackMap, [CmmNode O O])++setupStackFrame dflags lbl liveness updfr_off ret_args stack0+  = (cont_stack, assignments)+  where+      -- get the set of LocalRegs live in the continuation+      live = mapFindWithDefault Set.empty lbl liveness++      -- the stack from the base to updfr_off is off-limits.+      -- our new stack frame contains:+      --   * saved live variables+      --   * the return address [young(C) + 8]+      --   * the args for the call,+      --     which are replaced by the return values at the return+      --     point.++      -- everything up to updfr_off is off-limits+      -- stack1 contains updfr_off, plus everything we need to save+      (stack1, assignments) = allocate dflags updfr_off live stack0++      -- And the Sp at the continuation is:+      --   sm_sp stack1 + ret_args+      cont_stack = stack1{ sm_sp = sm_sp stack1 + ret_args+                         , sm_args = ret_args+                         , sm_ret_off = updfr_off+                         }+++-- -----------------------------------------------------------------------------+-- Note [diamond proc point]+--+-- This special case looks for the pattern we get from a typical+-- tagged case expression:+--+--    Sp[young(L1)] = L1+--    if (R1 & 7) != 0 goto L1 else goto L2+--  L2:+--    call [R1] returns to L1+--  L1: live: {y}+--    x = R1+--+-- If we let the generic case handle this, we get+--+--    Sp[-16] = L1+--    if (R1 & 7) != 0 goto L1a else goto L2+--  L2:+--    Sp[-8] = y+--    Sp = Sp - 16+--    call [R1] returns to L1+--  L1a:+--    Sp[-8] = y+--    Sp = Sp - 16+--    goto L1+--  L1:+--    x = R1+--+-- The code for saving the live vars is duplicated in each branch, and+-- furthermore there is an extra jump in the fast path (assuming L1 is+-- a proc point, which it probably is if there is a heap check).+--+-- So to fix this we want to set up the stack frame before the+-- conditional jump.  How do we know when to do this, and when it is+-- safe?  The basic idea is, when we see the assignment+--+--   Sp[young(L)] = L+--+-- we know that+--   * we are definitely heading for L+--   * there can be no more reads from another stack area, because young(L)+--     overlaps with it.+--+-- We don't necessarily know that everything live at L is live now+-- (some might be assigned between here and the jump to L).  So we+-- simplify and only do the optimisation when we see+--+--   (1) a block containing an assignment of a return address L+--   (2) ending in a branch where one (and only) continuation goes to L,+--       and no other continuations go to proc points.+--+-- then we allocate the stack frame for L at the end of the block,+-- before the branch.+--+-- We could generalise (2), but that would make it a bit more+-- complicated to handle, and this currently catches the common case.++futureContinuation :: Block CmmNode O O -> Maybe BlockId+futureContinuation middle = foldBlockNodesB f middle Nothing+   where f :: CmmNode a b -> Maybe BlockId -> Maybe BlockId+         f (CmmStore (CmmStackSlot (Young l) _) (CmmLit (CmmBlock _))) _+               = Just l+         f _ r = r++-- -----------------------------------------------------------------------------+-- Saving live registers++-- | Given a set of live registers and a StackMap, save all the registers+-- on the stack and return the new StackMap and the assignments to do+-- the saving.+--+allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap+         -> (StackMap, [CmmNode O O])+allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0+                                              , sm_regs = regs0 }+ =+   -- we only have to save regs that are not already in a slot+   let to_save = filter (not . (`elemUFM` regs0)) (Set.elems live)+       regs1   = filterUFM (\(r,_) -> elemRegSet r live) regs0+   in++   -- make a map of the stack+   let stack = reverse $ Array.elems $+               accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $+                 ret_words ++ live_words+            where ret_words =+                   [ (x, Occupied)+                   | x <- [ 1 .. toWords dflags ret_off] ]+                  live_words =+                   [ (toWords dflags x, Occupied)+                   | (r,off) <- nonDetEltsUFM regs1,+                   -- See Note [Unique Determinism and code generation]+                     let w = localRegBytes dflags r,+                     x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ]+   in++   -- Pass over the stack: find slots to save all the new live variables,+   -- choosing the oldest slots first (hence a foldr).+   let+       save slot ([], stack, n, assigs, regs) -- no more regs to save+          = ([], slot:stack, plusW dflags n 1, assigs, regs)+       save slot (to_save, stack, n, assigs, regs)+          = case slot of+               Occupied ->  (to_save, Occupied:stack, plusW dflags n 1, assigs, regs)+               Empty+                 | Just (stack', r, to_save') <-+                       select_save to_save (slot:stack)+                 -> let assig = CmmStore (CmmStackSlot Old n')+                                         (CmmReg (CmmLocal r))+                        n' = plusW dflags n 1+                   in+                        (to_save', stack', n', assig : assigs, (r,(r,n')):regs)++                 | otherwise+                 -> (to_save, slot:stack, plusW dflags n 1, assigs, regs)++       -- we should do better here: right now we'll fit the smallest first,+       -- but it would make more sense to fit the biggest first.+       select_save :: [LocalReg] -> [StackSlot]+                   -> Maybe ([StackSlot], LocalReg, [LocalReg])+       select_save regs stack = go regs []+         where go []     _no_fit = Nothing+               go (r:rs) no_fit+                 | Just rest <- dropEmpty words stack+                 = Just (replicate words Occupied ++ rest, r, rs++no_fit)+                 | otherwise+                 = go rs (r:no_fit)+                 where words = localRegWords dflags r++       -- fill in empty slots as much as possible+       (still_to_save, save_stack, n, save_assigs, save_regs)+          = foldr save (to_save, [], 0, [], []) stack++       -- push any remaining live vars on the stack+       (push_sp, push_assigs, push_regs)+          = foldr push (n, [], []) still_to_save+          where+              push r (n, assigs, regs)+                = (n', assig : assigs, (r,(r,n')) : regs)+                where+                  n' = n + localRegBytes dflags r+                  assig = CmmStore (CmmStackSlot Old n')+                                   (CmmReg (CmmLocal r))++       trim_sp+          | not (null push_regs) = push_sp+          | otherwise+          = plusW dflags n (- length (takeWhile isEmpty save_stack))++       final_regs = regs1 `addListToUFM` push_regs+                          `addListToUFM` save_regs++   in+  -- XXX should be an assert+   if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else++   if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0  then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else++   ( stackmap { sm_regs = final_regs , sm_sp = trim_sp }+   , push_assigs ++ save_assigs )+++-- -----------------------------------------------------------------------------+-- Manifesting Sp++-- | Manifest Sp: turn all the CmmStackSlots into CmmLoads from Sp.  The+-- block looks like this:+--+--    middle_pre       -- the middle nodes+--    Sp = Sp + sp_off -- Sp adjustment goes here+--    last             -- the last node+--+-- And we have some extra blocks too (that don't contain Sp adjustments)+--+-- The adjustment for middle_pre will be different from that for+-- middle_post, because the Sp adjustment intervenes.+--+manifestSp+   :: DynFlags+   -> LabelMap StackMap  -- StackMaps for other blocks+   -> StackMap           -- StackMap for this block+   -> ByteOff            -- Sp on entry to the block+   -> ByteOff            -- SpHigh+   -> CmmNode C O        -- first node+   -> [CmmNode O O]      -- middle+   -> ByteOff            -- sp_off+   -> CmmNode O C        -- last node+   -> [CmmBlock]         -- new blocks+   -> [CmmBlock]         -- final blocks with Sp manifest++manifestSp dflags stackmaps stack0 sp0 sp_high+           first middle_pre sp_off last fixup_blocks+  = final_block : fixup_blocks'+  where+    area_off = getAreaOff stackmaps++    adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x+    adj_pre_sp  = mapExpDeep (areaToSp dflags sp0            sp_high area_off)+    adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)++    final_middle = maybeAddSpAdj dflags sp0 sp_off+                 . blockFromList+                 . map adj_pre_sp+                 . elimStackStores stack0 stackmaps area_off+                 $ middle_pre+    final_last    = optStackCheck (adj_post_sp last)++    final_block   = blockJoin first final_middle final_last++    fixup_blocks' = map (mapBlock3' (id, adj_post_sp, id)) fixup_blocks++getAreaOff :: LabelMap StackMap -> (Area -> StackLoc)+getAreaOff _ Old = 0+getAreaOff stackmaps (Young l) =+  case mapLookup l stackmaps of+    Just sm -> sm_sp sm - sm_args sm+    Nothing -> pprPanic "getAreaOff" (ppr l)+++maybeAddSpAdj+  :: DynFlags -> ByteOff -> ByteOff -> Block CmmNode O O -> Block CmmNode O O+maybeAddSpAdj dflags sp0 sp_off block =+  add_initial_unwind $ add_adj_unwind $ adj block+  where+    adj block+      | sp_off /= 0+      = block `blockSnoc` CmmAssign spReg (cmmOffset dflags spExpr sp_off)+      | otherwise = block+    -- Add unwind pseudo-instruction at the beginning of each block to+    -- document Sp level for debugging+    add_initial_unwind block+      | debugLevel dflags > 0+      = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block+      | otherwise+      = block+      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags)++    -- Add unwind pseudo-instruction right after the Sp adjustment+    -- if there is one.+    add_adj_unwind block+      | debugLevel dflags > 0+      , sp_off /= 0+      = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)]+      | otherwise+      = block+      where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags - sp_off)++{- Note [SP old/young offsets]++Sp(L) is the Sp offset on entry to block L relative to the base of the+OLD area.++SpArgs(L) is the size of the young area for L, i.e. the number of+arguments.++ - in block L, each reference to [old + N] turns into+   [Sp + Sp(L) - N]++ - in block L, each reference to [young(L') + N] turns into+   [Sp + Sp(L) - Sp(L') + SpArgs(L') - N]++ - be careful with the last node of each block: Sp has already been adjusted+   to be Sp + Sp(L) - Sp(L')+-}++areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr++areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n)+  = cmmOffset dflags spExpr (sp_old - area_off area - n)+    -- Replace (CmmStackSlot area n) with an offset from Sp++areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark)+  = mkIntExpr dflags sp_hwm+    -- Replace CmmHighStackMark with the number of bytes of stack used,+    -- the sp_hwm.   See Note [Stack usage] in StgCmmHeap++areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) args)+  | falseStackCheck args+  = zeroExpr dflags+areaToSp dflags _ _ _ (CmmMachOp (MO_U_Ge _) args)+  | falseStackCheck args+  = mkIntExpr dflags 1+    -- Replace a stack-overflow test that cannot fail with a no-op+    -- See Note [Always false stack check]++areaToSp _ _ _ _ other = other++-- | Determine whether a stack check cannot fail.+falseStackCheck :: [CmmExpr] -> Bool+falseStackCheck [ CmmMachOp (MO_Sub _)+                      [ CmmRegOff (CmmGlobal Sp) x_off+                      , CmmLit (CmmInt y_lit _)]+                , CmmReg (CmmGlobal SpLim)]+  = fromIntegral x_off >= y_lit+falseStackCheck _ = False++-- Note [Always false stack check]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- We can optimise stack checks of the form+--+--   if ((Sp + x) - y < SpLim) then .. else ..+--+-- where are non-negative integer byte offsets.  Since we know that+-- SpLim <= Sp (remember the stack grows downwards), this test must+-- yield False if (x >= y), so we can rewrite the comparison to False.+-- A subsequent sinking pass will later drop the dead code.+-- Optimising this away depends on knowing that SpLim <= Sp, so it is+-- really the job of the stack layout algorithm, hence we do it now.+--+-- The control flow optimiser may negate a conditional to increase+-- the likelihood of a fallthrough if the branch is not taken.  But+-- not every conditional is inverted as the control flow optimiser+-- places some requirements on the predecessors of both branch targets.+-- So we better look for the inverted comparison too.++optStackCheck :: CmmNode O C -> CmmNode O C+optStackCheck n = -- Note [Always false stack check]+ case n of+   CmmCondBranch (CmmLit (CmmInt 0 _)) _true false _ -> CmmBranch false+   CmmCondBranch (CmmLit (CmmInt _ _)) true _false _ -> CmmBranch true+   other -> other+++-- -----------------------------------------------------------------------------++-- | Eliminate stores of the form+--+--    Sp[area+n] = r+--+-- when we know that r is already in the same slot as Sp[area+n].  We+-- could do this in a later optimisation pass, but that would involve+-- a separate analysis and we already have the information to hand+-- here.  It helps clean up some extra stack stores in common cases.+--+-- Note that we may have to modify the StackMap as we walk through the+-- code using procMiddle, since an assignment to a variable in the+-- StackMap will invalidate its mapping there.+--+elimStackStores :: StackMap+                -> LabelMap StackMap+                -> (Area -> ByteOff)+                -> [CmmNode O O]+                -> [CmmNode O O]+elimStackStores stackmap stackmaps area_off nodes+  = go stackmap nodes+  where+    go _stackmap [] = []+    go stackmap (n:ns)+     = case n of+         CmmStore (CmmStackSlot area m) (CmmReg (CmmLocal r))+            | Just (_,off) <- lookupUFM (sm_regs stackmap) r+            , area_off area + m == off+            -> go stackmap ns+         _otherwise+            -> n : go (procMiddle stackmaps n stackmap) ns+++-- -----------------------------------------------------------------------------+-- Update info tables to include stack liveness+++setInfoTableStackMap :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl+setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)+  = CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g+  where+    fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =+       info_tbl { cit_rep = StackRep (get_liveness lbl) }+    fix_info _ other = other++    get_liveness :: BlockId -> Liveness+    get_liveness lbl+      = case mapLookup lbl stackmaps of+          Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)+          Just sm -> stackMapToLiveness dflags sm++setInfoTableStackMap _ _ d = d+++stackMapToLiveness :: DynFlags -> StackMap -> Liveness+stackMapToLiveness dflags StackMap{..} =+   reverse $ Array.elems $+        accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1,+                                     toWords dflags (sm_sp - sm_args)) live_words+   where+     live_words =  [ (toWords dflags off, False)+                   | (r,off) <- nonDetEltsUFM sm_regs+                   , isGcPtrType (localRegType r) ]+                   -- See Note [Unique Determinism and code generation]++-- -----------------------------------------------------------------------------+-- Pass 2+-- -----------------------------------------------------------------------------++insertReloadsAsNeeded+    :: DynFlags+    -> ProcPointSet+    -> LabelMap StackMap+    -> BlockId+    -> [CmmBlock]+    -> UniqSM [CmmBlock]+insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do+    toBlockList . fst <$>+        rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty+  where+    rewriteCC :: RewriteFun CmmLocalLive+    rewriteCC (BlockCC e_node middle0 x_node) fact_base0 = do+        let entry_label = entryLabel e_node+            stackmap = case mapLookup entry_label final_stackmaps of+                Just sm -> sm+                Nothing -> panic "insertReloadsAsNeeded: rewriteCC: stackmap"++            -- Merge the liveness from successor blocks and analyse the last+            -- node.+            joined = gen_kill dflags x_node $!+                         joinOutFacts liveLattice x_node fact_base0+            -- What is live at the start of middle0.+            live_at_middle0 = foldNodesBwdOO (gen_kill dflags) middle0 joined++            -- If this is a procpoint we need to add the reloads, but only if+            -- they're actually live. Furthermore, nothing is live at the entry+            -- to a proc point.+            (middle1, live_with_reloads)+                | entry_label `setMember` procpoints+                = let reloads = insertReloads dflags stackmap live_at_middle0+                  in (foldr blockCons middle0 reloads, emptyRegSet)+                | otherwise+                = (middle0, live_at_middle0)++            -- Final liveness for this block.+            !fact_base2 = mapSingleton entry_label live_with_reloads++        return (BlockCC e_node middle1 x_node, fact_base2)++insertReloads :: DynFlags -> StackMap -> CmmLocalLive -> [CmmNode O O]+insertReloads dflags stackmap live =+     [ CmmAssign (CmmLocal reg)+                 -- This cmmOffset basically corresponds to manifesting+                 -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets]+                 (CmmLoad (cmmOffset dflags spExpr (sp_off - reg_off))+                          (localRegType reg))+     | (reg, reg_off) <- stackSlotRegs stackmap+     , reg `elemRegSet` live+     ]+   where+     sp_off = sm_sp stackmap++-- -----------------------------------------------------------------------------+-- Lowering safe foreign calls++{-+Note [Lower safe foreign calls]++We start with++   Sp[young(L1)] = L1+ ,-----------------------+ | r1 = foo(x,y,z) returns to L1+ '-----------------------+ L1:+   R1 = r1 -- copyIn, inserted by mkSafeCall+   ...++the stack layout algorithm will arrange to save and reload everything+live across the call.  Our job now is to expand the call so we get++   Sp[young(L1)] = L1+ ,-----------------------+ | SAVE_THREAD_STATE()+ | token = suspendThread(BaseReg, interruptible)+ | r = foo(x,y,z)+ | BaseReg = resumeThread(token)+ | LOAD_THREAD_STATE()+ | R1 = r  -- copyOut+ | jump Sp[0]+ '-----------------------+ L1:+   r = R1 -- copyIn, inserted by mkSafeCall+   ...++Note the copyOut, which saves the results in the places that L1 is+expecting them (see Note [safe foreign call convention]). Note also+that safe foreign call is replace by an unsafe one in the Cmm graph.+-}++lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock+lowerSafeForeignCall dflags block+  | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block+  = do+    -- Both 'id' and 'new_base' are KindNonPtr because they're+    -- RTS-only objects and are not subject to garbage collection+    id <- newTemp (bWord dflags)+    new_base <- newTemp (cmmRegType dflags baseReg)+    let (caller_save, caller_load) = callerSaveVolatileRegs dflags+    save_state_code <- saveThreadState dflags+    load_state_code <- loadThreadState dflags+    let suspend = save_state_code  <*>+                  caller_save <*>+                  mkMiddle (callSuspendThread dflags id intrbl)+        midCall = mkUnsafeCall tgt res args+        resume  = mkMiddle (callResumeThread new_base id) <*>+                  -- Assign the result to BaseReg: we+                  -- might now have a different Capability!+                  mkAssign baseReg (CmmReg (CmmLocal new_base)) <*>+                  caller_load <*>+                  load_state_code++        (_, regs, copyout) =+             copyOutOflow dflags NativeReturn Jump (Young succ)+                            (map (CmmReg . CmmLocal) res)+                            ret_off []++        -- NB. after resumeThread returns, the top-of-stack probably contains+        -- the stack frame for succ, but it might not: if the current thread+        -- received an exception during the call, then the stack might be+        -- different.  Hence we continue by jumping to the top stack frame,+        -- not by jumping to succ.+        jump = CmmCall { cml_target    = entryCode dflags $+                                         CmmLoad spExpr (bWord dflags)+                       , cml_cont      = Just succ+                       , cml_args_regs = regs+                       , cml_args      = widthInBytes (wordWidth dflags)+                       , cml_ret_args  = ret_args+                       , cml_ret_off   = ret_off }++    graph' <- lgraphOfAGraph ( suspend <*>+                               midCall <*>+                               resume  <*>+                               copyout <*>+                               mkLast jump, tscp)++    case toBlockList graph' of+      [one] -> let (_, middle', last) = blockSplit one+               in return (blockJoin entry (middle `blockAppend` middle') last)+      _ -> panic "lowerSafeForeignCall0"++  -- Block doesn't end in a safe foreign call:+  | otherwise = return block+++foreignLbl :: FastString -> CmmExpr+foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))++callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O+callSuspendThread dflags id intrbl =+  CmmUnsafeForeignCall+       (ForeignTarget (foreignLbl (fsLit "suspendThread"))+        (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))+       [id] [baseExpr, mkIntExpr dflags (fromEnum intrbl)]++callResumeThread :: LocalReg -> LocalReg -> CmmNode O O+callResumeThread new_base id =+  CmmUnsafeForeignCall+       (ForeignTarget (foreignLbl (fsLit "resumeThread"))+            (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn))+       [new_base] [CmmReg (CmmLocal id)]++-- -----------------------------------------------------------------------------++plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff+plusW dflags b w = b + w * wORD_SIZE dflags++data StackSlot = Occupied | Empty+     -- Occupied: a return address or part of an update frame++instance Outputable StackSlot where+  ppr Occupied = text "XXX"+  ppr Empty    = text "---"++dropEmpty :: WordOff -> [StackSlot] -> Maybe [StackSlot]+dropEmpty 0 ss           = Just ss+dropEmpty n (Empty : ss) = dropEmpty (n-1) ss+dropEmpty _ _            = Nothing++isEmpty :: StackSlot -> Bool+isEmpty Empty = True+isEmpty _ = False++localRegBytes :: DynFlags -> LocalReg -> ByteOff+localRegBytes dflags r+    = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r)))++localRegWords :: DynFlags -> LocalReg -> WordOff+localRegWords dflags = toWords dflags . localRegBytes dflags++toWords :: DynFlags -> ByteOff -> WordOff+toWords dflags x = x `quot` wORD_SIZE dflags+++stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]+stackSlotRegs sm = nonDetEltsUFM (sm_regs sm)+  -- See Note [Unique Determinism and code generation]
+ compiler/cmm/CmmLex.x view
@@ -0,0 +1,368 @@+-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2004-2006+--+-- Lexer for concrete Cmm.  We try to stay close to the C-- spec, but there+-- are a few minor differences:+--+--   * extra keywords for our macros, and float32/float64 types+--   * global registers (Sp,Hp, etc.)+--+-----------------------------------------------------------------------------++{+module CmmLex (+   CmmToken(..), cmmlex,+  ) where++import GhcPrelude++import CmmExpr++import Lexer+import CmmMonad+import SrcLoc+import UniqFM+import StringBuffer+import FastString+import Ctype+import Util+--import TRACE++import Data.Word+import Data.Char+}++$whitechar   = [\ \t\n\r\f\v\xa0] -- \xa0 is Unicode no-break space+$white_no_nl = $whitechar # \n++$ascdigit  = 0-9+$unidigit  = \x01 -- Trick Alex into handling Unicode. See alexGetChar.+$digit     = [$ascdigit $unidigit]+$octit     = 0-7+$hexit     = [$digit A-F a-f]++$unilarge  = \x03 -- Trick Alex into handling Unicode. See alexGetChar.+$asclarge  = [A-Z \xc0-\xd6 \xd8-\xde]+$large     = [$asclarge $unilarge]++$unismall  = \x04 -- Trick Alex into handling Unicode. See alexGetChar.+$ascsmall  = [a-z \xdf-\xf6 \xf8-\xff]+$small     = [$ascsmall $unismall \_]++$namebegin = [$large $small \. \$ \@]+$namechar  = [$namebegin $digit]++@decimal     = $digit++@octal       = $octit++@hexadecimal = $hexit++@exponent    = [eE] [\-\+]? @decimal++@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent++@escape      = \\ ([abfnrt\\\'\"\?] | x $hexit{1,2} | $octit{1,3})+@strchar     = ($printable # [\"\\]) | @escape++cmm :-++$white_no_nl+           ;+^\# pragma .* \n        ; -- Apple GCC 3.3 CPP generates pragmas in its output++^\# (line)?             { begin line_prag }++-- single-line line pragmas, of the form+--    # <line> "<file>" <extra-stuff> \n+<line_prag> $digit+                     { setLine line_prag1 }+<line_prag1> \" [^\"]* \"       { setFile line_prag2 }+<line_prag2> .*                         { pop }++<0> {+  \n                    ;++  [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!]      { special_char }++  ".."                  { kw CmmT_DotDot }+  "::"                  { kw CmmT_DoubleColon }+  ">>"                  { kw CmmT_Shr }+  "<<"                  { kw CmmT_Shl }+  ">="                  { kw CmmT_Ge }+  "<="                  { kw CmmT_Le }+  "=="                  { kw CmmT_Eq }+  "!="                  { kw CmmT_Ne }+  "&&"                  { kw CmmT_BoolAnd }+  "||"                  { kw CmmT_BoolOr }++  "True"                { kw CmmT_True  }+  "False"               { kw CmmT_False }+  "likely"              { kw CmmT_likely}++  P@decimal             { global_regN (\n -> VanillaReg n VGcPtr) }+  R@decimal             { global_regN (\n -> VanillaReg n VNonGcPtr) }+  F@decimal             { global_regN FloatReg }+  D@decimal             { global_regN DoubleReg }+  L@decimal             { global_regN LongReg }+  Sp                    { global_reg Sp }+  SpLim                 { global_reg SpLim }+  Hp                    { global_reg Hp }+  HpLim                 { global_reg HpLim }+  CCCS                  { global_reg CCCS }+  CurrentTSO            { global_reg CurrentTSO }+  CurrentNursery        { global_reg CurrentNursery }+  HpAlloc               { global_reg HpAlloc }+  BaseReg               { global_reg BaseReg }+  MachSp                { global_reg MachSp }+  UnwindReturnReg       { global_reg UnwindReturnReg }++  $namebegin $namechar* { name }++  0 @octal              { tok_octal }+  @decimal              { tok_decimal }+  0[xX] @hexadecimal    { tok_hexadecimal }+  @floating_point       { strtoken tok_float }++  \" @strchar* \"       { strtoken tok_string }+}++{+data CmmToken+  = CmmT_SpecChar  Char+  | CmmT_DotDot+  | CmmT_DoubleColon+  | CmmT_Shr+  | CmmT_Shl+  | CmmT_Ge+  | CmmT_Le+  | CmmT_Eq+  | CmmT_Ne+  | CmmT_BoolAnd+  | CmmT_BoolOr+  | CmmT_CLOSURE+  | CmmT_INFO_TABLE+  | CmmT_INFO_TABLE_RET+  | CmmT_INFO_TABLE_FUN+  | CmmT_INFO_TABLE_CONSTR+  | CmmT_INFO_TABLE_SELECTOR+  | CmmT_else+  | CmmT_export+  | CmmT_section+  | CmmT_goto+  | CmmT_if+  | CmmT_call+  | CmmT_jump+  | CmmT_foreign+  | CmmT_never+  | CmmT_prim+  | CmmT_reserve+  | CmmT_return+  | CmmT_returns+  | CmmT_import+  | CmmT_switch+  | CmmT_case+  | CmmT_default+  | CmmT_push+  | CmmT_unwind+  | CmmT_bits8+  | CmmT_bits16+  | CmmT_bits32+  | CmmT_bits64+  | CmmT_bits128+  | CmmT_bits256+  | CmmT_bits512+  | CmmT_float32+  | CmmT_float64+  | CmmT_gcptr+  | CmmT_GlobalReg GlobalReg+  | CmmT_Name      FastString+  | CmmT_String    String+  | CmmT_Int       Integer+  | CmmT_Float     Rational+  | CmmT_EOF+  | CmmT_False+  | CmmT_True+  | CmmT_likely+  deriving (Show)++-- -----------------------------------------------------------------------------+-- Lexer actions++type Action = RealSrcSpan -> StringBuffer -> Int -> PD (RealLocated CmmToken)++begin :: Int -> Action+begin code _span _str _len = do liftP (pushLexState code); lexToken++pop :: Action+pop _span _buf _len = liftP popLexState >> lexToken++special_char :: Action+special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf)))++kw :: CmmToken -> Action+kw tok span _buf _len = return (L span tok)++global_regN :: (Int -> GlobalReg) -> Action+global_regN con span buf len+  = return (L span (CmmT_GlobalReg (con (fromIntegral n))))+  where buf' = stepOn buf+        n = parseUnsignedInteger buf' (len-1) 10 octDecDigit++global_reg :: GlobalReg -> Action+global_reg r span _buf _len = return (L span (CmmT_GlobalReg r))++strtoken :: (String -> CmmToken) -> Action+strtoken f span buf len =+  return (L span $! (f $! lexemeToString buf len))++name :: Action+name span buf len =+  case lookupUFM reservedWordsFM fs of+        Just tok -> return (L span tok)+        Nothing  -> return (L span (CmmT_Name fs))+  where+        fs = lexemeToFastString buf len++reservedWordsFM = listToUFM $+        map (\(x, y) -> (mkFastString x, y)) [+        ( "CLOSURE",            CmmT_CLOSURE ),+        ( "INFO_TABLE",         CmmT_INFO_TABLE ),+        ( "INFO_TABLE_RET",     CmmT_INFO_TABLE_RET ),+        ( "INFO_TABLE_FUN",     CmmT_INFO_TABLE_FUN ),+        ( "INFO_TABLE_CONSTR",  CmmT_INFO_TABLE_CONSTR ),+        ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),+        ( "else",               CmmT_else ),+        ( "export",             CmmT_export ),+        ( "section",            CmmT_section ),+        ( "goto",               CmmT_goto ),+        ( "if",                 CmmT_if ),+        ( "call",               CmmT_call ),+        ( "jump",               CmmT_jump ),+        ( "foreign",            CmmT_foreign ),+        ( "never",              CmmT_never ),+        ( "prim",               CmmT_prim ),+        ( "reserve",            CmmT_reserve ),+        ( "return",             CmmT_return ),+        ( "returns",            CmmT_returns ),+        ( "import",             CmmT_import ),+        ( "switch",             CmmT_switch ),+        ( "case",               CmmT_case ),+        ( "default",            CmmT_default ),+        ( "push",               CmmT_push ),+        ( "unwind",             CmmT_unwind ),+        ( "bits8",              CmmT_bits8 ),+        ( "bits16",             CmmT_bits16 ),+        ( "bits32",             CmmT_bits32 ),+        ( "bits64",             CmmT_bits64 ),+        ( "bits128",            CmmT_bits128 ),+        ( "bits256",            CmmT_bits256 ),+        ( "bits512",            CmmT_bits512 ),+        ( "float32",            CmmT_float32 ),+        ( "float64",            CmmT_float64 ),+-- New forms+        ( "b8",                 CmmT_bits8 ),+        ( "b16",                CmmT_bits16 ),+        ( "b32",                CmmT_bits32 ),+        ( "b64",                CmmT_bits64 ),+        ( "b128",               CmmT_bits128 ),+        ( "b256",               CmmT_bits256 ),+        ( "b512",               CmmT_bits512 ),+        ( "f32",                CmmT_float32 ),+        ( "f64",                CmmT_float64 ),+        ( "gcptr",              CmmT_gcptr ),+        ( "likely",             CmmT_likely),+        ( "True",               CmmT_True  ),+        ( "False",              CmmT_False )+        ]++tok_decimal span buf len+  = return (L span (CmmT_Int  $! parseUnsignedInteger buf len 10 octDecDigit))++tok_octal span buf len+  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))++tok_hexadecimal span buf len+  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))++tok_float str = CmmT_Float $! readRational str++tok_string str = CmmT_String (read str)+                 -- urk, not quite right, but it'll do for now++-- -----------------------------------------------------------------------------+-- Line pragmas++setLine :: Int -> Action+setLine code span buf len = do+  let line = parseUnsignedInteger buf len 10 octDecDigit+  liftP $ do+    setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)+          -- subtract one: the line number refers to the *following* line+    -- trace ("setLine "  ++ show line) $ do+    popLexState >> pushLexState code+  lexToken++setFile :: Int -> Action+setFile code span buf len = do+  let file = lexemeToFastString (stepOn buf) (len-2)+  liftP $ do+    setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))+    popLexState >> pushLexState code+  lexToken++-- -----------------------------------------------------------------------------+-- This is the top-level function: called from the parser each time a+-- new token is to be read from the input.++cmmlex :: (Located CmmToken -> PD a) -> PD a+cmmlex cont = do+  (L span tok) <- lexToken+  --trace ("token: " ++ show tok) $ do+  cont (L (RealSrcSpan span) tok)++lexToken :: PD (RealLocated CmmToken)+lexToken = do+  inp@(loc1,buf) <- getInput+  sc <- liftP getLexState+  case alexScan inp sc of+    AlexEOF -> do let span = mkRealSrcSpan loc1 loc1+                  liftP (setLastToken span 0)+                  return (L span CmmT_EOF)+    AlexError (loc2,_) -> liftP $ failLocMsgP loc1 loc2 "lexical error"+    AlexSkip inp2 _ -> do+        setInput inp2+        lexToken+    AlexToken inp2@(end,_buf2) len t -> do+        setInput inp2+        let span = mkRealSrcSpan loc1 end+        span `seq` liftP (setLastToken span len)+        t span buf len++-- -----------------------------------------------------------------------------+-- Monad stuff++-- Stuff that Alex needs to know about our input type:+type AlexInput = (RealSrcLoc,StringBuffer)++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (_,s) = prevChar s '\n'++-- backwards compatibility for Alex 2.x+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)+alexGetChar inp = case alexGetByte inp of+                    Nothing    -> Nothing+                    Just (b,i) -> c `seq` Just (c,i)+                       where c = chr $ fromIntegral b++alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)+alexGetByte (loc,s)+  | atEnd s   = Nothing+  | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s'))+  where c    = currentChar s+        b    = fromIntegral $ ord $ c+        loc' = advanceSrcLoc loc c+        s'   = stepOn s++getInput :: PD AlexInput+getInput = PD $ \_ s@PState{ loc=l, buffer=b } -> POk s (l,b)++setInput :: AlexInput -> PD ()+setInput (l,b) = PD $ \_ s -> POk s{ loc=l, buffer=b } ()+}
+ compiler/cmm/CmmLint.hs view
@@ -0,0 +1,262 @@+-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 2011+--+-- CmmLint: checking the correctness of Cmm statements and expressions+--+-----------------------------------------------------------------------------+{-# LANGUAGE GADTs #-}+module CmmLint (+    cmmLint, cmmLintGraph+  ) where++import GhcPrelude++import Hoopl.Block+import Hoopl.Collections+import Hoopl.Graph+import Hoopl.Label+import Cmm+import CmmUtils+import CmmLive+import CmmSwitch (switchTargetsToList)+import PprCmm ()+import Outputable+import DynFlags++import Control.Monad (liftM, ap)++-- Things to check:+--     - invariant on CmmBlock in CmmExpr (see comment there)+--     - check for branches to blocks that don't exist+--     - check types++-- -----------------------------------------------------------------------------+-- Exported entry points:++cmmLint :: (Outputable d, Outputable h)+        => DynFlags -> GenCmmGroup d h CmmGraph -> Maybe SDoc+cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops++cmmLintGraph :: DynFlags -> CmmGraph -> Maybe SDoc+cmmLintGraph dflags g = runCmmLint dflags (lintCmmGraph dflags) g++runCmmLint :: Outputable a => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc+runCmmLint dflags l p =+   case unCL (l p) dflags of+     Left err -> Just (vcat [text "Cmm lint error:",+                             nest 2 err,+                             text "Program was:",+                             nest 2 (ppr p)])+     Right _  -> Nothing++lintCmmDecl :: DynFlags -> GenCmmDecl h i CmmGraph -> CmmLint ()+lintCmmDecl dflags (CmmProc _ lbl _ g)+  = addLintInfo (text "in proc " <> ppr lbl) $ lintCmmGraph dflags g+lintCmmDecl _ (CmmData {})+  = return ()+++lintCmmGraph :: DynFlags -> CmmGraph -> CmmLint ()+lintCmmGraph dflags g =+    cmmLocalLiveness dflags g `seq` mapM_ (lintCmmBlock labels) blocks+    -- cmmLiveness throws an error if there are registers+    -- live on entry to the graph (i.e. undefined+    -- variables)+  where+       blocks = toBlockList g+       labels = setFromList (map entryLabel blocks)+++lintCmmBlock :: LabelSet -> CmmBlock -> CmmLint ()+lintCmmBlock labels block+  = addLintInfo (text "in basic block " <> ppr (entryLabel block)) $ do+        let (_, middle, last) = blockSplit block+        mapM_ lintCmmMiddle (blockToList middle)+        lintCmmLast labels last++-- -----------------------------------------------------------------------------+-- lintCmmExpr++-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking+-- byte/word mismatches.++lintCmmExpr :: CmmExpr -> CmmLint CmmType+lintCmmExpr (CmmLoad expr rep) = do+  _ <- lintCmmExpr expr+  -- Disabled, if we have the inlining phase before the lint phase,+  -- we can have funny offsets due to pointer tagging. -- EZY+  -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $+  --   cmmCheckWordAddress expr+  return rep+lintCmmExpr expr@(CmmMachOp op args) = do+  dflags <- getDynFlags+  tys <- mapM lintCmmExpr args+  if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op+        then cmmCheckMachOp op args tys+        else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)+lintCmmExpr (CmmRegOff reg offset)+  = do dflags <- getDynFlags+       let rep = typeWidth (cmmRegType dflags reg)+       lintCmmExpr (CmmMachOp (MO_Add rep)+                [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])+lintCmmExpr expr =+  do dflags <- getDynFlags+     return (cmmExprType dflags expr)++-- Check for some common byte/word mismatches (eg. Sp + 1)+cmmCheckMachOp   :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType+cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys+  = cmmCheckMachOp op [reg, lit] tys+cmmCheckMachOp op _ tys+  = do dflags <- getDynFlags+       return (machOpResultType dflags op tys)++{-+isOffsetOp :: MachOp -> Bool+isOffsetOp (MO_Add _) = True+isOffsetOp (MO_Sub _) = True+isOffsetOp _ = False++-- This expression should be an address from which a word can be loaded:+-- check for funny-looking sub-word offsets.+_cmmCheckWordAddress :: CmmExpr -> CmmLint ()+_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])+  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0+  = cmmLintDubiousWordOffset e+_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])+  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0+  = cmmLintDubiousWordOffset e+_cmmCheckWordAddress _+  = return ()++-- No warnings for unaligned arithmetic with the node register,+-- which is used to extract fields from tagged constructor closures.+notNodeReg :: CmmExpr -> Bool+notNodeReg (CmmReg reg) | reg == nodeReg = False+notNodeReg _                             = True+-}++lintCmmMiddle :: CmmNode O O -> CmmLint ()+lintCmmMiddle node = case node of+  CmmComment _ -> return ()+  CmmTick _    -> return ()+  CmmUnwind{}  -> return ()++  CmmAssign reg expr -> do+            dflags <- getDynFlags+            erep <- lintCmmExpr expr+            let reg_ty = cmmRegType dflags reg+            if (erep `cmmEqType_ignoring_ptrhood` reg_ty)+                then return ()+                else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty++  CmmStore l r -> do+            _ <- lintCmmExpr l+            _ <- lintCmmExpr r+            return ()++  CmmUnsafeForeignCall target _formals actuals -> do+            lintTarget target+            mapM_ lintCmmExpr actuals+++lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()+lintCmmLast labels node = case node of+  CmmBranch id -> checkTarget id++  CmmCondBranch e t f _ -> do+            dflags <- getDynFlags+            mapM_ checkTarget [t,f]+            _ <- lintCmmExpr e+            checkCond dflags e++  CmmSwitch e ids -> do+            dflags <- getDynFlags+            mapM_ checkTarget $ switchTargetsToList ids+            erep <- lintCmmExpr e+            if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)+              then return ()+              else cmmLintErr (text "switch scrutinee is not a word: " <>+                               ppr e <> text " :: " <> ppr erep)++  CmmCall { cml_target = target, cml_cont = cont } -> do+          _ <- lintCmmExpr target+          maybe (return ()) checkTarget cont++  CmmForeignCall tgt _ args succ _ _ _ -> do+          lintTarget tgt+          mapM_ lintCmmExpr args+          checkTarget succ+ where+  checkTarget id+     | setMember id labels = return ()+     | otherwise = cmmLintErr (text "Branch to nonexistent id" <+> ppr id)+++lintTarget :: ForeignTarget -> CmmLint ()+lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()+lintTarget (PrimTarget {})     = return ()+++checkCond :: DynFlags -> CmmExpr -> CmmLint ()+checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()+checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values+checkCond _ expr+    = cmmLintErr (hang (text "expression is not a conditional:") 2+                         (ppr expr))++-- -----------------------------------------------------------------------------+-- CmmLint monad++-- just a basic error monad:++newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }++instance Functor CmmLint where+      fmap = liftM++instance Applicative CmmLint where+      pure a = CmmLint (\_ -> Right a)+      (<*>) = ap++instance Monad CmmLint where+  CmmLint m >>= k = CmmLint $ \dflags ->+                                case m dflags of+                                Left e -> Left e+                                Right a -> unCL (k a) dflags++instance HasDynFlags CmmLint where+    getDynFlags = CmmLint (\dflags -> Right dflags)++cmmLintErr :: SDoc -> CmmLint a+cmmLintErr msg = CmmLint (\_ -> Left msg)++addLintInfo :: SDoc -> CmmLint a -> CmmLint a+addLintInfo info thing = CmmLint $ \dflags ->+   case unCL thing dflags of+        Left err -> Left (hang info 2 err)+        Right a  -> Right a++cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a+cmmLintMachOpErr expr argsRep opExpectsRep+     = cmmLintErr (text "in MachOp application: " $$+                   nest 2 (ppr  expr) $$+                      (text "op is expecting: " <+> ppr opExpectsRep) $$+                      (text "arguments provide: " <+> ppr argsRep))++cmmLintAssignErr :: CmmNode e x -> CmmType -> CmmType -> CmmLint a+cmmLintAssignErr stmt e_ty r_ty+  = cmmLintErr (text "in assignment: " $$+                nest 2 (vcat [ppr stmt,+                              text "Reg ty:" <+> ppr r_ty,+                              text "Rhs ty:" <+> ppr e_ty]))+++{-+cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a+cmmLintDubiousWordOffset expr+   = cmmLintErr (text "offset is not a multiple of words: " $$+                 nest 2 (ppr expr))+-}+
+ compiler/cmm/CmmLive.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}++module CmmLive+    ( CmmLocalLive+    , cmmLocalLiveness+    , cmmGlobalLiveness+    , liveLattice+    , gen_kill+    )+where++import GhcPrelude++import DynFlags+import BlockId+import Cmm+import PprCmmExpr ()+import Hoopl.Block+import Hoopl.Collections+import Hoopl.Dataflow+import Hoopl.Label++import Maybes+import Outputable++-----------------------------------------------------------------------------+-- Calculating what variables are live on entry to a basic block+-----------------------------------------------------------------------------++-- | The variables live on entry to a block+type CmmLive r = RegSet r+type CmmLocalLive = CmmLive LocalReg++-- | The dataflow lattice+liveLattice :: Ord r => DataflowLattice (CmmLive r)+{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive LocalReg) #-}+{-# SPECIALIZE liveLattice :: DataflowLattice (CmmLive GlobalReg) #-}+liveLattice = DataflowLattice emptyRegSet add+  where+    add (OldFact old) (NewFact new) =+        let !join = plusRegSet old new+        in changedIf (sizeRegSet join > sizeRegSet old) join++-- | A mapping from block labels to the variables live on entry+type BlockEntryLiveness r = LabelMap (CmmLive r)++-----------------------------------------------------------------------------+-- | Calculated liveness info for a CmmGraph+-----------------------------------------------------------------------------++cmmLocalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness LocalReg+cmmLocalLiveness dflags graph =+    check $ analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty+  where+    entry = g_entry graph+    check facts =+        noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts++cmmGlobalLiveness :: DynFlags -> CmmGraph -> BlockEntryLiveness GlobalReg+cmmGlobalLiveness dflags graph =+    analyzeCmmBwd liveLattice (xferLive dflags) graph mapEmpty++-- | On entry to the procedure, there had better not be any LocalReg's live-in.+noLiveOnEntry :: BlockId -> CmmLive LocalReg -> a -> a+noLiveOnEntry bid in_fact x =+  if nullRegSet in_fact then x+  else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)++gen_kill+    :: (DefinerOfRegs r n, UserOfRegs r n)+    => DynFlags -> n -> CmmLive r -> CmmLive r+gen_kill dflags node set =+    let !afterKill = foldRegsDefd dflags deleteFromRegSet set node+    in foldRegsUsed dflags extendRegSet afterKill node+{-# INLINE gen_kill #-}++xferLive+    :: forall r.+       ( UserOfRegs r (CmmNode O O)+       , DefinerOfRegs r (CmmNode O O)+       , UserOfRegs r (CmmNode O C)+       , DefinerOfRegs r (CmmNode O C)+       )+    => DynFlags -> TransferFun (CmmLive r)+xferLive dflags (BlockCC eNode middle xNode) fBase =+    let joined = gen_kill dflags xNode $! joinOutFacts liveLattice xNode fBase+        !result = foldNodesBwdOO (gen_kill dflags) middle joined+    in mapSingleton (entryLabel eNode) result+{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive LocalReg) #-}+{-# SPECIALIZE xferLive :: DynFlags -> TransferFun (CmmLive GlobalReg) #-}
+ compiler/cmm/CmmMachOp.hs view
@@ -0,0 +1,658 @@+module CmmMachOp+    ( MachOp(..)+    , pprMachOp, isCommutableMachOp, isAssociativeMachOp+    , isComparisonMachOp, maybeIntComparison, machOpResultType+    , machOpArgReps, maybeInvertComparison, isFloatComparison++    -- MachOp builders+    , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot+    , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem+    , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe+    , mo_wordULe, mo_wordUGt, mo_wordULt+    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot+    , mo_wordShl, mo_wordSShr, mo_wordUShr+    , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32+    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord+    , mo_u_32ToWord, mo_s_32ToWord+    , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64++    -- CallishMachOp+    , CallishMachOp(..), callishMachOpHints+    , pprCallishMachOp+    , machOpMemcpyishAlign++    -- Atomic read-modify-write+    , AtomicMachOp(..)+   )+where++import GhcPrelude++import CmmType+import Outputable+import DynFlags++-----------------------------------------------------------------------------+--              MachOp+-----------------------------------------------------------------------------++{- |+Machine-level primops; ones which we can reasonably delegate to the+native code generators to handle.++Most operations are parameterised by the 'Width' that they operate on.+Some operations have separate signed and unsigned versions, and float+and integer versions.+-}++data MachOp+  -- Integer operations (insensitive to signed/unsigned)+  = MO_Add Width+  | MO_Sub Width+  | MO_Eq  Width+  | MO_Ne  Width+  | MO_Mul Width                -- low word of multiply++  -- Signed multiply/divide+  | MO_S_MulMayOflo Width       -- nonzero if signed multiply overflows+  | MO_S_Quot Width             -- signed / (same semantics as IntQuotOp)+  | MO_S_Rem  Width             -- signed % (same semantics as IntRemOp)+  | MO_S_Neg  Width             -- unary -++  -- Unsigned multiply/divide+  | MO_U_MulMayOflo Width       -- nonzero if unsigned multiply overflows+  | MO_U_Quot Width             -- unsigned / (same semantics as WordQuotOp)+  | MO_U_Rem  Width             -- unsigned % (same semantics as WordRemOp)++  -- Signed comparisons+  | MO_S_Ge Width+  | MO_S_Le Width+  | MO_S_Gt Width+  | MO_S_Lt Width++  -- Unsigned comparisons+  | MO_U_Ge Width+  | MO_U_Le Width+  | MO_U_Gt Width+  | MO_U_Lt Width++  -- Floating point arithmetic+  | MO_F_Add  Width+  | MO_F_Sub  Width+  | MO_F_Neg  Width             -- unary -+  | MO_F_Mul  Width+  | MO_F_Quot Width++  -- Floating point comparison+  | MO_F_Eq Width+  | MO_F_Ne Width+  | MO_F_Ge Width+  | MO_F_Le Width+  | MO_F_Gt Width+  | MO_F_Lt Width++  -- Bitwise operations.  Not all of these may be supported+  -- at all sizes, and only integral Widths are valid.+  | MO_And   Width+  | MO_Or    Width+  | MO_Xor   Width+  | MO_Not   Width+  | MO_Shl   Width+  | MO_U_Shr Width      -- unsigned shift right+  | MO_S_Shr Width      -- signed shift right++  -- Conversions.  Some of these will be NOPs.+  -- Floating-point conversions use the signed variant.+  | MO_SF_Conv Width Width      -- Signed int -> Float+  | MO_FS_Conv Width Width      -- Float -> Signed int+  | MO_SS_Conv Width Width      -- Signed int -> Signed int+  | MO_UU_Conv Width Width      -- unsigned int -> unsigned int+  | MO_XX_Conv Width Width      -- int -> int; puts no requirements on the+                                -- contents of upper bits when extending;+                                -- narrowing is simply truncation; the only+                                -- expectation is that we can recover the+                                -- original value by applying the opposite+                                -- MO_XX_Conv, e.g.,+                                --   MO_XX_CONV W64 W8 (MO_XX_CONV W8 W64 x)+                                -- is equivalent to just x.+  | MO_FF_Conv Width Width      -- Float -> Float++  -- Vector element insertion and extraction operations+  | MO_V_Insert  Length Width   -- Insert scalar into vector+  | MO_V_Extract Length Width   -- Extract scalar from vector++  -- Integer vector operations+  | MO_V_Add Length Width+  | MO_V_Sub Length Width+  | MO_V_Mul Length Width++  -- Signed vector multiply/divide+  | MO_VS_Quot Length Width+  | MO_VS_Rem  Length Width+  | MO_VS_Neg  Length Width++  -- Unsigned vector multiply/divide+  | MO_VU_Quot Length Width+  | MO_VU_Rem  Length Width++  -- Floting point vector element insertion and extraction operations+  | MO_VF_Insert  Length Width   -- Insert scalar into vector+  | MO_VF_Extract Length Width   -- Extract scalar from vector++  -- Floating point vector operations+  | MO_VF_Add  Length Width+  | MO_VF_Sub  Length Width+  | MO_VF_Neg  Length Width      -- unary negation+  | MO_VF_Mul  Length Width+  | MO_VF_Quot Length Width++  -- Alignment check (for -falignment-sanitisation)+  | MO_AlignmentCheck Int Width+  deriving (Eq, Show)++pprMachOp :: MachOp -> SDoc+pprMachOp mo = text (show mo)++++-- -----------------------------------------------------------------------------+-- Some common MachReps++-- A 'wordRep' is a machine word on the target architecture+-- Specifically, it is the size of an Int#, Word#, Addr#+-- and the unit of allocation on the stack and the heap+-- Any pointer is also guaranteed to be a wordRep.++mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot+    , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem+    , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe+    , mo_wordULe, mo_wordUGt, mo_wordULt+    , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr+    , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord+    , mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64+    :: DynFlags -> MachOp++mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32+    , mo_32To8, mo_32To16+    :: MachOp++mo_wordAdd      dflags = MO_Add (wordWidth dflags)+mo_wordSub      dflags = MO_Sub (wordWidth dflags)+mo_wordEq       dflags = MO_Eq  (wordWidth dflags)+mo_wordNe       dflags = MO_Ne  (wordWidth dflags)+mo_wordMul      dflags = MO_Mul (wordWidth dflags)+mo_wordSQuot    dflags = MO_S_Quot (wordWidth dflags)+mo_wordSRem     dflags = MO_S_Rem (wordWidth dflags)+mo_wordSNeg     dflags = MO_S_Neg (wordWidth dflags)+mo_wordUQuot    dflags = MO_U_Quot (wordWidth dflags)+mo_wordURem     dflags = MO_U_Rem (wordWidth dflags)++mo_wordSGe      dflags = MO_S_Ge  (wordWidth dflags)+mo_wordSLe      dflags = MO_S_Le  (wordWidth dflags)+mo_wordSGt      dflags = MO_S_Gt  (wordWidth dflags)+mo_wordSLt      dflags = MO_S_Lt  (wordWidth dflags)++mo_wordUGe      dflags = MO_U_Ge  (wordWidth dflags)+mo_wordULe      dflags = MO_U_Le  (wordWidth dflags)+mo_wordUGt      dflags = MO_U_Gt  (wordWidth dflags)+mo_wordULt      dflags = MO_U_Lt  (wordWidth dflags)++mo_wordAnd      dflags = MO_And (wordWidth dflags)+mo_wordOr       dflags = MO_Or  (wordWidth dflags)+mo_wordXor      dflags = MO_Xor (wordWidth dflags)+mo_wordNot      dflags = MO_Not (wordWidth dflags)+mo_wordShl      dflags = MO_Shl (wordWidth dflags)+mo_wordSShr     dflags = MO_S_Shr (wordWidth dflags)+mo_wordUShr     dflags = MO_U_Shr (wordWidth dflags)++mo_u_8To32             = MO_UU_Conv W8 W32+mo_s_8To32             = MO_SS_Conv W8 W32+mo_u_16To32            = MO_UU_Conv W16 W32+mo_s_16To32            = MO_SS_Conv W16 W32++mo_u_8ToWord    dflags = MO_UU_Conv W8  (wordWidth dflags)+mo_s_8ToWord    dflags = MO_SS_Conv W8  (wordWidth dflags)+mo_u_16ToWord   dflags = MO_UU_Conv W16 (wordWidth dflags)+mo_s_16ToWord   dflags = MO_SS_Conv W16 (wordWidth dflags)+mo_s_32ToWord   dflags = MO_SS_Conv W32 (wordWidth dflags)+mo_u_32ToWord   dflags = MO_UU_Conv W32 (wordWidth dflags)++mo_WordTo8      dflags = MO_UU_Conv (wordWidth dflags) W8+mo_WordTo16     dflags = MO_UU_Conv (wordWidth dflags) W16+mo_WordTo32     dflags = MO_UU_Conv (wordWidth dflags) W32+mo_WordTo64     dflags = MO_UU_Conv (wordWidth dflags) W64++mo_32To8               = MO_UU_Conv W32 W8+mo_32To16              = MO_UU_Conv W32 W16+++-- ----------------------------------------------------------------------------+-- isCommutableMachOp++{- |+Returns 'True' if the MachOp has commutable arguments.  This is used+in the platform-independent Cmm optimisations.++If in doubt, return 'False'.  This generates worse code on the+native routes, but is otherwise harmless.+-}+isCommutableMachOp :: MachOp -> Bool+isCommutableMachOp mop =+  case mop of+        MO_Add _                -> True+        MO_Eq _                 -> True+        MO_Ne _                 -> True+        MO_Mul _                -> True+        MO_S_MulMayOflo _       -> True+        MO_U_MulMayOflo _       -> True+        MO_And _                -> True+        MO_Or _                 -> True+        MO_Xor _                -> True+        MO_F_Add _              -> True+        MO_F_Mul _              -> True+        _other                  -> False++-- ----------------------------------------------------------------------------+-- isAssociativeMachOp++{- |+Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@)+This is used in the platform-independent Cmm optimisations.++If in doubt, return 'False'.  This generates worse code on the+native routes, but is otherwise harmless.+-}+isAssociativeMachOp :: MachOp -> Bool+isAssociativeMachOp mop =+  case mop of+        MO_Add {} -> True       -- NB: does not include+        MO_Mul {} -> True --     floatint point!+        MO_And {} -> True+        MO_Or  {} -> True+        MO_Xor {} -> True+        _other    -> False+++-- ----------------------------------------------------------------------------+-- isComparisonMachOp++{- |+Returns 'True' if the MachOp is a comparison.++If in doubt, return False.  This generates worse code on the+native routes, but is otherwise harmless.+-}+isComparisonMachOp :: MachOp -> Bool+isComparisonMachOp mop =+  case mop of+    MO_Eq   _  -> True+    MO_Ne   _  -> True+    MO_S_Ge _  -> True+    MO_S_Le _  -> True+    MO_S_Gt _  -> True+    MO_S_Lt _  -> True+    MO_U_Ge _  -> True+    MO_U_Le _  -> True+    MO_U_Gt _  -> True+    MO_U_Lt _  -> True+    MO_F_Eq {} -> True+    MO_F_Ne {} -> True+    MO_F_Ge {} -> True+    MO_F_Le {} -> True+    MO_F_Gt {} -> True+    MO_F_Lt {} -> True+    _other     -> False++{- |+Returns @Just w@ if the operation is an integer comparison with width+@w@, or @Nothing@ otherwise.+-}+maybeIntComparison :: MachOp -> Maybe Width+maybeIntComparison mop =+  case mop of+    MO_Eq   w  -> Just w+    MO_Ne   w  -> Just w+    MO_S_Ge w  -> Just w+    MO_S_Le w  -> Just w+    MO_S_Gt w  -> Just w+    MO_S_Lt w  -> Just w+    MO_U_Ge w  -> Just w+    MO_U_Le w  -> Just w+    MO_U_Gt w  -> Just w+    MO_U_Lt w  -> Just w+    _ -> Nothing++isFloatComparison :: MachOp -> Bool+isFloatComparison mop =+  case mop of+    MO_F_Eq {} -> True+    MO_F_Ne {} -> True+    MO_F_Ge {} -> True+    MO_F_Le {} -> True+    MO_F_Gt {} -> True+    MO_F_Lt {} -> True+    _other     -> False++-- -----------------------------------------------------------------------------+-- Inverting conditions++-- Sometimes it's useful to be able to invert the sense of a+-- condition.  Not all conditional tests are invertible: in+-- particular, floating point conditionals cannot be inverted, because+-- there exist floating-point values which return False for both senses+-- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)).++maybeInvertComparison :: MachOp -> Maybe MachOp+maybeInvertComparison op+  = case op of  -- None of these Just cases include floating point+        MO_Eq r   -> Just (MO_Ne r)+        MO_Ne r   -> Just (MO_Eq r)+        MO_U_Lt r -> Just (MO_U_Ge r)+        MO_U_Gt r -> Just (MO_U_Le r)+        MO_U_Le r -> Just (MO_U_Gt r)+        MO_U_Ge r -> Just (MO_U_Lt r)+        MO_S_Lt r -> Just (MO_S_Ge r)+        MO_S_Gt r -> Just (MO_S_Le r)+        MO_S_Le r -> Just (MO_S_Gt r)+        MO_S_Ge r -> Just (MO_S_Lt r)+        _other    -> Nothing++-- ----------------------------------------------------------------------------+-- machOpResultType++{- |+Returns the MachRep of the result of a MachOp.+-}+machOpResultType :: DynFlags -> MachOp -> [CmmType] -> CmmType+machOpResultType dflags mop tys =+  case mop of+    MO_Add {}           -> ty1  -- Preserve GC-ptr-hood+    MO_Sub {}           -> ty1  -- of first arg+    MO_Mul    r         -> cmmBits r+    MO_S_MulMayOflo r   -> cmmBits r+    MO_S_Quot r         -> cmmBits r+    MO_S_Rem  r         -> cmmBits r+    MO_S_Neg  r         -> cmmBits r+    MO_U_MulMayOflo r   -> cmmBits r+    MO_U_Quot r         -> cmmBits r+    MO_U_Rem  r         -> cmmBits r++    MO_Eq {}            -> comparisonResultRep dflags+    MO_Ne {}            -> comparisonResultRep dflags+    MO_S_Ge {}          -> comparisonResultRep dflags+    MO_S_Le {}          -> comparisonResultRep dflags+    MO_S_Gt {}          -> comparisonResultRep dflags+    MO_S_Lt {}          -> comparisonResultRep dflags++    MO_U_Ge {}          -> comparisonResultRep dflags+    MO_U_Le {}          -> comparisonResultRep dflags+    MO_U_Gt {}          -> comparisonResultRep dflags+    MO_U_Lt {}          -> comparisonResultRep dflags++    MO_F_Add r          -> cmmFloat r+    MO_F_Sub r          -> cmmFloat r+    MO_F_Mul r          -> cmmFloat r+    MO_F_Quot r         -> cmmFloat r+    MO_F_Neg r          -> cmmFloat r+    MO_F_Eq  {}         -> comparisonResultRep dflags+    MO_F_Ne  {}         -> comparisonResultRep dflags+    MO_F_Ge  {}         -> comparisonResultRep dflags+    MO_F_Le  {}         -> comparisonResultRep dflags+    MO_F_Gt  {}         -> comparisonResultRep dflags+    MO_F_Lt  {}         -> comparisonResultRep dflags++    MO_And {}           -> ty1  -- Used for pointer masking+    MO_Or {}            -> ty1+    MO_Xor {}           -> ty1+    MO_Not   r          -> cmmBits r+    MO_Shl   r          -> cmmBits r+    MO_U_Shr r          -> cmmBits r+    MO_S_Shr r          -> cmmBits r++    MO_SS_Conv _ to     -> cmmBits to+    MO_UU_Conv _ to     -> cmmBits to+    MO_XX_Conv _ to     -> cmmBits to+    MO_FS_Conv _ to     -> cmmBits to+    MO_SF_Conv _ to     -> cmmFloat to+    MO_FF_Conv _ to     -> cmmFloat to++    MO_V_Insert  l w    -> cmmVec l (cmmBits w)+    MO_V_Extract _ w    -> cmmBits w++    MO_V_Add l w        -> cmmVec l (cmmBits w)+    MO_V_Sub l w        -> cmmVec l (cmmBits w)+    MO_V_Mul l w        -> cmmVec l (cmmBits w)++    MO_VS_Quot l w      -> cmmVec l (cmmBits w)+    MO_VS_Rem  l w      -> cmmVec l (cmmBits w)+    MO_VS_Neg  l w      -> cmmVec l (cmmBits w)++    MO_VU_Quot l w      -> cmmVec l (cmmBits w)+    MO_VU_Rem  l w      -> cmmVec l (cmmBits w)++    MO_VF_Insert  l w   -> cmmVec l (cmmFloat w)+    MO_VF_Extract _ w   -> cmmFloat w++    MO_VF_Add  l w      -> cmmVec l (cmmFloat w)+    MO_VF_Sub  l w      -> cmmVec l (cmmFloat w)+    MO_VF_Mul  l w      -> cmmVec l (cmmFloat w)+    MO_VF_Quot l w      -> cmmVec l (cmmFloat w)+    MO_VF_Neg  l w      -> cmmVec l (cmmFloat w)++    MO_AlignmentCheck _ _ -> ty1+  where+    (ty1:_) = tys++comparisonResultRep :: DynFlags -> CmmType+comparisonResultRep = bWord  -- is it?+++-- -----------------------------------------------------------------------------+-- machOpArgReps++-- | This function is used for debugging only: we can check whether an+-- application of a MachOp is "type-correct" by checking that the MachReps of+-- its arguments are the same as the MachOp expects.  This is used when+-- linting a CmmExpr.++machOpArgReps :: DynFlags -> MachOp -> [Width]+machOpArgReps dflags op =+  case op of+    MO_Add    r         -> [r,r]+    MO_Sub    r         -> [r,r]+    MO_Eq     r         -> [r,r]+    MO_Ne     r         -> [r,r]+    MO_Mul    r         -> [r,r]+    MO_S_MulMayOflo r   -> [r,r]+    MO_S_Quot r         -> [r,r]+    MO_S_Rem  r         -> [r,r]+    MO_S_Neg  r         -> [r]+    MO_U_MulMayOflo r   -> [r,r]+    MO_U_Quot r         -> [r,r]+    MO_U_Rem  r         -> [r,r]++    MO_S_Ge r           -> [r,r]+    MO_S_Le r           -> [r,r]+    MO_S_Gt r           -> [r,r]+    MO_S_Lt r           -> [r,r]++    MO_U_Ge r           -> [r,r]+    MO_U_Le r           -> [r,r]+    MO_U_Gt r           -> [r,r]+    MO_U_Lt r           -> [r,r]++    MO_F_Add r          -> [r,r]+    MO_F_Sub r          -> [r,r]+    MO_F_Mul r          -> [r,r]+    MO_F_Quot r         -> [r,r]+    MO_F_Neg r          -> [r]+    MO_F_Eq  r          -> [r,r]+    MO_F_Ne  r          -> [r,r]+    MO_F_Ge  r          -> [r,r]+    MO_F_Le  r          -> [r,r]+    MO_F_Gt  r          -> [r,r]+    MO_F_Lt  r          -> [r,r]++    MO_And   r          -> [r,r]+    MO_Or    r          -> [r,r]+    MO_Xor   r          -> [r,r]+    MO_Not   r          -> [r]+    MO_Shl   r          -> [r, wordWidth dflags]+    MO_U_Shr r          -> [r, wordWidth dflags]+    MO_S_Shr r          -> [r, wordWidth dflags]++    MO_SS_Conv from _   -> [from]+    MO_UU_Conv from _   -> [from]+    MO_XX_Conv from _   -> [from]+    MO_SF_Conv from _   -> [from]+    MO_FS_Conv from _   -> [from]+    MO_FF_Conv from _   -> [from]++    MO_V_Insert  l r    -> [typeWidth (vec l (cmmBits r)),r,wordWidth dflags]+    MO_V_Extract l r    -> [typeWidth (vec l (cmmBits r)),wordWidth dflags]++    MO_V_Add _ r        -> [r,r]+    MO_V_Sub _ r        -> [r,r]+    MO_V_Mul _ r        -> [r,r]++    MO_VS_Quot _ r      -> [r,r]+    MO_VS_Rem  _ r      -> [r,r]+    MO_VS_Neg  _ r      -> [r]++    MO_VU_Quot _ r      -> [r,r]+    MO_VU_Rem  _ r      -> [r,r]++    MO_VF_Insert  l r   -> [typeWidth (vec l (cmmFloat r)),r,wordWidth dflags]+    MO_VF_Extract l r   -> [typeWidth (vec l (cmmFloat r)),wordWidth dflags]++    MO_VF_Add  _ r      -> [r,r]+    MO_VF_Sub  _ r      -> [r,r]+    MO_VF_Mul  _ r      -> [r,r]+    MO_VF_Quot _ r      -> [r,r]+    MO_VF_Neg  _ r      -> [r]++    MO_AlignmentCheck _ r -> [r]++-----------------------------------------------------------------------------+-- CallishMachOp+-----------------------------------------------------------------------------++-- CallishMachOps tend to be implemented by foreign calls in some backends,+-- so we separate them out.  In Cmm, these can only occur in a+-- statement position, in contrast to an ordinary MachOp which can occur+-- anywhere in an expression.+data CallishMachOp+  = MO_F64_Pwr+  | MO_F64_Sin+  | MO_F64_Cos+  | MO_F64_Tan+  | MO_F64_Sinh+  | MO_F64_Cosh+  | MO_F64_Tanh+  | MO_F64_Asin+  | MO_F64_Acos+  | MO_F64_Atan+  | MO_F64_Asinh+  | MO_F64_Acosh+  | MO_F64_Atanh+  | MO_F64_Log+  | MO_F64_Exp+  | MO_F64_Fabs+  | MO_F64_Sqrt+  | MO_F32_Pwr+  | MO_F32_Sin+  | MO_F32_Cos+  | MO_F32_Tan+  | MO_F32_Sinh+  | MO_F32_Cosh+  | MO_F32_Tanh+  | MO_F32_Asin+  | MO_F32_Acos+  | MO_F32_Atan+  | MO_F32_Asinh+  | MO_F32_Acosh+  | MO_F32_Atanh+  | MO_F32_Log+  | MO_F32_Exp+  | MO_F32_Fabs+  | MO_F32_Sqrt++  | MO_UF_Conv Width++  | MO_S_QuotRem Width+  | MO_U_QuotRem Width+  | MO_U_QuotRem2 Width+  | MO_Add2      Width+  | MO_AddWordC  Width+  | MO_SubWordC  Width+  | MO_AddIntC   Width+  | MO_SubIntC   Width+  | MO_U_Mul2    Width++  | MO_WriteBarrier+  | MO_Touch         -- Keep variables live (when using interior pointers)++  -- Prefetch+  | MO_Prefetch_Data Int -- Prefetch hint. May change program performance but not+                     -- program behavior.+                     -- the Int can be 0-3. Needs to be known at compile time+                     -- to interact with code generation correctly.+                     --  TODO: add support for prefetch WRITES,+                     --  currently only exposes prefetch reads, which+                     -- would the majority of use cases in ghc anyways+++  -- These three MachOps are parameterised by the known alignment+  -- of the destination and source (for memcpy/memmove) pointers.+  -- This information may be used for optimisation in backends.+  | MO_Memcpy Int+  | MO_Memset Int+  | MO_Memmove Int+  | MO_Memcmp Int++  | MO_PopCnt Width+  | MO_Pdep Width+  | MO_Pext Width+  | MO_Clz Width+  | MO_Ctz Width++  | MO_BSwap Width+  | MO_BRev Width++  -- Atomic read-modify-write.+  | MO_AtomicRMW Width AtomicMachOp+  | MO_AtomicRead Width+  | MO_AtomicWrite Width+  | MO_Cmpxchg Width+  deriving (Eq, Show)++-- | The operation to perform atomically.+data AtomicMachOp =+      AMO_Add+    | AMO_Sub+    | AMO_And+    | AMO_Nand+    | AMO_Or+    | AMO_Xor+      deriving (Eq, Show)++pprCallishMachOp :: CallishMachOp -> SDoc+pprCallishMachOp mo = text (show mo)++callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint])+callishMachOpHints op = case op of+  MO_Memcpy _  -> ([], [AddrHint,AddrHint,NoHint])+  MO_Memset _  -> ([], [AddrHint,NoHint,NoHint])+  MO_Memmove _ -> ([], [AddrHint,AddrHint,NoHint])+  MO_Memcmp _  -> ([], [AddrHint, AddrHint, NoHint])+  _            -> ([],[])+  -- empty lists indicate NoHint++-- | The alignment of a 'memcpy'-ish operation.+machOpMemcpyishAlign :: CallishMachOp -> Maybe Int+machOpMemcpyishAlign op = case op of+  MO_Memcpy  align -> Just align+  MO_Memset  align -> Just align+  MO_Memmove align -> Just align+  MO_Memcmp  align -> Just align+  _                -> Nothing
+ compiler/cmm/CmmMonad.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+-- A Parser monad with access to the 'DynFlags'.+--+-- The 'P' monad  only has access to the subset of of 'DynFlags'+-- required for parsing Haskell.++-- The parser for C-- requires access to a lot more of the 'DynFlags',+-- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.+-----------------------------------------------------------------------------+module CmmMonad (+    PD(..)+  , liftP+  ) where++import GhcPrelude++import Control.Monad+import qualified Control.Monad.Fail as MonadFail++import DynFlags+import Lexer++newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a }++instance Functor PD where+  fmap = liftM++instance Applicative PD where+  pure = returnPD+  (<*>) = ap++instance Monad PD where+  (>>=) = thenPD+#if !MIN_VERSION_base(4,13,0)+  fail = MonadFail.fail+#endif++instance MonadFail.MonadFail PD where+  fail = failPD++liftP :: P a -> PD a+liftP (P f) = PD $ \_ s -> f s++returnPD :: a -> PD a+returnPD = liftP . return++thenPD :: PD a -> (a -> PD b) -> PD b+(PD m) `thenPD` k = PD $ \d s ->+        case m d s of+                POk s1 a         -> unPD (k a) d s1+                PFailed s1 -> PFailed s1++failPD :: String -> PD a+failPD = liftP . fail++instance HasDynFlags PD where+   getDynFlags = PD $ \d s -> POk s d
+ compiler/cmm/CmmNode.hs view
@@ -0,0 +1,724 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+++-- CmmNode type for representation using Hoopl graphs.++module CmmNode (+     CmmNode(..), CmmFormal, CmmActual, CmmTickish,+     UpdFrameOffset, Convention(..),+     ForeignConvention(..), ForeignTarget(..), foreignTargetHints,+     CmmReturnInfo(..),+     mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,+     mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors, mapCollectSuccessors,++     -- * Tick scopes+     CmmTickScope(..), isTickSubScope, combineTickScopes,+  ) where++import GhcPrelude hiding (succ)++import CodeGen.Platform+import CmmExpr+import CmmSwitch+import DynFlags+import FastString+import ForeignCall+import Outputable+import SMRep+import CoreSyn (Tickish)+import qualified Unique as U++import Hoopl.Block+import Hoopl.Graph+import Hoopl.Collections+import Hoopl.Label+import Data.Maybe+import Data.List (tails,sortBy)+import Unique (nonDetCmpUnique)+import Util+++------------------------+-- CmmNode++#define ULabel {-# UNPACK #-} !Label++data CmmNode e x where+  CmmEntry :: ULabel -> CmmTickScope -> CmmNode C O++  CmmComment :: FastString -> CmmNode O O++    -- Tick annotation, covering Cmm code in our tick scope. We only+    -- expect non-code @Tickish@ at this point (e.g. @SourceNote@).+    -- See Note [CmmTick scoping details]+  CmmTick :: !CmmTickish -> CmmNode O O++    -- Unwind pseudo-instruction, encoding stack unwinding+    -- instructions for a debugger. This describes how to reconstruct+    -- the "old" value of a register if we want to navigate the stack+    -- up one frame. Having unwind information for @Sp@ will allow the+    -- debugger to "walk" the stack.+    --+    -- See Note [What is this unwinding business?] in Debug+  CmmUnwind :: [(GlobalReg, Maybe CmmExpr)] -> CmmNode O O++  CmmAssign :: !CmmReg -> !CmmExpr -> CmmNode O O+    -- Assign to register++  CmmStore :: !CmmExpr -> !CmmExpr -> CmmNode O O+    -- Assign to memory location.  Size is+    -- given by cmmExprType of the rhs.++  CmmUnsafeForeignCall ::       -- An unsafe foreign call;+                                -- see Note [Foreign calls]+                                -- Like a "fat machine instruction"; can occur+                                -- in the middle of a block+      ForeignTarget ->          -- call target+      [CmmFormal] ->            -- zero or more results+      [CmmActual] ->            -- zero or more arguments+      CmmNode O O+      -- Semantics: clobbers any GlobalRegs for which callerSaves r == True+      -- See Note [Unsafe foreign calls clobber caller-save registers]+      --+      -- Invariant: the arguments and the ForeignTarget must not+      -- mention any registers for which CodeGen.Platform.callerSaves+      -- is True.  See Note [Register Parameter Passing].++  CmmBranch :: ULabel -> CmmNode O C+                                   -- Goto another block in the same procedure++  CmmCondBranch :: {                 -- conditional branch+      cml_pred :: CmmExpr,+      cml_true, cml_false :: ULabel,+      cml_likely :: Maybe Bool       -- likely result of the conditional,+                                     -- if known+  } -> CmmNode O C++  CmmSwitch+    :: CmmExpr       -- Scrutinee, of some integral type+    -> SwitchTargets -- Cases. See [Note SwitchTargets]+    -> CmmNode O C++  CmmCall :: {                -- A native call or tail call+      cml_target :: CmmExpr,  -- never a CmmPrim to a CallishMachOp!++      cml_cont :: Maybe Label,+          -- Label of continuation (Nothing for return or tail call)+          --+          -- Note [Continuation BlockId]: these BlockIds are called+          -- Continuation BlockIds, and are the only BlockIds that can+          -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or+          -- (CmmStackSlot (Young b) _).++      cml_args_regs :: [GlobalReg],+          -- The argument GlobalRegs (Rx, Fx, Dx, Lx) that are passed+          -- to the call.  This is essential information for the+          -- native code generator's register allocator; without+          -- knowing which GlobalRegs are live it has to assume that+          -- they are all live.  This list should only include+          -- GlobalRegs that are mapped to real machine registers on+          -- the target platform.++      cml_args :: ByteOff,+          -- Byte offset, from the *old* end of the Area associated with+          -- the Label (if cml_cont = Nothing, then Old area), of+          -- youngest outgoing arg.  Set the stack pointer to this before+          -- transferring control.+          -- (NB: an update frame might also have been stored in the Old+          --      area, but it'll be in an older part than the args.)++      cml_ret_args :: ByteOff,+          -- For calls *only*, the byte offset for youngest returned value+          -- This is really needed at the *return* point rather than here+          -- at the call, but in practice it's convenient to record it here.++      cml_ret_off :: ByteOff+        -- For calls *only*, the byte offset of the base of the frame that+        -- must be described by the info table for the return point.+        -- The older words are an update frames, which have their own+        -- info-table and layout information++        -- From a liveness point of view, the stack words older than+        -- cml_ret_off are treated as live, even if the sequel of+        -- the call goes into a loop.+  } -> CmmNode O C++  CmmForeignCall :: {           -- A safe foreign call; see Note [Foreign calls]+                                -- Always the last node of a block+      tgt   :: ForeignTarget,   -- call target and convention+      res   :: [CmmFormal],     -- zero or more results+      args  :: [CmmActual],     -- zero or more arguments; see Note [Register parameter passing]+      succ  :: ULabel,          -- Label of continuation+      ret_args :: ByteOff,      -- same as cml_ret_args+      ret_off :: ByteOff,       -- same as cml_ret_off+      intrbl:: Bool             -- whether or not the call is interruptible+  } -> CmmNode O C++{- Note [Foreign calls]+~~~~~~~~~~~~~~~~~~~~~~~+A CmmUnsafeForeignCall is used for *unsafe* foreign calls;+a CmmForeignCall call is used for *safe* foreign calls.++Unsafe ones are mostly easy: think of them as a "fat machine+instruction".  In particular, they do *not* kill all live registers,+just the registers they return to (there was a bit of code in GHC that+conservatively assumed otherwise.)  However, see [Register parameter passing].++Safe ones are trickier.  A safe foreign call+     r = f(x)+ultimately expands to+     push "return address"      -- Never used to return to;+                                -- just points an info table+     save registers into TSO+     call suspendThread+     r = f(x)                   -- Make the call+     call resumeThread+     restore registers+     pop "return address"+We cannot "lower" a safe foreign call to this sequence of Cmms, because+after we've saved Sp all the Cmm optimiser's assumptions are broken.++Note that a safe foreign call needs an info table.++So Safe Foreign Calls must remain as last nodes until the stack is+made manifest in CmmLayoutStack, where they are lowered into the above+sequence.+-}++{- Note [Unsafe foreign calls clobber caller-save registers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++A foreign call is defined to clobber any GlobalRegs that are mapped to+caller-saves machine registers (according to the prevailing C ABI).+StgCmmUtils.callerSaves tells you which GlobalRegs are caller-saves.++This is a design choice that makes it easier to generate code later.+We could instead choose to say that foreign calls do *not* clobber+caller-saves regs, but then we would have to figure out which regs+were live across the call later and insert some saves/restores.++Furthermore when we generate code we never have any GlobalRegs live+across a call, because they are always copied-in to LocalRegs and+copied-out again before making a call/jump.  So all we have to do is+avoid any code motion that would make a caller-saves GlobalReg live+across a foreign call during subsequent optimisations.+-}++{- Note [Register parameter passing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On certain architectures, some registers are utilized for parameter+passing in the C calling convention.  For example, in x86-64 Linux+convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for+argument passing.  These are registers R3-R6, which our generated+code may also be using; as a result, it's necessary to save these+values before doing a foreign call.  This is done during initial+code generation in callerSaveVolatileRegs in StgCmmUtils.hs.  However,+one result of doing this is that the contents of these registers+may mysteriously change if referenced inside the arguments.  This+is dangerous, so you'll need to disable inlining much in the same+way is done in cmm/CmmOpt.hs currently.  We should fix this!+-}++---------------------------------------------+-- Eq instance of CmmNode++deriving instance Eq (CmmNode e x)++----------------------------------------------+-- Hoopl instances of CmmNode++instance NonLocal CmmNode where+  entryLabel (CmmEntry l _) = l++  successors (CmmBranch l) = [l]+  successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint+  successors (CmmSwitch _ ids) = switchTargetsToList ids+  successors (CmmCall {cml_cont=l}) = maybeToList l+  successors (CmmForeignCall {succ=l}) = [l]+++--------------------------------------------------+-- Various helper types++type CmmActual = CmmExpr+type CmmFormal = LocalReg++type UpdFrameOffset = ByteOff++-- | A convention maps a list of values (function arguments or return+-- values) to registers or stack locations.+data Convention+  = NativeDirectCall+       -- ^ top-level Haskell functions use @NativeDirectCall@, which+       -- maps arguments to registers starting with R2, according to+       -- how many registers are available on the platform.  This+       -- convention ignores R1, because for a top-level function call+       -- the function closure is implicit, and doesn't need to be passed.+  | NativeNodeCall+       -- ^ non-top-level Haskell functions, which pass the address of+       -- the function closure in R1 (regardless of whether R1 is a+       -- real register or not), and the rest of the arguments in+       -- registers or on the stack.+  | NativeReturn+       -- ^ a native return.  The convention for returns depends on+       -- how many values are returned: for just one value returned,+       -- the appropriate register is used (R1, F1, etc.). regardless+       -- of whether it is a real register or not.  For multiple+       -- values returned, they are mapped to registers or the stack.+  | Slow+       -- ^ Slow entry points: all args pushed on the stack+  | GC+       -- ^ Entry to the garbage collector: uses the node reg!+       -- (TODO: I don't think we need this --SDM)+  deriving( Eq )++data ForeignConvention+  = ForeignConvention+        CCallConv               -- Which foreign-call convention+        [ForeignHint]           -- Extra info about the args+        [ForeignHint]           -- Extra info about the result+        CmmReturnInfo+  deriving Eq++data CmmReturnInfo+  = CmmMayReturn+  | CmmNeverReturns+  deriving ( Eq )++data ForeignTarget        -- The target of a foreign call+  = ForeignTarget                -- A foreign procedure+        CmmExpr                  -- Its address+        ForeignConvention        -- Its calling convention+  | PrimTarget            -- A possibly-side-effecting machine operation+        CallishMachOp            -- Which one+  deriving Eq++foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])+foreignTargetHints target+  = ( res_hints ++ repeat NoHint+    , arg_hints ++ repeat NoHint )+  where+    (res_hints, arg_hints) =+       case target of+          PrimTarget op -> callishMachOpHints op+          ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) ->+             (res_hints, arg_hints)++--------------------------------------------------+-- Instances of register and slot users / definers++instance UserOfRegs LocalReg (CmmNode e x) where+  foldRegsUsed dflags f !z n = case n of+    CmmAssign _ expr -> fold f z expr+    CmmStore addr rval -> fold f (fold f z addr) rval+    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args+    CmmCondBranch expr _ _ _ -> fold f z expr+    CmmSwitch expr _ -> fold f z expr+    CmmCall {cml_target=tgt} -> fold f z tgt+    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args+    _ -> z+    where fold :: forall a b. UserOfRegs LocalReg a+               => (b -> LocalReg -> b) -> b -> a -> b+          fold f z n = foldRegsUsed dflags f z n++instance UserOfRegs GlobalReg (CmmNode e x) where+  foldRegsUsed dflags f !z n = case n of+    CmmAssign _ expr -> fold f z expr+    CmmStore addr rval -> fold f (fold f z addr) rval+    CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args+    CmmCondBranch expr _ _ _ -> fold f z expr+    CmmSwitch expr _ -> fold f z expr+    CmmCall {cml_target=tgt, cml_args_regs=args} -> fold f (fold f z args) tgt+    CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args+    _ -> z+    where fold :: forall a b.  UserOfRegs GlobalReg a+               => (b -> GlobalReg -> b) -> b -> a -> b+          fold f z n = foldRegsUsed dflags f z n++instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r ForeignTarget where+  -- The (Ord r) in the context is necessary here+  -- See Note [Recursive superclasses] in TcInstDcls+  foldRegsUsed _      _ !z (PrimTarget _)      = z+  foldRegsUsed dflags f !z (ForeignTarget e _) = foldRegsUsed dflags f z e++instance DefinerOfRegs LocalReg (CmmNode e x) where+  foldRegsDefd dflags f !z n = case n of+    CmmAssign lhs _ -> fold f z lhs+    CmmUnsafeForeignCall _ fs _ -> fold f z fs+    CmmForeignCall {res=res} -> fold f z res+    _ -> z+    where fold :: forall a b. DefinerOfRegs LocalReg a+               => (b -> LocalReg -> b) -> b -> a -> b+          fold f z n = foldRegsDefd dflags f z n++instance DefinerOfRegs GlobalReg (CmmNode e x) where+  foldRegsDefd dflags f !z n = case n of+    CmmAssign lhs _ -> fold f z lhs+    CmmUnsafeForeignCall tgt _ _  -> fold f z (foreignTargetRegs tgt)+    CmmCall        {} -> fold f z activeRegs+    CmmForeignCall {} -> fold f z activeRegs+                      -- See Note [Safe foreign calls clobber STG registers]+    _ -> z+    where fold :: forall a b. DefinerOfRegs GlobalReg a+               => (b -> GlobalReg -> b) -> b -> a -> b+          fold f z n = foldRegsDefd dflags f z n++          platform = targetPlatform dflags+          activeRegs = activeStgRegs platform+          activeCallerSavesRegs = filter (callerSaves platform) activeRegs++          foreignTargetRegs (ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns)) = []+          foreignTargetRegs _ = activeCallerSavesRegs++-- Note [Safe foreign calls clobber STG registers]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- During stack layout phase every safe foreign call is expanded into a block+-- that contains unsafe foreign call (instead of safe foreign call) and ends+-- with a normal call (See Note [Foreign calls]). This means that we must+-- treat safe foreign call as if it was a normal call (because eventually it+-- will be). This is important if we try to run sinking pass before stack+-- layout phase. Consider this example of what might go wrong (this is cmm+-- code from stablename001 test). Here is code after common block elimination+-- (before stack layout):+--+--  c1q6:+--      _s1pf::P64 = R1;+--      _c1q8::I64 = performMajorGC;+--      I64[(young<c1q9> + 8)] = c1q9;+--      foreign call "ccall" arg hints:  []  result hints:  [] (_c1q8::I64)(...)+--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;+--  c1q9:+--      I64[(young<c1qb> + 8)] = c1qb;+--      R1 = _s1pc::P64;+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;+--+-- If we run sinking pass now (still before stack layout) we will get this:+--+--  c1q6:+--      I64[(young<c1q9> + 8)] = c1q9;+--      foreign call "ccall" arg hints:  []  result hints:  [] performMajorGC(...)+--                   returns to c1q9 args: ([]) ress: ([])ret_args: 8ret_off: 8;+--  c1q9:+--      I64[(young<c1qb> + 8)] = c1qb;+--      _s1pf::P64 = R1;         <------ _s1pf sunk past safe foreign call+--      R1 = _s1pc::P64;+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;+--+-- Notice that _s1pf was sunk past a foreign call. When we run stack layout+-- safe call to performMajorGC will be turned into:+--+--  c1q6:+--      _s1pc::P64 = P64[Sp + 8];+--      I64[Sp - 8] = c1q9;+--      Sp = Sp - 8;+--      I64[I64[CurrentTSO + 24] + 16] = Sp;+--      P64[CurrentNursery + 8] = Hp + 8;+--      (_u1qI::I64) = call "ccall" arg hints:  [PtrHint,]+--                           result hints:  [PtrHint] suspendThread(BaseReg, 0);+--      call "ccall" arg hints:  []  result hints:  [] performMajorGC();+--      (_u1qJ::I64) = call "ccall" arg hints:  [PtrHint]+--                           result hints:  [PtrHint] resumeThread(_u1qI::I64);+--      BaseReg = _u1qJ::I64;+--      _u1qK::P64 = CurrentTSO;+--      _u1qL::P64 = I64[_u1qK::P64 + 24];+--      Sp = I64[_u1qL::P64 + 16];+--      SpLim = _u1qL::P64 + 192;+--      HpAlloc = 0;+--      Hp = I64[CurrentNursery + 8] - 8;+--      HpLim = I64[CurrentNursery] + (%MO_SS_Conv_W32_W64(I32[CurrentNursery + 48]) * 4096 - 1);+--      call (I64[Sp])() returns to c1q9, args: 8, res: 8, upd: 8;+--  c1q9:+--      I64[(young<c1qb> + 8)] = c1qb;+--      _s1pf::P64 = R1;         <------ INCORRECT!+--      R1 = _s1pc::P64;+--      call stg_makeStableName#(R1) returns to c1qb, args: 8, res: 8, upd: 8;+--+-- Notice that c1q6 now ends with a call. Sinking _s1pf::P64 = R1 past that+-- call is clearly incorrect. This is what would happen if we assumed that+-- safe foreign call has the same semantics as unsafe foreign call. To prevent+-- this we need to treat safe foreign call as if was normal call.++-----------------------------------+-- mapping Expr in CmmNode++mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget+mapForeignTarget exp   (ForeignTarget e c) = ForeignTarget (exp e) c+mapForeignTarget _   m@(PrimTarget _)      = m++wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr+-- Take a transformer on expressions and apply it recursively.+-- (wrapRecExp f e) first recursively applies itself to sub-expressions of e+--                  then  uses f to rewrite the resulting expression+wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map (wrapRecExp f) es)+wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (wrapRecExp f addr) ty)+wrapRecExp f e                    = f e++mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x+mapExp _ f@(CmmEntry{})                          = f+mapExp _ m@(CmmComment _)                        = m+mapExp _ m@(CmmTick _)                           = m+mapExp f   (CmmUnwind regs)                      = CmmUnwind (map (fmap (fmap f)) regs)+mapExp f   (CmmAssign r e)                       = CmmAssign r (f e)+mapExp f   (CmmStore addr e)                     = CmmStore (f addr) (f e)+mapExp f   (CmmUnsafeForeignCall tgt fs as)      = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)+mapExp _ l@(CmmBranch _)                         = l+mapExp f   (CmmCondBranch e ti fi l)             = CmmCondBranch (f e) ti fi l+mapExp f   (CmmSwitch e ids)                     = CmmSwitch (f e) ids+mapExp f   n@CmmCall {cml_target=tgt}            = n{cml_target = f tgt}+mapExp f   (CmmForeignCall tgt fs as succ ret_args updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ ret_args updfr intrbl++mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x+mapExpDeep f = mapExp $ wrapRecExp f++------------------------------------------------------------------------+-- mapping Expr in CmmNode, but not performing allocation if no changes++mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget+mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e+mapForeignTargetM _ (PrimTarget _)      = Nothing++wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr)+-- (wrapRecExpM f e) first recursively applies itself to sub-expressions of e+--                   then  gives f a chance to rewrite the resulting expression+wrapRecExpM f n@(CmmMachOp op es)  = maybe (f n) (f . CmmMachOp op)    (mapListM (wrapRecExpM f) es)+wrapRecExpM f n@(CmmLoad addr ty)  = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr)+wrapRecExpM f e                    = f e++mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)+mapExpM _ (CmmEntry{})              = Nothing+mapExpM _ (CmmComment _)            = Nothing+mapExpM _ (CmmTick _)               = Nothing+mapExpM f (CmmUnwind regs)          = CmmUnwind `fmap` mapM (\(r,e) -> mapM f e >>= \e' -> pure (r,e')) regs+mapExpM f (CmmAssign r e)           = CmmAssign r `fmap` f e+mapExpM f (CmmStore addr e)         = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e]+mapExpM _ (CmmBranch _)             = Nothing+mapExpM f (CmmCondBranch e ti fi l) = (\x -> CmmCondBranch x ti fi l) `fmap` f e+mapExpM f (CmmSwitch e tbl)         = (\x -> CmmSwitch x tbl)       `fmap` f e+mapExpM f (CmmCall tgt mb_id r o i s) = (\x -> CmmCall x mb_id r o i s) `fmap` f tgt+mapExpM f (CmmUnsafeForeignCall tgt fs as)+    = case mapForeignTargetM f tgt of+        Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as))+        Nothing   -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as+mapExpM f (CmmForeignCall tgt fs as succ ret_args updfr intrbl)+    = case mapForeignTargetM f tgt of+        Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ ret_args updfr intrbl)+        Nothing   -> (\xs -> CmmForeignCall tgt fs xs succ ret_args updfr intrbl) `fmap` mapListM f as++-- share as much as possible+mapListM :: (a -> Maybe a) -> [a] -> Maybe [a]+mapListM f xs = let (b, r) = mapListT f xs+                in if b then Just r else Nothing++mapListJ :: (a -> Maybe a) -> [a] -> [a]+mapListJ f xs = snd (mapListT f xs)++mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a])+mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs))+    where g (_,   y, Nothing) (True, ys)  = (True,  y:ys)+          g (_,   _, Just y)  (True, ys)  = (True,  y:ys)+          g (ys', _, Nothing) (False, _)  = (False, ys')+          g (_,   _, Just y)  (False, ys) = (True,  y:ys)++mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x)+mapExpDeepM f = mapExpM $ wrapRecExpM f++-----------------------------------+-- folding Expr in CmmNode++foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z+foldExpForeignTarget exp (ForeignTarget e _) z = exp e z+foldExpForeignTarget _   (PrimTarget _)      z = z++-- Take a folder on expressions and apply it recursively.+-- Specifically (wrapRecExpf f e z) deals with CmmMachOp and CmmLoad+-- itself, delegating all the other CmmExpr forms to 'f'.+wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z+wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es+wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)+wrapRecExpf f e                  z = f e z++foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z+foldExp _ (CmmEntry {}) z                         = z+foldExp _ (CmmComment {}) z                       = z+foldExp _ (CmmTick {}) z                          = z+foldExp f (CmmUnwind xs) z                        = foldr (maybe id f) z (map snd xs)+foldExp f (CmmAssign _ e) z                       = f e z+foldExp f (CmmStore addr e) z                     = f addr $ f e z+foldExp f (CmmUnsafeForeignCall t _ as) z         = foldr f (foldExpForeignTarget f t z) as+foldExp _ (CmmBranch _) z                         = z+foldExp f (CmmCondBranch e _ _ _) z               = f e z+foldExp f (CmmSwitch e _) z                       = f e z+foldExp f (CmmCall {cml_target=tgt}) z            = f tgt z+foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args++foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z+foldExpDeep f = foldExp (wrapRecExpf f)++-- -----------------------------------------------------------------------------++mapSuccessors :: (Label -> Label) -> CmmNode O C -> CmmNode O C+mapSuccessors f (CmmBranch bid)         = CmmBranch (f bid)+mapSuccessors f (CmmCondBranch p y n l) = CmmCondBranch p (f y) (f n) l+mapSuccessors f (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets f ids)+mapSuccessors _ n = n++mapCollectSuccessors :: forall a. (Label -> (Label,a)) -> CmmNode O C+                     -> (CmmNode O C, [a])+mapCollectSuccessors f (CmmBranch bid)+  = let (bid', acc) = f bid in (CmmBranch bid', [acc])+mapCollectSuccessors f (CmmCondBranch p y n l)+  = let (bidt, acct) = f y+        (bidf, accf) = f n+    in  (CmmCondBranch p bidt bidf l, [accf, acct])+mapCollectSuccessors f (CmmSwitch e ids)+  = let lbls = switchTargetsToList ids :: [Label]+        lblMap = mapFromList $ zip lbls (map f lbls) :: LabelMap (Label, a)+    in ( CmmSwitch e+          (mapSwitchTargets+            (\l -> fst $ mapFindWithDefault (error "impossible") l lblMap) ids)+          , map snd (mapElems lblMap)+        )+mapCollectSuccessors _ n = (n, [])++-- -----------------------------------------------------------------------------++-- | Tickish in Cmm context (annotations only)+type CmmTickish = Tickish ()++-- | Tick scope identifier, allowing us to reason about what+-- annotations in a Cmm block should scope over. We especially take+-- care to allow optimisations to reorganise blocks without losing+-- tick association in the process.+data CmmTickScope+  = GlobalScope+    -- ^ The global scope is the "root" of the scope graph. Every+    -- scope is a sub-scope of the global scope. It doesn't make sense+    -- to add ticks to this scope. On the other hand, this means that+    -- setting this scope on a block means no ticks apply to it.++  | SubScope !U.Unique CmmTickScope+    -- ^ Constructs a new sub-scope to an existing scope. This allows+    -- us to translate Core-style scoping rules (see @tickishScoped@)+    -- into the Cmm world. Suppose the following code:+    --+    --   tick<1> case ... of+    --             A -> tick<2> ...+    --             B -> tick<3> ...+    --+    -- We want the top-level tick annotation to apply to blocks+    -- generated for the A and B alternatives. We can achieve that by+    -- generating tick<1> into a block with scope a, while the code+    -- for alternatives A and B gets generated into sub-scopes a/b and+    -- a/c respectively.++  | CombinedScope CmmTickScope CmmTickScope+    -- ^ A combined scope scopes over everything that the two given+    -- scopes cover. It is therefore a sub-scope of either scope. This+    -- is required for optimisations. Consider common block elimination:+    --+    --   A -> tick<2> case ... of+    --     C -> [common]+    --   B -> tick<3> case ... of+    --     D -> [common]+    --+    -- We will generate code for the C and D alternatives, and figure+    -- out afterwards that it's actually common code. Scoping rules+    -- dictate that the resulting common block needs to be covered by+    -- both tick<2> and tick<3>, therefore we need to construct a+    -- scope that is a child to *both* scope. Now we can do that - if+    -- we assign the scopes a/c and b/d to the common-ed up blocks,+    -- the new block could have a combined tick scope a/c+b/d, which+    -- both tick<2> and tick<3> apply to.++-- Note [CmmTick scoping details]:+--+-- The scope of a @CmmTick@ is given by the @CmmEntry@ node of the+-- same block. Note that as a result of this, optimisations making+-- tick scopes more specific can *reduce* the amount of code a tick+-- scopes over. Fixing this would require a separate @CmmTickScope@+-- field for @CmmTick@. Right now we do not do this simply because I+-- couldn't find an example where it actually mattered -- multiple+-- blocks within the same scope generally jump to each other, which+-- prevents common block elimination from happening in the first+-- place. But this is no strong reason, so if Cmm optimisations become+-- more involved in future this might have to be revisited.++-- | Output all scope paths.+scopeToPaths :: CmmTickScope -> [[U.Unique]]+scopeToPaths GlobalScope           = [[]]+scopeToPaths (SubScope u s)        = map (u:) (scopeToPaths s)+scopeToPaths (CombinedScope s1 s2) = scopeToPaths s1 ++ scopeToPaths s2++-- | Returns the head uniques of the scopes. This is based on the+-- assumption that the @Unique@ of @SubScope@ identifies the+-- underlying super-scope. Used for efficient equality and comparison,+-- see below.+scopeUniques :: CmmTickScope -> [U.Unique]+scopeUniques GlobalScope           = []+scopeUniques (SubScope u _)        = [u]+scopeUniques (CombinedScope s1 s2) = scopeUniques s1 ++ scopeUniques s2++-- Equality and order is based on the head uniques defined above. We+-- take care to short-cut the (extremly) common cases.+instance Eq CmmTickScope where+  GlobalScope    == GlobalScope     = True+  GlobalScope    == _               = False+  _              == GlobalScope     = False+  (SubScope u _) == (SubScope u' _) = u == u'+  (SubScope _ _) == _               = False+  _              == (SubScope _ _)  = False+  scope          == scope'          =+    sortBy nonDetCmpUnique (scopeUniques scope) ==+    sortBy nonDetCmpUnique (scopeUniques scope')+    -- This is still deterministic because+    -- the order is the same for equal lists++-- This is non-deterministic but we do not currently support deterministic+-- code-generation. See Note [Unique Determinism and code generation]+-- See Note [No Ord for Unique]+instance Ord CmmTickScope where+  compare GlobalScope    GlobalScope     = EQ+  compare GlobalScope    _               = LT+  compare _              GlobalScope     = GT+  compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u'+  compare scope scope'                   = cmpList nonDetCmpUnique+     (sortBy nonDetCmpUnique $ scopeUniques scope)+     (sortBy nonDetCmpUnique $ scopeUniques scope')++instance Outputable CmmTickScope where+  ppr GlobalScope     = text "global"+  ppr (SubScope us GlobalScope)+                      = ppr us+  ppr (SubScope us s) = ppr s <> char '/' <> ppr us+  ppr combined        = parens $ hcat $ punctuate (char '+') $+                        map (hcat . punctuate (char '/') . map ppr . reverse) $+                        scopeToPaths combined++-- | Checks whether two tick scopes are sub-scopes of each other. True+-- if the two scopes are equal.+isTickSubScope :: CmmTickScope -> CmmTickScope -> Bool+isTickSubScope = cmp+  where cmp _              GlobalScope             = True+        cmp GlobalScope    _                       = False+        cmp (CombinedScope s1 s2) s'               = cmp s1 s' && cmp s2 s'+        cmp s              (CombinedScope s1' s2') = cmp s s1' || cmp s s2'+        cmp (SubScope u s) s'@(SubScope u' _)      = u == u' || cmp s s'++-- | Combine two tick scopes. The new scope should be sub-scope of+-- both parameters. We simplfy automatically if one tick scope is a+-- sub-scope of the other already.+combineTickScopes :: CmmTickScope -> CmmTickScope -> CmmTickScope+combineTickScopes s1 s2+  | s1 `isTickSubScope` s2 = s1+  | s2 `isTickSubScope` s1 = s2+  | otherwise              = CombinedScope s1 s2
+ compiler/cmm/CmmOpt.hs view
@@ -0,0 +1,427 @@+-- The default iteration limit is a bit too low for the definitions+-- in this module.+{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}++-----------------------------------------------------------------------------+--+-- Cmm optimisation+--+-- (c) The University of Glasgow 2006+--+-----------------------------------------------------------------------------++module CmmOpt (+        constantFoldNode,+        constantFoldExpr,+        cmmMachOpFold,+        cmmMachOpFoldM+ ) where++import GhcPrelude++import CmmUtils+import Cmm+import DynFlags+import Util++import Outputable+import Platform++import Data.Bits+import Data.Maybe+++constantFoldNode :: DynFlags -> CmmNode e x -> CmmNode e x+constantFoldNode dflags = mapExp (constantFoldExpr dflags)++constantFoldExpr :: DynFlags -> CmmExpr -> CmmExpr+constantFoldExpr dflags = wrapRecExp f+  where f (CmmMachOp op args) = cmmMachOpFold dflags op args+        f (CmmRegOff r 0) = CmmReg r+        f e = e++-- -----------------------------------------------------------------------------+-- MachOp constant folder++-- Now, try to constant-fold the MachOps.  The arguments have already+-- been optimized and folded.++cmmMachOpFold+    :: DynFlags+    -> MachOp       -- The operation from an CmmMachOp+    -> [CmmExpr]    -- The optimized arguments+    -> CmmExpr++cmmMachOpFold dflags op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM dflags op args)++-- Returns Nothing if no changes, useful for Hoopl, also reduces+-- allocation!+cmmMachOpFoldM+    :: DynFlags+    -> MachOp+    -> [CmmExpr]+    -> Maybe CmmExpr++cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]+  = Just $ case op of+      MO_S_Neg _ -> CmmLit (CmmInt (-x) rep)+      MO_Not _   -> CmmLit (CmmInt (complement x) rep)++        -- these are interesting: we must first narrow to the+        -- "from" type, in order to truncate to the correct size.+        -- The final narrow/widen to the destination type+        -- is implicit in the CmmLit.+      MO_SF_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to)+      MO_SS_Conv  from to -> CmmLit (CmmInt (narrowS from x) to)+      MO_UU_Conv  from to -> CmmLit (CmmInt (narrowU from x) to)++      _ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op+++-- Eliminate conversion NOPs+cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x+cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x++-- Eliminate nested conversions where possible+cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]]+  | Just (rep1,rep2,signed1) <- isIntConversion conv_inner,+    Just (_,   rep3,signed2) <- isIntConversion conv_outer+  = case () of+        -- widen then narrow to the same size is a nop+      _ | rep1 < rep2 && rep1 == rep3 -> Just x+        -- Widen then narrow to different size: collapse to single conversion+        -- but remember to use the signedness from the widening, just in case+        -- the final conversion is a widen.+        | rep1 < rep2 && rep2 > rep3 ->+            Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]+        -- Nested widenings: collapse if the signedness is the same+        | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->+            Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]+        -- Nested narrowings: collapse+        | rep1 > rep2 && rep2 > rep3 ->+            Just $ cmmMachOpFold dflags (MO_UU_Conv rep1 rep3) [x]+        | otherwise ->+            Nothing+  where+        isIntConversion (MO_UU_Conv rep1 rep2)+          = Just (rep1,rep2,False)+        isIntConversion (MO_SS_Conv rep1 rep2)+          = Just (rep1,rep2,True)+        isIntConversion _ = Nothing++        intconv True  = MO_SS_Conv+        intconv False = MO_UU_Conv++-- ToDo: a narrow of a load can be collapsed into a narrow load, right?+-- but what if the architecture only supports word-sized loads, should+-- we do the transformation anyway?++cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]+  = case mop of+        -- for comparisons: don't forget to narrow the arguments before+        -- comparing, since they might be out of range.+        MO_Eq _   -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth dflags))+        MO_Ne _   -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth dflags))++        MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u >  y_u then 1 else 0) (wordWidth dflags))+        MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth dflags))+        MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u <  y_u then 1 else 0) (wordWidth dflags))+        MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth dflags))++        MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s >  y_s then 1 else 0) (wordWidth dflags))+        MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth dflags))+        MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s <  y_s then 1 else 0) (wordWidth dflags))+        MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth dflags))++        MO_Add r -> Just $ CmmLit (CmmInt (x + y) r)+        MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r)+        MO_Mul r -> Just $ CmmLit (CmmInt (x * y) r)+        MO_U_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `quot` y_u) r)+        MO_U_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `rem`  y_u) r)+        MO_S_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x `quot` y) r)+        MO_S_Rem  r | y /= 0 -> Just $ CmmLit (CmmInt (x `rem` y) r)++        MO_And   r -> Just $ CmmLit (CmmInt (x .&. y) r)+        MO_Or    r -> Just $ CmmLit (CmmInt (x .|. y) r)+        MO_Xor   r -> Just $ CmmLit (CmmInt (x `xor` y) r)++        MO_Shl   r -> Just $ CmmLit (CmmInt (x `shiftL` fromIntegral y) r)+        MO_U_Shr r -> Just $ CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)+        MO_S_Shr r -> Just $ CmmLit (CmmInt (x `shiftR` fromIntegral y) r)++        _          -> Nothing++   where+        x_u = narrowU xrep x+        y_u = narrowU xrep y+        x_s = narrowS xrep x+        y_s = narrowS xrep y+++-- When possible, shift the constants to the right-hand side, so that we+-- can match for strength reductions.  Note that the code generator will+-- also assume that constants have been shifted to the right when+-- possible.++cmmMachOpFoldM dflags op [x@(CmmLit _), y]+   | not (isLit y) && isCommutableMachOp op+   = Just (cmmMachOpFold dflags op [y, x])++-- Turn (a+b)+c into a+(b+c) where possible.  Because literals are+-- moved to the right, it is more likely that we will find+-- opportunities for constant folding when the expression is+-- right-associated.+--+-- ToDo: this appears to introduce a quadratic behaviour due to the+-- nested cmmMachOpFold.  Can we fix this?+--+-- Why do we check isLit arg1?  If arg1 is a lit, it means that arg2+-- is also a lit (otherwise arg1 would be on the right).  If we+-- put arg1 on the left of the rearranged expression, we'll get into a+-- loop:  (x1+x2)+x3 => x1+(x2+x3)  => (x2+x3)+x1 => x2+(x3+x1) ...+--+-- Also don't do it if arg1 is PicBaseReg, so that we don't separate the+-- PicBaseReg from the corresponding label (or label difference).+--+cmmMachOpFoldM dflags mop1 [CmmMachOp mop2 [arg1,arg2], arg3]+   | mop2 `associates_with` mop1+     && not (isLit arg1) && not (isPicReg arg1)+   = Just (cmmMachOpFold dflags mop2 [arg1, cmmMachOpFold dflags mop1 [arg2,arg3]])+   where+     MO_Add{} `associates_with` MO_Sub{} = True+     mop1 `associates_with` mop2 =+        mop1 == mop2 && isAssociativeMachOp mop1++-- special case: (a - b) + c  ==>  a + (c - b)+cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]+   | not (isLit arg1) && not (isPicReg arg1)+   = Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]])++-- special case: (PicBaseReg + lit) + N  ==>  PicBaseReg + (lit+N)+--+-- this is better because lit+N is a single link-time constant (e.g. a+-- CmmLabelOff), so the right-hand expression needs only one+-- instruction, whereas the left needs two.  This happens when pointer+-- tagging gives us label+offset, and PIC turns the label into+-- PicBaseReg + label.+--+cmmMachOpFoldM _ MO_Add{} [ CmmMachOp op@MO_Add{} [pic, CmmLit lit]+                          , CmmLit (CmmInt n rep) ]+  | isPicReg pic+  = Just $ CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ]+  where off = fromIntegral (narrowS rep n)++-- Make a RegOff if we can+cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]+  = Just $ cmmRegOff reg (fromIntegral (narrowS rep n))+cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]+  = Just $ cmmRegOff reg (off + fromIntegral (narrowS rep n))+cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]+  = Just $ cmmRegOff reg (- fromIntegral (narrowS rep n))+cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]+  = Just $ cmmRegOff reg (off - fromIntegral (narrowS rep n))++-- Fold label(+/-)offset into a CmmLit where possible++cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)]+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))+cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit]+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))+cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i))))+++-- Comparison of literal with widened operand: perform the comparison+-- at the smaller width, as long as the literal is within range.++-- We can't do the reverse trick, when the operand is narrowed:+-- narrowing throws away bits from the operand, there's no way to do+-- the same comparison at the larger size.++cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]+  |     -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try+    platformArch (targetPlatform dflags) `elem` [ArchX86, ArchX86_64],+        -- if the operand is widened:+    Just (rep, signed, narrow_fn) <- maybe_conversion conv,+        -- and this is a comparison operation:+    Just narrow_cmp <- maybe_comparison cmp rep signed,+        -- and the literal fits in the smaller size:+    i == narrow_fn rep i+        -- then we can do the comparison at the smaller size+  = Just (cmmMachOpFold dflags narrow_cmp [x, CmmLit (CmmInt i rep)])+ where+    maybe_conversion (MO_UU_Conv from to)+        | to > from+        = Just (from, False, narrowU)+    maybe_conversion (MO_SS_Conv from to)+        | to > from+        = Just (from, True, narrowS)++        -- don't attempt to apply this optimisation when the source+        -- is a float; see #1916+    maybe_conversion _ = Nothing++        -- careful (#2080): if the original comparison was signed, but+        -- we were doing an unsigned widen, then we must do an+        -- unsigned comparison at the smaller size.+    maybe_comparison (MO_U_Gt _) rep _     = Just (MO_U_Gt rep)+    maybe_comparison (MO_U_Ge _) rep _     = Just (MO_U_Ge rep)+    maybe_comparison (MO_U_Lt _) rep _     = Just (MO_U_Lt rep)+    maybe_comparison (MO_U_Le _) rep _     = Just (MO_U_Le rep)+    maybe_comparison (MO_Eq   _) rep _     = Just (MO_Eq   rep)+    maybe_comparison (MO_S_Gt _) rep True  = Just (MO_S_Gt rep)+    maybe_comparison (MO_S_Ge _) rep True  = Just (MO_S_Ge rep)+    maybe_comparison (MO_S_Lt _) rep True  = Just (MO_S_Lt rep)+    maybe_comparison (MO_S_Le _) rep True  = Just (MO_S_Le rep)+    maybe_comparison (MO_S_Gt _) rep False = Just (MO_U_Gt rep)+    maybe_comparison (MO_S_Ge _) rep False = Just (MO_U_Ge rep)+    maybe_comparison (MO_S_Lt _) rep False = Just (MO_U_Lt rep)+    maybe_comparison (MO_S_Le _) rep False = Just (MO_U_Le rep)+    maybe_comparison _ _ _ = Nothing++-- We can often do something with constants of 0 and 1 ...+-- See Note [Comparison operators]++cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))]+  = case mop of+        -- Arithmetic+        MO_Add   _ -> Just x   -- x + 0 = x+        MO_Sub   _ -> Just x   -- x - 0 = x+        MO_Mul   _ -> Just y   -- x * 0 = 0++        -- Logical operations+        MO_And   _ -> Just y   -- x &     0 = 0+        MO_Or    _ -> Just x   -- x |     0 = x+        MO_Xor   _ -> Just x   -- x `xor` 0 = x++        -- Shifts+        MO_Shl   _ -> Just x   -- x << 0 = x+        MO_S_Shr _ -> Just x   -- ditto shift-right+        MO_U_Shr _ -> Just x++        -- Comparisons; these ones are trickier+        -- See Note [Comparison operators]+        MO_Ne    _ | isComparisonExpr x -> Just x                -- (x > y) != 0  =  x > y+        MO_Eq    _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x > y) == 0  =  x <= y+        MO_U_Gt  _ | isComparisonExpr x -> Just x                -- (x > y) > 0   =  x > y+        MO_S_Gt  _ | isComparisonExpr x -> Just x                -- ditto+        MO_U_Lt  _ | isComparisonExpr x -> Just zero             -- (x > y) < 0  =  0+        MO_S_Lt  _ | isComparisonExpr x -> Just zero+        MO_U_Ge  _ | isComparisonExpr x -> Just one              -- (x > y) >= 0  =  1+        MO_S_Ge  _ | isComparisonExpr x -> Just one++        MO_U_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x > y) <= 0  =  x <= y+        MO_S_Le  _ | Just x' <- maybeInvertCmmExpr x -> Just x'+        _ -> Nothing+  where+    zero = CmmLit (CmmInt 0 (wordWidth dflags))+    one  = CmmLit (CmmInt 1 (wordWidth dflags))++cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))]+  = case mop of+        -- Arithmetic: x*1 = x, etc+        MO_Mul    _ -> Just x+        MO_S_Quot _ -> Just x+        MO_U_Quot _ -> Just x+        MO_S_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)+        MO_U_Rem  _ -> Just $ CmmLit (CmmInt 0 rep)++        -- Comparisons; trickier+        -- See Note [Comparison operators]+        MO_Ne    _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x>y) != 1  =  x<=y+        MO_Eq    _ | isComparisonExpr x -> Just x                -- (x>y) == 1  =  x>y+        MO_U_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- (x>y) < 1   =  x<=y+        MO_S_Lt  _ | Just x' <- maybeInvertCmmExpr x -> Just x'  -- ditto+        MO_U_Gt  _ | isComparisonExpr x -> Just zero             -- (x>y) > 1   = 0+        MO_S_Gt  _ | isComparisonExpr x -> Just zero+        MO_U_Le  _ | isComparisonExpr x -> Just one              -- (x>y) <= 1  = 1+        MO_S_Le  _ | isComparisonExpr x -> Just one+        MO_U_Ge  _ | isComparisonExpr x -> Just x                -- (x>y) >= 1  = x>y+        MO_S_Ge  _ | isComparisonExpr x -> Just x+        _ -> Nothing+  where+    zero = CmmLit (CmmInt 0 (wordWidth dflags))+    one  = CmmLit (CmmInt 1 (wordWidth dflags))++-- Now look for multiplication/division by powers of 2 (integers).++cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))]+  = case mop of+        MO_Mul rep+           | Just p <- exactLog2 n ->+                 Just (cmmMachOpFold dflags (MO_Shl rep) [x, CmmLit (CmmInt p rep)])+        MO_U_Quot rep+           | Just p <- exactLog2 n ->+                 Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])+        MO_U_Rem rep+           | Just _ <- exactLog2 n ->+                 Just (cmmMachOpFold dflags (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])+        MO_S_Quot rep+           | Just p <- exactLog2 n,+             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require+                                -- it is a reg.  FIXME: remove this restriction.+                Just (cmmMachOpFold dflags (MO_S_Shr rep)+                  [signedQuotRemHelper rep p, CmmLit (CmmInt p rep)])+        MO_S_Rem rep+           | Just p <- exactLog2 n,+             CmmReg _ <- x ->   -- We duplicate x in signedQuotRemHelper, hence require+                                -- it is a reg.  FIXME: remove this restriction.+                -- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).+                -- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)+                -- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.+                Just (cmmMachOpFold dflags (MO_Sub rep)+                    [x, cmmMachOpFold dflags (MO_And rep)+                      [signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])+        _ -> Nothing+  where+    -- In contrast with unsigned integers, for signed ones+    -- shift right is not the same as quot, because it rounds+    -- to minus infinity, whereas quot rounds toward zero.+    -- To fix this up, we add one less than the divisor to the+    -- dividend if it is a negative number.+    --+    -- to avoid a test/jump, we use the following sequence:+    --      x1 = x >> word_size-1  (all 1s if -ve, all 0s if +ve)+    --      x2 = y & (divisor-1)+    --      result = x + x2+    -- this could be done a bit more simply using conditional moves,+    -- but we're processor independent here.+    --+    -- we optimise the divide by 2 case slightly, generating+    --      x1 = x >> word_size-1  (unsigned)+    --      return = x + x1+    signedQuotRemHelper :: Width -> Integer -> CmmExpr+    signedQuotRemHelper rep p = CmmMachOp (MO_Add rep) [x, x2]+      where+        bits = fromIntegral (widthInBits rep) - 1+        shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep+        x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)]+        x2 = if p == 1 then x1 else+             CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)]++-- ToDo (#7116): optimise floating-point multiplication, e.g. x*2.0 -> x+x+-- Unfortunately this needs a unique supply because x might not be a+-- register.  See #2253 (program 6) for an example.+++-- Anything else is just too hard.++cmmMachOpFoldM _ _ _ = Nothing++{- Note [Comparison operators]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+   CmmCondBranch ((x>#y) == 1) t f+we really want to convert to+   CmmCondBranch (x>#y) t f++That's what the constant-folding operations on comparison operators do above.+-}+++-- -----------------------------------------------------------------------------+-- Utils++isPicReg :: CmmExpr -> Bool+isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True+isPicReg _ = False
+ compiler/cmm/CmmParse.y view
@@ -0,0 +1,1439 @@+-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2004-2012+--+-- Parser for concrete Cmm.+--+-----------------------------------------------------------------------------++{- -----------------------------------------------------------------------------+Note [Syntax of .cmm files]++NOTE: You are very much on your own in .cmm.  There is very little+error checking at all:++  * Type errors are detected by the (optional) -dcmm-lint pass, if you+    don't turn this on then a type error will likely result in a panic+    from the native code generator.++  * Passing the wrong number of arguments or arguments of the wrong+    type is not detected.++There are two ways to write .cmm code:++ (1) High-level Cmm code delegates the stack handling to GHC, and+     never explicitly mentions Sp or registers.++ (2) Low-level Cmm manages the stack itself, and must know about+     calling conventions.++Whether you want high-level or low-level Cmm is indicated by the+presence of an argument list on a procedure.  For example:++foo ( gcptr a, bits32 b )+{+  // this is high-level cmm code++  if (b > 0) {+     // we can make tail calls passing arguments:+     jump stg_ap_0_fast(a);+  }++  push (stg_upd_frame_info, a) {+    // stack frames can be explicitly pushed++    (x,y) = call wibble(a,b,3,4);+      // calls pass arguments and return results using the native+      // Haskell calling convention.  The code generator will automatically+      // construct a stack frame and an info table for the continuation.++    return (x,y);+      // we can return multiple values from the current proc+  }+}++bar+{+  // this is low-level cmm code, indicated by the fact that we did not+  // put an argument list on bar.++  x = R1;  // the calling convention is explicit: better be careful+           // that this works on all platforms!++  jump %ENTRY_CODE(Sp(0))+}++Here is a list of rules for high-level and low-level code.  If you+break the rules, you get a panic (for using a high-level construct in+a low-level proc), or wrong code (when using low-level code in a+high-level proc).  This stuff isn't checked! (TODO!)++High-level only:++  - tail-calls with arguments, e.g.+    jump stg_fun (arg1, arg2);++  - function calls:+    (ret1,ret2) = call stg_fun (arg1, arg2);++    This makes a call with the NativeNodeCall convention, and the+    values are returned to the following code using the NativeReturn+    convention.++  - returning:+    return (ret1, ret2)++    These use the NativeReturn convention to return zero or more+    results to the caller.++  - pushing stack frames:+    push (info_ptr, field1, ..., fieldN) { ... statements ... }++  - reserving temporary stack space:++      reserve N = x { ... }++    this reserves an area of size N (words) on the top of the stack,+    and binds its address to x (a local register).  Typically this is+    used for allocating temporary storage for passing to foreign+    functions.++    Note that if you make any native calls or invoke the GC in the+    scope of the reserve block, you are responsible for ensuring that+    the stack you reserved is laid out correctly with an info table.++Low-level only:++  - References to Sp, R1-R8, F1-F4 etc.++    NB. foreign calls may clobber the argument registers R1-R8, F1-F4+    etc., so ensure they are saved into variables around foreign+    calls.++  - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp+    directly.++Both high-level and low-level code can use a raw tail-call:++    jump stg_fun [R1,R2]++NB. you *must* specify the list of GlobalRegs that are passed via a+jump, otherwise the register allocator will assume that all the+GlobalRegs are dead at the jump.+++Calling Conventions+-------------------++High-level procedures use the NativeNode calling convention, or the+NativeReturn convention if the 'return' keyword is used (see Stack+Frames below).++Low-level procedures implement their own calling convention, so it can+be anything at all.++If a low-level procedure implements the NativeNode calling convention,+then it can be called by high-level code using an ordinary function+call.  In general this is hard to arrange because the calling+convention depends on the number of physical registers available for+parameter passing, but there are two cases where the calling+convention is platform-independent:++ - Zero arguments.++ - One argument of pointer or non-pointer word type; this is always+   passed in R1 according to the NativeNode convention.++ - Returning a single value; these conventions are fixed and platform+   independent.+++Stack Frames+------------++A stack frame is written like this:++INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN )+               return ( arg1, ..., argM )+{+  ... code ...+}++where field1 ... fieldN are the fields of the stack frame (with types)+arg1...argN are the values returned to the stack frame (with types).+The return values are assumed to be passed according to the+NativeReturn convention.++On entry to the code, the stack frame looks like:++   |----------|+   | fieldN   |+   |   ...    |+   | field1   |+   |----------|+   | info_ptr |+   |----------|+   |  argN    |+   |   ...    | <- Sp++and some of the args may be in registers.++We prepend the code by a copyIn of the args, and assign all the stack+frame fields to their formals.  The initial "arg offset" for stack+layout purposes consists of the whole stack frame plus any args that+might be on the stack.++A tail-call may pass a stack frame to the callee using the following+syntax:++jump f (info_ptr, field1,..,fieldN) (arg1,..,argN)++where info_ptr and field1..fieldN describe the stack frame, and+arg1..argN are the arguments passed to f using the NativeNodeCall+convention. Note if a field is longer than a word (e.g. a D_ on+a 32-bit machine) then the call will push as many words as+necessary to the stack to accommodate it (e.g. 2).+++----------------------------------------------------------------------------- -}++{+module CmmParse ( parseCmmFile ) where++import GhcPrelude++import StgCmmExtCode+import CmmCallConv+import StgCmmProf+import StgCmmHeap+import StgCmmMonad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit, emitStore+                          , emitAssign, emitOutOfLine, withUpdFrameOff+                          , getUpdFrameOff )+import qualified StgCmmMonad as F+import StgCmmUtils+import StgCmmForeign+import StgCmmExpr+import StgCmmClosure+import StgCmmLayout     hiding (ArgRep(..))+import StgCmmTicky+import StgCmmBind       ( emitBlackHoleCode, emitUpdateFrame )+import CoreSyn          ( Tickish(SourceNote) )++import CmmOpt+import MkGraph+import Cmm+import CmmUtils+import CmmSwitch        ( mkSwitchTargets )+import CmmInfo+import BlockId+import CmmLex+import CLabel+import SMRep+import Lexer+import CmmMonad++import CostCentre+import ForeignCall+import Module+import Platform+import Literal+import Unique+import UniqFM+import SrcLoc+import DynFlags+import ErrUtils+import StringBuffer+import FastString+import Panic+import Constants+import Outputable+import BasicTypes+import Bag              ( emptyBag, unitBag )+import Var++import Control.Monad+import Data.Array+import Data.Char        ( ord )+import System.Exit+import Data.Maybe+import qualified Data.Map as M+import qualified Data.ByteString.Char8 as BS8++#include "HsVersions.h"+}++%expect 0++%token+        ':'     { L _ (CmmT_SpecChar ':') }+        ';'     { L _ (CmmT_SpecChar ';') }+        '{'     { L _ (CmmT_SpecChar '{') }+        '}'     { L _ (CmmT_SpecChar '}') }+        '['     { L _ (CmmT_SpecChar '[') }+        ']'     { L _ (CmmT_SpecChar ']') }+        '('     { L _ (CmmT_SpecChar '(') }+        ')'     { L _ (CmmT_SpecChar ')') }+        '='     { L _ (CmmT_SpecChar '=') }+        '`'     { L _ (CmmT_SpecChar '`') }+        '~'     { L _ (CmmT_SpecChar '~') }+        '/'     { L _ (CmmT_SpecChar '/') }+        '*'     { L _ (CmmT_SpecChar '*') }+        '%'     { L _ (CmmT_SpecChar '%') }+        '-'     { L _ (CmmT_SpecChar '-') }+        '+'     { L _ (CmmT_SpecChar '+') }+        '&'     { L _ (CmmT_SpecChar '&') }+        '^'     { L _ (CmmT_SpecChar '^') }+        '|'     { L _ (CmmT_SpecChar '|') }+        '>'     { L _ (CmmT_SpecChar '>') }+        '<'     { L _ (CmmT_SpecChar '<') }+        ','     { L _ (CmmT_SpecChar ',') }+        '!'     { L _ (CmmT_SpecChar '!') }++        '..'    { L _ (CmmT_DotDot) }+        '::'    { L _ (CmmT_DoubleColon) }+        '>>'    { L _ (CmmT_Shr) }+        '<<'    { L _ (CmmT_Shl) }+        '>='    { L _ (CmmT_Ge) }+        '<='    { L _ (CmmT_Le) }+        '=='    { L _ (CmmT_Eq) }+        '!='    { L _ (CmmT_Ne) }+        '&&'    { L _ (CmmT_BoolAnd) }+        '||'    { L _ (CmmT_BoolOr) }++        'True'  { L _ (CmmT_True ) }+        'False' { L _ (CmmT_False) }+        'likely'{ L _ (CmmT_likely)}++        'CLOSURE'       { L _ (CmmT_CLOSURE) }+        'INFO_TABLE'    { L _ (CmmT_INFO_TABLE) }+        'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }+        'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }+        'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }+        'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }+        'else'          { L _ (CmmT_else) }+        'export'        { L _ (CmmT_export) }+        'section'       { L _ (CmmT_section) }+        'goto'          { L _ (CmmT_goto) }+        'if'            { L _ (CmmT_if) }+        'call'          { L _ (CmmT_call) }+        'jump'          { L _ (CmmT_jump) }+        'foreign'       { L _ (CmmT_foreign) }+        'never'         { L _ (CmmT_never) }+        'prim'          { L _ (CmmT_prim) }+        'reserve'       { L _ (CmmT_reserve) }+        'return'        { L _ (CmmT_return) }+        'returns'       { L _ (CmmT_returns) }+        'import'        { L _ (CmmT_import) }+        'switch'        { L _ (CmmT_switch) }+        'case'          { L _ (CmmT_case) }+        'default'       { L _ (CmmT_default) }+        'push'          { L _ (CmmT_push) }+        'unwind'        { L _ (CmmT_unwind) }+        'bits8'         { L _ (CmmT_bits8) }+        'bits16'        { L _ (CmmT_bits16) }+        'bits32'        { L _ (CmmT_bits32) }+        'bits64'        { L _ (CmmT_bits64) }+        'bits128'       { L _ (CmmT_bits128) }+        'bits256'       { L _ (CmmT_bits256) }+        'bits512'       { L _ (CmmT_bits512) }+        'float32'       { L _ (CmmT_float32) }+        'float64'       { L _ (CmmT_float64) }+        'gcptr'         { L _ (CmmT_gcptr) }++        GLOBALREG       { L _ (CmmT_GlobalReg   $$) }+        NAME            { L _ (CmmT_Name        $$) }+        STRING          { L _ (CmmT_String      $$) }+        INT             { L _ (CmmT_Int         $$) }+        FLOAT           { L _ (CmmT_Float       $$) }++%monad { PD } { >>= } { return }+%lexer { cmmlex } { L _ CmmT_EOF }+%name cmmParse cmm+%tokentype { Located CmmToken }++-- C-- operator precedences, taken from the C-- spec+%right '||'     -- non-std extension, called %disjoin in C--+%right '&&'     -- non-std extension, called %conjoin in C--+%right '!'+%nonassoc '>=' '>' '<=' '<' '!=' '=='+%left '|'+%left '^'+%left '&'+%left '>>' '<<'+%left '-' '+'+%left '/' '*' '%'+%right '~'++%%++cmm     :: { CmmParse () }+        : {- empty -}                   { return () }+        | cmmtop cmm                    { do $1; $2 }++cmmtop  :: { CmmParse () }+        : cmmproc                       { $1 }+        | cmmdata                       { $1 }+        | decl                          { $1 } +        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'  +                {% liftP . withThisPackage $ \pkg ->+                   do lits <- sequence $6;+                      staticClosure pkg $3 $5 (map getLit lits) }++-- The only static closures in the RTS are dummy closures like+-- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need+-- to provide the full generality of static closures here.+-- In particular:+--      * CCS can always be CCS_DONT_CARE+--      * closure is always extern+--      * payload is always empty+--      * we can derive closure and info table labels from a single NAME++cmmdata :: { CmmParse () }+        : 'section' STRING '{' data_label statics '}' +                { do lbl <- $4;+                     ss <- sequence $5;+                     code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) }++data_label :: { CmmParse CLabel }+    : NAME ':'  +                {% liftP . withThisPackage $ \pkg ->+                   return (mkCmmDataLabel pkg $1) }++statics :: { [CmmParse [CmmStatic]] }+        : {- empty -}                   { [] }+        | static statics                { $1 : $2 }+    +static  :: { CmmParse [CmmStatic] }+        : type expr ';' { do e <- $2;+                             return [CmmStaticLit (getLit e)] }+        | type ';'                      { return [CmmUninitialised+                                                        (widthInBytes (typeWidth $1))] }+        | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }+        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised +                                                        (fromIntegral $3)] }+        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised +                                                (widthInBytes (typeWidth $1) * +                                                        fromIntegral $3)] }+        | 'CLOSURE' '(' NAME lits ')'+                { do { lits <- sequence $4+                ; dflags <- getDynFlags+                     ; return $ map CmmStaticLit $+                        mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)+                         -- mkForeignLabel because these are only used+                         -- for CHARLIKE and INTLIKE closures in the RTS.+                        dontCareCCS (map getLit lits) [] [] [] } }+        -- arrays of closures required for the CHARLIKE & INTLIKE arrays++lits    :: { [CmmParse CmmExpr] }+        : {- empty -}           { [] }+        | ',' expr lits         { $2 : $3 }++cmmproc :: { CmmParse () }+        : info maybe_conv maybe_formals maybe_body+                { do ((entry_ret_label, info, stk_formals, formals), agraph) <-+                       getCodeScoped $ loopDecls $ do {+                         (entry_ret_label, info, stk_formals) <- $1;+                         dflags <- getDynFlags;+                         formals <- sequence (fromMaybe [] $3);+                         withName (showSDoc dflags (ppr entry_ret_label))+                           $4;+                         return (entry_ret_label, info, stk_formals, formals) }+                     let do_layout = isJust $3+                     code (emitProcWithStackFrame $2 info+                                entry_ret_label stk_formals formals agraph+                                do_layout ) }++maybe_conv :: { Convention }+           : {- empty -}        { NativeNodeCall }+           | 'return'           { NativeReturn }++maybe_body :: { CmmParse () }+           : ';'                { return () }+           | '{' body '}'       { withSourceNote $1 $3 $2 }++info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }+        : NAME+                {% liftP . withThisPackage $ \pkg ->+                   do   newFunctionName $1 pkg+                        return (mkCmmCodeLabel pkg $1, Nothing, []) }+++        | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'+                -- ptrs, nptrs, closure type, description, type+                {% liftP . withThisPackage $ \pkg ->+                   do dflags <- getDynFlags+                      let prof = profilingInfo dflags $11 $13+                          rep  = mkRTSRep (fromIntegral $9) $+                                   mkHeapRep dflags False (fromIntegral $5)+                                                   (fromIntegral $7) Thunk+                              -- not really Thunk, but that makes the info table+                              -- we want.+                      return (mkCmmEntryLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                              []) }+        +        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'+                -- ptrs, nptrs, closure type, description, type, fun type+                {% liftP . withThisPackage $ \pkg ->+                   do dflags <- getDynFlags+                      let prof = profilingInfo dflags $11 $13+                          ty   = Fun 0 (ArgSpec (fromIntegral $15))+                                -- Arity zero, arg_type $15+                          rep = mkRTSRep (fromIntegral $9) $+                                    mkHeapRep dflags False (fromIntegral $5)+                                                    (fromIntegral $7) ty+                      return (mkCmmEntryLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                              []) }+                -- we leave most of the fields zero here.  This is only used+                -- to generate the BCO info table in the RTS at the moment.++        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'+                -- ptrs, nptrs, tag, closure type, description, type+                {% liftP . withThisPackage $ \pkg ->+                   do dflags <- getDynFlags+                      let prof = profilingInfo dflags $13 $15+                          ty  = Constr (fromIntegral $9)  -- Tag+                                       (BS8.pack $13)+                          rep = mkRTSRep (fromIntegral $11) $+                                  mkHeapRep dflags False (fromIntegral $5)+                                                  (fromIntegral $7) ty+                      return (mkCmmEntryLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },+                              []) }++                     -- If profiling is on, this string gets duplicated,+                     -- but that's the way the old code did it we can fix it some other time.+        +        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'+                -- selector, closure type, description, type+                {% liftP . withThisPackage $ \pkg ->+                   do dflags <- getDynFlags+                      let prof = profilingInfo dflags $9 $11+                          ty  = ThunkSelector (fromIntegral $5)+                          rep = mkRTSRep (fromIntegral $7) $+                                   mkHeapRep dflags False 0 0 ty+                      return (mkCmmEntryLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                              []) }++        | 'INFO_TABLE_RET' '(' NAME ',' INT ')'+                -- closure type (no live regs)+                {% liftP . withThisPackage $ \pkg ->+                   do let prof = NoProfilingInfo+                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []+                      return (mkCmmRetLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                              []) }++        | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'+                -- closure type, live regs+                {% liftP . withThisPackage $ \pkg ->+                   do dflags <- getDynFlags+                      live <- sequence $7+                      let prof = NoProfilingInfo+                          -- drop one for the info pointer+                          bitmap = mkLiveness dflags (drop 1 live)+                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap+                      return (mkCmmRetLabel pkg $3,+                              Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3+                                           , cit_rep = rep+                                           , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },+                              live) }++body    :: { CmmParse () }+        : {- empty -}                   { return () }+        | decl body                     { do $1; $2 }+        | stmt body                     { do $1; $2 }++decl    :: { CmmParse () }+        : type names ';'                { mapM_ (newLocal $1) $2 }+        | 'import' importNames ';'      { mapM_ newImport $2 }+        | 'export' names ';'            { return () }  -- ignore exports+++-- an imported function name, with optional packageId+importNames+        :: { [(FastString, CLabel)] }+        : importName                    { [$1] }+        | importName ',' importNames    { $1 : $3 }++importName+        :: { (FastString,  CLabel) }++        -- A label imported without an explicit packageId.+        --      These are taken to come frome some foreign, unnamed package.+        : NAME  +        { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }++        -- as previous 'NAME', but 'IsData'+        | 'CLOSURE' NAME+        { ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }++        -- A label imported with an explicit packageId.+        | STRING NAME+        { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) }+        +        +names   :: { [FastString] }+        : NAME                          { [$1] }+        | NAME ',' names                { $1 : $3 }++stmt    :: { CmmParse () }+        : ';'                                   { return () }++        | NAME ':'+                { do l <- newLabel $1; emitLabel l }++++        | lreg '=' expr ';'+                { do reg <- $1; e <- $3; withSourceNote $2 $4 (emitAssign reg e) }+        | type '[' expr ']' '=' expr ';'+                { withSourceNote $2 $7 (doStore $1 $3 $6) }++        -- Gah! We really want to say "foreign_results" but that causes+        -- a shift/reduce conflict with assignment.  We either+        -- we expand out the no-result and single result cases or+        -- we tweak the syntax to avoid the conflict.  The later+        -- option is taken here because the other way would require+        -- multiple levels of expanding and get unwieldy.+        | foreign_results 'foreign' STRING foreignLabel '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'+                {% foreignCall $3 $1 $4 $6 $8 $9 }+        | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'+                {% primCall $1 $4 $6 }+        -- stmt-level macros, stealing syntax from ordinary C-- function calls.+        -- Perhaps we ought to use the %%-form?+        | NAME '(' exprs0 ')' ';'+                {% stmtMacro $1 $3  }+        | 'switch' maybe_range expr '{' arms default '}'+                { do as <- sequence $5; doSwitch $2 $3 as $6 }+        | 'goto' NAME ';'+                { do l <- lookupLabel $2; emit (mkBranch l) }+        | 'return' '(' exprs0 ')' ';'+                { doReturn $3 }+        | 'jump' expr vols ';'+                { doRawJump $2 $3 }+        | 'jump' expr '(' exprs0 ')' ';'+                { doJumpWithStack $2 [] $4 }+        | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';'+                { doJumpWithStack $2 $4 $7 }+        | 'call' expr '(' exprs0 ')' ';'+                { doCall $2 [] $4 }+        | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'+                { doCall $6 $2 $8 }+        | 'if' bool_expr cond_likely 'goto' NAME+                { do l <- lookupLabel $5; cmmRawIf $2 l $3 }+        | 'if' bool_expr cond_likely '{' body '}' else+                { cmmIfThenElse $2 (withSourceNote $4 $6 $5) $7 $3 }+        | 'push' '(' exprs0 ')' maybe_body+                { pushStackFrame $3 $5 }+        | 'reserve' expr '=' lreg maybe_body+                { reserveStackFrame $2 $4 $5 }+        | 'unwind' unwind_regs ';'+                { $2 >>= code . emitUnwind }++unwind_regs+        :: { CmmParse [(GlobalReg, Maybe CmmExpr)] }+        : GLOBALREG '=' expr_or_unknown ',' unwind_regs+                { do e <- $3; rest <- $5; return (($1, e) : rest) }+        | GLOBALREG '=' expr_or_unknown+                { do e <- $3; return [($1, e)] }++-- | Used by unwind to indicate unknown unwinding values.+expr_or_unknown+        :: { CmmParse (Maybe CmmExpr) }+        : 'return'+                { do return Nothing }+        | expr+                { do e <- $1; return (Just e) }++foreignLabel     :: { CmmParse CmmExpr }+        : NAME                          { return (CmmLit (CmmLabel (mkForeignLabel $1 Nothing ForeignLabelInThisPackage IsFunction))) }++opt_never_returns :: { CmmReturnInfo }+        :                               { CmmMayReturn }+        | 'never' 'returns'             { CmmNeverReturns }++bool_expr :: { CmmParse BoolExpr }+        : bool_op                       { $1 }+        | expr                          { do e <- $1; return (BoolTest e) }++bool_op :: { CmmParse BoolExpr }+        : bool_expr '&&' bool_expr      { do e1 <- $1; e2 <- $3; +                                          return (BoolAnd e1 e2) }+        | bool_expr '||' bool_expr      { do e1 <- $1; e2 <- $3; +                                          return (BoolOr e1 e2)  }+        | '!' bool_expr                 { do e <- $2; return (BoolNot e) }+        | '(' bool_op ')'               { $2 }++safety  :: { Safety }+        : {- empty -}                   { PlayRisky }+        | STRING                        {% parseSafety $1 }++vols    :: { [GlobalReg] }+        : '[' ']'                       { [] }+        | '[' '*' ']'                   {% do df <- getDynFlags+                                         ; return (realArgRegsCover df) }+                                           -- All of them. See comment attached+                                           -- to realArgRegsCover+        | '[' globals ']'               { $2 }++globals :: { [GlobalReg] }+        : GLOBALREG                     { [$1] }+        | GLOBALREG ',' globals         { $1 : $3 }++maybe_range :: { Maybe (Integer,Integer) }+        : '[' INT '..' INT ']'  { Just ($2, $4) }+        | {- empty -}           { Nothing }++arms    :: { [CmmParse ([Integer],Either BlockId (CmmParse ()))] }+        : {- empty -}                   { [] }+        | arm arms                      { $1 : $2 }++arm     :: { CmmParse ([Integer],Either BlockId (CmmParse ())) }+        : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }++arm_body :: { CmmParse (Either BlockId (CmmParse ())) }+        : '{' body '}'                  { return (Right (withSourceNote $1 $3 $2)) }+        | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }++ints    :: { [Integer] }+        : INT                           { [ $1 ] }+        | INT ',' ints                  { $1 : $3 }++default :: { Maybe (CmmParse ()) }+        : 'default' ':' '{' body '}'    { Just (withSourceNote $3 $5 $4) }+        -- taking a few liberties with the C-- syntax here; C-- doesn't have+        -- 'default' branches+        | {- empty -}                   { Nothing }++-- Note: OldCmm doesn't support a first class 'else' statement, though+-- CmmNode does.+else    :: { CmmParse () }+        : {- empty -}                   { return () }+        | 'else' '{' body '}'           { withSourceNote $2 $4 $3 }++cond_likely :: { Maybe Bool }+        : '(' 'likely' ':' 'True'  ')'  { Just True  }+        | '(' 'likely' ':' 'False' ')'  { Just False }+        | {- empty -}                   { Nothing }+++-- we have to write this out longhand so that Happy's precedence rules+-- can kick in.+expr    :: { CmmParse CmmExpr }+        : expr '/' expr                 { mkMachOp MO_U_Quot [$1,$3] }+        | expr '*' expr                 { mkMachOp MO_Mul [$1,$3] }+        | expr '%' expr                 { mkMachOp MO_U_Rem [$1,$3] }+        | expr '-' expr                 { mkMachOp MO_Sub [$1,$3] }+        | expr '+' expr                 { mkMachOp MO_Add [$1,$3] }+        | expr '>>' expr                { mkMachOp MO_U_Shr [$1,$3] }+        | expr '<<' expr                { mkMachOp MO_Shl [$1,$3] }+        | expr '&' expr                 { mkMachOp MO_And [$1,$3] }+        | expr '^' expr                 { mkMachOp MO_Xor [$1,$3] }+        | expr '|' expr                 { mkMachOp MO_Or [$1,$3] }+        | expr '>=' expr                { mkMachOp MO_U_Ge [$1,$3] }+        | expr '>' expr                 { mkMachOp MO_U_Gt [$1,$3] }+        | expr '<=' expr                { mkMachOp MO_U_Le [$1,$3] }+        | expr '<' expr                 { mkMachOp MO_U_Lt [$1,$3] }+        | expr '!=' expr                { mkMachOp MO_Ne [$1,$3] }+        | expr '==' expr                { mkMachOp MO_Eq [$1,$3] }+        | '~' expr                      { mkMachOp MO_Not [$2] }+        | '-' expr                      { mkMachOp MO_S_Neg [$2] }+        | expr0 '`' NAME '`' expr0      {% do { mo <- nameToMachOp $3 ;+                                                return (mkMachOp mo [$1,$5]) } }+        | expr0                         { $1 }++expr0   :: { CmmParse CmmExpr }+        : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }+        | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }+        | STRING                 { do s <- code (newStringCLit $1); +                                      return (CmmLit s) }+        | reg                    { $1 }+        | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }+        | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }+        | '(' expr ')'           { $2 }+++-- leaving out the type of a literal gives you the native word size in C--+maybe_ty :: { CmmType }+        : {- empty -}                   {% do dflags <- getDynFlags; return $ bWord dflags }+        | '::' type                     { $2 }++cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }+        : {- empty -}                   { [] }+        | cmm_hint_exprs                { $1 }++cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }+        : cmm_hint_expr                 { [$1] }+        | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }++cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }+        : expr                          { do e <- $1;+                                             return (e, inferCmmHint e) }+        | expr STRING                   {% do h <- parseCmmHint $2;+                                              return $ do+                                                e <- $1; return (e, h) }++exprs0  :: { [CmmParse CmmExpr] }+        : {- empty -}                   { [] }+        | exprs                         { $1 }++exprs   :: { [CmmParse CmmExpr] }+        : expr                          { [ $1 ] }+        | expr ',' exprs                { $1 : $3 }++reg     :: { CmmParse CmmExpr }+        : NAME                  { lookupName $1 }+        | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }++foreign_results :: { [CmmParse (LocalReg, ForeignHint)] }+        : {- empty -}                   { [] }+        | '(' foreign_formals ')' '='   { $2 }++foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }+        : foreign_formal                        { [$1] }+        | foreign_formal ','                    { [$1] }+        | foreign_formal ',' foreign_formals    { $1 : $3 }++foreign_formal :: { CmmParse (LocalReg, ForeignHint) }+        : local_lreg            { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) }+        | STRING local_lreg     {% do h <- parseCmmHint $1;+                                      return $ do+                                         e <- $2; return (e,h) }++local_lreg :: { CmmParse LocalReg }+        : NAME                  { do e <- lookupName $1;+                                     return $+                                       case e of +                                        CmmReg (CmmLocal r) -> r+                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }++lreg    :: { CmmParse CmmReg }+        : NAME                  { do e <- lookupName $1;+                                     return $+                                       case e of +                                        CmmReg r -> r+                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }+        | GLOBALREG             { return (CmmGlobal $1) }++maybe_formals :: { Maybe [CmmParse LocalReg] }+        : {- empty -}           { Nothing }+        | '(' formals0 ')'      { Just $2 }++formals0 :: { [CmmParse LocalReg] }+        : {- empty -}           { [] }+        | formals               { $1 }++formals :: { [CmmParse LocalReg] }+        : formal ','            { [$1] }+        | formal                { [$1] }+        | formal ',' formals       { $1 : $3 }++formal :: { CmmParse LocalReg }+        : type NAME             { newLocal $1 $2 }++type    :: { CmmType }+        : 'bits8'               { b8 }+        | typenot8              { $1 }++typenot8 :: { CmmType }+        : 'bits16'              { b16 }+        | 'bits32'              { b32 }+        | 'bits64'              { b64 }+        | 'bits128'             { b128 }+        | 'bits256'             { b256 }+        | 'bits512'             { b512 }+        | 'float32'             { f32 }+        | 'float64'             { f64 }+        | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }++{+section :: String -> SectionType+section "text"      = Text+section "data"      = Data+section "rodata"    = ReadOnlyData+section "relrodata" = RelocatableReadOnlyData+section "bss"       = UninitialisedData+section s           = OtherSection s++mkString :: String -> CmmStatic+mkString s = CmmString (BS8.pack s)++-- |+-- Given an info table, decide what the entry convention for the proc+-- is.  That is, for an INFO_TABLE_RET we want the return convention,+-- otherwise it is a NativeNodeCall.+--+infoConv :: Maybe CmmInfoTable -> Convention+infoConv Nothing = NativeNodeCall+infoConv (Just info)+  | isStackRep (cit_rep info) = NativeReturn+  | otherwise                 = NativeNodeCall++-- mkMachOp infers the type of the MachOp from the type of its first+-- argument.  We assume that this is correct: for MachOps that don't have+-- symmetrical args (e.g. shift ops), the first arg determines the type of+-- the op.+mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr+mkMachOp fn args = do+  dflags <- getDynFlags+  arg_exprs <- sequence args+  return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)++getLit :: CmmExpr -> CmmLit+getLit (CmmLit l) = l+getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r+getLit _ = panic "invalid literal" -- TODO messy failure++nameToMachOp :: FastString -> PD (Width -> MachOp)+nameToMachOp name =+  case lookupUFM machOps name of+        Nothing -> fail ("unknown primitive " ++ unpackFS name)+        Just m  -> return m++exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)+exprOp name args_code = do+  dflags <- getDynFlags+  case lookupUFM (exprMacros dflags) name of+     Just f  -> return $ do+        args <- sequence args_code+        return (f args)+     Nothing -> do+        mo <- nameToMachOp name+        return $ mkMachOp mo args_code++exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)+exprMacros dflags = listToUFM [+  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode dflags x ),+  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr dflags x ),+  ( fsLit "STD_INFO",     \ [x] -> infoTable dflags x ),+  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable dflags x ),+  ( fsLit "GET_ENTRY",    \ [x] -> entryCode dflags (closureInfoPtr dflags x) ),+  ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),+  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),+  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType dflags x ),+  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs dflags x ),+  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs dflags x )+  ]++-- we understand a subset of C-- primitives:+machOps = listToUFM $+        map (\(x, y) -> (mkFastString x, y)) [+        ( "add",        MO_Add ),+        ( "sub",        MO_Sub ),+        ( "eq",         MO_Eq ),+        ( "ne",         MO_Ne ),+        ( "mul",        MO_Mul ),+        ( "neg",        MO_S_Neg ),+        ( "quot",       MO_S_Quot ),+        ( "rem",        MO_S_Rem ),+        ( "divu",       MO_U_Quot ),+        ( "modu",       MO_U_Rem ),++        ( "ge",         MO_S_Ge ),+        ( "le",         MO_S_Le ),+        ( "gt",         MO_S_Gt ),+        ( "lt",         MO_S_Lt ),++        ( "geu",        MO_U_Ge ),+        ( "leu",        MO_U_Le ),+        ( "gtu",        MO_U_Gt ),+        ( "ltu",        MO_U_Lt ),++        ( "and",        MO_And ),+        ( "or",         MO_Or ),+        ( "xor",        MO_Xor ),+        ( "com",        MO_Not ),+        ( "shl",        MO_Shl ),+        ( "shrl",       MO_U_Shr ),+        ( "shra",       MO_S_Shr ),++        ( "fadd",       MO_F_Add ),+        ( "fsub",       MO_F_Sub ),+        ( "fneg",       MO_F_Neg ),+        ( "fmul",       MO_F_Mul ),+        ( "fquot",      MO_F_Quot ),++        ( "feq",        MO_F_Eq ),+        ( "fne",        MO_F_Ne ),+        ( "fge",        MO_F_Ge ),+        ( "fle",        MO_F_Le ),+        ( "fgt",        MO_F_Gt ),+        ( "flt",        MO_F_Lt ),++        ( "lobits8",  flip MO_UU_Conv W8  ),+        ( "lobits16", flip MO_UU_Conv W16 ),+        ( "lobits32", flip MO_UU_Conv W32 ),+        ( "lobits64", flip MO_UU_Conv W64 ),++        ( "zx16",     flip MO_UU_Conv W16 ),+        ( "zx32",     flip MO_UU_Conv W32 ),+        ( "zx64",     flip MO_UU_Conv W64 ),++        ( "sx16",     flip MO_SS_Conv W16 ),+        ( "sx32",     flip MO_SS_Conv W32 ),+        ( "sx64",     flip MO_SS_Conv W64 ),++        ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode+        ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode+        ( "f2i8",     flip MO_FS_Conv W8 ),+        ( "f2i16",    flip MO_FS_Conv W16 ),+        ( "f2i32",    flip MO_FS_Conv W32 ),+        ( "f2i64",    flip MO_FS_Conv W64 ),+        ( "i2f32",    flip MO_SF_Conv W32 ),+        ( "i2f64",    flip MO_SF_Conv W64 )+        ]++callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))+callishMachOps = listToUFM $+        map (\(x, y) -> (mkFastString x, y)) [+        ( "write_barrier", (,) MO_WriteBarrier ),+        ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),+        ( "memset", memcpyLikeTweakArgs MO_Memset ),+        ( "memmove", memcpyLikeTweakArgs MO_Memmove ),+        ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ),++        ("prefetch0", (,) $ MO_Prefetch_Data 0),+        ("prefetch1", (,) $ MO_Prefetch_Data 1),+        ("prefetch2", (,) $ MO_Prefetch_Data 2),+        ("prefetch3", (,) $ MO_Prefetch_Data 3),++        ( "popcnt8",  (,) $ MO_PopCnt W8  ),+        ( "popcnt16", (,) $ MO_PopCnt W16 ),+        ( "popcnt32", (,) $ MO_PopCnt W32 ),+        ( "popcnt64", (,) $ MO_PopCnt W64 ),++        ( "pdep8",  (,) $ MO_Pdep W8  ),+        ( "pdep16", (,) $ MO_Pdep W16 ),+        ( "pdep32", (,) $ MO_Pdep W32 ),+        ( "pdep64", (,) $ MO_Pdep W64 ),++        ( "pext8",  (,) $ MO_Pext W8  ),+        ( "pext16", (,) $ MO_Pext W16 ),+        ( "pext32", (,) $ MO_Pext W32 ),+        ( "pext64", (,) $ MO_Pext W64 ),++        ( "cmpxchg8",  (,) $ MO_Cmpxchg W8  ),+        ( "cmpxchg16", (,) $ MO_Cmpxchg W16 ),+        ( "cmpxchg32", (,) $ MO_Cmpxchg W32 ),+        ( "cmpxchg64", (,) $ MO_Cmpxchg W64 )++        -- ToDo: the rest, maybe+        -- edit: which rest?+        -- also: how do we tell CMM Lint how to type check callish macops?+    ]+  where+    memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])+    memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"+    memcpyLikeTweakArgs op args@(_:_) =+        (op align, args')+      where+        args' = init args+        align = case last args of+          CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger+          e -> pprPgmError "Non-constant alignment in memcpy-like function:" (ppr e)+        -- The alignment of memcpy-ish operations must be a+        -- compile-time constant. We verify this here, passing it around+        -- in the MO_* constructor. In order to do this, however, we+        -- must intercept the arguments in primCall.++parseSafety :: String -> PD Safety+parseSafety "safe"   = return PlaySafe+parseSafety "unsafe" = return PlayRisky+parseSafety "interruptible" = return PlayInterruptible+parseSafety str      = fail ("unrecognised safety: " ++ str)++parseCmmHint :: String -> PD ForeignHint+parseCmmHint "ptr"    = return AddrHint+parseCmmHint "signed" = return SignedHint+parseCmmHint str      = fail ("unrecognised hint: " ++ str)++-- labels are always pointers, so we might as well infer the hint+inferCmmHint :: CmmExpr -> ForeignHint+inferCmmHint (CmmLit (CmmLabel _)) = AddrHint+inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint+inferCmmHint _ = NoHint++isPtrGlobalReg Sp                    = True+isPtrGlobalReg SpLim                 = True+isPtrGlobalReg Hp                    = True+isPtrGlobalReg HpLim                 = True+isPtrGlobalReg CCCS                  = True+isPtrGlobalReg CurrentTSO            = True+isPtrGlobalReg CurrentNursery        = True+isPtrGlobalReg (VanillaReg _ VGcPtr) = True+isPtrGlobalReg _                     = False++happyError :: PD a+happyError = PD $ \_ s -> unP srcParseFail s++-- -----------------------------------------------------------------------------+-- Statement-level macros++stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())+stmtMacro fun args_code = do+  case lookupUFM stmtMacros fun of+    Nothing -> fail ("unknown macro: " ++ unpackFS fun)+    Just fcode -> return $ do+        args <- sequence args_code+        code (fcode args)++stmtMacros :: UniqFM ([CmmExpr] -> FCode ())+stmtMacros = listToUFM [+  ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),+  ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),++  ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),+  ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),++  -- completely generic heap and stack checks, for use in high-level cmm.+  ( fsLit "HP_CHK_GEN",            \[bytes] ->+                                      heapStackCheckGen Nothing (Just bytes) ),+  ( fsLit "STK_CHK_GEN",           \[] ->+                                      heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),++  -- A stack check for a fixed amount of stack.  Sounds a bit strange, but+  -- we use the stack for a bit of temporary storage in a couple of primops+  ( fsLit "STK_CHK_GEN_N",         \[bytes] ->+                                      heapStackCheckGen (Just bytes) Nothing ),++  -- A stack check on entry to a thunk, where the argument is the thunk pointer.+  ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),++  ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),+  ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),++  ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),+  ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),++  ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),+  ( fsLit "SET_HDR",               \[ptr,info,ccs] ->+                                        emitSetDynHdr ptr info ccs ),+  ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->+                                        tickyAllocPrim hdr goods slop ),+  ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->+                                        tickyAllocPAP goods slop ),+  ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->+                                        tickyAllocThunk goods slop ),+  ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode reg )+ ]++emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()+emitPushUpdateFrame sp e = do+  dflags <- getDynFlags+  emitUpdateFrame dflags sp mkUpdInfoLabel e++pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()+pushStackFrame fields body = do+  dflags <- getDynFlags+  exprs <- sequence fields+  updfr_off <- getUpdFrameOff+  let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old+                                           [] updfr_off exprs+  emit g+  withUpdFrameOff new_updfr_off body++reserveStackFrame+  :: CmmParse CmmExpr+  -> CmmParse CmmReg+  -> CmmParse ()+  -> CmmParse ()+reserveStackFrame psize preg body = do+  dflags <- getDynFlags+  old_updfr_off <- getUpdFrameOff+  reg <- preg+  esize <- psize+  let size = case constantFoldExpr dflags esize of+               CmmLit (CmmInt n _) -> n+               _other -> pprPanic "CmmParse: not a compile-time integer: "+                            (ppr esize)+  let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size+  emitAssign reg (CmmStackSlot Old frame)+  withUpdFrameOff frame body++profilingInfo dflags desc_str ty_str+  = if not (gopt Opt_SccProfilingOn dflags)+    then NoProfilingInfo+    else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)++staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()+staticClosure pkg cl_label info payload+  = do dflags <- getDynFlags+       let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []+       code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits++foreignCall+        :: String+        -> [CmmParse (LocalReg, ForeignHint)]+        -> CmmParse CmmExpr+        -> [CmmParse (CmmExpr, ForeignHint)]+        -> Safety+        -> CmmReturnInfo+        -> PD (CmmParse ())+foreignCall conv_string results_code expr_code args_code safety ret+  = do  conv <- case conv_string of+          "C" -> return CCallConv+          "stdcall" -> return StdCallConv+          _ -> fail ("unknown calling convention: " ++ conv_string)+        return $ do+          dflags <- getDynFlags+          results <- sequence results_code+          expr <- expr_code+          args <- sequence args_code+          let+                  expr' = adjCallTarget dflags conv expr args+                  (arg_exprs, arg_hints) = unzip args+                  (res_regs,  res_hints) = unzip results+                  fc = ForeignConvention conv arg_hints res_hints ret+                  target = ForeignTarget expr' fc+          _ <- code $ emitForeignCall safety res_regs target arg_exprs+          return ()+++doReturn :: [CmmParse CmmExpr] -> CmmParse ()+doReturn exprs_code = do+  dflags <- getDynFlags+  exprs <- sequence exprs_code+  updfr_off <- getUpdFrameOff+  emit (mkReturnSimple dflags exprs updfr_off)++mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph+mkReturnSimple dflags actuals updfr_off =+  mkReturn dflags e actuals updfr_off+  where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)+                             (gcWord dflags))++doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()+doRawJump expr_code vols = do+  dflags <- getDynFlags+  expr <- expr_code+  updfr_off <- getUpdFrameOff+  emit (mkRawJump dflags expr updfr_off vols)++doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]+                -> [CmmParse CmmExpr] -> CmmParse ()+doJumpWithStack expr_code stk_code args_code = do+  dflags <- getDynFlags+  expr <- expr_code+  stk_args <- sequence stk_code+  args <- sequence args_code+  updfr_off <- getUpdFrameOff+  emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)++doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]+       -> CmmParse ()+doCall expr_code res_code args_code = do+  dflags <- getDynFlags+  expr <- expr_code+  args <- sequence args_code+  ress <- sequence res_code+  updfr_off <- getUpdFrameOff+  c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []+  emit c++adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]+              -> CmmExpr+-- On Windows, we have to add the '@N' suffix to the label when making+-- a call with the stdcall calling convention.+adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args+ | platformOS (targetPlatform dflags) == OSMinGW32+  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))+  where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))+                 -- c.f. CgForeignCall.emitForeignCall+adjCallTarget _ _ expr _+  = expr++primCall+        :: [CmmParse (CmmFormal, ForeignHint)]+        -> FastString+        -> [CmmParse CmmExpr]+        -> PD (CmmParse ())+primCall results_code name args_code+  = case lookupUFM callishMachOps name of+        Nothing -> fail ("unknown primitive " ++ unpackFS name)+        Just f  -> return $ do+                results <- sequence results_code+                args <- sequence args_code+                let (p, args') = f args+                code (emitPrimCall (map fst results) p args')++doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()+doStore rep addr_code val_code+  = do dflags <- getDynFlags+       addr <- addr_code+       val <- val_code+        -- if the specified store type does not match the type of the expr+        -- on the rhs, then we insert a coercion that will cause the type+        -- mismatch to be flagged by cmm-lint.  If we don't do this, then+        -- the store will happen at the wrong type, and the error will not+        -- be noticed.+       let val_width = typeWidth (cmmExprType dflags val)+           rep_width = typeWidth rep+       let coerce_val+                | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]+                | otherwise              = val+       emitStore addr coerce_val++-- -----------------------------------------------------------------------------+-- If-then-else and boolean expressions++data BoolExpr+  = BoolExpr `BoolAnd` BoolExpr+  | BoolExpr `BoolOr`  BoolExpr+  | BoolNot BoolExpr+  | BoolTest CmmExpr++-- ToDo: smart constructors which simplify the boolean expression.++cmmIfThenElse cond then_part else_part likely = do+     then_id <- newBlockId+     join_id <- newBlockId+     c <- cond+     emitCond c then_id likely+     else_part+     emit (mkBranch join_id)+     emitLabel then_id+     then_part+     -- fall through to join+     emitLabel join_id++cmmRawIf cond then_id likely = do+    c <- cond+    emitCond c then_id likely++-- 'emitCond cond true_id'  emits code to test whether the cond is true,+-- branching to true_id if so, and falling through otherwise.+emitCond (BoolTest e) then_id likely = do+  else_id <- newBlockId+  emit (mkCbranch e then_id else_id likely)+  emitLabel else_id+emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id likely+  | Just op' <- maybeInvertComparison op+  = emitCond (BoolTest (CmmMachOp op' args)) then_id (not <$> likely)+emitCond (BoolNot e) then_id likely = do+  else_id <- newBlockId+  emitCond e else_id likely+  emit (mkBranch then_id)+  emitLabel else_id+emitCond (e1 `BoolOr` e2) then_id likely = do+  emitCond e1 then_id likely+  emitCond e2 then_id likely+emitCond (e1 `BoolAnd` e2) then_id likely = do+        -- we'd like to invert one of the conditionals here to avoid an+        -- extra branch instruction, but we can't use maybeInvertComparison+        -- here because we can't look too closely at the expression since+        -- we're in a loop.+  and_id <- newBlockId+  else_id <- newBlockId+  emitCond e1 and_id likely+  emit (mkBranch else_id)+  emitLabel and_id+  emitCond e2 then_id likely+  emitLabel else_id++-- -----------------------------------------------------------------------------+-- Source code notes++-- | Generate a source note spanning from "a" to "b" (inclusive), then+-- proceed with parsing. This allows debugging tools to reason about+-- locations in Cmm code.+withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c+withSourceNote a b parse = do+  name <- getName+  case combineSrcSpans (getLoc a) (getLoc b) of+    RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse+    _other           -> parse++-- -----------------------------------------------------------------------------+-- Table jumps++-- We use a simplified form of C-- switch statements for now.  A+-- switch statement always compiles to a table jump.  Each arm can+-- specify a list of values (not ranges), and there can be a single+-- default branch.  The range of the table is given either by the+-- optional range on the switch (eg. switch [0..7] {...}), or by+-- the minimum/maximum values from the branches.++doSwitch :: Maybe (Integer,Integer)+         -> CmmParse CmmExpr+         -> [([Integer],Either BlockId (CmmParse ()))]+         -> Maybe (CmmParse ()) -> CmmParse ()+doSwitch mb_range scrut arms deflt+   = do+        -- Compile code for the default branch+        dflt_entry <- +                case deflt of+                  Nothing -> return Nothing+                  Just e  -> do b <- forkLabelledCode e; return (Just b)++        -- Compile each case branch+        table_entries <- mapM emitArm arms+        let table = M.fromList (concat table_entries)++        dflags <- getDynFlags+        let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range++        expr <- scrut+        -- ToDo: check for out of range and jump to default if necessary+        emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table)+   where+        emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)]+        emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]+        emitArm (ints,Right code) = do+           blockid <- forkLabelledCode code+           return [ (i,blockid) | i <- ints ]++forkLabelledCode :: CmmParse () -> CmmParse BlockId+forkLabelledCode p = do+  (_,ag) <- getCodeScoped p+  l <- newBlockId+  emitOutOfLine l ag+  return l++-- -----------------------------------------------------------------------------+-- Putting it all together++-- The initial environment: we define some constants that the compiler+-- knows about here.+initEnv :: DynFlags -> Env+initEnv dflags = listToUFM [+  ( fsLit "SIZEOF_StgHeader",+    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )),+  ( fsLit "SIZEOF_StgInfoTable",+    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))+  ]++parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)+parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do+  buf <- hGetStringBuffer filename+  let+        init_loc = mkRealSrcLoc (mkFastString filename) 1 1+        init_state = (mkPState dflags buf init_loc) { lex_state = [0] }+                -- reset the lex_state: the Lexer monad leaves some stuff+                -- in there we don't want.+  case unPD cmmParse dflags init_state of+    PFailed pst ->+        return (getMessages pst dflags, Nothing)+    POk pst code -> do+        st <- initC+        let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()+            (cmm,_) = runC dflags no_module st fcode+        let ms = getMessages pst dflags+        if (errorsFound dflags ms)+         then return (ms, Nothing)+         else return (ms, Just cmm)+  where+        no_module = panic "parseCmmFile: no module"+}
+ compiler/cmm/CmmPipeline.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE BangPatterns #-}++module CmmPipeline (+  -- | Converts C-- with an implicit stack and native C-- calls into+  -- optimized, CPS converted and native-call-less C--.  The latter+  -- C-- can be used to generate assembly.+  cmmPipeline+) where++import GhcPrelude++import Cmm+import CmmLint+import CmmBuildInfoTables+import CmmCommonBlockElim+import CmmImplementSwitchPlans+import CmmProcPoint+import CmmContFlowOpt+import CmmLayoutStack+import CmmSink+import Hoopl.Collections++import UniqSupply+import DynFlags+import ErrUtils+import HscTypes+import Control.Monad+import Outputable+import Platform++-----------------------------------------------------------------------------+-- | Top level driver for C-- pipeline+-----------------------------------------------------------------------------++cmmPipeline+ :: HscEnv -- Compilation env including+           -- dynamic flags: -dcmm-lint -ddump-cmm-cps+ -> ModuleSRTInfo        -- Info about SRTs generated so far+ -> CmmGroup             -- Input C-- with Procedures+ -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C--++cmmPipeline hsc_env srtInfo prog =+  do let dflags = hsc_dflags hsc_env++     tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog++     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops+     dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" (ppr cmms)++     return (srtInfo, cmms)+++cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])+cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])+cpsTop hsc_env proc =+    do+       ----------- Control-flow optimisations ----------------------------------++       -- The first round of control-flow optimisation speeds up the+       -- later passes by removing lots of empty blocks, so we do it+       -- even when optimisation isn't turned on.+       --+       CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}+            return $ cmmCfgOptsProc splitting_proc_points proc+       dump Opt_D_dump_cmm_cfg "Post control-flow optimisations" g++       let !TopInfo {stack_info=StackInfo { arg_space = entry_off+                                          , do_layout = do_layout }} = h++       ----------- Eliminate common blocks -------------------------------------+       g <- {-# SCC "elimCommonBlocks" #-}+            condPass Opt_CmmElimCommonBlocks elimCommonBlocks g+                          Opt_D_dump_cmm_cbe "Post common block elimination"++       -- Any work storing block Labels must be performed _after_+       -- elimCommonBlocks++       g <- {-# SCC "createSwitchPlans" #-}+            runUniqSM $ cmmImplementSwitchPlans dflags g+       dump Opt_D_dump_cmm_switch "Post switch plan" g++       ----------- Proc points -------------------------------------------------+       let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g+       proc_points <-+          if splitting_proc_points+             then do+               pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $+                  minimalProcPointSet (targetPlatform dflags) call_pps g+               dumpWith dflags Opt_D_dump_cmm_proc "Proc points"+                     (ppr l $$ ppr pp $$ ppr g)+               return pp+             else+               return call_pps++       ----------- Layout the stack and manifest Sp ----------------------------+       (g, stackmaps) <-+            {-# SCC "layoutStack" #-}+            if do_layout+               then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g+               else return (g, mapEmpty)+       dump Opt_D_dump_cmm_sp "Layout Stack" g++       ----------- Sink and inline assignments  --------------------------------+       g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]+            condPass Opt_CmmSink (cmmSink dflags) g+                     Opt_D_dump_cmm_sink "Sink assignments"++       ------------- CAF analysis ----------------------------------------------+       let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g+       dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" (ppr cafEnv)++       g <- if splitting_proc_points+            then do+               ------------- Split into separate procedures -----------------------+               let pp_map = {-# SCC "procPointAnalysis" #-}+                            procPointAnalysis proc_points g+               dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" $+                    ppr pp_map+               g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $+                    splitAtProcPoints dflags l call_pps proc_points pp_map+                                      (CmmProc h l v g)+               dumps Opt_D_dump_cmm_split "Post splitting" g+               return g+             else do+               -- attach info tables to return points+               return $ [attachContInfoTables call_pps (CmmProc h l v g)]++       ------------- Populate info tables with stack info -----------------+       g <- {-# SCC "setInfoTableStackMap" #-}+            return $ map (setInfoTableStackMap dflags stackmaps) g+       dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g++       ----------- Control-flow optimisations -----------------------------+       g <- {-# SCC "cmmCfgOpts(2)" #-}+            return $ if optLevel dflags >= 1+                     then map (cmmCfgOptsProc splitting_proc_points) g+                     else g+       g <- return (map removeUnreachableBlocksProc g)+            -- See Note [unreachable blocks]+       dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g++       return (cafEnv, g)++  where dflags = hsc_dflags hsc_env+        platform = targetPlatform dflags+        dump = dumpGraph dflags++        dumps flag name+           = mapM_ (dumpWith dflags flag name . ppr)++        condPass flag pass g dumpflag dumpname =+            if gopt flag dflags+               then do+                    g <- return $ pass g+                    dump dumpflag dumpname g+                    return g+               else return g++        -- we don't need to split proc points for the NCG, unless+        -- tablesNextToCode is off.  The latter is because we have no+        -- label to put on info tables for basic blocks that are not+        -- the entry point.+        splitting_proc_points = hscTarget dflags /= HscAsm+                             || not (tablesNextToCode dflags)+                             || -- Note [inconsistent-pic-reg]+                                usingInconsistentPicReg+        usingInconsistentPicReg+           = case (platformArch platform, platformOS platform, positionIndependent dflags)+             of   (ArchX86, OSDarwin, pic) -> pic+                  _                        -> False++-- Note [Sinking after stack layout]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- In the past we considered running sinking pass also before stack+-- layout, but after making some measurements we realized that:+--+--   a) running sinking only before stack layout produces slower+--      code than running sinking only before stack layout+--+--   b) running sinking both before and after stack layout produces+--      code that has the same performance as when running sinking+--      only after stack layout.+--+-- In other words sinking before stack layout doesn't buy as anything.+--+-- An interesting question is "why is it better to run sinking after+-- stack layout"? It seems that the major reason are stores and loads+-- generated by stack layout. Consider this code before stack layout:+--+--  c1E:+--      _c1C::P64 = R3;+--      _c1B::P64 = R2;+--      _c1A::P64 = R1;+--      I64[(young<c1D> + 8)] = c1D;+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;+--  c1D:+--      R3 = _c1C::P64;+--      R2 = _c1B::P64;+--      R1 = _c1A::P64;+--      call (P64[(old + 8)])(R3, R2, R1) args: 8, res: 0, upd: 8;+--+-- Stack layout pass will save all local variables live across a call+-- (_c1C, _c1B and _c1A in this example) on the stack just before+-- making a call and reload them from the stack after returning from a+-- call:+--+--  c1E:+--      _c1C::P64 = R3;+--      _c1B::P64 = R2;+--      _c1A::P64 = R1;+--      I64[Sp - 32] = c1D;+--      P64[Sp - 24] = _c1A::P64;+--      P64[Sp - 16] = _c1B::P64;+--      P64[Sp - 8] = _c1C::P64;+--      Sp = Sp - 32;+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;+--  c1D:+--      _c1A::P64 = P64[Sp + 8];+--      _c1B::P64 = P64[Sp + 16];+--      _c1C::P64 = P64[Sp + 24];+--      R3 = _c1C::P64;+--      R2 = _c1B::P64;+--      R1 = _c1A::P64;+--      Sp = Sp + 32;+--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;+--+-- If we don't run sinking pass after stack layout we are basically+-- left with such code. However, running sinking on this code can lead+-- to significant improvements:+--+--  c1E:+--      I64[Sp - 32] = c1D;+--      P64[Sp - 24] = R1;+--      P64[Sp - 16] = R2;+--      P64[Sp - 8] = R3;+--      Sp = Sp - 32;+--      call stg_gc_noregs() returns to c1D, args: 8, res: 8, upd: 8;+--  c1D:+--      R3 = P64[Sp + 24];+--      R2 = P64[Sp + 16];+--      R1 = P64[Sp + 8];+--      Sp = Sp + 32;+--      call (P64[Sp])(R3, R2, R1) args: 8, res: 0, upd: 8;+--+-- Now we only have 9 assignments instead of 15.+--+-- There is one case when running sinking before stack layout could+-- be beneficial. Consider this:+--+--   L1:+--      x = y+--      call f() returns L2+--   L2: ...x...y...+--+-- Since both x and y are live across a call to f, they will be stored+-- on the stack during stack layout and restored after the call:+--+--   L1:+--      x = y+--      P64[Sp - 24] = L2+--      P64[Sp - 16] = x+--      P64[Sp - 8]  = y+--      Sp = Sp - 24+--      call f() returns L2+--   L2:+--      y = P64[Sp + 16]+--      x = P64[Sp + 8]+--      Sp = Sp + 24+--      ...x...y...+--+-- However, if we run sinking before stack layout we would propagate x+-- to its usage place (both x and y must be local register for this to+-- be possible - global registers cannot be floated past a call):+--+--   L1:+--      x = y+--      call f() returns L2+--   L2: ...y...y...+--+-- Thus making x dead at the call to f(). If we ran stack layout now+-- we would generate less stores and loads:+--+--   L1:+--      x = y+--      P64[Sp - 16] = L2+--      P64[Sp - 8]  = y+--      Sp = Sp - 16+--      call f() returns L2+--   L2:+--      y = P64[Sp + 8]+--      Sp = Sp + 16+--      ...y...y...+--+-- But since we don't see any benefits from running sinking befroe stack+-- layout, this situation probably doesn't arise too often in practice.+--++{- Note [inconsistent-pic-reg]++On x86/Darwin, PIC is implemented by inserting a sequence like++    call 1f+ 1: popl %reg++at the proc entry point, and then referring to labels as offsets from+%reg.  If we don't split proc points, then we could have many entry+points in a proc that would need this sequence, and each entry point+would then get a different value for %reg.  If there are any join+points, then at the join point we don't have a consistent value for+%reg, so we don't know how to refer to labels.++Hence, on x86/Darwin, we have to split proc points, and then each proc+point will get its own PIC initialisation sequence.++This isn't an issue on x86/ELF, where the sequence is++    call 1f+ 1: popl %reg+    addl $_GLOBAL_OFFSET_TABLE_+(.-1b), %reg++so %reg always has a consistent value: the address of+_GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.++-}++{- Note [unreachable blocks]++The control-flow optimiser sometimes leaves unreachable blocks behind+containing junk code.  These aren't necessarily a problem, but+removing them is good because it might save time in the native code+generator later.++-}++runUniqSM :: UniqSM a -> IO a+runUniqSM m = do+  us <- mkSplitUniqSupply 'u'+  return (initUs_ us m)+++dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()+dumpGraph dflags flag name g = do+  when (gopt Opt_DoCmmLinting dflags) $ do_lint g+  dumpWith dflags flag name (ppr g)+ where+  do_lint g = case cmmLintGraph dflags g of+                 Just err -> do { fatalErrorMsg dflags err+                                ; ghcExit dflags 1+                                }+                 Nothing  -> return ()++dumpWith :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()+dumpWith dflags flag txt sdoc = do+         -- ToDo: No easy way of say "dump all the cmm, *and* split+         -- them into files."  Also, -ddump-cmm-verbose doesn't play+         -- nicely with -ddump-to-file, since the headers get omitted.+   dumpIfSet_dyn dflags flag txt sdoc+   when (not (dopt flag dflags)) $+      dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose txt sdoc
+ compiler/cmm/CmmProcPoint.hs view
@@ -0,0 +1,496 @@+{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}++module CmmProcPoint+    ( ProcPointSet, Status(..)+    , callProcPoints, minimalProcPointSet+    , splitAtProcPoints, procPointAnalysis+    , attachContInfoTables+    )+where++import GhcPrelude hiding (last, unzip, succ, zip)++import DynFlags+import BlockId+import CLabel+import Cmm+import PprCmm ()+import CmmUtils+import CmmInfo+import CmmLive+import CmmSwitch+import Data.List (sortBy)+import Maybes+import Control.Monad+import Outputable+import Platform+import UniqSupply+import Hoopl.Block+import Hoopl.Collections+import Hoopl.Dataflow+import Hoopl.Graph+import Hoopl.Label++-- Compute a minimal set of proc points for a control-flow graph.++-- Determine a protocol for each proc point (which live variables will+-- be passed as arguments and which will be on the stack).++{-+A proc point is a basic block that, after CPS transformation, will+start a new function.  The entry block of the original function is a+proc point, as is the continuation of each function call.+A third kind of proc point arises if we want to avoid copying code.+Suppose we have code like the following:++  f() {+    if (...) { ..1..; call foo(); ..2..}+    else     { ..3..; call bar(); ..4..}+    x = y + z;+    return x;+  }++The statement 'x = y + z' can be reached from two different proc+points: the continuations of foo() and bar().  We would prefer not to+put a copy in each continuation; instead we would like 'x = y + z' to+be the start of a new procedure to which the continuations can jump:++  f_cps () {+    if (...) { ..1..; push k_foo; jump foo_cps(); }+    else     { ..3..; push k_bar; jump bar_cps(); }+  }+  k_foo() { ..2..; jump k_join(y, z); }+  k_bar() { ..4..; jump k_join(y, z); }+  k_join(y, z) { x = y + z; return x; }++You might think then that a criterion to make a node a proc point is+that it is directly reached by two distinct proc points.  (Note+[Direct reachability].)  But this criterion is a bit too simple; for+example, 'return x' is also reached by two proc points, yet there is+no point in pulling it out of k_join.  A good criterion would be to+say that a node should be made a proc point if it is reached by a set+of proc points that is different than its immediate dominator.  NR+believes this criterion can be shown to produce a minimum set of proc+points, and given a dominator tree, the proc points can be chosen in+time linear in the number of blocks.  Lacking a dominator analysis,+however, we turn instead to an iterative solution, starting with no+proc points and adding them according to these rules:++  1. The entry block is a proc point.+  2. The continuation of a call is a proc point.+  3. A node is a proc point if it is directly reached by more proc+     points than one of its predecessors.++Because we don't understand the problem very well, we apply rule 3 at+most once per iteration, then recompute the reachability information.+(See Note [No simple dataflow].)  The choice of the new proc point is+arbitrary, and I don't know if the choice affects the final solution,+so I don't know if the number of proc points chosen is the+minimum---but the set will be minimal.++++Note [Proc-point analysis]+~~~~~~~~~~~~~~~~~~~~~~~~~~++Given a specified set of proc-points (a set of block-ids), "proc-point+analysis" figures out, for every block, which proc-point it belongs to.+All the blocks belonging to proc-point P will constitute a single+top-level C procedure.++A non-proc-point block B "belongs to" a proc-point P iff B is+reachable from P without going through another proc-point.++Invariant: a block B should belong to at most one proc-point; if it+belongs to two, that's a bug.++Note [Non-existing proc-points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++On some architectures it might happen that the list of proc-points+computed before stack layout pass will be invalidated by the stack+layout. This will happen if stack layout removes from the graph+blocks that were determined to be proc-points. Later on in the pipeline+we use list of proc-points to perform [Proc-point analysis], but+if a proc-point does not exist anymore then we will get compiler panic.+See #8205.+-}++type ProcPointSet = LabelSet++data Status+  = ReachedBy ProcPointSet  -- set of proc points that directly reach the block+  | ProcPoint               -- this block is itself a proc point++instance Outputable Status where+  ppr (ReachedBy ps)+      | setNull ps = text "<not-reached>"+      | otherwise = text "reached by" <+>+                    (hsep $ punctuate comma $ map ppr $ setElems ps)+  ppr ProcPoint = text "<procpt>"++--------------------------------------------------+-- Proc point analysis++-- Once you know what the proc-points are, figure out+-- what proc-points each block is reachable from+-- See Note [Proc-point analysis]+procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status+procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =+    analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints+  where+    initProcPoints =+        mkFactBase+            procPointLattice+            [ (id, ProcPoint)+            | id <- setElems procPoints+            -- See Note [Non-existing proc-points]+            , id `setMember` labelsInGraph+            ]+    labelsInGraph = labelsDefined graph++procPointTransfer :: TransferFun Status+procPointTransfer block facts =+    let label = entryLabel block+        !fact = case getFact procPointLattice label facts of+            ProcPoint -> ReachedBy $! setSingleton label+            f -> f+        result = map (\id -> (id, fact)) (successors block)+    in mkFactBase procPointLattice result++procPointLattice :: DataflowLattice Status+procPointLattice = DataflowLattice unreached add_to+  where+    unreached = ReachedBy setEmpty+    add_to (OldFact ProcPoint) _ = NotChanged ProcPoint+    add_to _ (NewFact ProcPoint) = Changed ProcPoint -- because of previous case+    add_to (OldFact (ReachedBy p)) (NewFact (ReachedBy p'))+        | setSize union > setSize p = Changed (ReachedBy union)+        | otherwise = NotChanged (ReachedBy p)+      where+        union = setUnion p' p++----------------------------------------------------------------------++-- It is worth distinguishing two sets of proc points: those that are+-- induced by calls in the original graph and those that are+-- introduced because they're reachable from multiple proc points.+--+-- Extract the set of Continuation BlockIds, see Note [Continuation BlockIds].+callProcPoints      :: CmmGraph -> ProcPointSet+callProcPoints g = foldlGraphBlocks add (setSingleton (g_entry g)) g+  where add :: LabelSet -> CmmBlock -> LabelSet+        add set b = case lastNode b of+                      CmmCall {cml_cont = Just k} -> setInsert k set+                      CmmForeignCall {succ=k}     -> setInsert k set+                      _ -> set++minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph+                    -> UniqSM ProcPointSet+-- Given the set of successors of calls (which must be proc-points)+-- figure out the minimal set of necessary proc-points+minimalProcPointSet platform callProcPoints g+  = extendPPSet platform g (revPostorder g) callProcPoints++extendPPSet+    :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet+extendPPSet platform g blocks procPoints =+    let env = procPointAnalysis procPoints g+        add pps block = let id = entryLabel block+                        in  case mapLookup id env of+                              Just ProcPoint -> setInsert id pps+                              _ -> pps+        procPoints' = foldlGraphBlocks add setEmpty g+        newPoints = mapMaybe ppSuccessor blocks+        newPoint  = listToMaybe newPoints+        ppSuccessor b =+            let nreached id = case mapLookup id env `orElse`+                                    pprPanic "no ppt" (ppr id <+> ppr b) of+                                ProcPoint -> 1+                                ReachedBy ps -> setSize ps+                block_procpoints = nreached (entryLabel b)+                -- | Looking for a successor of b that is reached by+                -- more proc points than b and is not already a proc+                -- point.  If found, it can become a proc point.+                newId succ_id = not (setMember succ_id procPoints') &&+                                nreached succ_id > block_procpoints+            in  listToMaybe $ filter newId $ successors b++    in case newPoint of+         Just id ->+             if setMember id procPoints'+                then panic "added old proc pt"+                else extendPPSet platform g blocks (setInsert id procPoints')+         Nothing -> return procPoints'+++-- At this point, we have found a set of procpoints, each of which should be+-- the entry point of a procedure.+-- Now, we create the procedure for each proc point,+-- which requires that we:+-- 1. build a map from proc points to the blocks reachable from the proc point+-- 2. turn each branch to a proc point into a jump+-- 3. turn calls and returns into jumps+-- 4. build info tables for the procedures -- and update the info table for+--    the SRTs in the entry procedure as well.+-- Input invariant: A block should only be reachable from a single ProcPoint.+-- ToDo: use the _ret naming convention that the old code generator+-- used. -- EZY+splitAtProcPoints :: DynFlags -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status ->+                     CmmDecl -> UniqSM [CmmDecl]+splitAtProcPoints dflags entry_label callPPs procPoints procMap+                  (CmmProc (TopInfo {info_tbls = info_tbls})+                           top_l _ g@(CmmGraph {g_entry=entry})) =+  do -- Build a map from procpoints to the blocks they reach+     let add_block+             :: LabelMap (LabelMap CmmBlock)+             -> CmmBlock+             -> LabelMap (LabelMap CmmBlock)+         add_block graphEnv b =+           case mapLookup bid procMap of+             Just ProcPoint -> add graphEnv bid bid b+             Just (ReachedBy set) ->+               case setElems set of+                 []   -> graphEnv+                 [id] -> add graphEnv id bid b+                 _    -> panic "Each block should be reachable from only one ProcPoint"+             Nothing -> graphEnv+           where bid = entryLabel b+         add graphEnv procId bid b = mapInsert procId graph' graphEnv+               where graph  = mapLookup procId graphEnv `orElse` mapEmpty+                     graph' = mapInsert bid b graph++     let liveness = cmmGlobalLiveness dflags g+     let ppLiveness pp = filter isArgReg $+                         regSetToList $+                         expectJust "ppLiveness" $ mapLookup pp liveness++     graphEnv <- return $ foldlGraphBlocks add_block mapEmpty g++     -- Build a map from proc point BlockId to pairs of:+     --  * Labels for their new procedures+     --  * Labels for the info tables of their new procedures (only if+     --    the proc point is a callPP)+     -- Due to common blockification, we may overestimate the set of procpoints.+     let add_label map pp = mapInsert pp lbls map+           where lbls | pp == entry = (entry_label, fmap cit_lbl (mapLookup entry info_tbls))+                      | otherwise   = (block_lbl, guard (setMember pp callPPs) >>+                                                    Just info_table_lbl)+                      where block_lbl      = blockLbl pp+                            info_table_lbl = infoTblLbl pp++         procLabels :: LabelMap (CLabel, Maybe CLabel)+         procLabels = foldl' add_label mapEmpty+                             (filter (flip mapMember (toBlockMap g)) (setElems procPoints))++     -- In each new graph, add blocks jumping off to the new procedures,+     -- and replace branches to procpoints with branches to the jump-off blocks+     let add_jump_block+             :: (LabelMap Label, [CmmBlock])+             -> (Label, CLabel)+             -> UniqSM (LabelMap Label, [CmmBlock])+         add_jump_block (env, bs) (pp, l) =+           do bid <- liftM mkBlockId getUniqueM+              let b = blockJoin (CmmEntry bid GlobalScope) emptyBlock jump+                  live = ppLiveness pp+                  jump = CmmCall (CmmLit (CmmLabel l)) Nothing live 0 0 0+              return (mapInsert pp bid env, b : bs)++         add_jumps+             :: LabelMap CmmGraph+             -> (Label, LabelMap CmmBlock)+             -> UniqSM (LabelMap CmmGraph)+         add_jumps newGraphEnv (ppId, blockEnv) =+           do let needed_jumps = -- find which procpoints we currently branch to+                    mapFoldr add_if_branch_to_pp [] blockEnv+                  add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]+                  add_if_branch_to_pp block rst =+                    case lastNode block of+                      CmmBranch id          -> add_if_pp id rst+                      CmmCondBranch _ ti fi _ -> add_if_pp ti (add_if_pp fi rst)+                      CmmSwitch _ ids       -> foldr add_if_pp rst $ switchTargetsToList ids+                      _                     -> rst++                  -- when jumping to a PP that has an info table, if+                  -- tablesNextToCode is off we must jump to the entry+                  -- label instead.+                  jump_label (Just info_lbl) _+                             | tablesNextToCode dflags = info_lbl+                             | otherwise               = toEntryLbl info_lbl+                  jump_label Nothing         block_lbl = block_lbl++                  add_if_pp id rst = case mapLookup id procLabels of+                                       Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst+                                       Nothing                 -> rst+              (jumpEnv, jumpBlocks) <-+                 foldM add_jump_block (mapEmpty, []) needed_jumps+                  -- update the entry block+              let b = expectJust "block in env" $ mapLookup ppId blockEnv+                  blockEnv' = mapInsert ppId b blockEnv+                  -- replace branches to procpoints with branches to jumps+                  blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'+                  -- add the jump blocks to the graph+                  blockEnv''' = foldl' (flip addBlock) blockEnv'' jumpBlocks+              let g' = ofBlockMap ppId blockEnv'''+              -- pprTrace "g' pre jumps" (ppr g') $ do+              return (mapInsert ppId g' newGraphEnv)++     graphEnv <- foldM add_jumps mapEmpty $ mapToList graphEnv++     let to_proc (bid, g)+             | bid == entry+             =  CmmProc (TopInfo {info_tbls  = info_tbls,+                                  stack_info = stack_info})+                        top_l live g'+             | otherwise+             = case expectJust "pp label" $ mapLookup bid procLabels of+                 (lbl, Just info_lbl)+                    -> CmmProc (TopInfo { info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl)+                                        , stack_info=stack_info})+                               lbl live g'+                 (lbl, Nothing)+                    -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})+                               lbl live g'+                where+                 g' = replacePPIds g+                 live = ppLiveness (g_entry g')+                 stack_info = StackInfo { arg_space = 0+                                        , updfr_space =  Nothing+                                        , do_layout = True }+                               -- cannot use panic, this is printed by -ddump-cmm++         -- References to procpoint IDs can now be replaced with the+         -- infotable's label+         replacePPIds g = {-# SCC "replacePPIds" #-}+                          mapGraphNodes (id, mapExp repl, mapExp repl) g+           where repl e@(CmmLit (CmmBlock bid)) =+                   case mapLookup bid procLabels of+                     Just (_, Just info_lbl)  -> CmmLit (CmmLabel info_lbl)+                     _ -> e+                 repl e = e++     -- The C back end expects to see return continuations before the+     -- call sites.  Here, we sort them in reverse order -- it gets+     -- reversed later.+     let (_, block_order) =+             foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)+                   (revPostorder g)+         add_block_num (i, map) block =+           (i + 1, mapInsert (entryLabel block) i map)+         sort_fn (bid, _) (bid', _) =+           compare (expectJust "block_order" $ mapLookup bid  block_order)+                   (expectJust "block_order" $ mapLookup bid' block_order)+     procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv+     return -- pprTrace "procLabels" (ppr procLabels)+            -- pprTrace "splitting graphs" (ppr procs)+            procs+splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]++-- Only called from CmmProcPoint.splitAtProcPoints. NB. does a+-- recursive lookup, see comment below.+replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph+replaceBranches env cmmg+  = {-# SCC "replaceBranches" #-}+    ofBlockMap (g_entry cmmg) $ mapMap f $ toBlockMap cmmg+  where+    f block = replaceLastNode block $ last (lastNode block)++    last :: CmmNode O C -> CmmNode O C+    last (CmmBranch id)          = CmmBranch (lookup id)+    last (CmmCondBranch e ti fi l) = CmmCondBranch e (lookup ti) (lookup fi) l+    last (CmmSwitch e ids)       = CmmSwitch e (mapSwitchTargets lookup ids)+    last l@(CmmCall {})          = l { cml_cont = Nothing }+            -- NB. remove the continuation of a CmmCall, since this+            -- label will now be in a different CmmProc.  Not only+            -- is this tidier, it stops CmmLint from complaining.+    last l@(CmmForeignCall {})   = l+    lookup id = fmap lookup (mapLookup id env) `orElse` id+            -- XXX: this is a recursive lookup, it follows chains+            -- until the lookup returns Nothing, at which point we+            -- return the last BlockId++-- --------------------------------------------------------------+-- Not splitting proc points: add info tables for continuations++attachContInfoTables :: ProcPointSet -> CmmDecl -> CmmDecl+attachContInfoTables call_proc_points (CmmProc top_info top_l live g)+ = CmmProc top_info{info_tbls = info_tbls'} top_l live g+ where+   info_tbls' = mapUnion (info_tbls top_info) $+                mapFromList [ (l, mkEmptyContInfoTable (infoTblLbl l))+                            | l <- setElems call_proc_points+                            , l /= g_entry g ]+attachContInfoTables _ other_decl+ = other_decl++----------------------------------------------------------------++{-+Note [Direct reachability]++Block B is directly reachable from proc point P iff control can flow+from P to B without passing through an intervening proc point.+-}++----------------------------------------------------------------++{-+Note [No simple dataflow]++Sadly, it seems impossible to compute the proc points using a single+dataflow pass.  One might attempt to use this simple lattice:++  data Location = Unknown+                | InProc BlockId -- node is in procedure headed by the named proc point+                | ProcPoint      -- node is itself a proc point++At a join, a node in two different blocks becomes a proc point.+The difficulty is that the change of information during iterative+computation may promote a node prematurely.  Here's a program that+illustrates the difficulty:++  f () {+  entry:+    ....+  L1:+    if (...) { ... }+    else { ... }++  L2: if (...) { g(); goto L1; }+      return x + y;+  }++The only proc-point needed (besides the entry) is L1.  But in an+iterative analysis, consider what happens to L2.  On the first pass+through, it rises from Unknown to 'InProc entry', but when L1 is+promoted to a proc point (because it's the successor of g()), L1's+successors will be promoted to 'InProc L1'.  The problem hits when the+new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'.+The join operation makes it a proc point when in fact it needn't be,+because its immediate dominator L1 is already a proc point and there+are no other proc points that directly reach L2.+-}++++{- Note [Separate Adams optimization]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It may be worthwhile to attempt the Adams optimization by rewriting+the graph before the assignment of proc-point protocols.  Here are a+couple of rules:++  g() returns to k;                    g() returns to L;+  k: CopyIn c ress; goto L:+   ...                        ==>        ...+  L: // no CopyIn node here            L: CopyIn c ress;+++And when c == c' and ress == ress', this also:++  g() returns to k;                    g() returns to L;+  k: CopyIn c ress; goto L:+   ...                        ==>        ...+  L: CopyIn c' ress'                   L: CopyIn c' ress' ;++In both cases the goal is to eliminate k.+-}
+ compiler/cmm/CmmSink.hs view
@@ -0,0 +1,855 @@+{-# LANGUAGE GADTs #-}+module CmmSink (+     cmmSink+  ) where++import GhcPrelude++import Cmm+import CmmOpt+import CmmLive+import CmmUtils+import Hoopl.Block+import Hoopl.Label+import Hoopl.Collections+import Hoopl.Graph+import CodeGen.Platform+import Platform (isARM, platformArch)++import DynFlags+import Unique+import UniqFM+import PprCmm ()++import qualified Data.IntSet as IntSet+import Data.List (partition)+import qualified Data.Set as Set+import Data.Maybe++-- Compact sets for membership tests of local variables.++type LRegSet = IntSet.IntSet++emptyLRegSet :: LRegSet+emptyLRegSet = IntSet.empty++nullLRegSet :: LRegSet -> Bool+nullLRegSet = IntSet.null++insertLRegSet :: LocalReg -> LRegSet -> LRegSet+insertLRegSet l = IntSet.insert (getKey (getUnique l))++elemLRegSet :: LocalReg -> LRegSet -> Bool+elemLRegSet l = IntSet.member (getKey (getUnique l))++-- -----------------------------------------------------------------------------+-- Sinking and inlining++-- This is an optimisation pass that+--  (a) moves assignments closer to their uses, to reduce register pressure+--  (b) pushes assignments into a single branch of a conditional if possible+--  (c) inlines assignments to registers that are mentioned only once+--  (d) discards dead assignments+--+-- This tightens up lots of register-heavy code.  It is particularly+-- helpful in the Cmm generated by the Stg->Cmm code generator, in+-- which every function starts with a copyIn sequence like:+--+--    x1 = R1+--    x2 = Sp[8]+--    x3 = Sp[16]+--    if (Sp - 32 < SpLim) then L1 else L2+--+-- we really want to push the x1..x3 assignments into the L2 branch.+--+-- Algorithm:+--+--  * Start by doing liveness analysis.+--+--  * Keep a list of assignments A; earlier ones may refer to later ones.+--    Currently we only sink assignments to local registers, because we don't+--    have liveness information about global registers.+--+--  * Walk forwards through the graph, look at each node N:+--+--    * If it is a dead assignment, i.e. assignment to a register that is+--      not used after N, discard it.+--+--    * Try to inline based on current list of assignments+--      * If any assignments in A (1) occur only once in N, and (2) are+--        not live after N, inline the assignment and remove it+--        from A.+--+--      * If an assignment in A is cheap (RHS is local register), then+--        inline the assignment and keep it in A in case it is used afterwards.+--+--      * Otherwise don't inline.+--+--    * If N is assignment to a local register pick up the assignment+--      and add it to A.+--+--    * If N is not an assignment to a local register:+--      * remove any assignments from A that conflict with N, and+--        place them before N in the current block.  We call this+--        "dropping" the assignments.+--+--      * An assignment conflicts with N if it:+--        - assigns to a register mentioned in N+--        - mentions a register assigned by N+--        - reads from memory written by N+--      * do this recursively, dropping dependent assignments+--+--    * At an exit node:+--      * drop any assignments that are live on more than one successor+--        and are not trivial+--      * if any successor has more than one predecessor (a join-point),+--        drop everything live in that successor. Since we only propagate+--        assignments that are not dead at the successor, we will therefore+--        eliminate all assignments dead at this point. Thus analysis of a+--        join-point will always begin with an empty list of assignments.+--+--+-- As a result of above algorithm, sinking deletes some dead assignments+-- (transitively, even).  This isn't as good as removeDeadAssignments,+-- but it's much cheaper.++-- -----------------------------------------------------------------------------+-- things that we aren't optimising very well yet.+--+-- -----------+-- (1) From GHC's FastString.hashStr:+--+--  s2ay:+--      if ((_s2an::I64 == _s2ao::I64) >= 1) goto c2gn; else goto c2gp;+--  c2gn:+--      R1 = _s2au::I64;+--      call (I64[Sp])(R1) args: 8, res: 0, upd: 8;+--  c2gp:+--      _s2cO::I64 = %MO_S_Rem_W64(%MO_UU_Conv_W8_W64(I8[_s2aq::I64 + (_s2an::I64 << 0)]) + _s2au::I64 * 128,+--                                 4091);+--      _s2an::I64 = _s2an::I64 + 1;+--      _s2au::I64 = _s2cO::I64;+--      goto s2ay;+--+-- a nice loop, but we didn't eliminate the silly assignment at the end.+-- See Note [dependent assignments], which would probably fix this.+-- This is #8336.+--+-- -----------+-- (2) From stg_atomically_frame in PrimOps.cmm+--+-- We have a diamond control flow:+--+--     x = ...+--       |+--      / \+--     A   B+--      \ /+--       |+--    use of x+--+-- Now x won't be sunk down to its use, because we won't push it into+-- both branches of the conditional.  We certainly do have to check+-- that we can sink it past all the code in both A and B, but having+-- discovered that, we could sink it to its use.+--++-- -----------------------------------------------------------------------------++type Assignment = (LocalReg, CmmExpr, AbsMem)+  -- Assignment caches AbsMem, an abstraction of the memory read by+  -- the RHS of the assignment.++type Assignments = [Assignment]+  -- A sequence of assignments; kept in *reverse* order+  -- So the list [ x=e1, y=e2 ] means the sequence of assignments+  --     y = e2+  --     x = e1++cmmSink :: DynFlags -> CmmGraph -> CmmGraph+cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks+  where+  liveness = cmmLocalLiveness dflags graph+  getLive l = mapFindWithDefault Set.empty l liveness++  blocks = revPostorder graph++  join_pts = findJoinPoints blocks++  sink :: LabelMap Assignments -> [CmmBlock] -> [CmmBlock]+  sink _ [] = []+  sink sunk (b:bs) =+    -- pprTrace "sink" (ppr lbl) $+    blockJoin first final_middle final_last : sink sunk' bs+    where+      lbl = entryLabel b+      (first, middle, last) = blockSplit b++      succs = successors last++      -- Annotate the middle nodes with the registers live *after*+      -- the node.  This will help us decide whether we can inline+      -- an assignment in the current node or not.+      live = Set.unions (map getLive succs)+      live_middle = gen_kill dflags last live+      ann_middles = annotate dflags live_middle (blockToList middle)++      -- Now sink and inline in this block+      (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk)+      fold_last = constantFoldNode dflags last+      (final_last, assigs') = tryToInline dflags live fold_last assigs++      -- We cannot sink into join points (successors with more than+      -- one predecessor), so identify the join points and the set+      -- of registers live in them.+      (joins, nonjoins) = partition (`mapMember` join_pts) succs+      live_in_joins = Set.unions (map getLive joins)++      -- We do not want to sink an assignment into multiple branches,+      -- so identify the set of registers live in multiple successors.+      -- This is made more complicated because when we sink an assignment+      -- into one branch, this might change the set of registers that are+      -- now live in multiple branches.+      init_live_sets = map getLive nonjoins+      live_in_multi live_sets r =+         case filter (Set.member r) live_sets of+           (_one:_two:_) -> True+           _ -> False++      -- Now, drop any assignments that we will not sink any further.+      (dropped_last, assigs'') = dropAssignments dflags drop_if init_live_sets assigs'++      drop_if a@(r,rhs,_) live_sets = (should_drop, live_sets')+          where+            should_drop =  conflicts dflags a final_last+                        || not (isTrivial dflags rhs) && live_in_multi live_sets r+                        || r `Set.member` live_in_joins++            live_sets' | should_drop = live_sets+                       | otherwise   = map upd live_sets++            upd set | r `Set.member` set = set `Set.union` live_rhs+                    | otherwise          = set++            live_rhs = foldRegsUsed dflags extendRegSet emptyRegSet rhs++      final_middle = foldl' blockSnoc middle' dropped_last++      sunk' = mapUnion sunk $+                 mapFromList [ (l, filterAssignments dflags (getLive l) assigs'')+                             | l <- succs ]++{- TODO: enable this later, when we have some good tests in place to+   measure the effect and tune it.++-- small: an expression we don't mind duplicating+isSmall :: CmmExpr -> Bool+isSmall (CmmReg (CmmLocal _)) = True  --+isSmall (CmmLit _) = True+isSmall (CmmMachOp (MO_Add _) [x,y]) = isTrivial x && isTrivial y+isSmall (CmmRegOff (CmmLocal _) _) = True+isSmall _ = False+-}++--+-- We allow duplication of trivial expressions: registers (both local and+-- global) and literals.+--+isTrivial :: DynFlags -> CmmExpr -> Bool+isTrivial _ (CmmReg (CmmLocal _)) = True+isTrivial dflags (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?]+  if isARM (platformArch (targetPlatform dflags))+  then True -- CodeGen.Platform.ARM does not have globalRegMaybe+  else isJust (globalRegMaybe (targetPlatform dflags) r)+  -- GlobalRegs that are loads from BaseReg are not trivial+isTrivial _ (CmmLit _) = True+isTrivial _ _          = False++--+-- annotate each node with the set of registers live *after* the node+--+annotate :: DynFlags -> LocalRegSet -> [CmmNode O O] -> [(LocalRegSet, CmmNode O O)]+annotate dflags live nodes = snd $ foldr ann (live,[]) nodes+  where ann n (live,nodes) = (gen_kill dflags n live, (live,n) : nodes)++--+-- Find the blocks that have multiple successors (join points)+--+findJoinPoints :: [CmmBlock] -> LabelMap Int+findJoinPoints blocks = mapFilter (>1) succ_counts+ where+  all_succs = concatMap successors blocks++  succ_counts :: LabelMap Int+  succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs++--+-- filter the list of assignments to remove any assignments that+-- are not live in a continuation.+--+filterAssignments :: DynFlags -> LocalRegSet -> Assignments -> Assignments+filterAssignments dflags live assigs = reverse (go assigs [])+  where go []             kept = kept+        go (a@(r,_,_):as) kept | needed    = go as (a:kept)+                               | otherwise = go as kept+           where+              needed = r `Set.member` live+                       || any (conflicts dflags a) (map toNode kept)+                       --  Note that we must keep assignments that are+                       -- referred to by other assignments we have+                       -- already kept.++-- -----------------------------------------------------------------------------+-- Walk through the nodes of a block, sinking and inlining assignments+-- as we go.+--+-- On input we pass in a:+--    * list of nodes in the block+--    * a list of assignments that appeared *before* this block and+--      that are being sunk.+--+-- On output we get:+--    * a new block+--    * a list of assignments that will be placed *after* that block.+--++walk :: DynFlags+     -> [(LocalRegSet, CmmNode O O)]    -- nodes of the block, annotated with+                                        -- the set of registers live *after*+                                        -- this node.++     -> Assignments                     -- The current list of+                                        -- assignments we are sinking.+                                        -- Earlier assignments may refer+                                        -- to later ones.++     -> ( Block CmmNode O O             -- The new block+        , Assignments                   -- Assignments to sink further+        )++walk dflags nodes assigs = go nodes emptyBlock assigs+ where+   go []               block as = (block, as)+   go ((live,node):ns) block as+    | shouldDiscard node live           = go ns block as+       -- discard dead assignment+    | Just a <- shouldSink dflags node2 = go ns block (a : as1)+    | otherwise                         = go ns block' as'+    where+      node1 = constantFoldNode dflags node++      (node2, as1) = tryToInline dflags live node1 as++      (dropped, as') = dropAssignmentsSimple dflags+                          (\a -> conflicts dflags a node2) as1++      block' = foldl' blockSnoc block dropped `blockSnoc` node2+++--+-- Heuristic to decide whether to pick up and sink an assignment+-- Currently we pick up all assignments to local registers.  It might+-- be profitable to sink assignments to global regs too, but the+-- liveness analysis doesn't track those (yet) so we can't.+--+shouldSink :: DynFlags -> CmmNode e x -> Maybe Assignment+shouldSink dflags (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem dflags e)+  where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e+shouldSink _ _other = Nothing++--+-- discard dead assignments.  This doesn't do as good a job as+-- removeDeadAssignments, because it would need multiple passes+-- to get all the dead code, but it catches the common case of+-- superfluous reloads from the stack that the stack allocator+-- leaves behind.+--+-- Also we catch "r = r" here.  You might think it would fall+-- out of inlining, but the inliner will see that r is live+-- after the instruction and choose not to inline r in the rhs.+--+shouldDiscard :: CmmNode e x -> LocalRegSet -> Bool+shouldDiscard node live+   = case node of+       CmmAssign r (CmmReg r') | r == r' -> True+       CmmAssign (CmmLocal r) _ -> not (r `Set.member` live)+       _otherwise -> False+++toNode :: Assignment -> CmmNode O O+toNode (r,rhs,_) = CmmAssign (CmmLocal r) rhs++dropAssignmentsSimple :: DynFlags -> (Assignment -> Bool) -> Assignments+                      -> ([CmmNode O O], Assignments)+dropAssignmentsSimple dflags f = dropAssignments dflags (\a _ -> (f a, ())) ()++dropAssignments :: DynFlags -> (Assignment -> s -> (Bool, s)) -> s -> Assignments+                -> ([CmmNode O O], Assignments)+dropAssignments dflags should_drop state assigs+ = (dropped, reverse kept)+ where+   (dropped,kept) = go state assigs [] []++   go _ []             dropped kept = (dropped, kept)+   go state (assig : rest) dropped kept+      | conflict  = go state' rest (toNode assig : dropped) kept+      | otherwise = go state' rest dropped (assig:kept)+      where+        (dropit, state') = should_drop assig state+        conflict = dropit || any (conflicts dflags assig) dropped+++-- -----------------------------------------------------------------------------+-- Try to inline assignments into a node.+-- This also does constant folding for primpops, since+-- inlining opens up opportunities for doing so.++tryToInline+   :: DynFlags+   -> LocalRegSet               -- set of registers live after this+                                -- node.  We cannot inline anything+                                -- that is live after the node, unless+                                -- it is small enough to duplicate.+   -> CmmNode O x               -- The node to inline into+   -> Assignments               -- Assignments to inline+   -> (+        CmmNode O x             -- New node+      , Assignments             -- Remaining assignments+      )++tryToInline dflags live node assigs = go usages node emptyLRegSet assigs+ where+  usages :: UniqFM Int -- Maps each LocalReg to a count of how often it is used+  usages = foldLocalRegsUsed dflags addUsage emptyUFM node++  go _usages node _skipped [] = (node, [])++  go usages node skipped (a@(l,rhs,_) : rest)+   | cannot_inline           = dont_inline+   | occurs_none             = discard  -- Note [discard during inlining]+   | occurs_once             = inline_and_discard+   | isTrivial dflags rhs    = inline_and_keep+   | otherwise               = dont_inline+   where+        inline_and_discard = go usages' inl_node skipped rest+          where usages' = foldLocalRegsUsed dflags addUsage usages rhs++        discard = go usages node skipped rest++        dont_inline        = keep node  -- don't inline the assignment, keep it+        inline_and_keep    = keep inl_node -- inline the assignment, keep it++        keep node' = (final_node, a : rest')+          where (final_node, rest') = go usages' node' (insertLRegSet l skipped) rest+                usages' = foldLocalRegsUsed dflags (\m r -> addToUFM m r 2)+                                            usages rhs+                -- we must not inline anything that is mentioned in the RHS+                -- of a binding that we have already skipped, so we set the+                -- usages of the regs on the RHS to 2.++        cannot_inline = skipped `regsUsedIn` rhs -- Note [dependent assignments]+                        || l `elemLRegSet` skipped+                        || not (okToInline dflags rhs node)++        l_usages = lookupUFM usages l+        l_live   = l `elemRegSet` live++        occurs_once = not l_live && l_usages == Just 1+        occurs_none = not l_live && l_usages == Nothing++        inl_node = improveConditional (mapExpDeep inl_exp node)++        inl_exp :: CmmExpr -> CmmExpr+        -- inl_exp is where the inlining actually takes place!+        inl_exp (CmmReg    (CmmLocal l'))     | l == l' = rhs+        inl_exp (CmmRegOff (CmmLocal l') off) | l == l'+                    = cmmOffset dflags rhs off+                    -- re-constant fold after inlining+        inl_exp (CmmMachOp op args) = cmmMachOpFold dflags op args+        inl_exp other = other+++{- Note [improveConditional]++cmmMachOpFold tries to simplify conditionals to turn things like+  (a == b) != 1+into+  (a != b)+but there's one case it can't handle: when the comparison is over+floating-point values, we can't invert it, because floating-point+comparisons aren't invertible (because of NaNs).++But we *can* optimise this conditional by swapping the true and false+branches. Given+  CmmCondBranch ((a >## b) != 1) t f+we can turn it into+  CmmCondBranch (a >## b) f t++So here we catch conditionals that weren't optimised by cmmMachOpFold,+and apply above transformation to eliminate the comparison against 1.++It's tempting to just turn every != into == and then let cmmMachOpFold+do its thing, but that risks changing a nice fall-through conditional+into one that requires two jumps. (see swapcond_last in+CmmContFlowOpt), so instead we carefully look for just the cases where+we can eliminate a comparison.+-}+improveConditional :: CmmNode O x -> CmmNode O x+improveConditional+  (CmmCondBranch (CmmMachOp mop [x, CmmLit (CmmInt 1 _)]) t f l)+  | neLike mop, isComparisonExpr x+  = CmmCondBranch x f t (fmap not l)+  where+    neLike (MO_Ne _) = True+    neLike (MO_U_Lt _) = True   -- (x<y) < 1 behaves like (x<y) != 1+    neLike (MO_S_Lt _) = True   -- (x<y) < 1 behaves like (x<y) != 1+    neLike _ = False+improveConditional other = other++-- Note [dependent assignments]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If our assignment list looks like+--+--    [ y = e,  x = ... y ... ]+--+-- We cannot inline x.  Remember this list is really in reverse order,+-- so it means  x = ... y ...; y = e+--+-- Hence if we inline x, the outer assignment to y will capture the+-- reference in x's right hand side.+--+-- In this case we should rename the y in x's right-hand side,+-- i.e. change the list to [ y = e, x = ... y1 ..., y1 = y ]+-- Now we can go ahead and inline x.+--+-- For now we do nothing, because this would require putting+-- everything inside UniqSM.+--+-- One more variant of this (#7366):+--+--   [ y = e, y = z ]+--+-- If we don't want to inline y = e, because y is used many times, we+-- might still be tempted to inline y = z (because we always inline+-- trivial rhs's).  But of course we can't, because y is equal to e,+-- not z.++-- Note [discard during inlining]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Opportunities to discard assignments sometimes appear after we've+-- done some inlining.  Here's an example:+--+--      x = R1;+--      y = P64[x + 7];+--      z = P64[x + 15];+--      /* z is dead */+--      R1 = y & (-8);+--+-- The x assignment is trivial, so we inline it in the RHS of y, and+-- keep both x and y.  z gets dropped because it is dead, then we+-- inline y, and we have a dead assignment to x.  If we don't notice+-- that x is dead in tryToInline, we end up retaining it.++addUsage :: UniqFM Int -> LocalReg -> UniqFM Int+addUsage m r = addToUFM_C (+) m r 1++regsUsedIn :: LRegSet -> CmmExpr -> Bool+regsUsedIn ls _ | nullLRegSet ls = False+regsUsedIn ls e = wrapRecExpf f e False+  where f (CmmReg (CmmLocal l))      _ | l `elemLRegSet` ls = True+        f (CmmRegOff (CmmLocal l) _) _ | l `elemLRegSet` ls = True+        f _ z = z++-- we don't inline into CmmUnsafeForeignCall if the expression refers+-- to global registers.  This is a HACK to avoid global registers+-- clashing with C argument-passing registers, really the back-end+-- ought to be able to handle it properly, but currently neither PprC+-- nor the NCG can do it.  See Note [Register parameter passing]+-- See also StgCmmForeign:load_args_into_temps.+okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool+okToInline dflags expr node@(CmmUnsafeForeignCall{}) =+    not (globalRegistersConflict dflags expr node)+okToInline _ _ _ = True++-- -----------------------------------------------------------------------------++-- | @conflicts (r,e) node@ is @False@ if and only if the assignment+-- @r = e@ can be safely commuted past statement @node@.+conflicts :: DynFlags -> Assignment -> CmmNode O x -> Bool+conflicts dflags (r, rhs, addr) node++  -- (1) node defines registers used by rhs of assignment. This catches+  -- assignments and all three kinds of calls. See Note [Sinking and calls]+  | globalRegistersConflict dflags rhs node                       = True+  | localRegistersConflict  dflags rhs node                       = True++  -- (2) node uses register defined by assignment+  | foldRegsUsed dflags (\b r' -> r == r' || b) False node        = True++  -- (3) a store to an address conflicts with a read of the same memory+  | CmmStore addr' e <- node+  , memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True++  -- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively+  | HeapMem    <- addr, CmmAssign (CmmGlobal Hp) _ <- node        = True+  | StackMem   <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True+  | SpMem{}    <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True++  -- (5) foreign calls clobber heap: see Note [Foreign calls clobber heap]+  | CmmUnsafeForeignCall{} <- node, memConflicts addr AnyMem      = True++  -- (6) native calls clobber any memory+  | CmmCall{} <- node, memConflicts addr AnyMem                   = True++  -- (7) otherwise, no conflict+  | otherwise = False++-- Returns True if node defines any global registers that are used in the+-- Cmm expression+globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool+globalRegistersConflict dflags expr node =+    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmGlobal r) expr)+                 False node++-- Returns True if node defines any local registers that are used in the+-- Cmm expression+localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool+localRegistersConflict dflags expr node =+    foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmLocal  r) expr)+                 False node++-- Note [Sinking and calls]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We have three kinds of calls: normal (CmmCall), safe foreign (CmmForeignCall)+-- and unsafe foreign (CmmUnsafeForeignCall). We perform sinking pass after+-- stack layout (see Note [Sinking after stack layout]) which leads to two+-- invariants related to calls:+--+--   a) during stack layout phase all safe foreign calls are turned into+--      unsafe foreign calls (see Note [Lower safe foreign calls]). This+--      means that we will never encounter CmmForeignCall node when running+--      sinking after stack layout+--+--   b) stack layout saves all variables live across a call on the stack+--      just before making a call (remember we are not sinking assignments to+--      stack):+--+--       L1:+--          x = R1+--          P64[Sp - 16] = L2+--          P64[Sp - 8]  = x+--          Sp = Sp - 16+--          call f() returns L2+--       L2:+--+--      We will attempt to sink { x = R1 } but we will detect conflict with+--      { P64[Sp - 8]  = x } and hence we will drop { x = R1 } without even+--      checking whether it conflicts with { call f() }. In this way we will+--      never need to check any assignment conflicts with CmmCall. Remember+--      that we still need to check for potential memory conflicts.+--+-- So the result is that we only need to worry about CmmUnsafeForeignCall nodes+-- when checking conflicts (see Note [Unsafe foreign calls clobber caller-save registers]).+-- This assumption holds only when we do sinking after stack layout. If we run+-- it before stack layout we need to check for possible conflicts with all three+-- kinds of calls. Our `conflicts` function does that by using a generic+-- foldRegsDefd and foldRegsUsed functions defined in DefinerOfRegs and+-- UserOfRegs typeclasses.+--++-- An abstraction of memory read or written.+data AbsMem+  = NoMem            -- no memory accessed+  | AnyMem           -- arbitrary memory+  | HeapMem          -- definitely heap memory+  | StackMem         -- definitely stack memory+  | SpMem            -- <size>[Sp+n]+       {-# UNPACK #-} !Int+       {-# UNPACK #-} !Int++-- Having SpMem is important because it lets us float loads from Sp+-- past stores to Sp as long as they don't overlap, and this helps to+-- unravel some long sequences of+--    x1 = [Sp + 8]+--    x2 = [Sp + 16]+--    ...+--    [Sp + 8]  = xi+--    [Sp + 16] = xj+--+-- Note that SpMem is invalidated if Sp is changed, but the definition+-- of 'conflicts' above handles that.++-- ToDo: this won't currently fix the following commonly occurring code:+--    x1 = [R1 + 8]+--    x2 = [R1 + 16]+--    ..+--    [Hp - 8] = x1+--    [Hp - 16] = x2+--    ..++-- because [R1 + 8] and [Hp - 8] are both HeapMem.  We know that+-- assignments to [Hp + n] do not conflict with any other heap memory,+-- but this is tricky to nail down.  What if we had+--+--   x = Hp + n+--   [x] = ...+--+--  the store to [x] should be "new heap", not "old heap".+--  Furthermore, you could imagine that if we started inlining+--  functions in Cmm then there might well be reads of heap memory+--  that was written in the same basic block.  To take advantage of+--  non-aliasing of heap memory we will have to be more clever.++-- Note [Foreign calls clobber heap]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- It is tempting to say that foreign calls clobber only+-- non-heap/stack memory, but unfortunately we break this invariant in+-- the RTS.  For example, in stg_catch_retry_frame we call+-- stmCommitNestedTransaction() which modifies the contents of the+-- TRec it is passed (this actually caused incorrect code to be+-- generated).+--+-- Since the invariant is true for the majority of foreign calls,+-- perhaps we ought to have a special annotation for calls that can+-- modify heap/stack memory.  For now we just use the conservative+-- definition here.+--+-- Some CallishMachOp imply a memory barrier e.g. AtomicRMW and+-- therefore we should never float any memory operations across one of+-- these calls.+++bothMems :: AbsMem -> AbsMem -> AbsMem+bothMems NoMem    x         = x+bothMems x        NoMem     = x+bothMems HeapMem  HeapMem   = HeapMem+bothMems StackMem StackMem     = StackMem+bothMems (SpMem o1 w1) (SpMem o2 w2)+  | o1 == o2  = SpMem o1 (max w1 w2)+  | otherwise = StackMem+bothMems SpMem{}  StackMem  = StackMem+bothMems StackMem SpMem{}   = StackMem+bothMems _         _        = AnyMem++memConflicts :: AbsMem -> AbsMem -> Bool+memConflicts NoMem      _          = False+memConflicts _          NoMem      = False+memConflicts HeapMem    StackMem   = False+memConflicts StackMem   HeapMem    = False+memConflicts SpMem{}    HeapMem    = False+memConflicts HeapMem    SpMem{}    = False+memConflicts (SpMem o1 w1) (SpMem o2 w2)+  | o1 < o2   = o1 + w1 > o2+  | otherwise = o2 + w2 > o1+memConflicts _         _         = True++exprMem :: DynFlags -> CmmExpr -> AbsMem+exprMem dflags (CmmLoad addr w)  = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr)+exprMem dflags (CmmMachOp _ es)  = foldr bothMems NoMem (map (exprMem dflags) es)+exprMem _      _                 = NoMem++loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem+loadAddr dflags e w =+  case e of+   CmmReg r       -> regAddr dflags r 0 w+   CmmRegOff r i  -> regAddr dflags r i w+   _other | regUsedIn dflags spReg e -> StackMem+          | otherwise -> AnyMem++regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem+regAddr _      (CmmGlobal Sp) i w = SpMem i (widthInBytes w)+regAddr _      (CmmGlobal Hp) _ _ = HeapMem+regAddr _      (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps+regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself+regAddr _      _ _ _ = AnyMem++{-+Note [Inline GlobalRegs?]++Should we freely inline GlobalRegs?++Actually it doesn't make a huge amount of difference either way, so we+*do* currently treat GlobalRegs as "trivial" and inline them+everywhere, but for what it's worth, here is what I discovered when I+(SimonM) looked into this:++Common sense says we should not inline GlobalRegs, because when we+have++  x = R1++the register allocator will coalesce this assignment, generating no+code, and simply record the fact that x is bound to $rbx (or+whatever).  Furthermore, if we were to sink this assignment, then the+range of code over which R1 is live increases, and the range of code+over which x is live decreases.  All things being equal, it is better+for x to be live than R1, because R1 is a fixed register whereas x can+live in any register.  So we should neither sink nor inline 'x = R1'.++However, not inlining GlobalRegs can have surprising+consequences. e.g. (cgrun020)++  c3EN:+      _s3DB::P64 = R1;+      _c3ES::P64 = _s3DB::P64 & 7;+      if (_c3ES::P64 >= 2) goto c3EU; else goto c3EV;+  c3EU:+      _s3DD::P64 = P64[_s3DB::P64 + 6];+      _s3DE::P64 = P64[_s3DB::P64 + 14];+      I64[Sp - 8] = c3F0;+      R1 = _s3DE::P64;+      P64[Sp] = _s3DD::P64;++inlining the GlobalReg gives:++  c3EN:+      if (R1 & 7 >= 2) goto c3EU; else goto c3EV;+  c3EU:+      I64[Sp - 8] = c3F0;+      _s3DD::P64 = P64[R1 + 6];+      R1 = P64[R1 + 14];+      P64[Sp] = _s3DD::P64;++but if we don't inline the GlobalReg, instead we get:++      _s3DB::P64 = R1;+      if (_s3DB::P64 & 7 >= 2) goto c3EU; else goto c3EV;+  c3EU:+      I64[Sp - 8] = c3F0;+      R1 = P64[_s3DB::P64 + 14];+      P64[Sp] = P64[_s3DB::P64 + 6];++This looks better - we managed to inline _s3DD - but in fact it+generates an extra reg-reg move:++.Lc3EU:+        movq $c3F0_info,-8(%rbp)+        movq %rbx,%rax+        movq 14(%rbx),%rbx+        movq 6(%rax),%rax+        movq %rax,(%rbp)++because _s3DB is now live across the R1 assignment, we lost the+benefit of coalescing.++Who is at fault here?  Perhaps if we knew that _s3DB was an alias for+R1, then we would not sink a reference to _s3DB past the R1+assignment.  Or perhaps we *should* do that - we might gain by sinking+it, despite losing the coalescing opportunity.++Sometimes not inlining global registers wins by virtue of the rule+about not inlining into arguments of a foreign call, e.g. (T7163) this+is what happens when we inlined F1:++      _s3L2::F32 = F1;+      _c3O3::F32 = %MO_F_Mul_W32(F1, 10.0 :: W32);+      (_s3L7::F32) = call "ccall" arg hints:  []  result hints:  [] rintFloat(_c3O3::F32);++but if we don't inline F1:++      (_s3L7::F32) = call "ccall" arg hints:  []  result hints:  [] rintFloat(%MO_F_Mul_W32(_s3L2::F32,+                                                                                            10.0 :: W32));+-}
+ compiler/cmm/CmmSwitch.hs view
@@ -0,0 +1,500 @@+{-# LANGUAGE GADTs #-}+module CmmSwitch (+     SwitchTargets,+     mkSwitchTargets,+     switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned,+     mapSwitchTargets, switchTargetsToTable, switchTargetsFallThrough,+     switchTargetsToList, eqSwitchTargetWith,++     SwitchPlan(..),+     targetSupportsSwitch,+     createSwitchPlan,+  ) where++import GhcPrelude++import Outputable+import DynFlags+import Hoopl.Label (Label)++import Data.Maybe+import Data.List (groupBy)+import Data.Function (on)+import qualified Data.Map as M++-- Note [Cmm Switches, the general plan]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Compiling a high-level switch statement, as it comes out of a STG case+-- expression, for example, allows for a surprising amount of design decisions.+-- Therefore, we cleanly separated this from the Stg → Cmm transformation, as+-- well as from the actual code generation.+--+-- The overall plan is:+--  * The Stg → Cmm transformation creates a single `SwitchTargets` in+--    emitSwitch and emitCmmLitSwitch in StgCmmUtils.hs.+--    At this stage, they are unsuitable for code generation.+--  * A dedicated Cmm transformation (CmmImplementSwitchPlans) replaces these+--    switch statements with code that is suitable for code generation, i.e.+--    a nice balanced tree of decisions with dense jump tables in the leafs.+--    The actual planning of this tree is performed in pure code in createSwitchPlan+--    in this module. See Note [createSwitchPlan].+--  * The actual code generation will not do any further processing and+--    implement each CmmSwitch with a jump tables.+--+-- When compiling to LLVM or C, CmmImplementSwitchPlans leaves the switch+-- statements alone, as we can turn a SwitchTargets value into a nice+-- switch-statement in LLVM resp. C, and leave the rest to the compiler.+--+-- See Note [CmmSwitch vs. CmmImplementSwitchPlans] why the two module are+-- separated.++-----------------------------------------------------------------------------+-- Note [Magic Constants in CmmSwitch]+--+-- There are a lot of heuristics here that depend on magic values where it is+-- hard to determine the "best" value (for whatever that means). These are the+-- magic values:++-- | Number of consecutive default values allowed in a jump table. If there are+-- more of them, the jump tables are split.+--+-- Currently 7, as it costs 7 words of additional code when a jump table is+-- split (at least on x64, determined experimentally).+maxJumpTableHole :: Integer+maxJumpTableHole = 7++-- | Minimum size of a jump table. If the number is smaller, the switch is+-- implemented using conditionals.+-- Currently 5, because an if-then-else tree of 4 values is nice and compact.+minJumpTableSize :: Int+minJumpTableSize = 5++-- | Minimum non-zero offset for a jump table. See Note [Jump Table Offset].+minJumpTableOffset :: Integer+minJumpTableOffset = 2+++-----------------------------------------------------------------------------+-- Switch Targets++-- Note [SwitchTargets]:+-- ~~~~~~~~~~~~~~~~~~~~~+--+-- The branches of a switch are stored in a SwitchTargets, which consists of an+-- (optional) default jump target, and a map from values to jump targets.+--+-- If the default jump target is absent, the behaviour of the switch outside the+-- values of the map is undefined.+--+-- We use an Integer for the keys the map so that it can be used in switches on+-- unsigned as well as signed integers.+--+-- The map may be empty (we prune out-of-range branches here, so it could be us+-- emptying it).+--+-- Before code generation, the table needs to be brought into a form where all+-- entries are non-negative, so that it can be compiled into a jump table.+-- See switchTargetsToTable.+++-- | A value of type SwitchTargets contains the alternatives for a 'CmmSwitch'+-- value, and knows whether the value is signed, the possible range, an+-- optional default value and a map from values to jump labels.+data SwitchTargets =+    SwitchTargets+        Bool                       -- Signed values+        (Integer, Integer)         -- Range+        (Maybe Label)              -- Default value+        (M.Map Integer Label)      -- The branches+    deriving (Show, Eq)++-- | The smart constructor mkSwitchTargets normalises the map a bit:+--  * No entries outside the range+--  * No entries equal to the default+--  * No default if all elements have explicit values+mkSwitchTargets :: Bool -> (Integer, Integer) -> Maybe Label -> M.Map Integer Label -> SwitchTargets+mkSwitchTargets signed range@(lo,hi) mbdef ids+    = SwitchTargets signed range mbdef' ids'+  where+    ids' = dropDefault $ restrict ids+    mbdef' | defaultNeeded = mbdef+           | otherwise     = Nothing++    -- Drop entries outside the range, if there is a range+    restrict = restrictMap (lo,hi)++    -- Drop entries that equal the default, if there is a default+    dropDefault | Just l <- mbdef = M.filter (/= l)+                | otherwise       = id++    -- Check if the default is still needed+    defaultNeeded = fromIntegral (M.size ids') /= hi-lo+1+++-- | Changes all labels mentioned in the SwitchTargets value+mapSwitchTargets :: (Label -> Label) -> SwitchTargets -> SwitchTargets+mapSwitchTargets f (SwitchTargets signed range mbdef branches)+    = SwitchTargets signed range (fmap f mbdef) (fmap f branches)++-- | Returns the list of non-default branches of the SwitchTargets value+switchTargetsCases :: SwitchTargets -> [(Integer, Label)]+switchTargetsCases (SwitchTargets _ _ _ branches) = M.toList branches++-- | Return the default label of the SwitchTargets value+switchTargetsDefault :: SwitchTargets -> Maybe Label+switchTargetsDefault (SwitchTargets _ _ mbdef _) = mbdef++-- | Return the range of the SwitchTargets value+switchTargetsRange :: SwitchTargets -> (Integer, Integer)+switchTargetsRange (SwitchTargets _ range _ _) = range++-- | Return whether this is used for a signed value+switchTargetsSigned :: SwitchTargets -> Bool+switchTargetsSigned (SwitchTargets signed _ _ _) = signed++-- | switchTargetsToTable creates a dense jump table, usable for code generation.+--+-- Also returns an offset to add to the value; the list is 0-based on the+-- result of that addition.+--+-- The conversion from Integer to Int is a bit of a wart, as the actual+-- scrutinee might be an unsigned word, but it just works, due to wrap-around+-- arithmetic (as verified by the CmmSwitchTest test case).+switchTargetsToTable :: SwitchTargets -> (Int, [Maybe Label])+switchTargetsToTable (SwitchTargets _ (lo,hi) mbdef branches)+    = (fromIntegral (-start), [ labelFor i | i <- [start..hi] ])+  where+    labelFor i = case M.lookup i branches of Just l -> Just l+                                             Nothing -> mbdef+    start | lo >= 0 && lo < minJumpTableOffset  = 0  -- See Note [Jump Table Offset]+          | otherwise                           = lo++-- Note [Jump Table Offset]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Usually, the code for a jump table starting at x will first subtract x from+-- the value, to avoid a large amount of empty entries. But if x is very small,+-- the extra entries are no worse than the subtraction in terms of code size, and+-- not having to do the subtraction is quicker.+--+-- I.e. instead of+--     _u20N:+--             leaq -1(%r14),%rax+--             jmp *_n20R(,%rax,8)+--     _n20R:+--             .quad   _c20p+--             .quad   _c20q+-- do+--     _u20N:+--             jmp *_n20Q(,%r14,8)+--+--     _n20Q:+--             .quad   0+--             .quad   _c20p+--             .quad   _c20q+--             .quad   _c20r++-- | The list of all labels occuring in the SwitchTargets value.+switchTargetsToList :: SwitchTargets -> [Label]+switchTargetsToList (SwitchTargets _ _ mbdef branches)+    = maybeToList mbdef ++ M.elems branches++-- | Groups cases with equal targets, suitable for pretty-printing to a+-- c-like switch statement with fall-through semantics.+switchTargetsFallThrough :: SwitchTargets -> ([([Integer], Label)], Maybe Label)+switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef)+  where+    groups = map (\xs -> (map fst xs, snd (head xs))) $+             groupBy ((==) `on` snd) $+             M.toList branches++-- | Custom equality helper, needed for "CmmCommonBlockElim"+eqSwitchTargetWith :: (Label -> Label -> Bool) -> SwitchTargets -> SwitchTargets -> Bool+eqSwitchTargetWith eq (SwitchTargets signed1 range1 mbdef1 ids1) (SwitchTargets signed2 range2 mbdef2 ids2) =+    signed1 == signed2 && range1 == range2 && goMB mbdef1 mbdef2 && goList (M.toList ids1) (M.toList ids2)+  where+    goMB Nothing Nothing = True+    goMB (Just l1) (Just l2) = l1 `eq` l2+    goMB _ _ = False+    goList [] [] = True+    goList ((i1,l1):ls1) ((i2,l2):ls2) = i1 == i2 && l1 `eq` l2 && goList ls1 ls2+    goList _ _ = False++-----------------------------------------------------------------------------+-- Code generation for Switches+++-- | A SwitchPlan abstractly describes how a Switch statement ought to be+-- implemented. See Note [createSwitchPlan]+data SwitchPlan+    = Unconditionally Label+    | IfEqual Integer Label SwitchPlan+    | IfLT Bool Integer SwitchPlan SwitchPlan+    | JumpTable SwitchTargets+  deriving Show+--+-- Note [createSwitchPlan]+-- ~~~~~~~~~~~~~~~~~~~~~~~+--+-- A SwitchPlan describes how a Switch statement is to be broken down into+-- smaller pieces suitable for code generation.+--+-- createSwitchPlan creates such a switch plan, in these steps:+--  1. It splits the switch statement at segments of non-default values that+--     are too large. See splitAtHoles and Note [Magic Constants in CmmSwitch]+--  2. Too small jump tables should be avoided, so we break up smaller pieces+--     in breakTooSmall.+--  3. We fill in the segments between those pieces with a jump to the default+--     label (if there is one), returning a SeparatedList in mkFlatSwitchPlan+--  4. We find and replace two less-than branches by a single equal-to-test in+--     findSingleValues+--  5. The thus collected pieces are assembled to a balanced binary tree.++{-+  Note [Two alts + default]+  ~~~~~~~~~~~~~~~~~~~~~~~~~++Discussion and a bit more info at #14644++When dealing with a switch of the form:+switch(e) {+  case 1: goto l1;+  case 3000: goto l2;+  default: goto ldef;+}++If we treat it as a sparse jump table we would generate:++if (e > 3000) //Check if value is outside of the jump table.+    goto ldef;+else {+    if (e < 3000) { //Compare to upper value+        if(e != 1) //Compare to remaining value+            goto ldef;+          else+            goto l2;+    }+    else+        goto l1;+}++Instead we special case this to :++if (e==1) goto l1;+else if (e==3000) goto l2;+else goto l3;++This means we have:+* Less comparisons for: 1,<3000+* Unchanged for 3000+* One more for >3000++This improves code in a few ways:+* One comparison less means smaller code which helps with cache.+* It exchanges a taken jump for two jumps no taken in the >range case.+  Jumps not taken are cheaper (See Agner guides) making this about as fast.+* For all other cases the first range check is removed making it faster.++The end result is that the change is not measurably slower for the case+>3000 and faster for the other cases.++This makes running this kind of match in an inner loop cheaper by 10-20%+depending on the data.+In nofib this improves wheel-sieve1 by 4-9% depending on problem+size.++We could also add a second conditional jump after the comparison to+keep the range check like this:+    cmp 3000, rArgument+    jg <default>+    je <branch 2>+While this is fairly cheap it made no big difference for the >3000 case+and slowed down all other cases making it not worthwhile.+-}+++-- | Does the target support switch out of the box? Then leave this to the+-- target!+targetSupportsSwitch :: HscTarget -> Bool+targetSupportsSwitch HscC = True+targetSupportsSwitch HscLlvm = True+targetSupportsSwitch _ = False++-- | This function creates a SwitchPlan from a SwitchTargets value, breaking it+-- down into smaller pieces suitable for code generation.+createSwitchPlan :: SwitchTargets -> SwitchPlan+-- Lets do the common case of a singleton map quicky and efficiently (#10677)+createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m)+    | [(x, l)] <- M.toList m+    = IfEqual x l (Unconditionally defLabel)+-- And another common case, matching "booleans"+createSwitchPlan (SwitchTargets _signed (lo,hi) Nothing m)+    | [(x1, l1), (_x2,l2)] <- M.toAscList m+    --Checking If |range| = 2 is enough if we have two unique literals+    , hi - lo == 1+    = IfEqual x1 l1 (Unconditionally l2)+-- See Note [Two alts + default]+createSwitchPlan (SwitchTargets _signed _range (Just defLabel) m)+    | [(x1, l1), (x2,l2)] <- M.toAscList m+    = IfEqual x1 l1 (IfEqual x2 l2 (Unconditionally defLabel))+createSwitchPlan (SwitchTargets signed range mbdef m) =+    -- pprTrace "createSwitchPlan" (text (show ids) $$ text (show (range,m)) $$ text (show pieces) $$ text (show flatPlan) $$ text (show plan)) $+    plan+  where+    pieces = concatMap breakTooSmall $ splitAtHoles maxJumpTableHole m+    flatPlan = findSingleValues $ mkFlatSwitchPlan signed mbdef range pieces+    plan = buildTree signed $ flatPlan+++---+--- Step 1: Splitting at large holes+---+splitAtHoles :: Integer -> M.Map Integer a -> [M.Map Integer a]+splitAtHoles _        m | M.null m = []+splitAtHoles holeSize m = map (\range -> restrictMap range m) nonHoles+  where+    holes = filter (\(l,h) -> h - l > holeSize) $ zip (M.keys m) (tail (M.keys m))+    nonHoles = reassocTuples lo holes hi++    (lo,_) = M.findMin m+    (hi,_) = M.findMax m++---+--- Step 2: Avoid small jump tables+---+-- We do not want jump tables below a certain size. This breaks them up+-- (into singleton maps, for now).+breakTooSmall :: M.Map Integer a -> [M.Map Integer a]+breakTooSmall m+  | M.size m > minJumpTableSize = [m]+  | otherwise                   = [M.singleton k v | (k,v) <- M.toList m]++---+---  Step 3: Fill in the blanks+---++-- | A FlatSwitchPlan is a list of SwitchPlans, with an integer inbetween every+-- two entries, dividing the range.+-- So if we have (abusing list syntax) [plan1,n,plan2], then we use plan1 if+-- the expression is < n, and plan2 otherwise.++type FlatSwitchPlan = SeparatedList Integer SwitchPlan++mkFlatSwitchPlan :: Bool -> Maybe Label -> (Integer, Integer) -> [M.Map Integer Label] -> FlatSwitchPlan++-- If we have no default (i.e. undefined where there is no entry), we can+-- branch at the minimum of each map+mkFlatSwitchPlan _ Nothing _ [] = pprPanic "mkFlatSwitchPlan with nothing left to do" empty+mkFlatSwitchPlan signed  Nothing _ (m:ms)+  = (mkLeafPlan signed Nothing m , [ (fst (M.findMin m'), mkLeafPlan signed Nothing m') | m' <- ms ])++-- If we have a default, we have to interleave segments that jump+-- to the default between the maps+mkFlatSwitchPlan signed (Just l) r ms = let ((_,p1):ps) = go r ms in (p1, ps)+  where+    go (lo,hi) []+        | lo > hi = []+        | otherwise = [(lo, Unconditionally l)]+    go (lo,hi) (m:ms)+        | lo < min+        = (lo, Unconditionally l) : go (min,hi) (m:ms)+        | lo == min+        = (lo, mkLeafPlan signed (Just l) m) : go (max+1,hi) ms+        | otherwise+        = pprPanic "mkFlatSwitchPlan" (integer lo <+> integer min)+      where+        min = fst (M.findMin m)+        max = fst (M.findMax m)+++mkLeafPlan :: Bool -> Maybe Label -> M.Map Integer Label -> SwitchPlan+mkLeafPlan signed mbdef m+    | [(_,l)] <- M.toList m -- singleton map+    = Unconditionally l+    | otherwise+    = JumpTable $ mkSwitchTargets signed (min,max) mbdef m+  where+    min = fst (M.findMin m)+    max = fst (M.findMax m)++---+---  Step 4: Reduce the number of branches using ==+---++-- A sequence of three unconditional jumps, with the outer two pointing to the+-- same value and the bounds off by exactly one can be improved+findSingleValues :: FlatSwitchPlan -> FlatSwitchPlan+findSingleValues (Unconditionally l, (i, Unconditionally l2) : (i', Unconditionally l3) : xs)+  | l == l3 && i + 1 == i'+  = findSingleValues (IfEqual i l2 (Unconditionally l), xs)+findSingleValues (p, (i,p'):xs)+  = (p,i) `consSL` findSingleValues (p', xs)+findSingleValues (p, [])+  = (p, [])++---+---  Step 5: Actually build the tree+---++-- Build a balanced tree from a separated list+buildTree :: Bool -> FlatSwitchPlan -> SwitchPlan+buildTree _ (p,[]) = p+buildTree signed sl = IfLT signed m (buildTree signed sl1) (buildTree signed sl2)+  where+    (sl1, m, sl2) = divideSL sl++++--+-- Utility data type: Non-empty lists with extra markers in between each+-- element:+--++type SeparatedList b a = (a, [(b,a)])++consSL :: (a, b) -> SeparatedList b a -> SeparatedList b a+consSL (a, b) (a', xs) = (a, (b,a'):xs)++divideSL :: SeparatedList b a -> (SeparatedList b a, b, SeparatedList b a)+divideSL (_,[]) = error "divideSL: Singleton SeparatedList"+divideSL (p,xs) = ((p, xs1), m, (p', xs2))+  where+    (xs1, (m,p'):xs2) = splitAt (length xs `div` 2) xs++--+-- Other Utilities+--++restrictMap :: (Integer,Integer) -> M.Map Integer b -> M.Map Integer b+restrictMap (lo,hi) m = mid+  where (_,   mid_hi) = M.split (lo-1) m+        (mid, _) =      M.split (hi+1) mid_hi++-- for example: reassocTuples a [(b,c),(d,e)] f == [(a,b),(c,d),(e,f)]+reassocTuples :: a -> [(a,a)] -> a -> [(a,a)]+reassocTuples initial [] last+    = [(initial,last)]+reassocTuples initial ((a,b):tuples) last+    = (initial,a) : reassocTuples b tuples last++-- Note [CmmSwitch vs. CmmImplementSwitchPlans]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- I (Joachim) separated the two somewhat closely related modules+--+--  - CmmSwitch, which provides the CmmSwitchTargets type and contains the strategy+--    for implementing a Cmm switch (createSwitchPlan), and+--  - CmmImplementSwitchPlans, which contains the actuall Cmm graph modification,+--+-- for these reasons:+--+--  * CmmSwitch is very low in the dependency tree, i.e. does not depend on any+--    GHC specific modules at all (with the exception of Output and Hoople+--    (Literal)). CmmImplementSwitchPlans is the Cmm transformation and hence very+--    high in the dependency tree.+--  * CmmSwitch provides the CmmSwitchTargets data type, which is abstract, but+--    used in CmmNodes.+--  * Because CmmSwitch is low in the dependency tree, the separation allows+--    for more parallelism when building GHC.+--  * The interaction between the modules is very explicit and easy to+--    understand, due to the small and simple interface.
+ compiler/cmm/CmmUtils.hs view
@@ -0,0 +1,592 @@+{-# LANGUAGE GADTs, RankNTypes #-}++-----------------------------------------------------------------------------+--+-- Cmm utilities.+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module CmmUtils(+        -- CmmType+        primRepCmmType, slotCmmType, slotForeignHint,+        typeCmmType, typeForeignHint, primRepForeignHint,++        -- CmmLit+        zeroCLit, mkIntCLit,+        mkWordCLit, packHalfWordsCLit,+        mkByteStringCLit,+        mkDataLits, mkRODataLits,+        mkStgWordCLit,++        -- CmmExpr+        mkIntExpr, zeroExpr,+        mkLblExpr,+        cmmRegOff,  cmmOffset,  cmmLabelOff,  cmmOffsetLit,  cmmOffsetExpr,+        cmmRegOffB, cmmOffsetB, cmmLabelOffB, cmmOffsetLitB, cmmOffsetExprB,+        cmmRegOffW, cmmOffsetW, cmmLabelOffW, cmmOffsetLitW, cmmOffsetExprW,+        cmmIndex, cmmIndexExpr, cmmLoadIndex, cmmLoadIndexW,+        cmmNegate,+        cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,+        cmmSLtWord,+        cmmNeWord, cmmEqWord,+        cmmOrWord, cmmAndWord,+        cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,+        cmmToWord,++        isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr,++        baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,+        currentTSOExpr, currentNurseryExpr, cccsExpr,++        -- Statics+        blankWord,++        -- Tagging+        cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,+        cmmConstrTag1,++        -- Overlap and usage+        regsOverlap, regUsedIn,++        -- Liveness and bitmaps+        mkLiveness,++        -- * Operations that probably don't belong here+        modifyGraph,++        ofBlockMap, toBlockMap,+        ofBlockList, toBlockList, bodyToBlockList,+        toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,+        foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1,++        -- * Ticks+        blockTicks+  ) where++import GhcPrelude++import TyCon    ( PrimRep(..), PrimElemRep(..) )+import RepType  ( UnaryType, SlotTy (..), typePrimRep1 )++import SMRep+import Cmm+import BlockId+import CLabel+import Outputable+import DynFlags+import CodeGen.Platform++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Bits+import Hoopl.Graph+import Hoopl.Label+import Hoopl.Block+import Hoopl.Collections++---------------------------------------------------+--+--      CmmTypes+--+---------------------------------------------------++primRepCmmType :: DynFlags -> PrimRep -> CmmType+primRepCmmType _      VoidRep          = panic "primRepCmmType:VoidRep"+primRepCmmType dflags LiftedRep        = gcWord dflags+primRepCmmType dflags UnliftedRep      = gcWord dflags+primRepCmmType dflags IntRep           = bWord dflags+primRepCmmType dflags WordRep          = bWord dflags+primRepCmmType _      Int8Rep          = b8+primRepCmmType _      Word8Rep         = b8+primRepCmmType _      Int16Rep         = b16+primRepCmmType _      Word16Rep        = b16+primRepCmmType _      Int64Rep         = b64+primRepCmmType _      Word64Rep        = b64+primRepCmmType dflags AddrRep          = bWord dflags+primRepCmmType _      FloatRep         = f32+primRepCmmType _      DoubleRep        = f64+primRepCmmType _      (VecRep len rep) = vec len (primElemRepCmmType rep)++slotCmmType :: DynFlags -> SlotTy -> CmmType+slotCmmType dflags PtrSlot    = gcWord dflags+slotCmmType dflags WordSlot   = bWord dflags+slotCmmType _      Word64Slot = b64+slotCmmType _      FloatSlot  = f32+slotCmmType _      DoubleSlot = f64++primElemRepCmmType :: PrimElemRep -> CmmType+primElemRepCmmType Int8ElemRep   = b8+primElemRepCmmType Int16ElemRep  = b16+primElemRepCmmType Int32ElemRep  = b32+primElemRepCmmType Int64ElemRep  = b64+primElemRepCmmType Word8ElemRep  = b8+primElemRepCmmType Word16ElemRep = b16+primElemRepCmmType Word32ElemRep = b32+primElemRepCmmType Word64ElemRep = b64+primElemRepCmmType FloatElemRep  = f32+primElemRepCmmType DoubleElemRep = f64++typeCmmType :: DynFlags -> UnaryType -> CmmType+typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty)++primRepForeignHint :: PrimRep -> ForeignHint+primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep"+primRepForeignHint LiftedRep    = AddrHint+primRepForeignHint UnliftedRep  = AddrHint+primRepForeignHint IntRep       = SignedHint+primRepForeignHint Int8Rep      = SignedHint+primRepForeignHint Int16Rep     = SignedHint+primRepForeignHint Int64Rep     = SignedHint+primRepForeignHint WordRep      = NoHint+primRepForeignHint Word8Rep     = NoHint+primRepForeignHint Word16Rep    = NoHint+primRepForeignHint Word64Rep    = NoHint+primRepForeignHint AddrRep      = AddrHint -- NB! AddrHint, but NonPtrArg+primRepForeignHint FloatRep     = NoHint+primRepForeignHint DoubleRep    = NoHint+primRepForeignHint (VecRep {})  = NoHint++slotForeignHint :: SlotTy -> ForeignHint+slotForeignHint PtrSlot       = AddrHint+slotForeignHint WordSlot      = NoHint+slotForeignHint Word64Slot    = NoHint+slotForeignHint FloatSlot     = NoHint+slotForeignHint DoubleSlot    = NoHint++typeForeignHint :: UnaryType -> ForeignHint+typeForeignHint = primRepForeignHint . typePrimRep1++---------------------------------------------------+--+--      CmmLit+--+---------------------------------------------------++-- XXX: should really be Integer, since Int doesn't necessarily cover+-- the full range of target Ints.+mkIntCLit :: DynFlags -> Int -> CmmLit+mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)++mkIntExpr :: DynFlags -> Int -> CmmExpr+mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i++zeroCLit :: DynFlags -> CmmLit+zeroCLit dflags = CmmInt 0 (wordWidth dflags)++zeroExpr :: DynFlags -> CmmExpr+zeroExpr dflags = CmmLit (zeroCLit dflags)++mkWordCLit :: DynFlags -> Integer -> CmmLit+mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)++mkByteStringCLit+  :: CLabel -> ByteString -> (CmmLit, GenCmmDecl CmmStatics info stmt)+-- We have to make a top-level decl for the string,+-- and return a literal pointing to it+mkByteStringCLit lbl bytes+  = (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes])+  where+    -- This can not happen for String literals (as there \NUL is replaced by+    -- C0 80). However, it can happen with Addr# literals.+    sec = if 0 `BS.elem` bytes then ReadOnlyData else CString++mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt+-- Build a data-segment data block+mkDataLits section lbl lits+  = CmmData section (Statics lbl $ map CmmStaticLit lits)++mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt+-- Build a read-only data block+mkRODataLits lbl lits+  = mkDataLits section lbl lits+  where+    section | any needsRelocation lits = Section RelocatableReadOnlyData lbl+            | otherwise                = Section ReadOnlyData lbl+    needsRelocation (CmmLabel _)      = True+    needsRelocation (CmmLabelOff _ _) = True+    needsRelocation _                 = False++mkStgWordCLit :: DynFlags -> StgWord -> CmmLit+mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)++packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit+-- Make a single word literal in which the lower_half_word is+-- at the lower address, and the upper_half_word is at the+-- higher address+-- ToDo: consider using half-word lits instead+--       but be careful: that's vulnerable when reversed+packHalfWordsCLit dflags lower_half_word upper_half_word+   = if wORDS_BIGENDIAN dflags+     then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS dflags) .|. u)+     else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS dflags))+    where l = fromStgHalfWord lower_half_word+          u = fromStgHalfWord upper_half_word++---------------------------------------------------+--+--      CmmExpr+--+---------------------------------------------------++mkLblExpr :: CLabel -> CmmExpr+mkLblExpr lbl = CmmLit (CmmLabel lbl)++cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr+-- assumes base and offset have the same CmmType+cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n)+cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off]++cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr+cmmOffset _ e                 0        = e+cmmOffset _ (CmmReg reg)      byte_off = cmmRegOff reg byte_off+cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)+cmmOffset _ (CmmLit lit)      byte_off = CmmLit (cmmOffsetLit lit byte_off)+cmmOffset _ (CmmStackSlot area off) byte_off+  = CmmStackSlot area (off - byte_off)+  -- note stack area offsets increase towards lower addresses+cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2+  = CmmMachOp (MO_Add rep)+              [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]+cmmOffset dflags expr byte_off+  = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]+  where+    width = cmmExprWidth dflags expr++-- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above.+cmmRegOff :: CmmReg -> Int -> CmmExpr+cmmRegOff reg 0        = CmmReg reg+cmmRegOff reg byte_off = CmmRegOff reg byte_off++cmmOffsetLit :: CmmLit -> Int -> CmmLit+cmmOffsetLit (CmmLabel l)      byte_off = cmmLabelOff l byte_off+cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff l (m+byte_off)+cmmOffsetLit (CmmLabelDiffOff l1 l2 m w) byte_off+                                        = CmmLabelDiffOff l1 l2 (m+byte_off) w+cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep+cmmOffsetLit _                 byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)++cmmLabelOff :: CLabel -> Int -> CmmLit+-- Smart constructor for CmmLabelOff+cmmLabelOff lbl 0        = CmmLabel lbl+cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off++-- | Useful for creating an index into an array, with a statically known offset.+-- The type is the element type; used for making the multiplier+cmmIndex :: DynFlags+         -> Width       -- Width w+         -> CmmExpr     -- Address of vector of items of width w+         -> Int         -- Which element of the vector (0 based)+         -> CmmExpr     -- Address of i'th element+cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)++-- | Useful for creating an index into an array, with an unknown offset.+cmmIndexExpr :: DynFlags+             -> Width           -- Width w+             -> CmmExpr         -- Address of vector of items of width w+             -> CmmExpr         -- Which element of the vector (0 based)+             -> CmmExpr         -- Address of i'th element+cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n)+cmmIndexExpr dflags width base idx =+  cmmOffsetExpr dflags base byte_off+  where+    idx_w = cmmExprWidth dflags idx+    byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)]++cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr+cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty++-- The "B" variants take byte offsets+cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr+cmmRegOffB = cmmRegOff++cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr+cmmOffsetB = cmmOffset++cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr+cmmOffsetExprB = cmmOffsetExpr++cmmLabelOffB :: CLabel -> ByteOff -> CmmLit+cmmLabelOffB = cmmLabelOff++cmmOffsetLitB :: CmmLit -> ByteOff -> CmmLit+cmmOffsetLitB = cmmOffsetLit++-----------------------+-- The "W" variants take word offsets++cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr+-- The second arg is a *word* offset; need to change it to bytes+cmmOffsetExprW dflags  e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n)+cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off++cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr+cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n)++cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr+cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off)++cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit+cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off)++cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit+cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off)++cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr+cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty++-----------------------+cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,+  cmmSLtWord,+  cmmNeWord, cmmEqWord,+  cmmOrWord, cmmAndWord,+  cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord+  :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr+cmmOrWord dflags  e1 e2 = CmmMachOp (mo_wordOr dflags)  [e1, e2]+cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2]+cmmNeWord dflags  e1 e2 = CmmMachOp (mo_wordNe dflags)  [e1, e2]+cmmEqWord dflags  e1 e2 = CmmMachOp (mo_wordEq dflags)  [e1, e2]+cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2]+cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2]+cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2]+cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]+cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2]+cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2]+cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2]+cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2]+cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2]++cmmNegate :: DynFlags -> CmmExpr -> CmmExpr+cmmNegate _      (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)+cmmNegate dflags e                       = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]++blankWord :: DynFlags -> CmmStatic+blankWord dflags = CmmUninitialised (wORD_SIZE dflags)++cmmToWord :: DynFlags -> CmmExpr -> CmmExpr+cmmToWord dflags e+  | w == word  = e+  | otherwise  = CmmMachOp (MO_UU_Conv w word) [e]+  where+    w = cmmExprWidth dflags e+    word = wordWidth dflags++---------------------------------------------------+--+--      CmmExpr predicates+--+---------------------------------------------------++isTrivialCmmExpr :: CmmExpr -> Bool+isTrivialCmmExpr (CmmLoad _ _)      = False+isTrivialCmmExpr (CmmMachOp _ _)    = False+isTrivialCmmExpr (CmmLit _)         = True+isTrivialCmmExpr (CmmReg _)         = True+isTrivialCmmExpr (CmmRegOff _ _)    = True+isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"++hasNoGlobalRegs :: CmmExpr -> Bool+hasNoGlobalRegs (CmmLoad e _)              = hasNoGlobalRegs e+hasNoGlobalRegs (CmmMachOp _ es)           = all hasNoGlobalRegs es+hasNoGlobalRegs (CmmLit _)                 = True+hasNoGlobalRegs (CmmReg (CmmLocal _))      = True+hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True+hasNoGlobalRegs _ = False++isLit :: CmmExpr -> Bool+isLit (CmmLit _) = True+isLit _          = False++isComparisonExpr :: CmmExpr -> Bool+isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op+isComparisonExpr _                  = False++---------------------------------------------------+--+--      Tagging+--+---------------------------------------------------++-- Tag bits mask+cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr+cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)+cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))++-- Used to untag a possibly tagged pointer+-- A static label need not be untagged+cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr+cmmUntag _ e@(CmmLit (CmmLabel _)) = e+-- Default case+cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)++-- Test if a closure pointer is untagged+cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)++-- Get constructor tag, but one based.+cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)+++-----------------------------------------------------------------------------+-- Overlap and usage++-- | Returns True if the two STG registers overlap on the specified+-- platform, in the sense that writing to one will clobber the+-- other. This includes the case that the two registers are the same+-- STG register. See Note [Overlapping global registers] for details.+regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool+regsOverlap dflags (CmmGlobal g) (CmmGlobal g')+  | Just real  <- globalRegMaybe (targetPlatform dflags) g,+    Just real' <- globalRegMaybe (targetPlatform dflags) g',+    real == real'+    = True+regsOverlap _ reg reg' = reg == reg'++-- | Returns True if the STG register is used by the expression, in+-- the sense that a store to the register might affect the value of+-- the expression.+--+-- We must check for overlapping registers and not just equal+-- registers here, otherwise CmmSink may incorrectly reorder+-- assignments that conflict due to overlap. See #10521 and Note+-- [Overlapping global registers].+regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool+regUsedIn dflags = regUsedIn_ where+  _   `regUsedIn_` CmmLit _         = False+  reg `regUsedIn_` CmmLoad e  _     = reg `regUsedIn_` e+  reg `regUsedIn_` CmmReg reg'      = regsOverlap dflags reg reg'+  reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg'+  reg `regUsedIn_` CmmMachOp _ es   = any (reg `regUsedIn_`) es+  _   `regUsedIn_` CmmStackSlot _ _ = False++--------------------------------------------+--+--        mkLiveness+--+---------------------------------------------++mkLiveness :: DynFlags -> [LocalReg] -> Liveness+mkLiveness _      [] = []+mkLiveness dflags (reg:regs)+  = bits ++ mkLiveness dflags regs+  where+    sizeW = (widthInBytes (typeWidth (localRegType reg)) + wORD_SIZE dflags - 1)+            `quot` wORD_SIZE dflags+            -- number of words, rounded up+    bits = replicate sizeW is_non_ptr -- True <=> Non Ptr++    is_non_ptr = not $ isGcPtrType (localRegType reg)+++-- ============================================== -+-- ============================================== -+-- ============================================== -++---------------------------------------------------+--+--      Manipulating CmmGraphs+--+---------------------------------------------------++modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'+modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}++toBlockMap :: CmmGraph -> LabelMap CmmBlock+toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body++ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph+ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}++toBlockList :: CmmGraph -> [CmmBlock]+toBlockList g = mapElems $ toBlockMap g++-- | like 'toBlockList', but the entry block always comes first+toBlockListEntryFirst :: CmmGraph -> [CmmBlock]+toBlockListEntryFirst g+  | mapNull m  = []+  | otherwise  = entry_block : others+  where+    m = toBlockMap g+    entry_id = g_entry g+    Just entry_block = mapLookup entry_id m+    others = filter ((/= entry_id) . entryLabel) (mapElems m)++-- | Like 'toBlockListEntryFirst', but we strive to ensure that we order blocks+-- so that the false case of a conditional jumps to the next block in the output+-- list of blocks. This matches the way OldCmm blocks were output since in+-- OldCmm the false case was a fallthrough, whereas in Cmm conditional branches+-- have both true and false successors. Block ordering can make a big difference+-- in performance in the LLVM backend. Note that we rely crucially on the order+-- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode+-- defined in cmm/CmmNode.hs. -GBM+toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]+toBlockListEntryFirstFalseFallthrough g+  | mapNull m  = []+  | otherwise  = dfs setEmpty [entry_block]+  where+    m = toBlockMap g+    entry_id = g_entry g+    Just entry_block = mapLookup entry_id m++    dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]+    dfs _ [] = []+    dfs visited (block:bs)+      | id `setMember` visited = dfs visited bs+      | otherwise              = block : dfs (setInsert id visited) bs'+      where id = entryLabel block+            bs' = foldr add_id bs (successors block)+            add_id id bs = case mapLookup id m of+                              Just b  -> b : bs+                              Nothing -> bs++ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph+ofBlockList entry blocks = CmmGraph { g_entry = entry+                                    , g_graph = GMany NothingO body NothingO }+  where body = foldr addBlock emptyBody blocks++bodyToBlockList :: Body CmmNode -> [CmmBlock]+bodyToBlockList body = mapElems body++mapGraphNodes :: ( CmmNode C O -> CmmNode C O+                 , CmmNode O O -> CmmNode O O+                 , CmmNode O C -> CmmNode O C)+              -> CmmGraph -> CmmGraph+mapGraphNodes funs@(mf,_,_) g =+  ofBlockMap (entryLabel $ mf $ CmmEntry (g_entry g) GlobalScope) $+  mapMap (mapBlock3' funs) $ toBlockMap g++mapGraphNodes1 :: (forall e x. CmmNode e x -> CmmNode e x) -> CmmGraph -> CmmGraph+mapGraphNodes1 f = modifyGraph (mapGraph f)+++foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a+foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g++revPostorder :: CmmGraph -> [CmmBlock]+revPostorder g = {-# SCC "revPostorder" #-}+    revPostorderFrom (toBlockMap g) (g_entry g)++-------------------------------------------------+-- Tick utilities++-- | Extract all tick annotations from the given block+blockTicks :: Block CmmNode C C -> [CmmTickish]+blockTicks b = reverse $ foldBlockNodesF goStmt b []+  where goStmt :: CmmNode e x -> [CmmTickish] -> [CmmTickish]+        goStmt  (CmmTick t) ts = t:ts+        goStmt  _other      ts = ts+++-- -----------------------------------------------------------------------------+-- Access to common global registers++baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr,+  spLimExpr, hpLimExpr, cccsExpr :: CmmExpr+baseExpr = CmmReg baseReg+spExpr = CmmReg spReg+spLimExpr = CmmReg spLimReg+hpExpr = CmmReg hpReg+hpLimExpr = CmmReg hpLimReg+currentTSOExpr = CmmReg currentTSOReg+currentNurseryExpr = CmmReg currentNurseryReg+cccsExpr = CmmReg cccsReg
+ compiler/cmm/Debug.hs view
@@ -0,0 +1,550 @@+{-# LANGUAGE GADTs #-}++-----------------------------------------------------------------------------+--+-- Debugging data+--+-- Association of debug data on the Cmm level, with methods to encode it in+-- event log format for later inclusion in profiling event logs.+--+-----------------------------------------------------------------------------++module Debug (++  DebugBlock(..), dblIsEntry,+  cmmDebugGen,+  cmmDebugLabels,+  cmmDebugLink,+  debugToMap,++  -- * Unwinding information+  UnwindTable, UnwindPoint(..),+  UnwindExpr(..), toUnwindExpr+  ) where++import GhcPrelude++import BlockId+import CLabel+import Cmm+import CmmUtils+import CoreSyn+import FastString      ( nilFS, mkFastString )+import Module+import Outputable+import PprCore         ()+import PprCmmExpr      ( pprExpr )+import SrcLoc+import Util            ( seqList )++import Hoopl.Block+import Hoopl.Collections+import Hoopl.Graph+import Hoopl.Label++import Data.Maybe+import Data.List     ( minimumBy, nubBy )+import Data.Ord      ( comparing )+import qualified Data.Map as Map+import Data.Either   ( partitionEithers )++-- | Debug information about a block of code. Ticks scope over nested+-- blocks.+data DebugBlock =+  DebugBlock+  { dblProcedure  :: !Label        -- ^ Entry label of containing proc+  , dblLabel      :: !Label        -- ^ Hoopl label+  , dblCLabel     :: !CLabel       -- ^ Output label+  , dblHasInfoTbl :: !Bool         -- ^ Has an info table?+  , dblParent     :: !(Maybe DebugBlock)+    -- ^ The parent of this proc. See Note [Splitting DebugBlocks]+  , dblTicks      :: ![CmmTickish] -- ^ Ticks defined in this block+  , dblSourceTick+            :: !(Maybe CmmTickish) -- ^ Best source tick covering block+  , dblPosition   :: !(Maybe Int)  -- ^ Output position relative to+                                   -- other blocks. @Nothing@ means+                                   -- the block was optimized out+  , dblUnwind     :: [UnwindPoint]+  , dblBlocks     :: ![DebugBlock] -- ^ Nested blocks+  }++-- | Is this the entry block?+dblIsEntry :: DebugBlock -> Bool+dblIsEntry blk = dblProcedure blk == dblLabel blk++instance Outputable DebugBlock where+  ppr blk = (if dblProcedure blk == dblLabel blk+             then text "proc "+             else if dblHasInfoTbl blk+                  then text "pp-blk "+                  else text "blk ") <>+            ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+>+            (maybe empty ppr (dblSourceTick blk)) <+>+            (maybe (text "removed") ((text "pos " <>) . ppr)+                   (dblPosition blk)) <+>+            (ppr (dblUnwind blk)) <+>+            (if null (dblBlocks blk) then empty else ppr (dblBlocks blk))++-- | Intermediate data structure holding debug-relevant context information+-- about a block.+type BlockContext = (CmmBlock, RawCmmDecl)++-- | Extract debug data from a group of procedures. We will prefer+-- source notes that come from the given module (presumably the module+-- that we are currently compiling).+cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock]+cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes+  where+      blockCtxs :: Map.Map CmmTickScope [BlockContext]+      blockCtxs = blockContexts decls++      -- Analyse tick scope structure: Each one is either a top-level+      -- tick scope, or the child of another.+      (topScopes, childScopes)+        = partitionEithers $ map (\a -> findP a a) $ Map.keys blockCtxs+      findP tsc GlobalScope = Left tsc -- top scope+      findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)+                    | otherwise                   = findP tsc scp'+        where -- Note that we only following the left parent of+              -- combined scopes. This loses us ticks, which we will+              -- recover by copying ticks below.+              scp' | SubScope _ scp' <- scp      = scp'+                   | CombinedScope scp' _ <- scp = scp'+                   | otherwise                   = panic "findP impossible"++      scopeMap = foldr (uncurry insertMulti) Map.empty childScopes++      -- This allows us to recover ticks that we lost by flattening+      -- the graph. Basically, if the parent is A but the child is+      -- CBA, we know that there is no BA, because it would have taken+      -- priority - but there might be a B scope, with ticks that+      -- would not be associated with our child anymore. Note however+      -- that there might be other childs (DB), which we have to+      -- filter out.+      --+      -- We expect this to be called rarely, which is why we are not+      -- trying too hard to be efficient here. In many cases we won't+      -- have to construct blockCtxsU in the first place.+      ticksToCopy :: CmmTickScope -> [CmmTickish]+      ticksToCopy (CombinedScope scp s) = go s+        where go s | scp `isTickSubScope` s   = [] -- done+                   | SubScope _ s' <- s       = ticks ++ go s'+                   | CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2+                   | otherwise                = panic "ticksToCopy impossible"+                where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs+      ticksToCopy _ = []+      bCtxsTicks = concatMap (blockTicks . fst)++      -- Finding the "best" source tick is somewhat arbitrary -- we+      -- select the first source span, while preferring source ticks+      -- from the same source file.  Furthermore, dumps take priority+      -- (if we generated one, we probably want debug information to+      -- refer to it).+      bestSrcTick = minimumBy (comparing rangeRating)+      rangeRating (SourceNote span _)+        | srcSpanFile span == thisFile = 1+        | otherwise                    = 2 :: Int+      rangeRating note                 = pprPanic "rangeRating" (ppr note)+      thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc++      -- Returns block tree for this scope as well as all nested+      -- scopes. Note that if there are multiple blocks in the (exact)+      -- same scope we elect one as the "branch" node and add the rest+      -- as children.+      blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock+      blocksForScope cstick scope = mkBlock True (head bctxs)+        where bctxs = fromJust $ Map.lookup scope blockCtxs+              nested = fromMaybe [] $ Map.lookup scope scopeMap+              childs = map (mkBlock False) (tail bctxs) +++                       map (blocksForScope stick) nested++              mkBlock :: Bool -> BlockContext -> DebugBlock+              mkBlock top (block, prc)+                = DebugBlock { dblProcedure    = g_entry graph+                             , dblLabel        = label+                             , dblCLabel       = case info of+                                 Just (Statics infoLbl _)   -> infoLbl+                                 Nothing+                                   | g_entry graph == label -> entryLbl+                                   | otherwise              -> blockLbl label+                             , dblHasInfoTbl   = isJust info+                             , dblParent       = Nothing+                             , dblTicks        = ticks+                             , dblPosition     = Nothing -- see cmmDebugLink+                             , dblSourceTick   = stick+                             , dblBlocks       = blocks+                             , dblUnwind       = []+                             }+                where (CmmProc infos entryLbl _ graph) = prc+                      label = entryLabel block+                      info = mapLookup label infos+                      blocks | top       = seqList childs childs+                             | otherwise = []++              -- A source tick scopes over all nested blocks. However+              -- their source ticks might take priority.+              isSourceTick SourceNote {} = True+              isSourceTick _             = False+              -- Collect ticks from all blocks inside the tick scope.+              -- We attempt to filter out duplicates while we're at it.+              ticks = nubBy (flip tickishContains) $+                      bCtxsTicks bctxs ++ ticksToCopy scope+              stick = case filter isSourceTick ticks of+                []     -> cstick+                sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)++-- | Build a map of blocks sorted by their tick scopes+--+-- This involves a pre-order traversal, as we want blocks in rough+-- control flow order (so ticks have a chance to be sorted in the+-- right order).+blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext]+blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls+  where walkProc :: RawCmmDecl+                 -> Map.Map CmmTickScope [BlockContext]+                 -> Map.Map CmmTickScope [BlockContext]+        walkProc CmmData{}                 m = m+        walkProc prc@(CmmProc _ _ _ graph) m+          | mapNull blocks = m+          | otherwise      = snd $ walkBlock prc entry (emptyLbls, m)+          where blocks = toBlockMap graph+                entry  = [mapFind (g_entry graph) blocks]+                emptyLbls = setEmpty :: LabelSet++        walkBlock :: RawCmmDecl -> [Block CmmNode C C]+                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])+                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])+        walkBlock _   []             c            = c+        walkBlock prc (block:blocks) (visited, m)+          | lbl `setMember` visited+          = walkBlock prc blocks (visited, m)+          | otherwise+          = walkBlock prc blocks $+            walkBlock prc succs+              (lbl `setInsert` visited,+               insertMulti scope (block, prc) m)+          where CmmEntry lbl scope = firstNode block+                (CmmProc _ _ _ graph) = prc+                succs = map (flip mapFind (toBlockMap graph))+                            (successors (lastNode block))+        mapFind = mapFindWithDefault (error "contextTree: block not found!")++insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a]+insertMulti k v = Map.insertWith (const (v:)) k [v]++cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]+cmmDebugLabels isMeta nats = seqList lbls lbls+  where -- Find order in which procedures will be generated by the+        -- back-end (that actually matters for DWARF generation).+        --+        -- Note that we might encounter blocks that are missing or only+        -- consist of meta instructions -- we will declare them missing,+        -- which will skip debug data generation without messing up the+        -- block hierarchy.+        lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats+        getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs+        getBlocks _other                         = []+        allMeta (BasicBlock _ instrs) = all isMeta instrs++-- | Sets position and unwind table fields in the debug block tree according to+-- native generated code.+cmmDebugLink :: [Label] -> LabelMap [UnwindPoint]+             -> [DebugBlock] -> [DebugBlock]+cmmDebugLink labels unwindPts blocks = map link blocks+  where blockPos :: LabelMap Int+        blockPos = mapFromList $ flip zip [0..] labels+        link block = block { dblPosition = mapLookup (dblLabel block) blockPos+                           , dblBlocks   = map link (dblBlocks block)+                           , dblUnwind   = fromMaybe mempty+                                         $ mapLookup (dblLabel block) unwindPts+                           }++-- | Converts debug blocks into a label map for easier lookups+debugToMap :: [DebugBlock] -> LabelMap DebugBlock+debugToMap = mapUnions . map go+   where go b = mapInsert (dblLabel b) b $ mapUnions $ map go (dblBlocks b)++{-+Note [What is this unwinding business?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Unwinding tables are a variety of debugging information used by debugging tools+to reconstruct the execution history of a program at runtime. These tables+consist of sets of "instructions", one set for every instruction in the program,+which describe how to reconstruct the state of the machine at the point where+the current procedure was called. For instance, consider the following annotated+pseudo-code,++  a_fun:+    add rsp, 8            -- unwind: rsp = rsp - 8+    mov rax, 1            -- unwind: rax = unknown+    call another_block+    sub rsp, 8            -- unwind: rsp = rsp++We see that attached to each instruction there is an "unwind" annotation, which+provides a relationship between each updated register and its value at the+time of entry to a_fun. This is the sort of information that allows gdb to give+you a stack backtrace given the execution state of your program. This+unwinding information is captured in various ways by various debug information+formats; in the case of DWARF (the only format supported by GHC) it is known as+Call Frame Information (CFI) and can be found in the .debug.frames section of+your object files.++Currently we only bother to produce unwinding information for registers which+are necessary to reconstruct flow-of-execution. On x86_64 this includes $rbp+(which is the STG stack pointer) and $rsp (the C stack pointer).++Let's consider how GHC would annotate a C-- program with unwinding information+with a typical C-- procedure as would come from the STG-to-Cmm code generator,++  entry()+     { c2fe:+           v :: P64 = R2;+           if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;+       c2ff:+           R2 = v :: P64;+           R1 = test_closure;+           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;+       c2fg:+           I64[Sp - 8] = c2dD;+           R1 = v :: P64;+           Sp = Sp - 8;          // Sp updated here+           if (R1 & 7 != 0) goto c2dD; else goto c2dE;+       c2dE:+           call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;+       c2dD:+           w :: P64 = R1;+           Hp = Hp + 48;+           if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;+       ...+  },++Let's consider how this procedure will be decorated with unwind information+(largely by CmmLayoutStack). Naturally, when we enter the procedure `entry` the+value of Sp is no different from what it was at its call site. Therefore we will+add an `unwind` statement saying this at the beginning of its unwind-annotated+code,++  entry()+     { c2fe:+           unwind Sp = Just Sp + 0;+           v :: P64 = R2;+           if ((Sp + 8) - 32 < SpLim) (likely: False) goto c2ff; else goto c2fg;++After c2fe we may pass to either c2ff or c2fg; let's first consider the+former. In this case there is nothing in particular that we need to do other+than reiterate what we already know about Sp,++       c2ff:+           unwind Sp = Just Sp + 0;+           R2 = v :: P64;+           R1 = test_closure;+           call (stg_gc_fun)(R2, R1) args: 8, res: 0, upd: 8;++In contrast, c2fg updates Sp midway through its body. To ensure that unwinding+can happen correctly after this point we must include an unwind statement there,+in addition to the usual beginning-of-block statement,++       c2fg:+           unwind Sp = Just Sp + 0;+           I64[Sp - 8] = c2dD;+           R1 = v :: P64;+           Sp = Sp - 8;+           unwind Sp = Just Sp + 8;+           if (R1 & 7 != 0) goto c2dD; else goto c2dE;++The remaining blocks are simple,++       c2dE:+           unwind Sp = Just Sp + 8;+           call (I64[R1])(R1) returns to c2dD, args: 8, res: 8, upd: 8;+       c2dD:+           unwind Sp = Just Sp + 8;+           w :: P64 = R1;+           Hp = Hp + 48;+           if (Hp > HpLim) (likely: False) goto c2fj; else goto c2fi;+       ...+  },+++The flow of unwinding information through the compiler is a bit convoluted:++ * C-- begins life in StgCmm without any unwind information. This is because we+   haven't actually done any register assignment or stack layout yet, so there+   is no need for unwind information.++ * CmmLayoutStack figures out how to layout each procedure's stack, and produces+   appropriate unwinding nodes for each adjustment of the STG Sp register.++ * The unwind nodes are carried through the sinking pass. Currently this is+   guaranteed not to invalidate unwind information since it won't touch stores+   to Sp, but this will need revisiting if CmmSink gets smarter in the future.++ * Eventually we make it to the native code generator backend which can then+   preserve the unwind nodes in its machine-specific instructions. In so doing+   the backend can also modify or add unwinding information; this is necessary,+   for instance, in the case of x86-64, where adjustment of $rsp may be+   necessary during calls to native foreign code due to the native calling+   convention.++ * The NCG then retrieves the final unwinding table for each block from the+   backend with extractUnwindPoints.++ * This unwind information is converted to DebugBlocks by Debug.cmmDebugGen++ * These DebugBlocks are then converted to, e.g., DWARF unwinding tables+   (by the Dwarf module) and emitted in the final object.++See also:+  Note [Unwinding information in the NCG] in AsmCodeGen,+  Note [Unwind pseudo-instruction in Cmm],+  Note [Debugging DWARF unwinding info].+++Note [Debugging DWARF unwinding info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++For debugging generated unwinding info I've found it most useful to dump the+disassembled binary with objdump -D and dump the debug info with+readelf --debug-dump=frames-interp.++You should get something like this:++  0000000000000010 <stg_catch_frame_info>:+    10:   48 83 c5 18             add    $0x18,%rbp+    14:   ff 65 00                jmpq   *0x0(%rbp)++and:++  Contents of the .debug_frame section:++  00000000 0000000000000014 ffffffff CIE "" cf=1 df=-8 ra=16+     LOC           CFA      rbp   rsp   ra+  0000000000000000 rbp+0    v+0   s     c+0++  00000018 0000000000000024 00000000 FDE cie=00000000 pc=000000000000000f..0000000000000017+     LOC           CFA      rbp   rsp   ra+  000000000000000f rbp+0    v+0   s     c+0+  000000000000000f rbp+24   v+0   s     c+0++To read it http://www.dwarfstd.org/doc/dwarf-2.0.0.pdf has a nice example in+Appendix 5 (page 101 of the pdf) and more details in the relevant section.++The key thing to keep in mind is that the value at LOC is the value from+*before* the instruction at LOC executes. In other words it answers the+question: if my $rip is at LOC, how do I get the relevant values given the+values obtained through unwinding so far.++If the readelf --debug-dump=frames-interp output looks wrong, it may also be+useful to look at readelf --debug-dump=frames, which is closer to the+information that GHC generated.++It's also useful to dump the relevant Cmm with -ddump-cmm -ddump-opt-cmm+-ddump-cmm-proc -ddump-cmm-verbose. Note [Unwind pseudo-instruction in Cmm]+explains how to interpret it.++Inside gdb there are a couple useful commands for inspecting frames.+For example:++  gdb> info frame <num>++It shows the values of registers obtained through unwinding.++Another useful thing to try when debugging the DWARF unwinding is to enable+extra debugging output in GDB:++  gdb> set debug frame 1++This makes GDB produce a trace of its internal workings. Having gone this far,+it's just a tiny step to run GDB in GDB. Make sure you install debugging+symbols for gdb if you obtain it through a package manager.++Keep in mind that the current release of GDB has an instruction pointer handling+heuristic that works well for C-like languages, but doesn't always work for+Haskell. See Note [Info Offset] in Dwarf.Types for more details.++Note [Unwind pseudo-instruction in Cmm]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++One of the possible CmmNodes is a CmmUnwind pseudo-instruction. It doesn't+generate any assembly, but controls what DWARF unwinding information gets+generated.++It's important to understand what ranges of code the unwind pseudo-instruction+refers to.+For a sequence of CmmNodes like:++  A // starts at addr X and ends at addr Y-1+  unwind Sp = Just Sp + 16;+  B // starts at addr Y and ends at addr Z++the unwind statement reflects the state after A has executed, but before B+has executed. If you consult the Note [Debugging DWARF unwinding info], the+LOC this information will end up in is Y.+-}++-- | A label associated with an 'UnwindTable'+data UnwindPoint = UnwindPoint !CLabel !UnwindTable++instance Outputable UnwindPoint where+  ppr (UnwindPoint lbl uws) =+      braces $ ppr lbl<>colon+      <+> hsep (punctuate comma $ map pprUw $ Map.toList uws)+    where+      pprUw (g, expr) = ppr g <> char '=' <> ppr expr++-- | Maps registers to expressions that yield their "old" values+-- further up the stack. Most interesting for the stack pointer @Sp@,+-- but might be useful to document saved registers, too. Note that a+-- register's value will be 'Nothing' when the register's previous+-- value cannot be reconstructed.+type UnwindTable = Map.Map GlobalReg (Maybe UnwindExpr)++-- | Expressions, used for unwind information+data UnwindExpr = UwConst !Int                  -- ^ literal value+                | UwReg !GlobalReg !Int         -- ^ register plus offset+                | UwDeref UnwindExpr            -- ^ pointer dereferencing+                | UwLabel CLabel+                | UwPlus UnwindExpr UnwindExpr+                | UwMinus UnwindExpr UnwindExpr+                | UwTimes UnwindExpr UnwindExpr+                deriving (Eq)++instance Outputable UnwindExpr where+  pprPrec _ (UwConst i)     = ppr i+  pprPrec _ (UwReg g 0)     = ppr g+  pprPrec p (UwReg g x)     = pprPrec p (UwPlus (UwReg g 0) (UwConst x))+  pprPrec _ (UwDeref e)     = char '*' <> pprPrec 3 e+  pprPrec _ (UwLabel l)     = pprPrec 3 l+  pprPrec p (UwPlus e0 e1)  | p <= 0+                            = pprPrec 0 e0 <> char '+' <> pprPrec 0 e1+  pprPrec p (UwMinus e0 e1) | p <= 0+                            = pprPrec 1 e0 <> char '-' <> pprPrec 1 e1+  pprPrec p (UwTimes e0 e1) | p <= 1+                            = pprPrec 2 e0 <> char '*' <> pprPrec 2 e1+  pprPrec _ other           = parens (pprPrec 0 other)++-- | Conversion of Cmm expressions to unwind expressions. We check for+-- unsupported operator usages and simplify the expression as far as+-- possible.+toUnwindExpr :: CmmExpr -> UnwindExpr+toUnwindExpr (CmmLit (CmmInt i _))       = UwConst (fromIntegral i)+toUnwindExpr (CmmLit (CmmLabel l))       = UwLabel l+toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i+toUnwindExpr (CmmReg (CmmGlobal g))      = UwReg g 0+toUnwindExpr (CmmLoad e _)               = UwDeref (toUnwindExpr e)+toUnwindExpr e@(CmmMachOp op [e1, e2])   =+  case (op, toUnwindExpr e1, toUnwindExpr e2) of+    (MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y)+    (MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y)+    (MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y)+    (MO_Add{}, UwConst x, UwConst y) -> UwConst (x + y)+    (MO_Sub{}, UwConst x, UwConst y) -> UwConst (x - y)+    (MO_Mul{}, UwConst x, UwConst y) -> UwConst (x * y)+    (MO_Add{}, u1,        u2       ) -> UwPlus u1 u2+    (MO_Sub{}, u1,        u2       ) -> UwMinus u1 u2+    (MO_Mul{}, u1,        u2       ) -> UwTimes u1 u2+    _otherwise -> pprPanic "Unsupported operator in unwind expression!"+                           (pprExpr e)+toUnwindExpr e+  = pprPanic "Unsupported unwind expression!" (ppr e)
+ compiler/cmm/Hoopl/Block.hs view
@@ -0,0 +1,328 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module Hoopl.Block+    ( C+    , O+    , MaybeO(..)+    , IndexedCO+    , Block(..)+    , blockAppend+    , blockCons+    , blockFromList+    , blockJoin+    , blockJoinHead+    , blockJoinTail+    , blockSnoc+    , blockSplit+    , blockSplitHead+    , blockSplitTail+    , blockToList+    , emptyBlock+    , firstNode+    , foldBlockNodesB+    , foldBlockNodesB3+    , foldBlockNodesF+    , isEmptyBlock+    , lastNode+    , mapBlock+    , mapBlock'+    , mapBlock3'+    , replaceFirstNode+    , replaceLastNode+    ) where++import GhcPrelude++-- -----------------------------------------------------------------------------+-- Shapes: Open and Closed++-- | Used at the type level to indicate an "open" structure with+-- a unique, unnamed control-flow edge flowing in or out.+-- "Fallthrough" and concatenation are permitted at an open point.+data O++-- | Used at the type level to indicate a "closed" structure which+-- supports control transfer only through the use of named+-- labels---no "fallthrough" is permitted.  The number of control-flow+-- edges is unconstrained.+data C++-- | Either type indexed by closed/open using type families+type family IndexedCO ex a b :: *+type instance IndexedCO C a _b = a+type instance IndexedCO O _a b = b++-- | Maybe type indexed by open/closed+data MaybeO ex t where+  JustO    :: t -> MaybeO O t+  NothingO ::      MaybeO C t++-- | Maybe type indexed by closed/open+data MaybeC ex t where+  JustC    :: t -> MaybeC C t+  NothingC ::      MaybeC O t+++instance Functor (MaybeO ex) where+  fmap _ NothingO = NothingO+  fmap f (JustO a) = JustO (f a)++instance Functor (MaybeC ex) where+  fmap _ NothingC = NothingC+  fmap f (JustC a) = JustC (f a)++-- -----------------------------------------------------------------------------+-- The Block type++-- | A sequence of nodes.  May be any of four shapes (O/O, O/C, C/O, C/C).+-- Open at the entry means single entry, mutatis mutandis for exit.+-- A closed/closed block is a /basic/ block and can't be extended further.+-- Clients should avoid manipulating blocks and should stick to either nodes+-- or graphs.+data Block n e x where+  BlockCO  :: n C O -> Block n O O          -> Block n C O+  BlockCC  :: n C O -> Block n O O -> n O C -> Block n C C+  BlockOC  ::          Block n O O -> n O C -> Block n O C++  BNil    :: Block n O O+  BMiddle :: n O O                      -> Block n O O+  BCat    :: Block n O O -> Block n O O -> Block n O O+  BSnoc   :: Block n O O -> n O O       -> Block n O O+  BCons   :: n O O       -> Block n O O -> Block n O O+++-- -----------------------------------------------------------------------------+-- Simple operations on Blocks++-- Predicates++isEmptyBlock :: Block n e x -> Bool+isEmptyBlock BNil       = True+isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r+isEmptyBlock _          = False+++-- Building++emptyBlock :: Block n O O+emptyBlock = BNil++blockCons :: n O O -> Block n O x -> Block n O x+blockCons n b = case b of+  BlockOC b l  -> (BlockOC $! (n `blockCons` b)) l+  BNil{}    -> BMiddle n+  BMiddle{} -> n `BCons` b+  BCat{}    -> n `BCons` b+  BSnoc{}   -> n `BCons` b+  BCons{}   -> n `BCons` b++blockSnoc :: Block n e O -> n O O -> Block n e O+blockSnoc b n = case b of+  BlockCO f b -> BlockCO f $! (b `blockSnoc` n)+  BNil{}      -> BMiddle n+  BMiddle{}   -> b `BSnoc` n+  BCat{}      -> b `BSnoc` n+  BSnoc{}     -> b `BSnoc` n+  BCons{}     -> b `BSnoc` n++blockJoinHead :: n C O -> Block n O x -> Block n C x+blockJoinHead f (BlockOC b l) = BlockCC f b l+blockJoinHead f b = BlockCO f BNil `cat` b++blockJoinTail :: Block n e O -> n O C -> Block n e C+blockJoinTail (BlockCO f b) t = BlockCC f b t+blockJoinTail b t = b `cat` BlockOC BNil t++blockJoin :: n C O -> Block n O O -> n O C -> Block n C C+blockJoin f b t = BlockCC f b t++blockAppend :: Block n e O -> Block n O x -> Block n e x+blockAppend = cat+++-- Taking apart++firstNode :: Block n C x -> n C O+firstNode (BlockCO n _)   = n+firstNode (BlockCC n _ _) = n++lastNode :: Block n x C -> n O C+lastNode (BlockOC   _ n) = n+lastNode (BlockCC _ _ n) = n++blockSplitHead :: Block n C x -> (n C O, Block n O x)+blockSplitHead (BlockCO n b)   = (n, b)+blockSplitHead (BlockCC n b t) = (n, BlockOC b t)++blockSplitTail :: Block n e C -> (Block n e O, n O C)+blockSplitTail (BlockOC b n)   = (b, n)+blockSplitTail (BlockCC f b t) = (BlockCO f b, t)++-- | Split a closed block into its entry node, open middle block, and+-- exit node.+blockSplit :: Block n C C -> (n C O, Block n O O, n O C)+blockSplit (BlockCC f b t) = (f, b, t)++blockToList :: Block n O O -> [n O O]+blockToList b = go b []+   where go :: Block n O O -> [n O O] -> [n O O]+         go BNil         r = r+         go (BMiddle n)  r = n : r+         go (BCat b1 b2) r = go b1 $! go b2 r+         go (BSnoc b1 n) r = go b1 (n:r)+         go (BCons n b1) r = n : go b1 r++blockFromList :: [n O O] -> Block n O O+blockFromList = foldr BCons BNil++-- Modifying++replaceFirstNode :: Block n C x -> n C O -> Block n C x+replaceFirstNode (BlockCO _ b)   f = BlockCO f b+replaceFirstNode (BlockCC _ b n) f = BlockCC f b n++replaceLastNode :: Block n x C -> n O C -> Block n x C+replaceLastNode (BlockOC   b _) n = BlockOC b n+replaceLastNode (BlockCC l b _) n = BlockCC l b n++-- -----------------------------------------------------------------------------+-- General concatenation++cat :: Block n e O -> Block n O x -> Block n e x+cat x y = case x of+  BNil -> y++  BlockCO l b1 -> case y of+                   BlockOC b2 n -> (BlockCC l $! (b1 `cat` b2)) n+                   BNil         -> x+                   BMiddle _    -> BlockCO l $! (b1 `cat` y)+                   BCat{}       -> BlockCO l $! (b1 `cat` y)+                   BSnoc{}      -> BlockCO l $! (b1 `cat` y)+                   BCons{}      -> BlockCO l $! (b1 `cat` y)++  BMiddle n -> case y of+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2+                   BNil          -> x+                   BMiddle{}     -> BCons n y+                   BCat{}        -> BCons n y+                   BSnoc{}       -> BCons n y+                   BCons{}       -> BCons n y++  BCat{} -> case y of+                   BlockOC b3 n2 -> (BlockOC $! (x `cat` b3)) n2+                   BNil          -> x+                   BMiddle n     -> BSnoc x n+                   BCat{}        -> BCat x y+                   BSnoc{}       -> BCat x y+                   BCons{}       -> BCat x y++  BSnoc{} -> case y of+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2+                   BNil          -> x+                   BMiddle n     -> BSnoc x n+                   BCat{}        -> BCat x y+                   BSnoc{}       -> BCat x y+                   BCons{}       -> BCat x y+++  BCons{} -> case y of+                   BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2+                   BNil          -> x+                   BMiddle n     -> BSnoc x n+                   BCat{}        -> BCat x y+                   BSnoc{}       -> BCat x y+                   BCons{}       -> BCat x y+++-- -----------------------------------------------------------------------------+-- Mapping++-- | map a function over the nodes of a 'Block'+mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x+mapBlock f (BlockCO n b  ) = BlockCO (f n) (mapBlock f b)+mapBlock f (BlockOC   b n) = BlockOC       (mapBlock f b) (f n)+mapBlock f (BlockCC n b m) = BlockCC (f n) (mapBlock f b) (f m)+mapBlock _  BNil           = BNil+mapBlock f (BMiddle n)     = BMiddle (f n)+mapBlock f (BCat b1 b2)    = BCat    (mapBlock f b1) (mapBlock f b2)+mapBlock f (BSnoc b n)     = BSnoc   (mapBlock f b)  (f n)+mapBlock f (BCons n b)     = BCons   (f n)  (mapBlock f b)++-- | A strict 'mapBlock'+mapBlock' :: (forall e x. n e x -> n' e x) -> (Block n e x -> Block n' e x)+mapBlock' f = mapBlock3' (f, f, f)++-- | map over a block, with different functions to apply to first nodes,+-- middle nodes and last nodes respectively.  The map is strict.+--+mapBlock3' :: forall n n' e x .+             ( n C O -> n' C O+             , n O O -> n' O O,+               n O C -> n' O C)+          -> Block n e x -> Block n' e x+mapBlock3' (f, m, l) b = go b+  where go :: forall e x . Block n e x -> Block n' e x+        go (BlockOC b y)   = (BlockOC $! go b) $! l y+        go (BlockCO x b)   = (BlockCO $! f x) $! (go b)+        go (BlockCC x b y) = ((BlockCC $! f x) $! go b) $! (l y)+        go BNil            = BNil+        go (BMiddle n)     = BMiddle $! m n+        go (BCat x y)      = (BCat $! go x) $! (go y)+        go (BSnoc x n)     = (BSnoc $! go x) $! (m n)+        go (BCons n x)     = (BCons $! m n) $! (go x)++-- -----------------------------------------------------------------------------+-- Folding+++-- | Fold a function over every node in a block, forward or backward.+-- The fold function must be polymorphic in the shape of the nodes.+foldBlockNodesF3 :: forall n a b c .+                   ( n C O       -> a -> b+                   , n O O       -> b -> b+                   , n O C       -> b -> c)+                 -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)+foldBlockNodesF  :: forall n a .+                    (forall e x . n e x       -> a -> a)+                 -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a)+foldBlockNodesB3 :: forall n a b c .+                   ( n C O       -> b -> c+                   , n O O       -> b -> b+                   , n O C       -> a -> b)+                 -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b)+foldBlockNodesB  :: forall n a .+                    (forall e x . n e x       -> a -> a)+                 -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a)++foldBlockNodesF3 (ff, fm, fl) = block+  where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b+        block (BlockCO f b  )   = ff f `cat` block b+        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l+        block (BlockOC   b l)   =            block b `cat` fl l+        block BNil              = id+        block (BMiddle node)    = fm node+        block (b1 `BCat`    b2) = block b1 `cat` block b2+        block (b1 `BSnoc` n)    = block b1 `cat` fm n+        block (n `BCons` b2)    = fm n `cat` block b2+        cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c+        cat f f' = f' . f++foldBlockNodesF f = foldBlockNodesF3 (f, f, f)++foldBlockNodesB3 (ff, fm, fl) = block+  where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b+        block (BlockCO f b  )   = ff f `cat` block b+        block (BlockCC f b l)   = ff f `cat` block b `cat` fl l+        block (BlockOC   b l)   =            block b `cat` fl l+        block BNil              = id+        block (BMiddle node)    = fm node+        block (b1 `BCat`    b2) = block b1 `cat` block b2+        block (b1 `BSnoc` n)    = block b1 `cat` fm n+        block (n `BCons` b2)    = fm n `cat` block b2+        cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c+        cat f f' = f . f'++foldBlockNodesB f = foldBlockNodesB3 (f, f, f)+
+ compiler/cmm/Hoopl/Collections.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Hoopl.Collections+    ( IsSet(..)+    , setInsertList, setDeleteList, setUnions+    , IsMap(..)+    , mapInsertList, mapDeleteList, mapUnions+    , UniqueMap, UniqueSet+    ) where++import GhcPrelude++import qualified Data.IntMap.Strict as M+import qualified Data.IntSet as S++import Data.List (foldl1')++class IsSet set where+  type ElemOf set++  setNull :: set -> Bool+  setSize :: set -> Int+  setMember :: ElemOf set -> set -> Bool++  setEmpty :: set+  setSingleton :: ElemOf set -> set+  setInsert :: ElemOf set -> set -> set+  setDelete :: ElemOf set -> set -> set++  setUnion :: set -> set -> set+  setDifference :: set -> set -> set+  setIntersection :: set -> set -> set+  setIsSubsetOf :: set -> set -> Bool+  setFilter :: (ElemOf set -> Bool) -> set -> set++  setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b+  setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b++  setElems :: set -> [ElemOf set]+  setFromList :: [ElemOf set] -> set++-- Helper functions for IsSet class+setInsertList :: IsSet set => [ElemOf set] -> set -> set+setInsertList keys set = foldl' (flip setInsert) set keys++setDeleteList :: IsSet set => [ElemOf set] -> set -> set+setDeleteList keys set = foldl' (flip setDelete) set keys++setUnions :: IsSet set => [set] -> set+setUnions [] = setEmpty+setUnions sets = foldl1' setUnion sets+++class IsMap map where+  type KeyOf map++  mapNull :: map a -> Bool+  mapSize :: map a -> Int+  mapMember :: KeyOf map -> map a -> Bool+  mapLookup :: KeyOf map -> map a -> Maybe a+  mapFindWithDefault :: a -> KeyOf map -> map a -> a++  mapEmpty :: map a+  mapSingleton :: KeyOf map -> a -> map a+  mapInsert :: KeyOf map -> a -> map a -> map a+  mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a+  mapDelete :: KeyOf map -> map a -> map a+  mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a+  mapAdjust :: (a -> a) -> KeyOf map -> map a -> map a++  mapUnion :: map a -> map a -> map a+  mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a+  mapDifference :: map a -> map a -> map a+  mapIntersection :: map a -> map a -> map a+  mapIsSubmapOf :: Eq a => map a -> map a -> Bool++  mapMap :: (a -> b) -> map a -> map b+  mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b+  mapFoldl :: (b -> a -> b) -> b -> map a -> b+  mapFoldr :: (a -> b -> b) -> b -> map a -> b+  mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b+  mapFoldMapWithKey :: Monoid m => (KeyOf map -> a -> m) -> map a -> m+  mapFilter :: (a -> Bool) -> map a -> map a+  mapFilterWithKey :: (KeyOf map -> a -> Bool) -> map a -> map a+++  mapElems :: map a -> [a]+  mapKeys :: map a -> [KeyOf map]+  mapToList :: map a -> [(KeyOf map, a)]+  mapFromList :: [(KeyOf map, a)] -> map a+  mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a++-- Helper functions for IsMap class+mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a+mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs++mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a+mapDeleteList keys map = foldl' (flip mapDelete) map keys++mapUnions :: IsMap map => [map a] -> map a+mapUnions [] = mapEmpty+mapUnions maps = foldl1' mapUnion maps++-----------------------------------------------------------------------------+-- Basic instances+-----------------------------------------------------------------------------++newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show, Semigroup, Monoid)++instance IsSet UniqueSet where+  type ElemOf UniqueSet = Int++  setNull (US s) = S.null s+  setSize (US s) = S.size s+  setMember k (US s) = S.member k s++  setEmpty = US S.empty+  setSingleton k = US (S.singleton k)+  setInsert k (US s) = US (S.insert k s)+  setDelete k (US s) = US (S.delete k s)++  setUnion (US x) (US y) = US (S.union x y)+  setDifference (US x) (US y) = US (S.difference x y)+  setIntersection (US x) (US y) = US (S.intersection x y)+  setIsSubsetOf (US x) (US y) = S.isSubsetOf x y+  setFilter f (US s) = US (S.filter f s)++  setFoldl k z (US s) = S.foldl' k z s+  setFoldr k z (US s) = S.foldr k z s++  setElems (US s) = S.elems s+  setFromList ks = US (S.fromList ks)++newtype UniqueMap v = UM (M.IntMap v)+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++instance IsMap UniqueMap where+  type KeyOf UniqueMap = Int++  mapNull (UM m) = M.null m+  mapSize (UM m) = M.size m+  mapMember k (UM m) = M.member k m+  mapLookup k (UM m) = M.lookup k m+  mapFindWithDefault def k (UM m) = M.findWithDefault def k m++  mapEmpty = UM M.empty+  mapSingleton k v = UM (M.singleton k v)+  mapInsert k v (UM m) = UM (M.insert k v m)+  mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)+  mapDelete k (UM m) = UM (M.delete k m)+  mapAlter f k (UM m) = UM (M.alter f k m)+  mapAdjust f k (UM m) = UM (M.adjust f k m)++  mapUnion (UM x) (UM y) = UM (M.union x y)+  mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y)+  mapDifference (UM x) (UM y) = UM (M.difference x y)+  mapIntersection (UM x) (UM y) = UM (M.intersection x y)+  mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y++  mapMap f (UM m) = UM (M.map f m)+  mapMapWithKey f (UM m) = UM (M.mapWithKey f m)+  mapFoldl k z (UM m) = M.foldl' k z m+  mapFoldr k z (UM m) = M.foldr k z m+  mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m+  mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m+  mapFilter f (UM m) = UM (M.filter f m)+  mapFilterWithKey f (UM m) = UM (M.filterWithKey f m)++  mapElems (UM m) = M.elems m+  mapKeys (UM m) = M.keys m+  mapToList (UM m) = M.toList m+  mapFromList assocs = UM (M.fromList assocs)+  mapFromListWith f assocs = UM (M.fromListWith f assocs)
+ compiler/cmm/Hoopl/Dataflow.hs view
@@ -0,0 +1,440 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fprof-auto-top #-}++--+-- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones,+-- and Norman Ramsey+--+-- Modifications copyright (c) The University of Glasgow 2012+--+-- This module is a specialised and optimised version of+-- Compiler.Hoopl.Dataflow in the hoopl package.  In particular it is+-- specialised to the UniqSM monad.+--++module Hoopl.Dataflow+  ( C, O, Block+  , lastNode, entryLabel+  , foldNodesBwdOO+  , foldRewriteNodesBwdOO+  , DataflowLattice(..), OldFact(..), NewFact(..), JoinedFact(..)+  , TransferFun, RewriteFun+  , Fact, FactBase+  , getFact, mkFactBase+  , analyzeCmmFwd, analyzeCmmBwd+  , rewriteCmmBwd+  , changedIf+  , joinOutFacts+  , joinFacts+  )+where++import GhcPrelude++import Cmm+import UniqSupply++import Data.Array+import Data.Maybe+import Data.IntSet (IntSet)+import qualified Data.IntSet as IntSet++import Hoopl.Block+import Hoopl.Graph+import Hoopl.Collections+import Hoopl.Label++type family   Fact x f :: *+type instance Fact C f = FactBase f+type instance Fact O f = f++newtype OldFact a = OldFact a++newtype NewFact a = NewFact a++-- | The result of joining OldFact and NewFact.+data JoinedFact a+    = Changed !a     -- ^ Result is different than OldFact.+    | NotChanged !a  -- ^ Result is the same as OldFact.++getJoined :: JoinedFact a -> a+getJoined (Changed a) = a+getJoined (NotChanged a) = a++changedIf :: Bool -> a -> JoinedFact a+changedIf True = Changed+changedIf False = NotChanged++type JoinFun a = OldFact a -> NewFact a -> JoinedFact a++data DataflowLattice a = DataflowLattice+    { fact_bot :: a+    , fact_join :: JoinFun a+    }++data Direction = Fwd | Bwd++type TransferFun f = CmmBlock -> FactBase f -> FactBase f++-- | Function for rewrtiting and analysis combined. To be used with+-- @rewriteCmm@.+--+-- Currently set to work with @UniqSM@ monad, but we could probably abstract+-- that away (if we do that, we might want to specialize the fixpoint algorithms+-- to the particular monads through SPECIALIZE).+type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f)++analyzeCmmBwd, analyzeCmmFwd+    :: DataflowLattice f+    -> TransferFun f+    -> CmmGraph+    -> FactBase f+    -> FactBase f+analyzeCmmBwd = analyzeCmm Bwd+analyzeCmmFwd = analyzeCmm Fwd++analyzeCmm+    :: Direction+    -> DataflowLattice f+    -> TransferFun f+    -> CmmGraph+    -> FactBase f+    -> FactBase f+analyzeCmm dir lattice transfer cmmGraph initFact =+    let entry = g_entry cmmGraph+        hooplGraph = g_graph cmmGraph+        blockMap =+            case hooplGraph of+                GMany NothingO bm NothingO -> bm+    in fixpointAnalysis dir lattice transfer entry blockMap initFact++-- Fixpoint algorithm.+fixpointAnalysis+    :: forall f.+       Direction+    -> DataflowLattice f+    -> TransferFun f+    -> Label+    -> LabelMap CmmBlock+    -> FactBase f+    -> FactBase f+fixpointAnalysis direction lattice do_block entry blockmap = loop start+  where+    -- Sorting the blocks helps to minimize the number of times we need to+    -- process blocks. For instance, for forward analysis we want to look at+    -- blocks in reverse postorder. Also, see comments for sortBlocks.+    blocks     = sortBlocks direction entry blockmap+    num_blocks = length blocks+    block_arr  = {-# SCC "block_arr" #-} listArray (0, num_blocks - 1) blocks+    start      = {-# SCC "start" #-} IntSet.fromDistinctAscList+      [0 .. num_blocks - 1]+    dep_blocks = {-# SCC "dep_blocks" #-} mkDepBlocks direction blocks+    join       = fact_join lattice++    loop+        :: IntHeap     -- ^ Worklist, i.e., blocks to process+        -> FactBase f  -- ^ Current result (increases monotonically)+        -> FactBase f+    loop todo !fbase1 | Just (index, todo1) <- IntSet.minView todo =+        let block = block_arr ! index+            out_facts = {-# SCC "do_block" #-} do_block block fbase1+            -- For each of the outgoing edges, we join it with the current+            -- information in fbase1 and (if something changed) we update it+            -- and add the affected blocks to the worklist.+            (todo2, fbase2) = {-# SCC "mapFoldWithKey" #-}+                mapFoldlWithKey+                    (updateFact join dep_blocks) (todo1, fbase1) out_facts+        in loop todo2 fbase2+    loop _ !fbase1 = fbase1++rewriteCmmBwd+    :: DataflowLattice f+    -> RewriteFun f+    -> CmmGraph+    -> FactBase f+    -> UniqSM (CmmGraph, FactBase f)+rewriteCmmBwd = rewriteCmm Bwd++rewriteCmm+    :: Direction+    -> DataflowLattice f+    -> RewriteFun f+    -> CmmGraph+    -> FactBase f+    -> UniqSM (CmmGraph, FactBase f)+rewriteCmm dir lattice rwFun cmmGraph initFact = do+    let entry = g_entry cmmGraph+        hooplGraph = g_graph cmmGraph+        blockMap1 =+            case hooplGraph of+                GMany NothingO bm NothingO -> bm+    (blockMap2, facts) <-+        fixpointRewrite dir lattice rwFun entry blockMap1 initFact+    return (cmmGraph {g_graph = GMany NothingO blockMap2 NothingO}, facts)++fixpointRewrite+    :: forall f.+       Direction+    -> DataflowLattice f+    -> RewriteFun f+    -> Label+    -> LabelMap CmmBlock+    -> FactBase f+    -> UniqSM (LabelMap CmmBlock, FactBase f)+fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap+  where+    -- Sorting the blocks helps to minimize the number of times we need to+    -- process blocks. For instance, for forward analysis we want to look at+    -- blocks in reverse postorder. Also, see comments for sortBlocks.+    blocks     = sortBlocks dir entry blockmap+    num_blocks = length blocks+    block_arr  = {-# SCC "block_arr_rewrite" #-}+                 listArray (0, num_blocks - 1) blocks+    start      = {-# SCC "start_rewrite" #-}+                 IntSet.fromDistinctAscList [0 .. num_blocks - 1]+    dep_blocks = {-# SCC "dep_blocks_rewrite" #-} mkDepBlocks dir blocks+    join       = fact_join lattice++    loop+        :: IntHeap            -- ^ Worklist, i.e., blocks to process+        -> LabelMap CmmBlock  -- ^ Rewritten blocks.+        -> FactBase f         -- ^ Current facts.+        -> UniqSM (LabelMap CmmBlock, FactBase f)+    loop todo !blocks1 !fbase1+      | Just (index, todo1) <- IntSet.minView todo = do+        -- Note that we use the *original* block here. This is important.+        -- We're optimistically rewriting blocks even before reaching the fixed+        -- point, which means that the rewrite might be incorrect. So if the+        -- facts change, we need to rewrite the original block again (taking+        -- into account the new facts).+        let block = block_arr ! index+        (new_block, out_facts) <- {-# SCC "do_block_rewrite" #-}+            do_block block fbase1+        let blocks2 = mapInsert (entryLabel new_block) new_block blocks1+            (todo2, fbase2) = {-# SCC "mapFoldWithKey_rewrite" #-}+                mapFoldlWithKey+                    (updateFact join dep_blocks) (todo1, fbase1) out_facts+        loop todo2 blocks2 fbase2+    loop _ !blocks1 !fbase1 = return (blocks1, fbase1)+++{-+Note [Unreachable blocks]+~~~~~~~~~~~~~~~~~~~~~~~~~+A block that is not in the domain of tfb_fbase is "currently unreachable".+A currently-unreachable block is not even analyzed.  Reason: consider+constant prop and this graph, with entry point L1:+  L1: x:=3; goto L4+  L2: x:=4; goto L4+  L4: if x>3 goto L2 else goto L5+Here L2 is actually unreachable, but if we process it with bottom input fact,+we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4.++* If a currently-unreachable block is not analyzed, then its rewritten+  graph will not be accumulated in tfb_rg.  And that is good:+  unreachable blocks simply do not appear in the output.++* Note that clients must be careful to provide a fact (even if bottom)+  for each entry point. Otherwise useful blocks may be garbage collected.++* Note that updateFact must set the change-flag if a label goes from+  not-in-fbase to in-fbase, even if its fact is bottom.  In effect the+  real fact lattice is+       UNR+       bottom+       the points above bottom++* Even if the fact is going from UNR to bottom, we still call the+  client's fact_join function because it might give the client+  some useful debugging information.++* All of this only applies for *forward* ixpoints.  For the backward+  case we must treat every block as reachable; it might finish with a+  'return', and therefore have no successors, for example.+-}+++-----------------------------------------------------------------------------+--  Pieces that are shared by fixpoint and fixpoint_anal+-----------------------------------------------------------------------------++-- | Sort the blocks into the right order for analysis. This means reverse+-- postorder for a forward analysis. For the backward one, we simply reverse+-- that (see Note [Backward vs forward analysis]).+sortBlocks+    :: NonLocal n+    => Direction -> Label -> LabelMap (Block n C C) -> [Block n C C]+sortBlocks direction entry blockmap =+    case direction of+        Fwd -> fwd+        Bwd -> reverse fwd+  where+    fwd = revPostorderFrom blockmap entry++-- Note [Backward vs forward analysis]+--+-- The forward and backward cases are not dual.  In the forward case, the entry+-- points are known, and one simply traverses the body blocks from those points.+-- In the backward case, something is known about the exit points, but a+-- backward analysis must also include reachable blocks that don't reach the+-- exit, as in a procedure that loops forever and has side effects.)+-- For instance, let E be the entry and X the exit blocks (arrows indicate+-- control flow)+--   E -> X+--   E -> B+--   B -> C+--   C -> B+-- We do need to include B and C even though they're unreachable in the+-- *reverse* graph (that we could use for backward analysis):+--   E <- X+--   E <- B+--   B <- C+--   C <- B+-- So when sorting the blocks for the backward analysis, we simply take the+-- reverse of what is used for the forward one.+++-- | Construct a mapping from a @Label@ to the block indexes that should be+-- re-analyzed if the facts at that @Label@ change.+--+-- Note that we're considering here the entry point of the block, so if the+-- facts change at the entry:+-- * for a backward analysis we need to re-analyze all the predecessors, but+-- * for a forward analysis, we only need to re-analyze the current block+--   (and that will in turn propagate facts into its successors).+mkDepBlocks :: Direction -> [CmmBlock] -> LabelMap IntSet+mkDepBlocks Fwd blocks = go blocks 0 mapEmpty+  where+    go []     !_ !dep_map = dep_map+    go (b:bs) !n !dep_map =+        go bs (n + 1) $ mapInsert (entryLabel b) (IntSet.singleton n) dep_map+mkDepBlocks Bwd blocks = go blocks 0 mapEmpty+  where+    go []     !_ !dep_map = dep_map+    go (b:bs) !n !dep_map =+        let insert m l = mapInsertWith IntSet.union l (IntSet.singleton n) m+        in go bs (n + 1) $ foldl' insert dep_map (successors b)++-- | After some new facts have been generated by analysing a block, we+-- fold this function over them to generate (a) a list of block+-- indices to (re-)analyse, and (b) the new FactBase.+updateFact+    :: JoinFun f+    -> LabelMap IntSet+    -> (IntHeap, FactBase f)+    -> Label+    -> f -- out fact+    -> (IntHeap, FactBase f)+updateFact fact_join dep_blocks (todo, fbase) lbl new_fact+  = case lookupFact lbl fbase of+      Nothing ->+          -- Note [No old fact]+          let !z = mapInsert lbl new_fact fbase in (changed, z)+      Just old_fact ->+          case fact_join (OldFact old_fact) (NewFact new_fact) of+              (NotChanged _) -> (todo, fbase)+              (Changed f) -> let !z = mapInsert lbl f fbase in (changed, z)+  where+    changed = todo `IntSet.union`+              mapFindWithDefault IntSet.empty lbl dep_blocks++{-+Note [No old fact]++We know that the new_fact is >= _|_, so we don't need to join.  However,+if the new fact is also _|_, and we have already analysed its block,+we don't need to record a change.  So there's a tradeoff here.  It turns+out that always recording a change is faster.+-}++----------------------------------------------------------------+--       Utilities+----------------------------------------------------------------++-- Fact lookup: the fact `orelse` bottom+getFact  :: DataflowLattice f -> Label -> FactBase f -> f+getFact lat l fb = case lookupFact l fb of Just  f -> f+                                           Nothing -> fact_bot lat++-- | Returns the result of joining the facts from all the successors of the+-- provided node or block.+joinOutFacts :: (NonLocal n) => DataflowLattice f -> n e C -> FactBase f -> f+joinOutFacts lattice nonLocal fact_base = foldl' join (fact_bot lattice) facts+  where+    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)+    facts =+        [ fromJust fact+        | s <- successors nonLocal+        , let fact = lookupFact s fact_base+        , isJust fact+        ]++joinFacts :: DataflowLattice f -> [f] -> f+joinFacts lattice facts  = foldl' join (fact_bot lattice) facts+  where+    join new old = getJoined $ fact_join lattice (OldFact old) (NewFact new)++-- | Returns the joined facts for each label.+mkFactBase :: DataflowLattice f -> [(Label, f)] -> FactBase f+mkFactBase lattice = foldl' add mapEmpty+  where+    join = fact_join lattice++    add result (l, f1) =+        let !newFact =+                case mapLookup l result of+                    Nothing -> f1+                    Just f2 -> getJoined $ join (OldFact f1) (NewFact f2)+        in mapInsert l newFact result++-- | Folds backward over all nodes of an open-open block.+-- Strict in the accumulator.+foldNodesBwdOO :: (CmmNode O O -> f -> f) -> Block CmmNode O O -> f -> f+foldNodesBwdOO funOO = go+  where+    go (BCat b1 b2) f = go b1 $! go b2 f+    go (BSnoc h n) f = go h $! funOO n f+    go (BCons n t) f = funOO n $! go t f+    go (BMiddle n) f = funOO n f+    go BNil f = f+{-# INLINABLE foldNodesBwdOO #-}++-- | Folds backward over all the nodes of an open-open block and allows+-- rewriting them. The accumulator is both the block of nodes and @f@ (usually+-- dataflow facts).+-- Strict in both accumulated parts.+foldRewriteNodesBwdOO+    :: forall f.+       (CmmNode O O -> f -> UniqSM (Block CmmNode O O, f))+    -> Block CmmNode O O+    -> f+    -> UniqSM (Block CmmNode O O, f)+foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts+  where+    go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1+    go (BSnoc block1 node1) !fact1 = (go block1 `comp` rewriteOO node1) fact1+    go (BCat blockA1 blockB1) !fact1 = (go blockA1 `comp` go blockB1) fact1+    go (BMiddle node) !fact1 = rewriteOO node fact1+    go BNil !fact = return (BNil, fact)++    comp rew1 rew2 = \f1 -> do+        (b, f2) <- rew2 f1+        (a, !f3) <- rew1 f2+        let !c = joinBlocksOO a b+        return (c, f3)+    {-# INLINE comp #-}+{-# INLINABLE foldRewriteNodesBwdOO #-}++joinBlocksOO :: Block n O O -> Block n O O -> Block n O O+joinBlocksOO BNil b = b+joinBlocksOO b BNil = b+joinBlocksOO (BMiddle n) b = blockCons n b+joinBlocksOO b (BMiddle n) = blockSnoc b n+joinBlocksOO b1 b2 = BCat b1 b2++type IntHeap = IntSet
+ compiler/cmm/Hoopl/Graph.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module Hoopl.Graph+    ( Body+    , Graph+    , Graph'(..)+    , NonLocal(..)+    , addBlock+    , bodyList+    , emptyBody+    , labelsDefined+    , mapGraph+    , mapGraphBlocks+    , revPostorderFrom+    ) where+++import GhcPrelude+import Util++import Hoopl.Label+import Hoopl.Block+import Hoopl.Collections++-- | A (possibly empty) collection of closed/closed blocks+type Body n = LabelMap (Block n C C)++-- | @Body@ abstracted over @block@+type Body' block (n :: * -> * -> *) = LabelMap (block n C C)++-------------------------------+-- | Gives access to the anchor points for+-- nonlocal edges as well as the edges themselves+class NonLocal thing where+  entryLabel :: thing C x -> Label   -- ^ The label of a first node or block+  successors :: thing e C -> [Label] -- ^ Gives control-flow successors++instance NonLocal n => NonLocal (Block n) where+  entryLabel (BlockCO f _)   = entryLabel f+  entryLabel (BlockCC f _ _) = entryLabel f++  successors (BlockOC   _ n) = successors n+  successors (BlockCC _ _ n) = successors n+++emptyBody :: Body' block n+emptyBody = mapEmpty++bodyList :: Body' block n -> [(Label,block n C C)]+bodyList body = mapToList body++addBlock+    :: (NonLocal block, HasDebugCallStack)+    => block C C -> LabelMap (block C C) -> LabelMap (block C C)+addBlock block body = mapAlter add lbl body+  where+    lbl = entryLabel block+    add Nothing = Just block+    add _ = error $ "duplicate label " ++ show lbl ++ " in graph"+++-- ---------------------------------------------------------------------------+-- Graph++-- | A control-flow graph, which may take any of four shapes (O/O,+-- O/C, C/O, C/C).  A graph open at the entry has a single,+-- distinguished, anonymous entry point; if a graph is closed at the+-- entry, its entry point(s) are supplied by a context.+type Graph = Graph' Block++-- | @Graph'@ is abstracted over the block type, so that we can build+-- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow+-- needs this).+data Graph' block (n :: * -> * -> *) e x where+  GNil  :: Graph' block n O O+  GUnit :: block n O O -> Graph' block n O O+  GMany :: MaybeO e (block n O C)+        -> Body' block n+        -> MaybeO x (block n C O)+        -> Graph' block n e x+++-- -----------------------------------------------------------------------------+-- Mapping over graphs++-- | Maps over all nodes in a graph.+mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x+mapGraph f = mapGraphBlocks (mapBlock f)++-- | Function 'mapGraphBlocks' enables a change of representation of blocks,+-- nodes, or both.  It lifts a polymorphic block transform into a polymorphic+-- graph transform.  When the block representation stabilizes, a similar+-- function should be provided for blocks.+mapGraphBlocks :: forall block n block' n' e x .+                  (forall e x . block n e x -> block' n' e x)+               -> (Graph' block n e x -> Graph' block' n' e x)++mapGraphBlocks f = map+  where map :: Graph' block n e x -> Graph' block' n' e x+        map GNil = GNil+        map (GUnit b) = GUnit (f b)+        map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)++-- -----------------------------------------------------------------------------+-- Extracting Labels from graphs++labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x+              -> LabelSet+labelsDefined GNil      = setEmpty+labelsDefined (GUnit{}) = setEmpty+labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body+  where addEntry :: forall a. LabelSet -> ElemOf LabelSet -> a -> LabelSet+        addEntry labels label _ = setInsert label labels+        exitLabel :: MaybeO x (block n C O) -> LabelSet+        exitLabel NothingO  = setEmpty+        exitLabel (JustO b) = setSingleton (entryLabel b)+++----------------------------------------------------------------++-- | Returns a list of blocks reachable from the provided Labels in the reverse+-- postorder.+--+-- This is the most important traversal over this data structure.  It drops+-- unreachable code and puts blocks in an order that is good for solving forward+-- dataflow problems quickly.  The reverse order is good for solving backward+-- dataflow problems quickly.  The forward order is also reasonably good for+-- emitting instructions, except that it will not usually exploit Forrest+-- Baskett's trick of eliminating the unconditional branch from a loop.  For+-- that you would need a more serious analysis, probably based on dominators, to+-- identify loop headers.+--+-- For forward analyses we want reverse postorder visitation, consider:+-- @+--      A -> [B,C]+--      B -> D+--      C -> D+-- @+-- Postorder: [D, C, B, A] (or [D, B, C, A])+-- Reverse postorder: [A, B, C, D] (or [A, C, B, D])+-- This matters for, e.g., forward analysis, because we want to analyze *both*+-- B and C before we analyze D.+revPostorderFrom+  :: forall block.  (NonLocal block)+  => LabelMap (block C C) -> Label -> [block C C]+revPostorderFrom graph start = go start_worklist setEmpty []+  where+    start_worklist = lookup_for_descend start Nil++    -- To compute the postorder we need to "visit" a block (mark as done)+    -- *after* visiting all its successors. So we need to know whether we+    -- already processed all successors of each block (and @NonLocal@ allows+    -- arbitrary many successors). So we use an explicit stack with an extra bit+    -- of information:+    -- * @ConsTodo@ means to explore the block if it wasn't visited before+    -- * @ConsMark@ means that all successors were already done and we can add+    --   the block to the result.+    --+    -- NOTE: We add blocks to the result list in postorder, but we *prepend*+    -- them (i.e., we use @(:)@), which means that the final list is in reverse+    -- postorder.+    go :: DfsStack (block C C) -> LabelSet -> [block C C] -> [block C C]+    go Nil                      !_           !result = result+    go (ConsMark block rest)    !wip_or_done !result =+        go rest wip_or_done (block : result)+    go (ConsTodo block rest)    !wip_or_done !result+        | entryLabel block `setMember` wip_or_done = go rest wip_or_done result+        | otherwise =+            let new_worklist =+                    foldr lookup_for_descend+                          (ConsMark block rest)+                          (successors block)+            in go new_worklist (setInsert (entryLabel block) wip_or_done) result++    lookup_for_descend :: Label -> DfsStack (block C C) -> DfsStack (block C C)+    lookup_for_descend label wl+      | Just b <- mapLookup label graph = ConsTodo b wl+      | otherwise =+           error $ "Label that doesn't have a block?! " ++ show label++data DfsStack a = ConsTodo a (DfsStack a) | ConsMark a (DfsStack a) | Nil
+ compiler/cmm/Hoopl/Label.hs view
@@ -0,0 +1,142 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module Hoopl.Label+    ( Label+    , LabelMap+    , LabelSet+    , FactBase+    , lookupFact+    , mkHooplLabel+    ) where++import GhcPrelude++import Outputable++-- TODO: This should really just use GHC's Unique and Uniq{Set,FM}+import Hoopl.Collections++import Unique (Uniquable(..))+import TrieMap+++-----------------------------------------------------------------------------+--              Label+-----------------------------------------------------------------------------++newtype Label = Label { lblToUnique :: Int }+  deriving (Eq, Ord)++mkHooplLabel :: Int -> Label+mkHooplLabel = Label++instance Show Label where+  show (Label n) = "L" ++ show n++instance Uniquable Label where+  getUnique label = getUnique (lblToUnique label)++instance Outputable Label where+  ppr label = ppr (getUnique label)++-----------------------------------------------------------------------------+-- LabelSet++newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show, Monoid, Semigroup)++instance IsSet LabelSet where+  type ElemOf LabelSet = Label++  setNull (LS s) = setNull s+  setSize (LS s) = setSize s+  setMember (Label k) (LS s) = setMember k s++  setEmpty = LS setEmpty+  setSingleton (Label k) = LS (setSingleton k)+  setInsert (Label k) (LS s) = LS (setInsert k s)+  setDelete (Label k) (LS s) = LS (setDelete k s)++  setUnion (LS x) (LS y) = LS (setUnion x y)+  setDifference (LS x) (LS y) = LS (setDifference x y)+  setIntersection (LS x) (LS y) = LS (setIntersection x y)+  setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y+  setFilter f (LS s) = LS (setFilter (f . mkHooplLabel) s)+  setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s+  setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s++  setElems (LS s) = map mkHooplLabel (setElems s)+  setFromList ks = LS (setFromList (map lblToUnique ks))++-----------------------------------------------------------------------------+-- LabelMap++newtype LabelMap v = LM (UniqueMap v)+  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)++instance IsMap LabelMap where+  type KeyOf LabelMap = Label++  mapNull (LM m) = mapNull m+  mapSize (LM m) = mapSize m+  mapMember (Label k) (LM m) = mapMember k m+  mapLookup (Label k) (LM m) = mapLookup k m+  mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m++  mapEmpty = LM mapEmpty+  mapSingleton (Label k) v = LM (mapSingleton k v)+  mapInsert (Label k) v (LM m) = LM (mapInsert k v m)+  mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)+  mapDelete (Label k) (LM m) = LM (mapDelete k m)+  mapAlter f (Label k) (LM m) = LM (mapAlter f k m)+  mapAdjust f (Label k) (LM m) = LM (mapAdjust f k m)++  mapUnion (LM x) (LM y) = LM (mapUnion x y)+  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y)+  mapDifference (LM x) (LM y) = LM (mapDifference x y)+  mapIntersection (LM x) (LM y) = LM (mapIntersection x y)+  mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y++  mapMap f (LM m) = LM (mapMap f m)+  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m)+  mapFoldl k z (LM m) = mapFoldl k z m+  mapFoldr k z (LM m) = mapFoldr k z m+  mapFoldlWithKey k z (LM m) =+      mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m+  mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m+  mapFilter f (LM m) = LM (mapFilter f m)+  mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m)++  mapElems (LM m) = mapElems m+  mapKeys (LM m) = map mkHooplLabel (mapKeys m)+  mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m]+  mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])+  mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])++-----------------------------------------------------------------------------+-- Instances++instance Outputable LabelSet where+  ppr = ppr . setElems++instance Outputable a => Outputable (LabelMap a) where+  ppr = ppr . mapToList++instance TrieMap LabelMap where+  type Key LabelMap = Label+  emptyTM = mapEmpty+  lookupTM k m = mapLookup k m+  alterTM k f m = mapAlter f k m+  foldTM k m z = mapFoldr k z m+  mapTM f m = mapMap f m++-----------------------------------------------------------------------------+-- FactBase++type FactBase f = LabelMap f++lookupFact :: Label -> FactBase f -> Maybe f+lookupFact = mapLookup
+ compiler/cmm/MkGraph.hs view
@@ -0,0 +1,484 @@+{-# LANGUAGE BangPatterns, GADTs #-}++module MkGraph+  ( CmmAGraph, CmmAGraphScoped, CgStmt(..)+  , (<*>), catAGraphs+  , mkLabel, mkMiddle, mkLast, outOfLine+  , lgraphOfAGraph, labelAGraph++  , stackStubExpr+  , mkNop, mkAssign, mkStore+  , mkUnsafeCall, mkFinalCall, mkCallReturnsTo+  , mkJumpReturnsTo+  , mkJump, mkJumpExtra+  , mkRawJump+  , mkCbranch, mkSwitch+  , mkReturn, mkComment, mkCallEntry, mkBranch+  , mkUnwind+  , copyInOflow, copyOutOflow+  , noExtraStack+  , toCall, Transfer(..)+  )+where++import GhcPrelude hiding ( (<*>) ) -- avoid importing (<*>)++import BlockId+import Cmm+import CmmCallConv+import CmmSwitch (SwitchTargets)++import Hoopl.Block+import Hoopl.Graph+import Hoopl.Label+import DynFlags+import FastString+import ForeignCall+import OrdList+import SMRep (ByteOff)+import UniqSupply+import Util+import Panic+++-----------------------------------------------------------------------------+-- Building Graphs+++-- | CmmAGraph is a chunk of code consisting of:+--+--   * ordinary statements (assignments, stores etc.)+--   * jumps+--   * labels+--   * out-of-line labelled blocks+--+-- The semantics is that control falls through labels and out-of-line+-- blocks.  Everything after a jump up to the next label is by+-- definition unreachable code, and will be discarded.+--+-- Two CmmAGraphs can be stuck together with <*>, with the meaning that+-- control flows from the first to the second.+--+-- A 'CmmAGraph' can be turned into a 'CmmGraph' (closed at both ends)+-- by providing a label for the entry point and a tick scope; see+-- 'labelAGraph'.+type CmmAGraph = OrdList CgStmt+-- | Unlabeled graph with tick scope+type CmmAGraphScoped = (CmmAGraph, CmmTickScope)++data CgStmt+  = CgLabel BlockId CmmTickScope+  | CgStmt  (CmmNode O O)+  | CgLast  (CmmNode O C)+  | CgFork  BlockId CmmAGraph CmmTickScope++flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph+flattenCmmAGraph id (stmts_t, tscope) =+    CmmGraph { g_entry = id,+               g_graph = GMany NothingO body NothingO }+  where+  body = foldr addBlock emptyBody $ flatten id stmts_t tscope []++  --+  -- flatten: given an entry label and a CmmAGraph, make a list of blocks.+  --+  -- NB. avoid the quadratic-append trap by passing in the tail of the+  -- list.  This is important for Very Long Functions (e.g. in T783).+  --+  flatten :: Label -> CmmAGraph -> CmmTickScope -> [Block CmmNode C C]+          -> [Block CmmNode C C]+  flatten id g tscope blocks+      = flatten1 (fromOL g) block' blocks+      where !block' = blockJoinHead (CmmEntry id tscope) emptyBlock+  --+  -- flatten0: we are outside a block at this point: any code before+  -- the first label is unreachable, so just drop it.+  --+  flatten0 :: [CgStmt] -> [Block CmmNode C C] -> [Block CmmNode C C]+  flatten0 [] blocks = blocks++  flatten0 (CgLabel id tscope : stmts) blocks+    = flatten1 stmts block blocks+    where !block = blockJoinHead (CmmEntry id tscope) emptyBlock++  flatten0 (CgFork fork_id stmts_t tscope : rest) blocks+    = flatten fork_id stmts_t tscope $ flatten0 rest blocks++  flatten0 (CgLast _ : stmts) blocks = flatten0 stmts blocks+  flatten0 (CgStmt _ : stmts) blocks = flatten0 stmts blocks++  --+  -- flatten1: we have a partial block, collect statements until the+  -- next last node to make a block, then call flatten0 to get the rest+  -- of the blocks+  --+  flatten1 :: [CgStmt] -> Block CmmNode C O+           -> [Block CmmNode C C] -> [Block CmmNode C C]++  -- The current block falls through to the end of a function or fork:+  -- this code should not be reachable, but it may be referenced by+  -- other code that is not reachable.  We'll remove it later with+  -- dead-code analysis, but for now we have to keep the graph+  -- well-formed, so we terminate the block with a branch to the+  -- beginning of the current block.+  flatten1 [] block blocks+    = blockJoinTail block (CmmBranch (entryLabel block)) : blocks++  flatten1 (CgLast stmt : stmts) block blocks+    = block' : flatten0 stmts blocks+    where !block' = blockJoinTail block stmt++  flatten1 (CgStmt stmt : stmts) block blocks+    = flatten1 stmts block' blocks+    where !block' = blockSnoc block stmt++  flatten1 (CgFork fork_id stmts_t tscope : rest) block blocks+    = flatten fork_id stmts_t tscope $ flatten1 rest block blocks++  -- a label here means that we should start a new block, and the+  -- current block should fall through to the new block.+  flatten1 (CgLabel id tscp : stmts) block blocks+    = blockJoinTail block (CmmBranch id) :+      flatten1 stmts (blockJoinHead (CmmEntry id tscp) emptyBlock) blocks++++---------- AGraph manipulation++(<*>)          :: CmmAGraph -> CmmAGraph -> CmmAGraph+(<*>)           = appOL++catAGraphs     :: [CmmAGraph] -> CmmAGraph+catAGraphs      = concatOL++-- | created a sequence "goto id; id:" as an AGraph+mkLabel        :: BlockId -> CmmTickScope -> CmmAGraph+mkLabel bid scp = unitOL (CgLabel bid scp)++-- | creates an open AGraph from a given node+mkMiddle        :: CmmNode O O -> CmmAGraph+mkMiddle middle = unitOL (CgStmt middle)++-- | created a closed AGraph from a given node+mkLast         :: CmmNode O C -> CmmAGraph+mkLast last     = unitOL (CgLast last)++-- | A labelled code block; should end in a last node+outOfLine      :: BlockId -> CmmAGraphScoped -> CmmAGraph+outOfLine l (c,s) = unitOL (CgFork l c s)++-- | allocate a fresh label for the entry point+lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph+lgraphOfAGraph g = do+  u <- getUniqueM+  return (labelAGraph (mkBlockId u) g)++-- | use the given BlockId as the label of the entry point+labelAGraph    :: BlockId -> CmmAGraphScoped -> CmmGraph+labelAGraph lbl ag = flattenCmmAGraph lbl ag++---------- No-ops+mkNop        :: CmmAGraph+mkNop         = nilOL++mkComment    :: FastString -> CmmAGraph+mkComment fs+  -- SDM: generating all those comments takes time, this saved about 4% for me+  | debugIsOn = mkMiddle $ CmmComment fs+  | otherwise = nilOL++---------- Assignment and store+mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph+mkAssign l (CmmReg r) | l == r  = mkNop+mkAssign l r  = mkMiddle $ CmmAssign l r++mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph+mkStore  l r  = mkMiddle $ CmmStore  l r++---------- Control transfer+mkJump          :: DynFlags -> Convention -> CmmExpr+                -> [CmmExpr]+                -> UpdFrameOffset+                -> CmmAGraph+mkJump dflags conv e actuals updfr_off =+  lastWithArgs dflags Jump Old conv actuals updfr_off $+    toCall e Nothing updfr_off 0++-- | A jump where the caller says what the live GlobalRegs are.  Used+-- for low-level hand-written Cmm.+mkRawJump       :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg]+                -> CmmAGraph+mkRawJump dflags e updfr_off vols =+  lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $+    \arg_space _  -> toCall e Nothing updfr_off 0 arg_space vols+++mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr]+                -> UpdFrameOffset -> [CmmExpr]+                -> CmmAGraph+mkJumpExtra dflags conv e actuals updfr_off extra_stack =+  lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $+    toCall e Nothing updfr_off 0++mkCbranch       :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph+mkCbranch pred ifso ifnot likely =+  mkLast (CmmCondBranch pred ifso ifnot likely)++mkSwitch        :: CmmExpr -> SwitchTargets -> CmmAGraph+mkSwitch e tbl   = mkLast $ CmmSwitch e tbl++mkReturn        :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset+                -> CmmAGraph+mkReturn dflags e actuals updfr_off =+  lastWithArgs dflags Ret  Old NativeReturn actuals updfr_off $+    toCall e Nothing updfr_off 0++mkBranch        :: BlockId -> CmmAGraph+mkBranch bid     = mkLast (CmmBranch bid)++mkFinalCall   :: DynFlags+              -> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset+              -> CmmAGraph+mkFinalCall dflags f _ actuals updfr_off =+  lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $+    toCall f Nothing updfr_off 0++mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]+                -> BlockId+                -> ByteOff+                -> UpdFrameOffset+                -> [CmmExpr]+                -> CmmAGraph+mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do+  lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals+     updfr_off extra_stack $+       toCall f (Just ret_lbl) updfr_off ret_off++-- Like mkCallReturnsTo, but does not push the return address (it is assumed to be+-- already on the stack).+mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]+                -> BlockId+                -> ByteOff+                -> UpdFrameOffset+                -> CmmAGraph+mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off  = do+  lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $+       toCall f (Just ret_lbl) updfr_off ret_off++mkUnsafeCall  :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph+mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as++-- | Construct a 'CmmUnwind' node for the given register and unwinding+-- expression.+mkUnwind     :: GlobalReg -> CmmExpr -> CmmAGraph+mkUnwind r e  = mkMiddle $ CmmUnwind [(r, Just e)]++--------------------------------------------------------------------------+++++-- Why are we inserting extra blocks that simply branch to the successors?+-- Because in addition to the branch instruction, @mkBranch@ will insert+-- a necessary adjustment to the stack pointer.+++-- For debugging purposes, we can stub out dead stack slots:+stackStubExpr :: Width -> CmmExpr+stackStubExpr w = CmmLit (CmmInt 0 w)++-- When we copy in parameters, we usually want to put overflow+-- parameters on the stack, but sometimes we want to pass the+-- variables in their spill slots.  Therefore, for copying arguments+-- and results, we provide different functions to pass the arguments+-- in an overflow area and to pass them in spill slots.+copyInOflow  :: DynFlags -> Convention -> Area+             -> [CmmFormal]+             -> [CmmFormal]+             -> (Int, [GlobalReg], CmmAGraph)++copyInOflow dflags conv area formals extra_stk+  = (offset, gregs, catAGraphs $ map mkMiddle nodes)+  where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk++-- Return the number of bytes used for copying arguments, as well as the+-- instructions to copy the arguments.+copyIn :: DynFlags -> Convention -> Area+       -> [CmmFormal]+       -> [CmmFormal]+       -> (ByteOff, [GlobalReg], [CmmNode O O])+copyIn dflags conv area formals extra_stk+  = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))+  where+    -- See Note [Width of parameters]+    ci (reg, RegisterParam r@(VanillaReg {})) =+        let local = CmmLocal reg+            global = CmmReg (CmmGlobal r)+            width = cmmRegWidth dflags local+            expr+                | width == wordWidth dflags = global+                | width < wordWidth dflags =+                    CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [global]+                | otherwise = panic "Parameter width greater than word width"++        in CmmAssign local expr++    -- Non VanillaRegs+    ci (reg, RegisterParam r) =+        CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))++    ci (reg, StackParam off)+      | isBitsType $ localRegType reg+      , typeWidth (localRegType reg) < wordWidth dflags =+        let+          stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth dflags))+          local = CmmLocal reg+          width = cmmRegWidth dflags local+          expr  = CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [stack_slot]+        in CmmAssign local expr +         +      | otherwise =+         CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)+         where ty = localRegType reg++    init_offset = widthInBytes (wordWidth dflags) -- infotable++    (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk++    (stk_size, args) = assignArgumentsPos dflags stk_off conv+                                          localRegType formals++-- Factoring out the common parts of the copyout functions yielded something+-- more complicated:++data Transfer = Call | JumpRet | Jump | Ret deriving Eq++copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]+             -> UpdFrameOffset+             -> [CmmExpr] -- extra stack args+             -> (Int, [GlobalReg], CmmAGraph)++-- Generate code to move the actual parameters into the locations+-- required by the calling convention.  This includes a store for the+-- return address.+--+-- The argument layout function ignores the pointer to the info table,+-- so we slot that in here. When copying-out to a young area, we set+-- the info table for return and adjust the offsets of the other+-- parameters.  If this is a call instruction, we adjust the offsets+-- of the other parameters.+copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff+  = (stk_size, regs, graph)+  where+    (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)++    -- See Note [Width of parameters]+    co (v, RegisterParam r@(VanillaReg {})) (rs, ms) =+        let width = cmmExprWidth dflags v+            value+                | width == wordWidth dflags = v+                | width < wordWidth dflags =+                    CmmMachOp (MO_XX_Conv width (wordWidth dflags)) [v]+                | otherwise = panic "Parameter width greater than word width"++        in (r:rs, mkAssign (CmmGlobal r) value <*> ms)++    -- Non VanillaRegs+    co (v, RegisterParam r) (rs, ms) =+        (r:rs, mkAssign (CmmGlobal r) v <*> ms)++    -- See Note [Width of parameters]+    co (v, StackParam off)  (rs, ms)+      = (rs, mkStore (CmmStackSlot area off) (value v) <*> ms)++    width v = cmmExprWidth dflags v+    value v+      | isBitsType $ cmmExprType dflags v+      , width v < wordWidth dflags =+        CmmMachOp (MO_XX_Conv (width v) (wordWidth dflags)) [v]+      | otherwise = v++    (setRA, init_offset) =+      case area of+            Young id ->  -- Generate a store instruction for+                         -- the return address if making a call+                  case transfer of+                     Call ->+                       ([(CmmLit (CmmBlock id), StackParam init_offset)],+                       widthInBytes (wordWidth dflags))+                     JumpRet ->+                       ([],+                       widthInBytes (wordWidth dflags))+                     _other ->+                       ([], 0)+            Old -> ([], updfr_off)++    (extra_stack_off, stack_params) =+       assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff++    args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it+    (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv+                                          (cmmExprType dflags) actuals+++-- Note [Width of parameters]+--+-- Consider passing a small (< word width) primitive like Int8# to a function.+-- It's actually non-trivial to do this without extending/narrowing:+-- * Global registers are considered to have native word width (i.e., 64-bits on+--   x86-64), so CmmLint would complain if we assigned an 8-bit parameter to a+--   global register.+-- * Same problem exists with LLVM IR.+-- * Lowering gets harder since on x86-32 not every register exposes its lower+--   8 bits (e.g., for %eax we can use %al, but there isn't a corresponding+--   8-bit register for %edi). So we would either need to extend/narrow anyway,+--   or complicate the calling convention.+-- * Passing a small integer in a stack slot, which has native word width,+--   requires extending to word width when writing to the stack and narrowing+--   when reading off the stack (see #16258).+-- So instead, we always extend every parameter smaller than native word width+-- in copyOutOflow and then truncate it back to the expected width in copyIn.+-- Note that we do this in cmm using MO_XX_Conv to avoid requiring+-- zero-/sign-extending - it's up to a backend to handle this in a most+-- efficient way (e.g., a simple register move or a smaller size store).+-- This convention (of ignoring the upper bits) is different from some C ABIs,+-- e.g. all PowerPC ELF ABIs, that require sign or zero extending parameters.+--+-- There was some discussion about this on this PR:+-- https://github.com/ghc-proposals/ghc-proposals/pull/74+++mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]+            -> (Int, [GlobalReg], CmmAGraph)+mkCallEntry dflags conv formals extra_stk+  = copyInOflow dflags conv Old formals extra_stk++lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmExpr]+             -> UpdFrameOffset+             -> (ByteOff -> [GlobalReg] -> CmmAGraph)+             -> CmmAGraph+lastWithArgs dflags transfer area conv actuals updfr_off last =+  lastWithArgsAndExtraStack dflags transfer area conv actuals+                            updfr_off noExtraStack last++lastWithArgsAndExtraStack :: DynFlags+             -> Transfer -> Area -> Convention -> [CmmExpr]+             -> UpdFrameOffset -> [CmmExpr]+             -> (ByteOff -> [GlobalReg] -> CmmAGraph)+             -> CmmAGraph+lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off+                          extra_stack last =+  copies <*> last outArgs regs+ where+  (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals+                               updfr_off extra_stack+++noExtraStack :: [CmmExpr]+noExtraStack = []++toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff+       -> ByteOff -> [GlobalReg]+       -> CmmAGraph+toCall e cont updfr_off res_space arg_space regs =+  mkLast $ CmmCall e cont regs arg_space res_space updfr_off
+ compiler/cmm/PprC.hs view
@@ -0,0 +1,1383 @@+{-# LANGUAGE CPP, GADTs #-}++-----------------------------------------------------------------------------+--+-- Pretty-printing of Cmm as C, suitable for feeding gcc+--+-- (c) The University of Glasgow 2004-2006+--+-- Print Cmm as real C, for -fvia-C+--+-- See wiki:commentary/compiler/backends/ppr-c+--+-- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"+-- relative to the old AbstractC, and many oddities/decorations have+-- disappeared from the data type.+--+-- This code generator is only supported in unregisterised mode.+--+-----------------------------------------------------------------------------++module PprC (+        writeCs,+        pprStringInCStyle+  ) where++#include "HsVersions.h"++-- Cmm stuff+import GhcPrelude++import BlockId+import CLabel+import ForeignCall+import Cmm hiding (pprBBlock)+import PprCmm ()+import Hoopl.Block+import Hoopl.Collections+import Hoopl.Graph+import CmmUtils+import CmmSwitch++-- Utils+import CPrim+import DynFlags+import FastString+import Outputable+import Platform+import UniqSet+import UniqFM+import Unique+import Util++-- The rest+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Control.Monad.ST+import Data.Bits+import Data.Char+import Data.List+import Data.Map (Map)+import Data.Word+import System.IO+import qualified Data.Map as Map+import Control.Monad (liftM, ap)+import qualified Data.Array.Unsafe as U ( castSTUArray )+import Data.Array.ST++-- --------------------------------------------------------------------------+-- Top level++pprCs :: [RawCmmGroup] -> SDoc+pprCs cmms+ = pprCode CStyle (vcat $ map pprC cmms)++writeCs :: DynFlags -> Handle -> [RawCmmGroup] -> IO ()+writeCs dflags handle cmms+  = printForC dflags handle (pprCs cmms)++-- --------------------------------------------------------------------------+-- Now do some real work+--+-- for fun, we could call cmmToCmm over the tops...+--++pprC :: RawCmmGroup -> SDoc+pprC tops = vcat $ intersperse blankLine $ map pprTop tops++--+-- top level procs+--+pprTop :: RawCmmDecl -> SDoc+pprTop (CmmProc infos clbl _in_live_regs graph) =++    (case mapLookup (g_entry graph) infos of+       Nothing -> empty+       Just (Statics info_clbl info_dat) ->+           pprDataExterns info_dat $$+           pprWordArray info_is_in_rodata info_clbl info_dat) $$+    (vcat [+           blankLine,+           extern_decls,+           (if (externallyVisibleCLabel clbl)+                    then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,+           nest 8 temp_decls,+           vcat (map pprBBlock blocks),+           rbrace ]+    )+  where+        -- info tables are always in .rodata+        info_is_in_rodata = True+        blocks = toBlockListEntryFirst graph+        (temp_decls, extern_decls) = pprTempAndExternDecls blocks+++-- Chunks of static data.++-- We only handle (a) arrays of word-sized things and (b) strings.++pprTop (CmmData section (Statics lbl [CmmString str])) =+  pprExternDecl lbl $$+  hcat [+    pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,+    text "[] = ", pprStringInCStyle str, semi+  ]++pprTop (CmmData section (Statics lbl [CmmUninitialised size])) =+  pprExternDecl lbl $$+  hcat [+    pprLocalness lbl, pprConstness (isSecConstant section), text "char ", ppr lbl,+    brackets (int size), semi+  ]++pprTop (CmmData section (Statics lbl lits)) =+  pprDataExterns lits $$+  pprWordArray (isSecConstant section) lbl lits++-- --------------------------------------------------------------------------+-- BasicBlocks are self-contained entities: they always end in a jump.+--+-- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn+-- as many jumps as possible into fall throughs.+--++pprBBlock :: CmmBlock -> SDoc+pprBBlock block =+  nest 4 (pprBlockId (entryLabel block) <> colon) $$+  nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last)+ where+  (_, nodes, last)  = blockSplit block++-- --------------------------------------------------------------------------+-- Info tables. Just arrays of words.+-- See codeGen/ClosureInfo, and nativeGen/PprMach++pprWordArray :: Bool -> CLabel -> [CmmStatic] -> SDoc+pprWordArray is_ro lbl ds+  = sdocWithDynFlags $ \dflags ->+    -- TODO: align closures only+    pprExternDecl lbl $$+    hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord"+         , space, ppr lbl, text "[]"+         -- See Note [StgWord alignment]+         , pprAlignment (wordWidth dflags)+         , text "= {" ]+    $$ nest 8 (commafy (pprStatics dflags ds))+    $$ text "};"++pprAlignment :: Width -> SDoc+pprAlignment words =+     text "__attribute__((aligned(" <> int (widthInBytes words) <> text ")))"++-- Note [StgWord alignment]+-- C codegen builds static closures as StgWord C arrays (pprWordArray).+-- Their real C type is 'StgClosure'. Macros like UNTAG_CLOSURE assume+-- pointers to 'StgClosure' are aligned at pointer size boundary:+--  4 byte boundary on 32 systems+--  and 8 bytes on 64-bit systems+-- see TAG_MASK and TAG_BITS definition and usage.+--+-- It's a reasonable assumption also known as natural alignment.+-- Although some architectures have different alignment rules.+-- One of known exceptions is m68k (#11395, comment:16) where:+--   __alignof__(StgWord) == 2, sizeof(StgWord) == 4+--+-- Thus we explicitly increase alignment by using+--    __attribute__((aligned(4)))+-- declaration.++--+-- has to be static, if it isn't globally visible+--+pprLocalness :: CLabel -> SDoc+pprLocalness lbl | not $ externallyVisibleCLabel lbl = text "static "+                 | otherwise = empty++pprConstness :: Bool -> SDoc+pprConstness is_ro | is_ro = text "const "+                   | otherwise = empty++-- --------------------------------------------------------------------------+-- Statements.+--++pprStmt :: CmmNode e x -> SDoc++pprStmt stmt =+    sdocWithDynFlags $ \dflags ->+    case stmt of+    CmmEntry{}   -> empty+    CmmComment _ -> empty -- (hang (text "/*") 3 (ftext s)) $$ ptext (sLit "*/")+                          -- XXX if the string contains "*/", we need to fix it+                          -- XXX we probably want to emit these comments when+                          -- some debugging option is on.  They can get quite+                          -- large.++    CmmTick _ -> empty+    CmmUnwind{} -> empty++    CmmAssign dest src -> pprAssign dflags dest src++    CmmStore  dest src+        | typeWidth rep == W64 && wordWidth dflags /= W64+        -> (if isFloatType rep then text "ASSIGN_DBL"+                               else ptext (sLit ("ASSIGN_Word64"))) <>+           parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi++        | otherwise+        -> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]+        where+          rep = cmmExprType dflags src++    CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args ->+        fnCall+        where+        (res_hints, arg_hints) = foreignTargetHints target+        hresults = zip results res_hints+        hargs    = zip args arg_hints++        ForeignConvention cconv _ _ ret = conv++        cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn)++        -- See wiki:commentary/compiler/backends/ppr-c#prototypes+        fnCall =+            case fn of+              CmmLit (CmmLabel lbl)+                | StdCallConv <- cconv ->+                    pprCall (ppr lbl) cconv hresults hargs+                        -- stdcall functions must be declared with+                        -- a function type, otherwise the C compiler+                        -- doesn't add the @n suffix to the label.  We+                        -- can't add the @n suffix ourselves, because+                        -- it isn't valid C.+                | CmmNeverReturns <- ret ->+                    pprCall cast_fn cconv hresults hargs <> semi+                | not (isMathFun lbl) ->+                    pprForeignCall (ppr lbl) cconv hresults hargs+              _ ->+                    pprCall cast_fn cconv hresults hargs <> semi+                        -- for a dynamic call, no declaration is necessary.++    CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty+    CmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data _)) _results _args -> empty++    CmmUnsafeForeignCall target@(PrimTarget op) results args ->+        fn_call+      where+        cconv = CCallConv+        fn = pprCallishMachOp_for_C op++        (res_hints, arg_hints) = foreignTargetHints target+        hresults = zip results res_hints+        hargs    = zip args arg_hints++        fn_call+          -- The mem primops carry an extra alignment arg.+          -- We could maybe emit an alignment directive using this info.+          -- We also need to cast mem primops to prevent conflicts with GCC+          -- builtins (see bug #5967).+          | Just _align <- machOpMemcpyishAlign op+          = (text ";EFF_(" <> fn <> char ')' <> semi) $$+            pprForeignCall fn cconv hresults hargs+          | otherwise+          = pprCall fn cconv hresults hargs++    CmmBranch ident          -> pprBranch ident+    CmmCondBranch expr yes no _ -> pprCondBranch expr yes no+    CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi+    CmmSwitch arg ids        -> sdocWithDynFlags $ \dflags ->+                                pprSwitch dflags arg ids++    _other -> pprPanic "PprC.pprStmt" (ppr stmt)++type Hinted a = (a, ForeignHint)++pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]+               -> SDoc+pprForeignCall fn cconv results args = fn_call+  where+    fn_call = braces (+                 pprCFunType (char '*' <> text "ghcFunPtr") cconv results args <> semi+              $$ text "ghcFunPtr" <+> equals <+> cast_fn <> semi+              $$ pprCall (text "ghcFunPtr") cconv results args <> semi+             )+    cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)++pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc+pprCFunType ppr_fn cconv ress args+  = sdocWithDynFlags $ \dflags ->+    let res_type [] = text "void"+        res_type [(one, hint)] = machRepHintCType (localRegType one) hint+        res_type _ = panic "pprCFunType: only void or 1 return value supported"++        arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint+    in res_type ress <+>+       parens (ccallConvAttribute cconv <> ppr_fn) <>+       parens (commafy (map arg_type args))++-- ---------------------------------------------------------------------+-- unconditional branches+pprBranch :: BlockId -> SDoc+pprBranch ident = text "goto" <+> pprBlockId ident <> semi+++-- ---------------------------------------------------------------------+-- conditional branches to local labels+pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc+pprCondBranch expr yes no+        = hsep [ text "if" , parens(pprExpr expr) ,+                        text "goto", pprBlockId yes <> semi,+                        text "else goto", pprBlockId no <> semi ]++-- ---------------------------------------------------------------------+-- a local table branch+--+-- we find the fall-through cases+--+pprSwitch :: DynFlags -> CmmExpr -> SwitchTargets -> SDoc+pprSwitch dflags e ids+  = (hang (text "switch" <+> parens ( pprExpr e ) <+> lbrace)+                4 (vcat ( map caseify pairs ) $$ def)) $$ rbrace+  where+    (pairs, mbdef) = switchTargetsFallThrough ids++    -- fall through case+    caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix+        where+        do_fallthrough ix =+                 hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,+                        text "/* fall through */" ]++        final_branch ix =+                hsep [ text "case" , pprHexVal ix (wordWidth dflags) <> colon ,+                       text "goto" , (pprBlockId ident) <> semi ]++    caseify (_     , _    ) = panic "pprSwitch: switch with no cases!"++    def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi+        | otherwise       = empty++-- ---------------------------------------------------------------------+-- Expressions.+--++-- C Types: the invariant is that the C expression generated by+--+--      pprExpr e+--+-- has a type in C which is also given by+--+--      machRepCType (cmmExprType e)+--+-- (similar invariants apply to the rest of the pretty printer).++pprExpr :: CmmExpr -> SDoc+pprExpr e = case e of+    CmmLit lit -> pprLit lit+++    CmmLoad e ty -> sdocWithDynFlags $ \dflags -> pprLoad dflags e ty+    CmmReg reg      -> pprCastReg reg+    CmmRegOff reg 0 -> pprCastReg reg++    -- CmmRegOff is an alias of MO_Add+    CmmRegOff reg i -> sdocWithDynFlags $ \dflags ->+                       pprCastReg reg <> char '+' <>+                       pprHexVal (fromIntegral i) (wordWidth dflags)++    CmmMachOp mop args -> pprMachOpApp mop args++    CmmStackSlot _ _   -> panic "pprExpr: CmmStackSlot not supported!"+++pprLoad :: DynFlags -> CmmExpr -> CmmType -> SDoc+pprLoad dflags e ty+  | width == W64, wordWidth dflags /= W64+  = (if isFloatType ty then text "PK_DBL"+                       else text "PK_Word64")+    <> parens (mkP_ <> pprExpr1 e)++  | otherwise+  = case e of+        CmmReg r | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)+                 -> char '*' <> pprAsPtrReg r++        CmmRegOff r 0 | isPtrReg r && width == wordWidth dflags && not (isFloatType ty)+                      -> char '*' <> pprAsPtrReg r++        CmmRegOff r off | isPtrReg r && width == wordWidth dflags+                        , off `rem` wORD_SIZE dflags == 0 && not (isFloatType ty)+        -- ToDo: check that the offset is a word multiple?+        --       (For tagging to work, I had to avoid unaligned loads. --ARY)+                        -> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift dflags))++        _other -> cLoad e ty+  where+    width = typeWidth ty++pprExpr1 :: CmmExpr -> SDoc+pprExpr1 (CmmLit lit)     = pprLit1 lit+pprExpr1 e@(CmmReg _reg)  = pprExpr e+pprExpr1 other            = parens (pprExpr other)++-- --------------------------------------------------------------------------+-- MachOp applications++pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc++pprMachOpApp op args+  | isMulMayOfloOp op+  = text "mulIntMayOflo" <> parens (commafy (map pprExpr args))+  where isMulMayOfloOp (MO_U_MulMayOflo _) = True+        isMulMayOfloOp (MO_S_MulMayOflo _) = True+        isMulMayOfloOp _ = False++pprMachOpApp mop args+  | Just ty <- machOpNeedsCast mop+  = ty <> parens (pprMachOpApp' mop args)+  | otherwise+  = pprMachOpApp' mop args++-- Comparisons in C have type 'int', but we want type W_ (this is what+-- resultRepOfMachOp says).  The other C operations inherit their type+-- from their operands, so no casting is required.+machOpNeedsCast :: MachOp -> Maybe SDoc+machOpNeedsCast mop+  | isComparisonMachOp mop = Just mkW_+  | otherwise              = Nothing++pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc+pprMachOpApp' mop args+ = case args of+    -- dyadic+    [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y++    -- unary+    [x]   -> pprMachOp_for_C mop <> parens (pprArg x)++    _     -> panic "PprC.pprMachOp : machop with wrong number of args"++  where+        -- Cast needed for signed integer ops+    pprArg e | signedOp    mop = sdocWithDynFlags $ \dflags ->+                                 cCast (machRep_S_CType (typeWidth (cmmExprType dflags e))) e+             | needsFCasts mop = sdocWithDynFlags $ \dflags ->+                                 cCast (machRep_F_CType (typeWidth (cmmExprType dflags e))) e+             | otherwise    = pprExpr1 e+    needsFCasts (MO_F_Eq _)   = False+    needsFCasts (MO_F_Ne _)   = False+    needsFCasts (MO_F_Neg _)  = True+    needsFCasts (MO_F_Quot _) = True+    needsFCasts mop  = floatComparison mop++-- --------------------------------------------------------------------------+-- Literals++pprLit :: CmmLit -> SDoc+pprLit lit = case lit of+    CmmInt i rep      -> pprHexVal i rep++    CmmFloat f w       -> parens (machRep_F_CType w) <> str+        where d = fromRational f :: Double+              str | isInfinite d && d < 0 = text "-INFINITY"+                  | isInfinite d          = text "INFINITY"+                  | isNaN d               = text "NAN"+                  | otherwise             = text (show d)+                -- these constants come from <math.h>+                -- see #1861++    CmmVec {} -> panic "PprC printing vector literal"++    CmmBlock bid       -> mkW_ <> pprCLabelAddr (infoTblLbl bid)+    CmmHighStackMark   -> panic "PprC printing high stack mark"+    CmmLabel clbl      -> mkW_ <> pprCLabelAddr clbl+    CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i+    CmmLabelDiffOff clbl1 _ i _   -- non-word widths not supported via C+        -- WARNING:+        --  * the lit must occur in the info table clbl2+        --  * clbl1 must be an SRT, a slow entry point or a large bitmap+        -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i++    where+        pprCLabelAddr lbl = char '&' <> ppr lbl++pprLit1 :: CmmLit -> SDoc+pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)+pprLit1 lit@(CmmLabelDiffOff _ _ _ _) = parens (pprLit lit)+pprLit1 lit@(CmmFloat _ _)    = parens (pprLit lit)+pprLit1 other = pprLit other++-- ---------------------------------------------------------------------------+-- Static data++pprStatics :: DynFlags -> [CmmStatic] -> [SDoc]+pprStatics _ [] = []+pprStatics dflags (CmmStaticLit (CmmFloat f W32) : rest)+  -- odd numbers of floats are padded to a word by mkVirtHeapOffsetsWithPadding+  | wORD_SIZE dflags == 8, CmmStaticLit (CmmInt 0 W32) : rest' <- rest+  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest'+  -- adjacent floats aren't padded but combined into a single word+  | wORD_SIZE dflags == 8, CmmStaticLit (CmmFloat g W32) : rest' <- rest+  = pprLit1 (floatPairToWord dflags f g) : pprStatics dflags rest'+  | wORD_SIZE dflags == 4+  = pprLit1 (floatToWord dflags f) : pprStatics dflags rest+  | otherwise+  = pprPanic "pprStatics: float" (vcat (map ppr' rest))+    where ppr' (CmmStaticLit l) = sdocWithDynFlags $ \dflags ->+                                  ppr (cmmLitType dflags l)+          ppr' _other           = text "bad static!"+pprStatics dflags (CmmStaticLit (CmmFloat f W64) : rest)+  = map pprLit1 (doubleToWords dflags f) ++ pprStatics dflags rest++pprStatics dflags (CmmStaticLit (CmmInt i W64) : rest)+  | wordWidth dflags == W32+  = if wORDS_BIGENDIAN dflags+    then pprStatics dflags (CmmStaticLit (CmmInt q W32) :+                            CmmStaticLit (CmmInt r W32) : rest)+    else pprStatics dflags (CmmStaticLit (CmmInt r W32) :+                            CmmStaticLit (CmmInt q W32) : rest)+  where r = i .&. 0xffffffff+        q = i `shiftR` 32+pprStatics dflags (CmmStaticLit (CmmInt a W32) :+                   CmmStaticLit (CmmInt b W32) : rest)+  | wordWidth dflags == W64+  = if wORDS_BIGENDIAN dflags+    then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 32) .|. b) W64) :+                            rest)+    else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 32) .|. a) W64) :+                            rest)+pprStatics dflags (CmmStaticLit (CmmInt a W16) :+                   CmmStaticLit (CmmInt b W16) : rest)+  | wordWidth dflags == W32+  = if wORDS_BIGENDIAN dflags+    then pprStatics dflags (CmmStaticLit (CmmInt ((shiftL a 16) .|. b) W32) :+                            rest)+    else pprStatics dflags (CmmStaticLit (CmmInt ((shiftL b 16) .|. a) W32) :+                            rest)+pprStatics dflags (CmmStaticLit (CmmInt _ w) : _)+  | w /= wordWidth dflags+  = pprPanic "pprStatics: cannot emit a non-word-sized static literal" (ppr w)+pprStatics dflags (CmmStaticLit lit : rest)+  = pprLit1 lit : pprStatics dflags rest+pprStatics _ (other : _)+  = pprPanic "pprStatics: other" (pprStatic other)++pprStatic :: CmmStatic -> SDoc+pprStatic s = case s of++    CmmStaticLit lit   -> nest 4 (pprLit lit)+    CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))++    -- these should be inlined, like the old .hc+    CmmString s'       -> nest 4 (mkW_ <> parens(pprStringInCStyle s'))+++-- ---------------------------------------------------------------------------+-- Block Ids++pprBlockId :: BlockId -> SDoc+pprBlockId b = char '_' <> ppr (getUnique b)++-- --------------------------------------------------------------------------+-- Print a MachOp in a way suitable for emitting via C.+--++pprMachOp_for_C :: MachOp -> SDoc++pprMachOp_for_C mop = case mop of++        -- Integer operations+        MO_Add          _ -> char '+'+        MO_Sub          _ -> char '-'+        MO_Eq           _ -> text "=="+        MO_Ne           _ -> text "!="+        MO_Mul          _ -> char '*'++        MO_S_Quot       _ -> char '/'+        MO_S_Rem        _ -> char '%'+        MO_S_Neg        _ -> char '-'++        MO_U_Quot       _ -> char '/'+        MO_U_Rem        _ -> char '%'++        -- & Floating-point operations+        MO_F_Add        _ -> char '+'+        MO_F_Sub        _ -> char '-'+        MO_F_Neg        _ -> char '-'+        MO_F_Mul        _ -> char '*'+        MO_F_Quot       _ -> char '/'++        -- Signed comparisons+        MO_S_Ge         _ -> text ">="+        MO_S_Le         _ -> text "<="+        MO_S_Gt         _ -> char '>'+        MO_S_Lt         _ -> char '<'++        -- & Unsigned comparisons+        MO_U_Ge         _ -> text ">="+        MO_U_Le         _ -> text "<="+        MO_U_Gt         _ -> char '>'+        MO_U_Lt         _ -> char '<'++        -- & Floating-point comparisons+        MO_F_Eq         _ -> text "=="+        MO_F_Ne         _ -> text "!="+        MO_F_Ge         _ -> text ">="+        MO_F_Le         _ -> text "<="+        MO_F_Gt         _ -> char '>'+        MO_F_Lt         _ -> char '<'++        -- Bitwise operations.  Not all of these may be supported at all+        -- sizes, and only integral MachReps are valid.+        MO_And          _ -> char '&'+        MO_Or           _ -> char '|'+        MO_Xor          _ -> char '^'+        MO_Not          _ -> char '~'+        MO_Shl          _ -> text "<<"+        MO_U_Shr        _ -> text ">>" -- unsigned shift right+        MO_S_Shr        _ -> text ">>" -- signed shift right++-- Conversions.  Some of these will be NOPs, but never those that convert+-- between ints and floats.+-- Floating-point conversions use the signed variant.+-- We won't know to generate (void*) casts here, but maybe from+-- context elsewhere++-- noop casts+        MO_UU_Conv from to | from == to -> empty+        MO_UU_Conv _from to -> parens (machRep_U_CType to)++        MO_SS_Conv from to | from == to -> empty+        MO_SS_Conv _from to -> parens (machRep_S_CType to)++        MO_XX_Conv from to | from == to -> empty+        MO_XX_Conv _from to -> parens (machRep_U_CType to)++        MO_FF_Conv from to | from == to -> empty+        MO_FF_Conv _from to -> parens (machRep_F_CType to)++        MO_SF_Conv _from to -> parens (machRep_F_CType to)+        MO_FS_Conv _from to -> parens (machRep_S_CType to)++        MO_S_MulMayOflo _ -> pprTrace "offending mop:"+                                (text "MO_S_MulMayOflo")+                                (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo"+                                      ++ " should have been handled earlier!")+        MO_U_MulMayOflo _ -> pprTrace "offending mop:"+                                (text "MO_U_MulMayOflo")+                                (panic $ "PprC.pprMachOp_for_C: MO_U_MulMayOflo"+                                      ++ " should have been handled earlier!")++        MO_V_Insert {}    -> pprTrace "offending mop:"+                                (text "MO_V_Insert")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Insert"+                                      ++ " should have been handled earlier!")+        MO_V_Extract {}   -> pprTrace "offending mop:"+                                (text "MO_V_Extract")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Extract"+                                      ++ " should have been handled earlier!")++        MO_V_Add {}       -> pprTrace "offending mop:"+                                (text "MO_V_Add")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Add"+                                      ++ " should have been handled earlier!")+        MO_V_Sub {}       -> pprTrace "offending mop:"+                                (text "MO_V_Sub")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Sub"+                                      ++ " should have been handled earlier!")+        MO_V_Mul {}       -> pprTrace "offending mop:"+                                (text "MO_V_Mul")+                                (panic $ "PprC.pprMachOp_for_C: MO_V_Mul"+                                      ++ " should have been handled earlier!")++        MO_VS_Quot {}     -> pprTrace "offending mop:"+                                (text "MO_VS_Quot")+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Quot"+                                      ++ " should have been handled earlier!")+        MO_VS_Rem {}      -> pprTrace "offending mop:"+                                (text "MO_VS_Rem")+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Rem"+                                      ++ " should have been handled earlier!")+        MO_VS_Neg {}      -> pprTrace "offending mop:"+                                (text "MO_VS_Neg")+                                (panic $ "PprC.pprMachOp_for_C: MO_VS_Neg"+                                      ++ " should have been handled earlier!")++        MO_VU_Quot {}     -> pprTrace "offending mop:"+                                (text "MO_VU_Quot")+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Quot"+                                      ++ " should have been handled earlier!")+        MO_VU_Rem {}      -> pprTrace "offending mop:"+                                (text "MO_VU_Rem")+                                (panic $ "PprC.pprMachOp_for_C: MO_VU_Rem"+                                      ++ " should have been handled earlier!")++        MO_VF_Insert {}   -> pprTrace "offending mop:"+                                (text "MO_VF_Insert")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Insert"+                                      ++ " should have been handled earlier!")+        MO_VF_Extract {}  -> pprTrace "offending mop:"+                                (text "MO_VF_Extract")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract"+                                      ++ " should have been handled earlier!")++        MO_VF_Add {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Add")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Add"+                                      ++ " should have been handled earlier!")+        MO_VF_Sub {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Sub")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub"+                                      ++ " should have been handled earlier!")+        MO_VF_Neg {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Neg")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg"+                                      ++ " should have been handled earlier!")+        MO_VF_Mul {}      -> pprTrace "offending mop:"+                                (text "MO_VF_Mul")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul"+                                      ++ " should have been handled earlier!")+        MO_VF_Quot {}     -> pprTrace "offending mop:"+                                (text "MO_VF_Quot")+                                (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot"+                                      ++ " should have been handled earlier!")++        MO_AlignmentCheck {} -> panic "-falignment-santisation not supported by unregisterised backend"++signedOp :: MachOp -> Bool      -- Argument type(s) are signed ints+signedOp (MO_S_Quot _)    = True+signedOp (MO_S_Rem  _)    = True+signedOp (MO_S_Neg  _)    = True+signedOp (MO_S_Ge   _)    = True+signedOp (MO_S_Le   _)    = True+signedOp (MO_S_Gt   _)    = True+signedOp (MO_S_Lt   _)    = True+signedOp (MO_S_Shr  _)    = True+signedOp (MO_SS_Conv _ _) = True+signedOp (MO_SF_Conv _ _) = True+signedOp _                = False++floatComparison :: MachOp -> Bool  -- comparison between float args+floatComparison (MO_F_Eq   _) = True+floatComparison (MO_F_Ne   _) = True+floatComparison (MO_F_Ge   _) = True+floatComparison (MO_F_Le   _) = True+floatComparison (MO_F_Gt   _) = True+floatComparison (MO_F_Lt   _) = True+floatComparison _             = False++-- ---------------------------------------------------------------------+-- tend to be implemented by foreign calls++pprCallishMachOp_for_C :: CallishMachOp -> SDoc++pprCallishMachOp_for_C mop+    = case mop of+        MO_F64_Pwr      -> text "pow"+        MO_F64_Sin      -> text "sin"+        MO_F64_Cos      -> text "cos"+        MO_F64_Tan      -> text "tan"+        MO_F64_Sinh     -> text "sinh"+        MO_F64_Cosh     -> text "cosh"+        MO_F64_Tanh     -> text "tanh"+        MO_F64_Asin     -> text "asin"+        MO_F64_Acos     -> text "acos"+        MO_F64_Atanh    -> text "atanh"+        MO_F64_Asinh    -> text "asinh"+        MO_F64_Acosh    -> text "acosh"+        MO_F64_Atan     -> text "atan"+        MO_F64_Log      -> text "log"+        MO_F64_Exp      -> text "exp"+        MO_F64_Sqrt     -> text "sqrt"+        MO_F64_Fabs     -> text "fabs"+        MO_F32_Pwr      -> text "powf"+        MO_F32_Sin      -> text "sinf"+        MO_F32_Cos      -> text "cosf"+        MO_F32_Tan      -> text "tanf"+        MO_F32_Sinh     -> text "sinhf"+        MO_F32_Cosh     -> text "coshf"+        MO_F32_Tanh     -> text "tanhf"+        MO_F32_Asin     -> text "asinf"+        MO_F32_Acos     -> text "acosf"+        MO_F32_Atan     -> text "atanf"+        MO_F32_Asinh    -> text "asinhf"+        MO_F32_Acosh    -> text "acoshf"+        MO_F32_Atanh    -> text "atanhf"+        MO_F32_Log      -> text "logf"+        MO_F32_Exp      -> text "expf"+        MO_F32_Sqrt     -> text "sqrtf"+        MO_F32_Fabs     -> text "fabsf"+        MO_WriteBarrier -> text "write_barrier"+        MO_Memcpy _     -> text "memcpy"+        MO_Memset _     -> text "memset"+        MO_Memmove _    -> text "memmove"+        MO_Memcmp _     -> text "memcmp"+        (MO_BSwap w)    -> ptext (sLit $ bSwapLabel w)+        (MO_BRev w)     -> ptext (sLit $ bRevLabel w)+        (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)+        (MO_Pext w)     -> ptext (sLit $ pextLabel w)+        (MO_Pdep w)     -> ptext (sLit $ pdepLabel w)+        (MO_Clz w)      -> ptext (sLit $ clzLabel w)+        (MO_Ctz w)      -> ptext (sLit $ ctzLabel w)+        (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop)+        (MO_Cmpxchg w)  -> ptext (sLit $ cmpxchgLabel w)+        (MO_AtomicRead w)  -> ptext (sLit $ atomicReadLabel w)+        (MO_AtomicWrite w) -> ptext (sLit $ atomicWriteLabel w)+        (MO_UF_Conv w)  -> ptext (sLit $ word2FloatLabel w)++        MO_S_QuotRem  {} -> unsupported+        MO_U_QuotRem  {} -> unsupported+        MO_U_QuotRem2 {} -> unsupported+        MO_Add2       {} -> unsupported+        MO_AddWordC   {} -> unsupported+        MO_SubWordC   {} -> unsupported+        MO_AddIntC    {} -> unsupported+        MO_SubIntC    {} -> unsupported+        MO_U_Mul2     {} -> unsupported+        MO_Touch         -> unsupported+        (MO_Prefetch_Data _ ) -> unsupported+        --- we could support prefetch via "__builtin_prefetch"+        --- Not adding it for now+    where unsupported = panic ("pprCallishMachOp_for_C: " ++ show mop+                            ++ " not supported!")++-- ---------------------------------------------------------------------+-- Useful #defines+--++mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc++mkJMP_ i = text "JMP_" <> parens i+mkFN_  i = text "FN_"  <> parens i -- externally visible function+mkIF_  i = text "IF_"  <> parens i -- locally visible++-- from includes/Stg.h+--+mkC_,mkW_,mkP_ :: SDoc++mkC_  = text "(C_)"        -- StgChar+mkW_  = text "(W_)"        -- StgWord+mkP_  = text "(P_)"        -- StgWord*++-- ---------------------------------------------------------------------+--+-- Assignments+--+-- Generating assignments is what we're all about, here+--+pprAssign :: DynFlags -> CmmReg -> CmmExpr -> SDoc++-- dest is a reg, rhs is a reg+pprAssign _ r1 (CmmReg r2)+   | isPtrReg r1 && isPtrReg r2+   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]++-- dest is a reg, rhs is a CmmRegOff+pprAssign dflags r1 (CmmRegOff r2 off)+   | isPtrReg r1 && isPtrReg r2 && (off `rem` wORD_SIZE dflags == 0)+   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]+  where+        off1 = off `shiftR` wordShift dflags++        (op,off') | off >= 0  = (char '+', off1)+                  | otherwise = (char '-', -off1)++-- dest is a reg, rhs is anything.+-- We can't cast the lvalue, so we have to cast the rhs if necessary.  Casting+-- the lvalue elicits a warning from new GCC versions (3.4+).+pprAssign _ r1 r2+  | isFixedPtrReg r1             = mkAssign (mkP_ <> pprExpr1 r2)+  | Just ty <- strangeRegType r1 = mkAssign (parens ty <> pprExpr1 r2)+  | otherwise                    = mkAssign (pprExpr r2)+    where mkAssign x = if r1 == CmmGlobal BaseReg+                       then text "ASSIGN_BaseReg" <> parens x <> semi+                       else pprReg r1 <> text " = " <> x <> semi++-- ---------------------------------------------------------------------+-- Registers++pprCastReg :: CmmReg -> SDoc+pprCastReg reg+   | isStrangeTypeReg reg = mkW_ <> pprReg reg+   | otherwise            = pprReg reg++-- True if (pprReg reg) will give an expression with type StgPtr.  We+-- need to take care with pointer arithmetic on registers with type+-- StgPtr.+isFixedPtrReg :: CmmReg -> Bool+isFixedPtrReg (CmmLocal _) = False+isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r++-- True if (pprAsPtrReg reg) will give an expression with type StgPtr+-- JD: THIS IS HORRIBLE AND SHOULD BE RENAMED, AT THE VERY LEAST.+-- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT;+-- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY.+isPtrReg :: CmmReg -> Bool+isPtrReg (CmmLocal _)                         = False+isPtrReg (CmmGlobal (VanillaReg _ VGcPtr))    = True  -- if we print via pprAsPtrReg+isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg+isPtrReg (CmmGlobal reg)                      = isFixedPtrGlobalReg reg++-- True if this global reg has type StgPtr+isFixedPtrGlobalReg :: GlobalReg -> Bool+isFixedPtrGlobalReg Sp    = True+isFixedPtrGlobalReg Hp    = True+isFixedPtrGlobalReg HpLim = True+isFixedPtrGlobalReg SpLim = True+isFixedPtrGlobalReg _     = False++-- True if in C this register doesn't have the type given by+-- (machRepCType (cmmRegType reg)), so it has to be cast.+isStrangeTypeReg :: CmmReg -> Bool+isStrangeTypeReg (CmmLocal _)   = False+isStrangeTypeReg (CmmGlobal g)  = isStrangeTypeGlobal g++isStrangeTypeGlobal :: GlobalReg -> Bool+isStrangeTypeGlobal CCCS                = True+isStrangeTypeGlobal CurrentTSO          = True+isStrangeTypeGlobal CurrentNursery      = True+isStrangeTypeGlobal BaseReg             = True+isStrangeTypeGlobal r                   = isFixedPtrGlobalReg r++strangeRegType :: CmmReg -> Maybe SDoc+strangeRegType (CmmGlobal CCCS) = Just (text "struct CostCentreStack_ *")+strangeRegType (CmmGlobal CurrentTSO) = Just (text "struct StgTSO_ *")+strangeRegType (CmmGlobal CurrentNursery) = Just (text "struct bdescr_ *")+strangeRegType (CmmGlobal BaseReg) = Just (text "struct StgRegTable_ *")+strangeRegType _ = Nothing++-- pprReg just prints the register name.+--+pprReg :: CmmReg -> SDoc+pprReg r = case r of+        CmmLocal  local  -> pprLocalReg local+        CmmGlobal global -> pprGlobalReg global++pprAsPtrReg :: CmmReg -> SDoc+pprAsPtrReg (CmmGlobal (VanillaReg n gcp))+  = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> text ".p"+pprAsPtrReg other_reg = pprReg other_reg++pprGlobalReg :: GlobalReg -> SDoc+pprGlobalReg gr = case gr of+    VanillaReg n _ -> char 'R' <> int n  <> text ".w"+        -- pprGlobalReg prints a VanillaReg as a .w regardless+        -- Example:     R1.w = R1.w & (-0x8UL);+        --              JMP_(*R1.p);+    FloatReg   n   -> char 'F' <> int n+    DoubleReg  n   -> char 'D' <> int n+    LongReg    n   -> char 'L' <> int n+    Sp             -> text "Sp"+    SpLim          -> text "SpLim"+    Hp             -> text "Hp"+    HpLim          -> text "HpLim"+    CCCS           -> text "CCCS"+    CurrentTSO     -> text "CurrentTSO"+    CurrentNursery -> text "CurrentNursery"+    HpAlloc        -> text "HpAlloc"+    BaseReg        -> text "BaseReg"+    EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"+    GCEnter1       -> text "stg_gc_enter_1"+    GCFun          -> text "stg_gc_fun"+    other          -> panic $ "pprGlobalReg: Unsupported register: " ++ show other++pprLocalReg :: LocalReg -> SDoc+pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq++-- -----------------------------------------------------------------------------+-- Foreign Calls++pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc+pprCall ppr_fn cconv results args+  | not (is_cishCC cconv)+  = panic $ "pprCall: unknown calling convention"++  | otherwise+  =+    ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi+  where+     ppr_assign []           rhs = rhs+     ppr_assign [(one,hint)] rhs+         = pprLocalReg one <> text " = "+                 <> pprUnHint hint (localRegType one) <> rhs+     ppr_assign _other _rhs = panic "pprCall: multiple results"++     pprArg (expr, AddrHint)+        = cCast (text "void *") expr+        -- see comment by machRepHintCType below+     pprArg (expr, SignedHint)+        = sdocWithDynFlags $ \dflags ->+          cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr+     pprArg (expr, _other)+        = pprExpr expr++     pprUnHint AddrHint   rep = parens (machRepCType rep)+     pprUnHint SignedHint rep = parens (machRepCType rep)+     pprUnHint _          _   = empty++-- Currently we only have these two calling conventions, but this might+-- change in the future...+is_cishCC :: CCallConv -> Bool+is_cishCC CCallConv    = True+is_cishCC CApiConv     = True+is_cishCC StdCallConv  = True+is_cishCC PrimCallConv = False+is_cishCC JavaScriptCallConv = False++-- ---------------------------------------------------------------------+-- Find and print local and external declarations for a list of+-- Cmm statements.+--+pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})+pprTempAndExternDecls stmts+  = (pprUFM (getUniqSet temps) (vcat . map pprTempDecl),+     vcat (map pprExternDecl (Map.keys lbls)))+  where (temps, lbls) = runTE (mapM_ te_BB stmts)++pprDataExterns :: [CmmStatic] -> SDoc+pprDataExterns statics+  = vcat (map pprExternDecl (Map.keys lbls))+  where (_, lbls) = runTE (mapM_ te_Static statics)++pprTempDecl :: LocalReg -> SDoc+pprTempDecl l@(LocalReg _ rep)+  = hcat [ machRepCType rep, space, pprLocalReg l, semi ]++pprExternDecl :: CLabel -> SDoc+pprExternDecl lbl+  -- do not print anything for "known external" things+  | not (needsCDecl lbl) = empty+  | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz+  | otherwise =+        hcat [ visibility, label_type lbl , lparen, ppr lbl, text ");"+             -- occasionally useful to see label type+             -- , text "/* ", pprDebugCLabel lbl, text " */"+             ]+ where+  label_type lbl | isBytesLabel lbl         = text "B_"+                 | isForeignLabel lbl && isCFunctionLabel lbl+                                            = text "FF_"+                 | isCFunctionLabel lbl     = text "F_"+                 | isStaticClosureLabel lbl = text "C_"+                 -- generic .rodata labels+                 | isSomeRODataLabel lbl    = text "RO_"+                 -- generic .data labels (common case)+                 | otherwise                = text "RW_"++  visibility+     | externallyVisibleCLabel lbl = char 'E'+     | otherwise                   = char 'I'++  -- If the label we want to refer to is a stdcall function (on Windows) then+  -- we must generate an appropriate prototype for it, so that the C compiler will+  -- add the @n suffix to the label (#2276)+  stdcall_decl sz = sdocWithDynFlags $ \dflags ->+        text "extern __attribute__((stdcall)) void " <> ppr lbl+        <> parens (commafy (replicate (sz `quot` wORD_SIZE dflags) (machRep_U_CType (wordWidth dflags))))+        <> semi++type TEState = (UniqSet LocalReg, Map CLabel ())+newtype TE a = TE { unTE :: TEState -> (a, TEState) }++instance Functor TE where+      fmap = liftM++instance Applicative TE where+      pure a = TE $ \s -> (a, s)+      (<*>) = ap++instance Monad TE where+   TE m >>= k  = TE $ \s -> case m s of (a, s') -> unTE (k a) s'++te_lbl :: CLabel -> TE ()+te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, Map.insert lbl () lbls))++te_temp :: LocalReg -> TE ()+te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls))++runTE :: TE () -> TEState+runTE (TE m) = snd (m (emptyUniqSet, Map.empty))++te_Static :: CmmStatic -> TE ()+te_Static (CmmStaticLit lit) = te_Lit lit+te_Static _ = return ()++te_BB :: CmmBlock -> TE ()+te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last+  where (_, mid, last) = blockSplit block++te_Lit :: CmmLit -> TE ()+te_Lit (CmmLabel l) = te_lbl l+te_Lit (CmmLabelOff l _) = te_lbl l+te_Lit (CmmLabelDiffOff l1 _ _ _) = te_lbl l1+te_Lit _ = return ()++te_Stmt :: CmmNode e x -> TE ()+te_Stmt (CmmAssign r e)         = te_Reg r >> te_Expr e+te_Stmt (CmmStore l r)          = te_Expr l >> te_Expr r+te_Stmt (CmmUnsafeForeignCall target rs es)+  = do  te_Target target+        mapM_ te_temp rs+        mapM_ te_Expr es+te_Stmt (CmmCondBranch e _ _ _) = te_Expr e+te_Stmt (CmmSwitch e _)         = te_Expr e+te_Stmt (CmmCall { cml_target = e }) = te_Expr e+te_Stmt _                       = return ()++te_Target :: ForeignTarget -> TE ()+te_Target (ForeignTarget e _)      = te_Expr e+te_Target (PrimTarget{})           = return ()++te_Expr :: CmmExpr -> TE ()+te_Expr (CmmLit lit)            = te_Lit lit+te_Expr (CmmLoad e _)           = te_Expr e+te_Expr (CmmReg r)              = te_Reg r+te_Expr (CmmMachOp _ es)        = mapM_ te_Expr es+te_Expr (CmmRegOff r _)         = te_Reg r+te_Expr (CmmStackSlot _ _)      = panic "te_Expr: CmmStackSlot not supported!"++te_Reg :: CmmReg -> TE ()+te_Reg (CmmLocal l) = te_temp l+te_Reg _            = return ()+++-- ---------------------------------------------------------------------+-- C types for MachReps++cCast :: SDoc -> CmmExpr -> SDoc+cCast ty expr = parens ty <> pprExpr1 expr++cLoad :: CmmExpr -> CmmType -> SDoc+cLoad expr rep+    = sdocWithPlatform $ \platform ->+      if bewareLoadStoreAlignment (platformArch platform)+      then let decl = machRepCType rep <+> text "x" <> semi+               struct = text "struct" <+> braces (decl)+               packed_attr = text "__attribute__((packed))"+               cast = parens (struct <+> packed_attr <> char '*')+           in parens (cast <+> pprExpr1 expr) <> text "->x"+      else char '*' <> parens (cCast (machRepPtrCType rep) expr)+    where -- On these platforms, unaligned loads are known to cause problems+          bewareLoadStoreAlignment ArchAlpha    = True+          bewareLoadStoreAlignment ArchMipseb   = True+          bewareLoadStoreAlignment ArchMipsel   = True+          bewareLoadStoreAlignment (ArchARM {}) = True+          bewareLoadStoreAlignment ArchARM64    = True+          bewareLoadStoreAlignment ArchSPARC    = True+          bewareLoadStoreAlignment ArchSPARC64  = True+          -- Pessimistically assume that they will also cause problems+          -- on unknown arches+          bewareLoadStoreAlignment ArchUnknown  = True+          bewareLoadStoreAlignment _            = False++isCmmWordType :: DynFlags -> CmmType -> Bool+-- True of GcPtrReg/NonGcReg of native word size+isCmmWordType dflags ty = not (isFloatType ty)+                       && typeWidth ty == wordWidth dflags++-- This is for finding the types of foreign call arguments.  For a pointer+-- argument, we always cast the argument to (void *), to avoid warnings from+-- the C compiler.+machRepHintCType :: CmmType -> ForeignHint -> SDoc+machRepHintCType _   AddrHint   = text "void *"+machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep)+machRepHintCType rep _other     = machRepCType rep++machRepPtrCType :: CmmType -> SDoc+machRepPtrCType r+ = sdocWithDynFlags $ \dflags ->+   if isCmmWordType dflags r then text "P_"+                             else machRepCType r <> char '*'++machRepCType :: CmmType -> SDoc+machRepCType ty | isFloatType ty = machRep_F_CType w+                | otherwise      = machRep_U_CType w+                where+                  w = typeWidth ty++machRep_F_CType :: Width -> SDoc+machRep_F_CType W32 = text "StgFloat" -- ToDo: correct?+machRep_F_CType W64 = text "StgDouble"+machRep_F_CType _   = panic "machRep_F_CType"++machRep_U_CType :: Width -> SDoc+machRep_U_CType w+ = sdocWithDynFlags $ \dflags ->+   case w of+   _ | w == wordWidth dflags -> text "W_"+   W8  -> text "StgWord8"+   W16 -> text "StgWord16"+   W32 -> text "StgWord32"+   W64 -> text "StgWord64"+   _   -> panic "machRep_U_CType"++machRep_S_CType :: Width -> SDoc+machRep_S_CType w+ = sdocWithDynFlags $ \dflags ->+   case w of+   _ | w == wordWidth dflags -> text "I_"+   W8  -> text "StgInt8"+   W16 -> text "StgInt16"+   W32 -> text "StgInt32"+   W64 -> text "StgInt64"+   _   -> panic "machRep_S_CType"+++-- ---------------------------------------------------------------------+-- print strings as valid C strings++pprStringInCStyle :: ByteString -> SDoc+pprStringInCStyle s = doubleQuotes (text (concatMap charToC (BS.unpack s)))++-- ---------------------------------------------------------------------------+-- Initialising static objects with floating-point numbers.  We can't+-- just emit the floating point number, because C will cast it to an int+-- by rounding it.  We want the actual bit-representation of the float.+--+-- Consider a concrete C example:+--    double d = 2.5e-10;+--    float f  = 2.5e-10f;+--+--    int * i2 = &d;      printf ("i2: %08X %08X\n", i2[0], i2[1]);+--    long long * l = &d; printf (" l: %016llX\n",   l[0]);+--    int * i = &f;       printf (" i: %08X\n",      i[0]);+-- Result on 64-bit LE (x86_64):+--     i2: E826D695 3DF12E0B+--      l: 3DF12E0BE826D695+--      i: 2F89705F+-- Result on 32-bit BE (m68k):+--     i2: 3DF12E0B E826D695+--      l: 3DF12E0BE826D695+--      i: 2F89705F+--+-- The trick here is to notice that binary representation does not+-- change much: only Word32 values get swapped on LE hosts / targets.++-- This is a hack to turn the floating point numbers into ints that we+-- can safely initialise to static locations.++castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)+castFloatToWord32Array = U.castSTUArray++castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)+castDoubleToWord64Array = U.castSTUArray++floatToWord :: DynFlags -> Rational -> CmmLit+floatToWord dflags r+  = runST (do+        arr <- newArray_ ((0::Int),0)+        writeArray arr 0 (fromRational r)+        arr' <- castFloatToWord32Array arr+        w32 <- readArray arr' 0+        return (CmmInt (toInteger w32 `shiftL` wo) (wordWidth dflags))+    )+    where wo | wordWidth dflags == W64+             , wORDS_BIGENDIAN dflags    = 32+             | otherwise                 = 0++floatPairToWord :: DynFlags -> Rational -> Rational -> CmmLit+floatPairToWord dflags r1 r2+  = runST (do+        arr <- newArray_ ((0::Int),1)+        writeArray arr 0 (fromRational r1)+        writeArray arr 1 (fromRational r2)+        arr' <- castFloatToWord32Array arr+        w32_1 <- readArray arr' 0+        w32_2 <- readArray arr' 1+        return (pprWord32Pair w32_1 w32_2)+    )+    where pprWord32Pair w32_1 w32_2+              | wORDS_BIGENDIAN dflags =+                  CmmInt ((shiftL i1 32) .|. i2) W64+              | otherwise =+                  CmmInt ((shiftL i2 32) .|. i1) W64+              where i1 = toInteger w32_1+                    i2 = toInteger w32_2++doubleToWords :: DynFlags -> Rational -> [CmmLit]+doubleToWords dflags r+  = runST (do+        arr <- newArray_ ((0::Int),1)+        writeArray arr 0 (fromRational r)+        arr' <- castDoubleToWord64Array arr+        w64 <- readArray arr' 0+        return (pprWord64 w64)+    )+    where targetWidth = wordWidth dflags+          targetBE    = wORDS_BIGENDIAN dflags+          pprWord64 w64+              | targetWidth == W64 =+                  [ CmmInt (toInteger w64) targetWidth ]+              | targetWidth == W32 =+                  [ CmmInt (toInteger targetW1) targetWidth+                  , CmmInt (toInteger targetW2) targetWidth+                  ]+              | otherwise = panic "doubleToWords.pprWord64"+              where (targetW1, targetW2)+                        | targetBE  = (wHi, wLo)+                        | otherwise = (wLo, wHi)+                    wHi = w64 `shiftR` 32+                    wLo = w64 .&. 0xFFFFffff++-- ---------------------------------------------------------------------------+-- Utils++wordShift :: DynFlags -> Int+wordShift dflags = widthInLog (wordWidth dflags)++commafy :: [SDoc] -> SDoc+commafy xs = hsep $ punctuate comma xs++-- Print in C hex format: 0x13fa+pprHexVal :: Integer -> Width -> SDoc+pprHexVal w rep+  | w < 0     = parens (char '-' <>+                    text "0x" <> intToDoc (-w) <> repsuffix rep)+  | otherwise =     text "0x" <> intToDoc   w  <> repsuffix rep+  where+        -- type suffix for literals:+        -- Integer literals are unsigned in Cmm/C.  We explicitly cast to+        -- signed values for doing signed operations, but at all other+        -- times values are unsigned.  This also helps eliminate occasional+        -- warnings about integer overflow from gcc.++      repsuffix W64 = sdocWithDynFlags $ \dflags ->+               if cINT_SIZE       dflags == 8 then char 'U'+          else if cLONG_SIZE      dflags == 8 then text "UL"+          else if cLONG_LONG_SIZE dflags == 8 then text "ULL"+          else panic "pprHexVal: Can't find a 64-bit type"+      repsuffix _ = char 'U'++      intToDoc :: Integer -> SDoc+      intToDoc i = case truncInt i of+                       0 -> char '0'+                       v -> go v++      -- We need to truncate value as Cmm backend does not drop+      -- redundant bits to ease handling of negative values.+      -- Thus the following Cmm code on 64-bit arch, like amd64:+      --     CInt v;+      --     v = {something};+      --     if (v == %lobits32(-1)) { ...+      -- leads to the following C code:+      --     StgWord64 v = (StgWord32)({something});+      --     if (v == 0xFFFFffffFFFFffffU) { ...+      -- Such code is incorrect as it promotes both operands to StgWord64+      -- and the whole condition is always false.+      truncInt :: Integer -> Integer+      truncInt i =+          case rep of+              W8  -> i `rem` (2^(8 :: Int))+              W16 -> i `rem` (2^(16 :: Int))+              W32 -> i `rem` (2^(32 :: Int))+              W64 -> i `rem` (2^(64 :: Int))+              _   -> panic ("pprHexVal/truncInt: C backend can't encode "+                            ++ show rep ++ " literals")++      go 0 = empty+      go w' = go q <> dig+           where+             (q,r) = w' `quotRem` 16+             dig | r < 10    = char (chr (fromInteger r + ord '0'))+                 | otherwise = char (chr (fromInteger r - 10 + ord 'a'))
+ compiler/cmm/PprCmm.hs view
@@ -0,0 +1,311 @@+{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++----------------------------------------------------------------------------+--+-- Pretty-printing of Cmm as (a superset of) C--+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------+--+-- This is where we walk over CmmNode emitting an external representation,+-- suitable for parsing, in a syntax strongly reminiscent of C--. This+-- is the "External Core" for the Cmm layer.+--+-- As such, this should be a well-defined syntax: we want it to look nice.+-- Thus, we try wherever possible to use syntax defined in [1],+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather+-- than C--'s bits8 .. bits64.+--+-- We try to ensure that all information available in the abstract+-- syntax is reproduced, or reproducible, in the concrete syntax.+-- Data that is not in printed out can be reconstructed according to+-- conventions used in the pretty printer. There are at least two such+-- cases:+--      1) if a value has wordRep type, the type is not appended in the+--      output.+--      2) MachOps that operate over wordRep type are printed in a+--      C-style, rather than as their internal MachRep name.+--+-- These conventions produce much more readable Cmm output.+--+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs++module PprCmm+  ( module PprCmmDecl+  , module PprCmmExpr+  )+where++import GhcPrelude hiding (succ)++import BlockId ()+import CLabel+import Cmm+import CmmUtils+import CmmSwitch+import DynFlags+import FastString+import Outputable+import PprCmmDecl+import PprCmmExpr+import Util+import PprCore ()++import BasicTypes+import Hoopl.Block+import Hoopl.Graph++-------------------------------------------------+-- Outputable instances++instance Outputable CmmStackInfo where+    ppr = pprStackInfo++instance Outputable CmmTopInfo where+    ppr = pprTopInfo+++instance Outputable (CmmNode e x) where+    ppr = pprNode++instance Outputable Convention where+    ppr = pprConvention++instance Outputable ForeignConvention where+    ppr = pprForeignConvention++instance Outputable ForeignTarget where+    ppr = pprForeignTarget++instance Outputable CmmReturnInfo where+    ppr = pprReturnInfo++instance Outputable (Block CmmNode C C) where+    ppr = pprBlock+instance Outputable (Block CmmNode C O) where+    ppr = pprBlock+instance Outputable (Block CmmNode O C) where+    ppr = pprBlock+instance Outputable (Block CmmNode O O) where+    ppr = pprBlock++instance Outputable (Graph CmmNode e x) where+    ppr = pprGraph++instance Outputable CmmGraph where+    ppr = pprCmmGraph++----------------------------------------------------------+-- Outputting types Cmm contains++pprStackInfo :: CmmStackInfo -> SDoc+pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =+  text "arg_space: " <> ppr arg_space <+>+  text "updfr_space: " <> ppr updfr_space++pprTopInfo :: CmmTopInfo -> SDoc+pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =+  vcat [text "info_tbls: " <> ppr info_tbl,+        text "stack_info: " <> ppr stack_info]++----------------------------------------------------------+-- Outputting blocks and graphs++pprBlock :: IndexedCO x SDoc SDoc ~ SDoc+         => Block CmmNode e x -> IndexedCO e SDoc SDoc+pprBlock block+    = foldBlockNodesB3 ( ($$) . ppr+                       , ($$) . (nest 4) . ppr+                       , ($$) . (nest 4) . ppr+                       )+                       block+                       empty++pprGraph :: Graph CmmNode e x -> SDoc+pprGraph GNil = empty+pprGraph (GUnit block) = ppr block+pprGraph (GMany entry body exit)+   = text "{"+  $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)+  $$ text "}"+  where pprMaybeO :: Outputable (Block CmmNode e x)+                  => MaybeO ex (Block CmmNode e x) -> SDoc+        pprMaybeO NothingO = empty+        pprMaybeO (JustO block) = ppr block++pprCmmGraph :: CmmGraph -> SDoc+pprCmmGraph g+   = text "{" <> text "offset"+  $$ nest 2 (vcat $ map ppr blocks)+  $$ text "}"+  where blocks = revPostorder g+    -- revPostorder has the side-effect of discarding unreachable code,+    -- so pretty-printed Cmm will omit any unreachable blocks.  This can+    -- sometimes be confusing.++---------------------------------------------+-- Outputting CmmNode and types which it contains++pprConvention :: Convention -> SDoc+pprConvention (NativeNodeCall   {}) = text "<native-node-call-convention>"+pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"+pprConvention (NativeReturn {})     = text "<native-ret-convention>"+pprConvention  Slow                 = text "<slow-convention>"+pprConvention  GC                   = text "<gc-convention>"++pprForeignConvention :: ForeignConvention -> SDoc+pprForeignConvention (ForeignConvention c args res ret) =+          doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret++pprReturnInfo :: CmmReturnInfo -> SDoc+pprReturnInfo CmmMayReturn = empty+pprReturnInfo CmmNeverReturns = text "never returns"++pprForeignTarget :: ForeignTarget -> SDoc+pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn+  where+        ppr_target :: CmmExpr -> SDoc+        ppr_target t@(CmmLit _) = ppr t+        ppr_target fn'          = parens (ppr fn')++pprForeignTarget (PrimTarget op)+ -- HACK: We're just using a ForeignLabel to get this printed, the label+ --       might not really be foreign.+ = ppr+               (CmmLabel (mkForeignLabel+                         (mkFastString (show op))+                         Nothing ForeignLabelInThisPackage IsFunction))++pprNode :: CmmNode e x -> SDoc+pprNode node = pp_node <+> pp_debug+  where+    pp_node :: SDoc+    pp_node = sdocWithDynFlags $ \dflags -> case node of+      -- label:+      CmmEntry id tscope -> lbl <> colon <+>+         (sdocWithDynFlags $ \dflags ->+           ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope))+          where+            lbl = if gopt Opt_SuppressUniques dflags+                then text "_lbl_"+                else ppr id++      -- // text+      CmmComment s -> text "//" <+> ftext s++      -- //tick bla<...>+      CmmTick t -> ppUnless (gopt Opt_SuppressTicks dflags) $+                   text "//tick" <+> ppr t++      -- unwind reg = expr;+      CmmUnwind regs ->+          text "unwind "+          <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> ppr e) regs) <> semi++      -- reg = expr;+      CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi++      -- rep[lv] = expr;+      CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi+          where+            rep = sdocWithDynFlags $ \dflags ->+                  ppr ( cmmExprType dflags expr )++      -- call "ccall" foo(x, y)[r1, r2];+      -- ToDo ppr volatile+      CmmUnsafeForeignCall target results args ->+          hsep [ ppUnless (null results) $+                    parens (commafy $ map ppr results) <+> equals,+                 text "call",+                 ppr target <> parens (commafy $ map ppr args) <> semi]++      -- goto label;+      CmmBranch ident -> text "goto" <+> ppr ident <> semi++      -- if (expr) goto t; else goto f;+      CmmCondBranch expr t f l ->+          hsep [ text "if"+               , parens(ppr expr)+               , case l of+                   Nothing -> empty+                   Just b -> parens (text "likely:" <+> ppr b)+               , text "goto"+               , ppr t <> semi+               , text "else goto"+               , ppr f <> semi+               ]++      CmmSwitch expr ids ->+          hang (hsep [ text "switch"+                     , range+                     , if isTrivialCmmExpr expr+                       then ppr expr+                       else parens (ppr expr)+                     , text "{"+                     ])+             4 (vcat (map ppCase cases) $$ def) $$ rbrace+          where+            (cases, mbdef) = switchTargetsFallThrough ids+            ppCase (is,l) = hsep+                            [ text "case"+                            , commafy $ map integer is+                            , text ": goto"+                            , ppr l <> semi+                            ]+            def | Just l <- mbdef = hsep+                            [ text "default:"+                            , braces (text "goto" <+> ppr l <> semi)+                            ]+                | otherwise = empty++            range = brackets $ hsep [integer lo, text "..", integer hi]+              where (lo,hi) = switchTargetsRange ids++      CmmCall tgt k regs out res updfr_off ->+          hcat [ text "call", space+               , pprFun tgt, parens (interpp'SP regs), space+               , returns <+>+                 text "args: " <> ppr out <> comma <+>+                 text "res: " <> ppr res <> comma <+>+                 text "upd: " <> ppr updfr_off+               , semi ]+          where pprFun f@(CmmLit _) = ppr f+                pprFun f = parens (ppr f)++                returns+                  | Just r <- k = text "returns to" <+> ppr r <> comma+                  | otherwise   = empty++      CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->+          hcat $ if i then [text "interruptible", space] else [] +++               [ text "foreign call", space+               , ppr t, text "(...)", space+               , text "returns to" <+> ppr s+                    <+> text "args:" <+> parens (ppr as)+                    <+> text "ress:" <+> parens (ppr rs)+               , text "ret_args:" <+> ppr a+               , text "ret_off:" <+> ppr u+               , semi ]++    pp_debug :: SDoc+    pp_debug =+      if not debugIsOn then empty+      else case node of+             CmmEntry {}             -> empty -- Looks terrible with text "  // CmmEntry"+             CmmComment {}           -> empty -- Looks also terrible with text "  // CmmComment"+             CmmTick {}              -> empty+             CmmUnwind {}            -> text "  // CmmUnwind"+             CmmAssign {}            -> text "  // CmmAssign"+             CmmStore {}             -> text "  // CmmStore"+             CmmUnsafeForeignCall {} -> text "  // CmmUnsafeForeignCall"+             CmmBranch {}            -> text "  // CmmBranch"+             CmmCondBranch {}        -> text "  // CmmCondBranch"+             CmmSwitch {}            -> text "  // CmmSwitch"+             CmmCall {}              -> text "  // CmmCall"+             CmmForeignCall {}       -> text "  // CmmForeignCall"++    commafy :: [SDoc] -> SDoc+    commafy xs = hsep $ punctuate comma xs
+ compiler/cmm/PprCmmDecl.hs view
@@ -0,0 +1,169 @@+----------------------------------------------------------------------------+--+-- Pretty-printing of common Cmm types+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++--+-- This is where we walk over Cmm emitting an external representation,+-- suitable for parsing, in a syntax strongly reminiscent of C--. This+-- is the "External Core" for the Cmm layer.+--+-- As such, this should be a well-defined syntax: we want it to look nice.+-- Thus, we try wherever possible to use syntax defined in [1],+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather+-- than C--'s bits8 .. bits64.+--+-- We try to ensure that all information available in the abstract+-- syntax is reproduced, or reproducible, in the concrete syntax.+-- Data that is not in printed out can be reconstructed according to+-- conventions used in the pretty printer. There are at least two such+-- cases:+--      1) if a value has wordRep type, the type is not appended in the+--      output.+--      2) MachOps that operate over wordRep type are printed in a+--      C-style, rather than as their internal MachRep name.+--+-- These conventions produce much more readable Cmm output.+--+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs+--++{-# OPTIONS_GHC -fno-warn-orphans #-}+module PprCmmDecl+    ( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic+    )+where++import GhcPrelude++import PprCmmExpr+import Cmm++import DynFlags+import Outputable+import FastString++import Data.List+import System.IO++import qualified Data.ByteString as BS+++pprCmms :: (Outputable info, Outputable g)+        => [GenCmmGroup CmmStatics info g] -> SDoc+pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))+        where+          separator = space $$ text "-------------------" $$ space++writeCmms :: (Outputable info, Outputable g)+          => DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO ()+writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms)++-----------------------------------------------------------------------------++instance (Outputable d, Outputable info, Outputable i)+      => Outputable (GenCmmDecl d info i) where+    ppr t = pprTop t++instance Outputable CmmStatics where+    ppr = pprStatics++instance Outputable CmmStatic where+    ppr = pprStatic++instance Outputable CmmInfoTable where+    ppr = pprInfoTable+++-----------------------------------------------------------------------------++pprCmmGroup :: (Outputable d, Outputable info, Outputable g)+            => GenCmmGroup d info g -> SDoc+pprCmmGroup tops+    = vcat $ intersperse blankLine $ map pprTop tops++-- --------------------------------------------------------------------------+-- Top level `procedure' blocks.+--+pprTop :: (Outputable d, Outputable info, Outputable i)+       => GenCmmDecl d info i -> SDoc++pprTop (CmmProc info lbl live graph)++  = vcat [ ppr lbl <> lparen <> rparen <+> text "// " <+> ppr live+         , nest 8 $ lbrace <+> ppr info $$ rbrace+         , nest 4 $ ppr graph+         , rbrace ]++-- --------------------------------------------------------------------------+-- We follow [1], 4.5+--+--      section "data" { ... }+--+pprTop (CmmData section ds) =+    (hang (pprSection section <+> lbrace) 4 (ppr ds))+    $$ rbrace++-- --------------------------------------------------------------------------+-- Info tables.++pprInfoTable :: CmmInfoTable -> SDoc+pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep+                           , cit_prof = prof_info+                           , cit_srt = srt })+  = vcat [ text "label: " <> ppr lbl+         , text "rep: " <> ppr rep+         , case prof_info of+             NoProfilingInfo -> empty+             ProfilingInfo ct cd ->+               vcat [ text "type: " <> text (show (BS.unpack ct))+                    , text "desc: " <> text (show (BS.unpack cd)) ]+         , text "srt: " <> ppr srt ]++instance Outputable ForeignHint where+  ppr NoHint     = empty+  ppr SignedHint = quotes(text "signed")+--  ppr AddrHint   = quotes(text "address")+-- Temp Jan08+  ppr AddrHint   = (text "PtrHint")++-- --------------------------------------------------------------------------+-- Static data.+--      Strings are printed as C strings, and we print them as I8[],+--      following C--+--+pprStatics :: CmmStatics -> SDoc+pprStatics (Statics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)++pprStatic :: CmmStatic -> SDoc+pprStatic s = case s of+    CmmStaticLit lit   -> nest 4 $ text "const" <+> pprLit lit <> semi+    CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)+    CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')++-- --------------------------------------------------------------------------+-- data sections+--+pprSection :: Section -> SDoc+pprSection (Section t suffix) =+  section <+> doubleQuotes (pprSectionType t <+> char '.' <+> ppr suffix)+  where+    section = text "section"++pprSectionType :: SectionType -> SDoc+pprSectionType s = doubleQuotes (ptext t)+ where+  t = case s of+    Text              -> sLit "text"+    Data              -> sLit "data"+    ReadOnlyData      -> sLit "readonly"+    ReadOnlyData16    -> sLit "readonly16"+    RelocatableReadOnlyData+                      -> sLit "relreadonly"+    UninitialisedData -> sLit "uninitialised"+    CString           -> sLit "cstring"+    OtherSection s'   -> sLit s' -- Not actually a literal though.
+ compiler/cmm/PprCmmExpr.hs view
@@ -0,0 +1,286 @@+----------------------------------------------------------------------------+--+-- Pretty-printing of common Cmm types+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++--+-- This is where we walk over Cmm emitting an external representation,+-- suitable for parsing, in a syntax strongly reminiscent of C--. This+-- is the "External Core" for the Cmm layer.+--+-- As such, this should be a well-defined syntax: we want it to look nice.+-- Thus, we try wherever possible to use syntax defined in [1],+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather+-- than C--'s bits8 .. bits64.+--+-- We try to ensure that all information available in the abstract+-- syntax is reproduced, or reproducible, in the concrete syntax.+-- Data that is not in printed out can be reconstructed according to+-- conventions used in the pretty printer. There are at least two such+-- cases:+--      1) if a value has wordRep type, the type is not appended in the+--      output.+--      2) MachOps that operate over wordRep type are printed in a+--      C-style, rather than as their internal MachRep name.+--+-- These conventions produce much more readable Cmm output.+--+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs+--++{-# OPTIONS_GHC -fno-warn-orphans #-}+module PprCmmExpr+    ( pprExpr, pprLit+    )+where++import GhcPrelude++import CmmExpr++import Outputable+import DynFlags++import Data.Maybe+import Numeric ( fromRat )++-----------------------------------------------------------------------------++instance Outputable CmmExpr where+    ppr e = pprExpr e++instance Outputable CmmReg where+    ppr e = pprReg e++instance Outputable CmmLit where+    ppr l = pprLit l++instance Outputable LocalReg where+    ppr e = pprLocalReg e++instance Outputable Area where+    ppr e = pprArea e++instance Outputable GlobalReg where+    ppr e = pprGlobalReg e++-- --------------------------------------------------------------------------+-- Expressions+--++pprExpr :: CmmExpr -> SDoc+pprExpr e+    = sdocWithDynFlags $ \dflags ->+      case e of+        CmmRegOff reg i ->+                pprExpr (CmmMachOp (MO_Add rep)+                           [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])+                where rep = typeWidth (cmmRegType dflags reg)+        CmmLit lit -> pprLit lit+        _other     -> pprExpr1 e++-- Here's the precedence table from CmmParse.y:+-- %nonassoc '>=' '>' '<=' '<' '!=' '=='+-- %left '|'+-- %left '^'+-- %left '&'+-- %left '>>' '<<'+-- %left '-' '+'+-- %left '/' '*' '%'+-- %right '~'++-- We just cope with the common operators for now, the rest will get+-- a default conservative behaviour.++-- %nonassoc '>=' '>' '<=' '<' '!=' '=='+pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc+pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op+   = pprExpr7 x <+> doc <+> pprExpr7 y+pprExpr1 e = pprExpr7 e++infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc++infixMachOp1 (MO_Eq     _) = Just (text "==")+infixMachOp1 (MO_Ne     _) = Just (text "!=")+infixMachOp1 (MO_Shl    _) = Just (text "<<")+infixMachOp1 (MO_U_Shr  _) = Just (text ">>")+infixMachOp1 (MO_U_Ge   _) = Just (text ">=")+infixMachOp1 (MO_U_Le   _) = Just (text "<=")+infixMachOp1 (MO_U_Gt   _) = Just (char '>')+infixMachOp1 (MO_U_Lt   _) = Just (char '<')+infixMachOp1 _             = Nothing++-- %left '-' '+'+pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0+   = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])+pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op+   = pprExpr7 x <+> doc <+> pprExpr8 y+pprExpr7 e = pprExpr8 e++infixMachOp7 (MO_Add _)  = Just (char '+')+infixMachOp7 (MO_Sub _)  = Just (char '-')+infixMachOp7 _           = Nothing++-- %left '/' '*' '%'+pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op+   = pprExpr8 x <+> doc <+> pprExpr9 y+pprExpr8 e = pprExpr9 e++infixMachOp8 (MO_U_Quot _) = Just (char '/')+infixMachOp8 (MO_Mul _)    = Just (char '*')+infixMachOp8 (MO_U_Rem _)  = Just (char '%')+infixMachOp8 _             = Nothing++pprExpr9 :: CmmExpr -> SDoc+pprExpr9 e =+   case e of+        CmmLit    lit       -> pprLit1 lit+        CmmLoad   expr rep  -> ppr rep <> brackets (ppr expr)+        CmmReg    reg       -> ppr reg+        CmmRegOff  reg off  -> parens (ppr reg <+> char '+' <+> int off)+        CmmStackSlot a off  -> parens (ppr a   <+> char '+' <+> int off)+        CmmMachOp mop args  -> genMachOp mop args++genMachOp :: MachOp -> [CmmExpr] -> SDoc+genMachOp mop args+   | Just doc <- infixMachOp mop = case args of+        -- dyadic+        [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y++        -- unary+        [x]   -> doc <> pprExpr9 x++        _     -> pprTrace "PprCmm.genMachOp: machop with strange number of args"+                          (pprMachOp mop <+>+                            parens (hcat $ punctuate comma (map pprExpr args)))+                          empty++   | isJust (infixMachOp1 mop)+   || isJust (infixMachOp7 mop)+   || isJust (infixMachOp8 mop)  = parens (pprExpr (CmmMachOp mop args))++   | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))+        where ppr_op = text (map (\c -> if c == ' ' then '_' else c)+                                 (show mop))+                -- replace spaces in (show mop) with underscores,++--+-- Unsigned ops on the word size of the machine get nice symbols.+-- All else get dumped in their ugly format.+--+infixMachOp :: MachOp -> Maybe SDoc+infixMachOp mop+        = case mop of+            MO_And    _ -> Just $ char '&'+            MO_Or     _ -> Just $ char '|'+            MO_Xor    _ -> Just $ char '^'+            MO_Not    _ -> Just $ char '~'+            MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)+            _ -> Nothing++-- --------------------------------------------------------------------------+-- Literals.+--  To minimise line noise we adopt the convention that if the literal+--  has the natural machine word size, we do not append the type+--+pprLit :: CmmLit -> SDoc+pprLit lit = sdocWithDynFlags $ \dflags ->+             case lit of+    CmmInt i rep ->+        hcat [ (if i < 0 then parens else id)(integer i)+             , ppUnless (rep == wordWidth dflags) $+               space <> dcolon <+> ppr rep ]++    CmmFloat f rep     -> hsep [ double (fromRat f), dcolon, ppr rep ]+    CmmVec lits        -> char '<' <> commafy (map pprLit lits) <> char '>'+    CmmLabel clbl      -> ppr clbl+    CmmLabelOff clbl i -> ppr clbl <> ppr_offset i+    CmmLabelDiffOff clbl1 clbl2 i _ -> ppr clbl1 <> char '-'+                                  <> ppr clbl2 <> ppr_offset i+    CmmBlock id        -> ppr id+    CmmHighStackMark -> text "<highSp>"++pprLit1 :: CmmLit -> SDoc+pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)+pprLit1 lit                  = pprLit lit++ppr_offset :: Int -> SDoc+ppr_offset i+    | i==0      = empty+    | i>=0      = char '+' <> int i+    | otherwise = char '-' <> int (-i)++-- --------------------------------------------------------------------------+-- Registers, whether local (temps) or global+--+pprReg :: CmmReg -> SDoc+pprReg r+    = case r of+        CmmLocal  local  -> pprLocalReg  local+        CmmGlobal global -> pprGlobalReg global++--+-- We only print the type of the local reg if it isn't wordRep+--+pprLocalReg :: LocalReg -> SDoc+pprLocalReg (LocalReg uniq rep) = sdocWithDynFlags $ \dflags ->+--   = ppr rep <> char '_' <> ppr uniq+-- Temp Jan08+    char '_' <> pprUnique dflags uniq <>+       (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08               -- sigh+                    then dcolon <> ptr <> ppr rep+                    else dcolon <> ptr <> ppr rep)+   where+     pprUnique dflags unique =+        if gopt Opt_SuppressUniques dflags+            then text "_locVar_"+            else ppr unique+     ptr = empty+         --if isGcPtrType rep+         --      then doubleQuotes (text "ptr")+         --      else empty++-- Stack areas+pprArea :: Area -> SDoc+pprArea Old        = text "old"+pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]++-- needs to be kept in syn with CmmExpr.hs.GlobalReg+--+pprGlobalReg :: GlobalReg -> SDoc+pprGlobalReg gr+    = case gr of+        VanillaReg n _ -> char 'R' <> int n+-- Temp Jan08+--        VanillaReg n VNonGcPtr -> char 'R' <> int n+--        VanillaReg n VGcPtr    -> char 'P' <> int n+        FloatReg   n   -> char 'F' <> int n+        DoubleReg  n   -> char 'D' <> int n+        LongReg    n   -> char 'L' <> int n+        XmmReg     n   -> text "XMM" <> int n+        YmmReg     n   -> text "YMM" <> int n+        ZmmReg     n   -> text "ZMM" <> int n+        Sp             -> text "Sp"+        SpLim          -> text "SpLim"+        Hp             -> text "Hp"+        HpLim          -> text "HpLim"+        MachSp         -> text "MachSp"+        UnwindReturnReg-> text "UnwindReturnReg"+        CCCS           -> text "CCCS"+        CurrentTSO     -> text "CurrentTSO"+        CurrentNursery -> text "CurrentNursery"+        HpAlloc        -> text "HpAlloc"+        EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"+        GCEnter1       -> text "stg_gc_enter_1"+        GCFun          -> text "stg_gc_fun"+        BaseReg        -> text "BaseReg"+        PicBaseReg     -> text "PicBaseReg"++-----------------------------------------------------------------------------++commafy :: [SDoc] -> SDoc+commafy xs = fsep $ punctuate comma xs
+ compiler/cmm/SMRep.hs view
@@ -0,0 +1,563 @@+-- (c) The University of Glasgow 2006+-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998+--+-- Storage manager representation of closures++{-# LANGUAGE CPP,GeneralizedNewtypeDeriving #-}++module SMRep (+        -- * Words and bytes+        WordOff, ByteOff,+        wordsToBytes, bytesToWordsRoundUp,+        roundUpToWords, roundUpTo,++        StgWord, fromStgWord, toStgWord,+        StgHalfWord, fromStgHalfWord, toStgHalfWord,+        hALF_WORD_SIZE, hALF_WORD_SIZE_IN_BITS,++        -- * Closure repesentation+        SMRep(..), -- CmmInfo sees the rep; no one else does+        IsStatic,+        ClosureTypeInfo(..), ArgDescr(..), Liveness,+        ConstrDescription,++        -- ** Construction+        mkHeapRep, blackHoleRep, indStaticRep, mkStackRep, mkRTSRep, arrPtrsRep,+        smallArrPtrsRep, arrWordsRep,++        -- ** Predicates+        isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon,+        isStackRep,++        -- ** Size-related things+        heapClosureSizeW,+        fixedHdrSizeW, arrWordsHdrSize, arrWordsHdrSizeW, arrPtrsHdrSize,+        arrPtrsHdrSizeW, profHdrSize, thunkHdrSize, nonHdrSize, nonHdrSizeW,+        smallArrPtrsHdrSize, smallArrPtrsHdrSizeW, hdrSize, hdrSizeW,+        fixedHdrSize,++        -- ** RTS closure types+        rtsClosureType, rET_SMALL, rET_BIG,+        aRG_GEN, aRG_GEN_BIG,++        -- ** Arrays+        card, cardRoundUp, cardTableSizeB, cardTableSizeW+    ) where++import GhcPrelude++import BasicTypes( ConTagZ )+import DynFlags+import Outputable+import Platform+import FastString++import Data.Word+import Data.Bits+import Data.ByteString (ByteString)++{-+************************************************************************+*                                                                      *+                Words and bytes+*                                                                      *+************************************************************************+-}++-- | Word offset, or word count+type WordOff = Int++-- | Byte offset, or byte count+type ByteOff = Int++-- | Round up the given byte count to the next byte count that's a+-- multiple of the machine's word size.+roundUpToWords :: DynFlags -> ByteOff -> ByteOff+roundUpToWords dflags n = roundUpTo n (wORD_SIZE dflags)++-- | Round up @base@ to a multiple of @size@.+roundUpTo :: ByteOff -> ByteOff -> ByteOff+roundUpTo base size = (base + (size - 1)) .&. (complement (size - 1))++-- | Convert the given number of words to a number of bytes.+--+-- This function morally has type @WordOff -> ByteOff@, but uses @Num+-- a@ to allow for overloading.+wordsToBytes :: Num a => DynFlags -> a -> a+wordsToBytes dflags n = fromIntegral (wORD_SIZE dflags) * n+{-# SPECIALIZE wordsToBytes :: DynFlags -> Int -> Int #-}+{-# SPECIALIZE wordsToBytes :: DynFlags -> Word -> Word #-}+{-# SPECIALIZE wordsToBytes :: DynFlags -> Integer -> Integer #-}++-- | First round the given byte count up to a multiple of the+-- machine's word size and then convert the result to words.+bytesToWordsRoundUp :: DynFlags -> ByteOff -> WordOff+bytesToWordsRoundUp dflags n = (n + word_size - 1) `quot` word_size+ where word_size = wORD_SIZE dflags+-- StgWord is a type representing an StgWord on the target platform.+-- A Word64 is large enough to hold a Word for either a 32bit or 64bit platform+newtype StgWord = StgWord Word64+    deriving (Eq, Bits)++fromStgWord :: StgWord -> Integer+fromStgWord (StgWord i) = toInteger i++toStgWord :: DynFlags -> Integer -> StgWord+toStgWord dflags i+    = case platformWordSize (targetPlatform dflags) of+      -- These conversions mean that things like toStgWord (-1)+      -- do the right thing+      4 -> StgWord (fromIntegral (fromInteger i :: Word32))+      8 -> StgWord (fromInteger i :: Word64)+      w -> panic ("toStgWord: Unknown platformWordSize: " ++ show w)++instance Outputable StgWord where+    ppr (StgWord i) = integer (toInteger i)++--++-- A Word32 is large enough to hold half a Word for either a 32bit or+-- 64bit platform+newtype StgHalfWord = StgHalfWord Word32+    deriving Eq++fromStgHalfWord :: StgHalfWord -> Integer+fromStgHalfWord (StgHalfWord w) = toInteger w++toStgHalfWord :: DynFlags -> Integer -> StgHalfWord+toStgHalfWord dflags i+    = case platformWordSize (targetPlatform dflags) of+      -- These conversions mean that things like toStgHalfWord (-1)+      -- do the right thing+      4 -> StgHalfWord (fromIntegral (fromInteger i :: Word16))+      8 -> StgHalfWord (fromInteger i :: Word32)+      w -> panic ("toStgHalfWord: Unknown platformWordSize: " ++ show w)++instance Outputable StgHalfWord where+    ppr (StgHalfWord w) = integer (toInteger w)++hALF_WORD_SIZE :: DynFlags -> ByteOff+hALF_WORD_SIZE dflags = platformWordSize (targetPlatform dflags) `shiftR` 1+hALF_WORD_SIZE_IN_BITS :: DynFlags -> Int+hALF_WORD_SIZE_IN_BITS dflags = platformWordSize (targetPlatform dflags) `shiftL` 2++{-+************************************************************************+*                                                                      *+\subsubsection[SMRep-datatype]{@SMRep@---storage manager representation}+*                                                                      *+************************************************************************+-}++-- | A description of the layout of a closure.  Corresponds directly+-- to the closure types in includes/rts/storage/ClosureTypes.h.+data SMRep+  = HeapRep              -- GC routines consult sizes in info tbl+        IsStatic+        !WordOff         --  # ptr words+        !WordOff         --  # non-ptr words INCLUDING SLOP (see mkHeapRep below)+        ClosureTypeInfo  -- type-specific info++  | ArrayPtrsRep+        !WordOff        -- # ptr words+        !WordOff        -- # card table words++  | SmallArrayPtrsRep+        !WordOff        -- # ptr words++  | ArrayWordsRep+        !WordOff        -- # bytes expressed in words, rounded up++  | StackRep            -- Stack frame (RET_SMALL or RET_BIG)+        Liveness++  | RTSRep              -- The RTS needs to declare info tables with specific+        Int             -- type tags, so this form lets us override the default+        SMRep           -- tag for an SMRep.++-- | True <=> This is a static closure.  Affects how we garbage-collect it.+-- Static closure have an extra static link field at the end.+-- Constructors do not have a static variant; see Note [static constructors]+type IsStatic = Bool++-- From an SMRep you can get to the closure type defined in+-- includes/rts/storage/ClosureTypes.h. Described by the function+-- rtsClosureType below.++data ClosureTypeInfo+  = Constr        ConTagZ ConstrDescription+  | Fun           FunArity ArgDescr+  | Thunk+  | ThunkSelector SelectorOffset+  | BlackHole+  | IndStatic++type ConstrDescription = ByteString -- result of dataConIdentity+type FunArity          = Int+type SelectorOffset    = Int++-------------------------+-- We represent liveness bitmaps as a Bitmap (whose internal+-- representation really is a bitmap).  These are pinned onto case return+-- vectors to indicate the state of the stack for the garbage collector.+--+-- In the compiled program, liveness bitmaps that fit inside a single+-- word (StgWord) are stored as a single word, while larger bitmaps are+-- stored as a pointer to an array of words.++type Liveness = [Bool]   -- One Bool per word; True  <=> non-ptr or dead+                         --                    False <=> ptr++-------------------------+-- An ArgDescr describes the argument pattern of a function++data ArgDescr+  = ArgSpec             -- Fits one of the standard patterns+        !Int            -- RTS type identifier ARG_P, ARG_N, ...++  | ArgGen              -- General case+        Liveness        -- Details about the arguments+++-----------------------------------------------------------------------------+-- Construction++mkHeapRep :: DynFlags -> IsStatic -> WordOff -> WordOff -> ClosureTypeInfo+          -> SMRep+mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info+  = HeapRep is_static+            ptr_wds+            (nonptr_wds + slop_wds)+            cl_type_info+  where+     slop_wds+      | is_static = 0+      | otherwise = max 0 (minClosureSize dflags - (hdr_size + payload_size))++     hdr_size     = closureTypeHdrSize dflags cl_type_info+     payload_size = ptr_wds + nonptr_wds++mkRTSRep :: Int -> SMRep -> SMRep+mkRTSRep = RTSRep++mkStackRep :: [Bool] -> SMRep+mkStackRep liveness = StackRep liveness++blackHoleRep :: SMRep+blackHoleRep = HeapRep False 0 0 BlackHole++indStaticRep :: SMRep+indStaticRep = HeapRep True 1 0 IndStatic++arrPtrsRep :: DynFlags -> WordOff -> SMRep+arrPtrsRep dflags elems = ArrayPtrsRep elems (cardTableSizeW dflags elems)++smallArrPtrsRep :: WordOff -> SMRep+smallArrPtrsRep elems = SmallArrayPtrsRep elems++arrWordsRep :: DynFlags -> ByteOff -> SMRep+arrWordsRep dflags bytes = ArrayWordsRep (bytesToWordsRoundUp dflags bytes)++-----------------------------------------------------------------------------+-- Predicates++isStaticRep :: SMRep -> IsStatic+isStaticRep (HeapRep is_static _ _ _) = is_static+isStaticRep (RTSRep _ rep)            = isStaticRep rep+isStaticRep _                         = False++isStackRep :: SMRep -> Bool+isStackRep StackRep{}     = True+isStackRep (RTSRep _ rep) = isStackRep rep+isStackRep _              = False++isConRep :: SMRep -> Bool+isConRep (HeapRep _ _ _ Constr{}) = True+isConRep _                        = False++isThunkRep :: SMRep -> Bool+isThunkRep (HeapRep _ _ _ Thunk)           = True+isThunkRep (HeapRep _ _ _ ThunkSelector{}) = True+isThunkRep (HeapRep _ _ _ BlackHole)       = True+isThunkRep (HeapRep _ _ _ IndStatic)       = True+isThunkRep _                               = False++isFunRep :: SMRep -> Bool+isFunRep (HeapRep _ _ _ Fun{}) = True+isFunRep _                     = False++isStaticNoCafCon :: SMRep -> Bool+-- This should line up exactly with CONSTR_NOCAF below+-- See Note [Static NoCaf constructors]+isStaticNoCafCon (HeapRep _ 0 _ Constr{}) = True+isStaticNoCafCon _                        = False+++-----------------------------------------------------------------------------+-- Size-related things++fixedHdrSize :: DynFlags -> ByteOff+fixedHdrSize dflags = wordsToBytes dflags (fixedHdrSizeW dflags)++-- | Size of a closure header (StgHeader in includes/rts/storage/Closures.h)+fixedHdrSizeW :: DynFlags -> WordOff+fixedHdrSizeW dflags = sTD_HDR_SIZE dflags + profHdrSize dflags++-- | Size of the profiling part of a closure header+-- (StgProfHeader in includes/rts/storage/Closures.h)+profHdrSize  :: DynFlags -> WordOff+profHdrSize dflags+ | gopt Opt_SccProfilingOn dflags = pROF_HDR_SIZE dflags+ | otherwise                      = 0++-- | The garbage collector requires that every closure is at least as+--   big as this.+minClosureSize :: DynFlags -> WordOff+minClosureSize dflags = fixedHdrSizeW dflags + mIN_PAYLOAD_SIZE dflags++arrWordsHdrSize :: DynFlags -> ByteOff+arrWordsHdrSize dflags+ = fixedHdrSize dflags + sIZEOF_StgArrBytes_NoHdr dflags++arrWordsHdrSizeW :: DynFlags -> WordOff+arrWordsHdrSizeW dflags =+    fixedHdrSizeW dflags ++    (sIZEOF_StgArrBytes_NoHdr dflags `quot` wORD_SIZE dflags)++arrPtrsHdrSize :: DynFlags -> ByteOff+arrPtrsHdrSize dflags+ = fixedHdrSize dflags + sIZEOF_StgMutArrPtrs_NoHdr dflags++arrPtrsHdrSizeW :: DynFlags -> WordOff+arrPtrsHdrSizeW dflags =+    fixedHdrSizeW dflags ++    (sIZEOF_StgMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags)++smallArrPtrsHdrSize :: DynFlags -> ByteOff+smallArrPtrsHdrSize dflags+ = fixedHdrSize dflags + sIZEOF_StgSmallMutArrPtrs_NoHdr dflags++smallArrPtrsHdrSizeW :: DynFlags -> WordOff+smallArrPtrsHdrSizeW dflags =+    fixedHdrSizeW dflags ++    (sIZEOF_StgSmallMutArrPtrs_NoHdr dflags `quot` wORD_SIZE dflags)++-- Thunks have an extra header word on SMP, so the update doesn't+-- splat the payload.+thunkHdrSize :: DynFlags -> WordOff+thunkHdrSize dflags = fixedHdrSizeW dflags + smp_hdr+        where smp_hdr = sIZEOF_StgSMPThunkHeader dflags `quot` wORD_SIZE dflags++hdrSize :: DynFlags -> SMRep -> ByteOff+hdrSize dflags rep = wordsToBytes dflags (hdrSizeW dflags rep)++hdrSizeW :: DynFlags -> SMRep -> WordOff+hdrSizeW dflags (HeapRep _ _ _ ty)    = closureTypeHdrSize dflags ty+hdrSizeW dflags (ArrayPtrsRep _ _)    = arrPtrsHdrSizeW dflags+hdrSizeW dflags (SmallArrayPtrsRep _) = smallArrPtrsHdrSizeW dflags+hdrSizeW dflags (ArrayWordsRep _)     = arrWordsHdrSizeW dflags+hdrSizeW _ _                          = panic "SMRep.hdrSizeW"++nonHdrSize :: DynFlags -> SMRep -> ByteOff+nonHdrSize dflags rep = wordsToBytes dflags (nonHdrSizeW rep)++nonHdrSizeW :: SMRep -> WordOff+nonHdrSizeW (HeapRep _ p np _) = p + np+nonHdrSizeW (ArrayPtrsRep elems ct) = elems + ct+nonHdrSizeW (SmallArrayPtrsRep elems) = elems+nonHdrSizeW (ArrayWordsRep words) = words+nonHdrSizeW (StackRep bs)      = length bs+nonHdrSizeW (RTSRep _ rep)     = nonHdrSizeW rep++-- | The total size of the closure, in words.+heapClosureSizeW :: DynFlags -> SMRep -> WordOff+heapClosureSizeW dflags (HeapRep _ p np ty)+ = closureTypeHdrSize dflags ty + p + np+heapClosureSizeW dflags (ArrayPtrsRep elems ct)+ = arrPtrsHdrSizeW dflags + elems + ct+heapClosureSizeW dflags (SmallArrayPtrsRep elems)+ = smallArrPtrsHdrSizeW dflags + elems+heapClosureSizeW dflags (ArrayWordsRep words)+ = arrWordsHdrSizeW dflags + words+heapClosureSizeW _ _ = panic "SMRep.heapClosureSize"++closureTypeHdrSize :: DynFlags -> ClosureTypeInfo -> WordOff+closureTypeHdrSize dflags ty = case ty of+                  Thunk           -> thunkHdrSize dflags+                  ThunkSelector{} -> thunkHdrSize dflags+                  BlackHole       -> thunkHdrSize dflags+                  IndStatic       -> thunkHdrSize dflags+                  _               -> fixedHdrSizeW dflags+        -- All thunks use thunkHdrSize, even if they are non-updatable.+        -- this is because we don't have separate closure types for+        -- updatable vs. non-updatable thunks, so the GC can't tell the+        -- difference.  If we ever have significant numbers of non-+        -- updatable thunks, it might be worth fixing this.++-- ---------------------------------------------------------------------------+-- Arrays++-- | The byte offset into the card table of the card for a given element+card :: DynFlags -> Int -> Int+card dflags i = i `shiftR` mUT_ARR_PTRS_CARD_BITS dflags++-- | Convert a number of elements to a number of cards, rounding up+cardRoundUp :: DynFlags -> Int -> Int+cardRoundUp dflags i =+  card dflags (i + ((1 `shiftL` mUT_ARR_PTRS_CARD_BITS dflags) - 1))++-- | The size of a card table, in bytes+cardTableSizeB :: DynFlags -> Int -> ByteOff+cardTableSizeB dflags elems = cardRoundUp dflags elems++-- | The size of a card table, in words+cardTableSizeW :: DynFlags -> Int -> WordOff+cardTableSizeW dflags elems =+  bytesToWordsRoundUp dflags (cardTableSizeB dflags elems)++-----------------------------------------------------------------------------+-- deriving the RTS closure type from an SMRep++#include "../includes/rts/storage/ClosureTypes.h"+#include "../includes/rts/storage/FunTypes.h"+-- Defines CONSTR, CONSTR_1_0 etc++-- | Derives the RTS closure type from an 'SMRep'+rtsClosureType :: SMRep -> Int+rtsClosureType rep+    = case rep of+      RTSRep ty _ -> ty++      -- See Note [static constructors]+      HeapRep _     1 0 Constr{} -> CONSTR_1_0+      HeapRep _     0 1 Constr{} -> CONSTR_0_1+      HeapRep _     2 0 Constr{} -> CONSTR_2_0+      HeapRep _     1 1 Constr{} -> CONSTR_1_1+      HeapRep _     0 2 Constr{} -> CONSTR_0_2+      HeapRep _     0 _ Constr{} -> CONSTR_NOCAF+           -- See Note [Static NoCaf constructors]+      HeapRep _     _ _ Constr{} -> CONSTR++      HeapRep False 1 0 Fun{} -> FUN_1_0+      HeapRep False 0 1 Fun{} -> FUN_0_1+      HeapRep False 2 0 Fun{} -> FUN_2_0+      HeapRep False 1 1 Fun{} -> FUN_1_1+      HeapRep False 0 2 Fun{} -> FUN_0_2+      HeapRep False _ _ Fun{} -> FUN++      HeapRep False 1 0 Thunk -> THUNK_1_0+      HeapRep False 0 1 Thunk -> THUNK_0_1+      HeapRep False 2 0 Thunk -> THUNK_2_0+      HeapRep False 1 1 Thunk -> THUNK_1_1+      HeapRep False 0 2 Thunk -> THUNK_0_2+      HeapRep False _ _ Thunk -> THUNK++      HeapRep False _ _ ThunkSelector{} ->  THUNK_SELECTOR++      HeapRep True _ _ Fun{}      -> FUN_STATIC+      HeapRep True _ _ Thunk      -> THUNK_STATIC+      HeapRep False _ _ BlackHole -> BLACKHOLE+      HeapRep False _ _ IndStatic -> IND_STATIC++      _ -> panic "rtsClosureType"++-- We export these ones+rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: Int+rET_SMALL   = RET_SMALL+rET_BIG     = RET_BIG+aRG_GEN     = ARG_GEN+aRG_GEN_BIG = ARG_GEN_BIG++{-+Note [static constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~++We used to have a CONSTR_STATIC closure type, and each constructor had+two info tables: one with CONSTR (or CONSTR_1_0 etc.), and one with+CONSTR_STATIC.++This distinction was removed, because when copying a data structure+into a compact region, we must copy static constructors into the+compact region too.  If we didn't do this, we would need to track the+references from the compact region out to the static constructors,+because they might (indirectly) refer to CAFs.++Since static constructors will be copied to the heap, if we wanted to+use different info tables for static and dynamic constructors, we+would have to switch the info pointer when copying the constructor+into the compact region, which means we would need an extra field of+the static info table to point to the dynamic one.++However, since the distinction between static and dynamic closure+types is never actually needed (other than for assertions), we can+just drop the distinction and use the same info table for both.++The GC *does* need to distinguish between static and dynamic closures,+but it does this using the HEAP_ALLOCED() macro which checks whether+the address of the closure resides within the dynamic heap.+HEAP_ALLOCED() doesn't read the closure's info table.++Note [Static NoCaf constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we know that a top-level binding 'x' is not Caffy (ie no CAFs are+reachable from 'x'), then a statically allocated constructor (Just x)+is also not Caffy, and the garbage collector need not follow its+argument fields.  Exploiting this would require two static info tables+for Just, for the two cases where the argument was Caffy or non-Caffy.++Currently we don't do this; instead we treat nullary constructors+as non-Caffy, and the others as potentially Caffy.+++************************************************************************+*                                                                      *+             Pretty printing of SMRep and friends+*                                                                      *+************************************************************************+-}++instance Outputable ClosureTypeInfo where+   ppr = pprTypeInfo++instance Outputable SMRep where+   ppr (HeapRep static ps nps tyinfo)+     = hang (header <+> lbrace) 2 (ppr tyinfo <+> rbrace)+     where+       header = text "HeapRep"+                <+> if static then text "static" else empty+                <+> pp_n "ptrs" ps <+> pp_n "nonptrs" nps+       pp_n :: String -> Int -> SDoc+       pp_n _ 0 = empty+       pp_n s n = int n <+> text s++   ppr (ArrayPtrsRep size _) = text "ArrayPtrsRep" <+> ppr size++   ppr (SmallArrayPtrsRep size) = text "SmallArrayPtrsRep" <+> ppr size++   ppr (ArrayWordsRep words) = text "ArrayWordsRep" <+> ppr words++   ppr (StackRep bs) = text "StackRep" <+> ppr bs++   ppr (RTSRep ty rep) = text "tag:" <> ppr ty <+> ppr rep++instance Outputable ArgDescr where+  ppr (ArgSpec n) = text "ArgSpec" <+> ppr n+  ppr (ArgGen ls) = text "ArgGen" <+> ppr ls++pprTypeInfo :: ClosureTypeInfo -> SDoc+pprTypeInfo (Constr tag descr)+  = text "Con" <+>+    braces (sep [ text "tag:" <+> ppr tag+                , text "descr:" <> text (show descr) ])++pprTypeInfo (Fun arity args)+  = text "Fun" <+>+    braces (sep [ text "arity:" <+> ppr arity+                , ptext (sLit ("fun_type:")) <+> ppr args ])++pprTypeInfo (ThunkSelector offset)+  = text "ThunkSel" <+> ppr offset++pprTypeInfo Thunk     = text "Thunk"+pprTypeInfo BlackHole = text "BlackHole"+pprTypeInfo IndStatic = text "IndStatic"
+ compiler/codeGen/CgUtils.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE GADTs #-}++-----------------------------------------------------------------------------+--+-- Code generator utilities; mostly monadic+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module CgUtils (+        fixStgRegisters,+        baseRegOffset,+        get_Regtable_addr_from_offset,+        regTableOffset,+        get_GlobalReg_addr,+  ) where++import GhcPrelude++import CodeGen.Platform+import Cmm+import Hoopl.Block+import Hoopl.Graph+import CmmUtils+import CLabel+import DynFlags+import Outputable++-- -----------------------------------------------------------------------------+-- Information about global registers++baseRegOffset :: DynFlags -> GlobalReg -> Int++baseRegOffset dflags (VanillaReg 1 _)    = oFFSET_StgRegTable_rR1 dflags+baseRegOffset dflags (VanillaReg 2 _)    = oFFSET_StgRegTable_rR2 dflags+baseRegOffset dflags (VanillaReg 3 _)    = oFFSET_StgRegTable_rR3 dflags+baseRegOffset dflags (VanillaReg 4 _)    = oFFSET_StgRegTable_rR4 dflags+baseRegOffset dflags (VanillaReg 5 _)    = oFFSET_StgRegTable_rR5 dflags+baseRegOffset dflags (VanillaReg 6 _)    = oFFSET_StgRegTable_rR6 dflags+baseRegOffset dflags (VanillaReg 7 _)    = oFFSET_StgRegTable_rR7 dflags+baseRegOffset dflags (VanillaReg 8 _)    = oFFSET_StgRegTable_rR8 dflags+baseRegOffset dflags (VanillaReg 9 _)    = oFFSET_StgRegTable_rR9 dflags+baseRegOffset dflags (VanillaReg 10 _)   = oFFSET_StgRegTable_rR10 dflags+baseRegOffset _      (VanillaReg n _)    = panic ("Registers above R10 are not supported (tried to use R" ++ show n ++ ")")+baseRegOffset dflags (FloatReg  1)       = oFFSET_StgRegTable_rF1 dflags+baseRegOffset dflags (FloatReg  2)       = oFFSET_StgRegTable_rF2 dflags+baseRegOffset dflags (FloatReg  3)       = oFFSET_StgRegTable_rF3 dflags+baseRegOffset dflags (FloatReg  4)       = oFFSET_StgRegTable_rF4 dflags+baseRegOffset dflags (FloatReg  5)       = oFFSET_StgRegTable_rF5 dflags+baseRegOffset dflags (FloatReg  6)       = oFFSET_StgRegTable_rF6 dflags+baseRegOffset _      (FloatReg  n)       = panic ("Registers above F6 are not supported (tried to use F" ++ show n ++ ")")+baseRegOffset dflags (DoubleReg 1)       = oFFSET_StgRegTable_rD1 dflags+baseRegOffset dflags (DoubleReg 2)       = oFFSET_StgRegTable_rD2 dflags+baseRegOffset dflags (DoubleReg 3)       = oFFSET_StgRegTable_rD3 dflags+baseRegOffset dflags (DoubleReg 4)       = oFFSET_StgRegTable_rD4 dflags+baseRegOffset dflags (DoubleReg 5)       = oFFSET_StgRegTable_rD5 dflags+baseRegOffset dflags (DoubleReg 6)       = oFFSET_StgRegTable_rD6 dflags+baseRegOffset _      (DoubleReg n)       = panic ("Registers above D6 are not supported (tried to use D" ++ show n ++ ")")+baseRegOffset dflags (XmmReg 1)          = oFFSET_StgRegTable_rXMM1 dflags+baseRegOffset dflags (XmmReg 2)          = oFFSET_StgRegTable_rXMM2 dflags+baseRegOffset dflags (XmmReg 3)          = oFFSET_StgRegTable_rXMM3 dflags+baseRegOffset dflags (XmmReg 4)          = oFFSET_StgRegTable_rXMM4 dflags+baseRegOffset dflags (XmmReg 5)          = oFFSET_StgRegTable_rXMM5 dflags+baseRegOffset dflags (XmmReg 6)          = oFFSET_StgRegTable_rXMM6 dflags+baseRegOffset _      (XmmReg n)          = panic ("Registers above XMM6 are not supported (tried to use XMM" ++ show n ++ ")")+baseRegOffset dflags (YmmReg 1)          = oFFSET_StgRegTable_rYMM1 dflags+baseRegOffset dflags (YmmReg 2)          = oFFSET_StgRegTable_rYMM2 dflags+baseRegOffset dflags (YmmReg 3)          = oFFSET_StgRegTable_rYMM3 dflags+baseRegOffset dflags (YmmReg 4)          = oFFSET_StgRegTable_rYMM4 dflags+baseRegOffset dflags (YmmReg 5)          = oFFSET_StgRegTable_rYMM5 dflags+baseRegOffset dflags (YmmReg 6)          = oFFSET_StgRegTable_rYMM6 dflags+baseRegOffset _      (YmmReg n)          = panic ("Registers above YMM6 are not supported (tried to use YMM" ++ show n ++ ")")+baseRegOffset dflags (ZmmReg 1)          = oFFSET_StgRegTable_rZMM1 dflags+baseRegOffset dflags (ZmmReg 2)          = oFFSET_StgRegTable_rZMM2 dflags+baseRegOffset dflags (ZmmReg 3)          = oFFSET_StgRegTable_rZMM3 dflags+baseRegOffset dflags (ZmmReg 4)          = oFFSET_StgRegTable_rZMM4 dflags+baseRegOffset dflags (ZmmReg 5)          = oFFSET_StgRegTable_rZMM5 dflags+baseRegOffset dflags (ZmmReg 6)          = oFFSET_StgRegTable_rZMM6 dflags+baseRegOffset _      (ZmmReg n)          = panic ("Registers above ZMM6 are not supported (tried to use ZMM" ++ show n ++ ")")+baseRegOffset dflags Sp                  = oFFSET_StgRegTable_rSp dflags+baseRegOffset dflags SpLim               = oFFSET_StgRegTable_rSpLim dflags+baseRegOffset dflags (LongReg 1)         = oFFSET_StgRegTable_rL1 dflags+baseRegOffset _      (LongReg n)         = panic ("Registers above L1 are not supported (tried to use L" ++ show n ++ ")")+baseRegOffset dflags Hp                  = oFFSET_StgRegTable_rHp dflags+baseRegOffset dflags HpLim               = oFFSET_StgRegTable_rHpLim dflags+baseRegOffset dflags CCCS                = oFFSET_StgRegTable_rCCCS dflags+baseRegOffset dflags CurrentTSO          = oFFSET_StgRegTable_rCurrentTSO dflags+baseRegOffset dflags CurrentNursery      = oFFSET_StgRegTable_rCurrentNursery dflags+baseRegOffset dflags HpAlloc             = oFFSET_StgRegTable_rHpAlloc dflags+baseRegOffset dflags EagerBlackholeInfo  = oFFSET_stgEagerBlackholeInfo dflags+baseRegOffset dflags GCEnter1            = oFFSET_stgGCEnter1 dflags+baseRegOffset dflags GCFun               = oFFSET_stgGCFun dflags+baseRegOffset _      BaseReg             = panic "CgUtils.baseRegOffset:BaseReg"+baseRegOffset _      PicBaseReg          = panic "CgUtils.baseRegOffset:PicBaseReg"+baseRegOffset _      MachSp              = panic "CgUtils.baseRegOffset:MachSp"+baseRegOffset _      UnwindReturnReg     = panic "CgUtils.baseRegOffset:UnwindReturnReg"+++-- -----------------------------------------------------------------------------+--+-- STG/Cmm GlobalReg+--+-- -----------------------------------------------------------------------------++-- | We map STG registers onto appropriate CmmExprs.  Either they map+-- to real machine registers or stored as offsets from BaseReg.  Given+-- a GlobalReg, get_GlobalReg_addr always produces the+-- register table address for it.+get_GlobalReg_addr :: DynFlags -> GlobalReg -> CmmExpr+get_GlobalReg_addr dflags BaseReg = regTableOffset dflags 0+get_GlobalReg_addr dflags mid+    = get_Regtable_addr_from_offset dflags (baseRegOffset dflags mid)++-- Calculate a literal representing an offset into the register table.+-- Used when we don't have an actual BaseReg to offset from.+regTableOffset :: DynFlags -> Int -> CmmExpr+regTableOffset dflags n =+  CmmLit (CmmLabelOff mkMainCapabilityLabel (oFFSET_Capability_r dflags + n))++get_Regtable_addr_from_offset :: DynFlags -> Int -> CmmExpr+get_Regtable_addr_from_offset dflags offset =+    if haveRegBase (targetPlatform dflags)+    then CmmRegOff baseReg offset+    else regTableOffset dflags offset++-- | Fixup global registers so that they assign to locations within the+-- RegTable if they aren't pinned for the current target.+fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl+fixStgRegisters _ top@(CmmData _ _) = top++fixStgRegisters dflags (CmmProc info lbl live graph) =+  let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph+  in CmmProc info lbl live graph'++fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x+fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block++fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x+fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt+  where+    platform = targetPlatform dflags++    fixAssign stmt =+      case stmt of+        CmmAssign (CmmGlobal reg) src+          -- MachSp isn't an STG register; it's merely here for tracking unwind+          -- information+          | reg == MachSp -> stmt+          | otherwise ->+            let baseAddr = get_GlobalReg_addr dflags reg+            in case reg `elem` activeStgRegs (targetPlatform dflags) of+                True  -> CmmAssign (CmmGlobal reg) src+                False -> CmmStore baseAddr src+        other_stmt -> other_stmt++    fixExpr expr = case expr of+        -- MachSp isn't an STG; it's merely here for tracking unwind information+        CmmReg (CmmGlobal MachSp) -> expr+        CmmReg (CmmGlobal reg) ->+            -- Replace register leaves with appropriate StixTrees for+            -- the given target.  MagicIds which map to a reg on this+            -- arch are left unchanged.  For the rest, BaseReg is taken+            -- to mean the address of the reg table in MainCapability,+            -- and for all others we generate an indirection to its+            -- location in the register table.+            case reg `elem` activeStgRegs platform of+                True  -> expr+                False ->+                    let baseAddr = get_GlobalReg_addr dflags reg+                    in case reg of+                        BaseReg -> baseAddr+                        _other  -> CmmLoad baseAddr (globalRegType dflags reg)++        CmmRegOff (CmmGlobal reg) offset ->+            -- RegOf leaves are just a shorthand form. If the reg maps+            -- to a real reg, we keep the shorthand, otherwise, we just+            -- expand it and defer to the above code.+            case reg `elem` activeStgRegs platform of+                True  -> expr+                False -> CmmMachOp (MO_Add (wordWidth dflags)) [+                                    fixExpr (CmmReg (CmmGlobal reg)),+                                    CmmLit (CmmInt (fromIntegral offset)+                                                   (wordWidth dflags))]++        other_expr -> other_expr
+ compiler/codeGen/CodeGen/Platform.hs view
@@ -0,0 +1,107 @@++module CodeGen.Platform+       (callerSaves, activeStgRegs, haveRegBase, globalRegMaybe, freeReg)+       where++import GhcPrelude++import CmmExpr+import Platform+import Reg++import qualified CodeGen.Platform.ARM        as ARM+import qualified CodeGen.Platform.ARM64      as ARM64+import qualified CodeGen.Platform.PPC        as PPC+import qualified CodeGen.Platform.SPARC      as SPARC+import qualified CodeGen.Platform.X86        as X86+import qualified CodeGen.Platform.X86_64     as X86_64+import qualified CodeGen.Platform.NoRegs     as NoRegs++-- | Returns 'True' if this global register is stored in a caller-saves+-- machine register.++callerSaves :: Platform -> GlobalReg -> Bool+callerSaves platform+ | platformUnregisterised platform = NoRegs.callerSaves+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.callerSaves+   ArchX86_64 -> X86_64.callerSaves+   ArchSPARC  -> SPARC.callerSaves+   ArchARM {} -> ARM.callerSaves+   ArchARM64  -> ARM64.callerSaves+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+        PPC.callerSaves++    | otherwise -> NoRegs.callerSaves++-- | Here is where the STG register map is defined for each target arch.+-- The order matters (for the llvm backend anyway)! We must make sure to+-- maintain the order here with the order used in the LLVM calling conventions.+-- Note that also, this isn't all registers, just the ones that are currently+-- possbily mapped to real registers.+activeStgRegs :: Platform -> [GlobalReg]+activeStgRegs platform+ | platformUnregisterised platform = NoRegs.activeStgRegs+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.activeStgRegs+   ArchX86_64 -> X86_64.activeStgRegs+   ArchSPARC  -> SPARC.activeStgRegs+   ArchARM {} -> ARM.activeStgRegs+   ArchARM64  -> ARM64.activeStgRegs+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+        PPC.activeStgRegs++    | otherwise -> NoRegs.activeStgRegs++haveRegBase :: Platform -> Bool+haveRegBase platform+ | platformUnregisterised platform = NoRegs.haveRegBase+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.haveRegBase+   ArchX86_64 -> X86_64.haveRegBase+   ArchSPARC  -> SPARC.haveRegBase+   ArchARM {} -> ARM.haveRegBase+   ArchARM64  -> ARM64.haveRegBase+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+        PPC.haveRegBase++    | otherwise -> NoRegs.haveRegBase++globalRegMaybe :: Platform -> GlobalReg -> Maybe RealReg+globalRegMaybe platform+ | platformUnregisterised platform = NoRegs.globalRegMaybe+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.globalRegMaybe+   ArchX86_64 -> X86_64.globalRegMaybe+   ArchSPARC  -> SPARC.globalRegMaybe+   ArchARM {} -> ARM.globalRegMaybe+   ArchARM64  -> ARM64.globalRegMaybe+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+        PPC.globalRegMaybe++    | otherwise -> NoRegs.globalRegMaybe++freeReg :: Platform -> RegNo -> Bool+freeReg platform+ | platformUnregisterised platform = NoRegs.freeReg+ | otherwise+ = case platformArch platform of+   ArchX86    -> X86.freeReg+   ArchX86_64 -> X86_64.freeReg+   ArchSPARC  -> SPARC.freeReg+   ArchARM {} -> ARM.freeReg+   ArchARM64  -> ARM64.freeReg+   arch+    | arch `elem` [ArchPPC, ArchPPC_64 ELF_V1, ArchPPC_64 ELF_V2] ->+        PPC.freeReg++    | otherwise -> NoRegs.freeReg+
+ compiler/codeGen/CodeGen/Platform/ARM.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module CodeGen.Platform.ARM where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_arm 1+#include "../../../../includes/CodeGen.Platform.hs"+
+ compiler/codeGen/CodeGen/Platform/ARM64.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module CodeGen.Platform.ARM64 where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_aarch64 1+#include "../../../../includes/CodeGen.Platform.hs"+
+ compiler/codeGen/CodeGen/Platform/NoRegs.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE CPP #-}++module CodeGen.Platform.NoRegs where++import GhcPrelude++#define MACHREGS_NO_REGS 1+#include "../../../../includes/CodeGen.Platform.hs"+
+ compiler/codeGen/CodeGen/Platform/PPC.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module CodeGen.Platform.PPC where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_powerpc 1+#include "../../../../includes/CodeGen.Platform.hs"+
+ compiler/codeGen/CodeGen/Platform/SPARC.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module CodeGen.Platform.SPARC where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_sparc 1+#include "../../../../includes/CodeGen.Platform.hs"+
+ compiler/codeGen/CodeGen/Platform/X86.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module CodeGen.Platform.X86 where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_i386 1+#include "../../../../includes/CodeGen.Platform.hs"+
+ compiler/codeGen/CodeGen/Platform/X86_64.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}++module CodeGen.Platform.X86_64 where++import GhcPrelude++#define MACHREGS_NO_REGS 0+#define MACHREGS_x86_64 1+#include "../../../../includes/CodeGen.Platform.hs"+
+ compiler/codeGen/StgCmm.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmm ( codeGen ) where++#include "HsVersions.h"++import GhcPrelude as Prelude++import StgCmmProf (initCostCentres, ldvEnter)+import StgCmmMonad+import StgCmmEnv+import StgCmmBind+import StgCmmCon+import StgCmmLayout+import StgCmmUtils+import StgCmmClosure+import StgCmmHpc+import StgCmmTicky++import Cmm+import CmmUtils+import CLabel++import StgSyn+import DynFlags++import HscTypes+import CostCentre+import Id+import IdInfo+import RepType+import DataCon+import TyCon+import Module+import Outputable+import Stream+import BasicTypes+import VarSet ( isEmptyDVarSet )++import OrdList+import MkGraph++import Data.IORef+import Control.Monad (when,void)+import Util++codeGen :: DynFlags+        -> Module+        -> [TyCon]+        -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.+        -> [CgStgTopBinding]           -- Bindings to convert+        -> HpcInfo+        -> Stream IO CmmGroup ()       -- Output as a stream, so codegen can+                                       -- be interleaved with output++codeGen dflags this_mod data_tycons+        cost_centre_info stg_binds hpc_info+  = do  {     -- cg: run the code generator, and yield the resulting CmmGroup+              -- Using an IORef to store the state is a bit crude, but otherwise+              -- we would need to add a state monad layer.+        ; cgref <- liftIO $ newIORef =<< initC+        ; let cg :: FCode () -> Stream IO CmmGroup ()+              cg fcode = do+                cmm <- liftIO $ do+                         st <- readIORef cgref+                         let (a,st') = runC dflags this_mod st (getCmm fcode)++                         -- NB. stub-out cgs_tops and cgs_stmts.  This fixes+                         -- a big space leak.  DO NOT REMOVE!+                         writeIORef cgref $! st'{ cgs_tops = nilOL,+                                                  cgs_stmts = mkNop }+                         return a+                yield cmm++               -- Note [codegen-split-init] the cmm_init block must come+               -- FIRST.  This is because when -split-objs is on we need to+               -- combine this block with its initialisation routines; see+               -- Note [pipeline-split-init].+        ; cg (mkModuleInit cost_centre_info this_mod hpc_info)++        ; mapM_ (cg . cgTopBinding dflags) stg_binds++                -- Put datatype_stuff after code_stuff, because the+                -- datatype closure table (for enumeration types) to+                -- (say) PrelBase_True_closure, which is defined in+                -- code_stuff+        ; let do_tycon tycon = do+                -- Generate a table of static closures for an+                -- enumeration type Note that the closure pointers are+                -- tagged.+                 when (isEnumerationTyCon tycon) $ cg (cgEnumerationTyCon tycon)+                 mapM_ (cg . cgDataCon) (tyConDataCons tycon)++        ; mapM_ do_tycon data_tycons+        }++---------------------------------------------------------------+--      Top-level bindings+---------------------------------------------------------------++{- 'cgTopBinding' is only used for top-level bindings, since they need+to be allocated statically (not in the heap) and need to be labelled.+No unboxed bindings can happen at top level.++In the code below, the static bindings are accumulated in the+@MkCgState@, and transferred into the ``statics'' slot by @forkStatics@.+This is so that we can write the top level processing in a compositional+style, with the increasing static environment being plumbed as a state+variable. -}++cgTopBinding :: DynFlags -> CgStgTopBinding -> FCode ()+cgTopBinding dflags (StgTopLifted (StgNonRec id rhs))+  = do  { let (info, fcode) = cgTopRhs dflags NonRecursive id rhs+        ; fcode+        ; addBindC info+        }++cgTopBinding dflags (StgTopLifted (StgRec pairs))+  = do  { let (bndrs, rhss) = unzip pairs+        ; let pairs' = zip bndrs rhss+              r = unzipWith (cgTopRhs dflags Recursive) pairs'+              (infos, fcodes) = unzip r+        ; addBindsC infos+        ; sequence_ fcodes+        }++cgTopBinding dflags (StgTopStringLit id str)+  = do  { let label = mkBytesLabel (idName id)+        ; let (lit, decl) = mkByteStringCLit label str+        ; emitDecl decl+        ; addBindC (litIdInfo dflags id mkLFStringLit lit)+        }++cgTopRhs :: DynFlags -> RecFlag -> Id -> CgStgRhs -> (CgIdInfo, FCode ())+        -- The Id is passed along for setting up a binding...++cgTopRhs dflags _rec bndr (StgRhsCon _cc con args)+  = cgTopRhsCon dflags bndr con (assertNonVoidStgArgs args)+      -- con args are always non-void,+      -- see Note [Post-unarisation invariants] in UnariseStg++cgTopRhs dflags rec bndr (StgRhsClosure fvs cc upd_flag args body)+  = ASSERT(isEmptyDVarSet fvs)    -- There should be no free variables+    cgTopRhsClosure dflags rec bndr cc upd_flag args body+++---------------------------------------------------------------+--      Module initialisation code+---------------------------------------------------------------++mkModuleInit+        :: CollectedCCs         -- cost centre info+        -> Module+        -> HpcInfo+        -> FCode ()++mkModuleInit cost_centre_info this_mod hpc_info+  = do  { initHpc this_mod hpc_info+        ; initCostCentres cost_centre_info+        }+++---------------------------------------------------------------+--      Generating static stuff for algebraic data types+---------------------------------------------------------------+++cgEnumerationTyCon :: TyCon -> FCode ()+cgEnumerationTyCon tycon+  = do dflags <- getDynFlags+       emitRODataLits (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)+             [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs)+                           (tagForCon dflags con)+             | con <- tyConDataCons tycon]+++cgDataCon :: DataCon -> FCode ()+-- Generate the entry code, info tables, and (for niladic constructor)+-- the static closure, for a constructor.+cgDataCon data_con+  = do  { dflags <- getDynFlags+        ; let+            (tot_wds, --  #ptr_wds + #nonptr_wds+             ptr_wds) --  #ptr_wds+              = mkVirtConstrSizes dflags arg_reps++            nonptr_wds   = tot_wds - ptr_wds++            dyn_info_tbl =+              mkDataConInfoTable dflags data_con False ptr_wds nonptr_wds++            -- We're generating info tables, so we don't know and care about+            -- what the actual arguments are. Using () here as the place holder.+            arg_reps :: [NonVoid PrimRep]+            arg_reps = [ NonVoid rep_ty+                       | ty <- dataConRepArgTys data_con+                       , rep_ty <- typePrimRep ty+                       , not (isVoidRep rep_ty) ]++        ; emitClosureAndInfoTable dyn_info_tbl NativeDirectCall [] $+            -- NB: the closure pointer is assumed *untagged* on+            -- entry to a constructor.  If the pointer is tagged,+            -- then we should not be entering it.  This assumption+            -- is used in ldvEnter and when tagging the pointer to+            -- return it.+            -- NB 2: We don't set CC when entering data (WDP 94/06)+            do { tickyEnterDynCon+               ; ldvEnter (CmmReg nodeReg)+               ; tickyReturnOldCon (length arg_reps)+               ; void $ emitReturn [cmmOffsetB dflags (CmmReg nodeReg) (tagForCon dflags data_con)]+               }+                    -- The case continuation code expects a tagged pointer+        }
+ compiler/codeGen/StgCmmArgRep.hs view
@@ -0,0 +1,158 @@+-----------------------------------------------------------------------------+--+-- Argument representations used in StgCmmLayout.+--+-- (c) The University of Glasgow 2013+--+-----------------------------------------------------------------------------++module StgCmmArgRep (+        ArgRep(..), toArgRep, argRepSizeW,++        argRepString, isNonV, idArgRep,++        slowCallPattern,++        ) where++import GhcPrelude++import StgCmmClosure    ( idPrimRep )++import SMRep            ( WordOff )+import Id               ( Id )+import TyCon            ( PrimRep(..), primElemRepSizeB )+import BasicTypes       ( RepArity )+import Constants        ( wORD64_SIZE )+import DynFlags++import Outputable+import FastString++-- I extricated this code as this new module in order to avoid a+-- cyclic dependency between StgCmmLayout and StgCmmTicky.+--+-- NSF 18 Feb 2013++-------------------------------------------------------------------------+--      Classifying arguments: ArgRep+-------------------------------------------------------------------------++-- ArgRep is re-exported by StgCmmLayout, but only for use in the+-- byte-code generator which also needs to know about the+-- classification of arguments.++data ArgRep = P   -- GC Ptr+            | N   -- Word-sized non-ptr+            | L   -- 64-bit non-ptr (long)+            | V   -- Void+            | F   -- Float+            | D   -- Double+            | V16 -- 16-byte (128-bit) vectors of Float/Double/Int8/Word32/etc.+            | V32 -- 32-byte (256-bit) vectors of Float/Double/Int8/Word32/etc.+            | V64 -- 64-byte (512-bit) vectors of Float/Double/Int8/Word32/etc.+instance Outputable ArgRep where ppr = text . argRepString++argRepString :: ArgRep -> String+argRepString P = "P"+argRepString N = "N"+argRepString L = "L"+argRepString V = "V"+argRepString F = "F"+argRepString D = "D"+argRepString V16 = "V16"+argRepString V32 = "V32"+argRepString V64 = "V64"++toArgRep :: PrimRep -> ArgRep+toArgRep VoidRep           = V+toArgRep LiftedRep         = P+toArgRep UnliftedRep       = P+toArgRep IntRep            = N+toArgRep WordRep           = N+toArgRep Int8Rep           = N  -- Gets widened to native word width for calls+toArgRep Word8Rep          = N  -- Gets widened to native word width for calls+toArgRep Int16Rep          = N  -- Gets widened to native word width for calls+toArgRep Word16Rep         = N  -- Gets widened to native word width for calls+toArgRep AddrRep           = N+toArgRep Int64Rep          = L+toArgRep Word64Rep         = L+toArgRep FloatRep          = F+toArgRep DoubleRep         = D+toArgRep (VecRep len elem) = case len*primElemRepSizeB elem of+                               16 -> V16+                               32 -> V32+                               64 -> V64+                               _  -> error "toArgRep: bad vector primrep"++isNonV :: ArgRep -> Bool+isNonV V = False+isNonV _ = True++argRepSizeW :: DynFlags -> ArgRep -> WordOff                -- Size in words+argRepSizeW _      N   = 1+argRepSizeW _      P   = 1+argRepSizeW _      F   = 1+argRepSizeW dflags L   = wORD64_SIZE        `quot` wORD_SIZE dflags+argRepSizeW dflags D   = dOUBLE_SIZE dflags `quot` wORD_SIZE dflags+argRepSizeW _      V   = 0+argRepSizeW dflags V16 = 16                 `quot` wORD_SIZE dflags+argRepSizeW dflags V32 = 32                 `quot` wORD_SIZE dflags+argRepSizeW dflags V64 = 64                 `quot` wORD_SIZE dflags++idArgRep :: Id -> ArgRep+idArgRep = toArgRep . idPrimRep++-- This list of argument patterns should be kept in sync with at least+-- the following:+--+--  * StgCmmLayout.stdPattern maybe to some degree?+--+--  * the RTS_RET(stg_ap_*) and RTS_FUN_DECL(stg_ap_*_fast)+--  declarations in includes/stg/MiscClosures.h+--+--  * the SLOW_CALL_*_ctr declarations in includes/stg/Ticky.h,+--+--  * the TICK_SLOW_CALL_*() #defines in includes/Cmm.h,+--+--  * the PR_CTR(SLOW_CALL_*_ctr) calls in rts/Ticky.c,+--+--  * and the SymI_HasProto(stg_ap_*_{ret,info,fast}) calls and+--  SymI_HasProto(SLOW_CALL_*_ctr) calls in rts/Linker.c+--+-- There may be more places that I haven't found; I merely igrep'd for+-- pppppp and excluded things that seemed ghci-specific.+--+-- Also, it seems at the moment that ticky counters with void+-- arguments will never be bumped, but I'm still declaring those+-- counters, defensively.+--+-- NSF 6 Mar 2013++slowCallPattern :: [ArgRep] -> (FastString, RepArity)+-- Returns the generic apply function and arity+--+-- The first batch of cases match (some) specialised entries+-- The last group deals exhaustively with the cases for the first argument+--   (and the zero-argument case)+--+-- In 99% of cases this function will match *all* the arguments in one batch++slowCallPattern (P: P: P: P: P: P: _) = (fsLit "stg_ap_pppppp", 6)+slowCallPattern (P: P: P: P: P: _)    = (fsLit "stg_ap_ppppp", 5)+slowCallPattern (P: P: P: P: _)       = (fsLit "stg_ap_pppp", 4)+slowCallPattern (P: P: P: V: _)       = (fsLit "stg_ap_pppv", 4)+slowCallPattern (P: P: P: _)          = (fsLit "stg_ap_ppp", 3)+slowCallPattern (P: P: V: _)          = (fsLit "stg_ap_ppv", 3)+slowCallPattern (P: P: _)             = (fsLit "stg_ap_pp", 2)+slowCallPattern (P: V: _)             = (fsLit "stg_ap_pv", 2)+slowCallPattern (P: _)                = (fsLit "stg_ap_p", 1)+slowCallPattern (V: _)                = (fsLit "stg_ap_v", 1)+slowCallPattern (N: _)                = (fsLit "stg_ap_n", 1)+slowCallPattern (F: _)                = (fsLit "stg_ap_f", 1)+slowCallPattern (D: _)                = (fsLit "stg_ap_d", 1)+slowCallPattern (L: _)                = (fsLit "stg_ap_l", 1)+slowCallPattern (V16: _)              = (fsLit "stg_ap_v16", 1)+slowCallPattern (V32: _)              = (fsLit "stg_ap_v32", 1)+slowCallPattern (V64: _)              = (fsLit "stg_ap_v64", 1)+slowCallPattern []                    = (fsLit "stg_ap_0", 0)
+ compiler/codeGen/StgCmmBind.hs view
@@ -0,0 +1,753 @@+-----------------------------------------------------------------------------+--+-- Stg to C-- code generation: bindings+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmBind (+        cgTopRhsClosure,+        cgBind,+        emitBlackHoleCode,+        pushUpdateFrame, emitUpdateFrame+  ) where++import GhcPrelude hiding ((<*>))++import StgCmmExpr+import StgCmmMonad+import StgCmmEnv+import StgCmmCon+import StgCmmHeap+import StgCmmProf (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,+                   initUpdFrameProf)+import StgCmmTicky+import StgCmmLayout+import StgCmmUtils+import StgCmmClosure+import StgCmmForeign    (emitPrimCall)++import MkGraph+import CoreSyn          ( AltCon(..), tickishIsCode )+import BlockId+import SMRep+import Cmm+import CmmInfo+import CmmUtils+import CLabel+import StgSyn+import CostCentre+import Id+import IdInfo+import Name+import Module+import ListSetOps+import Util+import VarSet+import BasicTypes+import Outputable+import FastString+import DynFlags++import Control.Monad++------------------------------------------------------------------------+--              Top-level bindings+------------------------------------------------------------------------++-- For closures bound at top level, allocate in static space.+-- They should have no free variables.++cgTopRhsClosure :: DynFlags+                -> RecFlag              -- member of a recursive group?+                -> Id+                -> CostCentreStack      -- Optional cost centre annotation+                -> UpdateFlag+                -> [Id]                 -- Args+                -> CgStgExpr+                -> (CgIdInfo, FCode ())++cgTopRhsClosure dflags rec id ccs upd_flag args body =+  let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)+      cg_id_info    = litIdInfo dflags id lf_info (CmmLabel closure_label)+      lf_info       = mkClosureLFInfo dflags id TopLevel [] upd_flag args+  in (cg_id_info, gen_code dflags lf_info closure_label)+  where+  -- special case for a indirection (f = g).  We create an IND_STATIC+  -- closure pointing directly to the indirectee.  This is exactly+  -- what the CAF will eventually evaluate to anyway, we're just+  -- shortcutting the whole process, and generating a lot less code+  -- (#7308). Eventually the IND_STATIC closure will be eliminated+  -- by assembly '.equiv' directives, where possible (#15155).+  -- See note [emit-time elimination of static indirections] in CLabel.+  --+  -- Note: we omit the optimisation when this binding is part of a+  -- recursive group, because the optimisation would inhibit the black+  -- hole detection from working in that case.  Test+  -- concurrent/should_run/4030 fails, for instance.+  --+  gen_code dflags _ closure_label+    | 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 ()++  gen_code dflags lf_info _closure_label+   = do { let name = idName id+        ; mod_name <- getModuleName+        ; let descr         = closureDescription dflags mod_name name+              closure_info  = mkClosureInfo dflags True id lf_info 0 0 descr++        -- We don't generate the static closure here, because we might+        -- want to add references to static closures to it later.  The+        -- static closure is generated by CmmBuildInfoTables.updInfoSRTs,+        -- See Note [SRTs], specifically the [FUN] optimisation.++        ; let fv_details :: [(NonVoid Id, ByteOff)]+              header = if isLFThunk lf_info then ThunkHeader else StdHeader+              (_, _, fv_details) = mkVirtHeapOffsets dflags header []+        -- Don't drop the non-void args until the closure info has been made+        ; forkClosureBody (closureCodeBody True id closure_info ccs+                                (nonVoidIds args) (length args) body fv_details)++        ; return () }++  unLit (CmmLit l) = l+  unLit _ = panic "unLit"++------------------------------------------------------------------------+--              Non-top-level bindings+------------------------------------------------------------------------++cgBind :: CgStgBinding -> FCode ()+cgBind (StgNonRec name rhs)+  = do  { (info, fcode) <- cgRhs name rhs+        ; addBindC info+        ; init <- fcode+        ; emit init }+        -- init cannot be used in body, so slightly better to sink it eagerly++cgBind (StgRec pairs)+  = do  {  r <- sequence $ unzipWith cgRhs pairs+        ;  let (id_infos, fcodes) = unzip r+        ;  addBindsC id_infos+        ;  (inits, body) <- getCodeR $ sequence fcodes+        ;  emit (catAGraphs inits <*> body) }++{- Note [cgBind rec]++   Recursive let-bindings are tricky.+   Consider the following pseudocode:++     let x = \_ ->  ... y ...+         y = \_ ->  ... z ...+         z = \_ ->  ... x ...+     in ...++   For each binding, we need to allocate a closure, and each closure must+   capture the address of the other closures.+   We want to generate the following C-- code:+     // Initialization Code+     x = hp - 24; // heap address of x's closure+     y = hp - 40; // heap address of x's closure+     z = hp - 64; // heap address of x's closure+     // allocate and initialize x+     m[hp-8]   = ...+     m[hp-16]  = y       // the closure for x captures y+     m[hp-24] = x_info;+     // allocate and initialize y+     m[hp-32] = z;       // the closure for y captures z+     m[hp-40] = y_info;+     // allocate and initialize z+     ...++   For each closure, we must generate not only the code to allocate and+   initialize the closure itself, but also some initialization Code that+   sets a variable holding the closure pointer.++   We could generate a pair of the (init code, body code), but since+   the bindings are recursive we also have to initialise the+   environment with the CgIdInfo for all the bindings before compiling+   anything.  So we do this in 3 stages:++     1. collect all the CgIdInfos and initialise the environment+     2. compile each binding into (init, body) code+     3. emit all the inits, and then all the bodies++   We'd rather not have separate functions to do steps 1 and 2 for+   each binding, since in pratice they share a lot of code.  So we+   have just one function, cgRhs, that returns a pair of the CgIdInfo+   for step 1, and a monadic computation to generate the code in step+   2.++   The alternative to separating things in this way is to use a+   fixpoint.  That's what we used to do, but it introduces a+   maintenance nightmare because there is a subtle dependency on not+   being too strict everywhere.  Doing things this way means that the+   FCode monad can be strict, for example.+ -}++cgRhs :: Id+      -> CgStgRhs+      -> FCode (+                 CgIdInfo         -- The info for this binding+               , FCode CmmAGraph  -- A computation which will generate the+                                  -- code for the binding, and return an+                                  -- assignent of the form "x = Hp - n"+                                  -- (see above)+               )++cgRhs id (StgRhsCon cc con args)+  = withNewTickyCounterCon (idName id) $+    buildDynCon id True cc con (assertNonVoidStgArgs args)+      -- con args are always non-void,+      -- see Note [Post-unarisation invariants] in UnariseStg++{- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -}+cgRhs id (StgRhsClosure fvs cc upd_flag args body)+  = do dflags <- getDynFlags+       mkRhsClosure dflags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body++------------------------------------------------------------------------+--              Non-constructor right hand sides+------------------------------------------------------------------------++mkRhsClosure :: DynFlags -> Id -> CostCentreStack+             -> [NonVoid Id]                    -- Free vars+             -> UpdateFlag+             -> [Id]                            -- Args+             -> CgStgExpr+             -> FCode (CgIdInfo, FCode CmmAGraph)++{- mkRhsClosure looks for two special forms of the right-hand side:+        a) selector thunks+        b) AP thunks++If neither happens, it just calls mkClosureLFInfo.  You might think+that mkClosureLFInfo should do all this, but it seems wrong for the+latter to look at the structure of an expression++Note [Selectors]+~~~~~~~~~~~~~~~~+We look at the body of the closure to see if it's a selector---turgid,+but nothing deep.  We are looking for a closure of {\em exactly} the+form:++...  = [the_fv] \ u [] ->+         case the_fv of+           con a_1 ... a_n -> a_i++Note [Ap thunks]+~~~~~~~~~~~~~~~~+A more generic AP thunk of the form++        x = [ x_1...x_n ] \.. [] -> x_1 ... x_n++A set of these is compiled statically into the RTS, so we just use+those.  We could extend the idea to thunks where some of the x_i are+global ids (and hence not free variables), but this would entail+generating a larger thunk.  It might be an option for non-optimising+compilation, though.++We only generate an Ap thunk if all the free variables are pointers,+for semi-obvious reasons.++-}++---------- Note [Selectors] ------------------+mkRhsClosure    dflags bndr _cc+                [NonVoid the_fv]                -- Just one free var+                upd_flag                -- Updatable thunk+                []                      -- A thunk+                expr+  | let strip = snd . stripStgTicksTop (not . tickishIsCode)+  , StgCase (StgApp scrutinee [{-no args-}])+         _   -- ignore bndr+         (AlgAlt _)+         [(DataAlt _, params, sel_expr)] <- strip expr+  , StgApp selectee [{-no args-}] <- strip sel_expr+  , the_fv == scrutinee                -- Scrutinee is the only free variable++  , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps (assertNonVoidIds params))+                                   -- pattern binders are always non-void,+                                   -- see Note [Post-unarisation invariants] in UnariseStg+  , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee)++  , let offset_into_int = bytesToWordsRoundUp dflags the_offset+                          - fixedHdrSizeW dflags+  , offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough+  = -- NOT TRUE: ASSERT(is_single_constructor)+    -- The simplifier may have statically determined that the single alternative+    -- is the only possible case and eliminated the others, even if there are+    -- other constructors in the datatype.  It's still ok to make a selector+    -- thunk in this case, because we *know* which constructor the scrutinee+    -- will evaluate to.+    --+    -- srt is discarded; it must be empty+    let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)+    in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]++---------- Note [Ap thunks] ------------------+mkRhsClosure    dflags bndr _cc+                fvs+                upd_flag+                []                      -- No args; a thunk+                (StgApp fun_id args)++  -- We are looking for an "ApThunk"; see data con ApThunk in StgCmmClosure+  -- of form (x1 x2 .... xn), where all the xi are locals (not top-level)+  -- So the xi will all be free variables+  | args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and+                               -- args are all distinct local variables+                               -- The "-1" is for fun_id+    -- Missed opportunity:   (f x x) is not detected+  , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs+  , isUpdatable upd_flag+  , n_fvs <= mAX_SPEC_AP_SIZE dflags+  , not (gopt Opt_SccProfilingOn dflags)+                         -- not when profiling: we don't want to+                         -- lose information about this particular+                         -- thunk (e.g. its type) (#949)+  , idArity fun_id == unknownArity -- don't spoil a known call++          -- Ha! an Ap thunk+  = cgRhsStdThunk bndr lf_info payload++  where+    n_fvs   = length fvs+    lf_info = mkApLFInfo bndr upd_flag n_fvs+    -- the payload has to be in the correct order, hence we can't+    -- just use the fvs.+    payload = StgVarArg fun_id : args++---------- Default case ------------------+mkRhsClosure dflags bndr cc fvs upd_flag args body+  = do  { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args+        ; (id_info, reg) <- rhsIdInfo bndr lf_info+        ; return (id_info, gen_code lf_info reg) }+ where+ gen_code lf_info reg+  = do  {       -- LAY OUT THE OBJECT+        -- If the binder is itself a free variable, then don't store+        -- it in the closure.  Instead, just bind it to Node on entry.+        -- NB we can be sure that Node will point to it, because we+        -- haven't told mkClosureLFInfo about this; so if the binder+        -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*+        -- stored in the closure itself, so it will make sure that+        -- Node points to it...+        ; let   reduced_fvs = filter (NonVoid bndr /=) fvs++        -- MAKE CLOSURE INFO FOR THIS CLOSURE+        ; mod_name <- getModuleName+        ; dflags <- getDynFlags+        ; let   name  = idName bndr+                descr = closureDescription dflags mod_name name+                fv_details :: [(NonVoid Id, ByteOff)]+                header = if isLFThunk lf_info then ThunkHeader else StdHeader+                (tot_wds, ptr_wds, fv_details)+                   = mkVirtHeapOffsets dflags header (addIdReps reduced_fvs)+                closure_info = mkClosureInfo dflags False       -- Not static+                                             bndr lf_info tot_wds ptr_wds+                                             descr++        -- BUILD ITS INFO TABLE AND CODE+        ; forkClosureBody $+                -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere+                --                  (b) ignore Sequel from context; use empty Sequel+                -- And compile the body+                closureCodeBody False bndr closure_info cc (nonVoidIds args)+                                (length args) body fv_details++        -- BUILD THE OBJECT+--      ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body+        ; let use_cc = cccsExpr; blame_cc = cccsExpr+        ; emit (mkComment $ mkFastString "calling allocDynClosure")+        ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)+        ; let info_tbl = mkCmmInfo closure_info bndr currentCCS+        ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc+                                         (map toVarArg fv_details)++        -- RETURN+        ; return (mkRhsInit dflags reg lf_info hp_plus_n) }++-------------------------+cgRhsStdThunk+        :: Id+        -> LambdaFormInfo+        -> [StgArg]             -- payload+        -> FCode (CgIdInfo, FCode CmmAGraph)++cgRhsStdThunk bndr lf_info payload+ = do  { (id_info, reg) <- rhsIdInfo bndr lf_info+       ; return (id_info, gen_code reg)+       }+ where+ gen_code reg  -- AHA!  A STANDARD-FORM THUNK+  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $+    do+  {     -- LAY OUT THE OBJECT+    mod_name <- getModuleName+  ; dflags <- getDynFlags+  ; let header = if isLFThunk lf_info then ThunkHeader else StdHeader+        (tot_wds, ptr_wds, payload_w_offsets)+            = mkVirtHeapOffsets dflags header+                (addArgReps (nonVoidStgArgs payload))++        descr = closureDescription dflags mod_name (idName bndr)+        closure_info = mkClosureInfo dflags False       -- Not static+                                     bndr lf_info tot_wds ptr_wds+                                     descr++--  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body+  ; let use_cc = cccsExpr; blame_cc = cccsExpr+++        -- BUILD THE OBJECT+  ; let info_tbl = mkCmmInfo closure_info bndr currentCCS+  ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info+                                   use_cc blame_cc payload_w_offsets++        -- RETURN+  ; return (mkRhsInit dflags reg lf_info hp_plus_n) }+++mkClosureLFInfo :: DynFlags+                -> Id           -- The binder+                -> TopLevelFlag -- True of top level+                -> [NonVoid Id] -- Free vars+                -> UpdateFlag   -- Update flag+                -> [Id]         -- Args+                -> LambdaFormInfo+mkClosureLFInfo dflags bndr top fvs upd_flag args+  | null args =+        mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag+  | otherwise =+        mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr dflags args)+++------------------------------------------------------------------------+--              The code for closures+------------------------------------------------------------------------++closureCodeBody :: Bool            -- whether this is a top-level binding+                -> Id              -- the closure's name+                -> ClosureInfo     -- Lots of information about this closure+                -> CostCentreStack -- Optional cost centre attached to closure+                -> [NonVoid Id]    -- incoming args to the closure+                -> Int             -- arity, including void args+                -> CgStgExpr+                -> [(NonVoid Id, ByteOff)] -- the closure's free vars+                -> FCode ()++{- There are two main cases for the code for closures.++* If there are *no arguments*, then the closure is a thunk, and not in+  normal form. So it should set up an update frame (if it is+  shared). NB: Thunks cannot have a primitive type!++* If there is *at least one* argument, then this closure is in+  normal form, so there is no need to set up an update frame.+-}++closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details+  | arity == 0 -- No args i.e. thunk+  = withNewTickyCounterThunk+        (isStaticClosure cl_info)+        (closureUpdReqd cl_info)+        (closureName cl_info) $+    emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $+      \(_, node, _) -> thunkCode cl_info fv_details cc node arity body+   where+     lf_info  = closureLFInfo cl_info+     info_tbl = mkCmmInfo cl_info bndr cc++closureCodeBody top_lvl bndr cl_info cc args arity body fv_details+  = -- Note: args may be [], if all args are Void+    withNewTickyCounterFun+        (closureSingleEntry cl_info)+        (closureName cl_info)+        args $ do {++        ; let+             lf_info  = closureLFInfo cl_info+             info_tbl = mkCmmInfo cl_info bndr cc++        -- Emit the main entry code+        ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $+            \(_offset, node, arg_regs) -> do+                -- Emit slow-entry code (for entering a closure through a PAP)+                { mkSlowEntryCode bndr cl_info arg_regs+                ; dflags <- getDynFlags+                ; let node_points = nodeMustPointToIt dflags lf_info+                      node' = if node_points then Just node else Nothing+                ; loop_header_id <- newBlockId+                -- Extend reader monad with information that+                -- self-recursive tail calls can be optimized into local+                -- jumps. See Note [Self-recursive tail calls] in StgCmmExpr.+                ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do+                {+                -- Main payload+                ; entryHeapCheck cl_info node' arity arg_regs $ do+                { -- emit LDV code when profiling+                  when node_points (ldvEnterClosure cl_info (CmmLocal node))+                -- ticky after heap check to avoid double counting+                ; tickyEnterFun cl_info+                ; enterCostCentreFun cc+                    (CmmMachOp (mo_wordSub dflags)+                         [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]+                         , mkIntExpr dflags (funTag dflags cl_info) ])+                ; fv_bindings <- mapM bind_fv fv_details+                -- Load free vars out of closure *after*+                -- heap check, to reduce live vars over check+                ; when node_points $ load_fvs node lf_info fv_bindings+                ; void $ cgExpr body+                }}}++  }++-- Note [NodeReg clobbered with loopification]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Previously we used to pass nodeReg (aka R1) here. With profiling, upon+-- entering a closure, enterFunCCS was called with R1 passed to it. But since R1+-- may get clobbered inside the body of a closure, and since a self-recursive+-- tail call does not restore R1, a subsequent call to enterFunCCS received a+-- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to+-- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores+-- the original value of R1. This way R1 may get modified but loopification will+-- not care.++-- A function closure pointer may be tagged, so we+-- must take it into account when accessing the free variables.+bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)+bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }++load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()+load_fvs node lf_info = mapM_ (\ (reg, off) ->+   do dflags <- getDynFlags+      let tag = lfDynTag dflags lf_info+      emit $ mkTaggedObjectLoad dflags reg node off tag)++-----------------------------------------+-- The "slow entry" code for a function.  This entry point takes its+-- arguments on the stack.  It loads the arguments into registers+-- according to the calling convention, and jumps to the function's+-- normal entry point.  The function's closure is assumed to be in+-- R1/node.+--+-- The slow entry point is used for unknown calls: eg. stg_PAP_entry++mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()+-- If this function doesn't have a specialised ArgDescr, we need+-- to generate the function's arg bitmap and slow-entry code.+-- Here, we emit the slow-entry code.+mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'+  | Just (_, ArgGen _) <- closureFunInfo cl_info+  = do dflags <- getDynFlags+       let node = idToReg dflags (NonVoid bndr)+           slow_lbl = closureSlowEntryLabel  cl_info+           fast_lbl = closureLocalEntryLabel dflags cl_info+           -- mkDirectJump does not clobber `Node' containing function closure+           jump = mkJump dflags NativeNodeCall+                                (mkLblExpr fast_lbl)+                                (map (CmmReg . CmmLocal) (node : arg_regs))+                                (initUpdFrameOff dflags)+       tscope <- getTickScope+       emitProcWithConvention Slow Nothing slow_lbl+         (node : arg_regs) (jump, tscope)+  | otherwise = return ()++-----------------------------------------+thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack+          -> LocalReg -> Int -> CgStgExpr -> FCode ()+thunkCode cl_info fv_details _cc node arity body+  = do { dflags <- getDynFlags+       ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)+             node'       = if node_points then Just node else Nothing+        ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling++        -- Heap overflow check+        ; entryHeapCheck cl_info node' arity [] $ do+        { -- Overwrite with black hole if necessary+          -- but *after* the heap-overflow check+        ; tickyEnterThunk cl_info+        ; when (blackHoleOnEntry cl_info && node_points)+                (blackHoleIt node)++          -- Push update frame+        ; setupUpdate cl_info node $+            -- We only enter cc after setting up update so+            -- that cc of enclosing scope will be recorded+            -- in update frame CAF/DICT functions will be+            -- subsumed by this enclosing cc+            do { enterCostCentreThunk (CmmReg nodeReg)+               ; let lf_info = closureLFInfo cl_info+               ; fv_bindings <- mapM bind_fv fv_details+               ; load_fvs node lf_info fv_bindings+               ; void $ cgExpr body }}}+++------------------------------------------------------------------------+--              Update and black-hole wrappers+------------------------------------------------------------------------++blackHoleIt :: LocalReg -> FCode ()+-- Only called for closures with no args+-- Node points to the closure+blackHoleIt node_reg+  = emitBlackHoleCode (CmmReg (CmmLocal node_reg))++emitBlackHoleCode :: CmmExpr -> FCode ()+emitBlackHoleCode node = do+  dflags <- getDynFlags++  -- Eager blackholing is normally disabled, but can be turned on with+  -- -feager-blackholing.  When it is on, we replace the info pointer+  -- of the thunk with stg_EAGER_BLACKHOLE_info on entry.++  -- If we wanted to do eager blackholing with slop filling, we'd need+  -- to do it at the *end* of a basic block, otherwise we overwrite+  -- the free variables in the thunk that we still need.  We have a+  -- patch for this from Andy Cheadle, but not incorporated yet. --SDM+  -- [6/2004]+  --+  -- Previously, eager blackholing was enabled when ticky-ticky was+  -- on. But it didn't work, and it wasn't strictly necessary to bring+  -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is+  -- unconditionally disabled. -- krc 1/2007++  -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,+  -- because emitBlackHoleCode is called from CmmParse.++  let  eager_blackholing =  not (gopt Opt_SccProfilingOn dflags)+                         && gopt Opt_EagerBlackHoling dflags+             -- Profiling needs slop filling (to support LDV+             -- profiling), so currently eager blackholing doesn't+             -- work with profiling.++  when eager_blackholing $ do+    emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags)) currentTSOExpr+    emitPrimCall [] MO_WriteBarrier []+    emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))++setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()+        -- Nota Bene: this function does not change Node (even if it's a CAF),+        -- so that the cost centre in the original closure can still be+        -- extracted by a subsequent enterCostCentre+setupUpdate closure_info node body+  | not (lfUpdatable (closureLFInfo closure_info))+  = body++  | not (isStaticClosure closure_info)+  = if not (closureUpdReqd closure_info)+      then do tickyUpdateFrameOmitted; body+      else do+          tickyPushUpdateFrame+          dflags <- getDynFlags+          let+              bh = blackHoleOnEntry closure_info &&+                   not (gopt Opt_SccProfilingOn dflags) &&+                   gopt Opt_EagerBlackHoling dflags++              lbl | bh        = mkBHUpdInfoLabel+                  | otherwise = mkUpdInfoLabel++          pushUpdateFrame lbl (CmmReg (CmmLocal node)) body++  | otherwise   -- A static closure+  = do  { tickyUpdateBhCaf closure_info++        ; if closureUpdReqd closure_info+          then do       -- Blackhole the (updatable) CAF:+                { upd_closure <- link_caf node True+                ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body }+          else do {tickyUpdateFrameOmitted; body}+    }++-----------------------------------------------------------------------------+-- Setting up update frames++-- Push the update frame on the stack in the Entry area,+-- leaving room for the return address that is already+-- at the old end of the area.+--+pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()+pushUpdateFrame lbl updatee body+  = do+       updfr  <- getUpdFrameOff+       dflags <- getDynFlags+       let+           hdr         = fixedHdrSize dflags+           frame       = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags+       --+       emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee+       withUpdFrameOff frame body++emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()+emitUpdateFrame dflags frame lbl updatee = do+  let+           hdr         = fixedHdrSize dflags+           off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags+  --+  emitStore frame (mkLblExpr lbl)+  emitStore (cmmOffset dflags frame off_updatee) updatee+  initUpdFrameProf frame++-----------------------------------------------------------------------------+-- Entering a CAF+--+-- See Note [CAF management] in rts/sm/Storage.c++link_caf :: LocalReg           -- pointer to the closure+         -> Bool               -- True <=> updatable, False <=> single-entry+         -> FCode CmmExpr      -- Returns amode for closure to be updated+-- This function returns the address of the black hole, so it can be+-- updated with the new value when available.+link_caf node _is_upd = do+  { dflags <- getDynFlags+        -- Call the RTS function newCAF, returning the newly-allocated+        -- blackhole indirection closure+  ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing+                                    ForeignLabelInExternalPackage IsFunction+  ; bh <- newTemp (bWord dflags)+  ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl+      [ (baseExpr,  AddrHint),+        (CmmReg (CmmLocal node), AddrHint) ]+      False++  -- see Note [atomic CAF entry] in rts/sm/Storage.c+  ; updfr  <- getUpdFrameOff+  ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node)))+  ; emit =<< mkCmmIfThen+      (cmmEqWord dflags (CmmReg (CmmLocal bh)) (zeroExpr dflags))+        -- re-enter the CAF+       (mkJump dflags NativeNodeCall target [] updfr)++  ; return (CmmReg (CmmLocal bh)) }++------------------------------------------------------------------------+--              Profiling+------------------------------------------------------------------------++-- For "global" data constructors the description is simply occurrence+-- name of the data constructor itself.  Otherwise it is determined by+-- @closureDescription@ from the let binding information.++closureDescription :: DynFlags+           -> Module            -- Module+                   -> Name              -- Id of closure binding+                   -> String+        -- Not called for StgRhsCon which have global info tables built in+        -- CgConTbls.hs with a description generated from the data constructor+closureDescription dflags mod_name name+  = showSDocDump dflags (char '<' <>+                    (if isExternalName name+                      then ppr name -- ppr will include the module name prefix+                      else pprModule mod_name <> char '.' <> ppr name) <>+                    char '>')+   -- showSDocDump, because we want to see the unique on the Name.
+ compiler/codeGen/StgCmmBind.hs-boot view
@@ -0,0 +1,6 @@+module StgCmmBind where++import StgCmmMonad( FCode )+import StgSyn( CgStgBinding )++cgBind :: CgStgBinding -> FCode ()
+ compiler/codeGen/StgCmmClosure.hs view
@@ -0,0 +1,1000 @@+{-# LANGUAGE CPP, RecordWildCards #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation:+--+-- The types   LambdaFormInfo+--             ClosureInfo+--+-- Nothing monadic in here!+--+-----------------------------------------------------------------------------++module StgCmmClosure (+        DynTag,  tagForCon, isSmallFamily,++        idPrimRep, isVoidRep, isGcPtrRep, addIdReps, addArgReps,+        argPrimRep,++        NonVoid(..), fromNonVoid, nonVoidIds, nonVoidStgArgs,+        assertNonVoidIds, assertNonVoidStgArgs,++        -- * LambdaFormInfo+        LambdaFormInfo,         -- Abstract+        StandardFormInfo,        -- ...ditto...+        mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,+        mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,+        mkLFStringLit,+        lfDynTag,+        isLFThunk, isLFReEntrant, lfUpdatable,++        -- * Used by other modules+        CgLoc(..), SelfLoopInfo, CallMethod(..),+        nodeMustPointToIt, isKnownFun, funTag, tagForArity, getCallMethod,++        -- * ClosureInfo+        ClosureInfo,+        mkClosureInfo,+        mkCmmInfo,++        -- ** Inspection+        closureLFInfo, closureName,++        -- ** Labels+        -- These just need the info table label+        closureInfoLabel, staticClosureLabel,+        closureSlowEntryLabel, closureLocalEntryLabel,++        -- ** Predicates+        -- These are really just functions on LambdaFormInfo+        closureUpdReqd, closureSingleEntry,+        closureReEntrant, closureFunInfo,+        isToplevClosure,++        blackHoleOnEntry,  -- Needs LambdaFormInfo and SMRep+        isStaticClosure,   -- Needs SMPre++        -- * InfoTables+        mkDataConInfoTable,+        cafBlackHoleInfoTable,+        indStaticInfoTable,+        staticClosureNeedsLink,+    ) where++#include "../includes/MachDeps.h"++#include "HsVersions.h"++import GhcPrelude++import StgSyn+import SMRep+import Cmm+import PprCmmExpr()++import CostCentre+import BlockId+import CLabel+import Id+import IdInfo+import DataCon+import Name+import Type+import TyCoRep+import TcType+import TyCon+import RepType+import BasicTypes+import Outputable+import DynFlags+import Util++import Data.Coerce (coerce)+import qualified Data.ByteString.Char8 as BS8++-----------------------------------------------------------------------------+--                Data types and synonyms+-----------------------------------------------------------------------------++-- These data types are mostly used by other modules, especially StgCmmMonad,+-- but we define them here because some functions in this module need to+-- have access to them as well++data CgLoc+  = CmmLoc CmmExpr      -- A stable CmmExpr; that is, one not mentioning+                        -- Hp, so that it remains valid across calls++  | LneLoc BlockId [LocalReg]             -- A join point+        -- A join point (= let-no-escape) should only+        -- be tail-called, and in a saturated way.+        -- To tail-call it, assign to these locals,+        -- and branch to the block id++instance Outputable CgLoc where+  ppr (CmmLoc e)    = text "cmm" <+> ppr e+  ppr (LneLoc b rs) = text "lne" <+> ppr b <+> ppr rs++type SelfLoopInfo = (Id, BlockId, [LocalReg])++-- used by ticky profiling+isKnownFun :: LambdaFormInfo -> Bool+isKnownFun LFReEntrant{} = True+isKnownFun LFLetNoEscape = True+isKnownFun _             = False+++-------------------------------------+--        Non-void types+-------------------------------------+-- We frequently need the invariant that an Id or a an argument+-- is of a non-void type. This type is a witness to the invariant.++newtype NonVoid a = NonVoid a+  deriving (Eq, Show)++fromNonVoid :: NonVoid a -> a+fromNonVoid (NonVoid a) = a++instance (Outputable a) => Outputable (NonVoid a) where+  ppr (NonVoid a) = ppr a++nonVoidIds :: [Id] -> [NonVoid Id]+nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidTy (idType id))]++-- | Used in places where some invariant ensures that all these Ids are+-- non-void; e.g. constructor field binders in case expressions.+-- See Note [Post-unarisation invariants] in UnariseStg.+assertNonVoidIds :: [Id] -> [NonVoid Id]+assertNonVoidIds ids = ASSERT(not (any (isVoidTy . idType) ids))+                       coerce ids++nonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]+nonVoidStgArgs args = [NonVoid arg | arg <- args, not (isVoidTy (stgArgType arg))]++-- | Used in places where some invariant ensures that all these arguments are+-- non-void; e.g. constructor arguments.+-- See Note [Post-unarisation invariants] in UnariseStg.+assertNonVoidStgArgs :: [StgArg] -> [NonVoid StgArg]+assertNonVoidStgArgs args = ASSERT(not (any (isVoidTy . stgArgType) args))+                            coerce args+++-----------------------------------------------------------------------------+--                Representations+-----------------------------------------------------------------------------++-- Why are these here?++idPrimRep :: Id -> PrimRep+idPrimRep id = typePrimRep1 (idType id)+    -- NB: typePrimRep1 fails on unboxed tuples,+    --     but by StgCmm no Ids have unboxed tuple type++addIdReps :: [NonVoid Id] -> [NonVoid (PrimRep, Id)]+addIdReps = map (\id -> let id' = fromNonVoid id+                         in NonVoid (idPrimRep id', id'))++addArgReps :: [NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]+addArgReps = map (\arg -> let arg' = fromNonVoid arg+                           in NonVoid (argPrimRep arg', arg'))++argPrimRep :: StgArg -> PrimRep+argPrimRep arg = typePrimRep1 (stgArgType arg)+++-----------------------------------------------------------------------------+--                LambdaFormInfo+-----------------------------------------------------------------------------++-- Information about an identifier, from the code generator's point of+-- view.  Every identifier is bound to a LambdaFormInfo in the+-- environment, which gives the code generator enough info to be able to+-- tail call or return that identifier.++data LambdaFormInfo+  = LFReEntrant         -- Reentrant closure (a function)+        TopLevelFlag    -- True if top level+        OneShotInfo+        !RepArity       -- Arity. Invariant: always > 0+        !Bool           -- True <=> no fvs+        ArgDescr        -- Argument descriptor (should really be in ClosureInfo)++  | LFThunk             -- Thunk (zero arity)+        TopLevelFlag+        !Bool           -- True <=> no free vars+        !Bool           -- True <=> updatable (i.e., *not* single-entry)+        StandardFormInfo+        !Bool           -- True <=> *might* be a function type++  | LFCon               -- A saturated constructor application+        DataCon         -- The constructor++  | LFUnknown           -- Used for function arguments and imported things.+                        -- We know nothing about this closure.+                        -- Treat like updatable "LFThunk"...+                        -- Imported things which we *do* know something about use+                        -- one of the other LF constructors (eg LFReEntrant for+                        -- known functions)+        !Bool           -- True <=> *might* be a function type+                        --      The False case is good when we want to enter it,+                        --        because then we know the entry code will do+                        --        For a function, the entry code is the fast entry point++  | LFUnlifted          -- A value of unboxed type;+                        -- always a value, needs evaluation++  | LFLetNoEscape       -- See LetNoEscape module for precise description+++-------------------------+-- StandardFormInfo tells whether this thunk has one of+-- a small number of standard forms++data StandardFormInfo+  = NonStandardThunk+        -- The usual case: not of the standard forms++  | SelectorThunk+        -- A SelectorThunk is of form+        --      case x of+        --           con a1,..,an -> ak+        -- and the constructor is from a single-constr type.+       WordOff          -- 0-origin offset of ak within the "goods" of+                        -- constructor (Recall that the a1,...,an may be laid+                        -- out in the heap in a non-obvious order.)++  | ApThunk+        -- An ApThunk is of form+        --        x1 ... xn+        -- The code for the thunk just pushes x2..xn on the stack and enters x1.+        -- There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled+        -- in the RTS to save space.+        RepArity                -- Arity, n+++------------------------------------------------------+--                Building LambdaFormInfo+------------------------------------------------------++mkLFArgument :: Id -> LambdaFormInfo+mkLFArgument id+  | isUnliftedType ty      = LFUnlifted+  | might_be_a_function ty = LFUnknown True+  | otherwise              = LFUnknown False+  where+    ty = idType id++-------------+mkLFLetNoEscape :: LambdaFormInfo+mkLFLetNoEscape = LFLetNoEscape++-------------+mkLFReEntrant :: TopLevelFlag    -- True of top level+              -> [Id]            -- Free vars+              -> [Id]            -- Args+              -> ArgDescr        -- Argument descriptor+              -> LambdaFormInfo++mkLFReEntrant _ _ [] _+  = pprPanic "mkLFReEntrant" empty+mkLFReEntrant top fvs args arg_descr+  = LFReEntrant top os_info (length args) (null fvs) arg_descr+  where os_info = idOneShotInfo (head args)++-------------+mkLFThunk :: Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo+mkLFThunk thunk_ty top fvs upd_flag+  = ASSERT( not (isUpdatable upd_flag) || not (isUnliftedType thunk_ty) )+    LFThunk top (null fvs)+            (isUpdatable upd_flag)+            NonStandardThunk+            (might_be_a_function thunk_ty)++--------------+might_be_a_function :: Type -> Bool+-- Return False only if we are *sure* it's a data type+-- Look through newtypes etc as much as poss+might_be_a_function ty+  | [LiftedRep] <- typePrimRep ty+  , Just tc <- tyConAppTyCon_maybe (unwrapType ty)+  , isDataTyCon tc+  = False+  | otherwise+  = True++-------------+mkConLFInfo :: DataCon -> LambdaFormInfo+mkConLFInfo con = LFCon con++-------------+mkSelectorLFInfo :: Id -> Int -> Bool -> LambdaFormInfo+mkSelectorLFInfo id offset updatable+  = LFThunk NotTopLevel False updatable (SelectorThunk offset)+        (might_be_a_function (idType id))++-------------+mkApLFInfo :: Id -> UpdateFlag -> Arity -> LambdaFormInfo+mkApLFInfo id upd_flag arity+  = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)+        (might_be_a_function (idType id))++-------------+mkLFImported :: Id -> LambdaFormInfo+mkLFImported id+  | Just con <- isDataConWorkId_maybe id+  , isNullaryRepDataCon con+  = LFCon con   -- An imported nullary constructor+                -- We assume that the constructor is evaluated so that+                -- the id really does point directly to the constructor++  | arity > 0+  = LFReEntrant TopLevel noOneShotInfo arity True (panic "arg_descr")++  | otherwise+  = mkLFArgument id -- Not sure of exact arity+  where+    arity = idFunRepArity id++-------------+mkLFStringLit :: LambdaFormInfo+mkLFStringLit = LFUnlifted++-----------------------------------------------------+--                Dynamic pointer tagging+-----------------------------------------------------++type DynTag = Int       -- The tag on a *pointer*+                        -- (from the dynamic-tagging paper)++-- Note [Data constructor dynamic tags]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- The family size of a data type (the number of constructors+-- or the arity of a function) can be either:+--    * small, if the family size < 2**tag_bits+--    * big, otherwise.+--+-- Small families can have the constructor tag in the tag bits.+-- Big families only use the tag value 1 to represent evaluatedness.+-- We don't have very many tag bits: for example, we have 2 bits on+-- x86-32 and 3 bits on x86-64.++isSmallFamily :: DynFlags -> Int -> Bool+isSmallFamily dflags fam_size = fam_size <= mAX_PTR_TAG dflags++tagForCon :: DynFlags -> DataCon -> DynTag+tagForCon dflags con+  | isSmallFamily dflags fam_size = con_tag+  | otherwise                     = 1+  where+    con_tag  = dataConTag con -- NB: 1-indexed+    fam_size = tyConFamilySize (dataConTyCon con)++tagForArity :: DynFlags -> RepArity -> DynTag+tagForArity dflags arity+ | isSmallFamily dflags arity = arity+ | otherwise                  = 0++lfDynTag :: DynFlags -> LambdaFormInfo -> DynTag+-- Return the tag in the low order bits of a variable bound+-- to this LambdaForm+lfDynTag dflags (LFCon con)                 = tagForCon dflags con+lfDynTag dflags (LFReEntrant _ _ arity _ _) = tagForArity dflags arity+lfDynTag _      _other                      = 0+++-----------------------------------------------------------------------------+--                Observing LambdaFormInfo+-----------------------------------------------------------------------------++------------+isLFThunk :: LambdaFormInfo -> Bool+isLFThunk (LFThunk {})  = True+isLFThunk _ = False++isLFReEntrant :: LambdaFormInfo -> Bool+isLFReEntrant (LFReEntrant {}) = True+isLFReEntrant _                = False++-----------------------------------------------------------------------------+--                Choosing SM reps+-----------------------------------------------------------------------------++lfClosureType :: LambdaFormInfo -> ClosureTypeInfo+lfClosureType (LFReEntrant _ _ arity _ argd) = Fun arity argd+lfClosureType (LFCon con)                    = Constr (dataConTagZ con)+                                                      (dataConIdentity con)+lfClosureType (LFThunk _ _ _ is_sel _)       = thunkClosureType is_sel+lfClosureType _                              = panic "lfClosureType"++thunkClosureType :: StandardFormInfo -> ClosureTypeInfo+thunkClosureType (SelectorThunk off) = ThunkSelector off+thunkClosureType _                   = Thunk++-- We *do* get non-updatable top-level thunks sometimes.  eg. f = g+-- gets compiled to a jump to g (if g has non-zero arity), instead of+-- messing around with update frames and PAPs.  We set the closure type+-- to FUN_STATIC in this case.++-----------------------------------------------------------------------------+--                nodeMustPointToIt+-----------------------------------------------------------------------------++nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool+-- If nodeMustPointToIt is true, then the entry convention for+-- this closure has R1 (the "Node" register) pointing to the+-- closure itself --- the "self" argument++nodeMustPointToIt _ (LFReEntrant top _ _ no_fvs _)+  =  not no_fvs          -- Certainly if it has fvs we need to point to it+  || isNotTopLevel top   -- See Note [GC recovery]+        -- For lex_profiling we also access the cost centre for a+        -- non-inherited (i.e. non-top-level) function.+        -- The isNotTopLevel test above ensures this is ok.++nodeMustPointToIt dflags (LFThunk top no_fvs updatable NonStandardThunk _)+  =  not no_fvs            -- Self parameter+  || isNotTopLevel top     -- Note [GC recovery]+  || updatable             -- Need to push update frame+  || gopt Opt_SccProfilingOn dflags+          -- For the non-updatable (single-entry case):+          --+          -- True if has fvs (in which case we need access to them, and we+          --                    should black-hole it)+          -- or profiling (in which case we need to recover the cost centre+          --                 from inside it)  ToDo: do we need this even for+          --                                    top-level thunks? If not,+          --                                    isNotTopLevel subsumes this++nodeMustPointToIt _ (LFThunk {})        -- Node must point to a standard-form thunk+  = True++nodeMustPointToIt _ (LFCon _) = True++        -- Strictly speaking, the above two don't need Node to point+        -- to it if the arity = 0.  But this is a *really* unlikely+        -- situation.  If we know it's nil (say) and we are entering+        -- it. Eg: let x = [] in x then we will certainly have inlined+        -- x, since nil is a simple atom.  So we gain little by not+        -- having Node point to known zero-arity things.  On the other+        -- hand, we do lose something; Patrick's code for figuring out+        -- when something has been updated but not entered relies on+        -- having Node point to the result of an update.  SLPJ+        -- 27/11/92.++nodeMustPointToIt _ (LFUnknown _)   = True+nodeMustPointToIt _ LFUnlifted      = False+nodeMustPointToIt _ LFLetNoEscape   = False++{- Note [GC recovery]+~~~~~~~~~~~~~~~~~~~~~+If we a have a local let-binding (function or thunk)+   let f = <body> in ...+AND <body> allocates, then the heap-overflow check needs to know how+to re-start the evaluation.  It uses the "self" pointer to do this.+So even if there are no free variables in <body>, we still make+nodeMustPointToIt be True for non-top-level bindings.++Why do any such bindings exist?  After all, let-floating should have+floated them out.  Well, a clever optimiser might leave one there to+avoid a space leak, deliberately recomputing a thunk.  Also (and this+really does happen occasionally) let-floating may make a function f smaller+so it can be inlined, so now (f True) may generate a local no-fv closure.+This actually happened during bootstrapping GHC itself, with f=mkRdrFunBind+in TcGenDeriv.) -}++-----------------------------------------------------------------------------+--                getCallMethod+-----------------------------------------------------------------------------++{- The entry conventions depend on the type of closure being entered,+whether or not it has free variables, and whether we're running+sequentially or in parallel.++Closure                           Node   Argument   Enter+Characteristics              Par   Req'd  Passing    Via+---------------------------------------------------------------------------+Unknown                     & no  & yes & stack     & node+Known fun (>1 arg), no fvs  & no  & no  & registers & fast entry (enough args)+                                                    & slow entry (otherwise)+Known fun (>1 arg), fvs     & no  & yes & registers & fast entry (enough args)+0 arg, no fvs \r,\s         & no  & no  & n/a       & direct entry+0 arg, no fvs \u            & no  & yes & n/a       & node+0 arg, fvs \r,\s,selector   & no  & yes & n/a       & node+0 arg, fvs \r,\s            & no  & yes & n/a       & direct entry+0 arg, fvs \u               & no  & yes & n/a       & node+Unknown                     & yes & yes & stack     & node+Known fun (>1 arg), no fvs  & yes & no  & registers & fast entry (enough args)+                                                    & slow entry (otherwise)+Known fun (>1 arg), fvs     & yes & yes & registers & node+0 arg, fvs \r,\s,selector   & yes & yes & n/a       & node+0 arg, no fvs \r,\s         & yes & no  & n/a       & direct entry+0 arg, no fvs \u            & yes & yes & n/a       & node+0 arg, fvs \r,\s            & yes & yes & n/a       & node+0 arg, fvs \u               & yes & yes & n/a       & node++When black-holing, single-entry closures could also be entered via node+(rather than directly) to catch double-entry. -}++data CallMethod+  = EnterIt             -- No args, not a function++  | JumpToIt BlockId [LocalReg] -- A join point or a header of a local loop++  | ReturnIt            -- It's a value (function, unboxed value,+                        -- or constructor), so just return it.++  | SlowCall                -- Unknown fun, or known fun with+                        -- too few args.++  | DirectEntry         -- Jump directly, with args in regs+        CLabel          --   The code label+        RepArity        --   Its arity++getCallMethod :: DynFlags+              -> Name           -- Function being applied+              -> Id             -- Function Id used to chech if it can refer to+                                -- CAF's and whether the function is tail-calling+                                -- itself+              -> LambdaFormInfo -- Its info+              -> RepArity       -- Number of available arguments+              -> RepArity       -- Number of them being void arguments+              -> CgLoc          -- Passed in from cgIdApp so that we can+                                -- handle let-no-escape bindings and self-recursive+                                -- tail calls using the same data constructor,+                                -- JumpToIt. This saves us one case branch in+                                -- cgIdApp+              -> Maybe SelfLoopInfo -- can we perform a self-recursive tail call?+              -> CallMethod++getCallMethod dflags _ id _ n_args v_args _cg_loc+              (Just (self_loop_id, block_id, args))+  | gopt Opt_Loopification dflags+  , id == self_loop_id+  , args `lengthIs` (n_args - v_args)+  -- If these patterns match then we know that:+  --   * loopification optimisation is turned on+  --   * function is performing a self-recursive call in a tail position+  --   * number of non-void parameters of the function matches functions arity.+  -- See Note [Self-recursive tail calls] and Note [Void arguments in+  -- self-recursive tail calls] in StgCmmExpr for more details+  = JumpToIt block_id args++getCallMethod dflags name id (LFReEntrant _ _ arity _ _) n_args _v_args _cg_loc+              _self_loop_info+  | n_args == 0 -- No args at all+  && not (gopt Opt_SccProfilingOn dflags)+     -- See Note [Evaluating functions with profiling] in rts/Apply.cmm+  = ASSERT( arity /= 0 ) ReturnIt+  | n_args < arity = SlowCall        -- Not enough args+  | otherwise      = DirectEntry (enterIdLabel dflags name (idCafInfo id)) arity++getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info+  = ASSERT( n_args == 0 ) ReturnIt++getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info+  = ASSERT( n_args == 0 ) ReturnIt+    -- n_args=0 because it'd be ill-typed to apply a saturated+    --          constructor application to anything++getCallMethod dflags name id (LFThunk _ _ updatable std_form_info is_fun)+              n_args _v_args _cg_loc _self_loop_info+  | is_fun      -- it *might* be a function, so we must "call" it (which is always safe)+  = SlowCall    -- We cannot just enter it [in eval/apply, the entry code+                -- is the fast-entry code]++  -- Since is_fun is False, we are *definitely* looking at a data value+  | updatable || gopt Opt_Ticky dflags -- to catch double entry+      {- OLD: || opt_SMP+         I decided to remove this, because in SMP mode it doesn't matter+         if we enter the same thunk multiple times, so the optimisation+         of jumping directly to the entry code is still valid.  --SDM+        -}+  = EnterIt++  -- even a non-updatable selector thunk can be updated by the garbage+  -- collector, so we must enter it. (#8817)+  | SelectorThunk{} <- std_form_info+  = EnterIt++    -- We used to have ASSERT( n_args == 0 ), but actually it is+    -- possible for the optimiser to generate+    --   let bot :: Int = error Int "urk"+    --   in (bot `cast` unsafeCoerce Int (Int -> Int)) 3+    -- This happens as a result of the case-of-error transformation+    -- So the right thing to do is just to enter the thing++  | otherwise        -- Jump direct to code for single-entry thunks+  = ASSERT( n_args == 0 )+    DirectEntry (thunkEntryLabel dflags name (idCafInfo id) std_form_info+                updatable) 0++getCallMethod _ _name _ (LFUnknown True) _n_arg _v_args _cg_locs _self_loop_info+  = SlowCall -- might be a function++getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info+  = ASSERT2( n_args == 0, ppr name <+> ppr n_args )+    EnterIt -- Not a function++getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs)+              _self_loop_info+  = JumpToIt blk_id lne_regs++getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"++-----------------------------------------------------------------------------+--              Data types for closure information+-----------------------------------------------------------------------------+++{- ClosureInfo: information about a binding++   We make a ClosureInfo for each let binding (both top level and not),+   but not bindings for data constructors: for those we build a CmmInfoTable+   directly (see mkDataConInfoTable).++   To a first approximation:+       ClosureInfo = (LambdaFormInfo, CmmInfoTable)++   A ClosureInfo has enough information+     a) to construct the info table itself, and build other things+        related to the binding (e.g. slow entry points for a function)+     b) to allocate a closure containing that info pointer (i.e.+           it knows the info table label)+-}++data ClosureInfo+  = ClosureInfo {+        closureName :: !Name,           -- The thing bound to this closure+           -- we don't really need this field: it's only used in generating+           -- code for ticky and profiling, and we could pass the information+           -- around separately, but it doesn't do much harm to keep it here.++        closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon+          -- this tells us about what the closure contains: it's right-hand-side.++          -- the rest is just an unpacked CmmInfoTable.+        closureInfoLabel :: !CLabel,+        closureSMRep     :: !SMRep,          -- representation used by storage mgr+        closureProf      :: !ProfilingInfo+    }++-- | Convert from 'ClosureInfo' to 'CmmInfoTable'.+mkCmmInfo :: ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable+mkCmmInfo ClosureInfo {..} id ccs+  = CmmInfoTable { cit_lbl  = closureInfoLabel+                 , cit_rep  = closureSMRep+                 , cit_prof = closureProf+                 , cit_srt  = Nothing+                 , cit_clo  = if isStaticRep closureSMRep+                                then Just (id,ccs)+                                else Nothing }++--------------------------------------+--        Building ClosureInfos+--------------------------------------++mkClosureInfo :: DynFlags+              -> Bool                -- Is static+              -> Id+              -> LambdaFormInfo+              -> Int -> Int        -- Total and pointer words+              -> String         -- String descriptor+              -> ClosureInfo+mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr+  = ClosureInfo { closureName      = name+                , closureLFInfo    = lf_info+                , closureInfoLabel = info_lbl   -- These three fields are+                , closureSMRep     = sm_rep     -- (almost) an info table+                , closureProf      = prof }     -- (we don't have an SRT yet)+  where+    name       = idName id+    sm_rep     = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)+    prof       = mkProfilingInfo dflags id val_descr+    nonptr_wds = tot_wds - ptr_wds++    info_lbl = mkClosureInfoTableLabel id lf_info++--------------------------------------+--   Other functions over ClosureInfo+--------------------------------------++-- Eager blackholing is normally disabled, but can be turned on with+-- -feager-blackholing.  When it is on, we replace the info pointer of+-- the thunk with stg_EAGER_BLACKHOLE_info on entry.++-- If we wanted to do eager blackholing with slop filling,+-- we'd need to do it at the *end* of a basic block, otherwise+-- we overwrite the free variables in the thunk that we still+-- need.  We have a patch for this from Andy Cheadle, but not+-- incorporated yet. --SDM [6/2004]+--+-- Previously, eager blackholing was enabled when ticky-ticky+-- was on. But it didn't work, and it wasn't strictly necessary+-- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING+-- is unconditionally disabled. -- krc 1/2007+--+-- Static closures are never themselves black-holed.++blackHoleOnEntry :: ClosureInfo -> Bool+blackHoleOnEntry cl_info+  | isStaticRep (closureSMRep cl_info)+  = False        -- Never black-hole a static closure++  | otherwise+  = case closureLFInfo cl_info of+      LFReEntrant {}            -> False+      LFLetNoEscape             -> False+      LFThunk _ _no_fvs upd _ _ -> upd   -- See Note [Black-holing non-updatable thunks]+      _other -> panic "blackHoleOnEntry"++{- Note [Black-holing non-updatable thunks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must not black-hole non-updatable (single-entry) thunks otherwise+we run into issues like #10414. Specifically:++  * There is no reason to black-hole a non-updatable thunk: it should+    not be competed for by multiple threads++  * It could, conceivably, cause a space leak if we don't black-hole+    it, if there was a live but never-followed pointer pointing to it.+    Let's hope that doesn't happen.++  * It is dangerous to black-hole a non-updatable thunk because+     - is not updated (of course)+     - hence, if it is black-holed and another thread tries to evaluate+       it, that thread will block forever+    This actually happened in #10414.  So we do not black-hole+    non-updatable thunks.++  * How could two threads evaluate the same non-updatable (single-entry)+    thunk?  See Reid Barton's example below.++  * Only eager blackholing could possibly black-hole a non-updatable+    thunk, because lazy black-holing only affects thunks with an+    update frame on the stack.++Here is and example due to Reid Barton (#10414):+    x = \u []  concat [[1], []]+with the following definitions,++    concat x = case x of+        []       -> []+        (:) x xs -> (++) x (concat xs)++    (++) xs ys = case xs of+        []         -> ys+        (:) x rest -> (:) x ((++) rest ys)++Where we use the syntax @\u []@ to denote an updatable thunk and @\s []@ to+denote a single-entry (i.e. non-updatable) thunk. After a thread evaluates @x@+to WHNF and calls @(++)@ the heap will contain the following thunks,++    x = 1 : y+    y = \u []  (++) [] z+    z = \s []  concat []++Now that the stage is set, consider the follow evaluations by two racing threads+A and B,++  1. Both threads enter @y@ before either is able to replace it with an+     indirection++  2. Thread A does the case analysis in @(++)@ and consequently enters @z@,+     replacing it with a black-hole++  3. At some later point thread B does the same case analysis and also attempts+     to enter @z@. However, it finds that it has been replaced with a black-hole+     so it blocks.++  4. Thread A eventually finishes evaluating @z@ (to @[]@) and updates @y@+     accordingly. It does *not* update @z@, however, as it is single-entry. This+     leaves Thread B blocked forever on a black-hole which will never be+     updated.++To avoid this sort of condition we never black-hole non-updatable thunks.+-}++isStaticClosure :: ClosureInfo -> Bool+isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)++closureUpdReqd :: ClosureInfo -> Bool+closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info++lfUpdatable :: LambdaFormInfo -> Bool+lfUpdatable (LFThunk _ _ upd _ _)  = upd+lfUpdatable _ = False++closureSingleEntry :: ClosureInfo -> Bool+closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd+closureSingleEntry (ClosureInfo { closureLFInfo = LFReEntrant _ OneShotLam _ _ _}) = True+closureSingleEntry _ = False++closureReEntrant :: ClosureInfo -> Bool+closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant {} }) = True+closureReEntrant _ = False++closureFunInfo :: ClosureInfo -> Maybe (RepArity, ArgDescr)+closureFunInfo (ClosureInfo { closureLFInfo = lf_info }) = lfFunInfo lf_info++lfFunInfo :: LambdaFormInfo ->  Maybe (RepArity, ArgDescr)+lfFunInfo (LFReEntrant _ _ arity _ arg_desc)  = Just (arity, arg_desc)+lfFunInfo _                                   = Nothing++funTag :: DynFlags -> ClosureInfo -> DynTag+funTag dflags (ClosureInfo { closureLFInfo = lf_info })+    = lfDynTag dflags lf_info++isToplevClosure :: ClosureInfo -> Bool+isToplevClosure (ClosureInfo { closureLFInfo = lf_info })+  = case lf_info of+      LFReEntrant TopLevel _ _ _ _ -> True+      LFThunk TopLevel _ _ _ _     -> True+      _other                       -> False++--------------------------------------+--   Label generation+--------------------------------------++staticClosureLabel :: ClosureInfo -> CLabel+staticClosureLabel = toClosureLbl .  closureInfoLabel++closureSlowEntryLabel :: ClosureInfo -> CLabel+closureSlowEntryLabel = toSlowEntryLbl . closureInfoLabel++closureLocalEntryLabel :: DynFlags -> ClosureInfo -> CLabel+closureLocalEntryLabel dflags+  | tablesNextToCode dflags = toInfoLbl  . closureInfoLabel+  | otherwise               = toEntryLbl . closureInfoLabel++mkClosureInfoTableLabel :: Id -> LambdaFormInfo -> CLabel+mkClosureInfoTableLabel id lf_info+  = case lf_info of+        LFThunk _ _ upd_flag (SelectorThunk offset) _+                      -> mkSelectorInfoLabel upd_flag offset++        LFThunk _ _ upd_flag (ApThunk arity) _+                      -> mkApInfoTableLabel upd_flag arity++        LFThunk{}     -> std_mk_lbl name cafs+        LFReEntrant{} -> std_mk_lbl name cafs+        _other        -> panic "closureInfoTableLabel"++  where+    name = idName id++    std_mk_lbl | is_local  = mkLocalInfoTableLabel+               | otherwise = mkInfoTableLabel++    cafs     = idCafInfo id+    is_local = isDataConWorkId id+       -- Make the _info pointer for the implicit datacon worker+       -- binding local. The reason we can do this is that importing+       -- code always either uses the _closure or _con_info. By the+       -- invariants in CorePrep anything else gets eta expanded.+++thunkEntryLabel :: DynFlags -> Name -> CafInfo -> StandardFormInfo -> Bool -> CLabel+-- thunkEntryLabel is a local help function, not exported.  It's used from+-- getCallMethod.+thunkEntryLabel dflags _thunk_id _ (ApThunk arity) upd_flag+  = enterApLabel dflags upd_flag arity+thunkEntryLabel dflags _thunk_id _ (SelectorThunk offset) upd_flag+  = enterSelectorLabel dflags upd_flag offset+thunkEntryLabel dflags thunk_id c _ _+  = enterIdLabel dflags thunk_id c++enterApLabel :: DynFlags -> Bool -> Arity -> CLabel+enterApLabel dflags is_updatable arity+  | tablesNextToCode dflags = mkApInfoTableLabel is_updatable arity+  | otherwise               = mkApEntryLabel is_updatable arity++enterSelectorLabel :: DynFlags -> Bool -> WordOff -> CLabel+enterSelectorLabel dflags upd_flag offset+  | tablesNextToCode dflags = mkSelectorInfoLabel upd_flag offset+  | otherwise               = mkSelectorEntryLabel upd_flag offset++enterIdLabel :: DynFlags -> Name -> CafInfo -> CLabel+enterIdLabel dflags id c+  | tablesNextToCode dflags = mkInfoTableLabel id c+  | otherwise               = mkEntryLabel id c+++--------------------------------------+--   Profiling+--------------------------------------++-- Profiling requires two pieces of information to be determined for+-- each closure's info table --- description and type.++-- The description is stored directly in the @CClosureInfoTable@ when the+-- info table is built.++-- The type is determined from the type information stored with the @Id@+-- in the closure info using @closureTypeDescr@.++mkProfilingInfo :: DynFlags -> Id -> String -> ProfilingInfo+mkProfilingInfo dflags id val_descr+  | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo+  | otherwise = ProfilingInfo ty_descr_w8 (BS8.pack val_descr)+  where+    ty_descr_w8  = BS8.pack (getTyDescription (idType id))++getTyDescription :: Type -> String+getTyDescription ty+  = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->+    case tau_ty of+      TyVarTy _              -> "*"+      AppTy fun _            -> getTyDescription fun+      TyConApp tycon _       -> getOccString tycon+      FunTy {}              -> '-' : fun_result tau_ty+      ForAllTy _  ty         -> getTyDescription ty+      LitTy n                -> getTyLitDescription n+      CastTy ty _            -> getTyDescription ty+      CoercionTy co          -> pprPanic "getTyDescription" (ppr co)+    }+  where+    fun_result (FunTy { ft_res = res }) = '>' : fun_result res+    fun_result other                    = getTyDescription other++getTyLitDescription :: TyLit -> String+getTyLitDescription l =+  case l of+    NumTyLit n -> show n+    StrTyLit n -> show n++--------------------------------------+--   CmmInfoTable-related things+--------------------------------------++mkDataConInfoTable :: DynFlags -> DataCon -> Bool -> Int -> Int -> CmmInfoTable+mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds+ = CmmInfoTable { cit_lbl  = info_lbl+                , cit_rep  = sm_rep+                , cit_prof = prof+                , cit_srt  = Nothing+                , cit_clo  = Nothing }+ where+   name = dataConName data_con+   info_lbl = mkConInfoTableLabel name NoCafRefs+   sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type+   cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)+                  -- We keep the *zero-indexed* tag in the srt_len field+                  -- of the info table of a data constructor.++   prof | not (gopt Opt_SccProfilingOn dflags) = NoProfilingInfo+        | otherwise                            = ProfilingInfo ty_descr val_descr++   ty_descr  = BS8.pack $ occNameString $ getOccName $ dataConTyCon data_con+   val_descr = BS8.pack $ occNameString $ getOccName data_con++-- We need a black-hole closure info to pass to @allocDynClosure@ when we+-- want to allocate the black hole on entry to a CAF.++cafBlackHoleInfoTable :: CmmInfoTable+cafBlackHoleInfoTable+  = CmmInfoTable { cit_lbl  = mkCAFBlackHoleInfoTableLabel+                 , cit_rep  = blackHoleRep+                 , cit_prof = NoProfilingInfo+                 , cit_srt  = Nothing+                 , cit_clo  = Nothing }++indStaticInfoTable :: CmmInfoTable+indStaticInfoTable+  = CmmInfoTable { cit_lbl  = mkIndStaticInfoLabel+                 , cit_rep  = indStaticRep+                 , cit_prof = NoProfilingInfo+                 , cit_srt  = Nothing+                 , cit_clo  = Nothing }++staticClosureNeedsLink :: Bool -> CmmInfoTable -> Bool+-- A static closure needs a link field to aid the GC when traversing+-- the static closure graph.  But it only needs such a field if either+--        a) it has an SRT+--        b) it's a constructor with one or more pointer fields+-- In case (b), the constructor's fields themselves play the role+-- of the SRT.+staticClosureNeedsLink has_srt CmmInfoTable{ cit_rep = smrep }+  | isConRep smrep         = not (isStaticNoCafCon smrep)+  | otherwise              = has_srt
+ compiler/codeGen/StgCmmCon.hs view
@@ -0,0 +1,285 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Stg to C--: code generation for constructors+--+-- This module provides the support code for StgCmm to deal with with+-- constructors on the RHSs of let(rec)s.+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmCon (+        cgTopRhsCon, buildDynCon, bindConArgs+    ) where++#include "HsVersions.h"++import GhcPrelude++import StgSyn+import CoreSyn  ( AltCon(..) )++import StgCmmMonad+import StgCmmEnv+import StgCmmHeap+import StgCmmLayout+import StgCmmUtils+import StgCmmClosure++import CmmExpr+import CmmUtils+import CLabel+import MkGraph+import SMRep+import CostCentre+import Module+import DataCon+import DynFlags+import FastString+import Id+import RepType (countConRepArgs)+import Literal+import PrelInfo+import Outputable+import Platform+import Util+import MonadUtils (mapMaybeM)++import Control.Monad+import Data.Char++++---------------------------------------------------------------+--      Top-level constructors+---------------------------------------------------------------++cgTopRhsCon :: DynFlags+            -> Id               -- Name of thing bound to this RHS+            -> DataCon          -- Id+            -> [NonVoid StgArg] -- Args+            -> (CgIdInfo, FCode ())+cgTopRhsCon dflags id con args =+    let id_info = litIdInfo dflags id (mkConLFInfo con) (CmmLabel closure_label)+    in (id_info, gen_code)+  where+   name          = idName id+   caffy         = idCafInfo id -- any stgArgHasCafRefs args+   closure_label = mkClosureLabel name caffy++   gen_code =+     do { this_mod <- getModuleName+        ; when (platformOS (targetPlatform dflags) == OSMinGW32) $+              -- Windows DLLs have a problem with static cross-DLL refs.+              MASSERT( not (isDllConApp dflags this_mod con (map fromNonVoid args)) )+        ; ASSERT( args `lengthIs` countConRepArgs con ) return ()++        -- LAY IT OUT+        ; let+            (tot_wds, --  #ptr_wds + #nonptr_wds+             ptr_wds, --  #ptr_wds+             nv_args_w_offsets) =+                 mkVirtHeapOffsetsWithPadding dflags StdHeader (addArgReps args)++            mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))+            mk_payload (FieldOff arg _) = do+                amode <- getArgAmode arg+                case amode of+                  CmmLit lit -> return lit+                  _          -> panic "StgCmmCon.cgTopRhsCon"++            nonptr_wds = tot_wds - ptr_wds++             -- we're not really going to emit an info table, so having+             -- to make a CmmInfoTable is a bit overkill, but mkStaticClosureFields+             -- needs to poke around inside it.+            info_tbl = mkDataConInfoTable dflags con True ptr_wds nonptr_wds+++        ; payload <- mapM mk_payload nv_args_w_offsets+                -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs+                -- NB2: all the amodes should be Lits!+                --      TODO (osa): Why?++        ; let closure_rep = mkStaticClosureFields+                             dflags+                             info_tbl+                             dontCareCCS                -- Because it's static data+                             caffy                      -- Has CAF refs+                             payload++                -- BUILD THE OBJECT+        ; emitDataLits closure_label closure_rep++        ; return () }+++---------------------------------------------------------------+--      Lay out and allocate non-top-level constructors+---------------------------------------------------------------++buildDynCon :: Id                 -- Name of the thing to which this constr will+                                  -- be bound+            -> Bool               -- is it genuinely bound to that name, or just+                                  -- for profiling?+            -> CostCentreStack    -- Where to grab cost centre from;+                                  -- current CCS if currentOrSubsumedCCS+            -> DataCon            -- The data constructor+            -> [NonVoid StgArg]   -- Its args+            -> FCode (CgIdInfo, FCode CmmAGraph)+               -- Return details about how to find it and initialization code+buildDynCon binder actually_bound cc con args+    = do dflags <- getDynFlags+         buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args+++buildDynCon' :: DynFlags+             -> Platform+             -> Id -> Bool+             -> CostCentreStack+             -> DataCon+             -> [NonVoid StgArg]+             -> FCode (CgIdInfo, FCode CmmAGraph)++{- We used to pass a boolean indicating whether all the+args were of size zero, so we could use a static+constructor; but I concluded that it just isn't worth it.+Now I/O uses unboxed tuples there just aren't any constructors+with all size-zero args.++The reason for having a separate argument, rather than looking at+the addr modes of the args is that we may be in a "knot", and+premature looking at the args will cause the compiler to black-hole!+-}+++-------- buildDynCon': Nullary constructors --------------+-- First we deal with the case of zero-arity constructors.  They+-- will probably be unfolded, so we don't expect to see this case much,+-- if at all, but it does no harm, and sets the scene for characters.+--+-- In the case of zero-arity constructors, or, more accurately, those+-- which have exclusively size-zero (VoidRep) args, we generate no code+-- at all.++buildDynCon' dflags _ binder _ _cc con []+  | isNullaryRepDataCon con+  = return (litIdInfo dflags binder (mkConLFInfo con)+                (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),+            return mkNop)++-------- buildDynCon': Charlike and Intlike constructors -----------+{- The following three paragraphs about @Char@-like and @Int@-like+closures are obsolete, but I don't understand the details well enough+to properly word them, sorry. I've changed the treatment of @Char@s to+be analogous to @Int@s: only a subset is preallocated, because @Char@+has now 31 bits. Only literals are handled here. -- Qrczak++Now for @Char@-like closures.  We generate an assignment of the+address of the closure to a temporary.  It would be possible simply to+generate no code, and record the addressing mode in the environment,+but we'd have to be careful if the argument wasn't a constant --- so+for simplicity we just always assign to a temporary.++Last special case: @Int@-like closures.  We only special-case the+situation in which the argument is a literal in the range+@mIN_INTLIKE@..@mAX_INTLILKE@.  NB: for @Char@-like closures we can+work with any old argument, but for @Int@-like ones the argument has+to be a literal.  Reason: @Char@ like closures have an argument type+which is guaranteed in range.++Because of this, we use can safely return an addressing mode.++We don't support this optimisation when compiling into Windows DLLs yet+because they don't support cross package data references well.+-}++buildDynCon' dflags platform binder _ _cc con [arg]+  | maybeIntLikeCon con+  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)+  , NonVoid (StgLitArg (LitNumber LitNumInt val _)) <- arg+  , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!+  , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...+  = do  { let intlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE")+              val_int = fromIntegral val :: Int+              offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSizeW dflags + 1)+                -- INTLIKE closures consist of a header and one word payload+              intlike_amode = cmmLabelOffW dflags intlike_lbl offsetW+        ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode+                 , return mkNop) }++buildDynCon' dflags platform binder _ _cc con [arg]+  | maybeCharLikeCon con+  , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)+  , NonVoid (StgLitArg (LitChar val)) <- arg+  , let val_int = ord val :: Int+  , val_int <= mAX_CHARLIKE dflags+  , val_int >= mIN_CHARLIKE dflags+  = do  { let charlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_CHARLIKE")+              offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSizeW dflags + 1)+                -- CHARLIKE closures consist of a header and one word payload+              charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW+        ; return ( litIdInfo dflags binder (mkConLFInfo con) charlike_amode+                 , return mkNop) }++-------- buildDynCon': the general case -----------+buildDynCon' dflags _ binder actually_bound ccs con args+  = do  { (id_info, reg) <- rhsIdInfo binder lf_info+        ; return (id_info, gen_code reg)+        }+ where+  lf_info = mkConLFInfo con++  gen_code reg+    = do  { let (tot_wds, ptr_wds, args_w_offsets)+                  = mkVirtConstrOffsets dflags (addArgReps args)+                nonptr_wds = tot_wds - ptr_wds+                info_tbl = mkDataConInfoTable dflags con False+                                ptr_wds nonptr_wds+          ; let ticky_name | actually_bound = Just binder+                           | otherwise = Nothing++          ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info+                                          use_cc blame_cc args_w_offsets+          ; return (mkRhsInit dflags reg lf_info hp_plus_n) }+    where+      use_cc      -- cost-centre to stick in the object+        | isCurrentCCS ccs = cccsExpr+        | otherwise        = panic "buildDynCon: non-current CCS not implemented"++      blame_cc = use_cc -- cost-centre on which to blame the alloc (same)+++---------------------------------------------------------------+--      Binding constructor arguments+---------------------------------------------------------------++bindConArgs :: AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]+-- bindConArgs is called from cgAlt of a case+-- (bindConArgs con args) augments the environment with bindings for the+-- binders args, assuming that we have just returned from a 'case' which+-- found a con+bindConArgs (DataAlt con) base args+  = ASSERT(not (isUnboxedTupleCon con))+    do dflags <- getDynFlags+       let (_, _, args_w_offsets) = mkVirtConstrOffsets dflags (addIdReps args)+           tag = tagForCon dflags con++           -- The binding below forces the masking out of the tag bits+           -- when accessing the constructor field.+           bind_arg :: (NonVoid Id, ByteOff) -> FCode (Maybe LocalReg)+           bind_arg (arg@(NonVoid b), offset)+             | isDeadBinder b  -- See Note [Dead-binder optimisation] in StgCmmExpr+             = return Nothing+             | otherwise+             = do { emit $ mkTaggedObjectLoad dflags (idToReg dflags arg)+                                              base offset tag+                  ; Just <$> bindArgToReg arg }++       mapMaybeM bind_arg args_w_offsets++bindConArgs _other_con _base args+  = ASSERT( null args ) return []
+ compiler/codeGen/StgCmmEnv.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation: the binding environment+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------+module StgCmmEnv (+        CgIdInfo,++        litIdInfo, lneIdInfo, rhsIdInfo, mkRhsInit,+        idInfoToAmode,++        addBindC, addBindsC,++        bindArgsToRegs, bindToReg, rebindToReg,+        bindArgToReg, idToReg,+        getArgAmode, getNonVoidArgAmodes,+        getCgIdInfo,+        maybeLetNoEscape,+    ) where++#include "HsVersions.h"++import GhcPrelude++import TyCon+import StgCmmMonad+import StgCmmUtils+import StgCmmClosure++import CLabel++import BlockId+import CmmExpr+import CmmUtils+import DynFlags+import Id+import MkGraph+import Name+import Outputable+import StgSyn+import Type+import TysPrim+import UniqFM+import Util+import VarEnv++-------------------------------------+--        Manipulating CgIdInfo+-------------------------------------++mkCgIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> CgIdInfo+mkCgIdInfo id lf expr+  = CgIdInfo { cg_id = id, cg_lf = lf+             , cg_loc = CmmLoc expr }++litIdInfo :: DynFlags -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo+litIdInfo dflags id lf lit+  = CgIdInfo { cg_id = id, cg_lf = lf+             , cg_loc = CmmLoc (addDynTag dflags (CmmLit lit) tag) }+  where+    tag = lfDynTag dflags lf++lneIdInfo :: DynFlags -> Id -> [NonVoid Id] -> CgIdInfo+lneIdInfo dflags id regs+  = CgIdInfo { cg_id = id, cg_lf = lf+             , cg_loc = LneLoc blk_id (map (idToReg dflags) regs) }+  where+    lf     = mkLFLetNoEscape+    blk_id = mkBlockId (idUnique id)+++rhsIdInfo :: Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)+rhsIdInfo id lf_info+  = do dflags <- getDynFlags+       reg <- newTemp (gcWord dflags)+       return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), reg)++mkRhsInit :: DynFlags -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph+mkRhsInit dflags reg lf_info expr+  = mkAssign (CmmLocal reg) (addDynTag dflags expr (lfDynTag dflags lf_info))++idInfoToAmode :: CgIdInfo -> CmmExpr+-- Returns a CmmExpr for the *tagged* pointer+idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e+idInfoToAmode cg_info+  = pprPanic "idInfoToAmode" (ppr (cg_id cg_info))        -- LneLoc++addDynTag :: DynFlags -> CmmExpr -> DynTag -> CmmExpr+-- A tag adds a byte offset to the pointer+addDynTag dflags expr tag = cmmOffsetB dflags expr tag++maybeLetNoEscape :: CgIdInfo -> Maybe (BlockId, [LocalReg])+maybeLetNoEscape (CgIdInfo { cg_loc = LneLoc blk_id args}) = Just (blk_id, args)+maybeLetNoEscape _other                                      = Nothing++++---------------------------------------------------------+--        The binding environment+--+-- There are three basic routines, for adding (addBindC),+-- modifying(modifyBindC) and looking up (getCgIdInfo) bindings.+---------------------------------------------------------++addBindC :: CgIdInfo -> FCode ()+addBindC stuff_to_bind = do+        binds <- getBinds+        setBinds $ extendVarEnv binds (cg_id stuff_to_bind) stuff_to_bind++addBindsC :: [CgIdInfo] -> FCode ()+addBindsC new_bindings = do+        binds <- getBinds+        let new_binds = foldl' (\ binds info -> extendVarEnv binds (cg_id info) info)+                               binds+                               new_bindings+        setBinds new_binds++getCgIdInfo :: Id -> FCode CgIdInfo+getCgIdInfo id+  = do  { dflags <- getDynFlags+        ; local_binds <- getBinds -- Try local bindings first+        ; case lookupVarEnv local_binds id of {+            Just info -> return info ;+            Nothing   -> do {++                -- Should be imported; make up a CgIdInfo for it+          let name = idName id+        ; if isExternalName name then+              let ext_lbl+                      | isUnliftedType (idType id) =+                          -- An unlifted external Id must refer to a top-level+                          -- string literal. See Note [Bytes label] in CLabel.+                          ASSERT( idType id `eqType` addrPrimTy )+                          mkBytesLabel name+                      | otherwise = mkClosureLabel name $ idCafInfo id+              in return $+                  litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl)+          else+              cgLookupPanic id -- Bug+        }}}++cgLookupPanic :: Id -> FCode a+cgLookupPanic id+  = do  local_binds <- getBinds+        pprPanic "StgCmmEnv: variable not found"+                (vcat [ppr id,+                text "local binds for:",+                pprUFM local_binds $ \infos ->+                  vcat [ ppr (cg_id info) | info <- infos ]+              ])+++--------------------+getArgAmode :: NonVoid StgArg -> FCode CmmExpr+getArgAmode (NonVoid (StgVarArg var)) = idInfoToAmode <$> getCgIdInfo var+getArgAmode (NonVoid (StgLitArg lit)) = CmmLit <$> cgLit lit++getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr]+-- NB: Filters out void args,+--     so the result list may be shorter than the argument list+getNonVoidArgAmodes [] = return []+getNonVoidArgAmodes (arg:args)+  | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args+  | otherwise = do { amode  <- getArgAmode (NonVoid arg)+                   ; amodes <- getNonVoidArgAmodes args+                   ; return ( amode : amodes ) }+++------------------------------------------------------------------------+--        Interface functions for binding and re-binding names+------------------------------------------------------------------------++bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg+-- Bind an Id to a fresh LocalReg+bindToReg nvid@(NonVoid id) lf_info+  = do dflags <- getDynFlags+       let reg = idToReg dflags nvid+       addBindC (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)))+       return reg++rebindToReg :: NonVoid Id -> FCode LocalReg+-- Like bindToReg, but the Id is already in scope, so+-- get its LF info from the envt+rebindToReg nvid@(NonVoid id)+  = do  { info <- getCgIdInfo id+        ; bindToReg nvid (cg_lf info) }++bindArgToReg :: NonVoid Id -> FCode LocalReg+bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id)++bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg]+bindArgsToRegs args = mapM bindArgToReg args++idToReg :: DynFlags -> NonVoid Id -> LocalReg+-- Make a register from an Id, typically a function argument,+-- free variable, or case binder+--+-- We re-use the Unique from the Id to make it easier to see what is going on+--+-- By now the Ids should be uniquely named; else one would worry+-- about accidental collision+idToReg dflags (NonVoid id)+             = LocalReg (idUnique id)+                        (primRepCmmType dflags (idPrimRep id))
+ compiler/codeGen/StgCmmExpr.hs view
@@ -0,0 +1,992 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Stg to C-- code generation: expressions+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmExpr ( cgExpr ) where++#include "HsVersions.h"++import GhcPrelude hiding ((<*>))++import {-# SOURCE #-} StgCmmBind ( cgBind )++import StgCmmMonad+import StgCmmHeap+import StgCmmEnv+import StgCmmCon+import StgCmmProf (saveCurrentCostCentre, restoreCurrentCostCentre, emitSetCCC)+import StgCmmLayout+import StgCmmPrim+import StgCmmHpc+import StgCmmTicky+import StgCmmUtils+import StgCmmClosure++import StgSyn++import MkGraph+import BlockId+import Cmm+import CmmInfo+import CoreSyn+import DataCon+import ForeignCall+import Id+import PrimOp+import TyCon+import Type             ( isUnliftedType )+import RepType          ( isVoidTy, countConRepArgs, primRepSlot )+import CostCentre       ( CostCentreStack, currentCCS )+import Maybes+import Util+import FastString+import Outputable++import Control.Monad (unless,void)+import Control.Arrow (first)+import Data.Function ( on )++------------------------------------------------------------------------+--              cgExpr: the main function+------------------------------------------------------------------------++cgExpr  :: CgStgExpr -> FCode ReturnKind++cgExpr (StgApp fun args)     = cgIdApp fun args++-- seq# a s ==> a+-- See Note [seq# magic] in PrelRules+cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =+  cgIdApp a []++-- dataToTag# :: a -> Int#+-- See Note [dataToTag#] in primops.txt.pp+cgExpr (StgOpApp (StgPrimOp DataToTagOp) [StgVarArg a] _res_ty) = do+  dflags <- getDynFlags+  emitComment (mkFastString "dataToTag#")+  tmp <- newTemp (bWord dflags)+  _ <- withSequel (AssignTo [tmp] False) (cgIdApp a [])+  -- TODO: For small types look at the tag bits instead of reading info table+  emitReturn [getConstrTag dflags (cmmUntag dflags (CmmReg (CmmLocal tmp)))]++cgExpr (StgOpApp op args ty) = cgOpApp op args ty+cgExpr (StgConApp con args _)= cgConApp con args+cgExpr (StgTick t e)         = cgTick t >> cgExpr e+cgExpr (StgLit lit)       = do cmm_lit <- cgLit lit+                               emitReturn [CmmLit cmm_lit]++cgExpr (StgLet _ binds expr) = do { cgBind binds;     cgExpr expr }+cgExpr (StgLetNoEscape _ binds expr) =+  do { u <- newUnique+     ; let join_id = mkBlockId u+     ; cgLneBinds join_id binds+     ; r <- cgExpr expr+     ; emitLabel join_id+     ; return r }++cgExpr (StgCase expr bndr alt_type alts) =+  cgCase expr bndr alt_type alts++cgExpr (StgLam {}) = panic "cgExpr: StgLam"++------------------------------------------------------------------------+--              Let no escape+------------------------------------------------------------------------++{- Generating code for a let-no-escape binding, aka join point is very+very similar to what we do for a case expression.  The duality is+between+        let-no-escape x = b+        in e+and+        case e of ... -> b++That is, the RHS of 'x' (ie 'b') will execute *later*, just like+the alternative of the case; it needs to be compiled in an environment+in which all volatile bindings are forgotten, and the free vars are+bound only to stable things like stack locations..  The 'e' part will+execute *next*, just like the scrutinee of a case. -}++-------------------------+cgLneBinds :: BlockId -> CgStgBinding -> FCode ()+cgLneBinds join_id (StgNonRec bndr rhs)+  = do  { local_cc <- saveCurrentCostCentre+                -- See Note [Saving the current cost centre]+        ; (info, fcode) <- cgLetNoEscapeRhs join_id local_cc bndr rhs+        ; fcode+        ; addBindC info }++cgLneBinds join_id (StgRec pairs)+  = do  { local_cc <- saveCurrentCostCentre+        ; r <- sequence $ unzipWith (cgLetNoEscapeRhs join_id local_cc) pairs+        ; let (infos, fcodes) = unzip r+        ; addBindsC infos+        ; sequence_ fcodes+        }++-------------------------+cgLetNoEscapeRhs+    :: BlockId          -- join point for successor of let-no-escape+    -> Maybe LocalReg   -- Saved cost centre+    -> Id+    -> CgStgRhs+    -> FCode (CgIdInfo, FCode ())++cgLetNoEscapeRhs join_id local_cc bndr rhs =+  do { (info, rhs_code) <- cgLetNoEscapeRhsBody local_cc bndr rhs+     ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info+     ; let code = do { (_, body) <- getCodeScoped rhs_code+                     ; emitOutOfLine bid (first (<*> mkBranch join_id) body) }+     ; return (info, code)+     }++cgLetNoEscapeRhsBody+    :: Maybe LocalReg   -- Saved cost centre+    -> Id+    -> CgStgRhs+    -> FCode (CgIdInfo, FCode ())+cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure _ cc _upd args body)+  = cgLetNoEscapeClosure bndr local_cc cc (nonVoidIds args) body+cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args)+  = cgLetNoEscapeClosure bndr local_cc cc []+      (StgConApp con args (pprPanic "cgLetNoEscapeRhsBody" $+                           text "StgRhsCon doesn't have type args"))+        -- For a constructor RHS we want to generate a single chunk of+        -- code which can be jumped to from many places, which will+        -- return the constructor. It's easy; just behave as if it+        -- was an StgRhsClosure with a ConApp inside!++-------------------------+cgLetNoEscapeClosure+        :: Id                   -- binder+        -> Maybe LocalReg       -- Slot for saved current cost centre+        -> CostCentreStack      -- XXX: *** NOT USED *** why not?+        -> [NonVoid Id]         -- Args (as in \ args -> body)+        -> CgStgExpr            -- Body (as in above)+        -> FCode (CgIdInfo, FCode ())++cgLetNoEscapeClosure bndr cc_slot _unused_cc args body+  = do dflags <- getDynFlags+       return ( lneIdInfo dflags bndr args+              , code )+  where+   code = forkLneBody $ do {+            ; withNewTickyCounterLNE (idName bndr) args $ do+            ; restoreCurrentCostCentre cc_slot+            ; arg_regs <- bindArgsToRegs args+            ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) }+++------------------------------------------------------------------------+--              Case expressions+------------------------------------------------------------------------++{- Note [Compiling case expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is quite interesting to decide whether to put a heap-check at the+start of each alternative.  Of course we certainly have to do so if+the case forces an evaluation, or if there is a primitive op which can+trigger GC.++A more interesting situation is this (a Plan-B situation)++        !P!;+        ...P...+        case x# of+          0#      -> !Q!; ...Q...+          default -> !R!; ...R...++where !x! indicates a possible heap-check point. The heap checks+in the alternatives *can* be omitted, in which case the topmost+heapcheck will take their worst case into account.++In favour of omitting !Q!, !R!:++ - *May* save a heap overflow test,+   if ...P... allocates anything.++ - We can use relative addressing from a single Hp to+   get at all the closures so allocated.++ - No need to save volatile vars etc across heap checks+   in !Q!, !R!++Against omitting !Q!, !R!++  - May put a heap-check into the inner loop.  Suppose+        the main loop is P -> R -> P -> R...+        Q is the loop exit, and only it does allocation.+    This only hurts us if P does no allocation.  If P allocates,+    then there is a heap check in the inner loop anyway.++  - May do more allocation than reqd.  This sometimes bites us+    badly.  For example, nfib (ha!) allocates about 30\% more space if the+    worst-casing is done, because many many calls to nfib are leaf calls+    which don't need to allocate anything.++    We can un-allocate, but that costs an instruction++Neither problem hurts us if there is only one alternative.++Suppose the inner loop is P->R->P->R etc.  Then here is+how many heap checks we get in the *inner loop* under various+conditions++  Alloc   Heap check in branches (!Q!, !R!)?+  P Q R      yes     no (absorb to !P!)+--------------------------------------+  n n n      0          0+  n y n      0          1+  n . y      1          1+  y . y      2          1+  y . n      1          1++Best choices: absorb heap checks from Q and R into !P! iff+  a) P itself does some allocation+or+  b) P does allocation, or there is exactly one alternative++We adopt (b) because that is more likely to put the heap check at the+entry to a function, when not many things are live.  After a bunch of+single-branch cases, we may have lots of things live++Hence: two basic plans for++        case e of r { alts }++------ Plan A: the general case ---------++        ...save current cost centre...++        ...code for e,+           with sequel (SetLocals r)++        ...restore current cost centre...+        ...code for alts...+        ...alts do their own heap checks++------ Plan B: special case when ---------+  (i)  e does not allocate or call GC+  (ii) either upstream code performs allocation+       or there is just one alternative++  Then heap allocation in the (single) case branch+  is absorbed by the upstream check.+  Very common example: primops on unboxed values++        ...code for e,+           with sequel (SetLocals r)...++        ...code for alts...+        ...no heap check...+-}++++-------------------------------------+data GcPlan+  = GcInAlts            -- Put a GC check at the start the case alternatives,+        [LocalReg]      -- which binds these registers+  | NoGcInAlts          -- The scrutinee is a primitive value, or a call to a+                        -- primitive op which does no GC.  Absorb the allocation+                        -- of the case alternative(s) into the upstream check++-------------------------------------+cgCase :: CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind++cgCase (StgOpApp (StgPrimOp op) args _) bndr (AlgAlt tycon) alts+  | isEnumerationTyCon tycon -- Note [case on bool]+  = do { tag_expr <- do_enum_primop op args++       -- If the binder is not dead, convert the tag to a constructor+       -- and assign it. See Note [Dead-binder optimisation]+       ; unless (isDeadBinder bndr) $ do+            { dflags <- getDynFlags+            ; tmp_reg <- bindArgToReg (NonVoid bndr)+            ; emitAssign (CmmLocal tmp_reg)+                         (tagToClosure dflags tycon tag_expr) }++       ; (mb_deflt, branches) <- cgAlgAltRhss (NoGcInAlts,AssignedDirectly)+                                              (NonVoid bndr) alts+                                 -- See Note [GC for conditionals]+       ; emitSwitch tag_expr branches mb_deflt 0 (tyConFamilySize tycon - 1)+       ; return AssignedDirectly+       }+  where+    do_enum_primop :: PrimOp -> [StgArg] -> FCode CmmExpr+    do_enum_primop TagToEnumOp [arg]  -- No code!+      = getArgAmode (NonVoid arg)+    do_enum_primop primop args+      = do dflags <- getDynFlags+           tmp <- newTemp (bWord dflags)+           cgPrimOp [tmp] primop args+           return (CmmReg (CmmLocal tmp))++{-+Note [case on bool]+~~~~~~~~~~~~~~~~~~~+This special case handles code like++  case a <# b of+    True ->+    False ->++-->  case tagToEnum# (a <$# b) of+        True -> .. ; False -> ...++--> case (a <$# b) of r ->+    case tagToEnum# r of+        True -> .. ; False -> ...++If we let the ordinary case code handle it, we'll get something like++ tmp1 = a < b+ tmp2 = Bool_closure_tbl[tmp1]+ if (tmp2 & 7 != 0) then ... // normal tagged case++but this junk won't optimise away.  What we really want is just an+inline comparison:++ if (a < b) then ...++So we add a special case to generate++ tmp1 = a < b+ if (tmp1 == 0) then ...++and later optimisations will further improve this.++Now that #6135 has been resolved it should be possible to remove that+special case. The idea behind this special case and pre-6135 implementation+of Bool-returning primops was that tagToEnum# was added implicitly in the+codegen and then optimized away. Now the call to tagToEnum# is explicit+in the source code, which allows to optimize it away at the earlier stages+of compilation (i.e. at the Core level).++Note [Scrutinising VoidRep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have this STG code:+   f = \[s : State# RealWorld] ->+       case s of _ -> blah+This is very odd.  Why are we scrutinising a state token?  But it+can arise with bizarre NOINLINE pragmas (#9964)+    crash :: IO ()+    crash = IO (\s -> let {-# NOINLINE s' #-}+                          s' = s+                      in (# s', () #))++Now the trouble is that 's' has VoidRep, and we do not bind void+arguments in the environment; they don't live anywhere.  See the+calls to nonVoidIds in various places.  So we must not look up+'s' in the environment.  Instead, just evaluate the RHS!  Simple.++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).++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+(giving CmmSink less work to do), and in any case CmmSink only runs+with -O. Since the majority of case binders are dead, this+optimisation probably still has a great benefit-cost ratio and we want+to keep it for -O0. See also Phab:D5358.++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+job we deleted the hacks.+-}++cgCase (StgApp v []) _ (PrimAlt _) alts+  | isVoidRep (idPrimRep v)  -- See Note [Scrutinising VoidRep]+  , [(DEFAULT, _, rhs)] <- alts+  = cgExpr rhs++{- Note [Dodgy unsafeCoerce 1]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    case (x :: HValue) |> co of (y :: MutVar# Int)+        DEFAULT -> ...+We want to gnerate an assignment+     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+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+MutVar#.  The types are compatible though, so we can just generate an+assignment.+-}+cgCase (StgApp v []) bndr alt_type@(PrimAlt _) alts+  | isUnliftedType (idType v)  -- Note [Dodgy unsafeCoerce 1]+  || reps_compatible+  = -- assignment suffices for unlifted types+    do { dflags <- getDynFlags+       ; unless reps_compatible $+           pprPanic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"+                    (pp_bndr v $$ pp_bndr bndr)+       ; v_info <- getCgIdInfo v+       ; emitAssign (CmmLocal (idToReg dflags (NonVoid bndr)))+                    (idInfoToAmode v_info)+       -- Add bndr to the environment+       ; _ <- bindArgToReg (NonVoid bndr)+       ; cgAlts (NoGcInAlts,AssignedDirectly) (NonVoid bndr) alt_type alts }+  where+    reps_compatible = ((==) `on` (primRepSlot . idPrimRep)) v bndr+      -- Must compare SlotTys, not proper PrimReps, because with unboxed sums,+      -- the types of the binders are generated from slotPrimRep and might not+      -- match. Test case:+      --   swap :: (# Int | Int #) -> (# Int | Int #)+      --   swap (# x | #) = (# | x #)+      --   swap (# | y #) = (# y | #)++    pp_bndr id = ppr id <+> dcolon <+> ppr (idType id) <+> parens (ppr (idPrimRep id))++{- Note [Dodgy unsafeCoerce 2, #3132]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In all other cases of a lifted Id being cast to an unlifted type, the+Id should be bound to bottom, otherwise this is an unsafe use of+unsafeCoerce.  We can generate code to enter the Id and assume that+it will never return.  Hence, we emit the usual enter/return code, and+because bottom must be untagged, it will be entered.  The Sequel is a+type-correct assignment, albeit bogus.  The (dead) continuation loops;+it would be better to invoke some kind of panic function here.+-}+cgCase scrut@(StgApp v []) _ (PrimAlt _) _+  = do { dflags <- getDynFlags+       ; mb_cc <- maybeSaveCostCentre True+       ; _ <- withSequel+                  (AssignTo [idToReg dflags (NonVoid v)] False) (cgExpr scrut)+       ; restoreCurrentCostCentre mb_cc+       ; emitComment $ mkFastString "should be unreachable code"+       ; l <- newBlockId+       ; emitLabel l+       ; emit (mkBranch l)  -- an infinite loop+       ; return AssignedDirectly+       }++{- Note [Handle seq#]+~~~~~~~~~~~~~~~~~~~~~+See Note [seq# magic] in PrelRules.+The special case for seq# in cgCase does this:++  case seq# a s of v+    (# s', a' #) -> e+==>+  case a of v+    (# s', a' #) -> e++(taking advantage of the fact that the return convention for (# State#, a #)+is the same as the return convention for just 'a')+-}++cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts+  = -- Note [Handle seq#]+    -- And see Note [seq# magic] in PrelRules+    -- Use the same return convention as vanilla 'a'.+    cgCase (StgApp a []) bndr alt_type alts++cgCase scrut bndr alt_type alts+  = -- the general case+    do { dflags <- getDynFlags+       ; up_hp_usg <- getVirtHp        -- Upstream heap usage+       ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts+             alt_regs  = map (idToReg dflags) ret_bndrs+       ; simple_scrut <- isSimpleScrut scrut alt_type+       ; let do_gc  | is_cmp_op scrut  = False  -- See Note [GC for conditionals]+                    | not simple_scrut = True+                    | isSingleton alts = False+                    | up_hp_usg > 0    = False+                    | otherwise        = True+               -- cf Note [Compiling case expressions]+             gc_plan = if do_gc then GcInAlts alt_regs else NoGcInAlts++       ; mb_cc <- maybeSaveCostCentre simple_scrut++       ; let sequel = AssignTo alt_regs do_gc{- Note [scrut sequel] -}+       ; ret_kind <- withSequel sequel (cgExpr scrut)+       ; restoreCurrentCostCentre mb_cc+       ; _ <- bindArgsToRegs ret_bndrs+       ; cgAlts (gc_plan,ret_kind) (NonVoid bndr) alt_type alts+       }+  where+    is_cmp_op (StgOpApp (StgPrimOp op) _ _) = isComparisonPrimOp op+    is_cmp_op _                             = False++{- Note [GC for conditionals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For boolean conditionals it seems that we have always done NoGcInAlts.+That is, we have always done the GC check before the conditional.+This is enshrined in the special case for+   case tagToEnum# (a>b) of ...+See Note [case on bool]++It's odd, and it's flagrantly inconsistent with the rules described+Note [Compiling case expressions].  However, after eliminating the+tagToEnum# (#13397) we will have:+   case (a>b) of ...+Rather than make it behave quite differently, I am testing for a+comparison operator here in in the general case as well.++ToDo: figure out what the Right Rule should be.++Note [scrut sequel]+~~~~~~~~~~~~~~~~~~~+The job of the scrutinee is to assign its value(s) to alt_regs.+Additionally, if we plan to do a heap-check in the alternatives (see+Note [Compiling case expressions]), then we *must* retreat Hp to+recover any unused heap before passing control to the sequel.  If we+don't do this, then any unused heap will become slop because the heap+check will reset the heap usage. Slop in the heap breaks LDV profiling+(+RTS -hb) which needs to do a linear sweep through the nursery.+++Note [Inlining out-of-line primops and heap checks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If shouldInlinePrimOp returns True when called from StgCmmExpr for the+purpose of heap check placement, we *must* inline the primop later in+StgCmmPrim. If we don't things will go wrong.+-}++-----------------+maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)+maybeSaveCostCentre simple_scrut+  | simple_scrut = return Nothing+  | otherwise    = saveCurrentCostCentre+++-----------------+isSimpleScrut :: CgStgExpr -> AltType -> FCode Bool+-- Simple scrutinee, does not block or allocate; hence safe to amalgamate+-- heap usage from alternatives into the stuff before the case+-- NB: if you get this wrong, and claim that the expression doesn't allocate+--     when it does, you'll deeply mess up allocation+isSimpleScrut (StgOpApp op args _) _       = isSimpleOp op args+isSimpleScrut (StgLit _)       _           = return True       -- case 1# of { 0# -> ..; ... }+isSimpleScrut (StgApp _ [])    (PrimAlt _) = return True       -- case x# of { 0# -> ..; ... }+isSimpleScrut _                _           = return False++isSimpleOp :: StgOp -> [StgArg] -> FCode Bool+-- True iff the op cannot block or allocate+isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)+-- dataToTag# evalautes its argument, see Note [dataToTag#] in primops.txt.pp+isSimpleOp (StgPrimOp DataToTagOp) _ = return False+isSimpleOp (StgPrimOp op) stg_args                  = do+    arg_exprs <- getNonVoidArgAmodes stg_args+    dflags <- getDynFlags+    -- See Note [Inlining out-of-line primops and heap checks]+    return $! isJust $ shouldInlinePrimOp dflags op arg_exprs+isSimpleOp (StgPrimCallOp _) _                           = return False++-----------------+chooseReturnBndrs :: Id -> AltType -> [CgStgAlt] -> [NonVoid Id]+-- These are the binders of a case that are assigned by the evaluation of the+-- scrutinee.+-- They're non-void, see Note [Post-unarisation invariants] in UnariseStg.+chooseReturnBndrs bndr (PrimAlt _) _alts+  = assertNonVoidIds [bndr]++chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)]+  = ASSERT2(ids `lengthIs` n, ppr n $$ ppr ids $$ ppr _bndr)+    assertNonVoidIds ids     -- 'bndr' is not assigned!++chooseReturnBndrs bndr (AlgAlt _) _alts+  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned++chooseReturnBndrs bndr PolyAlt _alts+  = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned++chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs"+                             -- MultiValAlt has only one alternative++-------------------------------------+cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]+       -> FCode ReturnKind+-- At this point the result of the case are in the binders+cgAlts gc_plan _bndr PolyAlt [(_, _, rhs)]+  = maybeAltHeapCheck gc_plan (cgExpr rhs)++cgAlts gc_plan _bndr (MultiValAlt _) [(_, _, rhs)]+  = maybeAltHeapCheck gc_plan (cgExpr rhs)+        -- Here bndrs are *already* in scope, so don't rebind them++cgAlts gc_plan bndr (PrimAlt _) alts+  = do  { dflags <- getDynFlags++        ; tagged_cmms <- cgAltRhss gc_plan bndr alts++        ; let bndr_reg = CmmLocal (idToReg dflags bndr)+              (DEFAULT,deflt) = head tagged_cmms+                -- PrimAlts always have a DEFAULT case+                -- and it always comes first++              tagged_cmms' = [(lit,code)+                             | (LitAlt lit, code) <- tagged_cmms]+        ; emitCmmLitSwitch (CmmReg bndr_reg) tagged_cmms' deflt+        ; return AssignedDirectly }++cgAlts gc_plan bndr (AlgAlt tycon) alts+  = do  { dflags <- getDynFlags++        ; (mb_deflt, branches) <- cgAlgAltRhss gc_plan bndr alts++        ; let fam_sz   = tyConFamilySize tycon+              bndr_reg = CmmLocal (idToReg dflags bndr)++                    -- Is the constructor tag in the node reg?+        ; if isSmallFamily dflags fam_sz+          then do+                let   -- Yes, bndr_reg has constr. tag in ls bits+                   tag_expr = cmmConstrTag1 dflags (CmmReg bndr_reg)+                   branches' = [(tag+1,branch) | (tag,branch) <- branches]+                emitSwitch tag_expr branches' mb_deflt 1 fam_sz++           else -- No, get tag from info table+                let -- Note that ptr _always_ has tag 1+                    -- when the family size is big enough+                    untagged_ptr = cmmRegOffB bndr_reg (-1)+                    tag_expr = getConstrTag dflags (untagged_ptr)+                in emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)++        ; return AssignedDirectly }++cgAlts _ _ _ _ = panic "cgAlts"+        -- UbxTupAlt and PolyAlt have only one alternative+++-- Note [alg-alt heap check]+--+-- In an algebraic case with more than one alternative, we will have+-- code like+--+-- L0:+--   x = R1+--   goto L1+-- L1:+--   if (x & 7 >= 2) then goto L2 else goto L3+-- L2:+--   Hp = Hp + 16+--   if (Hp > HpLim) then goto L4+--   ...+-- L4:+--   call gc() returns to L5+-- L5:+--   x = R1+--   goto L1++-------------------+cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]+             -> FCode ( Maybe CmmAGraphScoped+                      , [(ConTagZ, CmmAGraphScoped)] )+cgAlgAltRhss gc_plan bndr alts+  = do { tagged_cmms <- cgAltRhss gc_plan bndr alts++       ; let { mb_deflt = case tagged_cmms of+                           ((DEFAULT,rhs) : _) -> Just rhs+                           _other              -> Nothing+                            -- DEFAULT is always first, if present++              ; branches = [ (dataConTagZ con, cmm)+                           | (DataAlt con, cmm) <- tagged_cmms ]+              }++       ; return (mb_deflt, branches)+       }+++-------------------+cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]+          -> FCode [(AltCon, CmmAGraphScoped)]+cgAltRhss gc_plan bndr alts = do+  dflags <- getDynFlags+  let+    base_reg = idToReg dflags bndr+    cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)+    cg_alt (con, bndrs, rhs)+      = getCodeScoped             $+        maybeAltHeapCheck gc_plan $+        do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs)+                    -- alt binders are always non-void,+                    -- see Note [Post-unarisation invariants] in UnariseStg+           ; _ <- cgExpr rhs+           ; return con }+  forkAlts (map cg_alt alts)++maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a+maybeAltHeapCheck (NoGcInAlts,_)  code = code+maybeAltHeapCheck (GcInAlts regs, AssignedDirectly) code =+  altHeapCheck regs code+maybeAltHeapCheck (GcInAlts regs, ReturnedTo lret off) code =+  altHeapCheckReturnsTo regs lret off code++-----------------------------------------------------------------------------+--      Tail calls+-----------------------------------------------------------------------------++cgConApp :: DataCon -> [StgArg] -> FCode ReturnKind+cgConApp con stg_args+  | isUnboxedTupleCon con       -- Unboxed tuple: assign and return+  = do { arg_exprs <- getNonVoidArgAmodes stg_args+       ; tickyUnboxedTupleReturn (length arg_exprs)+       ; emitReturn arg_exprs }++  | otherwise   --  Boxed constructors; allocate and return+  = ASSERT2( stg_args `lengthIs` countConRepArgs con, ppr con <> parens (ppr (countConRepArgs con)) <+> ppr stg_args )+    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False+                                     currentCCS con (assertNonVoidStgArgs stg_args)+                                     -- con args are always non-void,+                                     -- see Note [Post-unarisation invariants] in UnariseStg+                -- The first "con" says that the name bound to this+                -- closure is "con", which is a bit of a fudge, but+                -- it only affects profiling (hence the False)++        ; emit =<< fcode_init+        ; tickyReturnNewCon (length stg_args)+        ; emitReturn [idInfoToAmode idinfo] }++cgIdApp :: Id -> [StgArg] -> FCode ReturnKind+cgIdApp fun_id args = do+    dflags         <- getDynFlags+    fun_info       <- getCgIdInfo fun_id+    self_loop_info <- getSelfLoop+    let fun_arg     = StgVarArg fun_id+        fun_name    = idName    fun_id+        fun         = idInfoToAmode fun_info+        lf_info     = cg_lf         fun_info+        n_args      = length args+        v_args      = length $ filter (isVoidTy . stgArgType) args+        node_points dflags = nodeMustPointToIt dflags lf_info+    case getCallMethod dflags fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop_info of+            -- A value in WHNF, so we can just return it.+        ReturnIt+          | isVoidTy (idType fun_id) -> emitReturn []+          | otherwise                -> emitReturn [fun]+          -- ToDo: does ReturnIt guarantee tagged?++        EnterIt -> ASSERT( null args )  -- Discarding arguments+                   emitEnter fun++        SlowCall -> do      -- A slow function call via the RTS apply routines+                { tickySlowCall lf_info args+                ; emitComment $ mkFastString "slowCall"+                ; slowCall fun args }++        -- A direct function call (possibly with some left-over arguments)+        DirectEntry lbl arity -> do+                { tickyDirectCall arity args+                ; if node_points dflags+                     then directCall NativeNodeCall   lbl arity (fun_arg:args)+                     else directCall NativeDirectCall lbl arity args }++        -- Let-no-escape call or self-recursive tail-call+        JumpToIt blk_id lne_regs -> do+          { adjustHpBackwards -- always do this before a tail-call+          ; cmm_args <- getNonVoidArgAmodes args+          ; emitMultiAssign lne_regs cmm_args+          ; emit (mkBranch blk_id)+          ; return AssignedDirectly }++-- Note [Self-recursive tail calls]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Self-recursive tail calls can be optimized into a local jump in the same+-- way as let-no-escape bindings (see Note [What is a non-escaping let] in+-- stgSyn/CoreToStg.hs). Consider this:+--+-- foo.info:+--     a = R1  // calling convention+--     b = R2+--     goto L1+-- L1: ...+--     ...+-- ...+-- L2: R1 = x+--     R2 = y+--     call foo(R1,R2)+--+-- Instead of putting x and y into registers (or other locations required by the+-- calling convention) and performing a call we can put them into local+-- variables a and b and perform jump to L1:+--+-- foo.info:+--     a = R1+--     b = R2+--     goto L1+-- L1: ...+--     ...+-- ...+-- L2: a = x+--     b = y+--     goto L1+--+-- This can be done only when function is calling itself in a tail position+-- and only if the call passes number of parameters equal to function's arity.+-- Note that this cannot be performed if a function calls itself with a+-- continuation.+--+-- This in fact implements optimization known as "loopification". It was+-- described in "Low-level code optimizations in the Glasgow Haskell Compiler"+-- by Krzysztof Woś, though we use different approach. Krzysztof performed his+-- optimization at the Cmm level, whereas we perform ours during code generation+-- (Stg-to-Cmm pass) essentially making sure that optimized Cmm code is+-- generated in the first place.+--+-- Implementation is spread across a couple of places in the code:+--+--   * FCode monad stores additional information in its reader environment+--     (cgd_self_loop field). This information tells us which function can+--     tail call itself in an optimized way (it is the function currently+--     being compiled), what is the label of a loop header (L1 in example above)+--     and information about local registers in which we should arguments+--     before making a call (this would be a and b in example above).+--+--   * Whenever we are compiling a function, we set that information to reflect+--     the fact that function currently being compiled can be jumped to, instead+--     of called. This is done in closureCodyBody in StgCmmBind.+--+--   * We also have to emit a label to which we will be jumping. We make sure+--     that the label is placed after a stack check but before the heap+--     check. The reason is that making a recursive tail-call does not increase+--     the stack so we only need to check once. But it may grow the heap, so we+--     have to repeat the heap check in every self-call. This is done in+--     do_checks in StgCmmHeap.+--+--   * When we begin compilation of another closure we remove the additional+--     information from the environment. This is done by forkClosureBody+--     in StgCmmMonad. Other functions that duplicate the environment -+--     forkLneBody, forkAlts, codeOnly - duplicate that information. In other+--     words, we only need to clean the environment of the self-loop information+--     when compiling right hand side of a closure (binding).+--+--   * When compiling a call (cgIdApp) we use getCallMethod to decide what kind+--     of call will be generated. getCallMethod decides to generate a self+--     recursive tail call when (a) environment stores information about+--     possible self tail-call; (b) that tail call is to a function currently+--     being compiled; (c) number of passed non-void arguments is equal to+--     function's arity. (d) loopification is turned on via -floopification+--     command-line option.+--+--   * Command line option to turn loopification on and off is implemented in+--     DynFlags.+--+--+-- Note [Void arguments in self-recursive tail calls]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- State# tokens can get in the way of the loopification optimization as seen in+-- #11372. Consider this:+--+-- foo :: [a]+--     -> (a -> State# s -> (# State s, Bool #))+--     -> State# s+--     -> (# State# s, Maybe a #)+-- foo [] f s = (# s, Nothing #)+-- foo (x:xs) f s = case f x s of+--      (# s', b #) -> case b of+--          True -> (# s', Just x #)+--          False -> foo xs f s'+--+-- We would like to compile the call to foo as a local jump instead of a call+-- (see Note [Self-recursive tail calls]). However, the generated function has+-- an arity of 2 while we apply it to 3 arguments, one of them being of void+-- type. Thus, we mustn't count arguments of void type when checking whether+-- we can turn a call into a self-recursive jump.+--++emitEnter :: CmmExpr -> FCode ReturnKind+emitEnter fun = do+  { dflags <- getDynFlags+  ; adjustHpBackwards+  ; sequel <- getSequel+  ; updfr_off <- getUpdFrameOff+  ; case sequel of+      -- For a return, we have the option of generating a tag-test or+      -- not.  If the value is tagged, we can return directly, which+      -- is quicker than entering the value.  This is a code+      -- size/speed trade-off: when optimising for speed rather than+      -- size we could generate the tag test.+      --+      -- Right now, we do what the old codegen did, and omit the tag+      -- test, just generating an enter.+      Return -> do+        { let entry = entryCode dflags $ closureInfoPtr dflags $ CmmReg nodeReg+        ; emit $ mkJump dflags NativeNodeCall entry+                        [cmmUntag dflags fun] updfr_off+        ; return AssignedDirectly+        }++      -- The result will be scrutinised in the sequel.  This is where+      -- we generate a tag-test to avoid entering the closure if+      -- possible.+      --+      -- The generated code will be something like this:+      --+      --    R1 = fun  -- copyout+      --    if (fun & 7 != 0) goto Lret else goto Lcall+      --  Lcall:+      --    call [fun] returns to Lret+      --  Lret:+      --    fun' = R1  -- copyin+      --    ...+      --+      -- Note in particular that the label Lret is used as a+      -- destination by both the tag-test and the call.  This is+      -- because Lret will necessarily be a proc-point, and we want to+      -- ensure that we generate only one proc-point for this+      -- sequence.+      --+      -- Furthermore, we tell the caller that we generated a native+      -- return continuation by returning (ReturnedTo Lret off), so+      -- that the continuation can be reused by the heap-check failure+      -- code in the enclosing case expression.+      --+      AssignTo res_regs _ -> do+       { lret <- newBlockId+       ; let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs []+       ; lcall <- newBlockId+       ; updfr_off <- getUpdFrameOff+       ; let area = Young lret+       ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area+                                          [fun] updfr_off []+         -- refer to fun via nodeReg after the copyout, to avoid having+         -- both live simultaneously; this sometimes enables fun to be+         -- inlined in the RHS of the R1 assignment.+       ; let entry = entryCode dflags (closureInfoPtr dflags (CmmReg nodeReg))+             the_call = toCall entry (Just lret) updfr_off off outArgs regs+       ; tscope <- getTickScope+       ; emit $+           copyout <*>+           mkCbranch (cmmIsTagged dflags (CmmReg nodeReg))+                     lret lcall Nothing <*>+           outOfLine lcall (the_call,tscope) <*>+           mkLabel lret tscope <*>+           copyin+       ; return (ReturnedTo lret off)+       }+  }++------------------------------------------------------------------------+--              Ticks+------------------------------------------------------------------------++-- | Generate Cmm code for a tick. Depending on the type of Tickish,+-- this will either generate actual Cmm instrumentation code, or+-- simply pass on the annotation as a @CmmTickish@.+cgTick :: Tickish Id -> FCode ()+cgTick tick+  = do { dflags <- getDynFlags+       ; case tick of+           ProfNote   cc t p -> emitSetCCC cc t p+           HpcTick    m n    -> emit (mkTickBox dflags m n)+           SourceNote s n    -> emitTick $ SourceNote s n+           _other            -> return () -- ignore+       }
+ compiler/codeGen/StgCmmExtCode.hs view
@@ -0,0 +1,253 @@+-- | Our extended FCode monad.++-- We add a mapping from names to CmmExpr, to support local variable names in+-- the concrete C-- code.  The unique supply of the underlying FCode monad+-- is used to grab a new unique for each local variable.++-- In C--, a local variable can be declared anywhere within a proc,+-- and it scopes from the beginning of the proc to the end.  Hence, we have+-- to collect declarations as we parse the proc, and feed the environment+-- back in circularly (to avoid a two-pass algorithm).++module StgCmmExtCode (+        CmmParse, unEC,+        Named(..), Env,++        loopDecls,+        getEnv,++        withName,+        getName,++        newLocal,+        newLabel,+        newBlockId,+        newFunctionName,+        newImport,+        lookupLabel,+        lookupName,++        code,+        emit, emitLabel, emitAssign, emitStore,+        getCode, getCodeR, getCodeScoped,+        emitOutOfLine,+        withUpdFrameOff, getUpdFrameOff+)++where++import GhcPrelude++import qualified StgCmmMonad as F+import StgCmmMonad (FCode, newUnique)++import Cmm+import CLabel+import MkGraph++import BlockId+import DynFlags+import FastString+import Module+import UniqFM+import Unique+import UniqSupply++import Control.Monad (liftM, ap)++-- | The environment contains variable definitions or blockids.+data Named+        = VarN CmmExpr          -- ^ Holds CmmLit(CmmLabel ..) which gives the label type,+                                --      eg, RtsLabel, ForeignLabel, CmmLabel etc.++        | FunN   UnitId      -- ^ A function name from this package+        | LabelN BlockId                -- ^ A blockid of some code or data.++-- | An environment of named things.+type Env        = UniqFM Named++-- | Local declarations that are in scope during code generation.+type Decls      = [(FastString,Named)]++-- | Does a computation in the FCode monad, with a current environment+--      and a list of local declarations. Returns the resulting list of declarations.+newtype CmmParse a+        = EC { unEC :: String -> Env -> Decls -> FCode (Decls, a) }++type ExtCode = CmmParse ()++returnExtFC :: a -> CmmParse a+returnExtFC a   = EC $ \_ _ s -> return (s, a)++thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b+thenExtFC (EC m) k = EC $ \c e s -> do (s',r) <- m c e s; unEC (k r) c e s'++instance Functor CmmParse where+      fmap = liftM++instance Applicative CmmParse where+      pure = returnExtFC+      (<*>) = ap++instance Monad CmmParse where+  (>>=) = thenExtFC++instance MonadUnique CmmParse where+  getUniqueSupplyM = code getUniqueSupplyM+  getUniqueM = EC $ \_ _ decls -> do+    u <- getUniqueM+    return (decls, u)++instance HasDynFlags CmmParse where+    getDynFlags = EC (\_ _ d -> do dflags <- getDynFlags+                                   return (d, dflags))+++-- | Takes the variable decarations and imports from the monad+--      and makes an environment, which is looped back into the computation.+--      In this way, we can have embedded declarations that scope over the whole+--      procedure, and imports that scope over the entire module.+--      Discards the local declaration contained within decl'+--+loopDecls :: CmmParse a -> CmmParse a+loopDecls (EC fcode) =+      EC $ \c e globalDecls -> do+        (_, a) <- F.fixC $ \ ~(decls, _) ->+          fcode c (addListToUFM e decls) globalDecls+        return (globalDecls, a)+++-- | Get the current environment from the monad.+getEnv :: CmmParse Env+getEnv  = EC $ \_ e s -> return (s, e)++-- | Get the current context name from the monad+getName :: CmmParse String+getName  = EC $ \c _ s -> return (s, c)++-- | Set context name for a sub-parse+withName :: String -> CmmParse a -> CmmParse a+withName c' (EC fcode) = EC $ \_ e s -> fcode c' e s++addDecl :: FastString -> Named -> ExtCode+addDecl name named = EC $ \_ _ s -> return ((name, named) : s, ())+++-- | Add a new variable to the list of local declarations.+--      The CmmExpr says where the value is stored.+addVarDecl :: FastString -> CmmExpr -> ExtCode+addVarDecl var expr = addDecl var (VarN expr)++-- | Add a new label to the list of local declarations.+addLabel :: FastString -> BlockId -> ExtCode+addLabel name block_id = addDecl name (LabelN block_id)+++-- | Create a fresh local variable of a given type.+newLocal+        :: CmmType              -- ^ data type+        -> FastString           -- ^ name of variable+        -> CmmParse LocalReg    -- ^ register holding the value++newLocal ty name = do+   u <- code newUnique+   let reg = LocalReg u ty+   addVarDecl name (CmmReg (CmmLocal reg))+   return reg+++-- | Allocate a fresh label.+newLabel :: FastString -> CmmParse BlockId+newLabel name = do+   u <- code newUnique+   addLabel name (mkBlockId u)+   return (mkBlockId u)++-- | Add add a local function to the environment.+newFunctionName+        :: FastString   -- ^ name of the function+        -> UnitId    -- ^ package of the current module+        -> ExtCode++newFunctionName name pkg = addDecl name (FunN pkg)+++-- | Add an imported foreign label to the list of local declarations.+--      If this is done at the start of the module the declaration will scope+--      over the whole module.+newImport+        :: (FastString, CLabel)+        -> CmmParse ()++newImport (name, cmmLabel)+   = addVarDecl name (CmmLit (CmmLabel cmmLabel))+++-- | Lookup the BlockId bound to the label with this name.+--      If one hasn't been bound yet, create a fresh one based on the+--      Unique of the name.+lookupLabel :: FastString -> CmmParse BlockId+lookupLabel name = do+  env <- getEnv+  return $+     case lookupUFM env name of+        Just (LabelN l) -> l+        _other          -> mkBlockId (newTagUnique (getUnique name) 'L')+++-- | Lookup the location of a named variable.+--      Unknown names are treated as if they had been 'import'ed from the runtime system.+--      This saves us a lot of bother in the RTS sources, at the expense of+--      deferring some errors to link time.+lookupName :: FastString -> CmmParse CmmExpr+lookupName name = do+  env    <- getEnv+  return $+     case lookupUFM env name of+        Just (VarN e)   -> e+        Just (FunN pkg) -> CmmLit (CmmLabel (mkCmmCodeLabel pkg          name))+        _other          -> CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId name))+++-- | Lift an FCode computation into the CmmParse monad+code :: FCode a -> CmmParse a+code fc = EC $ \_ _ s -> do+                r <- fc+                return (s, r)++emit :: CmmAGraph -> CmmParse ()+emit = code . F.emit++emitLabel :: BlockId -> CmmParse ()+emitLabel = code . F.emitLabel++emitAssign :: CmmReg  -> CmmExpr -> CmmParse ()+emitAssign l r = code (F.emitAssign l r)++emitStore :: CmmExpr  -> CmmExpr -> CmmParse ()+emitStore l r = code (F.emitStore l r)++getCode :: CmmParse a -> CmmParse CmmAGraph+getCode (EC ec) = EC $ \c e s -> do+  ((s',_), gr) <- F.getCodeR (ec c e s)+  return (s', gr)++getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)+getCodeR (EC ec) = EC $ \c e s -> do+  ((s', r), gr) <- F.getCodeR (ec c e s)+  return (s', (r,gr))++getCodeScoped :: CmmParse a -> CmmParse (a, CmmAGraphScoped)+getCodeScoped (EC ec) = EC $ \c e s -> do+  ((s', r), gr) <- F.getCodeScoped (ec c e s)+  return (s', (r,gr))++emitOutOfLine :: BlockId -> CmmAGraphScoped -> CmmParse ()+emitOutOfLine l g = code (F.emitOutOfLine l g)++withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()+withUpdFrameOff size inner+  = EC $ \c e s -> F.withUpdFrameOff size $ (unEC inner) c e s++getUpdFrameOff :: CmmParse UpdFrameOffset+getUpdFrameOff = code $ F.getUpdFrameOff
+ compiler/codeGen/StgCmmForeign.hs view
@@ -0,0 +1,534 @@+-----------------------------------------------------------------------------+--+-- Code generation for foreign calls.+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmForeign (+  cgForeignCall,+  emitPrimCall, emitCCall,+  emitForeignCall,     -- For CmmParse+  emitSaveThreadState,+  saveThreadState,+  emitLoadThreadState,+  loadThreadState,+  emitOpenNursery,+  emitCloseNursery,+ ) where++import GhcPrelude hiding( succ, (<*>) )++import StgSyn+import StgCmmProf (storeCurCCS, ccsType)+import StgCmmEnv+import StgCmmMonad+import StgCmmUtils+import StgCmmClosure+import StgCmmLayout++import BlockId (newBlockId)+import Cmm+import CmmUtils+import MkGraph+import Type+import RepType+import TysPrim+import CLabel+import SMRep+import ForeignCall+import DynFlags+import Maybes+import Outputable+import UniqSupply+import BasicTypes++import Control.Monad++-----------------------------------------------------------------------------+-- Code generation for Foreign Calls+-----------------------------------------------------------------------------++-- | emit code for a foreign call, and return the results to the sequel.+--+cgForeignCall :: ForeignCall            -- the op+              -> [StgArg]               -- x,y    arguments+              -> Type                   -- result type+              -> FCode ReturnKind++cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty+  = do  { dflags <- getDynFlags+        ; let -- in the stdcall calling convention, the symbol needs @size appended+              -- to it, where size is the total number of bytes of arguments.  We+              -- attach this info to the CLabel here, and the CLabel pretty printer+              -- will generate the suffix when the label is printed.+            call_size args+              | StdCallConv <- cconv = Just (sum (map arg_size args))+              | otherwise            = Nothing++              -- ToDo: this might not be correct for 64-bit API+            arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg)+                                     (wORD_SIZE dflags)+        ; cmm_args <- getFCallArgs stg_args+        ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty+        ; let ((call_args, arg_hints), cmm_target)+                = case target of+                   StaticTarget _ _   _      False ->+                       panic "cgForeignCall: unexpected FFI value import"+                   StaticTarget _ lbl mPkgId True+                     -> let labelSource+                                = case mPkgId of+                                        Nothing         -> ForeignLabelInThisPackage+                                        Just pkgId      -> ForeignLabelInPackage pkgId+                            size = call_size cmm_args+                        in  ( unzip cmm_args+                            , CmmLit (CmmLabel+                                        (mkForeignLabel lbl size labelSource IsFunction)))++                   DynamicTarget    ->  case cmm_args of+                                           (fn,_):rest -> (unzip rest, fn)+                                           [] -> panic "cgForeignCall []"+              fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn+              call_target = ForeignTarget cmm_target fc++        -- we want to emit code for the call, and then emitReturn.+        -- However, if the sequel is AssignTo, we shortcut a little+        -- and generate a foreign call that assigns the results+        -- directly.  Otherwise we end up generating a bunch of+        -- useless "r = r" assignments, which are not merely annoying:+        -- they prevent the common block elimination from working correctly+        -- in the case of a safe foreign call.+        -- See Note [safe foreign call convention]+        --+        ; sequel <- getSequel+        ; case sequel of+            AssignTo assign_to_these _ ->+                emitForeignCall safety assign_to_these call_target call_args++            _something_else ->+                do { _ <- emitForeignCall safety res_regs call_target call_args+                   ; emitReturn (map (CmmReg . CmmLocal) res_regs)+                   }+         }++{- Note [safe foreign call convention]++The simple thing to do for a safe foreign call would be the same as an+unsafe one: just++    emitForeignCall ...+    emitReturn ...++but consider what happens in this case++   case foo x y z of+     (# s, r #) -> ...++The sequel is AssignTo [r].  The call to newUnboxedTupleRegs picks [r]+as the result reg, and we generate++  r = foo(x,y,z) returns to L1  -- emitForeignCall+ L1:+  r = r  -- emitReturn+  goto L2+L2:+  ...++Now L1 is a proc point (by definition, it is the continuation of the+safe foreign call).  If L2 does a heap check, then L2 will also be a+proc point.++Furthermore, the stack layout algorithm has to arrange to save r+somewhere between the call and the jump to L1, which is annoying: we+would have to treat r differently from the other live variables, which+have to be saved *before* the call.++So we adopt a special convention for safe foreign calls: the results+are copied out according to the NativeReturn convention by the call,+and the continuation of the call should copyIn the results.  (The+copyOut code is actually inserted when the safe foreign call is+lowered later).  The result regs attached to the safe foreign call are+only used temporarily to hold the results before they are copied out.++We will now generate this:++  r = foo(x,y,z) returns to L1+ L1:+  r = R1  -- copyIn, inserted by mkSafeCall+  goto L2+ L2:+  ... r ...++And when the safe foreign call is lowered later (see Note [lower safe+foreign calls]) we get this:++  suspendThread()+  r = foo(x,y,z)+  resumeThread()+  R1 = r  -- copyOut, inserted by lowerSafeForeignCall+  jump L1+ L1:+  r = R1  -- copyIn, inserted by mkSafeCall+  goto L2+ L2:+  ... r ...++Now consider what happens if L2 does a heap check: the Adams+optimisation kicks in and commons up L1 with the heap-check+continuation, resulting in just one proc point instead of two. Yay!+-}+++emitCCall :: [(CmmFormal,ForeignHint)]+          -> CmmExpr+          -> [(CmmActual,ForeignHint)]+          -> FCode ()+emitCCall hinted_results fn hinted_args+  = void $ emitForeignCall PlayRisky results target args+  where+    (args, arg_hints) = unzip hinted_args+    (results, result_hints) = unzip hinted_results+    target = ForeignTarget fn fc+    fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn+++emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()+emitPrimCall res op args+  = void $ emitForeignCall PlayRisky res (PrimTarget op) args++-- alternative entry point, used by CmmParse+emitForeignCall+        :: Safety+        -> [CmmFormal]          -- where to put the results+        -> ForeignTarget        -- the op+        -> [CmmActual]          -- arguments+        -> FCode ReturnKind+emitForeignCall safety results target args+  | not (playSafe safety) = do+    dflags <- getDynFlags+    let (caller_save, caller_load) = callerSaveVolatileRegs dflags+    emit caller_save+    target' <- load_target_into_temp target+    args' <- mapM maybe_assign_temp args+    emit $ mkUnsafeCall target' results args'+    emit caller_load+    return AssignedDirectly++  | otherwise = do+    dflags <- getDynFlags+    updfr_off <- getUpdFrameOff+    target' <- load_target_into_temp target+    args' <- mapM maybe_assign_temp args+    k <- newBlockId+    let (off, _, copyout) = copyInOflow dflags NativeReturn (Young k) results []+       -- see Note [safe foreign call convention]+    tscope <- getTickScope+    emit $+           (    mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))+                        (CmmLit (CmmBlock k))+            <*> mkLast (CmmForeignCall { tgt  = target'+                                       , res  = results+                                       , args = args'+                                       , succ = k+                                       , ret_args = off+                                       , ret_off = updfr_off+                                       , intrbl = playInterruptible safety })+            <*> mkLabel k tscope+            <*> copyout+           )+    return (ReturnedTo k off)++load_target_into_temp :: ForeignTarget -> FCode ForeignTarget+load_target_into_temp (ForeignTarget expr conv) = do+  tmp <- maybe_assign_temp expr+  return (ForeignTarget tmp conv)+load_target_into_temp other_target@(PrimTarget _) =+  return other_target++-- What we want to do here is create a new temporary for the foreign+-- call argument if it is not safe to use the expression directly,+-- because the expression mentions caller-saves GlobalRegs (see+-- Note [Register Parameter Passing]).+--+-- However, we can't pattern-match on the expression here, because+-- this is used in a loop by CmmParse, and testing the expression+-- results in a black hole.  So we always create a temporary, and rely+-- on CmmSink to clean it up later.  (Yuck, ToDo).  The generated code+-- ends up being the same, at least for the RTS .cmm code.+--+maybe_assign_temp :: CmmExpr -> FCode CmmExpr+maybe_assign_temp e = do+  dflags <- getDynFlags+  reg <- newTemp (cmmExprType dflags e)+  emitAssign (CmmLocal reg) e+  return (CmmReg (CmmLocal reg))++-- -----------------------------------------------------------------------------+-- Save/restore the thread state in the TSO++-- This stuff can't be done in suspendThread/resumeThread, because it+-- refers to global registers which aren't available in the C world.++emitSaveThreadState :: FCode ()+emitSaveThreadState = do+  dflags <- getDynFlags+  code <- saveThreadState dflags+  emit code++-- | Produce code to save the current thread state to @CurrentTSO@+saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph+saveThreadState dflags = do+  tso <- newTemp (gcWord dflags)+  close_nursery <- closeNursery dflags tso+  pure $ catAGraphs [+    -- tso = CurrentTSO;+    mkAssign (CmmLocal tso) currentTSOExpr,+    -- tso->stackobj->sp = Sp;+    mkStore (cmmOffset dflags+                       (CmmLoad (cmmOffset dflags+                                           (CmmReg (CmmLocal tso))+                                           (tso_stackobj dflags))+                                (bWord dflags))+                       (stack_SP dflags))+            spExpr,+    close_nursery,+    -- and save the current cost centre stack in the TSO when profiling:+    if gopt Opt_SccProfilingOn dflags then+        mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr+      else mkNop+    ]++emitCloseNursery :: FCode ()+emitCloseNursery = do+  dflags <- getDynFlags+  tso <- newTemp (bWord dflags)+  code <- closeNursery dflags tso+  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code++{- |+@closeNursery dflags tso@ produces code to close the nursery.+A local register holding the value of @CurrentTSO@ is expected for+efficiency.++Closing the nursery corresponds to the following code:++@+  tso = CurrentTSO;+  cn = CurrentNuresry;++  // Update the allocation limit for the current thread.  We don't+  // check to see whether it has overflowed at this point, that check is+  // made when we run out of space in the current heap block (stg_gc_noregs)+  // and in the scheduler when context switching (schedulePostRunThread).+  tso->alloc_limit -= Hp + WDS(1) - cn->start;++  // Set cn->free to the next unoccupied word in the block+  cn->free = Hp + WDS(1);+@+-}+closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph+closeNursery df tso = do+  let tsoreg  = CmmLocal tso+  cnreg      <- CmmLocal <$> newTemp (bWord df)+  pure $ catAGraphs [+    mkAssign cnreg currentNurseryExpr,++    -- CurrentNursery->free = Hp+1;+    mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df hpExpr 1),++    let alloc =+           CmmMachOp (mo_wordSub df)+              [ cmmOffsetW df hpExpr 1+              , CmmLoad (nursery_bdescr_start df cnreg) (bWord df)+              ]++        alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)+    in++    -- tso->alloc_limit += alloc+    mkStore alloc_limit (CmmMachOp (MO_Sub W64)+                               [ CmmLoad alloc_limit b64+                               , CmmMachOp (mo_WordTo64 df) [alloc] ])+   ]++emitLoadThreadState :: FCode ()+emitLoadThreadState = do+  dflags <- getDynFlags+  code <- loadThreadState dflags+  emit code++-- | Produce code to load the current thread state from @CurrentTSO@+loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph+loadThreadState dflags = do+  tso <- newTemp (gcWord dflags)+  stack <- newTemp (gcWord dflags)+  open_nursery <- openNursery dflags tso+  pure $ catAGraphs [+    -- tso = CurrentTSO;+    mkAssign (CmmLocal tso) currentTSOExpr,+    -- stack = tso->stackobj;+    mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),+    -- Sp = stack->sp;+    mkAssign spReg (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),+    -- SpLim = stack->stack + RESERVED_STACK_WORDS;+    mkAssign spLimReg (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))+                                (rESERVED_STACK_WORDS dflags)),+    -- HpAlloc = 0;+    --   HpAlloc is assumed to be set to non-zero only by a failed+    --   a heap check, see HeapStackCheck.cmm:GC_GENERIC+    mkAssign hpAllocReg (zeroExpr dflags),+    open_nursery,+    -- and load the current cost centre stack from the TSO when profiling:+    if gopt Opt_SccProfilingOn dflags+       then storeCurCCS+              (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso))+                 (tso_CCCS dflags)) (ccsType dflags))+       else mkNop+   ]+++emitOpenNursery :: FCode ()+emitOpenNursery = do+  dflags <- getDynFlags+  tso <- newTemp (bWord dflags)+  code <- openNursery dflags tso+  emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code++{- |+@openNursery dflags tso@ produces code to open the nursery. A local register+holding the value of @CurrentTSO@ is expected for efficiency.++Opening the nursery corresponds to the following code:++@+   tso = CurrentTSO;+   cn = CurrentNursery;+   bdfree = CurrentNursery->free;+   bdstart = CurrentNursery->start;++   // We *add* the currently occupied portion of the nursery block to+   // the allocation limit, because we will subtract it again in+   // closeNursery.+   tso->alloc_limit += bdfree - bdstart;++   // Set Hp to the last occupied word of the heap block.  Why not the+   // next unocupied word?  Doing it this way means that we get to use+   // an offset of zero more often, which might lead to slightly smaller+   // code on some architectures.+   Hp = bdfree - WDS(1);++   // Set HpLim to the end of the current nursery block (note that this block+   // might be a block group, consisting of several adjacent blocks.+   HpLim = bdstart + CurrentNursery->blocks*BLOCK_SIZE_W - 1;+@+-}+openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph+openNursery df tso = do+  let tsoreg =  CmmLocal tso+  cnreg      <- CmmLocal <$> newTemp (bWord df)+  bdfreereg  <- CmmLocal <$> newTemp (bWord df)+  bdstartreg <- CmmLocal <$> newTemp (bWord df)++  -- These assignments are carefully ordered to reduce register+  -- pressure and generate not completely awful code on x86.  To see+  -- what code we generate, look at the assembly for+  -- stg_returnToStackTop in rts/StgStartup.cmm.+  pure $ catAGraphs [+     mkAssign cnreg currentNurseryExpr,+     mkAssign bdfreereg  (CmmLoad (nursery_bdescr_free df cnreg)  (bWord df)),++     -- Hp = CurrentNursery->free - 1;+     mkAssign hpReg (cmmOffsetW df (CmmReg bdfreereg) (-1)),++     mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)),++     -- HpLim = CurrentNursery->start ++     --              CurrentNursery->blocks*BLOCK_SIZE_W - 1;+     mkAssign hpLimReg+         (cmmOffsetExpr df+             (CmmReg bdstartreg)+             (cmmOffset df+               (CmmMachOp (mo_wordMul df) [+                 CmmMachOp (MO_SS_Conv W32 (wordWidth df))+                   [CmmLoad (nursery_bdescr_blocks df cnreg) b32],+                 mkIntExpr df (bLOCK_SIZE df)+                ])+               (-1)+             )+         ),++     -- alloc = bd->free - bd->start+     let alloc =+           CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg]++         alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)+     in++     -- tso->alloc_limit += alloc+     mkStore alloc_limit (CmmMachOp (MO_Add W64)+                               [ CmmLoad alloc_limit b64+                               , CmmMachOp (mo_WordTo64 df) [alloc] ])++   ]++nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks+  :: DynFlags -> CmmReg -> CmmExpr+nursery_bdescr_free   dflags cn =+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags)+nursery_bdescr_start  dflags cn =+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags)+nursery_bdescr_blocks dflags cn =+  cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_blocks dflags)++tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff+tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags)+tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags)+tso_CCCS     dflags = closureField dflags (oFFSET_StgTSO_cccs dflags)+stack_STACK  dflags = closureField dflags (oFFSET_StgStack_stack dflags)+stack_SP     dflags = closureField dflags (oFFSET_StgStack_sp dflags)+++closureField :: DynFlags -> ByteOff -> ByteOff+closureField dflags off = off + fixedHdrSize dflags++-- -----------------------------------------------------------------------------+-- For certain types passed to foreign calls, we adjust the actual+-- value passed to the call.  For ByteArray#/Array# we pass the+-- address of the actual array, not the address of the heap object.++getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]+-- (a) Drop void args+-- (b) Add foreign-call shim code+-- It's (b) that makes this differ from getNonVoidArgAmodes++getFCallArgs args+  = do  { mb_cmms <- mapM get args+        ; return (catMaybes mb_cmms) }+  where+    get arg | null arg_reps+            = return Nothing+            | otherwise+            = do { cmm <- getArgAmode (NonVoid arg)+                 ; dflags <- getDynFlags+                 ; return (Just (add_shim dflags arg_ty cmm, hint)) }+            where+              arg_ty   = stgArgType arg+              arg_reps = typePrimRep arg_ty+              hint     = typeForeignHint arg_ty++add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr+add_shim dflags arg_ty expr+  | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon+  = cmmOffsetB dflags expr (arrPtrsHdrSize dflags)++  | tycon == smallArrayPrimTyCon || tycon == smallMutableArrayPrimTyCon+  = cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)++  | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon+  = cmmOffsetB dflags expr (arrWordsHdrSize dflags)++  | otherwise = expr+  where+    tycon           = tyConAppTyCon (unwrapType arg_ty)+        -- should be a tycon app, since this is a foreign call
+ compiler/codeGen/StgCmmHeap.hs view
@@ -0,0 +1,680 @@+-----------------------------------------------------------------------------+--+-- Stg to C--: heap management functions+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmHeap (+        getVirtHp, setVirtHp, setRealHp,+        getHpRelOffset,++        entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo,+        heapStackCheckGen,+        entryHeapCheck',++        mkStaticClosureFields, mkStaticClosure,++        allocDynClosure, allocDynClosureCmm, allocHeapClosure,+        emitSetDynHdr+    ) where++import GhcPrelude hiding ((<*>))++import StgSyn+import CLabel+import StgCmmLayout+import StgCmmUtils+import StgCmmMonad+import StgCmmProf (profDynAlloc, dynProfHdr, staticProfHdr)+import StgCmmTicky+import StgCmmClosure+import StgCmmEnv++import MkGraph++import Hoopl.Label+import SMRep+import BlockId+import Cmm+import CmmUtils+import CostCentre+import IdInfo( CafInfo(..), mayHaveCafRefs )+import Id ( Id )+import Module+import DynFlags+import FastString( mkFastString, fsLit )+import Panic( sorry )++import Control.Monad (when)+import Data.Maybe (isJust)++-----------------------------------------------------------+--              Initialise dynamic heap objects+-----------------------------------------------------------++allocDynClosure+        :: Maybe Id+        -> CmmInfoTable+        -> LambdaFormInfo+        -> CmmExpr              -- Cost Centre to stick in the object+        -> CmmExpr              -- Cost Centre to blame for this alloc+                                -- (usually the same; sometimes "OVERHEAD")++        -> [(NonVoid StgArg, VirtualHpOffset)]  -- Offsets from start of object+                                                -- ie Info ptr has offset zero.+                                                -- No void args in here+        -> FCode CmmExpr -- returns Hp+n++allocDynClosureCmm+        :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr+        -> [(CmmExpr, ByteOff)]+        -> FCode CmmExpr -- returns Hp+n++-- allocDynClosure allocates the thing in the heap,+-- and modifies the virtual Hp to account for this.+-- The second return value is the graph that sets the value of the+-- returned LocalReg, which should point to the closure after executing+-- the graph.++-- allocDynClosure returns an (Hp+8) CmmExpr, and hence the result is+-- only valid until Hp is changed.  The caller should assign the+-- result to a LocalReg if it is required to remain live.+--+-- The reason we don't assign it to a LocalReg here is that the caller+-- is often about to call regIdInfo, which immediately assigns the+-- result of allocDynClosure to a new temp in order to add the tag.+-- So by not generating a LocalReg here we avoid a common source of+-- new temporaries and save some compile time.  This can be quite+-- significant - see test T4801.+++allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets = do+  let (args, offsets) = unzip args_w_offsets+  cmm_args <- mapM getArgAmode args     -- No void args+  allocDynClosureCmm mb_id info_tbl lf_info+                     use_cc _blame_cc (zip cmm_args offsets)+++allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets = do+  -- SAY WHAT WE ARE ABOUT TO DO+  let rep = cit_rep info_tbl+  tickyDynAlloc mb_id rep lf_info+  let info_ptr = CmmLit (CmmLabel (cit_lbl info_tbl))+  allocHeapClosure rep info_ptr use_cc amodes_w_offsets+++-- | Low-level heap object allocation.+allocHeapClosure+  :: SMRep                            -- ^ representation of the object+  -> CmmExpr                          -- ^ info pointer+  -> CmmExpr                          -- ^ cost centre+  -> [(CmmExpr,ByteOff)]              -- ^ payload+  -> FCode CmmExpr                    -- ^ returns the address of the object+allocHeapClosure rep info_ptr use_cc payload = do+  profDynAlloc rep use_cc++  virt_hp <- getVirtHp++  -- Find the offset of the info-ptr word+  let info_offset = virt_hp + 1+            -- info_offset is the VirtualHpOffset of the first+            -- word of the new object+            -- Remember, virtHp points to last allocated word,+            -- ie 1 *before* the info-ptr word of new object.++  base <- getHpRelOffset info_offset+  emitComment $ mkFastString "allocHeapClosure"+  emitSetDynHdr base info_ptr use_cc++  -- Fill in the fields+  hpStore base payload++  -- Bump the virtual heap pointer+  dflags <- getDynFlags+  setVirtHp (virt_hp + heapClosureSizeW dflags rep)++  return base+++emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()+emitSetDynHdr base info_ptr ccs+  = do dflags <- getDynFlags+       hpStore base (zip (header dflags) [0, wORD_SIZE dflags ..])+  where+    header :: DynFlags -> [CmmExpr]+    header dflags = [info_ptr] ++ dynProfHdr dflags ccs+        -- ToDo: Parallel stuff+        -- No ticky header++-- Store the item (expr,off) in base[off]+hpStore :: CmmExpr -> [(CmmExpr, ByteOff)] -> FCode ()+hpStore base vals = do+  dflags <- getDynFlags+  sequence_ $+    [ emitStore (cmmOffsetB dflags base off) val | (val,off) <- vals ]++-----------------------------------------------------------+--              Layout of static closures+-----------------------------------------------------------++-- Make a static closure, adding on any extra padding needed for CAFs,+-- and adding a static link field if necessary.++mkStaticClosureFields+        :: DynFlags+        -> CmmInfoTable+        -> CostCentreStack+        -> CafInfo+        -> [CmmLit]             -- Payload+        -> [CmmLit]             -- The full closure+mkStaticClosureFields dflags info_tbl ccs caf_refs payload+  = mkStaticClosure dflags info_lbl ccs payload padding+        static_link_field saved_info_field+  where+    info_lbl = cit_lbl info_tbl++    -- CAFs must have consistent layout, regardless of whether they+    -- are actually updatable or not.  The layout of a CAF is:+    --+    --        3 saved_info+    --        2 static_link+    --        1 indirectee+    --        0 info ptr+    --+    -- the static_link and saved_info fields must always be in the+    -- same place.  So we use isThunkRep rather than closureUpdReqd+    -- here:++    is_caf = isThunkRep (cit_rep info_tbl)++    padding+        | is_caf && null payload = [mkIntCLit dflags 0]+        | otherwise = []++    static_link_field+        | is_caf || staticClosureNeedsLink (mayHaveCafRefs caf_refs) info_tbl+        = [static_link_value]+        | otherwise+        = []++    saved_info_field+        | is_caf     = [mkIntCLit dflags 0]+        | otherwise  = []++        -- For a static constructor which has NoCafRefs, we set the+        -- static link field to a non-zero value so the garbage+        -- collector will ignore it.+    static_link_value+        | mayHaveCafRefs caf_refs  = mkIntCLit dflags 0+        | otherwise                = mkIntCLit dflags 3  -- No CAF refs+                                      -- See Note [STATIC_LINK fields]+                                      -- in rts/sm/Storage.h++mkStaticClosure :: DynFlags -> CLabel -> CostCentreStack -> [CmmLit]+  -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]+mkStaticClosure dflags info_lbl ccs payload padding static_link_field saved_info_field+  =  [CmmLabel info_lbl]+  ++ staticProfHdr dflags ccs+  ++ payload+  ++ padding+  ++ static_link_field+  ++ saved_info_field++-----------------------------------------------------------+--              Heap overflow checking+-----------------------------------------------------------++{- Note [Heap checks]+   ~~~~~~~~~~~~~~~~~~+Heap checks come in various forms.  We provide the following entry+points to the runtime system, all of which use the native C-- entry+convention.++  * gc() performs garbage collection and returns+    nothing to its caller++  * A series of canned entry points like+        r = gc_1p( r )+    where r is a pointer.  This performs gc, and+    then returns its argument r to its caller.++  * A series of canned entry points like+        gcfun_2p( f, x, y )+    where f is a function closure of arity 2+    This performs garbage collection, keeping alive the+    three argument ptrs, and then tail-calls f(x,y)++These are used in the following circumstances++* entryHeapCheck: Function entry+    (a) With a canned GC entry sequence+        f( f_clo, x:ptr, y:ptr ) {+             Hp = Hp+8+             if Hp > HpLim goto L+             ...+          L: HpAlloc = 8+             jump gcfun_2p( f_clo, x, y ) }+     Note the tail call to the garbage collector;+     it should do no register shuffling++    (b) No canned sequence+        f( f_clo, x:ptr, y:ptr, ...etc... ) {+          T: Hp = Hp+8+             if Hp > HpLim goto L+             ...+          L: HpAlloc = 8+             call gc()  -- Needs an info table+             goto T }++* altHeapCheck: Immediately following an eval+  Started as+        case f x y of r { (p,q) -> rhs }+  (a) With a canned sequence for the results of f+       (which is the very common case since+       all boxed cases return just one pointer+           ...+           r = f( x, y )+        K:      -- K needs an info table+           Hp = Hp+8+           if Hp > HpLim goto L+           ...code for rhs...++        L: r = gc_1p( r )+           goto K }++        Here, the info table needed by the call+        to gc_1p should be the *same* as the+        one for the call to f; the C-- optimiser+        spots this sharing opportunity)++   (b) No canned sequence for results of f+       Note second info table+           ...+           (r1,r2,r3) = call f( x, y )+        K:+           Hp = Hp+8+           if Hp > HpLim goto L+           ...code for rhs...++        L: call gc()    -- Extra info table here+           goto K++* generalHeapCheck: Anywhere else+  e.g. entry to thunk+       case branch *not* following eval,+       or let-no-escape+  Exactly the same as the previous case:++        K:      -- K needs an info table+           Hp = Hp+8+           if Hp > HpLim goto L+           ...++        L: call gc()+           goto K+-}++--------------------------------------------------------------+-- A heap/stack check at a function or thunk entry point.++entryHeapCheck :: ClosureInfo+               -> Maybe LocalReg -- Function (closure environment)+               -> Int            -- Arity -- not same as len args b/c of voids+               -> [LocalReg]     -- Non-void args (empty for thunk)+               -> FCode ()+               -> FCode ()++entryHeapCheck cl_info nodeSet arity args code+  = entryHeapCheck' is_fastf node arity args code+  where+    node = case nodeSet of+              Just r  -> CmmReg (CmmLocal r)+              Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)++    is_fastf = case closureFunInfo cl_info of+                 Just (_, ArgGen _) -> False+                 _otherwise         -> True++-- | lower-level version for CmmParse+entryHeapCheck' :: Bool           -- is a known function pattern+                -> CmmExpr        -- expression for the closure pointer+                -> Int            -- Arity -- not same as len args b/c of voids+                -> [LocalReg]     -- Non-void args (empty for thunk)+                -> FCode ()+                -> FCode ()+entryHeapCheck' is_fastf node arity args code+  = do dflags <- getDynFlags+       let is_thunk = arity == 0++           args' = map (CmmReg . CmmLocal) args+           stg_gc_fun    = CmmReg (CmmGlobal GCFun)+           stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)++           {- Thunks:          jump stg_gc_enter_1++              Function (fast): call (NativeNode) stg_gc_fun(fun, args)++              Function (slow): call (slow) stg_gc_fun(fun, args)+           -}+           gc_call upd+               | is_thunk+                 = mkJump dflags NativeNodeCall stg_gc_enter1 [node] upd++               | is_fastf+                 = mkJump dflags NativeNodeCall stg_gc_fun (node : args') upd++               | otherwise+                 = mkJump dflags Slow stg_gc_fun (node : args') upd++       updfr_sz <- getUpdFrameOff++       loop_id <- newBlockId+       emitLabel loop_id+       heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code++-- ------------------------------------------------------------+-- A heap/stack check in a case alternative+++-- If there are multiple alts and we need to GC, but don't have a+-- continuation already (the scrut was simple), then we should+-- pre-generate the continuation.  (if there are multiple alts it is+-- always a canned GC point).++-- altHeapCheck:+-- If we have a return continuation,+--   then if it is a canned GC pattern,+--           then we do mkJumpReturnsTo+--           else we do a normal call to stg_gc_noregs+--   else if it is a canned GC pattern,+--           then generate the continuation and do mkCallReturnsTo+--           else we do a normal call to stg_gc_noregs++altHeapCheck :: [LocalReg] -> FCode a -> FCode a+altHeapCheck regs code = altOrNoEscapeHeapCheck False regs code++altOrNoEscapeHeapCheck :: Bool -> [LocalReg] -> FCode a -> FCode a+altOrNoEscapeHeapCheck checkYield regs code = do+    dflags <- getDynFlags+    case cannedGCEntryPoint dflags regs of+      Nothing -> genericGC checkYield code+      Just gc -> do+        lret <- newBlockId+        let (off, _, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []+        lcont <- newBlockId+        tscope <- getTickScope+        emitOutOfLine lret (copyin <*> mkBranch lcont, tscope)+        emitLabel lcont+        cannedGCReturnsTo checkYield False gc regs lret off code++altHeapCheckReturnsTo :: [LocalReg] -> Label -> ByteOff -> FCode a -> FCode a+altHeapCheckReturnsTo regs lret off code+  = do dflags <- getDynFlags+       case cannedGCEntryPoint dflags regs of+           Nothing -> genericGC False code+           Just gc -> cannedGCReturnsTo False True gc regs lret off code++-- noEscapeHeapCheck is implemented identically to altHeapCheck (which+-- is more efficient), but cannot be optimized away in the non-allocating+-- case because it may occur in a loop+noEscapeHeapCheck :: [LocalReg] -> FCode a -> FCode a+noEscapeHeapCheck regs code = altOrNoEscapeHeapCheck True regs code++cannedGCReturnsTo :: Bool -> Bool -> CmmExpr -> [LocalReg] -> Label -> ByteOff+                  -> FCode a+                  -> FCode a+cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code+  = do dflags <- getDynFlags+       updfr_sz <- getUpdFrameOff+       heapCheck False checkYield (gc_call dflags gc updfr_sz) code+  where+    reg_exprs = map (CmmReg . CmmLocal) regs+      -- Note [stg_gc arguments]++      -- NB. we use the NativeReturn convention for passing arguments+      -- to the canned heap-check routines, because we are in a case+      -- alternative and hence the [LocalReg] was passed to us in the+      -- NativeReturn convention.+    gc_call dflags label sp+      | cont_on_stack+      = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp+      | otherwise+      = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp []++genericGC :: Bool -> FCode a -> FCode a+genericGC checkYield code+  = do updfr_sz <- getUpdFrameOff+       lretry <- newBlockId+       emitLabel lretry+       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []+       heapCheck False checkYield (call <*> mkBranch lretry) code++cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr+cannedGCEntryPoint dflags regs+  = case map localRegType regs of+      []  -> Just (mkGcLabel "stg_gc_noregs")+      [ty]+          | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1")+          | isFloatType ty -> case width of+                                  W32       -> Just (mkGcLabel "stg_gc_f1")+                                  W64       -> Just (mkGcLabel "stg_gc_d1")+                                  _         -> Nothing++          | width == wordWidth dflags -> Just (mkGcLabel "stg_gc_unbx_r1")+          | width == W64              -> Just (mkGcLabel "stg_gc_l1")+          | otherwise                 -> Nothing+          where+              width = typeWidth ty+      [ty1,ty2]+          |  isGcPtrType ty1+          && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp")+      [ty1,ty2,ty3]+          |  isGcPtrType ty1+          && isGcPtrType ty2+          && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp")+      [ty1,ty2,ty3,ty4]+          |  isGcPtrType ty1+          && isGcPtrType ty2+          && isGcPtrType ty3+          && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp")+      _otherwise -> Nothing++-- Note [stg_gc arguments]+-- It might seem that we could avoid passing the arguments to the+-- stg_gc function, because they are already in the right registers.+-- While this is usually the case, it isn't always.  Sometimes the+-- code generator has cleverly avoided the eval in a case, e.g. in+-- ffi/should_run/4221.hs we found+--+--   case a_r1mb of z+--     FunPtr x y -> ...+--+-- where a_r1mb is bound a top-level constructor, and is known to be+-- evaluated.  The codegen just assigns x, y and z, and continues;+-- R1 is never assigned.+--+-- So we'll have to rely on optimisations to eliminatethese+-- assignments where possible.+++-- | The generic GC procedure; no params, no results+generic_gc :: CmmExpr+generic_gc = mkGcLabel "stg_gc_noregs"++-- | Create a CLabel for calling a garbage collector entry point+mkGcLabel :: String -> CmmExpr+mkGcLabel s = CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit s)))++-------------------------------+heapCheck :: Bool -> Bool -> CmmAGraph -> FCode a -> FCode a+heapCheck checkStack checkYield do_gc code+  = getHeapUsage $ \ hpHw ->+    -- Emit heap checks, but be sure to do it lazily so+    -- that the conditionals on hpHw don't cause a black hole+    do  { dflags <- getDynFlags+        ; let mb_alloc_bytes+                 | hpHw > mBLOCK_SIZE = sorry $ unlines+                    [" Trying to allocate more than "++show mBLOCK_SIZE++" bytes.",+                     "",+                     "This is currently not possible due to a limitation of GHC's code generator.",+                     "See https://gitlab.haskell.org/ghc/ghc/issues/4505 for details.",+                     "Suggestion: read data from a file instead of having large static data",+                     "structures in code."]+                 | hpHw > 0  = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags)))+                 | otherwise = Nothing+                 where mBLOCK_SIZE = bLOCKS_PER_MBLOCK dflags * bLOCK_SIZE_W dflags+              stk_hwm | checkStack = Just (CmmLit CmmHighStackMark)+                      | otherwise  = Nothing+        ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc+        ; tickyAllocHeap True hpHw+        ; setRealHp hpHw+        ; code }++heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()+heapStackCheckGen stk_hwm mb_bytes+  = do updfr_sz <- getUpdFrameOff+       lretry <- newBlockId+       emitLabel lretry+       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []+       do_checks stk_hwm False mb_bytes (call <*> mkBranch lretry)++-- Note [Single stack check]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- When compiling a function we can determine how much stack space it+-- will use. We therefore need to perform only a single stack check at+-- the beginning of a function to see if we have enough stack space.+--+-- The check boils down to comparing Sp-N with SpLim, where N is the+-- amount of stack space needed (see Note [Stack usage] below).  *BUT*+-- at this stage of the pipeline we are not supposed to refer to Sp+-- itself, because the stack is not yet manifest, so we don't quite+-- know where Sp pointing.++-- So instead of referring directly to Sp - as we used to do in the+-- past - the code generator uses (old + 0) in the stack check. That+-- is the address of the first word of the old area, so if we add N+-- we'll get the address of highest used word.+--+-- This makes the check robust.  For example, while we need to perform+-- only one stack check for each function, we could in theory place+-- more stack checks later in the function. They would be redundant,+-- but not incorrect (in a sense that they should not change program+-- behaviour). We need to make sure however that a stack check+-- inserted after incrementing the stack pointer checks for a+-- respectively smaller stack space. This would not be the case if the+-- code generator produced direct references to Sp. By referencing+-- (old + 0) we make sure that we always check for a correct amount of+-- stack: when converting (old + 0) to Sp the stack layout phase takes+-- into account changes already made to stack pointer. The idea for+-- this change came from observations made while debugging #8275.++-- Note [Stack usage]+-- ~~~~~~~~~~~~~~~~~~+-- At the moment we convert from STG to Cmm we don't know N, the+-- number of bytes of stack that the function will use, so we use a+-- special late-bound CmmLit, namely+--       CmmHighStackMark+-- to stand for the number of bytes needed. When the stack is made+-- manifest, the number of bytes needed is calculated, and used to+-- replace occurrences of CmmHighStackMark+--+-- The (Maybe CmmExpr) passed to do_checks is usually+--     Just (CmmLit CmmHighStackMark)+-- but can also (in certain hand-written RTS functions)+--     Just (CmmLit 8)  or some other fixed valuet+-- If it is Nothing, we don't generate a stack check at all.++do_checks :: Maybe CmmExpr    -- Should we check the stack?+                              -- See Note [Stack usage]+          -> Bool             -- Should we check for preemption?+          -> Maybe CmmExpr    -- Heap headroom (bytes)+          -> CmmAGraph        -- What to do on failure+          -> FCode ()+do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do+  dflags <- getDynFlags+  gc_id <- newBlockId++  let+    Just alloc_lit = mb_alloc_lit++    bump_hp   = cmmOffsetExprB dflags hpExpr alloc_lit++    -- Sp overflow if ((old + 0) - CmmHighStack < SpLim)+    -- At the beginning of a function old + 0 = Sp+    -- See Note [Single stack check]+    sp_oflo sp_hwm =+         CmmMachOp (mo_wordULt dflags)+                  [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg)))+                             [CmmStackSlot Old 0, sp_hwm],+                   CmmReg spLimReg]++    -- Hp overflow if (Hp > HpLim)+    -- (Hp has been incremented by now)+    -- HpLim points to the LAST WORD of valid allocation space.+    hp_oflo = CmmMachOp (mo_wordUGt dflags) [hpExpr, hpLimExpr]++    alloc_n = mkAssign hpAllocReg alloc_lit++  case mb_stk_hwm of+    Nothing -> return ()+    Just stk_hwm -> tickyStackCheck+      >> (emit =<< mkCmmIfGoto' (sp_oflo stk_hwm) gc_id (Just False) )++  -- Emit new label that might potentially be a header+  -- of a self-recursive tail call.+  -- See Note [Self-recursive loop header].+  self_loop_info <- getSelfLoop+  case self_loop_info of+    Just (_, loop_header_id, _)+        | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id+    _otherwise -> return ()++  if (isJust mb_alloc_lit)+    then do+     tickyHeapCheck+     emitAssign hpReg bump_hp+     emit =<< mkCmmIfThen' hp_oflo (alloc_n <*> mkBranch gc_id) (Just False)+    else do+      when (checkYield && not (gopt Opt_OmitYields dflags)) $ do+         -- Yielding if HpLim == 0+         let yielding = CmmMachOp (mo_wordEq dflags)+                                  [CmmReg hpLimReg,+                                   CmmLit (zeroCLit dflags)]+         emit =<< mkCmmIfGoto' yielding gc_id (Just False)++  tscope <- getTickScope+  emitOutOfLine gc_id+   (do_gc, tscope) -- this is expected to jump back somewhere++                -- Test for stack pointer exhaustion, then+                -- bump heap pointer, and test for heap exhaustion+                -- Note that we don't move the heap pointer unless the+                -- stack check succeeds.  Otherwise we might end up+                -- with slop at the end of the current block, which can+                -- confuse the LDV profiler.++-- Note [Self-recursive loop header]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Self-recursive loop header is required by loopification optimization (See+-- Note [Self-recursive tail calls] in StgCmmExpr). We emit it if:+--+--  1. There is information about self-loop in the FCode environment. We don't+--     check the binder (first component of the self_loop_info) because we are+--     certain that if the self-loop info is present then we are compiling the+--     binder body. Reason: the only possible way to get here with the+--     self_loop_info present is from closureCodeBody.+--+--  2. checkYield && isJust mb_stk_hwm. checkYield tells us that it is possible+--     to preempt the heap check (see #367 for motivation behind this check). It+--     is True for heap checks placed at the entry to a function and+--     let-no-escape heap checks but false for other heap checks (eg. in case+--     alternatives or created from hand-written high-level Cmm). The second+--     check (isJust mb_stk_hwm) is true for heap checks at the entry to a+--     function and some heap checks created in hand-written Cmm. Otherwise it+--     is Nothing. In other words the only situation when both conditions are+--     true is when compiling stack and heap checks at the entry to a+--     function. This is the only situation when we want to emit a self-loop+--     label.
+ compiler/codeGen/StgCmmHpc.hs view
@@ -0,0 +1,48 @@+-----------------------------------------------------------------------------+--+-- Code generation for coverage+--+-- (c) Galois Connections, Inc. 2006+--+-----------------------------------------------------------------------------++module StgCmmHpc ( initHpc, mkTickBox ) where++import GhcPrelude++import StgCmmMonad++import MkGraph+import CmmExpr+import CLabel+import Module+import CmmUtils+import StgCmmUtils+import HscTypes+import DynFlags++import Control.Monad++mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph+mkTickBox dflags mod n+  = mkStore tick_box (CmmMachOp (MO_Add W64)+                                [ CmmLoad tick_box b64+                                , CmmLit (CmmInt 1 W64)+                                ])+  where+    tick_box = cmmIndex dflags W64+                        (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod)+                        n++initHpc :: Module -> HpcInfo -> FCode ()+-- Emit top-level tables for HPC and return code to initialise+initHpc _ (NoHpcInfo {})+  = return ()+initHpc this_mod (HpcInfo tickCount _hashNo)+  = do dflags <- getDynFlags+       when (gopt Opt_Hpc dflags) $+           do emitDataLits (mkHpcTicksLabel this_mod)+                           [ (CmmInt 0 W64)+                           | _ <- take tickCount [0 :: Int ..]+                           ]+
+ compiler/codeGen/StgCmmLayout.hs view
@@ -0,0 +1,623 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Building info tables.+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmLayout (+        mkArgDescr,+        emitCall, emitReturn, adjustHpBackwards,++        emitClosureProcAndInfoTable,+        emitClosureAndInfoTable,++        slowCall, directCall,++        FieldOffOrPadding(..),+        ClosureHeader(..),+        mkVirtHeapOffsets,+        mkVirtHeapOffsetsWithPadding,+        mkVirtConstrOffsets,+        mkVirtConstrSizes,+        getHpRelOffset,++        ArgRep(..), toArgRep, argRepSizeW -- re-exported from StgCmmArgRep+  ) where+++#include "HsVersions.h"++import GhcPrelude hiding ((<*>))++import StgCmmClosure+import StgCmmEnv+import StgCmmArgRep -- notably: ( slowCallPattern )+import StgCmmTicky+import StgCmmMonad+import StgCmmUtils++import MkGraph+import SMRep+import BlockId+import Cmm+import CmmUtils+import CmmInfo+import CLabel+import StgSyn+import Id+import TyCon             ( PrimRep(..), primRepSizeB )+import BasicTypes        ( RepArity )+import DynFlags+import Module++import Util+import Data.List+import Outputable+import FastString+import Control.Monad++------------------------------------------------------------------------+--                Call and return sequences+------------------------------------------------------------------------++-- | Return multiple values to the sequel+--+-- If the sequel is @Return@+--+-- >     return (x,y)+--+-- If the sequel is @AssignTo [p,q]@+--+-- >    p=x; q=y;+--+emitReturn :: [CmmExpr] -> FCode ReturnKind+emitReturn results+  = do { dflags    <- getDynFlags+       ; sequel    <- getSequel+       ; updfr_off <- getUpdFrameOff+       ; case sequel of+           Return ->+             do { adjustHpBackwards+                ; let e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)+                ; emit (mkReturn dflags (entryCode dflags e) results updfr_off)+                }+           AssignTo regs adjust ->+             do { when adjust adjustHpBackwards+                ; emitMultiAssign  regs results }+       ; return AssignedDirectly+       }+++-- | @emitCall conv fun args@ makes a call to the entry-code of @fun@,+-- using the call/return convention @conv@, passing @args@, and+-- returning the results to the current sequel.+--+emitCall :: (Convention, Convention) -> CmmExpr -> [CmmExpr] -> FCode ReturnKind+emitCall convs fun args+  = emitCallWithExtraStack convs fun args noExtraStack+++-- | @emitCallWithExtraStack conv fun args stack@ makes a call to the+-- entry-code of @fun@, using the call/return convention @conv@,+-- passing @args@, pushing some extra stack frames described by+-- @stack@, and returning the results to the current sequel.+--+emitCallWithExtraStack+   :: (Convention, Convention) -> CmmExpr -> [CmmExpr]+   -> [CmmExpr] -> FCode ReturnKind+emitCallWithExtraStack (callConv, retConv) fun args extra_stack+  = do  { dflags <- getDynFlags+        ; adjustHpBackwards+        ; sequel <- getSequel+        ; updfr_off <- getUpdFrameOff+        ; case sequel of+            Return -> do+              emit $ mkJumpExtra dflags callConv fun args updfr_off extra_stack+              return AssignedDirectly+            AssignTo res_regs _ -> do+              k <- newBlockId+              let area = Young k+                  (off, _, copyin) = copyInOflow dflags retConv area res_regs []+                  copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off+                                   extra_stack+              tscope <- getTickScope+              emit (copyout <*> mkLabel k tscope <*> copyin)+              return (ReturnedTo k off)+      }+++adjustHpBackwards :: FCode ()+-- This function adjusts the heap pointer just before a tail call or+-- return.  At a call or return, the virtual heap pointer may be less+-- than the real Hp, because the latter was advanced to deal with+-- the worst-case branch of the code, and we may be in a better-case+-- branch.  In that case, move the real Hp *back* and retract some+-- ticky allocation count.+--+-- It *does not* deal with high-water-mark adjustment.  That's done by+-- functions which allocate heap.+adjustHpBackwards+  = do  { hp_usg <- getHpUsage+        ; let rHp = realHp hp_usg+              vHp = virtHp hp_usg+              adjust_words = vHp -rHp+        ; new_hp <- getHpRelOffset vHp++        ; emit (if adjust_words == 0+                then mkNop+                else mkAssign hpReg new_hp) -- Generates nothing when vHp==rHp++        ; tickyAllocHeap False adjust_words -- ...ditto++        ; setRealHp vHp+        }+++-------------------------------------------------------------------------+--        Making calls: directCall and slowCall+-------------------------------------------------------------------------++-- General plan is:+--   - we'll make *one* fast call, either to the function itself+--     (directCall) or to stg_ap_<pat>_fast (slowCall)+--     Any left-over arguments will be pushed on the stack,+--+--     e.g. Sp[old+8]  = arg1+--          Sp[old+16] = arg2+--          Sp[old+32] = stg_ap_pp_info+--          R2 = arg3+--          R3 = arg4+--          call f() return to Nothing updfr_off: 32+++directCall :: Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind+-- (directCall f n args)+-- calls f(arg1, ..., argn), and applies the result to the remaining args+-- The function f has arity n, and there are guaranteed at least n args+-- Both arity and args include void args+directCall conv lbl arity stg_args+  = do  { argreps <- getArgRepsAmodes stg_args+        ; direct_call "directCall" conv lbl arity argreps }+++slowCall :: CmmExpr -> [StgArg] -> FCode ReturnKind+-- (slowCall fun args) applies fun to args, returning the results to Sequel+slowCall fun stg_args+  = do  dflags <- getDynFlags+        argsreps <- getArgRepsAmodes stg_args+        let (rts_fun, arity) = slowCallPattern (map fst argsreps)++        (r, slow_code) <- getCodeR $ do+           r <- direct_call "slow_call" NativeNodeCall+                 (mkRtsApFastLabel rts_fun) arity ((P,Just fun):argsreps)+           emitComment $ mkFastString ("slow_call for " +++                                      showSDoc dflags (ppr fun) +++                                      " with pat " ++ unpackFS rts_fun)+           return r++        -- Note [avoid intermediate PAPs]+        let n_args = length stg_args+        if n_args > arity && optLevel dflags >= 2+           then do+             funv <- (CmmReg . CmmLocal) `fmap` assignTemp fun+             fun_iptr <- (CmmReg . CmmLocal) `fmap`+                    assignTemp (closureInfoPtr dflags (cmmUntag dflags funv))++             -- ToDo: we could do slightly better here by reusing the+             -- continuation from the slow call, which we have in r.+             -- Also we'd like to push the continuation on the stack+             -- before the branch, so that we only get one copy of the+             -- code that saves all the live variables across the+             -- call, but that might need some improvements to the+             -- special case in the stack layout code to handle this+             -- (see Note [diamond proc point]).++             fast_code <- getCode $+                emitCall (NativeNodeCall, NativeReturn)+                  (entryCode dflags fun_iptr)+                  (nonVArgs ((P,Just funv):argsreps))++             slow_lbl <- newBlockId+             fast_lbl <- newBlockId+             is_tagged_lbl <- newBlockId+             end_lbl <- newBlockId++             let correct_arity = cmmEqWord dflags (funInfoArity dflags fun_iptr)+                                                  (mkIntExpr dflags n_args)++             tscope <- getTickScope+             emit (mkCbranch (cmmIsTagged dflags funv)+                             is_tagged_lbl slow_lbl (Just True)+                   <*> mkLabel is_tagged_lbl tscope+                   <*> mkCbranch correct_arity fast_lbl slow_lbl (Just True)+                   <*> mkLabel fast_lbl tscope+                   <*> fast_code+                   <*> mkBranch end_lbl+                   <*> mkLabel slow_lbl tscope+                   <*> slow_code+                   <*> mkLabel end_lbl tscope)+             return r++           else do+             emit slow_code+             return r+++-- Note [avoid intermediate PAPs]+--+-- A slow call which needs multiple generic apply patterns will be+-- almost guaranteed to create one or more intermediate PAPs when+-- applied to a function that takes the correct number of arguments.+-- We try to avoid this situation by generating code to test whether+-- we are calling a function with the correct number of arguments+-- first, i.e.:+--+--   if (TAG(f) != 0} {  // f is not a thunk+--      if (f->info.arity == n) {+--         ... make a fast call to f ...+--      }+--   }+--   ... otherwise make the slow call ...+--+-- We *only* do this when the call requires multiple generic apply+-- functions, which requires pushing extra stack frames and probably+-- results in intermediate PAPs.  (I say probably, because it might be+-- that we're over-applying a function, but that seems even less+-- likely).+--+-- This very rarely applies, but if it does happen in an inner loop it+-- can have a severe impact on performance (#6084).+++--------------+direct_call :: String+            -> Convention     -- e.g. NativeNodeCall or NativeDirectCall+            -> CLabel -> RepArity+            -> [(ArgRep,Maybe CmmExpr)] -> FCode ReturnKind+direct_call caller call_conv lbl arity args+  | debugIsOn && args `lengthLessThan` real_arity  -- Too few args+  = do -- Caller should ensure that there enough args!+       pprPanic "direct_call" $+            text caller <+> ppr arity <+>+            ppr lbl <+> ppr (length args) <+>+            ppr (map snd args) <+> ppr (map fst args)++  | null rest_args  -- Precisely the right number of arguments+  = emitCall (call_conv, NativeReturn) target (nonVArgs args)++  | otherwise       -- Note [over-saturated calls]+  = do dflags <- getDynFlags+       emitCallWithExtraStack (call_conv, NativeReturn)+                              target+                              (nonVArgs fast_args)+                              (nonVArgs (stack_args dflags))+  where+    target = CmmLit (CmmLabel lbl)+    (fast_args, rest_args) = splitAt real_arity args+    stack_args dflags = slowArgs dflags rest_args+    real_arity = case call_conv of+                   NativeNodeCall -> arity+1+                   _              -> arity+++-- When constructing calls, it is easier to keep the ArgReps and the+-- CmmExprs zipped together.  However, a void argument has no+-- representation, so we need to use Maybe CmmExpr (the alternative of+-- using zeroCLit or even undefined would work, but would be ugly).+--+getArgRepsAmodes :: [StgArg] -> FCode [(ArgRep, Maybe CmmExpr)]+getArgRepsAmodes = mapM getArgRepAmode+  where getArgRepAmode arg+           | V <- rep  = return (V, Nothing)+           | otherwise = do expr <- getArgAmode (NonVoid arg)+                            return (rep, Just expr)+           where rep = toArgRep (argPrimRep arg)++nonVArgs :: [(ArgRep, Maybe CmmExpr)] -> [CmmExpr]+nonVArgs [] = []+nonVArgs ((_,Nothing)  : args) = nonVArgs args+nonVArgs ((_,Just arg) : args) = arg : nonVArgs args++{-+Note [over-saturated calls]++The natural thing to do for an over-saturated call would be to call+the function with the correct number of arguments, and then apply the+remaining arguments to the value returned, e.g.++  f a b c d   (where f has arity 2)+  -->+  r = call f(a,b)+  call r(c,d)++but this entails+  - saving c and d on the stack+  - making a continuation info table+  - at the continuation, loading c and d off the stack into regs+  - finally, call r++Note that since there are a fixed number of different r's+(e.g.  stg_ap_pp_fast), we can also pre-compile continuations+that correspond to each of them, rather than generating a fresh+one for each over-saturated call.++Not only does this generate much less code, it is faster too.  We will+generate something like:++Sp[old+16] = c+Sp[old+24] = d+Sp[old+32] = stg_ap_pp_info+call f(a,b) -- usual calling convention++For the purposes of the CmmCall node, we count this extra stack as+just more arguments that we are passing on the stack (cml_args).+-}++-- | 'slowArgs' takes a list of function arguments and prepares them for+-- pushing on the stack for "extra" arguments to a function which requires+-- fewer arguments than we currently have.+slowArgs :: DynFlags -> [(ArgRep, Maybe CmmExpr)] -> [(ArgRep, Maybe CmmExpr)]+slowArgs _ [] = []+slowArgs dflags args -- careful: reps contains voids (V), but args does not+  | gopt Opt_SccProfilingOn dflags+              = save_cccs ++ this_pat ++ slowArgs dflags rest_args+  | otherwise =              this_pat ++ slowArgs dflags rest_args+  where+    (arg_pat, n)            = slowCallPattern (map fst args)+    (call_args, rest_args)  = splitAt n args++    stg_ap_pat = mkCmmRetInfoLabel rtsUnitId arg_pat+    this_pat   = (N, Just (mkLblExpr stg_ap_pat)) : call_args+    save_cccs  = [(N, Just (mkLblExpr save_cccs_lbl)), (N, Just cccsExpr)]+    save_cccs_lbl = mkCmmRetInfoLabel rtsUnitId (fsLit "stg_restore_cccs")++-------------------------------------------------------------------------+----        Laying out objects on the heap and stack+-------------------------------------------------------------------------++-- The heap always grows upwards, so hpRel is easy to compute+hpRel :: VirtualHpOffset         -- virtual offset of Hp+      -> VirtualHpOffset         -- virtual offset of The Thing+      -> WordOff                -- integer word offset+hpRel hp off = off - hp++getHpRelOffset :: VirtualHpOffset -> FCode CmmExpr+-- See Note [Virtual and real heap pointers] in StgCmmMonad+getHpRelOffset virtual_offset+  = do dflags <- getDynFlags+       hp_usg <- getHpUsage+       return (cmmRegOffW dflags hpReg (hpRel (realHp hp_usg) virtual_offset))++data FieldOffOrPadding a+    = FieldOff (NonVoid a) -- Something that needs an offset.+               ByteOff     -- Offset in bytes.+    | Padding ByteOff  -- Length of padding in bytes.+              ByteOff  -- Offset in bytes.++-- | Used to tell the various @mkVirtHeapOffsets@ functions what kind+-- of header the object has.  This will be accounted for in the+-- offsets of the fields returned.+data ClosureHeader+  = NoHeader+  | StdHeader+  | ThunkHeader++mkVirtHeapOffsetsWithPadding+  :: DynFlags+  -> ClosureHeader            -- What kind of header to account for+  -> [NonVoid (PrimRep, a)]   -- Things to make offsets for+  -> ( WordOff                -- Total number of words allocated+     , WordOff                -- Number of words allocated for *pointers*+     , [FieldOffOrPadding a]  -- Either an offset or padding.+     )++-- Things with their offsets from start of object in order of+-- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER+-- First in list gets lowest offset, which is initial offset + 1.+--+-- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets+-- than the unboxed things++mkVirtHeapOffsetsWithPadding dflags header things =+    ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))+    ( tot_wds+    , bytesToWordsRoundUp dflags bytes_of_ptrs+    , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad+    )+  where+    hdr_words = case header of+      NoHeader -> 0+      StdHeader -> fixedHdrSizeW dflags+      ThunkHeader -> thunkHdrSize dflags+    hdr_bytes = wordsToBytes dflags hdr_words++    (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things++    (bytes_of_ptrs, ptrs_w_offsets) =+       mapAccumL computeOffset 0 ptrs+    (tot_bytes, non_ptrs_w_offsets) =+       mapAccumL computeOffset bytes_of_ptrs non_ptrs++    tot_wds = bytesToWordsRoundUp dflags tot_bytes++    final_pad_size = tot_wds * word_size - tot_bytes+    final_pad+        | final_pad_size > 0 = [(Padding final_pad_size+                                         (hdr_bytes + tot_bytes))]+        | otherwise          = []++    word_size = wORD_SIZE dflags++    computeOffset bytes_so_far nv_thing =+        (new_bytes_so_far, with_padding field_off)+      where+        (rep, thing) = fromNonVoid nv_thing++        -- Size of the field in bytes.+        !sizeB = primRepSizeB dflags rep++        -- Align the start offset (eg, 2-byte value should be 2-byte aligned).+        -- But not more than to a word.+        !align = min word_size sizeB+        !start = roundUpTo bytes_so_far align+        !padding = start - bytes_so_far++        -- Final offset is:+        --   size of header + bytes_so_far + padding+        !final_offset = hdr_bytes + bytes_so_far + padding+        !new_bytes_so_far = start + sizeB+        field_off = FieldOff (NonVoid thing) final_offset++        with_padding field_off+            | padding == 0 = [field_off]+            | otherwise    = [ Padding padding (hdr_bytes + bytes_so_far)+                             , field_off+                             ]+++mkVirtHeapOffsets+  :: DynFlags+  -> ClosureHeader            -- What kind of header to account for+  -> [NonVoid (PrimRep,a)]    -- Things to make offsets for+  -> (WordOff,                -- _Total_ number of words allocated+      WordOff,                -- Number of words allocated for *pointers*+      [(NonVoid a, ByteOff)])+mkVirtHeapOffsets dflags header things =+    ( tot_wds+    , ptr_wds+    , [ (field, offset) | (FieldOff field offset) <- things_offsets ]+    )+  where+   (tot_wds, ptr_wds, things_offsets) =+       mkVirtHeapOffsetsWithPadding dflags header things++-- | Just like mkVirtHeapOffsets, but for constructors+mkVirtConstrOffsets+  :: DynFlags -> [NonVoid (PrimRep, a)]+  -> (WordOff, WordOff, [(NonVoid a, ByteOff)])+mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags StdHeader++-- | Just like mkVirtConstrOffsets, but used when we don't have the actual+-- arguments. Useful when e.g. generating info tables; we just need to know+-- sizes of pointer and non-pointer fields.+mkVirtConstrSizes :: DynFlags -> [NonVoid PrimRep] -> (WordOff, WordOff)+mkVirtConstrSizes dflags field_reps+  = (tot_wds, ptr_wds)+  where+    (tot_wds, ptr_wds, _) =+       mkVirtConstrOffsets dflags+         (map (\nv_rep -> NonVoid (fromNonVoid nv_rep, ())) field_reps)++-------------------------------------------------------------------------+--+--        Making argument descriptors+--+--  An argument descriptor describes the layout of args on the stack,+--  both for         * GC (stack-layout) purposes, and+--                * saving/restoring registers when a heap-check fails+--+-- Void arguments aren't important, therefore (contrast constructSlowCall)+--+-------------------------------------------------------------------------++-- bring in ARG_P, ARG_N, etc.+#include "../includes/rts/storage/FunTypes.h"++mkArgDescr :: DynFlags -> [Id] -> ArgDescr+mkArgDescr dflags args+  = let arg_bits = argBits dflags arg_reps+        arg_reps = filter isNonV (map idArgRep args)+           -- Getting rid of voids eases matching of standard patterns+    in case stdPattern arg_reps of+         Just spec_id -> ArgSpec spec_id+         Nothing      -> ArgGen  arg_bits++argBits :: DynFlags -> [ArgRep] -> [Bool]        -- True for non-ptr, False for ptr+argBits _      []           = []+argBits dflags (P   : args) = False : argBits dflags args+argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True)+                    ++ argBits dflags args++----------------------+stdPattern :: [ArgRep] -> Maybe Int+stdPattern reps+  = case reps of+        []    -> Just ARG_NONE        -- just void args, probably+        [N]   -> Just ARG_N+        [P]   -> Just ARG_P+        [F]   -> Just ARG_F+        [D]   -> Just ARG_D+        [L]   -> Just ARG_L+        [V16] -> Just ARG_V16+        [V32] -> Just ARG_V32+        [V64] -> Just ARG_V64++        [N,N] -> Just ARG_NN+        [N,P] -> Just ARG_NP+        [P,N] -> Just ARG_PN+        [P,P] -> Just ARG_PP++        [N,N,N] -> Just ARG_NNN+        [N,N,P] -> Just ARG_NNP+        [N,P,N] -> Just ARG_NPN+        [N,P,P] -> Just ARG_NPP+        [P,N,N] -> Just ARG_PNN+        [P,N,P] -> Just ARG_PNP+        [P,P,N] -> Just ARG_PPN+        [P,P,P] -> Just ARG_PPP++        [P,P,P,P]     -> Just ARG_PPPP+        [P,P,P,P,P]   -> Just ARG_PPPPP+        [P,P,P,P,P,P] -> Just ARG_PPPPPP++        _ -> Nothing++-------------------------------------------------------------------------+--+--        Generating the info table and code for a closure+--+-------------------------------------------------------------------------++-- Here we make an info table of type 'CmmInfo'.  The concrete+-- representation as a list of 'CmmAddr' is handled later+-- in the pipeline by 'cmmToRawCmm'.+-- When loading the free variables, a function closure pointer may be tagged,+-- so we must take it into account.++emitClosureProcAndInfoTable :: Bool                    -- top-level?+                            -> Id                      -- name of the closure+                            -> LambdaFormInfo+                            -> CmmInfoTable+                            -> [NonVoid Id]            -- incoming arguments+                            -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body+                            -> FCode ()+emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body+ = do   { dflags <- getDynFlags+        -- Bind the binder itself, but only if it's not a top-level+        -- binding. We need non-top let-bindings to refer to the+        -- top-level binding, which this binding would incorrectly shadow.+        ; node <- if top_lvl then return $ idToReg dflags (NonVoid bndr)+                  else bindToReg (NonVoid bndr) lf_info+        ; let node_points = nodeMustPointToIt dflags lf_info+        ; arg_regs <- bindArgsToRegs args+        ; let args' = if node_points then (node : arg_regs) else arg_regs+              conv  = if nodeMustPointToIt dflags lf_info then NativeNodeCall+                                                          else NativeDirectCall+              (offset, _, _) = mkCallEntry dflags conv args' []+        ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)+        }++-- Data constructors need closures, but not with all the argument handling+-- needed for functions. The shared part goes here.+emitClosureAndInfoTable ::+  CmmInfoTable -> Convention -> [LocalReg] -> FCode () -> FCode ()+emitClosureAndInfoTable info_tbl conv args body+  = do { (_, blks) <- getCodeScoped body+       ; let entry_lbl = toEntryLbl (cit_lbl info_tbl)+       ; emitProcWithConvention conv (Just info_tbl) entry_lbl args blks+       }
+ compiler/codeGen/StgCmmMonad.hs view
@@ -0,0 +1,862 @@+{-# LANGUAGE GADTs #-}++-----------------------------------------------------------------------------+--+-- Monad for Stg to C-- code generation+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmMonad (+        FCode,        -- type++        initC, runC, fixC,+        newUnique,++        emitLabel,++        emit, emitDecl,+        emitProcWithConvention, emitProcWithStackFrame,+        emitOutOfLine, emitAssign, emitStore,+        emitComment, emitTick, emitUnwind,++        getCmm, aGraphToGraph,+        getCodeR, getCode, getCodeScoped, getHeapUsage,++        mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,+        mkCmmIfThenElse', mkCmmIfThen', mkCmmIfGoto',++        mkCall, mkCmmCall,++        forkClosureBody, forkLneBody, forkAlts, forkAltPair, codeOnly,++        ConTagZ,++        Sequel(..), ReturnKind(..),+        withSequel, getSequel,++        setTickyCtrLabel, getTickyCtrLabel,+        tickScope, getTickScope,++        withUpdFrameOff, getUpdFrameOff, initUpdFrameOff,++        HeapUsage(..), VirtualHpOffset,        initHpUsage,+        getHpUsage,  setHpUsage, heapHWM,+        setVirtHp, getVirtHp, setRealHp,++        getModuleName,++        -- ideally we wouldn't export these, but some other modules access internal state+        getState, setState, getSelfLoop, withSelfLoop, getInfoDown, getDynFlags, getThisPackage,++        -- more localised access to monad state+        CgIdInfo(..),+        getBinds, setBinds,++        -- out of general friendliness, we also export ...+        CgInfoDownwards(..), CgState(..)        -- non-abstract+    ) where++import GhcPrelude hiding( sequence, succ )++import Cmm+import StgCmmClosure+import DynFlags+import Hoopl.Collections+import MkGraph+import BlockId+import CLabel+import SMRep+import Module+import Id+import VarEnv+import OrdList+import BasicTypes( ConTagZ )+import Unique+import UniqSupply+import FastString+import Outputable+import Util++import Control.Monad+import Data.List++++--------------------------------------------------------+-- The FCode monad and its types+--+-- FCode is the monad plumbed through the Stg->Cmm code generator, and+-- the Cmm parser.  It contains the following things:+--+--  - A writer monad, collecting:+--    - code for the current function, in the form of a CmmAGraph.+--      The function "emit" appends more code to this.+--    - the top-level CmmDecls accumulated so far+--+--  - A state monad with:+--    - the local bindings in scope+--    - the current heap usage+--    - a UniqSupply+--+--  - A reader monad, for CgInfoDownwards, containing+--    - DynFlags,+--    - the current Module+--    - the update-frame offset+--    - the ticky counter label+--    - the Sequel (the continuation to return to)+--    - the self-recursive tail call information++--------------------------------------------------------++newtype FCode a = FCode { doFCode :: CgInfoDownwards -> CgState -> (a, CgState) }++instance Functor FCode where+    fmap f (FCode g) = FCode $ \i s -> case g i s of (a, s') -> (f a, s')++instance Applicative FCode where+    pure val = FCode (\_info_down state -> (val, state))+    {-# INLINE pure #-}+    (<*>) = ap++instance Monad FCode where+    FCode m >>= k = FCode $+        \info_down state ->+            case m info_down state of+              (m_result, new_state) ->+                 case k m_result of+                   FCode kcode -> kcode info_down new_state+    {-# INLINE (>>=) #-}++instance MonadUnique FCode where+  getUniqueSupplyM = cgs_uniqs <$> getState+  getUniqueM = FCode $ \_ st ->+    let (u, us') = takeUniqFromSupply (cgs_uniqs st)+    in (u, st { cgs_uniqs = us' })++initC :: IO CgState+initC  = do { uniqs <- mkSplitUniqSupply 'c'+            ; return (initCgState uniqs) }++runC :: DynFlags -> Module -> CgState -> FCode a -> (a,CgState)+runC dflags mod st fcode = doFCode fcode (initCgInfoDown dflags mod) st++fixC :: (a -> FCode a) -> FCode a+fixC fcode = FCode $+    \info_down state -> let (v, s) = doFCode (fcode v) info_down state+                        in (v, s)++--------------------------------------------------------+--        The code generator environment+--------------------------------------------------------++-- This monadery has some information that it only passes+-- *downwards*, as well as some ``state'' which is modified+-- as we go along.++data CgInfoDownwards        -- information only passed *downwards* by the monad+  = MkCgInfoDown {+        cgd_dflags    :: DynFlags,+        cgd_mod       :: Module,            -- Module being compiled+        cgd_updfr_off :: UpdFrameOffset,    -- Size of current update frame+        cgd_ticky     :: CLabel,            -- Current destination for ticky counts+        cgd_sequel    :: Sequel,            -- What to do at end of basic block+        cgd_self_loop :: Maybe SelfLoopInfo,-- Which tail calls can be compiled+                                            -- as local jumps? See Note+                                            -- [Self-recursive tail calls] in+                                            -- StgCmmExpr+        cgd_tick_scope:: CmmTickScope       -- Tick scope for new blocks & ticks+  }++type CgBindings = IdEnv CgIdInfo++data CgIdInfo+  = CgIdInfo+        { cg_id :: Id   -- Id that this is the info for+        , cg_lf  :: LambdaFormInfo+        , cg_loc :: CgLoc                     -- CmmExpr for the *tagged* value+        }++instance Outputable CgIdInfo where+  ppr (CgIdInfo { cg_id = id, cg_loc = loc })+    = ppr id <+> text "-->" <+> ppr loc++-- Sequel tells what to do with the result of this expression+data Sequel+  = Return              -- Return result(s) to continuation found on the stack.++  | AssignTo+        [LocalReg]      -- Put result(s) in these regs and fall through+                        -- NB: no void arguments here+                        --+        Bool            -- Should we adjust the heap pointer back to+                        -- recover space that's unused on this path?+                        -- We need to do this only if the expression+                        -- may allocate (e.g. it's a foreign call or+                        -- allocating primOp)++instance Outputable Sequel where+    ppr Return = text "Return"+    ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b++-- See Note [sharing continuations] below+data ReturnKind+  = AssignedDirectly+  | ReturnedTo BlockId ByteOff++-- Note [sharing continuations]+--+-- ReturnKind says how the expression being compiled returned its+-- results: either by assigning directly to the registers specified+-- by the Sequel, or by returning to a continuation that does the+-- assignments.  The point of this is we might be able to re-use the+-- continuation in a subsequent heap-check.  Consider:+--+--    case f x of z+--      True  -> <True code>+--      False -> <False code>+--+-- Naively we would generate+--+--    R2 = x   -- argument to f+--    Sp[young(L1)] = L1+--    call f returns to L1+--  L1:+--    z = R1+--    if (z & 1) then Ltrue else Lfalse+--  Ltrue:+--    Hp = Hp + 24+--    if (Hp > HpLim) then L4 else L7+--  L4:+--    HpAlloc = 24+--    goto L5+--  L5:+--    R1 = z+--    Sp[young(L6)] = L6+--    call stg_gc_unpt_r1 returns to L6+--  L6:+--    z = R1+--    goto L1+--  L7:+--    <True code>+--  Lfalse:+--    <False code>+--+-- We want the gc call in L4 to return to L1, and discard L6.  Note+-- that not only can we share L1 and L6, but the assignment of the+-- return address in L4 is unnecessary because the return address for+-- L1 is already on the stack.  We used to catch the sharing of L1 and+-- L6 in the common-block-eliminator, but not the unnecessary return+-- address assignment.+--+-- Since this case is so common I decided to make it more explicit and+-- robust by programming the sharing directly, rather than relying on+-- the common-block eliminator to catch it.  This makes+-- common-block-elimination an optional optimisation, and furthermore+-- generates less code in the first place that we have to subsequently+-- clean up.+--+-- There are some rarer cases of common blocks that we don't catch+-- this way, but that's ok.  Common-block-elimination is still available+-- to catch them when optimisation is enabled.  Some examples are:+--+--   - when both the True and False branches do a heap check, we+--     can share the heap-check failure code L4a and maybe L4+--+--   - in a case-of-case, there might be multiple continuations that+--     we can common up.+--+-- It is always safe to use AssignedDirectly.  Expressions that jump+-- to the continuation from multiple places (e.g. case expressions)+-- fall back to AssignedDirectly.+--+++initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards+initCgInfoDown dflags mod+  = MkCgInfoDown { cgd_dflags    = dflags+                 , cgd_mod       = mod+                 , cgd_updfr_off = initUpdFrameOff dflags+                 , cgd_ticky     = mkTopTickyCtrLabel+                 , cgd_sequel    = initSequel+                 , cgd_self_loop = Nothing+                 , cgd_tick_scope= GlobalScope }++initSequel :: Sequel+initSequel = Return++initUpdFrameOff :: DynFlags -> UpdFrameOffset+initUpdFrameOff dflags = widthInBytes (wordWidth dflags) -- space for the RA+++--------------------------------------------------------+--        The code generator state+--------------------------------------------------------++data CgState+  = MkCgState {+     cgs_stmts :: CmmAGraph,          -- Current procedure++     cgs_tops  :: OrdList CmmDecl,+        -- Other procedures and data blocks in this compilation unit+        -- Both are ordered only so that we can+        -- reduce forward references, when it's easy to do so++     cgs_binds :: CgBindings,++     cgs_hp_usg  :: HeapUsage,++     cgs_uniqs :: UniqSupply }++data HeapUsage   -- See Note [Virtual and real heap pointers]+  = HeapUsage {+        virtHp :: VirtualHpOffset,       -- Virtual offset of highest-allocated word+                                         --   Incremented whenever we allocate+        realHp :: VirtualHpOffset        -- realHp: Virtual offset of real heap ptr+                                         --   Used in instruction addressing modes+    }++type VirtualHpOffset = WordOff+++{- Note [Virtual and real heap pointers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The code generator can allocate one or more objects contiguously, performing+one heap check to cover allocation of all the objects at once.  Let's call+this little chunk of heap space an "allocation chunk".  The code generator+will emit code to+  * Perform a heap-exhaustion check+  * Move the heap pointer to the end of the allocation chunk+  * Allocate multiple objects within the chunk++The code generator uses VirtualHpOffsets to address words within a+single allocation chunk; these start at one and increase positively.+The first word of the chunk has VirtualHpOffset=1, the second has+VirtualHpOffset=2, and so on.++ * The field realHp tracks (the VirtualHpOffset) where the real Hp+   register is pointing.  Typically it'll be pointing to the end of the+   allocation chunk.++ * The field virtHp gives the VirtualHpOffset of the highest-allocated+   word so far.  It starts at zero (meaning no word has been allocated),+   and increases whenever an object is allocated.++The difference between realHp and virtHp gives the offset from the+real Hp register of a particular word in the allocation chunk. This+is what getHpRelOffset does.  Since the returned offset is relative+to the real Hp register, it is valid only until you change the real+Hp register.  (Changing virtHp doesn't matter.)+-}+++initCgState :: UniqSupply -> CgState+initCgState uniqs+  = MkCgState { cgs_stmts  = mkNop+              , cgs_tops   = nilOL+              , cgs_binds  = emptyVarEnv+              , cgs_hp_usg = initHpUsage+              , cgs_uniqs  = uniqs }++stateIncUsage :: CgState -> CgState -> CgState+-- stateIncUsage@ e1 e2 incorporates in e1+-- the heap high water mark found in e2.+stateIncUsage s1 s2@(MkCgState { cgs_hp_usg = hp_usg })+     = s1 { cgs_hp_usg  = cgs_hp_usg  s1 `maxHpHw`  virtHp hp_usg }+       `addCodeBlocksFrom` s2++addCodeBlocksFrom :: CgState -> CgState -> CgState+-- Add code blocks from the latter to the former+-- (The cgs_stmts will often be empty, but not always; see codeOnly)+s1 `addCodeBlocksFrom` s2+  = s1 { cgs_stmts = cgs_stmts s1 MkGraph.<*> cgs_stmts s2,+         cgs_tops  = cgs_tops  s1 `appOL` cgs_tops  s2 }+++-- The heap high water mark is the larger of virtHp and hwHp.  The latter is+-- only records the high water marks of forked-off branches, so to find the+-- heap high water mark you have to take the max of virtHp and hwHp.  Remember,+-- virtHp never retreats!+--+-- Note Jan 04: ok, so why do we only look at the virtual Hp??++heapHWM :: HeapUsage -> VirtualHpOffset+heapHWM = virtHp++initHpUsage :: HeapUsage+initHpUsage = HeapUsage { virtHp = 0, realHp = 0 }++maxHpHw :: HeapUsage -> VirtualHpOffset -> HeapUsage+hp_usg `maxHpHw` hw = hp_usg { virtHp = virtHp hp_usg `max` hw }++--------------------------------------------------------+-- Operators for getting and setting the state and "info_down".+--------------------------------------------------------++getState :: FCode CgState+getState = FCode $ \_info_down state -> (state, state)++setState :: CgState -> FCode ()+setState state = FCode $ \_info_down _ -> ((), state)++getHpUsage :: FCode HeapUsage+getHpUsage = do+        state <- getState+        return $ cgs_hp_usg state++setHpUsage :: HeapUsage -> FCode ()+setHpUsage new_hp_usg = do+        state <- getState+        setState $ state {cgs_hp_usg = new_hp_usg}++setVirtHp :: VirtualHpOffset -> FCode ()+setVirtHp new_virtHp+  = do  { hp_usage <- getHpUsage+        ; setHpUsage (hp_usage {virtHp = new_virtHp}) }++getVirtHp :: FCode VirtualHpOffset+getVirtHp+  = do  { hp_usage <- getHpUsage+        ; return (virtHp hp_usage) }++setRealHp ::  VirtualHpOffset -> FCode ()+setRealHp new_realHp+  = do  { hp_usage <- getHpUsage+        ; setHpUsage (hp_usage {realHp = new_realHp}) }++getBinds :: FCode CgBindings+getBinds = do+        state <- getState+        return $ cgs_binds state++setBinds :: CgBindings -> FCode ()+setBinds new_binds = do+        state <- getState+        setState $ state {cgs_binds = new_binds}++withState :: FCode a -> CgState -> FCode (a,CgState)+withState (FCode fcode) newstate = FCode $ \info_down state ->+  case fcode info_down newstate of+    (retval, state2) -> ((retval,state2), state)++newUniqSupply :: FCode UniqSupply+newUniqSupply = do+        state <- getState+        let (us1, us2) = splitUniqSupply (cgs_uniqs state)+        setState $ state { cgs_uniqs = us1 }+        return us2++newUnique :: FCode Unique+newUnique = do+        state <- getState+        let (u,us') = takeUniqFromSupply (cgs_uniqs state)+        setState $ state { cgs_uniqs = us' }+        return u++------------------+getInfoDown :: FCode CgInfoDownwards+getInfoDown = FCode $ \info_down state -> (info_down,state)++getSelfLoop :: FCode (Maybe SelfLoopInfo)+getSelfLoop = do+        info_down <- getInfoDown+        return $ cgd_self_loop info_down++withSelfLoop :: SelfLoopInfo -> FCode a -> FCode a+withSelfLoop self_loop code = do+        info_down <- getInfoDown+        withInfoDown code (info_down {cgd_self_loop = Just self_loop})++instance HasDynFlags FCode where+    getDynFlags = liftM cgd_dflags getInfoDown++getThisPackage :: FCode UnitId+getThisPackage = liftM thisPackage getDynFlags++withInfoDown :: FCode a -> CgInfoDownwards -> FCode a+withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state++-- ----------------------------------------------------------------------------+-- Get the current module name++getModuleName :: FCode Module+getModuleName = do { info <- getInfoDown; return (cgd_mod info) }++-- ----------------------------------------------------------------------------+-- Get/set the end-of-block info++withSequel :: Sequel -> FCode a -> FCode a+withSequel sequel code+  = do  { info  <- getInfoDown+        ; withInfoDown code (info {cgd_sequel = sequel, cgd_self_loop = Nothing }) }++getSequel :: FCode Sequel+getSequel = do  { info <- getInfoDown+                ; return (cgd_sequel info) }++-- ----------------------------------------------------------------------------+-- Get/set the size of the update frame++-- We keep track of the size of the update frame so that we+-- can set the stack pointer to the proper address on return+-- (or tail call) from the closure.+-- There should be at most one update frame for each closure.+-- Note: I'm including the size of the original return address+-- in the size of the update frame -- hence the default case on `get'.++withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a+withUpdFrameOff size code+  = do  { info  <- getInfoDown+        ; withInfoDown code (info {cgd_updfr_off = size }) }++getUpdFrameOff :: FCode UpdFrameOffset+getUpdFrameOff+  = do  { info  <- getInfoDown+        ; return $ cgd_updfr_off info }++-- ----------------------------------------------------------------------------+-- Get/set the current ticky counter label++getTickyCtrLabel :: FCode CLabel+getTickyCtrLabel = do+        info <- getInfoDown+        return (cgd_ticky info)++setTickyCtrLabel :: CLabel -> FCode a -> FCode a+setTickyCtrLabel ticky code = do+        info <- getInfoDown+        withInfoDown code (info {cgd_ticky = ticky})++-- ----------------------------------------------------------------------------+-- Manage tick scopes++-- | The current tick scope. We will assign this to generated blocks.+getTickScope :: FCode CmmTickScope+getTickScope = do+        info <- getInfoDown+        return (cgd_tick_scope info)++-- | Places blocks generated by the given code into a fresh+-- (sub-)scope. This will make sure that Cmm annotations in our scope+-- will apply to the Cmm blocks generated therein - but not the other+-- way around.+tickScope :: FCode a -> FCode a+tickScope code = do+        info <- getInfoDown+        if debugLevel (cgd_dflags info) == 0 then code else do+          u <- newUnique+          let scope' = SubScope u (cgd_tick_scope info)+          withInfoDown code info{ cgd_tick_scope = scope' }+++--------------------------------------------------------+--                 Forking+--------------------------------------------------------++forkClosureBody :: FCode () -> FCode ()+-- forkClosureBody compiles body_code in environment where:+--   - sequel, update stack frame and self loop info are+--     set to fresh values+--   - state is set to a fresh value, except for local bindings+--     that are passed in unchanged. It's up to the enclosed code to+--     re-bind the free variables to a field of the closure.++forkClosureBody body_code+  = do  { dflags <- getDynFlags+        ; info   <- getInfoDown+        ; us     <- newUniqSupply+        ; state  <- getState+        ; let body_info_down = info { cgd_sequel    = initSequel+                                    , cgd_updfr_off = initUpdFrameOff dflags+                                    , cgd_self_loop = Nothing }+              fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }+              ((),fork_state_out) = doFCode body_code body_info_down fork_state_in+        ; setState $ state `addCodeBlocksFrom` fork_state_out }++forkLneBody :: FCode a -> FCode a+-- 'forkLneBody' takes a body of let-no-escape binding and compiles+-- it in the *current* environment, returning the graph thus constructed.+--+-- The current environment is passed on completely unchanged to+-- the successor.  In particular, any heap usage from the enclosed+-- code is discarded; it should deal with its own heap consumption.+forkLneBody body_code+  = do  { info_down <- getInfoDown+        ; us        <- newUniqSupply+        ; state     <- getState+        ; let fork_state_in = (initCgState us) { cgs_binds = cgs_binds state }+              (result, fork_state_out) = doFCode body_code info_down fork_state_in+        ; setState $ state `addCodeBlocksFrom` fork_state_out+        ; return result }++codeOnly :: FCode () -> FCode ()+-- Emit any code from the inner thing into the outer thing+-- Do not affect anything else in the outer state+-- Used in almost-circular code to prevent false loop dependencies+codeOnly body_code+  = do  { info_down <- getInfoDown+        ; us        <- newUniqSupply+        ; state     <- getState+        ; let   fork_state_in = (initCgState us) { cgs_binds   = cgs_binds state+                                                 , cgs_hp_usg  = cgs_hp_usg state }+                ((), fork_state_out) = doFCode body_code info_down fork_state_in+        ; setState $ state `addCodeBlocksFrom` fork_state_out }++forkAlts :: [FCode a] -> FCode [a]+-- (forkAlts' bs d) takes fcodes 'bs' for the branches of a 'case', and+-- an fcode for the default case 'd', and compiles each in the current+-- environment.  The current environment is passed on unmodified, except+-- that the virtual Hp is moved on to the worst virtual Hp for the branches++forkAlts branch_fcodes+  = do  { info_down <- getInfoDown+        ; us <- newUniqSupply+        ; state <- getState+        ; let compile us branch+                = (us2, doFCode branch info_down branch_state)+                where+                  (us1,us2) = splitUniqSupply us+                  branch_state = (initCgState us1) {+                                        cgs_binds  = cgs_binds state+                                      , cgs_hp_usg = cgs_hp_usg state }+              (_us, results) = mapAccumL compile us branch_fcodes+              (branch_results, branch_out_states) = unzip results+        ; setState $ foldl' stateIncUsage state branch_out_states+                -- NB foldl.  state is the *left* argument to stateIncUsage+        ; return branch_results }++forkAltPair :: FCode a -> FCode a -> FCode (a,a)+-- Most common use of 'forkAlts'; having this helper function avoids+-- accidental use of failible pattern-matches in @do@-notation+forkAltPair x y = do+  xy' <- forkAlts [x,y]+  case xy' of+    [x',y'] -> return (x',y')+    _ -> panic "forkAltPair"++-- collect the code emitted by an FCode computation+getCodeR :: FCode a -> FCode (a, CmmAGraph)+getCodeR fcode+  = do  { state1 <- getState+        ; (a, state2) <- withState fcode (state1 { cgs_stmts = mkNop })+        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }+        ; return (a, cgs_stmts state2) }++getCode :: FCode a -> FCode CmmAGraph+getCode fcode = do { (_,stmts) <- getCodeR fcode; return stmts }++-- | Generate code into a fresh tick (sub-)scope and gather generated code+getCodeScoped :: FCode a -> FCode (a, CmmAGraphScoped)+getCodeScoped fcode+  = do  { state1 <- getState+        ; ((a, tscope), state2) <-+            tickScope $+            flip withState state1 { cgs_stmts = mkNop } $+            do { a   <- fcode+               ; scp <- getTickScope+               ; return (a, scp) }+        ; setState $ state2 { cgs_stmts = cgs_stmts state1  }+        ; return (a, (cgs_stmts state2, tscope)) }+++-- 'getHeapUsage' applies a function to the amount of heap that it uses.+-- It initialises the heap usage to zeros, and passes on an unchanged+-- heap usage.+--+-- It is usually a prelude to performing a GC check, so everything must+-- be in a tidy and consistent state.+--+-- Note the slightly subtle fixed point behaviour needed here++getHeapUsage :: (VirtualHpOffset -> FCode a) -> FCode a+getHeapUsage fcode+  = do  { info_down <- getInfoDown+        ; state <- getState+        ; let   fstate_in = state { cgs_hp_usg  = initHpUsage }+                (r, fstate_out) = doFCode (fcode hp_hw) info_down fstate_in+                hp_hw = heapHWM (cgs_hp_usg fstate_out)        -- Loop here!++        ; setState $ fstate_out { cgs_hp_usg = cgs_hp_usg state }+        ; return r }++-- ----------------------------------------------------------------------------+-- Combinators for emitting code++emitCgStmt :: CgStmt -> FCode ()+emitCgStmt stmt+  = do  { state <- getState+        ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt }+        }++emitLabel :: BlockId -> FCode ()+emitLabel id = do tscope <- getTickScope+                  emitCgStmt (CgLabel id tscope)++emitComment :: FastString -> FCode ()+emitComment s+  | debugIsOn = emitCgStmt (CgStmt (CmmComment s))+  | otherwise = return ()++emitTick :: CmmTickish -> FCode ()+emitTick = emitCgStmt . CgStmt . CmmTick++emitUnwind :: [(GlobalReg, Maybe CmmExpr)] -> FCode ()+emitUnwind regs = do+  dflags <- getDynFlags+  when (debugLevel dflags > 0) $ do+     emitCgStmt $ CgStmt $ CmmUnwind regs++emitAssign :: CmmReg  -> CmmExpr -> FCode ()+emitAssign l r = emitCgStmt (CgStmt (CmmAssign l r))++emitStore :: CmmExpr  -> CmmExpr -> FCode ()+emitStore l r = emitCgStmt (CgStmt (CmmStore l r))++emit :: CmmAGraph -> FCode ()+emit ag+  = do  { state <- getState+        ; setState $ state { cgs_stmts = cgs_stmts state MkGraph.<*> ag } }++emitDecl :: CmmDecl -> FCode ()+emitDecl decl+  = do  { state <- getState+        ; setState $ state { cgs_tops = cgs_tops state `snocOL` decl } }++emitOutOfLine :: BlockId -> CmmAGraphScoped -> FCode ()+emitOutOfLine l (stmts, tscope) = emitCgStmt (CgFork l stmts tscope)++emitProcWithStackFrame+   :: Convention                        -- entry convention+   -> Maybe CmmInfoTable                -- info table?+   -> CLabel                            -- label for the proc+   -> [CmmFormal]                       -- stack frame+   -> [CmmFormal]                       -- arguments+   -> CmmAGraphScoped                   -- code+   -> Bool                              -- do stack layout?+   -> FCode ()++emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False+  = do  { dflags <- getDynFlags+        ; emitProc mb_info lbl [] blocks (widthInBytes (wordWidth dflags)) False+        }+emitProcWithStackFrame conv mb_info lbl stk_args args (graph, tscope) True+        -- do layout+  = do  { dflags <- getDynFlags+        ; let (offset, live, entry) = mkCallEntry dflags conv args stk_args+              graph' = entry MkGraph.<*> graph+        ; emitProc mb_info lbl live (graph', tscope) offset True+        }+emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"++emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel+                       -> [CmmFormal]+                       -> CmmAGraphScoped+                       -> FCode ()+emitProcWithConvention conv mb_info lbl args blocks+  = emitProcWithStackFrame conv mb_info lbl [] args blocks True++emitProc :: Maybe CmmInfoTable -> CLabel -> [GlobalReg] -> CmmAGraphScoped+         -> Int -> Bool -> FCode ()+emitProc mb_info lbl live blocks offset do_layout+  = do  { dflags <- getDynFlags+        ; l <- newBlockId+        ; let+              blks :: CmmGraph+              blks = labelAGraph l blocks++              infos | Just info <- mb_info = mapSingleton (g_entry blks) info+                    | otherwise            = mapEmpty++              sinfo = StackInfo { arg_space = offset+                                , updfr_space = Just (initUpdFrameOff dflags)+                                , do_layout = do_layout }++              tinfo = TopInfo { info_tbls = infos+                              , stack_info=sinfo}++              proc_block = CmmProc tinfo lbl live blks++        ; state <- getState+        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }++getCmm :: FCode () -> FCode CmmGroup+-- Get all the CmmTops (there should be no stmts)+-- Return a single Cmm which may be split from other Cmms by+-- object splitting (at a later stage)+getCmm code+  = do  { state1 <- getState+        ; ((), state2) <- withState code (state1 { cgs_tops  = nilOL })+        ; setState $ state2 { cgs_tops = cgs_tops state1 }+        ; return (fromOL (cgs_tops state2)) }+++mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph+mkCmmIfThenElse e tbranch fbranch = mkCmmIfThenElse' e tbranch fbranch Nothing++mkCmmIfThenElse' :: CmmExpr -> CmmAGraph -> CmmAGraph+                 -> Maybe Bool -> FCode CmmAGraph+mkCmmIfThenElse' e tbranch fbranch likely = do+  tscp  <- getTickScope+  endif <- newBlockId+  tid   <- newBlockId+  fid   <- newBlockId++  let+    (test, then_, else_, likely') = case likely of+      Just False | Just e' <- maybeInvertCmmExpr e+        -- currently NCG doesn't know about likely+        -- annotations. We manually switch then and+        -- else branch so the likely false branch+        -- becomes a fallthrough.+        -> (e', fbranch, tbranch, Just True)+      _ -> (e, tbranch, fbranch, likely)++  return $ catAGraphs [ mkCbranch test tid fid likely'+                      , mkLabel tid tscp, then_, mkBranch endif+                      , mkLabel fid tscp, else_, mkLabel endif tscp ]++mkCmmIfGoto :: CmmExpr -> BlockId -> FCode CmmAGraph+mkCmmIfGoto e tid = mkCmmIfGoto' e tid Nothing++mkCmmIfGoto' :: CmmExpr -> BlockId -> Maybe Bool -> FCode CmmAGraph+mkCmmIfGoto' e tid l = do+  endif <- newBlockId+  tscp  <- getTickScope+  return $ catAGraphs [ mkCbranch e tid endif l, mkLabel endif tscp ]++mkCmmIfThen :: CmmExpr -> CmmAGraph -> FCode CmmAGraph+mkCmmIfThen e tbranch = mkCmmIfThen' e tbranch Nothing++mkCmmIfThen' :: CmmExpr -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph+mkCmmIfThen' e tbranch l = do+  endif <- newBlockId+  tid   <- newBlockId+  tscp  <- getTickScope+  return $ catAGraphs [ mkCbranch e tid endif l+                      , mkLabel tid tscp, tbranch, mkLabel endif tscp ]++mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmExpr]+       -> UpdFrameOffset -> [CmmExpr] -> FCode CmmAGraph+mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do+  dflags <- getDynFlags+  k      <- newBlockId+  tscp   <- getTickScope+  let area = Young k+      (off, _, copyin) = copyInOflow dflags retConv area results []+      copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack+  return $ catAGraphs [copyout, mkLabel k tscp, copyin]++mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmExpr] -> UpdFrameOffset+          -> FCode CmmAGraph+mkCmmCall f results actuals updfr_off+   = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off []+++-- ----------------------------------------------------------------------------+-- turn CmmAGraph into CmmGraph, for making a new proc.++aGraphToGraph :: CmmAGraphScoped -> FCode CmmGraph+aGraphToGraph stmts+  = do  { l <- newBlockId+        ; return (labelAGraph l stmts) }
+ compiler/codeGen/StgCmmPrim.hs view
@@ -0,0 +1,2590 @@+{-# LANGUAGE CPP #-}+-- emitPrimOp is quite large+{-# OPTIONS_GHC -fmax-pmcheck-iterations=4000000 #-}++----------------------------------------------------------------------------+--+-- Stg to C--: primitive operations+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmPrim (+   cgOpApp,+   cgPrimOp, -- internal(ish), used by cgCase to get code for a+             -- comparison without also turning it into a Bool.+   shouldInlinePrimOp+ ) where++#include "HsVersions.h"++import GhcPrelude hiding ((<*>))++import StgCmmLayout+import StgCmmForeign+import StgCmmEnv+import StgCmmMonad+import StgCmmUtils+import StgCmmTicky+import StgCmmHeap+import StgCmmProf ( costCentreFrom )++import DynFlags+import Platform+import BasicTypes+import BlockId+import MkGraph+import StgSyn+import Cmm+import Type     ( Type, tyConAppTyCon )+import TyCon+import CLabel+import CmmUtils+import PrimOp+import SMRep+import FastString+import Outputable+import Util++import Data.Bits ((.&.), bit)+import Control.Monad (liftM, when, unless)++------------------------------------------------------------------------+--      Primitive operations and foreign calls+------------------------------------------------------------------------++{- Note [Foreign call results]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~+A foreign call always returns an unboxed tuple of results, one+of which is the state token.  This seems to happen even for pure+calls.++Even if we returned a single result for pure calls, it'd still be+right to wrap it in a singleton unboxed tuple, because the result+might be a Haskell closure pointer, we don't want to evaluate it. -}++----------------------------------+cgOpApp :: StgOp        -- The op+        -> [StgArg]     -- Arguments+        -> Type         -- Result type (always an unboxed tuple)+        -> FCode ReturnKind++-- Foreign calls+cgOpApp (StgFCallOp fcall _) stg_args res_ty+  = cgForeignCall fcall stg_args res_ty+      -- Note [Foreign call results]++-- tagToEnum# is special: we need to pull the constructor+-- out of the table, and perform an appropriate return.++cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty+  = ASSERT(isEnumerationTyCon tycon)+    do  { dflags <- getDynFlags+        ; args' <- getNonVoidArgAmodes [arg]+        ; let amode = case args' of [amode] -> amode+                                    _ -> panic "TagToEnumOp had void arg"+        ; emitReturn [tagToClosure dflags tycon amode] }+   where+          -- If you're reading this code in the attempt to figure+          -- out why the compiler panic'ed here, it is probably because+          -- you used tagToEnum# in a non-monomorphic setting, e.g.,+          --         intToTg :: Enum a => Int -> a ; intToTg (I# x#) = tagToEnum# x#+          -- That won't work.+        tycon = tyConAppTyCon res_ty++cgOpApp (StgPrimOp primop) args res_ty = do+    dflags <- getDynFlags+    cmm_args <- getNonVoidArgAmodes args+    case shouldInlinePrimOp dflags primop cmm_args of+        Nothing -> do  -- out-of-line+          let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))+          emitCall (NativeNodeCall, NativeReturn) fun cmm_args++        Just f  -- inline+          | ReturnsPrim VoidRep <- result_info+          -> do f []+                emitReturn []++          | ReturnsPrim rep <- result_info+          -> do dflags <- getDynFlags+                res <- newTemp (primRepCmmType dflags rep)+                f [res]+                emitReturn [CmmReg (CmmLocal res)]++          | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon+          -> do (regs, _hints) <- newUnboxedTupleRegs res_ty+                f regs+                emitReturn (map (CmmReg . CmmLocal) regs)++          | otherwise -> panic "cgPrimop"+          where+             result_info = getPrimOpResultInfo primop++cgOpApp (StgPrimCallOp primcall) args _res_ty+  = do  { cmm_args <- getNonVoidArgAmodes args+        ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))+        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }++-- | Interpret the argument as an unsigned value, assuming the value+-- is given in two-complement form in the given width.+--+-- Example: @asUnsigned W64 (-1)@ is 18446744073709551615.+--+-- This function is used to work around the fact that many array+-- primops take Int# arguments, but we interpret them as unsigned+-- quantities in the code gen. This means that we have to be careful+-- every time we work on e.g. a CmmInt literal that corresponds to the+-- array size, as it might contain a negative Integer value if the+-- user passed a value larger than 2^(wORD_SIZE_IN_BITS-1) as the Int#+-- literal.+asUnsigned :: Width -> Integer -> Integer+asUnsigned w n = n .&. (bit (widthInBits w) - 1)++-- TODO: Several primop implementations (e.g. 'doNewByteArrayOp') use+--     ByteOff (or some other fixed width signed type) to represent+--     array sizes or indices. This means that these will overflow for+--     large enough sizes.++-- | Decide whether an out-of-line primop should be replaced by an+-- inline implementation. This might happen e.g. if there's enough+-- static information, such as statically know arguments, to emit a+-- more efficient implementation inline.+--+-- Returns 'Nothing' if this primop should use its out-of-line+-- implementation (defined elsewhere) and 'Just' together with a code+-- generating function that takes the output regs as arguments+-- otherwise.+shouldInlinePrimOp :: DynFlags+                   -> PrimOp     -- ^ The primop+                   -> [CmmExpr]  -- ^ The primop arguments+                   -> Maybe ([LocalReg] -> FCode ())++shouldInlinePrimOp dflags NewByteArrayOp_Char [(CmmLit (CmmInt n w))]+  | asUnsigned w n <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> doNewByteArrayOp res (fromInteger n)++shouldInlinePrimOp dflags NewArrayOp [(CmmLit (CmmInt n w)), init]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] ->+      doNewArrayOp res (arrPtrsRep dflags (fromInteger n)) mkMAP_DIRTY_infoLabel+      [ (mkIntExpr dflags (fromInteger n),+         fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags)+      , (mkIntExpr dflags (nonHdrSizeW (arrPtrsRep dflags (fromInteger n))),+         fixedHdrSize dflags + oFFSET_StgMutArrPtrs_size dflags)+      ]+      (fromInteger n) init++shouldInlinePrimOp _ CopyArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp _ CopyMutableArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp _ CopyArrayArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopyArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp _ CopyMutableArrayArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopyMutableArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp dflags CloneArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags CloneMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags FreezeArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneArray mkMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags ThawArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneArray mkMAP_DIRTY_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags NewSmallArrayOp [(CmmLit (CmmInt n w)), init]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] ->+      doNewArrayOp res (smallArrPtrsRep (fromInteger n)) mkSMAP_DIRTY_infoLabel+      [ (mkIntExpr dflags (fromInteger n),+         fixedHdrSize dflags + oFFSET_StgSmallMutArrPtrs_ptrs dflags)+      ]+      (fromInteger n) init++shouldInlinePrimOp _ CopySmallArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopySmallArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp _ CopySmallMutableArrayOp+    [src, src_off, dst, dst_off, (CmmLit (CmmInt n _))] =+        Just $ \ [] -> doCopySmallMutableArrayOp src src_off dst dst_off (fromInteger n)++shouldInlinePrimOp dflags CloneSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags CloneSmallMutableArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags FreezeSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_FROZEN_CLEAN_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags ThawSmallArrayOp [src, src_off, (CmmLit (CmmInt n w))]+  | wordsToBytes dflags (asUnsigned w n) <= fromIntegral (maxInlineAllocSize dflags) =+      Just $ \ [res] -> emitCloneSmallArray mkSMAP_DIRTY_infoLabel res src src_off (fromInteger n)++shouldInlinePrimOp dflags primop args+  | primOpOutOfLine primop = Nothing+  | otherwise = Just $ \ regs -> emitPrimOp dflags regs primop args++-- TODO: Several primops, such as 'copyArray#', only have an inline+-- implementation (below) but could possibly have both an inline+-- implementation and an out-of-line implementation, just like+-- 'newArray#'. This would lower the amount of code generated,+-- hopefully without a performance impact (needs to be measured).++---------------------------------------------------+cgPrimOp   :: [LocalReg]        -- where to put the results+           -> PrimOp            -- the op+           -> [StgArg]          -- arguments+           -> FCode ()++cgPrimOp results op args+  = do dflags <- getDynFlags+       arg_exprs <- getNonVoidArgAmodes args+       emitPrimOp dflags results op arg_exprs+++------------------------------------------------------------------------+--      Emitting code for a primop+------------------------------------------------------------------------++emitPrimOp :: DynFlags+           -> [LocalReg]        -- where to put the results+           -> PrimOp            -- the op+           -> [CmmExpr]         -- arguments+           -> FCode ()++-- First we handle various awkward cases specially.  The remaining+-- easy cases are then handled by translateOp, defined below.++emitPrimOp _ [res] ParOp [arg]+  =+        -- for now, just implement this in a C function+        -- later, we might want to inline it.+    emitCCall+        [(res,NoHint)]+        (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))+        [(baseExpr, AddrHint), (arg,AddrHint)]++emitPrimOp dflags [res] SparkOp [arg]+  = do+        -- returns the value of arg in res.  We're going to therefore+        -- refer to arg twice (once to pass to newSpark(), and once to+        -- assign to res), so put it in a temporary.+        tmp <- assignTemp arg+        tmp2 <- newTemp (bWord dflags)+        emitCCall+            [(tmp2,NoHint)]+            (CmmLit (CmmLabel (mkForeignLabel (fsLit "newSpark") Nothing ForeignLabelInExternalPackage IsFunction)))+            [(baseExpr, AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)]+        emitAssign (CmmLocal res) (CmmReg (CmmLocal tmp))++emitPrimOp dflags [res] GetCCSOfOp [arg]+  = emitAssign (CmmLocal res) val+  where+    val+     | gopt Opt_SccProfilingOn dflags = costCentreFrom dflags (cmmUntag dflags arg)+     | otherwise                      = CmmLit (zeroCLit dflags)++emitPrimOp _ [res] GetCurrentCCSOp [_dummy_arg]+   = emitAssign (CmmLocal res) cccsExpr++emitPrimOp _ [res] MyThreadIdOp []+   = emitAssign (CmmLocal res) currentTSOExpr++emitPrimOp dflags [res] ReadMutVarOp [mutv]+   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags mutv (fixedHdrSizeW dflags) (gcWord dflags))++emitPrimOp dflags res@[] WriteMutVarOp [mutv,var]+   = do -- Without this write barrier, other CPUs may see this pointer before+        -- the writes for the closure it points to have occurred.+        emitPrimCall res MO_WriteBarrier []+        emitStore (cmmOffsetW dflags mutv (fixedHdrSizeW dflags)) var+        emitCCall+                [{-no results-}]+                (CmmLit (CmmLabel mkDirty_MUT_VAR_Label))+                [(baseExpr, AddrHint), (mutv,AddrHint)]++--  #define sizzeofByteArrayzh(r,a) \+--     r = ((StgArrBytes *)(a))->bytes+emitPrimOp dflags [res] SizeofByteArrayOp [arg]+   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))++--  #define sizzeofMutableByteArrayzh(r,a) \+--      r = ((StgArrBytes *)(a))->bytes+emitPrimOp dflags [res] SizeofMutableByteArrayOp [arg]+   = emitPrimOp dflags [res] SizeofByteArrayOp [arg]++--  #define getSizzeofMutableByteArrayzh(r,a) \+--      r = ((StgArrBytes *)(a))->bytes+emitPrimOp dflags [res] GetSizeofMutableByteArrayOp [arg]+   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))+++--  #define touchzh(o)                  /* nothing */+emitPrimOp _ res@[] TouchOp args@[_arg]+   = do emitPrimCall res MO_Touch args++--  #define byteArrayContentszh(r,a) r = BYTE_ARR_CTS(a)+emitPrimOp dflags [res] ByteArrayContents_Char [arg]+   = emitAssign (CmmLocal res) (cmmOffsetB dflags arg (arrWordsHdrSize dflags))++--  #define stableNameToIntzh(r,s)   (r = ((StgStableName *)s)->sn)+emitPrimOp dflags [res] StableNameToIntOp [arg]+   = emitAssign (CmmLocal res) (cmmLoadIndexW dflags arg (fixedHdrSizeW dflags) (bWord dflags))++emitPrimOp dflags [res] ReallyUnsafePtrEqualityOp [arg1,arg2]+   = emitAssign (CmmLocal res) (CmmMachOp (mo_wordEq dflags) [arg1,arg2])++--  #define addrToHValuezh(r,a) r=(P_)a+emitPrimOp _      [res] AddrToAnyOp [arg]+   = emitAssign (CmmLocal res) arg++--  #define hvalueToAddrzh(r, a) r=(W_)a+emitPrimOp _      [res] AnyToAddrOp [arg]+   = emitAssign (CmmLocal res) arg++{- Freezing arrays-of-ptrs requires changing an info table, for the+   benefit of the generational collector.  It needs to scavenge mutable+   objects, even if they are in old space.  When they become immutable,+   they can be removed from this scavenge list.  -}++--  #define unsafeFreezzeArrayzh(r,a)+--      {+--        SET_INFO((StgClosure *)a,&stg_MUT_ARR_PTRS_FROZEN_DIRTY_info);+--        r = a;+--      }+emitPrimOp _      [res] UnsafeFreezeArrayOp [arg]+   = emit $ catAGraphs+   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),+     mkAssign (CmmLocal res) arg ]+emitPrimOp _      [res] UnsafeFreezeArrayArrayOp [arg]+   = emit $ catAGraphs+   [ setInfo arg (CmmLit (CmmLabel mkMAP_FROZEN_DIRTY_infoLabel)),+     mkAssign (CmmLocal res) arg ]+emitPrimOp _      [res] UnsafeFreezeSmallArrayOp [arg]+   = emit $ catAGraphs+   [ setInfo arg (CmmLit (CmmLabel mkSMAP_FROZEN_DIRTY_infoLabel)),+     mkAssign (CmmLocal res) arg ]++--  #define unsafeFreezzeByteArrayzh(r,a)       r=(a)+emitPrimOp _      [res] UnsafeFreezeByteArrayOp [arg]+   = emitAssign (CmmLocal res) arg++-- Reading/writing pointer arrays++emitPrimOp _      [res] ReadArrayOp  [obj,ix]    = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] IndexArrayOp [obj,ix]    = doReadPtrArrayOp res obj ix+emitPrimOp _      []  WriteArrayOp [obj,ix,v]  = doWritePtrArrayOp obj ix v++emitPrimOp _      [res] IndexArrayArrayOp_ByteArray         [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] IndexArrayArrayOp_ArrayArray        [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] ReadArrayArrayOp_ByteArray          [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] ReadArrayArrayOp_MutableByteArray   [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] ReadArrayArrayOp_ArrayArray         [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      [res] ReadArrayArrayOp_MutableArrayArray  [obj,ix]   = doReadPtrArrayOp res obj ix+emitPrimOp _      []  WriteArrayArrayOp_ByteArray         [obj,ix,v] = doWritePtrArrayOp obj ix v+emitPrimOp _      []  WriteArrayArrayOp_MutableByteArray  [obj,ix,v] = doWritePtrArrayOp obj ix v+emitPrimOp _      []  WriteArrayArrayOp_ArrayArray        [obj,ix,v] = doWritePtrArrayOp obj ix v+emitPrimOp _      []  WriteArrayArrayOp_MutableArrayArray [obj,ix,v] = doWritePtrArrayOp obj ix v++emitPrimOp _      [res] ReadSmallArrayOp  [obj,ix] = doReadSmallPtrArrayOp res obj ix+emitPrimOp _      [res] IndexSmallArrayOp [obj,ix] = doReadSmallPtrArrayOp res obj ix+emitPrimOp _      []  WriteSmallArrayOp [obj,ix,v] = doWriteSmallPtrArrayOp obj ix v++-- Getting the size of pointer arrays++emitPrimOp dflags [res] SizeofArrayOp [arg]+   = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW dflags arg+    (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgMutArrPtrs_ptrs dflags))+        (bWord dflags))+emitPrimOp dflags [res] SizeofMutableArrayOp [arg]+   = emitPrimOp dflags [res] SizeofArrayOp [arg]+emitPrimOp dflags [res] SizeofArrayArrayOp [arg]+   = emitPrimOp dflags [res] SizeofArrayOp [arg]+emitPrimOp dflags [res] SizeofMutableArrayArrayOp [arg]+   = emitPrimOp dflags [res] SizeofArrayOp [arg]++emitPrimOp dflags [res] SizeofSmallArrayOp [arg] =+    emit $ mkAssign (CmmLocal res)+    (cmmLoadIndexW dflags arg+     (fixedHdrSizeW dflags + bytesToWordsRoundUp dflags (oFFSET_StgSmallMutArrPtrs_ptrs dflags))+        (bWord dflags))+emitPrimOp dflags [res] SizeofSmallMutableArrayOp [arg] =+    emitPrimOp dflags [res] SizeofSmallArrayOp [arg]++-- IndexXXXoffAddr++emitPrimOp dflags res IndexOffAddrOp_Char             args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args+emitPrimOp dflags res IndexOffAddrOp_WideChar         args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp dflags res IndexOffAddrOp_Int              args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexOffAddrOp_Word             args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexOffAddrOp_Addr             args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp _      res IndexOffAddrOp_Float            args = doIndexOffAddrOp   Nothing f32 res args+emitPrimOp _      res IndexOffAddrOp_Double           args = doIndexOffAddrOp   Nothing f64 res args+emitPrimOp dflags res IndexOffAddrOp_StablePtr        args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexOffAddrOp_Int8             args = doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args+emitPrimOp dflags res IndexOffAddrOp_Int16            args = doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args+emitPrimOp dflags res IndexOffAddrOp_Int32            args = doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args+emitPrimOp _      res IndexOffAddrOp_Int64            args = doIndexOffAddrOp   Nothing b64 res args+emitPrimOp dflags res IndexOffAddrOp_Word8            args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args+emitPrimOp dflags res IndexOffAddrOp_Word16           args = doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args+emitPrimOp dflags res IndexOffAddrOp_Word32           args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp _      res IndexOffAddrOp_Word64           args = doIndexOffAddrOp   Nothing b64 res args++-- ReadXXXoffAddr, which are identical, for our purposes, to IndexXXXoffAddr.++emitPrimOp dflags res ReadOffAddrOp_Char             args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8 res args+emitPrimOp dflags res ReadOffAddrOp_WideChar         args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp dflags res ReadOffAddrOp_Int              args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadOffAddrOp_Word             args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadOffAddrOp_Addr             args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp _      res ReadOffAddrOp_Float            args = doIndexOffAddrOp   Nothing f32 res args+emitPrimOp _      res ReadOffAddrOp_Double           args = doIndexOffAddrOp   Nothing f64 res args+emitPrimOp dflags res ReadOffAddrOp_StablePtr        args = doIndexOffAddrOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadOffAddrOp_Int8             args = doIndexOffAddrOp   (Just (mo_s_8ToWord dflags)) b8  res args+emitPrimOp dflags res ReadOffAddrOp_Int16            args = doIndexOffAddrOp   (Just (mo_s_16ToWord dflags)) b16 res args+emitPrimOp dflags res ReadOffAddrOp_Int32            args = doIndexOffAddrOp   (Just (mo_s_32ToWord dflags)) b32 res args+emitPrimOp _      res ReadOffAddrOp_Int64            args = doIndexOffAddrOp   Nothing b64 res args+emitPrimOp dflags res ReadOffAddrOp_Word8            args = doIndexOffAddrOp   (Just (mo_u_8ToWord dflags)) b8  res args+emitPrimOp dflags res ReadOffAddrOp_Word16           args = doIndexOffAddrOp   (Just (mo_u_16ToWord dflags)) b16 res args+emitPrimOp dflags res ReadOffAddrOp_Word32           args = doIndexOffAddrOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp _      res ReadOffAddrOp_Word64           args = doIndexOffAddrOp   Nothing b64 res args++-- IndexXXXArray++emitPrimOp dflags res IndexByteArrayOp_Char             args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args+emitPrimOp dflags res IndexByteArrayOp_WideChar         args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp dflags res IndexByteArrayOp_Int              args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexByteArrayOp_Word             args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexByteArrayOp_Addr             args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp _      res IndexByteArrayOp_Float            args = doIndexByteArrayOp   Nothing f32 res args+emitPrimOp _      res IndexByteArrayOp_Double           args = doIndexByteArrayOp   Nothing f64 res args+emitPrimOp dflags res IndexByteArrayOp_StablePtr        args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res IndexByteArrayOp_Int8             args = doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args+emitPrimOp dflags res IndexByteArrayOp_Int16            args = doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args+emitPrimOp dflags res IndexByteArrayOp_Int32            args = doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args+emitPrimOp _      res IndexByteArrayOp_Int64            args = doIndexByteArrayOp   Nothing b64  res args+emitPrimOp dflags res IndexByteArrayOp_Word8            args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args+emitPrimOp dflags res IndexByteArrayOp_Word16           args = doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args+emitPrimOp dflags res IndexByteArrayOp_Word32           args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args+emitPrimOp _      res IndexByteArrayOp_Word64           args = doIndexByteArrayOp   Nothing b64  res args++-- ReadXXXArray, identical to IndexXXXArray.++emitPrimOp dflags res ReadByteArrayOp_Char             args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8 res args+emitPrimOp dflags res ReadByteArrayOp_WideChar         args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32 res args+emitPrimOp dflags res ReadByteArrayOp_Int              args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadByteArrayOp_Word             args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadByteArrayOp_Addr             args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp _      res ReadByteArrayOp_Float            args = doIndexByteArrayOp   Nothing f32 res args+emitPrimOp _      res ReadByteArrayOp_Double           args = doIndexByteArrayOp   Nothing f64 res args+emitPrimOp dflags res ReadByteArrayOp_StablePtr        args = doIndexByteArrayOp   Nothing (bWord dflags) res args+emitPrimOp dflags res ReadByteArrayOp_Int8             args = doIndexByteArrayOp   (Just (mo_s_8ToWord dflags)) b8  res args+emitPrimOp dflags res ReadByteArrayOp_Int16            args = doIndexByteArrayOp   (Just (mo_s_16ToWord dflags)) b16  res args+emitPrimOp dflags res ReadByteArrayOp_Int32            args = doIndexByteArrayOp   (Just (mo_s_32ToWord dflags)) b32  res args+emitPrimOp _      res ReadByteArrayOp_Int64            args = doIndexByteArrayOp   Nothing b64  res args+emitPrimOp dflags res ReadByteArrayOp_Word8            args = doIndexByteArrayOp   (Just (mo_u_8ToWord dflags)) b8  res args+emitPrimOp dflags res ReadByteArrayOp_Word16           args = doIndexByteArrayOp   (Just (mo_u_16ToWord dflags)) b16  res args+emitPrimOp dflags res ReadByteArrayOp_Word32           args = doIndexByteArrayOp   (Just (mo_u_32ToWord dflags)) b32  res args+emitPrimOp _      res ReadByteArrayOp_Word64           args = doIndexByteArrayOp   Nothing b64  res args++-- IndexWord8ArrayAsXXX++emitPrimOp dflags res IndexByteArrayOp_Word8AsChar      args = doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsWideChar  args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsInt       args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsWord      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsAddr      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+emitPrimOp _      res IndexByteArrayOp_Word8AsFloat     args = doIndexByteArrayOpAs   Nothing f32 b8 res args+emitPrimOp _      res IndexByteArrayOp_Word8AsDouble    args = doIndexByteArrayOpAs   Nothing f64 b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsStablePtr args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsInt16     args = doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsInt32     args = doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args+emitPrimOp _      res IndexByteArrayOp_Word8AsInt64     args = doIndexByteArrayOpAs   Nothing b64 b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsWord16    args = doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args+emitPrimOp dflags res IndexByteArrayOp_Word8AsWord32    args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+emitPrimOp _      res IndexByteArrayOp_Word8AsWord64    args = doIndexByteArrayOpAs   Nothing b64 b8 res args++-- ReadInt8ArrayAsXXX, identical to IndexInt8ArrayAsXXX++emitPrimOp dflags res ReadByteArrayOp_Word8AsChar      args = doIndexByteArrayOpAs   (Just (mo_u_8ToWord dflags)) b8 b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsWideChar  args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsInt       args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsWord      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsAddr      args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+emitPrimOp _      res ReadByteArrayOp_Word8AsFloat     args = doIndexByteArrayOpAs   Nothing f32 b8 res args+emitPrimOp _      res ReadByteArrayOp_Word8AsDouble    args = doIndexByteArrayOpAs   Nothing f64 b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsStablePtr args = doIndexByteArrayOpAs   Nothing (bWord dflags) b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsInt16     args = doIndexByteArrayOpAs   (Just (mo_s_16ToWord dflags)) b16 b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsInt32     args = doIndexByteArrayOpAs   (Just (mo_s_32ToWord dflags)) b32 b8 res args+emitPrimOp _      res ReadByteArrayOp_Word8AsInt64     args = doIndexByteArrayOpAs   Nothing b64 b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsWord16    args = doIndexByteArrayOpAs   (Just (mo_u_16ToWord dflags)) b16 b8 res args+emitPrimOp dflags res ReadByteArrayOp_Word8AsWord32    args = doIndexByteArrayOpAs   (Just (mo_u_32ToWord dflags)) b32 b8 res args+emitPrimOp _      res ReadByteArrayOp_Word8AsWord64    args = doIndexByteArrayOpAs   Nothing b64 b8 res args++-- WriteXXXoffAddr++emitPrimOp dflags res WriteOffAddrOp_Char             args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+emitPrimOp dflags res WriteOffAddrOp_WideChar         args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp dflags res WriteOffAddrOp_Int              args = doWriteOffAddrOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteOffAddrOp_Word             args = doWriteOffAddrOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteOffAddrOp_Addr             args = doWriteOffAddrOp Nothing (bWord dflags) res args+emitPrimOp _      res WriteOffAddrOp_Float            args = doWriteOffAddrOp Nothing f32 res args+emitPrimOp _      res WriteOffAddrOp_Double           args = doWriteOffAddrOp Nothing f64 res args+emitPrimOp dflags res WriteOffAddrOp_StablePtr        args = doWriteOffAddrOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteOffAddrOp_Int8             args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+emitPrimOp dflags res WriteOffAddrOp_Int16            args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args+emitPrimOp dflags res WriteOffAddrOp_Int32            args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp _      res WriteOffAddrOp_Int64            args = doWriteOffAddrOp Nothing b64 res args+emitPrimOp dflags res WriteOffAddrOp_Word8            args = doWriteOffAddrOp (Just (mo_WordTo8 dflags))  b8 res args+emitPrimOp dflags res WriteOffAddrOp_Word16           args = doWriteOffAddrOp (Just (mo_WordTo16 dflags)) b16 res args+emitPrimOp dflags res WriteOffAddrOp_Word32           args = doWriteOffAddrOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp _      res WriteOffAddrOp_Word64           args = doWriteOffAddrOp Nothing b64 res args++-- WriteXXXArray++emitPrimOp dflags res WriteByteArrayOp_Char             args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+emitPrimOp dflags res WriteByteArrayOp_WideChar         args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp dflags res WriteByteArrayOp_Int              args = doWriteByteArrayOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteByteArrayOp_Word             args = doWriteByteArrayOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteByteArrayOp_Addr             args = doWriteByteArrayOp Nothing (bWord dflags) res args+emitPrimOp _      res WriteByteArrayOp_Float            args = doWriteByteArrayOp Nothing f32 res args+emitPrimOp _      res WriteByteArrayOp_Double           args = doWriteByteArrayOp Nothing f64 res args+emitPrimOp dflags res WriteByteArrayOp_StablePtr        args = doWriteByteArrayOp Nothing (bWord dflags) res args+emitPrimOp dflags res WriteByteArrayOp_Int8             args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+emitPrimOp dflags res WriteByteArrayOp_Int16            args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args+emitPrimOp dflags res WriteByteArrayOp_Int32            args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp _      res WriteByteArrayOp_Int64            args = doWriteByteArrayOp Nothing b64 res args+emitPrimOp dflags res WriteByteArrayOp_Word8            args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8  res args+emitPrimOp dflags res WriteByteArrayOp_Word16           args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b16 res args+emitPrimOp dflags res WriteByteArrayOp_Word32           args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b32 res args+emitPrimOp _      res WriteByteArrayOp_Word64           args = doWriteByteArrayOp Nothing b64 res args++-- WriteInt8ArrayAsXXX++emitPrimOp dflags res WriteByteArrayOp_Word8AsChar       args = doWriteByteArrayOp (Just (mo_WordTo8 dflags))  b8 res args+emitPrimOp dflags res WriteByteArrayOp_Word8AsWideChar   args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+emitPrimOp _      res WriteByteArrayOp_Word8AsInt        args = doWriteByteArrayOp Nothing b8 res args+emitPrimOp _      res WriteByteArrayOp_Word8AsWord       args = doWriteByteArrayOp Nothing b8 res args+emitPrimOp _      res WriteByteArrayOp_Word8AsAddr       args = doWriteByteArrayOp Nothing b8 res args+emitPrimOp _      res WriteByteArrayOp_Word8AsFloat      args = doWriteByteArrayOp Nothing b8 res args+emitPrimOp _      res WriteByteArrayOp_Word8AsDouble     args = doWriteByteArrayOp Nothing b8 res args+emitPrimOp _      res WriteByteArrayOp_Word8AsStablePtr  args = doWriteByteArrayOp Nothing b8 res args+emitPrimOp dflags res WriteByteArrayOp_Word8AsInt16      args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args+emitPrimOp dflags res WriteByteArrayOp_Word8AsInt32      args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+emitPrimOp _      res WriteByteArrayOp_Word8AsInt64      args = doWriteByteArrayOp Nothing b8 res args+emitPrimOp dflags res WriteByteArrayOp_Word8AsWord16     args = doWriteByteArrayOp (Just (mo_WordTo16 dflags)) b8 res args+emitPrimOp dflags res WriteByteArrayOp_Word8AsWord32     args = doWriteByteArrayOp (Just (mo_WordTo32 dflags)) b8 res args+emitPrimOp _      res WriteByteArrayOp_Word8AsWord64     args = doWriteByteArrayOp Nothing b8 res args++-- Copying and setting byte arrays+emitPrimOp _      [] CopyByteArrayOp [src,src_off,dst,dst_off,n] =+    doCopyByteArrayOp src src_off dst dst_off n+emitPrimOp _      [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] =+    doCopyMutableByteArrayOp src src_off dst dst_off n+emitPrimOp _      [] CopyByteArrayToAddrOp [src,src_off,dst,n] =+    doCopyByteArrayToAddrOp src src_off dst n+emitPrimOp _      [] CopyMutableByteArrayToAddrOp [src,src_off,dst,n] =+    doCopyMutableByteArrayToAddrOp src src_off dst n+emitPrimOp _      [] CopyAddrToByteArrayOp [src,dst,dst_off,n] =+    doCopyAddrToByteArrayOp src dst dst_off n+emitPrimOp _      [] SetByteArrayOp [ba,off,len,c] =+    doSetByteArrayOp ba off len c++-- Comparing byte arrays+emitPrimOp _      [res] CompareByteArraysOp [ba1,ba1_off,ba2,ba2_off,n] =+    doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n++emitPrimOp _      [res] BSwap16Op [w] = emitBSwapCall res w W16+emitPrimOp _      [res] BSwap32Op [w] = emitBSwapCall res w W32+emitPrimOp _      [res] BSwap64Op [w] = emitBSwapCall res w W64+emitPrimOp dflags [res] BSwapOp   [w] = emitBSwapCall res w (wordWidth dflags)++emitPrimOp _      [res] BRev8Op  [w] = emitBRevCall res w W8+emitPrimOp _      [res] BRev16Op [w] = emitBRevCall res w W16+emitPrimOp _      [res] BRev32Op [w] = emitBRevCall res w W32+emitPrimOp _      [res] BRev64Op [w] = emitBRevCall res w W64+emitPrimOp dflags [res] BRevOp   [w] = emitBRevCall res w (wordWidth dflags)++-- Population count+emitPrimOp _      [res] PopCnt8Op  [w] = emitPopCntCall res w W8+emitPrimOp _      [res] PopCnt16Op [w] = emitPopCntCall res w W16+emitPrimOp _      [res] PopCnt32Op [w] = emitPopCntCall res w W32+emitPrimOp _      [res] PopCnt64Op [w] = emitPopCntCall res w W64+emitPrimOp dflags [res] PopCntOp   [w] = emitPopCntCall res w (wordWidth dflags)++-- Parallel bit deposit+emitPrimOp _      [res] Pdep8Op  [src, mask] = emitPdepCall res src mask W8+emitPrimOp _      [res] Pdep16Op [src, mask] = emitPdepCall res src mask W16+emitPrimOp _      [res] Pdep32Op [src, mask] = emitPdepCall res src mask W32+emitPrimOp _      [res] Pdep64Op [src, mask] = emitPdepCall res src mask W64+emitPrimOp dflags [res] PdepOp   [src, mask] = emitPdepCall res src mask (wordWidth dflags)++-- Parallel bit extract+emitPrimOp _      [res] Pext8Op  [src, mask] = emitPextCall res src mask W8+emitPrimOp _      [res] Pext16Op [src, mask] = emitPextCall res src mask W16+emitPrimOp _      [res] Pext32Op [src, mask] = emitPextCall res src mask W32+emitPrimOp _      [res] Pext64Op [src, mask] = emitPextCall res src mask W64+emitPrimOp dflags [res] PextOp   [src, mask] = emitPextCall res src mask (wordWidth dflags)++-- count leading zeros+emitPrimOp _      [res] Clz8Op  [w] = emitClzCall res w W8+emitPrimOp _      [res] Clz16Op [w] = emitClzCall res w W16+emitPrimOp _      [res] Clz32Op [w] = emitClzCall res w W32+emitPrimOp _      [res] Clz64Op [w] = emitClzCall res w W64+emitPrimOp dflags [res] ClzOp   [w] = emitClzCall res w (wordWidth dflags)++-- count trailing zeros+emitPrimOp _      [res] Ctz8Op [w]  = emitCtzCall res w W8+emitPrimOp _      [res] Ctz16Op [w] = emitCtzCall res w W16+emitPrimOp _      [res] Ctz32Op [w] = emitCtzCall res w W32+emitPrimOp _      [res] Ctz64Op [w] = emitCtzCall res w W64+emitPrimOp dflags [res] CtzOp   [w] = emitCtzCall res w (wordWidth dflags)++-- Unsigned int to floating point conversions+emitPrimOp _      [res] Word2FloatOp  [w] = emitPrimCall [res]+                                            (MO_UF_Conv W32) [w]+emitPrimOp _      [res] Word2DoubleOp [w] = emitPrimCall [res]+                                            (MO_UF_Conv W64) [w]++-- SIMD primops+emitPrimOp dflags [res] (VecBroadcastOp vcat n w) [e] = do+    checkVecCompatibility dflags vcat n w+    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros (replicate n e) res+  where+    zeros :: CmmExpr+    zeros = CmmLit $ CmmVec (replicate n zero)++    zero :: CmmLit+    zero = case vcat of+             IntVec   -> CmmInt 0 w+             WordVec  -> CmmInt 0 w+             FloatVec -> CmmFloat 0 w++    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags [res] (VecPackOp vcat n w) es = do+    checkVecCompatibility dflags vcat n w+    when (es `lengthIsNot` n) $+        panic "emitPrimOp: VecPackOp has wrong number of arguments"+    doVecPackOp (vecElemInjectCast dflags vcat w) ty zeros es res+  where+    zeros :: CmmExpr+    zeros = CmmLit $ CmmVec (replicate n zero)++    zero :: CmmLit+    zero = case vcat of+             IntVec   -> CmmInt 0 w+             WordVec  -> CmmInt 0 w+             FloatVec -> CmmFloat 0 w++    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecUnpackOp vcat n w) [arg] = do+    checkVecCompatibility dflags vcat n w+    when (res `lengthIsNot` n) $+        panic "emitPrimOp: VecUnpackOp has wrong number of results"+    doVecUnpackOp (vecElemProjectCast dflags vcat w) ty arg res+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags [res] (VecInsertOp vcat n w) [v,e,i] = do+    checkVecCompatibility dflags vcat n w+    doVecInsertOp (vecElemInjectCast dflags vcat w) ty v e i res+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecIndexByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecReadByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecWriteByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doWriteByteArrayOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecIndexOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecReadOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecWriteOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doWriteOffAddrOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecVmmType vcat n w++emitPrimOp dflags res (VecIndexScalarByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOpAs Nothing vecty ty res args+  where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++emitPrimOp dflags res (VecReadScalarByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexByteArrayOpAs Nothing vecty ty res args+  where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++emitPrimOp dflags res (VecWriteScalarByteArrayOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doWriteByteArrayOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecCmmCat vcat w++emitPrimOp dflags res (VecIndexScalarOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOpAs Nothing vecty ty res args+  where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++emitPrimOp dflags res (VecReadScalarOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doIndexOffAddrOpAs Nothing vecty ty res args+  where+    vecty :: CmmType+    vecty = vecVmmType vcat n w++    ty :: CmmType+    ty = vecCmmCat vcat w++emitPrimOp dflags res (VecWriteScalarOffAddrOp vcat n w) args = do+    checkVecCompatibility dflags vcat n w+    doWriteOffAddrOp Nothing ty res args+  where+    ty :: CmmType+    ty = vecCmmCat vcat w++-- Prefetch+emitPrimOp _ [] PrefetchByteArrayOp3        args = doPrefetchByteArrayOp 3  args+emitPrimOp _ [] PrefetchMutableByteArrayOp3 args = doPrefetchMutableByteArrayOp 3  args+emitPrimOp _ [] PrefetchAddrOp3             args = doPrefetchAddrOp  3  args+emitPrimOp _ [] PrefetchValueOp3            args = doPrefetchValueOp 3 args++emitPrimOp _ [] PrefetchByteArrayOp2        args = doPrefetchByteArrayOp 2  args+emitPrimOp _ [] PrefetchMutableByteArrayOp2 args = doPrefetchMutableByteArrayOp 2  args+emitPrimOp _ [] PrefetchAddrOp2             args = doPrefetchAddrOp 2  args+emitPrimOp _ [] PrefetchValueOp2           args = doPrefetchValueOp 2 args++emitPrimOp _ [] PrefetchByteArrayOp1        args = doPrefetchByteArrayOp 1  args+emitPrimOp _ [] PrefetchMutableByteArrayOp1 args = doPrefetchMutableByteArrayOp 1  args+emitPrimOp _ [] PrefetchAddrOp1             args = doPrefetchAddrOp 1  args+emitPrimOp _ [] PrefetchValueOp1            args = doPrefetchValueOp 1 args++emitPrimOp _ [] PrefetchByteArrayOp0        args = doPrefetchByteArrayOp 0  args+emitPrimOp _ [] PrefetchMutableByteArrayOp0 args = doPrefetchMutableByteArrayOp 0  args+emitPrimOp _ [] PrefetchAddrOp0             args = doPrefetchAddrOp 0  args+emitPrimOp _ [] PrefetchValueOp0            args = doPrefetchValueOp 0 args++-- Atomic read-modify-write+emitPrimOp dflags [res] FetchAddByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_Add mba ix (bWord dflags) n+emitPrimOp dflags [res] FetchSubByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_Sub mba ix (bWord dflags) n+emitPrimOp dflags [res] FetchAndByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_And mba ix (bWord dflags) n+emitPrimOp dflags [res] FetchNandByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_Nand mba ix (bWord dflags) n+emitPrimOp dflags [res] FetchOrByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_Or mba ix (bWord dflags) n+emitPrimOp dflags [res] FetchXorByteArrayOp_Int [mba, ix, n] =+    doAtomicRMW res AMO_Xor mba ix (bWord dflags) n+emitPrimOp dflags [res] AtomicReadByteArrayOp_Int [mba, ix] =+    doAtomicReadByteArray res mba ix (bWord dflags)+emitPrimOp dflags [] AtomicWriteByteArrayOp_Int [mba, ix, val] =+    doAtomicWriteByteArray mba ix (bWord dflags) val+emitPrimOp dflags [res] CasByteArrayOp_Int [mba, ix, old, new] =+    doCasByteArray res mba ix (bWord dflags) old new++-- The rest just translate straightforwardly+emitPrimOp dflags [res] op [arg]+   | nopOp op+   = emitAssign (CmmLocal res) arg++   | Just (mop,rep) <- narrowOp op+   = emitAssign (CmmLocal res) $+           CmmMachOp (mop rep (wordWidth dflags)) [CmmMachOp (mop (wordWidth dflags) rep) [arg]]++emitPrimOp dflags r@[res] op args+   | Just prim <- callishOp op+   = do emitPrimCall r prim args++   | Just mop <- translateOp dflags op+   = let stmt = mkAssign (CmmLocal res) (CmmMachOp mop args) in+     emit stmt++emitPrimOp dflags results op args+   = case callishPrimOpSupported dflags op of+          Left op   -> emit $ mkUnsafeCall (PrimTarget op) results args+          Right gen -> gen results args++type GenericOp = [CmmFormal] -> [CmmActual] -> FCode ()++callishPrimOpSupported :: DynFlags -> PrimOp -> Either CallishMachOp GenericOp+callishPrimOpSupported dflags op+  = case op of+      IntQuotRemOp   | ncg && (x86ish || ppc) ->+                         Left (MO_S_QuotRem  (wordWidth dflags))+                     | otherwise              ->+                         Right (genericIntQuotRemOp (wordWidth dflags))++      Int8QuotRemOp  | ncg && (x86ish || ppc)+                                     -> Left (MO_S_QuotRem W8)+                     | otherwise     -> Right (genericIntQuotRemOp W8)++      Int16QuotRemOp | ncg && (x86ish || ppc)+                                     -> Left (MO_S_QuotRem W16)+                     | otherwise     -> Right (genericIntQuotRemOp W16)+++      WordQuotRemOp  | ncg && (x86ish || ppc) ->+                         Left (MO_U_QuotRem  (wordWidth dflags))+                     | otherwise      ->+                         Right (genericWordQuotRemOp (wordWidth dflags))++      WordQuotRem2Op | (ncg && (x86ish || ppc))+                          || llvm     -> Left (MO_U_QuotRem2 (wordWidth dflags))+                     | otherwise      -> Right (genericWordQuotRem2Op dflags)++      Word8QuotRemOp | ncg && (x86ish || ppc)+                                      -> Left (MO_U_QuotRem W8)+                     | otherwise      -> Right (genericWordQuotRemOp W8)++      Word16QuotRemOp| ncg && (x86ish || ppc)+                                     -> Left (MO_U_QuotRem W16)+                     | otherwise     -> Right (genericWordQuotRemOp W16)++      WordAdd2Op     | (ncg && (x86ish || ppc))+                         || llvm      -> Left (MO_Add2       (wordWidth dflags))+                     | otherwise      -> Right genericWordAdd2Op++      WordAddCOp     | (ncg && (x86ish || ppc))+                         || llvm      -> Left (MO_AddWordC   (wordWidth dflags))+                     | otherwise      -> Right genericWordAddCOp++      WordSubCOp     | (ncg && (x86ish || ppc))+                         || llvm      -> Left (MO_SubWordC   (wordWidth dflags))+                     | otherwise      -> Right genericWordSubCOp++      IntAddCOp      | (ncg && (x86ish || ppc))+                         || llvm      -> Left (MO_AddIntC    (wordWidth dflags))+                     | otherwise      -> Right genericIntAddCOp++      IntSubCOp      | (ncg && (x86ish || ppc))+                         || llvm      -> Left (MO_SubIntC    (wordWidth dflags))+                     | otherwise      -> Right genericIntSubCOp++      WordMul2Op     | ncg && (x86ish || ppc)+                         || llvm      -> Left (MO_U_Mul2     (wordWidth dflags))+                     | otherwise      -> Right genericWordMul2Op+      FloatFabsOp    | (ncg && x86ish || ppc)+                         || llvm      -> Left MO_F32_Fabs+                     | otherwise      -> Right $ genericFabsOp W32+      DoubleFabsOp   | (ncg && x86ish || ppc)+                         || llvm      -> Left MO_F64_Fabs+                     | otherwise      -> Right $ genericFabsOp W64++      _ -> pprPanic "emitPrimOp: can't translate PrimOp " (ppr op)+ where+  ncg = case hscTarget dflags of+           HscAsm -> True+           _      -> False+  llvm = case hscTarget dflags of+           HscLlvm -> True+           _       -> False+  x86ish = case platformArch (targetPlatform dflags) of+             ArchX86    -> True+             ArchX86_64 -> True+             _          -> False+  ppc = case platformArch (targetPlatform dflags) of+          ArchPPC      -> True+          ArchPPC_64 _ -> True+          _            -> False++genericIntQuotRemOp :: Width -> GenericOp+genericIntQuotRemOp width [res_q, res_r] [arg_x, arg_y]+   = emit $ mkAssign (CmmLocal res_q)+              (CmmMachOp (MO_S_Quot width) [arg_x, arg_y]) <*>+            mkAssign (CmmLocal res_r)+              (CmmMachOp (MO_S_Rem  width) [arg_x, arg_y])+genericIntQuotRemOp _ _ _ = panic "genericIntQuotRemOp"++genericWordQuotRemOp :: Width -> GenericOp+genericWordQuotRemOp width [res_q, res_r] [arg_x, arg_y]+    = emit $ mkAssign (CmmLocal res_q)+               (CmmMachOp (MO_U_Quot width) [arg_x, arg_y]) <*>+             mkAssign (CmmLocal res_r)+               (CmmMachOp (MO_U_Rem  width) [arg_x, arg_y])+genericWordQuotRemOp _ _ _ = panic "genericWordQuotRemOp"++genericWordQuotRem2Op :: DynFlags -> GenericOp+genericWordQuotRem2Op dflags [res_q, res_r] [arg_x_high, arg_x_low, arg_y]+    = emit =<< f (widthInBits (wordWidth dflags)) zero arg_x_high arg_x_low+    where    ty = cmmExprType dflags arg_x_high+             shl   x i = CmmMachOp (MO_Shl   (wordWidth dflags)) [x, i]+             shr   x i = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, i]+             or    x y = CmmMachOp (MO_Or    (wordWidth dflags)) [x, y]+             ge    x y = CmmMachOp (MO_U_Ge  (wordWidth dflags)) [x, y]+             ne    x y = CmmMachOp (MO_Ne    (wordWidth dflags)) [x, y]+             minus x y = CmmMachOp (MO_Sub   (wordWidth dflags)) [x, y]+             times x y = CmmMachOp (MO_Mul   (wordWidth dflags)) [x, y]+             zero   = lit 0+             one    = lit 1+             negone = lit (fromIntegral (widthInBits (wordWidth dflags)) - 1)+             lit i = CmmLit (CmmInt i (wordWidth dflags))++             f :: Int -> CmmExpr -> CmmExpr -> CmmExpr -> FCode CmmAGraph+             f 0 acc high _ = return (mkAssign (CmmLocal res_q) acc <*>+                                      mkAssign (CmmLocal res_r) high)+             f i acc high low =+                 do roverflowedBit <- newTemp ty+                    rhigh'         <- newTemp ty+                    rhigh''        <- newTemp ty+                    rlow'          <- newTemp ty+                    risge          <- newTemp ty+                    racc'          <- newTemp ty+                    let high'         = CmmReg (CmmLocal rhigh')+                        isge          = CmmReg (CmmLocal risge)+                        overflowedBit = CmmReg (CmmLocal roverflowedBit)+                    let this = catAGraphs+                               [mkAssign (CmmLocal roverflowedBit)+                                          (shr high negone),+                                mkAssign (CmmLocal rhigh')+                                          (or (shl high one) (shr low negone)),+                                mkAssign (CmmLocal rlow')+                                          (shl low one),+                                mkAssign (CmmLocal risge)+                                          (or (overflowedBit `ne` zero)+                                              (high' `ge` arg_y)),+                                mkAssign (CmmLocal rhigh'')+                                          (high' `minus` (arg_y `times` isge)),+                                mkAssign (CmmLocal racc')+                                          (or (shl acc one) isge)]+                    rest <- f (i - 1) (CmmReg (CmmLocal racc'))+                                      (CmmReg (CmmLocal rhigh''))+                                      (CmmReg (CmmLocal rlow'))+                    return (this <*> rest)+genericWordQuotRem2Op _ _ _ = panic "genericWordQuotRem2Op"++genericWordAdd2Op :: GenericOp+genericWordAdd2Op [res_h, res_l] [arg_x, arg_y]+  = do dflags <- getDynFlags+       r1 <- newTemp (cmmExprType dflags arg_x)+       r2 <- newTemp (cmmExprType dflags arg_x)+       let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]+           toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]+           bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]+           add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]+           or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]+           hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))+                                (wordWidth dflags))+           hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))+       emit $ catAGraphs+          [mkAssign (CmmLocal r1)+               (add (bottomHalf arg_x) (bottomHalf arg_y)),+           mkAssign (CmmLocal r2)+               (add (topHalf (CmmReg (CmmLocal r1)))+                    (add (topHalf arg_x) (topHalf arg_y))),+           mkAssign (CmmLocal res_h)+               (topHalf (CmmReg (CmmLocal r2))),+           mkAssign (CmmLocal res_l)+               (or (toTopHalf (CmmReg (CmmLocal r2)))+                   (bottomHalf (CmmReg (CmmLocal r1))))]+genericWordAdd2Op _ _ = panic "genericWordAdd2Op"++-- | Implements branchless recovery of the carry flag @c@ by checking the+-- leftmost bits of both inputs @a@ and @b@ and result @r = a + b@:+--+-- @+--    c = a&b | (a|b)&~r+-- @+--+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/+genericWordAddCOp :: GenericOp+genericWordAddCOp [res_r, res_c] [aa, bb]+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+            CmmMachOp (mo_wordOr dflags) [+              CmmMachOp (mo_wordAnd dflags) [aa,bb],+              CmmMachOp (mo_wordAnd dflags) [+                CmmMachOp (mo_wordOr dflags) [aa,bb],+                CmmMachOp (mo_wordNot dflags) [CmmReg (CmmLocal res_r)]+              ]+            ],+            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericWordAddCOp _ _ = panic "genericWordAddCOp"++-- | Implements branchless recovery of the carry flag @c@ by checking the+-- leftmost bits of both inputs @a@ and @b@ and result @r = a - b@:+--+-- @+--    c = ~a&b | (~a|b)&r+-- @+--+-- https://brodowsky.it-sky.net/2015/04/02/how-to-recover-the-carry-bit/+genericWordSubCOp :: GenericOp+genericWordSubCOp [res_r, res_c] [aa, bb]+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+            CmmMachOp (mo_wordOr dflags) [+              CmmMachOp (mo_wordAnd dflags) [+                CmmMachOp (mo_wordNot dflags) [aa],+                bb+              ],+              CmmMachOp (mo_wordAnd dflags) [+                CmmMachOp (mo_wordOr dflags) [+                  CmmMachOp (mo_wordNot dflags) [aa],+                  bb+                ],+                CmmReg (CmmLocal res_r)+              ]+            ],+            mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericWordSubCOp _ _ = panic "genericWordSubCOp"++genericIntAddCOp :: GenericOp+genericIntAddCOp [res_r, res_c] [aa, bb]+{-+   With some bit-twiddling, we can define int{Add,Sub}Czh portably in+   C, and without needing any comparisons.  This may not be the+   fastest way to do it - if you have better code, please send it! --SDM++   Return : r = a + b,  c = 0 if no overflow, 1 on overflow.++   We currently don't make use of the r value if c is != 0 (i.e.+   overflow), we just convert to big integers and try again.  This+   could be improved by making r and c the correct values for+   plugging into a new J#.++   { r = ((I_)(a)) + ((I_)(b));                                 \+     c = ((StgWord)(~(((I_)(a))^((I_)(b))) & (((I_)(a))^r)))    \+         >> (BITS_IN (I_) - 1);                                 \+   }+   Wading through the mass of bracketry, it seems to reduce to:+   c = ( (~(a^b)) & (a^r) ) >>unsigned (BITS_IN(I_)-1)++-}+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordAdd dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+                CmmMachOp (mo_wordAnd dflags) [+                    CmmMachOp (mo_wordNot dflags) [CmmMachOp (mo_wordXor dflags) [aa,bb]],+                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]+                ],+                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericIntAddCOp _ _ = panic "genericIntAddCOp"++genericIntSubCOp :: GenericOp+genericIntSubCOp [res_r, res_c] [aa, bb]+{- Similarly:+   #define subIntCzh(r,c,a,b)                                   \+   { r = ((I_)(a)) - ((I_)(b));                                 \+     c = ((StgWord)((((I_)(a))^((I_)(b))) & (((I_)(a))^r)))     \+         >> (BITS_IN (I_) - 1);                                 \+   }++   c =  ((a^b) & (a^r)) >>unsigned (BITS_IN(I_)-1)+-}+ = do dflags <- getDynFlags+      emit $ catAGraphs [+        mkAssign (CmmLocal res_r) (CmmMachOp (mo_wordSub dflags) [aa,bb]),+        mkAssign (CmmLocal res_c) $+          CmmMachOp (mo_wordUShr dflags) [+                CmmMachOp (mo_wordAnd dflags) [+                    CmmMachOp (mo_wordXor dflags) [aa,bb],+                    CmmMachOp (mo_wordXor dflags) [aa, CmmReg (CmmLocal res_r)]+                ],+                mkIntExpr dflags (wORD_SIZE_IN_BITS dflags - 1)+          ]+        ]+genericIntSubCOp _ _ = panic "genericIntSubCOp"++genericWordMul2Op :: GenericOp+genericWordMul2Op [res_h, res_l] [arg_x, arg_y]+ = do dflags <- getDynFlags+      let t = cmmExprType dflags arg_x+      xlyl <- liftM CmmLocal $ newTemp t+      xlyh <- liftM CmmLocal $ newTemp t+      xhyl <- liftM CmmLocal $ newTemp t+      r    <- liftM CmmLocal $ newTemp t+      -- This generic implementation is very simple and slow. We might+      -- well be able to do better, but for now this at least works.+      let topHalf x = CmmMachOp (MO_U_Shr (wordWidth dflags)) [x, hww]+          toTopHalf x = CmmMachOp (MO_Shl (wordWidth dflags)) [x, hww]+          bottomHalf x = CmmMachOp (MO_And (wordWidth dflags)) [x, hwm]+          add x y = CmmMachOp (MO_Add (wordWidth dflags)) [x, y]+          sum = foldl1 add+          mul x y = CmmMachOp (MO_Mul (wordWidth dflags)) [x, y]+          or x y = CmmMachOp (MO_Or (wordWidth dflags)) [x, y]+          hww = CmmLit (CmmInt (fromIntegral (widthInBits (halfWordWidth dflags)))+                               (wordWidth dflags))+          hwm = CmmLit (CmmInt (halfWordMask dflags) (wordWidth dflags))+      emit $ catAGraphs+             [mkAssign xlyl+                  (mul (bottomHalf arg_x) (bottomHalf arg_y)),+              mkAssign xlyh+                  (mul (bottomHalf arg_x) (topHalf arg_y)),+              mkAssign xhyl+                  (mul (topHalf arg_x) (bottomHalf arg_y)),+              mkAssign r+                  (sum [topHalf    (CmmReg xlyl),+                        bottomHalf (CmmReg xhyl),+                        bottomHalf (CmmReg xlyh)]),+              mkAssign (CmmLocal res_l)+                  (or (bottomHalf (CmmReg xlyl))+                      (toTopHalf (CmmReg r))),+              mkAssign (CmmLocal res_h)+                  (sum [mul (topHalf arg_x) (topHalf arg_y),+                        topHalf (CmmReg xhyl),+                        topHalf (CmmReg xlyh),+                        topHalf (CmmReg r)])]+genericWordMul2Op _ _ = panic "genericWordMul2Op"++-- This replicates what we had in libraries/base/GHC/Float.hs:+--+--    abs x    | x == 0    = 0 -- handles (-0.0)+--             | x >  0    = x+--             | otherwise = negateFloat x+genericFabsOp :: Width -> GenericOp+genericFabsOp w [res_r] [aa]+ = do dflags <- getDynFlags+      let zero   = CmmLit (CmmFloat 0 w)++          eq x y = CmmMachOp (MO_F_Eq w) [x, y]+          gt x y = CmmMachOp (MO_F_Gt w) [x, y]++          neg x  = CmmMachOp (MO_F_Neg w) [x]++          g1 = catAGraphs [mkAssign (CmmLocal res_r) zero]+          g2 = catAGraphs [mkAssign (CmmLocal res_r) aa]++      res_t <- CmmLocal <$> newTemp (cmmExprType dflags aa)+      let g3 = catAGraphs [mkAssign res_t aa,+                           mkAssign (CmmLocal res_r) (neg (CmmReg res_t))]++      g4 <- mkCmmIfThenElse (gt aa zero) g2 g3++      emit =<< mkCmmIfThenElse (eq aa zero) g1 g4++genericFabsOp _ _ _ = panic "genericFabsOp"++-- These PrimOps are NOPs in Cmm++nopOp :: PrimOp -> Bool+nopOp Int2WordOp     = True+nopOp Word2IntOp     = True+nopOp Int2AddrOp     = True+nopOp Addr2IntOp     = True+nopOp ChrOp          = True  -- Int# and Char# are rep'd the same+nopOp OrdOp          = True+nopOp _              = False++-- These PrimOps turn into double casts++narrowOp :: PrimOp -> Maybe (Width -> Width -> MachOp, Width)+narrowOp Narrow8IntOp   = Just (MO_SS_Conv, W8)+narrowOp Narrow16IntOp  = Just (MO_SS_Conv, W16)+narrowOp Narrow32IntOp  = Just (MO_SS_Conv, W32)+narrowOp Narrow8WordOp  = Just (MO_UU_Conv, W8)+narrowOp Narrow16WordOp = Just (MO_UU_Conv, W16)+narrowOp Narrow32WordOp = Just (MO_UU_Conv, W32)+narrowOp _              = Nothing++-- Native word signless ops++translateOp :: DynFlags -> PrimOp -> Maybe MachOp+translateOp dflags IntAddOp       = Just (mo_wordAdd dflags)+translateOp dflags IntSubOp       = Just (mo_wordSub dflags)+translateOp dflags WordAddOp      = Just (mo_wordAdd dflags)+translateOp dflags WordSubOp      = Just (mo_wordSub dflags)+translateOp dflags AddrAddOp      = Just (mo_wordAdd dflags)+translateOp dflags AddrSubOp      = Just (mo_wordSub dflags)++translateOp dflags IntEqOp        = Just (mo_wordEq dflags)+translateOp dflags IntNeOp        = Just (mo_wordNe dflags)+translateOp dflags WordEqOp       = Just (mo_wordEq dflags)+translateOp dflags WordNeOp       = Just (mo_wordNe dflags)+translateOp dflags AddrEqOp       = Just (mo_wordEq dflags)+translateOp dflags AddrNeOp       = Just (mo_wordNe dflags)++translateOp dflags AndOp          = Just (mo_wordAnd dflags)+translateOp dflags OrOp           = Just (mo_wordOr dflags)+translateOp dflags XorOp          = Just (mo_wordXor dflags)+translateOp dflags NotOp          = Just (mo_wordNot dflags)+translateOp dflags SllOp          = Just (mo_wordShl dflags)+translateOp dflags SrlOp          = Just (mo_wordUShr dflags)++translateOp dflags AddrRemOp      = Just (mo_wordURem dflags)++-- Native word signed ops++translateOp dflags IntMulOp        = Just (mo_wordMul dflags)+translateOp dflags IntMulMayOfloOp = Just (MO_S_MulMayOflo (wordWidth dflags))+translateOp dflags IntQuotOp       = Just (mo_wordSQuot dflags)+translateOp dflags IntRemOp        = Just (mo_wordSRem dflags)+translateOp dflags IntNegOp        = Just (mo_wordSNeg dflags)+++translateOp dflags IntGeOp        = Just (mo_wordSGe dflags)+translateOp dflags IntLeOp        = Just (mo_wordSLe dflags)+translateOp dflags IntGtOp        = Just (mo_wordSGt dflags)+translateOp dflags IntLtOp        = Just (mo_wordSLt dflags)++translateOp dflags AndIOp         = Just (mo_wordAnd dflags)+translateOp dflags OrIOp          = Just (mo_wordOr dflags)+translateOp dflags XorIOp         = Just (mo_wordXor dflags)+translateOp dflags NotIOp         = Just (mo_wordNot dflags)+translateOp dflags ISllOp         = Just (mo_wordShl dflags)+translateOp dflags ISraOp         = Just (mo_wordSShr dflags)+translateOp dflags ISrlOp         = Just (mo_wordUShr dflags)++-- Native word unsigned ops++translateOp dflags WordGeOp       = Just (mo_wordUGe dflags)+translateOp dflags WordLeOp       = Just (mo_wordULe dflags)+translateOp dflags WordGtOp       = Just (mo_wordUGt dflags)+translateOp dflags WordLtOp       = Just (mo_wordULt dflags)++translateOp dflags WordMulOp      = Just (mo_wordMul dflags)+translateOp dflags WordQuotOp     = Just (mo_wordUQuot dflags)+translateOp dflags WordRemOp      = Just (mo_wordURem dflags)++translateOp dflags AddrGeOp       = Just (mo_wordUGe dflags)+translateOp dflags AddrLeOp       = Just (mo_wordULe dflags)+translateOp dflags AddrGtOp       = Just (mo_wordUGt dflags)+translateOp dflags AddrLtOp       = Just (mo_wordULt dflags)++-- Int8# signed ops++translateOp dflags Int8Extend     = Just (MO_SS_Conv W8 (wordWidth dflags))+translateOp dflags Int8Narrow     = Just (MO_SS_Conv (wordWidth dflags) W8)+translateOp _      Int8NegOp      = Just (MO_S_Neg W8)+translateOp _      Int8AddOp      = Just (MO_Add W8)+translateOp _      Int8SubOp      = Just (MO_Sub W8)+translateOp _      Int8MulOp      = Just (MO_Mul W8)+translateOp _      Int8QuotOp     = Just (MO_S_Quot W8)+translateOp _      Int8RemOp      = Just (MO_S_Rem W8)++translateOp _      Int8EqOp       = Just (MO_Eq W8)+translateOp _      Int8GeOp       = Just (MO_S_Ge W8)+translateOp _      Int8GtOp       = Just (MO_S_Gt W8)+translateOp _      Int8LeOp       = Just (MO_S_Le W8)+translateOp _      Int8LtOp       = Just (MO_S_Lt W8)+translateOp _      Int8NeOp       = Just (MO_Ne W8)++-- Word8# unsigned ops++translateOp dflags Word8Extend     = Just (MO_UU_Conv W8 (wordWidth dflags))+translateOp dflags Word8Narrow     = Just (MO_UU_Conv (wordWidth dflags) W8)+translateOp _      Word8NotOp      = Just (MO_Not W8)+translateOp _      Word8AddOp      = Just (MO_Add W8)+translateOp _      Word8SubOp      = Just (MO_Sub W8)+translateOp _      Word8MulOp      = Just (MO_Mul W8)+translateOp _      Word8QuotOp     = Just (MO_U_Quot W8)+translateOp _      Word8RemOp      = Just (MO_U_Rem W8)++translateOp _      Word8EqOp       = Just (MO_Eq W8)+translateOp _      Word8GeOp       = Just (MO_U_Ge W8)+translateOp _      Word8GtOp       = Just (MO_U_Gt W8)+translateOp _      Word8LeOp       = Just (MO_U_Le W8)+translateOp _      Word8LtOp       = Just (MO_U_Lt W8)+translateOp _      Word8NeOp       = Just (MO_Ne W8)++-- Int16# signed ops++translateOp dflags Int16Extend     = Just (MO_SS_Conv W16 (wordWidth dflags))+translateOp dflags Int16Narrow     = Just (MO_SS_Conv (wordWidth dflags) W16)+translateOp _      Int16NegOp      = Just (MO_S_Neg W16)+translateOp _      Int16AddOp      = Just (MO_Add W16)+translateOp _      Int16SubOp      = Just (MO_Sub W16)+translateOp _      Int16MulOp      = Just (MO_Mul W16)+translateOp _      Int16QuotOp     = Just (MO_S_Quot W16)+translateOp _      Int16RemOp      = Just (MO_S_Rem W16)++translateOp _      Int16EqOp       = Just (MO_Eq W16)+translateOp _      Int16GeOp       = Just (MO_S_Ge W16)+translateOp _      Int16GtOp       = Just (MO_S_Gt W16)+translateOp _      Int16LeOp       = Just (MO_S_Le W16)+translateOp _      Int16LtOp       = Just (MO_S_Lt W16)+translateOp _      Int16NeOp       = Just (MO_Ne W16)++-- Word16# unsigned ops++translateOp dflags Word16Extend     = Just (MO_UU_Conv W16 (wordWidth dflags))+translateOp dflags Word16Narrow     = Just (MO_UU_Conv (wordWidth dflags) W16)+translateOp _      Word16NotOp      = Just (MO_Not W16)+translateOp _      Word16AddOp      = Just (MO_Add W16)+translateOp _      Word16SubOp      = Just (MO_Sub W16)+translateOp _      Word16MulOp      = Just (MO_Mul W16)+translateOp _      Word16QuotOp     = Just (MO_U_Quot W16)+translateOp _      Word16RemOp      = Just (MO_U_Rem W16)++translateOp _      Word16EqOp       = Just (MO_Eq W16)+translateOp _      Word16GeOp       = Just (MO_U_Ge W16)+translateOp _      Word16GtOp       = Just (MO_U_Gt W16)+translateOp _      Word16LeOp       = Just (MO_U_Le W16)+translateOp _      Word16LtOp       = Just (MO_U_Lt W16)+translateOp _      Word16NeOp       = Just (MO_Ne W16)++-- Char# ops++translateOp dflags CharEqOp       = Just (MO_Eq (wordWidth dflags))+translateOp dflags CharNeOp       = Just (MO_Ne (wordWidth dflags))+translateOp dflags CharGeOp       = Just (MO_U_Ge (wordWidth dflags))+translateOp dflags CharLeOp       = Just (MO_U_Le (wordWidth dflags))+translateOp dflags CharGtOp       = Just (MO_U_Gt (wordWidth dflags))+translateOp dflags CharLtOp       = Just (MO_U_Lt (wordWidth dflags))++-- Double ops++translateOp _      DoubleEqOp     = Just (MO_F_Eq W64)+translateOp _      DoubleNeOp     = Just (MO_F_Ne W64)+translateOp _      DoubleGeOp     = Just (MO_F_Ge W64)+translateOp _      DoubleLeOp     = Just (MO_F_Le W64)+translateOp _      DoubleGtOp     = Just (MO_F_Gt W64)+translateOp _      DoubleLtOp     = Just (MO_F_Lt W64)++translateOp _      DoubleAddOp    = Just (MO_F_Add W64)+translateOp _      DoubleSubOp    = Just (MO_F_Sub W64)+translateOp _      DoubleMulOp    = Just (MO_F_Mul W64)+translateOp _      DoubleDivOp    = Just (MO_F_Quot W64)+translateOp _      DoubleNegOp    = Just (MO_F_Neg W64)++-- Float ops++translateOp _      FloatEqOp     = Just (MO_F_Eq W32)+translateOp _      FloatNeOp     = Just (MO_F_Ne W32)+translateOp _      FloatGeOp     = Just (MO_F_Ge W32)+translateOp _      FloatLeOp     = Just (MO_F_Le W32)+translateOp _      FloatGtOp     = Just (MO_F_Gt W32)+translateOp _      FloatLtOp     = Just (MO_F_Lt W32)++translateOp _      FloatAddOp    = Just (MO_F_Add  W32)+translateOp _      FloatSubOp    = Just (MO_F_Sub  W32)+translateOp _      FloatMulOp    = Just (MO_F_Mul  W32)+translateOp _      FloatDivOp    = Just (MO_F_Quot W32)+translateOp _      FloatNegOp    = Just (MO_F_Neg  W32)++-- Vector ops++translateOp _ (VecAddOp FloatVec n w) = Just (MO_VF_Add  n w)+translateOp _ (VecSubOp FloatVec n w) = Just (MO_VF_Sub  n w)+translateOp _ (VecMulOp FloatVec n w) = Just (MO_VF_Mul  n w)+translateOp _ (VecDivOp FloatVec n w) = Just (MO_VF_Quot n w)+translateOp _ (VecNegOp FloatVec n w) = Just (MO_VF_Neg  n w)++translateOp _ (VecAddOp  IntVec n w) = Just (MO_V_Add   n w)+translateOp _ (VecSubOp  IntVec n w) = Just (MO_V_Sub   n w)+translateOp _ (VecMulOp  IntVec n w) = Just (MO_V_Mul   n w)+translateOp _ (VecQuotOp IntVec n w) = Just (MO_VS_Quot n w)+translateOp _ (VecRemOp  IntVec n w) = Just (MO_VS_Rem  n w)+translateOp _ (VecNegOp  IntVec n w) = Just (MO_VS_Neg  n w)++translateOp _ (VecAddOp  WordVec n w) = Just (MO_V_Add   n w)+translateOp _ (VecSubOp  WordVec n w) = Just (MO_V_Sub   n w)+translateOp _ (VecMulOp  WordVec n w) = Just (MO_V_Mul   n w)+translateOp _ (VecQuotOp WordVec n w) = Just (MO_VU_Quot n w)+translateOp _ (VecRemOp  WordVec n w) = Just (MO_VU_Rem  n w)++-- Conversions++translateOp dflags Int2DoubleOp   = Just (MO_SF_Conv (wordWidth dflags) W64)+translateOp dflags Double2IntOp   = Just (MO_FS_Conv W64 (wordWidth dflags))++translateOp dflags Int2FloatOp    = Just (MO_SF_Conv (wordWidth dflags) W32)+translateOp dflags Float2IntOp    = Just (MO_FS_Conv W32 (wordWidth dflags))++translateOp _      Float2DoubleOp = Just (MO_FF_Conv W32 W64)+translateOp _      Double2FloatOp = Just (MO_FF_Conv W64 W32)++-- Word comparisons masquerading as more exotic things.++translateOp dflags SameMutVarOp           = Just (mo_wordEq dflags)+translateOp dflags SameMVarOp             = Just (mo_wordEq dflags)+translateOp dflags SameMutableArrayOp     = Just (mo_wordEq dflags)+translateOp dflags SameMutableByteArrayOp = Just (mo_wordEq dflags)+translateOp dflags SameMutableArrayArrayOp= Just (mo_wordEq dflags)+translateOp dflags SameSmallMutableArrayOp= Just (mo_wordEq dflags)+translateOp dflags SameTVarOp             = Just (mo_wordEq dflags)+translateOp dflags EqStablePtrOp          = Just (mo_wordEq dflags)+-- See Note [Comparing stable names]+translateOp dflags EqStableNameOp         = Just (mo_wordEq dflags)++translateOp _      _ = Nothing++-- Note [Comparing stable names]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- A StableName# is actually a pointer to a stable name object (SNO)+-- containing an index into the stable name table (SNT). We+-- used to compare StableName#s by following the pointers to the+-- SNOs and checking whether they held the same SNT indices. However,+-- this is not necessary: there is a one-to-one correspondence+-- between SNOs and entries in the SNT, so simple pointer equality+-- does the trick.++-- These primops are implemented by CallishMachOps, because they sometimes+-- turn into foreign calls depending on the backend.++callishOp :: PrimOp -> Maybe CallishMachOp+callishOp DoublePowerOp  = Just MO_F64_Pwr+callishOp DoubleSinOp    = Just MO_F64_Sin+callishOp DoubleCosOp    = Just MO_F64_Cos+callishOp DoubleTanOp    = Just MO_F64_Tan+callishOp DoubleSinhOp   = Just MO_F64_Sinh+callishOp DoubleCoshOp   = Just MO_F64_Cosh+callishOp DoubleTanhOp   = Just MO_F64_Tanh+callishOp DoubleAsinOp   = Just MO_F64_Asin+callishOp DoubleAcosOp   = Just MO_F64_Acos+callishOp DoubleAtanOp   = Just MO_F64_Atan+callishOp DoubleAsinhOp  = Just MO_F64_Asinh+callishOp DoubleAcoshOp  = Just MO_F64_Acosh+callishOp DoubleAtanhOp  = Just MO_F64_Atanh+callishOp DoubleLogOp    = Just MO_F64_Log+callishOp DoubleExpOp    = Just MO_F64_Exp+callishOp DoubleSqrtOp   = Just MO_F64_Sqrt++callishOp FloatPowerOp  = Just MO_F32_Pwr+callishOp FloatSinOp    = Just MO_F32_Sin+callishOp FloatCosOp    = Just MO_F32_Cos+callishOp FloatTanOp    = Just MO_F32_Tan+callishOp FloatSinhOp   = Just MO_F32_Sinh+callishOp FloatCoshOp   = Just MO_F32_Cosh+callishOp FloatTanhOp   = Just MO_F32_Tanh+callishOp FloatAsinOp   = Just MO_F32_Asin+callishOp FloatAcosOp   = Just MO_F32_Acos+callishOp FloatAtanOp   = Just MO_F32_Atan+callishOp FloatAsinhOp  = Just MO_F32_Asinh+callishOp FloatAcoshOp  = Just MO_F32_Acosh+callishOp FloatAtanhOp  = Just MO_F32_Atanh+callishOp FloatLogOp    = Just MO_F32_Log+callishOp FloatExpOp    = Just MO_F32_Exp+callishOp FloatSqrtOp   = Just MO_F32_Sqrt++callishOp _ = Nothing++------------------------------------------------------------------------------+-- Helpers for translating various minor variants of array indexing.++doIndexOffAddrOp :: Maybe MachOp+                 -> CmmType+                 -> [LocalReg]+                 -> [CmmExpr]+                 -> FCode ()+doIndexOffAddrOp maybe_post_read_cast rep [res] [addr,idx]+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr rep idx+doIndexOffAddrOp _ _ _ _+   = panic "StgCmmPrim: doIndexOffAddrOp"++doIndexOffAddrOpAs :: Maybe MachOp+                   -> CmmType+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doIndexOffAddrOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]+   = mkBasicIndexedRead 0 maybe_post_read_cast rep res addr idx_rep idx+doIndexOffAddrOpAs _ _ _ _ _+   = panic "StgCmmPrim: doIndexOffAddrOpAs"++doIndexByteArrayOp :: Maybe MachOp+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doIndexByteArrayOp maybe_post_read_cast rep [res] [addr,idx]+   = do dflags <- getDynFlags+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr rep idx+doIndexByteArrayOp _ _ _ _+   = panic "StgCmmPrim: doIndexByteArrayOp"++doIndexByteArrayOpAs :: Maybe MachOp+                    -> CmmType+                    -> CmmType+                    -> [LocalReg]+                    -> [CmmExpr]+                    -> FCode ()+doIndexByteArrayOpAs maybe_post_read_cast rep idx_rep [res] [addr,idx]+   = do dflags <- getDynFlags+        mkBasicIndexedRead (arrWordsHdrSize dflags) maybe_post_read_cast rep res addr idx_rep idx+doIndexByteArrayOpAs _ _ _ _ _+   = panic "StgCmmPrim: doIndexByteArrayOpAs"++doReadPtrArrayOp :: LocalReg+                 -> CmmExpr+                 -> CmmExpr+                 -> FCode ()+doReadPtrArrayOp res addr idx+   = do dflags <- getDynFlags+        mkBasicIndexedRead (arrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr (gcWord dflags) idx++doWriteOffAddrOp :: Maybe MachOp+                 -> CmmType+                 -> [LocalReg]+                 -> [CmmExpr]+                 -> FCode ()+doWriteOffAddrOp maybe_pre_write_cast idx_ty [] [addr,idx,val]+   = mkBasicIndexedWrite 0 maybe_pre_write_cast addr idx_ty idx val+doWriteOffAddrOp _ _ _ _+   = panic "StgCmmPrim: doWriteOffAddrOp"++doWriteByteArrayOp :: Maybe MachOp+                   -> CmmType+                   -> [LocalReg]+                   -> [CmmExpr]+                   -> FCode ()+doWriteByteArrayOp maybe_pre_write_cast idx_ty [] [addr,idx,val]+   = do dflags <- getDynFlags+        mkBasicIndexedWrite (arrWordsHdrSize dflags) maybe_pre_write_cast addr idx_ty idx val+doWriteByteArrayOp _ _ _ _+   = panic "StgCmmPrim: doWriteByteArrayOp"++doWritePtrArrayOp :: CmmExpr+                  -> CmmExpr+                  -> CmmExpr+                  -> FCode ()+doWritePtrArrayOp addr idx val+  = do dflags <- getDynFlags+       let ty = cmmExprType dflags val+       -- This write barrier is to ensure that the heap writes to the object+       -- referred to by val have happened before we write val into the array.+       -- See #12469 for details.+       emitPrimCall [] MO_WriteBarrier []+       mkBasicIndexedWrite (arrPtrsHdrSize dflags) Nothing addr ty idx val+       emit (setInfo addr (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))+  -- the write barrier.  We must write a byte into the mark table:+  -- bits8[a + header_size + StgMutArrPtrs_size(a) + x >> N]+       emit $ mkStore (+         cmmOffsetExpr dflags+          (cmmOffsetExprW dflags (cmmOffsetB dflags addr (arrPtrsHdrSize dflags))+                         (loadArrPtrsSize dflags addr))+          (CmmMachOp (mo_wordUShr dflags) [idx,+                                           mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags)])+         ) (CmmLit (CmmInt 1 W8))++loadArrPtrsSize :: DynFlags -> CmmExpr -> CmmExpr+loadArrPtrsSize dflags addr = CmmLoad (cmmOffsetB dflags addr off) (bWord dflags)+ where off = fixedHdrSize dflags + oFFSET_StgMutArrPtrs_ptrs dflags++mkBasicIndexedRead :: ByteOff      -- Initial offset in bytes+                   -> Maybe MachOp -- Optional result cast+                   -> CmmType      -- Type of element we are accessing+                   -> LocalReg     -- Destination+                   -> CmmExpr      -- Base address+                   -> CmmType      -- Type of element by which we are indexing+                   -> CmmExpr      -- Index+                   -> FCode ()+mkBasicIndexedRead off Nothing ty res base idx_ty idx+   = do dflags <- getDynFlags+        emitAssign (CmmLocal res) (cmmLoadIndexOffExpr dflags off ty base idx_ty idx)+mkBasicIndexedRead off (Just cast) ty res base idx_ty idx+   = do dflags <- getDynFlags+        emitAssign (CmmLocal res) (CmmMachOp cast [+                                   cmmLoadIndexOffExpr dflags off ty base idx_ty idx])++mkBasicIndexedWrite :: ByteOff      -- Initial offset in bytes+                    -> Maybe MachOp -- Optional value cast+                    -> CmmExpr      -- Base address+                    -> CmmType      -- Type of element by which we are indexing+                    -> CmmExpr      -- Index+                    -> CmmExpr      -- Value to write+                    -> FCode ()+mkBasicIndexedWrite off Nothing base idx_ty idx val+   = do dflags <- getDynFlags+        emitStore (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) val+mkBasicIndexedWrite off (Just cast) base idx_ty idx val+   = mkBasicIndexedWrite off Nothing base idx_ty idx (CmmMachOp cast [val])++-- ----------------------------------------------------------------------------+-- Misc utils++cmmIndexOffExpr :: DynFlags+                -> ByteOff  -- Initial offset in bytes+                -> Width    -- Width of element by which we are indexing+                -> CmmExpr  -- Base address+                -> CmmExpr  -- Index+                -> CmmExpr+cmmIndexOffExpr dflags off width base idx+   = cmmIndexExpr dflags width (cmmOffsetB dflags base off) idx++cmmLoadIndexOffExpr :: DynFlags+                    -> ByteOff  -- Initial offset in bytes+                    -> CmmType  -- Type of element we are accessing+                    -> CmmExpr  -- Base address+                    -> CmmType  -- Type of element by which we are indexing+                    -> CmmExpr  -- Index+                    -> CmmExpr+cmmLoadIndexOffExpr dflags off ty base idx_ty idx+   = CmmLoad (cmmIndexOffExpr dflags off (typeWidth idx_ty) base idx) ty++setInfo :: CmmExpr -> CmmExpr -> CmmAGraph+setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr++------------------------------------------------------------------------------+-- Helpers for translating vector primops.++vecVmmType :: PrimOpVecCat -> Length -> Width -> CmmType+vecVmmType pocat n w = vec n (vecCmmCat pocat w)++vecCmmCat :: PrimOpVecCat -> Width -> CmmType+vecCmmCat IntVec   = cmmBits+vecCmmCat WordVec  = cmmBits+vecCmmCat FloatVec = cmmFloat++vecElemInjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp+vecElemInjectCast _      FloatVec _   =  Nothing+vecElemInjectCast dflags IntVec   W8  =  Just (mo_WordTo8  dflags)+vecElemInjectCast dflags IntVec   W16 =  Just (mo_WordTo16 dflags)+vecElemInjectCast dflags IntVec   W32 =  Just (mo_WordTo32 dflags)+vecElemInjectCast _      IntVec   W64 =  Nothing+vecElemInjectCast dflags WordVec  W8  =  Just (mo_WordTo8  dflags)+vecElemInjectCast dflags WordVec  W16 =  Just (mo_WordTo16 dflags)+vecElemInjectCast dflags WordVec  W32 =  Just (mo_WordTo32 dflags)+vecElemInjectCast _      WordVec  W64 =  Nothing+vecElemInjectCast _      _        _   =  Nothing++vecElemProjectCast :: DynFlags -> PrimOpVecCat -> Width -> Maybe MachOp+vecElemProjectCast _      FloatVec _   =  Nothing+vecElemProjectCast dflags IntVec   W8  =  Just (mo_s_8ToWord  dflags)+vecElemProjectCast dflags IntVec   W16 =  Just (mo_s_16ToWord dflags)+vecElemProjectCast dflags IntVec   W32 =  Just (mo_s_32ToWord dflags)+vecElemProjectCast _      IntVec   W64 =  Nothing+vecElemProjectCast dflags WordVec  W8  =  Just (mo_u_8ToWord  dflags)+vecElemProjectCast dflags WordVec  W16 =  Just (mo_u_16ToWord dflags)+vecElemProjectCast dflags WordVec  W32 =  Just (mo_u_32ToWord dflags)+vecElemProjectCast _      WordVec  W64 =  Nothing+vecElemProjectCast _      _        _   =  Nothing+++-- NOTE [SIMD Design for the future]+-- Check to make sure that we can generate code for the specified vector type+-- given the current set of dynamic flags.+-- Currently these checks are specific to x86 and x86_64 architecture.+-- This should be fixed!+-- In particular,+-- 1) Add better support for other architectures! (this may require a redesign)+-- 2) Decouple design choices from LLVM's pseudo SIMD model!+--   The high level LLVM naive rep makes per CPU family SIMD generation is own+--   optimization problem, and hides important differences in eg ARM vs x86_64 simd+-- 3) Depending on the architecture, the SIMD registers may also support general+--    computations on Float/Double/Word/Int scalars, but currently on+--    for example x86_64, we always put Word/Int (or sized) in GPR+--    (general purpose) registers. Would relaxing that allow for+--    useful optimization opportunities?+--      Phrased differently, it is worth experimenting with supporting+--    different register mapping strategies than we currently have, especially if+--    someday we want SIMD to be a first class denizen in GHC along with scalar+--    values!+--      The current design with respect to register mapping of scalars could+--    very well be the best,but exploring the  design space and doing careful+--    measurments is the only only way to validate that.+--      In some next generation CPU ISAs, notably RISC V, the SIMD extension+--    includes  support for a sort of run time CPU dependent vectorization parameter,+--    where a loop may act upon a single scalar each iteration OR some 2,4,8 ...+--    element chunk! Time will tell if that direction sees wide adoption,+--    but it is from that context that unifying our handling of simd and scalars+--    may benefit. It is not likely to benefit current architectures, though+--    it may very well be a design perspective that helps guide improving the NCG.+++checkVecCompatibility :: DynFlags -> PrimOpVecCat -> Length -> Width -> FCode ()+checkVecCompatibility dflags vcat l w = do+    when (hscTarget dflags /= HscLlvm) $ do+        sorry $ unlines ["SIMD vector instructions require the LLVM back-end."+                         ,"Please use -fllvm."]+    check vecWidth vcat l w+  where+    check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()+    check W128 FloatVec 4 W32 | not (isSseEnabled dflags) =+        sorry $ "128-bit wide single-precision floating point " +++                "SIMD vector instructions require at least -msse."+    check W128 _ _ _ | not (isSse2Enabled dflags) =+        sorry $ "128-bit wide integer and double precision " +++                "SIMD vector instructions require at least -msse2."+    check W256 FloatVec _ _ | not (isAvxEnabled dflags) =+        sorry $ "256-bit wide floating point " +++                "SIMD vector instructions require at least -mavx."+    check W256 _ _ _ | not (isAvx2Enabled dflags) =+        sorry $ "256-bit wide integer " +++                "SIMD vector instructions require at least -mavx2."+    check W512 _ _ _ | not (isAvx512fEnabled dflags) =+        sorry $ "512-bit wide " +++                "SIMD vector instructions require -mavx512f."+    check _ _ _ _ = return ()++    vecWidth = typeWidth (vecVmmType vcat l w)++------------------------------------------------------------------------------+-- Helpers for translating vector packing and unpacking.++doVecPackOp :: Maybe MachOp  -- Cast from element to vector component+            -> CmmType       -- Type of vector+            -> CmmExpr       -- Initial vector+            -> [CmmExpr]     -- Elements+            -> CmmFormal     -- Destination for result+            -> FCode ()+doVecPackOp maybe_pre_write_cast ty z es res = do+    dst <- newTemp ty+    emitAssign (CmmLocal dst) z+    vecPack dst es 0+  where+    vecPack :: CmmFormal -> [CmmExpr] -> Int -> FCode ()+    vecPack src [] _ =+        emitAssign (CmmLocal res) (CmmReg (CmmLocal src))++    vecPack src (e : es) i = do+        dst <- newTemp ty+        if isFloatType (vecElemType ty)+          then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)+                                                    [CmmReg (CmmLocal src), cast e, iLit])+          else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)+                                                    [CmmReg (CmmLocal src), cast e, iLit])+        vecPack dst es (i + 1)+      where+        -- vector indices are always 32-bits+        iLit = CmmLit (CmmInt (toInteger i) W32)++    cast :: CmmExpr -> CmmExpr+    cast val = case maybe_pre_write_cast of+                 Nothing   -> val+                 Just cast -> CmmMachOp cast [val]++    len :: Length+    len = vecLength ty++    wid :: Width+    wid = typeWidth (vecElemType ty)++doVecUnpackOp :: Maybe MachOp  -- Cast from vector component to element result+              -> CmmType       -- Type of vector+              -> CmmExpr       -- Vector+              -> [CmmFormal]   -- Element results+              -> FCode ()+doVecUnpackOp maybe_post_read_cast ty e res =+    vecUnpack res 0+  where+    vecUnpack :: [CmmFormal] -> Int -> FCode ()+    vecUnpack [] _ =+        return ()++    vecUnpack (r : rs) i = do+        if isFloatType (vecElemType ty)+          then emitAssign (CmmLocal r) (cast (CmmMachOp (MO_VF_Extract len wid)+                                             [e, iLit]))+          else emitAssign (CmmLocal r) (cast (CmmMachOp (MO_V_Extract len wid)+                                             [e, iLit]))+        vecUnpack rs (i + 1)+      where+        -- vector indices are always 32-bits+        iLit = CmmLit (CmmInt (toInteger i) W32)++    cast :: CmmExpr -> CmmExpr+    cast val = case maybe_post_read_cast of+                 Nothing   -> val+                 Just cast -> CmmMachOp cast [val]++    len :: Length+    len = vecLength ty++    wid :: Width+    wid = typeWidth (vecElemType ty)++doVecInsertOp :: Maybe MachOp  -- Cast from element to vector component+              -> CmmType       -- Vector type+              -> CmmExpr       -- Source vector+              -> CmmExpr       -- Element+              -> CmmExpr       -- Index at which to insert element+              -> CmmFormal     -- Destination for result+              -> FCode ()+doVecInsertOp maybe_pre_write_cast ty src e idx res = do+    dflags <- getDynFlags+    -- vector indices are always 32-bits+    let idx' :: CmmExpr+        idx' = CmmMachOp (MO_SS_Conv (wordWidth dflags) W32) [idx]+    if isFloatType (vecElemType ty)+      then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx'])+      else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx'])+  where+    cast :: CmmExpr -> CmmExpr+    cast val = case maybe_pre_write_cast of+                 Nothing   -> val+                 Just cast -> CmmMachOp cast [val]++    len :: Length+    len = vecLength ty++    wid :: Width+    wid = typeWidth (vecElemType ty)++------------------------------------------------------------------------------+-- Helpers for translating prefetching.+++-- | Translate byte array prefetch operations into proper primcalls.+doPrefetchByteArrayOp :: Int+                      -> [CmmExpr]+                      -> FCode ()+doPrefetchByteArrayOp locality  [addr,idx]+   = do dflags <- getDynFlags+        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx+doPrefetchByteArrayOp _ _+   = panic "StgCmmPrim: doPrefetchByteArrayOp"++-- | Translate mutable byte array prefetch operations into proper primcalls.+doPrefetchMutableByteArrayOp :: Int+                      -> [CmmExpr]+                      -> FCode ()+doPrefetchMutableByteArrayOp locality  [addr,idx]+   = do dflags <- getDynFlags+        mkBasicPrefetch locality (arrWordsHdrSize dflags)  addr idx+doPrefetchMutableByteArrayOp _ _+   = panic "StgCmmPrim: doPrefetchByteArrayOp"++-- | Translate address prefetch operations into proper primcalls.+doPrefetchAddrOp ::Int+                 -> [CmmExpr]+                 -> FCode ()+doPrefetchAddrOp locality   [addr,idx]+   = mkBasicPrefetch locality 0  addr idx+doPrefetchAddrOp _ _+   = panic "StgCmmPrim: doPrefetchAddrOp"++-- | Translate value prefetch operations into proper primcalls.+doPrefetchValueOp :: Int+                 -> [CmmExpr]+                 -> FCode ()+doPrefetchValueOp  locality   [addr]+  =  do dflags <- getDynFlags+        mkBasicPrefetch locality 0 addr  (CmmLit (CmmInt 0 (wordWidth dflags)))+doPrefetchValueOp _ _+  = panic "StgCmmPrim: doPrefetchValueOp"++-- | helper to generate prefetch primcalls+mkBasicPrefetch :: Int          -- Locality level 0-3+                -> ByteOff      -- Initial offset in bytes+                -> CmmExpr      -- Base address+                -> CmmExpr      -- Index+                -> FCode ()+mkBasicPrefetch locality off base idx+   = do dflags <- getDynFlags+        emitPrimCall [] (MO_Prefetch_Data locality) [cmmIndexExpr dflags W8 (cmmOffsetB dflags base off) idx]+        return ()++-- ----------------------------------------------------------------------------+-- Allocating byte arrays++-- | Takes a register to return the newly allocated array in and the+-- size of the new array in bytes. Allocates a new+-- 'MutableByteArray#'.+doNewByteArrayOp :: CmmFormal -> ByteOff -> FCode ()+doNewByteArrayOp res_r n = do+    dflags <- getDynFlags++    let info_ptr = mkLblExpr mkArrWords_infoLabel+        rep = arrWordsRep dflags n++    tickyAllocPrim (mkIntExpr dflags (arrWordsHdrSize dflags))+        (mkIntExpr dflags (nonHdrSize dflags rep))+        (zeroExpr dflags)++    let hdr_size = fixedHdrSize dflags++    base <- allocHeapClosure rep info_ptr cccsExpr+                     [ (mkIntExpr dflags n,+                        hdr_size + oFFSET_StgArrBytes_bytes dflags)+                     ]++    emit $ mkAssign (CmmLocal res_r) base++-- ----------------------------------------------------------------------------+-- Comparing byte arrays++doCompareByteArraysOp :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                     -> FCode ()+doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do+    dflags <- getDynFlags+    ba1_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba1 (arrWordsHdrSize dflags)) ba1_off+    ba2_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba2 (arrWordsHdrSize dflags)) ba2_off++    -- short-cut in case of equal pointers avoiding a costly+    -- subroutine call to the memcmp(3) routine; the Cmm logic below+    -- results in assembly code being generated for+    --+    --   cmpPrefix10 :: ByteArray# -> ByteArray# -> Int#+    --   cmpPrefix10 ba1 ba2 = compareByteArrays# ba1 0# ba2 0# 10#+    --+    -- that looks like+    --+    --          leaq 16(%r14),%rax+    --          leaq 16(%rsi),%rbx+    --          xorl %ecx,%ecx+    --          cmpq %rbx,%rax+    --          je l_ptr_eq+    --+    --          ; NB: the common case (unequal pointers) falls-through+    --          ; the conditional jump, and therefore matches the+    --          ; usual static branch prediction convention of modern cpus+    --+    --          subq $8,%rsp+    --          movq %rbx,%rsi+    --          movq %rax,%rdi+    --          movl $10,%edx+    --          xorl %eax,%eax+    --          call memcmp+    --          addq $8,%rsp+    --          movslq %eax,%rax+    --          movq %rax,%rcx+    --  l_ptr_eq:+    --          movq %rcx,%rbx+    --          jmp *(%rbp)++    l_ptr_eq <- newBlockId+    l_ptr_ne <- newBlockId++    emit (mkAssign (CmmLocal res) (zeroExpr dflags))+    emit (mkCbranch (cmmEqWord dflags ba1_p ba2_p)+                    l_ptr_eq l_ptr_ne (Just False))++    emitLabel l_ptr_ne+    emitMemcmpCall res ba1_p ba2_p n 1++    emitLabel l_ptr_eq++-- ----------------------------------------------------------------------------+-- Copying byte arrays++-- | Takes a source 'ByteArray#', an offset in the source array, a+-- destination 'MutableByteArray#', an offset into the destination+-- array, and the number of bytes to copy.  Copies the given number of+-- bytes from the source array to the destination array.+doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                  -> FCode ()+doCopyByteArrayOp = emitCopyByteArray copy+  where+    -- Copy data (we assume the arrays aren't overlapping since+    -- they're of different types)+    copy _src _dst dst_p src_p bytes align =+        emitMemcpyCall dst_p src_p bytes align++-- | Takes a source 'MutableByteArray#', an offset in the source+-- array, a destination 'MutableByteArray#', an offset into the+-- destination array, and the number of bytes to copy.  Copies the+-- given number of bytes from the source array to the destination+-- array.+doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                         -> FCode ()+doCopyMutableByteArrayOp = emitCopyByteArray copy+  where+    -- The only time the memory might overlap is when the two arrays+    -- we were provided are the same array!+    -- TODO: Optimize branch for common case of no aliasing.+    copy src dst dst_p src_p bytes align = do+        dflags <- getDynFlags+        (moveCall, cpyCall) <- forkAltPair+            (getCode $ emitMemmoveCall dst_p src_p bytes align)+            (getCode $ emitMemcpyCall  dst_p src_p bytes align)+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall++emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                      -> Alignment -> FCode ())+                  -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                  -> FCode ()+emitCopyByteArray copy src src_off dst dst_off n = do+    dflags <- getDynFlags+    let byteArrayAlignment = wordAlignment dflags+        srcOffAlignment = cmmExprAlignment src_off+        dstOffAlignment = cmmExprAlignment dst_off+        align = minimum [byteArrayAlignment, srcOffAlignment, dstOffAlignment]+    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off+    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off+    copy src dst dst_p src_p n align++-- | Takes a source 'ByteArray#', an offset in the source array, a+-- destination 'Addr#', and the number of bytes to copy.  Copies the given+-- number of bytes from the source array to the destination memory region.+doCopyByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()+doCopyByteArrayToAddrOp src src_off dst_p bytes = do+    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)+    dflags <- getDynFlags+    src_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags src (arrWordsHdrSize dflags)) src_off+    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)++-- | Takes a source 'MutableByteArray#', an offset in the source array, a+-- destination 'Addr#', and the number of bytes to copy.  Copies the given+-- number of bytes from the source array to the destination memory region.+doCopyMutableByteArrayToAddrOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                               -> FCode ()+doCopyMutableByteArrayToAddrOp = doCopyByteArrayToAddrOp++-- | Takes a source 'Addr#', a destination 'MutableByteArray#', an offset into+-- the destination array, and the number of bytes to copy.  Copies the given+-- number of bytes from the source memory region to the destination array.+doCopyAddrToByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode ()+doCopyAddrToByteArrayOp src_p dst dst_off bytes = do+    -- Use memcpy (we are allowed to assume the arrays aren't overlapping)+    dflags <- getDynFlags+    dst_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags dst (arrWordsHdrSize dflags)) dst_off+    emitMemcpyCall dst_p src_p bytes (mkAlignment 1)+++-- ----------------------------------------------------------------------------+-- Setting byte arrays++-- | Takes a 'MutableByteArray#', an offset into the array, a length,+-- and a byte, and sets each of the selected bytes in the array to the+-- character.+doSetByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr+                 -> FCode ()+doSetByteArrayOp ba off len c = do+    dflags <- getDynFlags++    let byteArrayAlignment = wordAlignment dflags -- known since BA is allocated on heap+        offsetAlignment = cmmExprAlignment off+        align = min byteArrayAlignment offsetAlignment++    p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba (arrWordsHdrSize dflags)) off+    emitMemsetCall p c len align++-- ----------------------------------------------------------------------------+-- Allocating arrays++-- | Allocate a new array.+doNewArrayOp :: CmmFormal             -- ^ return register+             -> SMRep                 -- ^ representation of the array+             -> CLabel                -- ^ info pointer+             -> [(CmmExpr, ByteOff)]  -- ^ header payload+             -> WordOff               -- ^ array size+             -> CmmExpr               -- ^ initial element+             -> FCode ()+doNewArrayOp res_r rep info payload n init = do+    dflags <- getDynFlags++    let info_ptr = mkLblExpr info++    tickyAllocPrim (mkIntExpr dflags (hdrSize dflags rep))+        (mkIntExpr dflags (nonHdrSize dflags rep))+        (zeroExpr dflags)++    base <- allocHeapClosure rep info_ptr cccsExpr payload++    arr <- CmmLocal `fmap` newTemp (bWord dflags)+    emit $ mkAssign arr base++    -- Initialise all elements of the array+    let mkOff off = cmmOffsetW dflags (CmmReg arr) (hdrSizeW dflags rep + off)+        initialization = [ mkStore (mkOff off) init | off <- [0.. n - 1] ]+    emit (catAGraphs initialization)++    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)++-- ----------------------------------------------------------------------------+-- Copying pointer arrays++-- EZY: This code has an unusually high amount of assignTemp calls, seen+-- nowhere else in the code generator.  This is mostly because these+-- "primitive" ops result in a surprisingly large amount of code.  It+-- will likely be worthwhile to optimize what is emitted here, so that+-- our optimization passes don't waste time repeatedly optimizing the+-- same bits of code.++-- More closely imitates 'assignTemp' from the old code generator, which+-- returns a CmmExpr rather than a LocalReg.+assignTempE :: CmmExpr -> FCode CmmExpr+assignTempE e = do+    t <- assignTemp e+    return (CmmReg (CmmLocal t))++-- | Takes a source 'Array#', an offset in the source array, a+-- destination 'MutableArray#', an offset into the destination array,+-- and the number of elements to copy.  Copies the given number of+-- elements from the source array to the destination array.+doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+              -> FCode ()+doCopyArrayOp = emitCopyArray copy+  where+    -- Copy data (we assume the arrays aren't overlapping since+    -- they're of different types)+    copy _src _dst dst_p src_p bytes =+        do dflags <- getDynFlags+           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)+               (wordAlignment dflags)+++-- | Takes a source 'MutableArray#', an offset in the source array, a+-- destination 'MutableArray#', an offset into the destination array,+-- and the number of elements to copy.  Copies the given number of+-- elements from the source array to the destination array.+doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+                     -> FCode ()+doCopyMutableArrayOp = emitCopyArray copy+  where+    -- The only time the memory might overlap is when the two arrays+    -- we were provided are the same array!+    -- TODO: Optimize branch for common case of no aliasing.+    copy src dst dst_p src_p bytes = do+        dflags <- getDynFlags+        (moveCall, cpyCall) <- forkAltPair+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)+             (wordAlignment dflags))+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)+             (wordAlignment dflags))+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall++emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff+                  -> FCode ())  -- ^ copy function+              -> CmmExpr        -- ^ source array+              -> CmmExpr        -- ^ offset in source array+              -> CmmExpr        -- ^ destination array+              -> CmmExpr        -- ^ offset in destination array+              -> WordOff        -- ^ number of elements to copy+              -> FCode ()+emitCopyArray copy src0 src_off dst0 dst_off0 n =+    when (n /= 0) $ do+        dflags <- getDynFlags++        -- Passed as arguments (be careful)+        src     <- assignTempE src0+        dst     <- assignTempE dst0+        dst_off <- assignTempE dst_off0++        -- Set the dirty bit in the header.+        emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel)))++        dst_elems_p <- assignTempE $ cmmOffsetB dflags dst+                       (arrPtrsHdrSize dflags)+        dst_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p dst_off+        src_p <- assignTempE $ cmmOffsetExprW dflags+                 (cmmOffsetB dflags src (arrPtrsHdrSize dflags)) src_off+        let bytes = wordsToBytes dflags n++        copy src dst dst_p src_p bytes++        -- The base address of the destination card table+        dst_cards_p <- assignTempE $ cmmOffsetExprW dflags dst_elems_p+                       (loadArrPtrsSize dflags dst)++        emitSetCards dst_off dst_cards_p n++doCopySmallArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+                   -> FCode ()+doCopySmallArrayOp = emitCopySmallArray copy+  where+    -- Copy data (we assume the arrays aren't overlapping since+    -- they're of different types)+    copy _src _dst dst_p src_p bytes =+        do dflags <- getDynFlags+           emitMemcpyCall dst_p src_p (mkIntExpr dflags bytes)+               (wordAlignment dflags)+++doCopySmallMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> WordOff+                          -> FCode ()+doCopySmallMutableArrayOp = emitCopySmallArray copy+  where+    -- The only time the memory might overlap is when the two arrays+    -- we were provided are the same array!+    -- TODO: Optimize branch for common case of no aliasing.+    copy src dst dst_p src_p bytes = do+        dflags <- getDynFlags+        (moveCall, cpyCall) <- forkAltPair+            (getCode $ emitMemmoveCall dst_p src_p (mkIntExpr dflags bytes)+             (wordAlignment dflags))+            (getCode $ emitMemcpyCall  dst_p src_p (mkIntExpr dflags bytes)+             (wordAlignment dflags))+        emit =<< mkCmmIfThenElse (cmmEqWord dflags src dst) moveCall cpyCall++emitCopySmallArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> ByteOff+                       -> FCode ())  -- ^ copy function+                   -> CmmExpr        -- ^ source array+                   -> CmmExpr        -- ^ offset in source array+                   -> CmmExpr        -- ^ destination array+                   -> CmmExpr        -- ^ offset in destination array+                   -> WordOff        -- ^ number of elements to copy+                   -> FCode ()+emitCopySmallArray copy src0 src_off dst0 dst_off n =+    when (n /= 0) $ do+        dflags <- getDynFlags++        -- Passed as arguments (be careful)+        src     <- assignTempE src0+        dst     <- assignTempE dst0++        -- Set the dirty bit in the header.+        emit (setInfo dst (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))++        dst_p <- assignTempE $ cmmOffsetExprW dflags+                 (cmmOffsetB dflags dst (smallArrPtrsHdrSize dflags)) dst_off+        src_p <- assignTempE $ cmmOffsetExprW dflags+                 (cmmOffsetB dflags src (smallArrPtrsHdrSize dflags)) src_off+        let bytes = wordsToBytes dflags n++        copy src dst dst_p src_p bytes++-- | Takes an info table label, a register to return the newly+-- allocated array in, a source array, an offset in the source array,+-- and the number of elements to copy. Allocates a new array and+-- initializes it from the source array.+emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff+               -> FCode ()+emitCloneArray info_p res_r src src_off n = do+    dflags <- getDynFlags++    let info_ptr = mkLblExpr info_p+        rep = arrPtrsRep dflags n++    tickyAllocPrim (mkIntExpr dflags (arrPtrsHdrSize dflags))+        (mkIntExpr dflags (nonHdrSize dflags rep))+        (zeroExpr dflags)++    let hdr_size = fixedHdrSize dflags++    base <- allocHeapClosure rep info_ptr cccsExpr+                     [ (mkIntExpr dflags n,+                        hdr_size + oFFSET_StgMutArrPtrs_ptrs dflags)+                     , (mkIntExpr dflags (nonHdrSizeW rep),+                        hdr_size + oFFSET_StgMutArrPtrs_size dflags)+                     ]++    arr <- CmmLocal `fmap` newTemp (bWord dflags)+    emit $ mkAssign arr base++    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)+             (arrPtrsHdrSize dflags)+    src_p <- assignTempE $ cmmOffsetExprW dflags src+             (cmmAddWord dflags+              (mkIntExpr dflags (arrPtrsHdrSizeW dflags)) src_off)++    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))+        (wordAlignment dflags)++    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)++-- | Takes an info table label, a register to return the newly+-- allocated array in, a source array, an offset in the source array,+-- and the number of elements to copy. Allocates a new array and+-- initializes it from the source array.+emitCloneSmallArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> WordOff+                    -> FCode ()+emitCloneSmallArray info_p res_r src src_off n = do+    dflags <- getDynFlags++    let info_ptr = mkLblExpr info_p+        rep = smallArrPtrsRep n++    tickyAllocPrim (mkIntExpr dflags (smallArrPtrsHdrSize dflags))+        (mkIntExpr dflags (nonHdrSize dflags rep))+        (zeroExpr dflags)++    let hdr_size = fixedHdrSize dflags++    base <- allocHeapClosure rep info_ptr cccsExpr+                     [ (mkIntExpr dflags n,+                        hdr_size + oFFSET_StgSmallMutArrPtrs_ptrs dflags)+                     ]++    arr <- CmmLocal `fmap` newTemp (bWord dflags)+    emit $ mkAssign arr base++    dst_p <- assignTempE $ cmmOffsetB dflags (CmmReg arr)+             (smallArrPtrsHdrSize dflags)+    src_p <- assignTempE $ cmmOffsetExprW dflags src+             (cmmAddWord dflags+              (mkIntExpr dflags (smallArrPtrsHdrSizeW dflags)) src_off)++    emitMemcpyCall dst_p src_p (mkIntExpr dflags (wordsToBytes dflags n))+        (wordAlignment dflags)++    emit $ mkAssign (CmmLocal res_r) (CmmReg arr)++-- | Takes and offset in the destination array, the base address of+-- the card table, and the number of elements affected (*not* the+-- number of cards). The number of elements may not be zero.+-- Marks the relevant cards as dirty.+emitSetCards :: CmmExpr -> CmmExpr -> WordOff -> FCode ()+emitSetCards dst_start dst_cards_start n = do+    dflags <- getDynFlags+    start_card <- assignTempE $ cardCmm dflags dst_start+    let end_card = cardCmm dflags+                   (cmmSubWord dflags+                    (cmmAddWord dflags dst_start (mkIntExpr dflags n))+                    (mkIntExpr dflags 1))+    emitMemsetCall (cmmAddWord dflags dst_cards_start start_card)+        (mkIntExpr dflags 1)+        (cmmAddWord dflags (cmmSubWord dflags end_card start_card) (mkIntExpr dflags 1))+        (mkAlignment 1) -- no alignment (1 byte)++-- Convert an element index to a card index+cardCmm :: DynFlags -> CmmExpr -> CmmExpr+cardCmm dflags i =+    cmmUShrWord dflags i (mkIntExpr dflags (mUT_ARR_PTRS_CARD_BITS dflags))++------------------------------------------------------------------------------+-- SmallArray PrimOp implementations++doReadSmallPtrArrayOp :: LocalReg+                      -> CmmExpr+                      -> CmmExpr+                      -> FCode ()+doReadSmallPtrArrayOp res addr idx = do+    dflags <- getDynFlags+    mkBasicIndexedRead (smallArrPtrsHdrSize dflags) Nothing (gcWord dflags) res addr+        (gcWord dflags) idx++doWriteSmallPtrArrayOp :: CmmExpr+                       -> CmmExpr+                       -> CmmExpr+                       -> FCode ()+doWriteSmallPtrArrayOp addr idx val = do+    dflags <- getDynFlags+    let ty = cmmExprType dflags val+    emitPrimCall [] MO_WriteBarrier [] -- #12469+    mkBasicIndexedWrite (smallArrPtrsHdrSize dflags) Nothing addr ty idx val+    emit (setInfo addr (CmmLit (CmmLabel mkSMAP_DIRTY_infoLabel)))++------------------------------------------------------------------------------+-- Atomic read-modify-write++-- | Emit an atomic modification to a byte array element. The result+-- reg contains that previous value of the element. Implies a full+-- memory barrier.+doAtomicRMW :: LocalReg      -- ^ Result reg+            -> AtomicMachOp  -- ^ Atomic op (e.g. add)+            -> CmmExpr       -- ^ MutableByteArray#+            -> CmmExpr       -- ^ Index+            -> CmmType       -- ^ Type of element by which we are indexing+            -> CmmExpr       -- ^ Op argument (e.g. amount to add)+            -> FCode ()+doAtomicRMW res amop mba idx idx_ty n = do+    dflags <- getDynFlags+    let width = typeWidth idx_ty+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+                width mba idx+    emitPrimCall+        [ res ]+        (MO_AtomicRMW width amop)+        [ addr, n ]++-- | Emit an atomic read to a byte array that acts as a memory barrier.+doAtomicReadByteArray+    :: LocalReg  -- ^ Result reg+    -> CmmExpr   -- ^ MutableByteArray#+    -> CmmExpr   -- ^ Index+    -> CmmType   -- ^ Type of element by which we are indexing+    -> FCode ()+doAtomicReadByteArray res mba idx idx_ty = do+    dflags <- getDynFlags+    let width = typeWidth idx_ty+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+                width mba idx+    emitPrimCall+        [ res ]+        (MO_AtomicRead width)+        [ addr ]++-- | Emit an atomic write to a byte array that acts as a memory barrier.+doAtomicWriteByteArray+    :: CmmExpr   -- ^ MutableByteArray#+    -> CmmExpr   -- ^ Index+    -> CmmType   -- ^ Type of element by which we are indexing+    -> CmmExpr   -- ^ Value to write+    -> FCode ()+doAtomicWriteByteArray mba idx idx_ty val = do+    dflags <- getDynFlags+    let width = typeWidth idx_ty+        addr  = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+                width mba idx+    emitPrimCall+        [ {- no results -} ]+        (MO_AtomicWrite width)+        [ addr, val ]++doCasByteArray+    :: LocalReg  -- ^ Result reg+    -> CmmExpr   -- ^ MutableByteArray#+    -> CmmExpr   -- ^ Index+    -> CmmType   -- ^ Type of element by which we are indexing+    -> CmmExpr   -- ^ Old value+    -> CmmExpr   -- ^ New value+    -> FCode ()+doCasByteArray res mba idx idx_ty old new = do+    dflags <- getDynFlags+    let width = (typeWidth idx_ty)+        addr = cmmIndexOffExpr dflags (arrWordsHdrSize dflags)+               width mba idx+    emitPrimCall+        [ res ]+        (MO_Cmpxchg width)+        [ addr, old, new ]++------------------------------------------------------------------------------+-- Helpers for emitting function calls++-- | Emit a call to @memcpy@.+emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()+emitMemcpyCall dst src n align = do+    emitPrimCall+        [ {-no results-} ]+        (MO_Memcpy (alignmentBytes align))+        [ dst, src, n ]++-- | Emit a call to @memmove@.+emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()+emitMemmoveCall dst src n align = do+    emitPrimCall+        [ {- no results -} ]+        (MO_Memmove (alignmentBytes align))+        [ dst, src, n ]++-- | Emit a call to @memset@.  The second argument must fit inside an+-- unsigned char.+emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> Alignment -> FCode ()+emitMemsetCall dst c n align = do+    emitPrimCall+        [ {- no results -} ]+        (MO_Memset (alignmentBytes align))+        [ dst, c, n ]++emitMemcmpCall :: LocalReg -> CmmExpr -> CmmExpr -> CmmExpr -> Int -> FCode ()+emitMemcmpCall res ptr1 ptr2 n align = do+    -- 'MO_Memcmp' is assumed to return an 32bit 'CInt' because all+    -- code-gens currently call out to the @memcmp(3)@ C function.+    -- This was easier than moving the sign-extensions into+    -- all the code-gens.+    dflags <- getDynFlags+    let is32Bit = typeWidth (localRegType res) == W32++    cres <- if is32Bit+              then return res+              else newTemp b32++    emitPrimCall+        [ cres ]+        (MO_Memcmp align)+        [ ptr1, ptr2, n ]++    unless is32Bit $ do+      emit $ mkAssign (CmmLocal res)+                      (CmmMachOp+                         (mo_s_32ToWord dflags)+                         [(CmmReg (CmmLocal cres))])++emitBSwapCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitBSwapCall res x width = do+    emitPrimCall+        [ res ]+        (MO_BSwap width)+        [ x ]++emitBRevCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitBRevCall res x width = do+    emitPrimCall+        [ res ]+        (MO_BRev width)+        [ x ]++emitPopCntCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitPopCntCall res x width = do+    emitPrimCall+        [ res ]+        (MO_PopCnt width)+        [ x ]++emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()+emitPdepCall res x y width = do+    emitPrimCall+        [ res ]+        (MO_Pdep width)+        [ x, y ]++emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()+emitPextCall res x y width = do+    emitPrimCall+        [ res ]+        (MO_Pext width)+        [ x, y ]++emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitClzCall res x width = do+    emitPrimCall+        [ res ]+        (MO_Clz width)+        [ x ]++emitCtzCall :: LocalReg -> CmmExpr -> Width -> FCode ()+emitCtzCall res x width = do+    emitPrimCall+        [ res ]+        (MO_Ctz width)+        [ x ]
+ compiler/codeGen/StgCmmProf.hs view
@@ -0,0 +1,360 @@+-----------------------------------------------------------------------------+--+-- Code generation for profiling+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmProf (+        initCostCentres, ccType, ccsType,+        mkCCostCentre, mkCCostCentreStack,++        -- Cost-centre Profiling+        dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,+        enterCostCentreThunk, enterCostCentreFun,+        costCentreFrom,+        storeCurCCS,+        emitSetCCC,++        saveCurrentCostCentre, restoreCurrentCostCentre,++        -- Lag/drag/void stuff+        ldvEnter, ldvEnterClosure, ldvRecordCreate+  ) where++import GhcPrelude++import StgCmmClosure+import StgCmmUtils+import StgCmmMonad+import SMRep++import MkGraph+import Cmm+import CmmUtils+import CLabel++import CostCentre+import DynFlags+import FastString+import Module+import Outputable++import Control.Monad+import Data.Char (ord)++-----------------------------------------------------------------------------+--+-- Cost-centre-stack Profiling+--+-----------------------------------------------------------------------------++-- Expression representing the current cost centre stack+ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack+ccsType = bWord++ccType :: DynFlags -> CmmType -- Type of a cost centre+ccType = bWord++storeCurCCS :: CmmExpr -> CmmAGraph+storeCurCCS e = mkAssign cccsReg e++mkCCostCentre :: CostCentre -> CmmLit+mkCCostCentre cc = CmmLabel (mkCCLabel cc)++mkCCostCentreStack :: CostCentreStack -> CmmLit+mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)++costCentreFrom :: DynFlags+               -> CmmExpr         -- A closure pointer+               -> CmmExpr        -- The cost centre from that closure+costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags)++-- | The profiling header words in a static closure+staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]+staticProfHdr dflags ccs+ = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]++-- | Profiling header words in a dynamic closure+dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]+dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]++-- | Initialise the profiling field of an update frame+initUpdFrameProf :: CmmExpr -> FCode ()+initUpdFrameProf frame+  = ifProfiling $        -- frame->header.prof.ccs = CCCS+    do dflags <- getDynFlags+       emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) cccsExpr+        -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)+        -- is unnecessary because it is not used anyhow.++---------------------------------------------------------------------------+--         Saving and restoring the current cost centre+---------------------------------------------------------------------------++{-        Note [Saving the current cost centre]+        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The current cost centre is like a global register.  Like other+global registers, it's a caller-saves one.  But consider+        case (f x) of (p,q) -> rhs+Since 'f' may set the cost centre, we must restore it+before resuming rhs.  So we want code like this:+        local_cc = CCC  -- save+        r = f( x )+        CCC = local_cc  -- restore+That is, we explicitly "save" the current cost centre in+a LocalReg, local_cc; and restore it after the call. The+C-- infrastructure will arrange to save local_cc across the+call.++The same goes for join points;+        let j x = join-stuff+        in blah-blah+We want this kind of code:+        local_cc = CCC  -- save+        blah-blah+     J:+        CCC = local_cc  -- restore+-}++saveCurrentCostCentre :: FCode (Maybe LocalReg)+        -- Returns Nothing if profiling is off+saveCurrentCostCentre+  = do dflags <- getDynFlags+       if not (gopt Opt_SccProfilingOn dflags)+           then return Nothing+           else do local_cc <- newTemp (ccType dflags)+                   emitAssign (CmmLocal local_cc) cccsExpr+                   return (Just local_cc)++restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()+restoreCurrentCostCentre Nothing+  = return ()+restoreCurrentCostCentre (Just local_cc)+  = emit (storeCurCCS (CmmReg (CmmLocal local_cc)))+++-------------------------------------------------------------------------------+-- Recording allocation in a cost centre+-------------------------------------------------------------------------------++-- | Record the allocation of a closure.  The CmmExpr is the cost+-- centre stack to which to attribute the allocation.+profDynAlloc :: SMRep -> CmmExpr -> FCode ()+profDynAlloc rep ccs+  = ifProfiling $+    do dflags <- getDynFlags+       profAlloc (mkIntExpr dflags (heapClosureSizeW dflags rep)) ccs++-- | Record the allocation of a closure (size is given by a CmmExpr)+-- The size must be in words, because the allocation counter in a CCS counts+-- in words.+profAlloc :: CmmExpr -> CmmExpr -> FCode ()+profAlloc words ccs+  = ifProfiling $+        do dflags <- getDynFlags+           let alloc_rep = rEP_CostCentreStack_mem_alloc dflags+           emit (addToMemE alloc_rep+                       (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))+                       (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $+                         [CmmMachOp (mo_wordSub dflags) [words,+                                                         mkIntExpr dflags (profHdrSize dflags)]]))+                       -- subtract the "profiling overhead", which is the+                       -- profiling header in a closure.++-- -----------------------------------------------------------------------+-- Setting the current cost centre on entry to a closure++enterCostCentreThunk :: CmmExpr -> FCode ()+enterCostCentreThunk closure =+  ifProfiling $ do+      dflags <- getDynFlags+      emit $ storeCurCCS (costCentreFrom dflags closure)++enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()+enterCostCentreFun ccs closure =+  ifProfiling $ do+    if isCurrentCCS ccs+       then do dflags <- getDynFlags+               emitRtsCall rtsUnitId (fsLit "enterFunCCS")+                   [(baseExpr, AddrHint),+                    (costCentreFrom dflags closure, AddrHint)] False+       else return () -- top-level function, nothing to do++ifProfiling :: FCode () -> FCode ()+ifProfiling code+  = do dflags <- getDynFlags+       if gopt Opt_SccProfilingOn dflags+           then code+           else return ()++ifProfilingL :: DynFlags -> [a] -> [a]+ifProfilingL dflags xs+  | gopt Opt_SccProfilingOn dflags = xs+  | otherwise                      = []+++---------------------------------------------------------------+--        Initialising Cost Centres & CCSs+---------------------------------------------------------------++initCostCentres :: CollectedCCs -> FCode ()+-- Emit the declarations+initCostCentres (local_CCs, singleton_CCSs)+  = do dflags <- getDynFlags+       when (gopt Opt_SccProfilingOn dflags) $+           do mapM_ emitCostCentreDecl local_CCs+              mapM_ emitCostCentreStackDecl singleton_CCSs+++emitCostCentreDecl :: CostCentre -> FCode ()+emitCostCentreDecl cc = do+  { dflags <- getDynFlags+  ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF+               | otherwise  = zero dflags+                        -- NB. bytesFS: we want the UTF-8 bytes here (#5559)+  ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)+  ; modl  <- newByteStringCLit (bytesFS $ Module.moduleNameFS+                                        $ Module.moduleName+                                        $ cc_mod cc)+  ; loc <- newByteStringCLit $ bytesFS $ mkFastString $+                   showPpr dflags (costCentreSrcSpan cc)+           -- XXX going via FastString to get UTF-8 encoding is silly+  ; let+     lits = [ zero dflags,           -- StgInt ccID,+              label,        -- char *label,+              modl,        -- char *module,+              loc,      -- char *srcloc,+              zero64,   -- StgWord64 mem_alloc+              zero dflags,     -- StgWord time_ticks+              is_caf,   -- StgInt is_caf+              zero dflags      -- struct _CostCentre *link+            ]+  ; emitDataLits (mkCCLabel cc) lits+  }++emitCostCentreStackDecl :: CostCentreStack -> FCode ()+emitCostCentreStackDecl ccs+  = case maybeSingletonCCS ccs of+    Just cc ->+        do dflags <- getDynFlags+           let mk_lits cc = zero dflags :+                            mkCCostCentre cc :+                            replicate (sizeof_ccs_words dflags - 2) (zero dflags)+                -- Note: to avoid making any assumptions about how the+                -- C compiler (that compiles the RTS, in particular) does+                -- layouts of structs containing long-longs, simply+                -- 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)+    Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)++zero :: DynFlags -> CmmLit+zero dflags = mkIntCLit dflags 0+zero64 :: CmmLit+zero64 = CmmInt 0 W64++sizeof_ccs_words :: DynFlags -> Int+sizeof_ccs_words dflags+    -- round up to the next word.+  | ms == 0   = ws+  | otherwise = ws + 1+  where+   (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags++-- ---------------------------------------------------------------------------+-- Set the current cost centre stack++emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()+emitSetCCC cc tick push+ = do dflags <- getDynFlags+      if not (gopt Opt_SccProfilingOn dflags)+          then return ()+          else do tmp <- newTemp (ccsType dflags)+                  pushCostCentre tmp cccsExpr cc+                  when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))+                  when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))++pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()+pushCostCentre result ccs cc+  = emitRtsCallWithResult result AddrHint+        rtsUnitId+        (fsLit "pushCostCentre") [(ccs,AddrHint),+                                (CmmLit (mkCCostCentre cc), AddrHint)]+        False++bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph+bumpSccCount dflags ccs+  = addToMem (rEP_CostCentreStack_scc_count dflags)+         (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1++-----------------------------------------------------------------------------+--+--                Lag/drag/void stuff+--+-----------------------------------------------------------------------------++--+-- Initial value for the LDV field in a static closure+--+staticLdvInit :: DynFlags -> CmmLit+staticLdvInit = zeroCLit++--+-- Initial value of the LDV field in a dynamic closure+--+dynLdvInit :: DynFlags -> CmmExpr+dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE+  CmmMachOp (mo_wordOr dflags) [+      CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],+      CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))+  ]++--+-- Initialise the LDV word of a new closure+--+ldvRecordCreate :: CmmExpr -> FCode ()+ldvRecordCreate closure = do+  dflags <- getDynFlags+  emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)++--+-- | Called when a closure is entered, marks the closure as having+-- been "used".  The closure is not an "inherently used" one.  The+-- closure is not @IND@ because that is not considered for LDV profiling.+--+ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()+ldvEnterClosure closure_info node_reg = do+    dflags <- getDynFlags+    let tag = funTag dflags closure_info+    -- don't forget to substract node's tag+    ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag))++ldvEnter :: CmmExpr -> FCode ()+-- Argument is a closure pointer+ldvEnter cl_ptr = do+    dflags <- getDynFlags+    let -- don't forget to substract node's tag+        ldv_wd = ldvWord dflags cl_ptr+        new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))+                                                         (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))+                                      (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))+    ifProfiling $+         -- if (era > 0) {+         --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |+         --                era | LDV_STATE_USE }+        emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])+                     (mkStore ldv_wd new_ldv_wd)+                     mkNop++loadEra :: DynFlags -> CmmExpr+loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))+    [CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era")))+             (cInt dflags)]++ldvWord :: DynFlags -> CmmExpr -> CmmExpr+-- Takes the address of a closure, and returns+-- the address of the LDV word in the closure+ldvWord dflags closure_ptr+    = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
+ compiler/codeGen/StgCmmTicky.hs view
@@ -0,0 +1,682 @@+{-# LANGUAGE BangPatterns #-}++-----------------------------------------------------------------------------+--+-- Code generation for ticky-ticky profiling+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++{- OVERVIEW: ticky ticky profiling++Please see+https://gitlab.haskell.org/ghc/ghc/wikis/debugging/ticky-ticky and also+edit it and the rest of this comment to keep them up-to-date if you+change ticky-ticky. Thanks!++ *** All allocation ticky numbers are in bytes. ***++Some of the relevant source files:++       ***not necessarily an exhaustive list***++  * some codeGen/ modules import this one++  * this module imports cmm/CLabel.hs to manage labels++  * cmm/CmmParse.y expands some macros using generators defined in+    this module++  * includes/stg/Ticky.h declares all of the global counters++  * includes/rts/Ticky.h declares the C data type for an+    STG-declaration's counters++  * some macros defined in includes/Cmm.h (and used within the RTS's+    CMM code) update the global ticky counters++  * at the end of execution rts/Ticky.c generates the final report+    +RTS -r<report-file> -RTS++The rts/Ticky.c function that generates the report includes an+STG-declaration's ticky counters if++  * that declaration was entered, or++  * it was allocated (if -ticky-allocd)++On either of those events, the counter is "registered" by adding it to+a linked list; cf the CMM generated by registerTickyCtr.++Ticky-ticky profiling has evolved over many years. Many of the+counters from its most sophisticated days are no longer+active/accurate. As the RTS has changed, sometimes the ticky code for+relevant counters was not accordingly updated. Unfortunately, neither+were the comments.++As of March 2013, there still exist deprecated code and comments in+the code generator as well as the RTS because:++  * I don't know what is out-of-date versus merely commented out for+    momentary convenience, and++  * someone else might know how to repair it!++-}++module StgCmmTicky (+  withNewTickyCounterFun,+  withNewTickyCounterLNE,+  withNewTickyCounterThunk,+  withNewTickyCounterStdThunk,+  withNewTickyCounterCon,++  tickyDynAlloc,+  tickyAllocHeap,++  tickyAllocPrim,+  tickyAllocThunk,+  tickyAllocPAP,+  tickyHeapCheck,+  tickyStackCheck,++  tickyUnknownCall, tickyDirectCall,++  tickyPushUpdateFrame,+  tickyUpdateFrameOmitted,++  tickyEnterDynCon,+  tickyEnterStaticCon,+  tickyEnterViaNode,++  tickyEnterFun,+  tickyEnterThunk, tickyEnterStdThunk,        -- dynamic non-value+                                              -- thunks only+  tickyEnterLNE,++  tickyUpdateBhCaf,+  tickyBlackHole,+  tickyUnboxedTupleReturn,+  tickyReturnOldCon, tickyReturnNewCon,++  tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,+  tickySlowCall, tickySlowCallPat,+  ) where++import GhcPrelude++import StgCmmArgRep    ( slowCallPattern , toArgRep , argRepString )+import StgCmmClosure+import StgCmmUtils+import StgCmmMonad++import StgSyn+import CmmExpr+import MkGraph+import CmmUtils+import CLabel+import SMRep++import Module+import Name+import Id+import BasicTypes+import FastString+import Outputable+import Util++import DynFlags++-- Turgid imports for showTypeCategory+import PrelNames+import TcType+import Type+import TyCon++import Data.Maybe+import qualified Data.Char+import Control.Monad ( when )++-----------------------------------------------------------------------------+--+-- Ticky-ticky profiling+--+-----------------------------------------------------------------------------++data TickyClosureType+    = TickyFun+        Bool -- True <-> single entry+    | TickyCon+    | TickyThunk+        Bool -- True <-> updateable+        Bool -- True <-> standard thunk (AP or selector), has no entry counter+    | TickyLNE++withNewTickyCounterFun :: Bool -> Name  -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry)++withNewTickyCounterLNE :: Name  -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounterLNE nm args code = do+  b <- tickyLNEIsOn+  if not b then code else withNewTickyCounter TickyLNE nm args code++thunkHasCounter :: Bool -> FCode Bool+thunkHasCounter isStatic = do+  b <- tickyDynThunkIsOn+  pure (not isStatic && b)++withNewTickyCounterThunk+  :: Bool -- ^ static+  -> Bool -- ^ updateable+  -> Name+  -> FCode a+  -> FCode a+withNewTickyCounterThunk isStatic isUpdatable name code = do+    has_ctr <- thunkHasCounter isStatic+    if not has_ctr+      then code+      else withNewTickyCounter (TickyThunk isUpdatable False) name [] code++withNewTickyCounterStdThunk+  :: Bool -- ^ updateable+  -> Name+  -> FCode a+  -> FCode a+withNewTickyCounterStdThunk isUpdatable name code = do+    has_ctr <- thunkHasCounter False+    if not has_ctr+      then code+      else withNewTickyCounter (TickyThunk isUpdatable True) name [] code++withNewTickyCounterCon+  :: Name+  -> FCode a+  -> FCode a+withNewTickyCounterCon name code = do+    has_ctr <- thunkHasCounter False+    if not has_ctr+      then code+      else withNewTickyCounter TickyCon name [] code++-- args does not include the void arguments+withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounter cloType name args m = do+  lbl <- emitTickyCounter cloType name args+  setTickyCtrLabel lbl m++emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel+emitTickyCounter cloType name args+  = let ctr_lbl = mkRednCountsLabel name in+    (>> return ctr_lbl) $+    ifTicky $ do+        { dflags <- getDynFlags+        ; parent <- getTickyCtrLabel+        ; mod_name <- getModuleName++          -- When printing the name of a thing in a ticky file, we+          -- want to give the module name even for *local* things.  We+          -- print just "x (M)" rather that "M.x" to distinguish them+          -- from the global kind.+        ; let ppr_for_ticky_name :: SDoc+              ppr_for_ticky_name =+                let n = ppr name+                    ext = case cloType of+                              TickyFun single_entry -> parens $ hcat $ punctuate comma $+                                  [text "fun"] ++ [text "se"|single_entry]+                              TickyCon -> parens (text "con")+                              TickyThunk upd std -> parens $ hcat $ punctuate comma $+                                  [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std]+                              TickyLNE | isInternalName name -> parens (text "LNE")+                                       | otherwise -> panic "emitTickyCounter: how is this an external LNE?"+                    p = case hasHaskellName parent of+                            -- NB the default "top" ticky ctr does not+                            -- have a Haskell name+                          Just pname -> text "in" <+> ppr (nameUnique pname)+                          _ -> empty+                in if isInternalName name+                   then n <+> parens (ppr mod_name) <+> ext <+> p+                   else n <+> ext <+> p++        ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name+        ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args+        ; emitDataLits ctr_lbl+        -- Must match layout of includes/rts/Ticky.h's StgEntCounter+        --+        -- krc: note that all the fields are I32 now; some were I16+        -- before, but the code generator wasn't handling that+        -- properly and it led to chaos, panic and disorder.+            [ mkIntCLit dflags 0,               -- registered?+              mkIntCLit dflags (length args),   -- Arity+              mkIntCLit dflags 0,               -- Heap allocated for this thing+              fun_descr_lit,+              arg_descr_lit,+              zeroCLit dflags,          -- Entries into this thing+              zeroCLit dflags,          -- Heap allocated by this thing+              zeroCLit dflags                   -- Link to next StgEntCounter+            ]+        }++-- -----------------------------------------------------------------------------+-- Ticky stack frames++tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()+tickyPushUpdateFrame    = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")+tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")++-- -----------------------------------------------------------------------------+-- Ticky entries++-- NB the name-specific entries are only available for names that have+-- dedicated Cmm code. As far as I know, this just rules out+-- constructor thunks. For them, there is no CMM code block to put the+-- bump of name-specific ticky counter into. On the other hand, we can+-- still track allocation their allocation.++tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode ()+tickyEnterDynCon      = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")+tickyEnterStaticCon   = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")+tickyEnterViaNode     = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")++tickyEnterThunk :: ClosureInfo -> FCode ()+tickyEnterThunk cl_info+  = ifTicky $ do+    { bumpTickyCounter ctr+    ; has_ctr <- thunkHasCounter static+    ; when has_ctr $ do+      ticky_ctr_lbl <- getTickyCtrLabel+      registerTickyCtrAtEntryDyn ticky_ctr_lbl+      bumpTickyEntryCount ticky_ctr_lbl }+  where+    updatable = closureSingleEntry cl_info+    static    = isStaticClosure cl_info++    ctr | static    = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr"+                                   else fsLit "ENT_STATIC_THK_MANY_ctr"+        | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr"+                                   else fsLit "ENT_DYN_THK_MANY_ctr"++tickyEnterStdThunk :: ClosureInfo -> FCode ()+tickyEnterStdThunk = tickyEnterThunk++tickyBlackHole :: Bool{-updatable-} -> FCode ()+tickyBlackHole updatable+  = ifTicky (bumpTickyCounter ctr)+  where+    ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr")+        | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr")++tickyUpdateBhCaf :: ClosureInfo -> FCode ()+tickyUpdateBhCaf cl_info+  = ifTicky (bumpTickyCounter ctr)+  where+    ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")+        | otherwise              = (fsLit "UPD_CAF_BH_UPDATABLE_ctr")++tickyEnterFun :: ClosureInfo -> FCode ()+tickyEnterFun cl_info = ifTicky $ do+  ctr_lbl <- getTickyCtrLabel++  if isStaticClosure cl_info+    then do bumpTickyCounter (fsLit "ENT_STATIC_FUN_DIRECT_ctr")+            registerTickyCtr ctr_lbl+    else do bumpTickyCounter (fsLit "ENT_DYN_FUN_DIRECT_ctr")+            registerTickyCtrAtEntryDyn ctr_lbl++  bumpTickyEntryCount ctr_lbl++tickyEnterLNE :: FCode ()+tickyEnterLNE = ifTicky $ do+  bumpTickyCounter (fsLit "ENT_LNE_ctr")+  ifTickyLNE $ do+    ctr_lbl <- getTickyCtrLabel+    registerTickyCtr ctr_lbl+    bumpTickyEntryCount ctr_lbl++-- needn't register a counter upon entry if+--+-- 1) it's for a dynamic closure, and+--+-- 2) -ticky-allocd is on+--+-- since the counter was registered already upon being alloc'd+registerTickyCtrAtEntryDyn :: CLabel -> FCode ()+registerTickyCtrAtEntryDyn ctr_lbl = do+  already_registered <- tickyAllocdIsOn+  when (not already_registered) $ registerTickyCtr ctr_lbl++registerTickyCtr :: CLabel -> FCode ()+-- Register a ticky counter+--   if ( ! f_ct.registeredp ) {+--          f_ct.link = ticky_entry_ctrs;       /* hook this one onto the front of the list */+--          ticky_entry_ctrs = & (f_ct);        /* mark it as "registered" */+--          f_ct.registeredp = 1 }+registerTickyCtr ctr_lbl = do+  dflags <- getDynFlags+  let+    -- krc: code generator doesn't handle Not, so we test for Eq 0 instead+    test = CmmMachOp (MO_Eq (wordWidth dflags))+              [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl+                                (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags),+               zeroExpr dflags]+    register_stmts+      = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags)))+                   (CmmLoad ticky_entry_ctrs (bWord dflags))+        , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)+        , mkStore (CmmLit (cmmLabelOffB ctr_lbl+                                (oFFSET_StgEntCounter_registeredp dflags)))+                   (mkIntExpr dflags 1) ]+    ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs"))+  emit =<< mkCmmIfThen test (catAGraphs register_stmts)++tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()+tickyReturnOldCon arity+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")+                 ; bumpHistogram    (fsLit "RET_OLD_hst") arity }+tickyReturnNewCon arity+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")+                 ; bumpHistogram    (fsLit "RET_NEW_hst") arity }++tickyUnboxedTupleReturn :: RepArity -> FCode ()+tickyUnboxedTupleReturn arity+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")+                 ; bumpHistogram    (fsLit "RET_UNBOXED_TUP_hst") arity }++-- -----------------------------------------------------------------------------+-- Ticky calls++-- Ticks at a *call site*:+tickyDirectCall :: RepArity -> [StgArg] -> FCode ()+tickyDirectCall arity args+  | args `lengthIs` arity = tickyKnownCallExact+  | otherwise = do tickyKnownCallExtraArgs+                   tickySlowCallPat (map argPrimRep (drop arity args))++tickyKnownCallTooFewArgs :: FCode ()+tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")++tickyKnownCallExact :: FCode ()+tickyKnownCallExact      = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")++tickyKnownCallExtraArgs :: FCode ()+tickyKnownCallExtraArgs  = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")++tickyUnknownCall :: FCode ()+tickyUnknownCall         = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")++-- Tick for the call pattern at slow call site (i.e. in addition to+-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)+tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()+tickySlowCall _ [] = return ()+tickySlowCall lf_info args = do+ -- see Note [Ticky for slow calls]+ if isKnownFun lf_info+   then tickyKnownCallTooFewArgs+   else tickyUnknownCall+ tickySlowCallPat (map argPrimRep args)++tickySlowCallPat :: [PrimRep] -> FCode ()+tickySlowCallPat args = ifTicky $+  let argReps = map toArgRep args+      (_, n_matched) = slowCallPattern argReps+  in if n_matched > 0 && args `lengthIs` n_matched+     then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps+     else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr"++{-++Note [Ticky for slow calls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Terminology is unfortunately a bit mixed up for these calls. codeGen+uses "slow call" to refer to unknown calls and under-saturated known+calls.++Nowadays, though (ie as of the eval/apply paper), the significantly+slower calls are actually just a subset of these: the ones with no+built-in argument pattern (cf StgCmmArgRep.slowCallPattern)++So for ticky profiling, we split slow calls into+"SLOW_CALL_fast_<pattern>_ctr" (those matching a built-in pattern) and+VERY_SLOW_CALL_ctr (those without a built-in pattern; these are very+bad for both space and time).++-}++-- -----------------------------------------------------------------------------+-- Ticky allocation++tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()+-- Called when doing a dynamic heap allocation; the LambdaFormInfo+-- used to distinguish between closure types+--+-- TODO what else to count while we're here?+tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags ->+  let bytes = wORD_SIZE dflags * heapClosureSizeW dflags rep++      countGlobal tot ctr = do+        bumpTickyCounterBy tot bytes+        bumpTickyCounter   ctr+      countSpecific = ifTickyAllocd $ case mb_id of+        Nothing -> return ()+        Just id -> do+          let ctr_lbl = mkRednCountsLabel (idName id)+          registerTickyCtr ctr_lbl+          bumpTickyAllocd ctr_lbl bytes++  -- TODO are we still tracking "good stuff" (_gds) versus+  -- administrative (_adm) versus slop (_slp)? I'm going with all _gds+  -- for now, since I don't currently know neither if we do nor how to+  -- distinguish. NSF Mar 2013++  in case () of+    _ | isConRep rep   ->+          ifTickyDynThunk countSpecific >>+          countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr")+      | isThunkRep rep ->+          ifTickyDynThunk countSpecific >>+          if lfUpdatable lf+          then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr")+          else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr")+      | isFunRep   rep ->+          countSpecific >>+          countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr")+      | otherwise      -> panic "How is this heap object not a con, thunk, or fun?"++++tickyAllocHeap ::+  Bool -> -- is this a genuine allocation? As opposed to+          -- StgCmmLayout.adjustHpBackwards+  VirtualHpOffset -> FCode ()+-- Called when doing a heap check [TICK_ALLOC_HEAP]+-- Must be lazy in the amount of allocation!+tickyAllocHeap genuine hp+  = ifTicky $+    do  { dflags <- getDynFlags+        ; ticky_ctr <- getTickyCtrLabel+        ; emit $ catAGraphs $+            -- only test hp from within the emit so that the monadic+            -- computation itself is not strict in hp (cf knot in+            -- StgCmmMonad.getHeapUsage)+          if hp == 0 then []+          else let !bytes = wORD_SIZE dflags * hp in [+            -- Bump the allocation total in the closure's StgEntCounter+            addToMem (rEP_StgEntCounter_allocs dflags)+                     (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags)))+                     bytes,+            -- Bump the global allocation total ALLOC_HEAP_tot+            addToMemLbl (bWord dflags)+                        (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))+                        bytes,+            -- Bump the global allocation counter ALLOC_HEAP_ctr+            if not genuine then mkNop+            else addToMemLbl (bWord dflags)+                             (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr"))+                             1+            ]}+++--------------------------------------------------------------------------------+-- these three are only called from CmmParse.y (ie ultimately from the RTS)++-- the units are bytes++tickyAllocPrim :: CmmExpr  -- ^ size of the full header, in bytes+               -> CmmExpr  -- ^ size of the payload, in bytes+               -> CmmExpr -> FCode ()+tickyAllocPrim _hdr _goods _slop = ifTicky $ do+  bumpTickyCounter    (fsLit "ALLOC_PRIM_ctr")+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_adm") _hdr+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_gds") _goods+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_slp") _slop++tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()+tickyAllocThunk _goods _slop = ifTicky $ do+    -- TODO is it ever called with a Single-Entry thunk?+  bumpTickyCounter    (fsLit "ALLOC_UP_THK_ctr")+  bumpTickyCounterByE (fsLit "ALLOC_THK_gds") _goods+  bumpTickyCounterByE (fsLit "ALLOC_THK_slp") _slop++tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()+tickyAllocPAP _goods _slop = ifTicky $ do+  bumpTickyCounter    (fsLit "ALLOC_PAP_ctr")+  bumpTickyCounterByE (fsLit "ALLOC_PAP_gds") _goods+  bumpTickyCounterByE (fsLit "ALLOC_PAP_slp") _slop++tickyHeapCheck :: FCode ()+tickyHeapCheck = ifTicky $ bumpTickyCounter (fsLit "HEAP_CHK_ctr")++tickyStackCheck :: FCode ()+tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr")++-- -----------------------------------------------------------------------------+-- Ticky utils++ifTicky :: FCode () -> FCode ()+ifTicky code =+  getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code++tickyAllocdIsOn :: FCode Bool+tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags++tickyLNEIsOn :: FCode Bool+tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags++tickyDynThunkIsOn :: FCode Bool+tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags++ifTickyAllocd :: FCode () -> FCode ()+ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code++ifTickyLNE :: FCode () -> FCode ()+ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code++ifTickyDynThunk :: FCode () -> FCode ()+ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code++bumpTickyCounter :: FastString -> FCode ()+bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsUnitId lbl)++bumpTickyCounterBy :: FastString -> Int -> FCode ()+bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsUnitId lbl)++bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()+bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsUnitId lbl)++bumpTickyEntryCount :: CLabel -> FCode ()+bumpTickyEntryCount lbl = do+  dflags <- getDynFlags+  bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags))++bumpTickyAllocd :: CLabel -> Int -> FCode ()+bumpTickyAllocd lbl bytes = do+  dflags <- getDynFlags+  bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes++bumpTickyLbl :: CLabel -> FCode ()+bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1++bumpTickyLblBy :: CLabel -> Int -> FCode ()+bumpTickyLblBy lhs = bumpTickyLitBy (cmmLabelOffB lhs 0)++bumpTickyLblByE :: CLabel -> CmmExpr -> FCode ()+bumpTickyLblByE lhs = bumpTickyLitByE (cmmLabelOffB lhs 0)++bumpTickyLit :: CmmLit -> FCode ()+bumpTickyLit lhs = bumpTickyLitBy lhs 1++bumpTickyLitBy :: CmmLit -> Int -> FCode ()+bumpTickyLitBy lhs n = do+  dflags <- getDynFlags+  emit (addToMem (bWord dflags) (CmmLit lhs) n)++bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()+bumpTickyLitByE lhs e = do+  dflags <- getDynFlags+  emit (addToMemE (bWord dflags) (CmmLit lhs) e)++bumpHistogram :: FastString -> Int -> FCode ()+bumpHistogram lbl n = do+    dflags <- getDynFlags+    let offset = n `min` (tICKY_BIN_COUNT dflags - 1)+    emit (addToMem (bWord dflags)+           (cmmIndexExpr dflags+                (wordWidth dflags)+                (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))+                (CmmLit (CmmInt (fromIntegral offset) (wordWidth dflags))))+           1)++------------------------------------------------------------------+-- Showing the "type category" for ticky-ticky profiling++showTypeCategory :: Type -> Char+  {-+        +           dictionary++        >           function++        {C,I,F,D,W} char, int, float, double, word+        {c,i,f,d,w} unboxed ditto++        T           tuple++        P           other primitive type+        p           unboxed ditto++        L           list+        E           enumeration type+        S           other single-constructor type+        M           other multi-constructor data-con type++        .           other type++        -           reserved for others to mark as "uninteresting"++  Accurate as of Mar 2013, but I eliminated the Array category instead+  of updating it, for simplicity. It's in P/p, I think --NSF++    -}+showTypeCategory ty+  | isDictTy ty = '+'+  | otherwise = case tcSplitTyConApp_maybe ty of+  Nothing -> '.'+  Just (tycon, _) ->+    (if isUnliftedTyCon tycon then Data.Char.toLower else id) $+    let anyOf us = getUnique tycon `elem` us in+    case () of+      _ | anyOf [funTyConKey] -> '>'+        | anyOf [charPrimTyConKey, charTyConKey] -> 'C'+        | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D'+        | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F'+        | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,+                 intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey+                ] -> 'I'+        | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey,+                 word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey+                ] -> 'W'+        | anyOf [listTyConKey] -> 'L'+        | isTupleTyCon tycon       -> 'T'+        | isPrimTyCon tycon        -> 'P'+        | isEnumerationTyCon tycon -> 'E'+        | isJust (tyConSingleDataCon_maybe tycon) -> 'S'+        | otherwise -> 'M' -- oh, well...
+ compiler/codeGen/StgCmmUtils.hs view
@@ -0,0 +1,578 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Code generator utilities; mostly monadic+--+-- (c) The University of Glasgow 2004-2006+--+-----------------------------------------------------------------------------++module StgCmmUtils (+        cgLit, mkSimpleLit,+        emitDataLits, mkDataLits,+        emitRODataLits, mkRODataLits,+        emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,+        assignTemp, newTemp,++        newUnboxedTupleRegs,++        emitMultiAssign, emitCmmLitSwitch, emitSwitch,++        tagToClosure, mkTaggedObjectLoad,++        callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,++        cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,+        cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,+        cmmOffsetExprW, cmmOffsetExprB,+        cmmRegOffW, cmmRegOffB,+        cmmLabelOffW, cmmLabelOffB,+        cmmOffsetW, cmmOffsetB,+        cmmOffsetLitW, cmmOffsetLitB,+        cmmLoadIndexW,+        cmmConstrTag1,++        cmmUntag, cmmIsTagged,++        addToMem, addToMemE, addToMemLblE, addToMemLbl,+        mkWordCLit,+        newStringCLit, newByteStringCLit,+        blankWord,+  ) where++#include "HsVersions.h"++import GhcPrelude++import StgCmmMonad+import StgCmmClosure+import Cmm+import BlockId+import MkGraph+import CodeGen.Platform+import CLabel+import CmmUtils+import CmmSwitch+import CgUtils++import ForeignCall+import IdInfo+import Type+import TyCon+import SMRep+import Module+import Literal+import Digraph+import Util+import Unique+import UniqSupply (MonadUnique(..))+import DynFlags+import FastString+import Outputable+import RepType++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS8+import qualified Data.Map as M+import Data.Char+import Data.List+import Data.Ord+++-------------------------------------------------------------------------+--+--      Literals+--+-------------------------------------------------------------------------++cgLit :: Literal -> FCode CmmLit+cgLit (LitString s) = newByteStringCLit s+ -- not unpackFS; we want the UTF-8 byte stream.+cgLit other_lit     = do dflags <- getDynFlags+                         return (mkSimpleLit dflags other_lit)++mkSimpleLit :: DynFlags -> Literal -> CmmLit+mkSimpleLit dflags (LitChar   c)                = CmmInt (fromIntegral (ord c))+                                                         (wordWidth dflags)+mkSimpleLit dflags LitNullAddr                  = zeroCLit dflags+mkSimpleLit dflags (LitNumber LitNumInt i _)    = CmmInt i (wordWidth dflags)+mkSimpleLit _      (LitNumber LitNumInt64 i _)  = CmmInt i W64+mkSimpleLit dflags (LitNumber LitNumWord i _)   = CmmInt i (wordWidth dflags)+mkSimpleLit _      (LitNumber LitNumWord64 i _) = CmmInt i W64+mkSimpleLit _      (LitFloat r)                 = CmmFloat r W32+mkSimpleLit _      (LitDouble r)                = CmmFloat r W64+mkSimpleLit _      (LitLabel fs ms fod)+  = let -- TODO: Literal labels might not actually be in the current package...+        labelSrc = ForeignLabelInThisPackage+    in CmmLabel (mkForeignLabel fs ms labelSrc fod)+-- NB: LitRubbish should have been lowered in "CoreToStg"+mkSimpleLit _      other = pprPanic "mkSimpleLit" (ppr other)++--------------------------------------------------------------------------+--+-- Incrementing a memory location+--+--------------------------------------------------------------------------++addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph+addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n++addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph+addToMemLblE rep lbl = addToMemE rep (CmmLit (CmmLabel lbl))++addToMem :: CmmType     -- rep of the counter+         -> CmmExpr     -- Address+         -> Int         -- What to add (a word)+         -> CmmAGraph+addToMem rep ptr n = addToMemE rep ptr (CmmLit (CmmInt (toInteger n) (typeWidth rep)))++addToMemE :: CmmType    -- rep of the counter+          -> CmmExpr    -- Address+          -> CmmExpr    -- What to add (a word-typed expression)+          -> CmmAGraph+addToMemE rep ptr n+  = mkStore ptr (CmmMachOp (MO_Add (typeWidth rep)) [CmmLoad ptr rep, n])+++-------------------------------------------------------------------------+--+--      Loading a field from an object,+--      where the object pointer is itself tagged+--+-------------------------------------------------------------------------++mkTaggedObjectLoad+  :: DynFlags -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph+-- (loadTaggedObjectField reg base off tag) generates assignment+--      reg = bitsK[ base + off - tag ]+-- where K is fixed by 'reg'+mkTaggedObjectLoad dflags reg base offset tag+  = mkAssign (CmmLocal reg)+             (CmmLoad (cmmOffsetB dflags+                                  (CmmReg (CmmLocal base))+                                  (offset - tag))+                      (localRegType reg))++-------------------------------------------------------------------------+--+--      Converting a closure tag to a closure for enumeration types+--      (this is the implementation of tagToEnum#).+--+-------------------------------------------------------------------------++tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr+tagToClosure dflags tycon tag+  = CmmLoad (cmmOffsetExprW dflags closure_tbl tag) (bWord dflags)+  where closure_tbl = CmmLit (CmmLabel lbl)+        lbl = mkClosureTableLabel (tyConName tycon) NoCafRefs++-------------------------------------------------------------------------+--+--      Conditionals and rts calls+--+-------------------------------------------------------------------------++emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()+emitRtsCall pkg fun args safe = emitRtsCallGen [] (mkCmmCodeLabel pkg fun) args safe++emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString+        -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()+emitRtsCallWithResult res hint pkg fun args safe+   = emitRtsCallGen [(res,hint)] (mkCmmCodeLabel pkg fun) args safe++-- Make a call to an RTS C procedure+emitRtsCallGen+   :: [(LocalReg,ForeignHint)]+   -> CLabel+   -> [(CmmExpr,ForeignHint)]+   -> Bool -- True <=> CmmSafe call+   -> FCode ()+emitRtsCallGen res lbl args safe+  = do { dflags <- getDynFlags+       ; updfr_off <- getUpdFrameOff+       ; let (caller_save, caller_load) = callerSaveVolatileRegs dflags+       ; emit caller_save+       ; call updfr_off+       ; emit caller_load }+  where+    call updfr_off =+      if safe then+        emit =<< mkCmmCall fun_expr res' args' updfr_off+      else do+        let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn+        emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'+    (args', arg_hints) = unzip args+    (res',  res_hints) = unzip res+    fun_expr = mkLblExpr lbl+++-----------------------------------------------------------------------------+--+--      Caller-Save Registers+--+-----------------------------------------------------------------------------++-- Here we generate the sequence of saves/restores required around a+-- foreign call instruction.++-- TODO: reconcile with includes/Regs.h+--  * Regs.h claims that BaseReg should be saved last and loaded first+--    * This might not have been tickled before since BaseReg is callee save+--  * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim+--+-- This code isn't actually used right now, because callerSaves+-- only ever returns true in the current universe for registers NOT in+-- system_regs (just do a grep for CALLER_SAVES in+-- includes/stg/MachRegs.h).  It's all one giant no-op, and for+-- good reason: having to save system registers on every foreign call+-- would be very expensive, so we avoid assigning them to those+-- registers when we add support for an architecture.+--+-- Note that the old code generator actually does more work here: it+-- also saves other global registers.  We can't (nor want) to do that+-- here, as we don't have liveness information.  And really, we+-- shouldn't be doing the workaround at this point in the pipeline, see+-- Note [Register parameter passing] and the ToDo on CmmCall in+-- cmm/CmmNode.hs.  Right now the workaround is to avoid inlining across+-- unsafe foreign calls in rewriteAssignments, but this is strictly+-- temporary.+callerSaveVolatileRegs :: DynFlags -> (CmmAGraph, CmmAGraph)+callerSaveVolatileRegs dflags = (caller_save, caller_load)+  where+    platform = targetPlatform dflags++    caller_save = catAGraphs (map callerSaveGlobalReg    regs_to_save)+    caller_load = catAGraphs (map callerRestoreGlobalReg regs_to_save)++    system_regs = [ Sp,SpLim,Hp,HpLim,CCCS,CurrentTSO,CurrentNursery+                    {- ,SparkHd,SparkTl,SparkBase,SparkLim -}+                  , BaseReg ]++    regs_to_save = filter (callerSaves platform) system_regs++    callerSaveGlobalReg reg+        = mkStore (get_GlobalReg_addr dflags reg) (CmmReg (CmmGlobal reg))++    callerRestoreGlobalReg reg+        = mkAssign (CmmGlobal reg)+                   (CmmLoad (get_GlobalReg_addr dflags reg) (globalRegType dflags reg))+++-------------------------------------------------------------------------+--+--      Strings generate a top-level data block+--+-------------------------------------------------------------------------++emitDataLits :: CLabel -> [CmmLit] -> FCode ()+-- Emit a data-segment data block+emitDataLits lbl lits = emitDecl (mkDataLits (Section Data lbl) lbl lits)++emitRODataLits :: CLabel -> [CmmLit] -> FCode ()+-- Emit a read-only data block+emitRODataLits lbl lits = emitDecl (mkRODataLits lbl lits)++newStringCLit :: String -> FCode CmmLit+-- Make a global definition for the string,+-- and return its label+newStringCLit str = newByteStringCLit (BS8.pack str)++newByteStringCLit :: ByteString -> FCode CmmLit+newByteStringCLit bytes+  = do  { uniq <- newUnique+        ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes+        ; emitDecl decl+        ; return lit }++-------------------------------------------------------------------------+--+--      Assigning expressions to temporaries+--+-------------------------------------------------------------------------++assignTemp :: CmmExpr -> FCode LocalReg+-- Make sure the argument is in a local register.+-- We don't bother being particularly aggressive with avoiding+-- unnecessary local registers, since we can rely on a later+-- optimization pass to inline as necessary (and skipping out+-- on things like global registers can be a little dangerous+-- due to them being trashed on foreign calls--though it means+-- the optimization pass doesn't have to do as much work)+assignTemp (CmmReg (CmmLocal reg)) = return reg+assignTemp e = do { dflags <- getDynFlags+                  ; uniq <- newUnique+                  ; let reg = LocalReg uniq (cmmExprType dflags e)+                  ; emitAssign (CmmLocal reg) e+                  ; return reg }++newTemp :: MonadUnique m => CmmType -> m LocalReg+newTemp rep = do { uniq <- getUniqueM+                 ; return (LocalReg uniq rep) }++newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])+-- Choose suitable local regs to use for the components+-- of an unboxed tuple that we are about to return to+-- the Sequel.  If the Sequel is a join point, using the+-- regs it wants will save later assignments.+newUnboxedTupleRegs res_ty+  = ASSERT( isUnboxedTupleType res_ty )+    do  { dflags <- getDynFlags+        ; sequel <- getSequel+        ; regs <- choose_regs dflags sequel+        ; ASSERT( regs `equalLength` reps )+          return (regs, map primRepForeignHint reps) }+  where+    reps = typePrimRep res_ty+    choose_regs _ (AssignTo regs _) = return regs+    choose_regs dflags _            = mapM (newTemp . primRepCmmType dflags) reps++++-------------------------------------------------------------------------+--      emitMultiAssign+-------------------------------------------------------------------------++emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()+-- Emit code to perform the assignments in the+-- input simultaneously, using temporary variables when necessary.++type Key  = Int+type Vrtx = (Key, Stmt) -- Give each vertex a unique number,+                        -- for fast comparison+type Stmt = (LocalReg, CmmExpr) -- r := e++-- We use the strongly-connected component algorithm, in which+--      * the vertices are the statements+--      * an edge goes from s1 to s2 iff+--              s1 assigns to something s2 uses+--        that is, if s1 should *follow* s2 in the final order++emitMultiAssign []    []    = return ()+emitMultiAssign [reg] [rhs] = emitAssign (CmmLocal reg) rhs+emitMultiAssign regs rhss   = do+  dflags <- getDynFlags+  ASSERT2( equalLength regs rhss, ppr regs $$ ppr rhss )+    unscramble dflags ([1..] `zip` (regs `zip` rhss))++unscramble :: DynFlags -> [Vrtx] -> FCode ()+unscramble dflags vertices = mapM_ do_component components+  where+        edges :: [ Node Key Vrtx ]+        edges = [ DigraphNode vertex key1 (edges_from stmt1)+                | vertex@(key1, stmt1) <- vertices ]++        edges_from :: Stmt -> [Key]+        edges_from stmt1 = [ key2 | (key2, stmt2) <- vertices,+                                    stmt1 `mustFollow` stmt2 ]++        components :: [SCC Vrtx]+        components = stronglyConnCompFromEdgedVerticesUniq edges++        -- do_components deal with one strongly-connected component+        -- Not cyclic, or singleton?  Just do it+        do_component :: SCC Vrtx -> FCode ()+        do_component (AcyclicSCC (_,stmt))  = mk_graph stmt+        do_component (CyclicSCC [])         = panic "do_component"+        do_component (CyclicSCC [(_,stmt)]) = mk_graph stmt++                -- Cyclic?  Then go via temporaries.  Pick one to+                -- break the loop and try again with the rest.+        do_component (CyclicSCC ((_,first_stmt) : rest)) = do+            dflags <- getDynFlags+            u <- newUnique+            let (to_tmp, from_tmp) = split dflags u first_stmt+            mk_graph to_tmp+            unscramble dflags rest+            mk_graph from_tmp++        split :: DynFlags -> Unique -> Stmt -> (Stmt, Stmt)+        split dflags uniq (reg, rhs)+          = ((tmp, rhs), (reg, CmmReg (CmmLocal tmp)))+          where+            rep = cmmExprType dflags rhs+            tmp = LocalReg uniq rep++        mk_graph :: Stmt -> FCode ()+        mk_graph (reg, rhs) = emitAssign (CmmLocal reg) rhs++        mustFollow :: Stmt -> Stmt -> Bool+        (reg, _) `mustFollow` (_, rhs) = regUsedIn dflags (CmmLocal reg) rhs++-------------------------------------------------------------------------+--      mkSwitch+-------------------------------------------------------------------------+++emitSwitch :: CmmExpr                      -- Tag to switch on+           -> [(ConTagZ, CmmAGraphScoped)] -- Tagged branches+           -> Maybe CmmAGraphScoped        -- Default branch (if any)+           -> ConTagZ -> ConTagZ           -- Min and Max possible values;+                                           -- behaviour outside this range is+                                           -- undefined+           -> FCode ()++-- First, two rather common cases in which there is no work to do+emitSwitch _ []         (Just code) _ _ = emit (fst code)+emitSwitch _ [(_,code)] Nothing     _ _ = emit (fst code)++-- Right, off we go+emitSwitch tag_expr branches mb_deflt lo_tag hi_tag = do+    join_lbl      <- newBlockId+    mb_deflt_lbl  <- label_default join_lbl mb_deflt+    branches_lbls <- label_branches join_lbl branches+    tag_expr'     <- assignTemp' tag_expr++    -- Sort the branches before calling mk_discrete_switch+    let branches_lbls' = [ (fromIntegral i, l) | (i,l) <- sortBy (comparing fst) branches_lbls ]+    let range = (fromIntegral lo_tag, fromIntegral hi_tag)++    emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range++    emitLabel join_lbl++mk_discrete_switch :: Bool -- ^ Use signed comparisons+          -> CmmExpr+          -> [(Integer, BlockId)]+          -> Maybe BlockId+          -> (Integer, Integer)+          -> CmmAGraph++-- SINGLETON TAG RANGE: no case analysis to do+mk_discrete_switch _ _tag_expr [(tag, lbl)] _ (lo_tag, hi_tag)+  | lo_tag == hi_tag+  = ASSERT( tag == lo_tag )+    mkBranch lbl++-- SINGLETON BRANCH, NO DEFAULT: no case analysis to do+mk_discrete_switch _ _tag_expr [(_tag,lbl)] Nothing _+  = mkBranch lbl+        -- The simplifier might have eliminated a case+        --       so we may have e.g. case xs of+        --                               [] -> e+        -- In that situation we can be sure the (:) case+        -- can't happen, so no need to test++-- SOMETHING MORE COMPLICATED: defer to CmmImplementSwitchPlans+-- See Note [Cmm Switches, the general plan] in CmmSwitch+mk_discrete_switch signed tag_expr branches mb_deflt range+  = mkSwitch tag_expr $ mkSwitchTargets signed range mb_deflt (M.fromList branches)++divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])+divideBranches branches = (lo_branches, mid, hi_branches)+  where+    -- 2 branches => n_branches `div` 2 = 1+    --            => branches !! 1 give the *second* tag+    -- There are always at least 2 branches here+    (mid,_) = branches !! (length branches `div` 2)+    (lo_branches, hi_branches) = span is_lo branches+    is_lo (t,_) = t < mid++--------------+emitCmmLitSwitch :: CmmExpr                    -- Tag to switch on+               -> [(Literal, CmmAGraphScoped)] -- Tagged branches+               -> CmmAGraphScoped              -- Default branch (always)+               -> FCode ()                     -- Emit the code+emitCmmLitSwitch _scrut []       deflt = emit $ fst deflt+emitCmmLitSwitch scrut  branches deflt = do+    scrut' <- assignTemp' scrut+    join_lbl <- newBlockId+    deflt_lbl <- label_code join_lbl deflt+    branches_lbls <- label_branches join_lbl branches++    dflags <- getDynFlags+    let cmm_ty = cmmExprType dflags scrut+        rep = typeWidth cmm_ty++    -- We find the necessary type information in the literals in the branches+    let signed = case head branches of+                    (LitNumber nt _ _, _) -> litNumIsSigned nt+                    _ -> False++    let range | signed    = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)+              | otherwise = (0, tARGET_MAX_WORD dflags)++    if isFloatType cmm_ty+    then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls+    else emit $ mk_discrete_switch+        signed+        scrut'+        [(litValue lit,l) | (lit,l) <- branches_lbls]+        (Just deflt_lbl)+        range+    emitLabel join_lbl++-- | lower bound (inclusive), upper bound (exclusive)+type LitBound = (Maybe Literal, Maybe Literal)++noBound :: LitBound+noBound = (Nothing, Nothing)++mk_float_switch :: Width -> CmmExpr -> BlockId+              -> LitBound+              -> [(Literal,BlockId)]+              -> FCode CmmAGraph+mk_float_switch rep scrut deflt _bounds [(lit,blk)]+  = do dflags <- getDynFlags+       return $ mkCbranch (cond dflags) deflt blk Nothing+  where+    cond dflags = CmmMachOp ne [scrut, CmmLit cmm_lit]+      where+        cmm_lit = mkSimpleLit dflags lit+        ne      = MO_F_Ne rep++mk_float_switch rep scrut deflt_blk_id (lo_bound, hi_bound) branches+  = do dflags <- getDynFlags+       lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches+       hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches+       mkCmmIfThenElse (cond dflags) lo_blk hi_blk+  where+    (lo_branches, mid_lit, hi_branches) = divideBranches branches++    bounds_lo = (lo_bound, Just mid_lit)+    bounds_hi = (Just mid_lit, hi_bound)++    cond dflags = CmmMachOp lt [scrut, CmmLit cmm_lit]+      where+        cmm_lit = mkSimpleLit dflags mid_lit+        lt      = MO_F_Lt rep+++--------------+label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)+label_default _ Nothing+  = return Nothing+label_default join_lbl (Just code)+  = do lbl <- label_code join_lbl code+       return (Just lbl)++--------------+label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]+label_branches _join_lbl []+  = return []+label_branches join_lbl ((tag,code):branches)+  = do lbl <- label_code join_lbl code+       branches' <- label_branches join_lbl branches+       return ((tag,lbl):branches')++--------------+label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId+--  label_code J code+--      generates+--  [L: code; goto J]+-- and returns L+label_code join_lbl (code,tsc) = do+    lbl <- newBlockId+    emitOutOfLine lbl (code MkGraph.<*> mkBranch join_lbl, tsc)+    return lbl++--------------+assignTemp' :: CmmExpr -> FCode CmmExpr+assignTemp' e+  | isTrivialCmmExpr e = return e+  | otherwise = do+       dflags <- getDynFlags+       lreg <- newTemp (cmmExprType dflags e)+       let reg = CmmLocal lreg+       emitAssign reg e+       return (CmmReg reg)
+ compiler/coreSyn/CoreLint.hs view
@@ -0,0 +1,2741 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998+++A ``lint'' pass to check for Core correctness+-}++{-# LANGUAGE CPP #-}++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 Kind+import Type+import RepType+import TyCoRep       -- checks validity of types/coercions+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 UniqSupply+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 [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 functin+        lintInTy :: Type -> LintM (Type, Kind)+returns a substituted type.++When we encounter a binder (like x::a) we must apply the substitution+to the type of the binding variable.  lintBinders does this.++For Ids, the type-substituted Id is added to the in_scope set (which+itself is part of the TCvSubst we are carrying down), and when we+find an occurrence of an Id, we fetch it from the in-scope set.++Note [Bad unsafe coercion]+~~~~~~~~~~~~~~~~~~~~~~~~~~+For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions+Linter introduces additional rules that checks improper coercion between+different types, called bad coercions. Following coercions are forbidden:++  (a) coercions between boxed and unboxed values;+  (b) coercions between unlifted values of the different sizes, here+      active size is checked, i.e. size of the actual value but not+      the space allocated for value;+  (c) coercions between floating and integral boxed values, this check+      is not yet supported for unboxed tuples, as no semantics were+      specified for that;+  (d) coercions from / to vector type+  (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be+      coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules+      (a-e) holds.++Note [Join points]+~~~~~~~~~~~~~~~~~~+We check the rules listed in Note [Invariants on join points] in CoreSyn. The+only one that causes any difficulty is the first: All occurrences must be tail+calls. To this end, along with the in-scope set, we remember in le_joins the+subset of in-scope Ids that are valid join ids. For example:++  join j x = ... in+  case e of+    A -> jump j y -- good+    B -> case (jump j z) of -- BAD+           C -> join h = jump j w in ... -- good+           D -> let x = jump j v in ... -- BAD++A join point remains valid in case branches, so when checking the A+branch, j is still valid. When we check the scrutinee of the inner+case, however, we set le_joins to empty, and catch the+error. Similarly, join points can occur free in RHSes of other join+points but not the RHSes of value bindings (thunks and functions).++************************************************************************+*                                                                      *+                 Beginning and ending passes+*                                                                      *+************************************************************************++These functions are not CoreM monad stuff, but they probably ought to+be, and it makes a convenient place for them.  They print out stuff+before and after core passes, and do Core Lint when necessary.+-}++endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()+endPass pass binds rules+  = do { hsc_env <- getHscEnv+       ; print_unqual <- getPrintUnqualified+       ; liftIO $ endPassIO hsc_env print_unqual pass binds rules }++endPassIO :: HscEnv -> PrintUnqualified+          -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()+-- Used by the IO-is CorePrep too+endPassIO hsc_env print_unqual pass binds rules+  = do { dumpPassResult dflags print_unqual mb_flag+                        (ppr pass) (pprPassDetails pass) binds rules+       ; lintPassResult hsc_env pass binds }+  where+    dflags  = hsc_dflags hsc_env+    mb_flag = case coreDumpFlag pass of+                Just flag | dopt flag dflags                    -> Just flag+                          | dopt Opt_D_verbose_core2core dflags -> Just flag+                _ -> Nothing++dumpIfSet :: DynFlags -> Bool -> CoreToDo -> SDoc -> SDoc -> IO ()+dumpIfSet dflags dump_me pass extra_info doc+  = Err.dumpIfSet dflags dump_me (showSDoc dflags (ppr pass <+> extra_info)) doc++dumpPassResult :: DynFlags+               -> PrintUnqualified+               -> Maybe DumpFlag        -- Just df => show details in a file whose+                                        --            name is specified by df+               -> SDoc                  -- Header+               -> SDoc                  -- Extra info to appear after header+               -> CoreProgram -> [CoreRule]+               -> IO ()+dumpPassResult dflags unqual mb_flag hdr extra_info binds rules+  = do { forM_ mb_flag $ \flag ->+           Err.dumpSDoc dflags unqual flag (showSDoc dflags hdr) dump_doc++         -- Report result size+         -- This has the side effect of forcing the intermediate to be evaluated+         -- if it's not already forced by a -ddump flag.+       ; Err.debugTraceMsg dflags 2 size_doc+       }++  where+    size_doc = sep [text "Result size of" <+> hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]++    dump_doc  = vcat [ nest 2 extra_info+                     , size_doc+                     , blankLine+                     , pprCoreBindingsWithSize binds+                     , ppUnless (null rules) pp_rules ]+    pp_rules = vcat [ blankLine+                    , text "------ Local rules for imported ids --------"+                    , pprRules rules ]++coreDumpFlag :: CoreToDo -> Maybe DumpFlag+coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_verbose_core2core+coreDumpFlag (CoreDoPluginPass {})    = Just Opt_D_verbose_core2core+coreDumpFlag CoreDoFloatInwards       = Just Opt_D_verbose_core2core+coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core+coreDumpFlag CoreLiberateCase         = Just Opt_D_verbose_core2core+coreDumpFlag CoreDoStaticArgs         = Just Opt_D_verbose_core2core+coreDumpFlag CoreDoCallArity          = Just Opt_D_dump_call_arity+coreDumpFlag CoreDoExitify            = Just Opt_D_dump_exitify+coreDumpFlag CoreDoStrictness         = Just Opt_D_dump_stranal+coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper+coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec+coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec+coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse+coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds_preopt+coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds+coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl+coreDumpFlag CorePrep                 = Just Opt_D_dump_prep+coreDumpFlag CoreOccurAnal            = Just Opt_D_dump_occur_anal++coreDumpFlag CoreDoPrintCore          = Nothing+coreDumpFlag (CoreDoRuleCheck {})     = Nothing+coreDumpFlag CoreDoNothing            = Nothing+coreDumpFlag (CoreDoPasses {})        = Nothing++{-+************************************************************************+*                                                                      *+                 Top-level interfaces+*                                                                      *+************************************************************************+-}++lintPassResult :: HscEnv -> CoreToDo -> CoreProgram -> IO ()+lintPassResult hsc_env pass binds+  | not (gopt Opt_DoCoreLinting dflags)+  = return ()+  | otherwise+  = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds+       ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)+       ; displayLintResults dflags pass warns errs binds  }+  where+    dflags = hsc_dflags hsc_env++displayLintResults :: DynFlags -> CoreToDo+                   -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram+                   -> IO ()+displayLintResults dflags pass warns errs binds+  | not (isEmptyBag errs)+  = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan+           (defaultDumpStyle dflags)+           (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs+                 , text "*** Offending Program ***"+                 , pprCoreBindings binds+                 , text "*** End of Offense ***" ])+       ; Err.ghcExit dflags 1 }++  | not (isEmptyBag warns)+  , not (hasNoDebugOutput dflags)+  , showLintWarnings pass+  -- If the Core linter encounters an error, output to stderr instead of+  -- stdout (#13342)+  = putLogMsg dflags NoReason Err.SevInfo noSrcSpan+        (defaultDumpStyle dflags)+        (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))++  | otherwise = return ()+  where++lint_banner :: String -> SDoc -> SDoc+lint_banner string pass = text "*** Core Lint"      <+> text string+                          <+> text ": in result of" <+> pass+                          <+> text "***"++showLintWarnings :: CoreToDo -> Bool+-- Disable Lint warnings on the first simplifier pass, because+-- there may be some INLINE knots still tied, which is tiresomely noisy+showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False+showLintWarnings _ = True++lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO ()+lintInteractiveExpr what hsc_env expr+  | not (gopt Opt_DoCoreLinting dflags)+  = return ()+  | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr+  = do { display_lint_err err+       ; Err.ghcExit dflags 1 }+  | otherwise+  = return ()+  where+    dflags = hsc_dflags hsc_env++    display_lint_err err+      = do { putLogMsg dflags NoReason Err.SevDump+               noSrcSpan (defaultDumpStyle dflags)+               (vcat [ lint_banner "errors" (text what)+                     , err+                     , text "*** Offending Program ***"+                     , pprCoreExpr expr+                     , text "*** End of Offense ***" ])+           ; Err.ghcExit dflags 1 }++interactiveInScope :: HscEnv -> [Var]+-- In GHCi we may lint expressions, or bindings arising from 'deriving'+-- clauses, that mention variables bound in the interactive context.+-- These are Local things (see Note [Interactively-bound Ids in GHCi] in HscTypes).+-- So we have to tell Lint about them, lest it reports them as out of scope.+--+-- We do this by find local-named things that may appear free in interactive+-- context.  This function is pretty revolting and quite possibly not quite right.+-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty+-- so this is a (cheap) no-op.+--+-- See #8215 for an example+interactiveInScope hsc_env+  = tyvars ++ ids+  where+    -- C.f. TcRnDriver.setInteractiveContext, Desugar.deSugarExpr+    ictxt                   = hsc_IC hsc_env+    (cls_insts, _fam_insts) = ic_instances ictxt+    te1    = mkTypeEnvWithImplicits (ic_tythings ictxt)+    te     = extendTypeEnvWithIds te1 (map instanceDFunId cls_insts)+    ids    = typeEnvIds te+    tyvars = tyCoVarsOfTypesList $ map idType ids+              -- Why the type variables?  How can the top level envt have free tyvars?+              -- I think it's because of the GHCi debugger, which can bind variables+              --   f :: [t] -> [t]+              -- where t is a RuntimeUnk (see TcType)++lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)+--   Returns (warnings, errors)+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintCoreBindings dflags pass local_in_scope binds+  = initL dflags flags in_scope_set $+    addLoc TopLevelBindings         $+    lintLetBndrs TopLevel binders   $+        -- Put all the top-level binders in scope at the start+        -- This is because transformation rules can bring something+        -- into use 'unexpectedly'+    do { checkL (null dups) (dupVars dups)+       ; checkL (null ext_dups) (dupExtVars ext_dups)+       ; mapM lint_bind binds }+  where+    in_scope_set = mkInScopeSet (mkVarSet local_in_scope)++    flags = defaultLintFlags+               { lf_check_global_ids = check_globals+               , lf_check_inline_loop_breakers = check_lbs+               , lf_check_static_ptrs = check_static_ptrs }++    -- See Note [Checking for global Ids]+    check_globals = case pass of+                      CoreTidy -> False+                      CorePrep -> False+                      _        -> True++    -- See Note [Checking for INLINE loop breakers]+    check_lbs = case pass of+                      CoreDesugar    -> False+                      CoreDesugarOpt -> False+                      _              -> True++    -- See Note [Checking StaticPtrs]+    check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere+                      | otherwise = case pass of+                          CoreDoFloatOutwards _ -> AllowAtTopLevel+                          CoreTidy              -> RejectEverywhere+                          CorePrep              -> AllowAtTopLevel+                          _                     -> AllowAnywhere++    binders = bindersOfBinds binds+    (_, dups) = removeDups compare binders++    -- dups_ext checks for names with different uniques+    -- but but the same External name M.n.  We don't+    -- allow this at top level:+    --    M.n{r3}  = ...+    --    M.n{r29} = ...+    -- because they both get the same linker symbol+    ext_dups = snd (removeDups ord_ext (map Var.varName binders))+    ord_ext n1 n2 | Just m1 <- nameModule_maybe n1+                  , Just m2 <- nameModule_maybe n2+                  = compare (m1, nameOccName n1) (m2, nameOccName n2)+                  | otherwise = LT++    -- If you edit this function, you may need to update the GHC formalism+    -- See Note [GHC Formalism]+    lint_bind (Rec prs)         = mapM_ (lintSingleBinding TopLevel Recursive) prs+    lint_bind (NonRec bndr rhs) = lintSingleBinding TopLevel NonRecursive (bndr,rhs)++{-+************************************************************************+*                                                                      *+\subsection[lintUnfolding]{lintUnfolding}+*                                                                      *+************************************************************************++Note [Linting Unfoldings from Interfaces]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We use this to check all top-level unfoldings that come in from interfaces+(it is very painful to catch errors otherwise).++We do not need to call lintUnfolding on unfoldings that are nested within+top-level unfoldings; they are linted when we lint the top-level unfolding;+hence the `TopLevelFlag` on `tcPragExpr` in TcIface.++-}++lintUnfolding :: DynFlags+              -> SrcLoc+              -> VarSet         -- Treat these as in scope+              -> CoreExpr+              -> Maybe MsgDoc   -- Nothing => OK++lintUnfolding dflags locn vars expr+  | isEmptyBag errs = Nothing+  | otherwise       = Just (pprMessageBag errs)+  where+    in_scope = mkInScopeSet vars+    (_warns, errs) = initL dflags defaultLintFlags in_scope linter+    linter = addLoc (ImportedUnfolding locn) $+             lintCoreExpr expr++lintExpr :: DynFlags+         -> [Var]               -- Treat these as in scope+         -> CoreExpr+         -> Maybe MsgDoc        -- Nothing => OK++lintExpr dflags vars expr+  | isEmptyBag errs = Nothing+  | otherwise       = Just (pprMessageBag errs)+  where+    in_scope = mkInScopeSet (mkVarSet vars)+    (_warns, errs) = initL dflags defaultLintFlags in_scope linter+    linter = addLoc TopLevelBindings $+             lintCoreExpr expr++{-+************************************************************************+*                                                                      *+\subsection[lintCoreBinding]{lintCoreBinding}+*                                                                      *+************************************************************************++Check a core binding, returning the list of variables bound.+-}++lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintSingleBinding top_lvl_flag rec_flag (binder,rhs)+  = addLoc (RhsOf binder) $+         -- Check the rhs+    do { ty <- lintRhs binder rhs+       ; binder_ty <- applySubstTy (idType binder)+       ; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty)++       -- If the binding is for a CoVar, the RHS should be (Coercion co)+       -- See Note [CoreSyn type and coercion invariant] in CoreSyn+       ; checkL (not (isCoVar binder) || isCoArg rhs)+                (mkLetErr binder rhs)++       -- Check that it's not levity-polymorphic+       -- Do this first, because otherwise isUnliftedType panics+       -- Annoyingly, this duplicates the test in lintIdBdr,+       -- because for non-rec lets we call lintSingleBinding first+       ; checkL (isJoinId binder || not (isTypeLevPoly binder_ty))+                (badBndrTyMsg binder (text "levity-polymorphic"))++        -- Check the let/app invariant+        -- See Note [CoreSyn let/app invariant] in CoreSyn+       ; checkL ( isJoinId binder+               || not (isUnliftedType binder_ty)+               || (isNonRec rec_flag && exprOkForSpeculation rhs)+               || exprIsTickedString rhs)+           (badBndrTyMsg binder (text "unlifted"))++        -- Check that if the binder is top-level or recursive, it's not+        -- demanded. Primitive string literals are exempt as there is no+        -- computation to perform, see Note [CoreSyn top-level string literals].+       ; checkL (not (isStrictId binder)+            || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))+            || exprIsTickedString rhs)+           (mkStrictMsg binder)++        -- Check that if the binder is at the top level and has type Addr#,+        -- that it is a string literal, see+        -- Note [CoreSyn top-level string literals].+       ; checkL (not (isTopLevel top_lvl_flag && binder_ty `eqType` addrPrimTy)+                 || exprIsTickedString rhs)+           (mkTopNonLitStrMsg binder)++       ; flags <- getLintFlags++         -- Check that a join-point binder has a valid type+         -- NB: lintIdBinder has checked that it is not top-level bound+       ; case isJoinId_maybe binder of+            Nothing    -> return ()+            Just arity ->  checkL (isValidJoinPointType arity binder_ty)+                                  (mkInvalidJoinPointMsg binder binder_ty)++       ; when (lf_check_inline_loop_breakers flags+               && isStableUnfolding (realIdUnfolding binder)+               && isStrongLoopBreaker (idOccInfo binder)+               && isInlinePragma (idInlinePragma binder))+              (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder))+              -- Only non-rule loop breakers inhibit inlining++       -- We used to check that the dmdTypeDepth of a demand signature never+       -- exceeds idArity, but that is an unnecessary complication, see+       -- Note [idArity varies independently of dmdTypeDepth] in DmdAnal++       -- Check that the binder's arity is within the bounds imposed by+       -- the type and the strictness signature. See Note [exprArity invariant]+       -- and Note [Trimming arity]+       ; checkL (typeArity (idType binder) `lengthAtLeast` idArity binder)+           (text "idArity" <+> ppr (idArity binder) <+>+           text "exceeds typeArity" <+>+           ppr (length (typeArity (idType binder))) <> colon <+>+           ppr binder)++       ; case splitStrictSig (idStrictness binder) of+           (demands, result_info) | isBotRes result_info ->+             checkL (demands `lengthAtLeast` idArity binder)+               (text "idArity" <+> ppr (idArity binder) <+>+               text "exceeds arity imposed by the strictness signature" <+>+               ppr (idStrictness binder) <> colon <+>+               ppr binder)+           _ -> return ()++       ; mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)++       ; addLoc (UnfoldingOf binder) $+         lintIdUnfolding binder binder_ty (idUnfolding binder) }++        -- We should check the unfolding, if any, but this is tricky because+        -- the unfolding is a SimplifiableCoreExpr. Give up for now.++-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr'+-- in that it doesn't reject occurrences of the function 'makeStatic' when they+-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and+-- for join points, it skips the outer lambdas that take arguments to the+-- join point.+--+-- See Note [Checking StaticPtrs].+lintRhs :: Id -> CoreExpr -> LintM OutType+lintRhs bndr rhs+    | Just arity <- isJoinId_maybe bndr+    = lint_join_lams arity arity True rhs+    | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)+    = lint_join_lams arity arity False rhs+  where+    lint_join_lams 0 _ _ rhs+      = lintCoreExpr rhs++    lint_join_lams n tot enforce (Lam var expr)+      = addLoc (LambdaBodyOf var) $+        lintBinder LambdaBind var $ \ var' ->+        do { body_ty <- lint_join_lams (n-1) tot enforce expr+           ; return $ mkLamType var' body_ty }++    lint_join_lams n tot True _other+      = failWithL $ mkBadJoinArityMsg bndr tot (tot-n) rhs+    lint_join_lams _ _ False rhs+      = markAllJoinsBad $ lintCoreExpr rhs+          -- Future join point, not yet eta-expanded+          -- Body is not a tail position++-- Allow applications of the data constructor @StaticPtr@ at the top+-- but produce errors otherwise.+lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go+  where+    -- Allow occurrences of 'makeStatic' at the top-level but produce errors+    -- otherwise.+    go AllowAtTopLevel+      | (binders0, rhs') <- collectTyBinders rhs+      , Just (fun, t, info, e) <- collectMakeStaticArgs rhs'+      = markAllJoinsBad $+        foldr+        -- imitate @lintCoreExpr (Lam ...)@+        (\var loopBinders ->+          addLoc (LambdaBodyOf var) $+            lintBinder LambdaBind var $ \var' ->+              do { body_ty <- loopBinders+                 ; return $ mkLamType var' body_ty }+        )+        -- imitate @lintCoreExpr (App ...)@+        (do fun_ty <- lintCoreExpr fun+            addLoc (AnExpr rhs') $ 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 _ _)+  = addLoc (AnExpr e) $+    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 e@(Case scrut var alt_ty alts) =+       -- Check the scrutinee+  do { let scrut_diverges = exprIsBottom scrut+     ; scrut_ty <- markAllJoinsBad $ lintCoreExpr scrut+     ; (alt_ty, _) <- lintInTy alt_ty+     ; (var_ty, _) <- 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.++     -- 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 scrut_diverges+              -> 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)++     ; lintBinder CaseBind var $ \_ ->+       do { -- Check the alternatives+            mapM_ (lintCoreAlt scrut_ty alt_ty) alts+          ; checkCaseAlts e scrut_ty alts+          ; return alt_ty } }++-- 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) $+    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 TyCoRep+        ; 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}+*                                                                      *+************************************************************************+-}++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)+     ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)++          -- 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) }++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) <- 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 TyCoRep+         ; 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]+                     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]+                     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)++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 Functor LintM where+      fmap = liftM++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+  | 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 env errs msg))++addErrL :: MsgDoc -> LintM ()+addErrL msg = LintM $ \ env (warns,errs) ->+              (Just (), (warns, addMsg env errs msg))++addWarnL :: MsgDoc -> LintM ()+addWarnL msg = LintM $ \ env (warns,errs) ->+              (Just (), (addMsg env warns msg, errs))++addMsg :: LintEnv ->  Bag MsgDoc -> MsgDoc -> Bag MsgDoc+addMsg env msgs msg+  = ASSERT( notNull locs )+    msgs `snocBag` mk_msg msg+  where+   locs = le_loc env+   (loc, cxt1) = dumpLoc (head locs)+   cxts        = [snd (dumpLoc loc) | loc <- locs]+   context     = ifPprDebug (vcat (reverse cxts) $$ cxt1 $$+                             text "Substitution:" <+> ppr (le_subst env))+                            cxt1++   mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg)++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+  | null join_ids+  = thing_inside+  | otherwise+  = LintM $ \ env errs -> unLintM thing_inside (add_joins env) errs+  where+    add_joins env = env { le_joins = le_joins env `extendVarSetList` join_ids }+    join_ids = filter isJoinId vars++getValidJoins :: LintM IdSet+getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs))++getTCvSubst :: LintM TCvSubst+getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs))++getInScope :: LintM InScopeSet+getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs))++applySubstTy :: InType -> LintM OutType+applySubstTy ty = do { subst <- getTCvSubst; return (substTy subst ty) }++applySubstCo :: InCoercion -> LintM OutCoercion+applySubstCo co = do { subst <- getTCvSubst; return (substCo subst co) }++lookupIdInScope :: Id -> LintM Id+lookupIdInScope id_occ+  = do { subst <- getTCvSubst+       ; case lookupInScope (getTCvInScope subst) id_occ of+           Just id_bnd  -> do { checkL (not (bad_global id_bnd)) global_in_scope+                              ; return id_bnd }+           Nothing -> do { checkL (not is_local) local_out_of_scope+                         ; return id_occ } }+  where+    is_local = mustHaveLocalBinding id_occ+    local_out_of_scope = text "Out of scope:" <+> pprBndr LetBind id_occ+    global_in_scope    = hang (text "Occurrence is GlobalId, but binding is LocalId")+                            2 (pprBndr LetBind id_occ)+    bad_global id_bnd = isGlobalId id_occ+                     && isLocalId id_bnd+                     && not (isWiredInName (idName id_occ))+       -- 'bad_global' checks for the case where an /occurrence/ is+       -- a GlobalId, but there is an enclosing binding fora a LocalId.+       -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr,+       --     but GHCi adds GlobalIds from the interactive context.  These+       --     are fine; hence the test (isLocalId id == isLocalId v)+       -- NB: when compiling Control.Exception.Base, things like absentError+       --     are defined locally, but appear in expressions as (global)+       --     wired-in Ids after worker/wrapper+       --     So we simply disable the test in this case++lookupJoinId :: Id -> LintM (Maybe JoinArity)+-- Look up an Id which should be a join point, valid here+-- If so, return its arity, if not return Nothing+lookupJoinId id+  = do { join_set <- getValidJoins+       ; case lookupVarSet join_set id of+            Just id' -> return (isJoinId_maybe id')+            Nothing  -> return Nothing }++lintTyCoVarInScope :: TyCoVar -> LintM ()+lintTyCoVarInScope var+  = do { subst <- getTCvSubst+       ; lintL (var `isInScope` subst)+               (pprBndr LetBind var <+> 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, brackets (text "RHS of" <+> pp_binders [v]))++dumpLoc (LambdaBodyOf b)+  = (getSrcLoc b, brackets (text "in body of lambda with binder" <+> pp_binder b))++dumpLoc (UnfoldingOf b)+  = (getSrcLoc b, brackets (text "in the unfolding of" <+> pp_binder b))++dumpLoc (BodyOfLetRec [])+  = (noSrcLoc, brackets (text "In body of a letrec with no binders"))++dumpLoc (BodyOfLetRec bs@(_:_))+  = ( getSrcLoc (head bs), brackets (text "in 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 (ImportedUnfolding locn)+  = (locn, brackets (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 =+        liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>+                                getUniqueSupplyM <*> 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/coreSyn/CorePrep.hs view
@@ -0,0 +1,1728 @@+{-+(c) The University of Glasgow, 1994-2006+++Core pass to saturate constructors and PrimOps+-}++{-# LANGUAGE BangPatterns, CPP, MultiWayIf #-}++module CorePrep (+      corePrepPgm, corePrepExpr, cvtLitInteger, cvtLitNatural,+      lookupMkIntegerName, lookupIntegerSDataConName,+      lookupMkNaturalName, lookupNaturalSDataConName+  ) where++#include "HsVersions.h"++import GhcPrelude++import OccurAnal++import HscTypes+import PrelNames+import MkId             ( realWorldPrimId )+import CoreUtils+import CoreArity+import CoreFVs+import CoreMonad        ( CoreToDo(..) )+import CoreLint         ( endPassIO )+import CoreSyn+import CoreSubst+import MkCore hiding( FloatBind(..) )   -- We use our own FloatBind here+import Type+import Literal+import Coercion+import TcEnv+import TyCon+import Demand+import Var+import VarSet+import VarEnv+import Id+import IdInfo+import TysWiredIn+import DataCon+import BasicTypes+import Module+import UniqSupply+import Maybes+import OrdList+import ErrUtils+import DynFlags+import Util+import Pair+import Outputable+import Platform+import FastString+import Name             ( NamedThing(..), nameSrcSpan )+import SrcLoc           ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )+import Data.Bits+import MonadUtils       ( mapAccumLM )+import Data.List        ( mapAccumL )+import Control.Monad+import CostCentre       ( CostCentre, ccFromThisModule )+import qualified Data.Set as S++{-+-- ---------------------------------------------------------------------------+-- Note [CorePrep Overview]+-- ---------------------------------------------------------------------------++The goal of this pass is to prepare for code generation.++1.  Saturate constructor and primop applications.++2.  Convert to A-normal form; that is, function arguments+    are always variables.++    * Use case for strict arguments:+        f E ==> case E of x -> f x+        (where f is strict)++    * Use let for non-trivial lazy arguments+        f E ==> let x = E in f x+        (were f is lazy and x is non-trivial)++3.  Similarly, convert any unboxed lets into cases.+    [I'm experimenting with leaving 'ok-for-speculation'+     rhss in let-form right up to this point.]++4.  Ensure that *value* lambdas only occur as the RHS of a binding+    (The code generator can't deal with anything else.)+    Type lambdas are ok, however, because the code gen discards them.++5.  [Not any more; nuked Jun 2002] Do the seq/par munging.++6.  Clone all local Ids.+    This means that all such Ids are unique, rather than the+    weaker guarantee of no clashes which the simplifier provides.+    And that is what the code generator needs.++    We don't clone TyVars or CoVars. The code gen doesn't need that,+    and doing so would be tiresome because then we'd need+    to substitute in types and coercions.++7.  Give each dynamic CCall occurrence a fresh unique; this is+    rather like the cloning step above.++8.  Inject bindings for the "implicit" Ids:+        * Constructor wrappers+        * Constructor workers+    We want curried definitions for all of these in case they+    aren't inlined by some caller.++9.  Replace (lazy e) by e.  See Note [lazyId magic] in MkId.hs+    Also replace (noinline e) by e.++10. Convert (LitInteger i t) into the core representation+    for the Integer i. Normally this uses mkInteger, but if+    we are using the integer-gmp implementation then there is a+    special case where we use the S# constructor for Integers that+    are in the range of Int.++11. Same for LitNatural.++12. Uphold tick consistency while doing this: We move ticks out of+    (non-type) applications where we can, and make sure that we+    annotate according to scoping rules when floating.++13. Collect cost centres (including cost centres in unfoldings) if we're in+    profiling mode. We have to do this here beucase we won't have unfoldings+    after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules].++This is all done modulo type applications and abstractions, so that+when type erasure is done for conversion to STG, we don't end up with+any trivial or useless bindings.+++Note [CorePrep invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is the syntax of the Core produced by CorePrep:++    Trivial expressions+       arg ::= lit |  var+              | arg ty  |  /\a. arg+              | truv co  |  /\c. arg  |  arg |> co++    Applications+       app ::= lit  |  var  |  app arg  |  app ty  | app co | app |> co++    Expressions+       body ::= app+              | let(rec) x = rhs in body     -- Boxed only+              | case body of pat -> body+              | /\a. body | /\c. body+              | body |> co++    Right hand sides (only place where value lambdas can occur)+       rhs ::= /\a.rhs  |  \x.rhs  |  body++We define a synonym for each of these non-terminals.  Functions+with the corresponding name produce a result in that syntax.+-}++type CpeArg  = CoreExpr    -- Non-terminal 'arg'+type CpeApp  = CoreExpr    -- Non-terminal 'app'+type CpeBody = CoreExpr    -- Non-terminal 'body'+type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'++{-+************************************************************************+*                                                                      *+                Top level stuff+*                                                                      *+************************************************************************+-}++corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]+            -> IO (CoreProgram, S.Set CostCentre)+corePrepPgm hsc_env this_mod mod_loc binds data_tycons =+    withTiming (pure dflags)+               (text "CorePrep"<+>brackets (ppr this_mod))+               (const ()) $ do+    us <- mkSplitUniqSupply 's'+    initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env++    let cost_centres+          | WayProf `elem` ways dflags+          = collectCostCentres this_mod binds+          | otherwise+          = S.empty++        implicit_binds = mkDataConWorkers dflags mod_loc data_tycons+            -- NB: we must feed mkImplicitBinds through corePrep too+            -- so that they are suitably cloned and eta-expanded++        binds_out = initUs_ us $ do+                      floats1 <- corePrepTopBinds initialCorePrepEnv binds+                      floats2 <- corePrepTopBinds initialCorePrepEnv implicit_binds+                      return (deFloatTop (floats1 `appendFloats` floats2))++    endPassIO hsc_env alwaysQualify CorePrep binds_out []+    return (binds_out, cost_centres)+  where+    dflags = hsc_dflags hsc_env++corePrepExpr :: DynFlags -> HscEnv -> CoreExpr -> IO CoreExpr+corePrepExpr dflags hsc_env expr =+    withTiming (pure dflags) (text "CorePrep [expr]") (const ()) $ do+    us <- mkSplitUniqSupply 's'+    initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env+    let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)+    dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr)+    return new_expr++corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats+-- Note [Floating out of top level bindings]+corePrepTopBinds initialCorePrepEnv binds+  = go initialCorePrepEnv binds+  where+    go _   []             = return emptyFloats+    go env (bind : binds) = do (env', floats, maybe_new_bind)+                                 <- cpeBind TopLevel env bind+                               MASSERT(isNothing maybe_new_bind)+                                 -- Only join points get returned this way by+                                 -- cpeBind, and no join point may float to top+                               floatss <- go env' binds+                               return (floats `appendFloats` floatss)++mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]+-- See Note [Data constructor workers]+-- c.f. Note [Injecting implicit bindings] in TidyPgm+mkDataConWorkers dflags mod_loc data_tycons+  = [ NonRec id (tick_it (getName data_con) (Var id))+                                -- The ice is thin here, but it works+    | tycon <- data_tycons,     -- CorePrep will eta-expand it+      data_con <- tyConDataCons tycon,+      let id = dataConWorkId data_con+    ]+ where+   -- If we want to generate debug info, we put a source note on the+   -- worker. This is useful, especially for heap profiling.+   tick_it name+     | debugLevel dflags == 0                = id+     | RealSrcSpan span <- nameSrcSpan name  = tick span+     | Just file <- ml_hs_file mod_loc       = tick (span1 file)+     | otherwise                             = tick (span1 "???")+     where tick span  = Tick (SourceNote span $ showSDoc dflags (ppr name))+           span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1++{-+Note [Floating out of top level bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: we do need to float out of top-level bindings+Consider        x = length [True,False]+We want to get+                s1 = False : []+                s2 = True  : s1+                x  = length s2++We return a *list* of bindings, because we may start with+        x* = f (g y)+where x is demanded, in which case we want to finish with+        a = g y+        x* = f a+And then x will actually end up case-bound++Note [CafInfo and floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+What happens when we try to float bindings to the top level?  At this+point all the CafInfo is supposed to be correct, and we must make certain+that is true of the new top-level bindings.  There are two cases+to consider++a) The top-level binding is marked asCafRefs.  In that case we are+   basically fine.  The floated bindings had better all be lazy lets,+   so they can float to top level, but they'll all have HasCafRefs+   (the default) which is safe.++b) The top-level binding is marked NoCafRefs.  This really happens+   Example.  CoreTidy produces+      $fApplicativeSTM [NoCafRefs] = D:Alternative retry# ...blah...+   Now CorePrep has to eta-expand to+      $fApplicativeSTM = let sat = \xy. retry x y+                         in D:Alternative sat ...blah...+   So what we *want* is+      sat [NoCafRefs] = \xy. retry x y+      $fApplicativeSTM [NoCafRefs] = D:Alternative sat ...blah...++   So, gruesomely, we must set the NoCafRefs flag on the sat bindings,+   *and* substitute the modified 'sat' into the old RHS.++   It should be the case that 'sat' is itself [NoCafRefs] (a value, no+   cafs) else the original top-level binding would not itself have been+   marked [NoCafRefs].  The DEBUG check in CoreToStg for+   consistentCafInfo will find this.++This is all very gruesome and horrible. It would be better to figure+out CafInfo later, after CorePrep.  We'll do that in due course.+Meanwhile this horrible hack works.++Note [Join points and floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Join points can float out of other join points but not out of value bindings:++  let z =+    let  w = ... in -- can float+    join k = ... in -- can't float+    ... jump k ...+  join j x1 ... xn =+    let  y = ... in -- can float (but don't want to)+    join h = ... in -- can float (but not much point)+    ... jump h ...+  in ...++Here, the jump to h remains valid if h is floated outward, but the jump to k+does not.++We don't float *out* of join points. It would only be safe to float out of+nullary join points (or ones where the arguments are all either type arguments+or dead binders). Nullary join points aren't ever recursive, so they're always+effectively one-shot functions, which we don't float out of. We *could* float+join points from nullary join points, but there's no clear benefit at this+stage.++Note [Data constructor workers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Create any necessary "implicit" bindings for data con workers.  We+create the rather strange (non-recursive!) binding++        $wC = \x y -> $wC x y++i.e. a curried constructor that allocates.  This means that we can+treat the worker for a constructor like any other function in the rest+of the compiler.  The point here is that CoreToStg will generate a+StgConApp for the RHS, rather than a call to the worker (which would+give a loop).  As Lennart says: the ice is thin here, but it works.++Hmm.  Should we create bindings for dictionary constructors?  They are+always fully applied, and the bindings are just there to support+partial applications. But it's easier to let them through.+++Note [Dead code in CorePrep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Imagine that we got an input program like this (see #4962):++  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)+  f x = (g True (Just x) + g () (Just x), g)+    where+      g :: Show a => a -> Maybe Int -> Int+      g _ Nothing = x+      g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown++After specialisation and SpecConstr, we would get something like this:++  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)+  f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)+    where+      {-# RULES g $dBool = g$Bool+                g $dUnit = g$Unit #-}+      g = ...+      {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}+      g$Bool = ...+      {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}+      g$Unit = ...+      g$Bool_True_Just = ...+      g$Unit_Unit_Just = ...++Note that the g$Bool and g$Unit functions are actually dead code: they+are only kept alive by the occurrence analyser because they are+referred to by the rules of g, which is being kept alive by the fact+that it is used (unspecialised) in the returned pair.++However, at the CorePrep stage there is no way that the rules for g+will ever fire, and it really seems like a shame to produce an output+program that goes to the trouble of allocating a closure for the+unreachable g$Bool and g$Unit functions.++The way we fix this is to:+ * In cloneBndr, drop all unfoldings/rules++ * In deFloatTop, run a simple dead code analyser on each top-level+   RHS to drop the dead local bindings. For that call to OccAnal, we+   disable the binder swap, else the occurrence analyser sometimes+   introduces new let bindings for cased binders, which lead to the bug+   in #5433.++The reason we don't just OccAnal the whole output of CorePrep is that+the tidier ensures that all top-level binders are GlobalIds, so they+don't show up in the free variables any longer. So if you run the+occurrence analyser on the output of CoreTidy (or later) you e.g. turn+this program:++  Rec {+  f = ... f ...+  }++Into this one:++  f = ... f ...++(Since f is not considered to be free in its own RHS.)+++************************************************************************+*                                                                      *+                The main code+*                                                                      *+************************************************************************+-}++cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind+        -> UniqSM (CorePrepEnv,+                   Floats,         -- Floating value bindings+                   Maybe CoreBind) -- Just bind' <=> returned new bind; no float+                                   -- Nothing <=> added bind' to floats instead+cpeBind top_lvl env (NonRec bndr rhs)+  | not (isJoinId bndr)+  = do { (_, bndr1) <- cpCloneBndr env bndr+       ; let dmd         = idDemandInfo bndr+             is_unlifted = isUnliftedType (idType bndr)+       ; (floats, rhs1) <- cpePair top_lvl NonRecursive+                                   dmd is_unlifted+                                   env bndr1 rhs+       -- See Note [Inlining in CorePrep]+       ; if exprIsTrivial rhs1 && isNotTopLevel top_lvl+            then return (extendCorePrepEnvExpr env bndr rhs1, floats, Nothing)+            else do {++       ; let new_float = mkFloat dmd is_unlifted bndr1 rhs1++       ; return (extendCorePrepEnv env bndr bndr1,+                 addFloat floats new_float,+                 Nothing) }}++  | otherwise -- A join point; see Note [Join points and floating]+  = ASSERT(not (isTopLevel top_lvl)) -- can't have top-level join point+    do { (_, bndr1) <- cpCloneBndr env bndr+       ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs+       ; return (extendCorePrepEnv env bndr bndr2,+                 emptyFloats,+                 Just (NonRec bndr2 rhs1)) }++cpeBind top_lvl env (Rec pairs)+  | not (isJoinId (head bndrs))+  = do { (env', bndrs1) <- cpCloneBndrs env bndrs+       ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env')+                           bndrs1 rhss++       ; let (floats_s, rhss1) = unzip stuff+             all_pairs = foldrOL add_float (bndrs1 `zip` rhss1)+                                           (concatFloats floats_s)++       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),+                 unitFloat (FloatLet (Rec all_pairs)),+                 Nothing) }++  | otherwise -- See Note [Join points and floating]+  = do { (env', bndrs1) <- cpCloneBndrs env bndrs+       ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss++       ; let bndrs2 = map fst pairs1+       ; return (extendCorePrepEnvList env' (bndrs `zip` bndrs2),+                 emptyFloats,+                 Just (Rec pairs1)) }+  where+    (bndrs, rhss) = unzip pairs++        -- Flatten all the floats, and the current+        -- group into a single giant Rec+    add_float (FloatLet (NonRec b r)) prs2 = (b,r) : prs2+    add_float (FloatLet (Rec prs1))   prs2 = prs1 ++ prs2+    add_float b                       _    = pprPanic "cpeBind" (ppr b)++---------------+cpePair :: TopLevelFlag -> RecFlag -> Demand -> Bool+        -> CorePrepEnv -> OutId -> CoreExpr+        -> UniqSM (Floats, CpeRhs)+-- Used for all bindings+-- The binder is already cloned, hence an OutId+cpePair top_lvl is_rec dmd is_unlifted env bndr rhs+  = ASSERT(not (isJoinId bndr)) -- those should use cpeJoinPair+    do { (floats1, rhs1) <- cpeRhsE env rhs++       -- See if we are allowed to float this stuff out of the RHS+       ; (floats2, rhs2) <- float_from_rhs floats1 rhs1++       -- Make the arity match up+       ; (floats3, rhs3)+            <- if manifestArity rhs1 <= arity+               then return (floats2, cpeEtaExpand arity rhs2)+               else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)+                               -- Note [Silly extra arguments]+                    (do { v <- newVar (idType bndr)+                        ; let float = mkFloat topDmd False v rhs2+                        ; return ( addFloat floats2 float+                                 , cpeEtaExpand arity (Var v)) })++        -- Wrap floating ticks+       ; let (floats4, rhs4) = wrapTicks floats3 rhs3++       ; return (floats4, rhs4) }+  where+    platform = targetPlatform (cpe_dynFlags env)++    arity = idArity bndr        -- We must match this arity++    ---------------------+    float_from_rhs floats rhs+      | isEmptyFloats floats = return (emptyFloats, rhs)+      | isTopLevel top_lvl   = float_top    floats rhs+      | otherwise            = float_nested floats rhs++    ---------------------+    float_nested floats rhs+      | wantFloatNested is_rec dmd is_unlifted floats rhs+                  = return (floats, rhs)+      | otherwise = dontFloat floats rhs++    ---------------------+    float_top floats rhs        -- Urhgh!  See Note [CafInfo and floating]+      | mayHaveCafRefs (idCafInfo bndr)+      , allLazyTop floats+      = return (floats, rhs)++      -- So the top-level binding is marked NoCafRefs+      | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs+      = return (floats', rhs')++      | otherwise+      = dontFloat floats rhs++dontFloat :: Floats -> CpeRhs -> UniqSM (Floats, CpeBody)+-- Non-empty floats, but do not want to float from rhs+-- So wrap the rhs in the floats+-- But: rhs1 might have lambdas, and we can't+--      put them inside a wrapBinds+dontFloat floats1 rhs+  = do { (floats2, body) <- rhsToBody rhs+        ; return (emptyFloats, wrapBinds floats1 $+                               wrapBinds floats2 body) }++{- Note [Silly extra arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we had this+        f{arity=1} = \x\y. e+We *must* match the arity on the Id, so we have to generate+        f' = \x\y. e+        f  = \x. f' x++It's a bizarre case: why is the arity on the Id wrong?  Reason+(in the days of __inline_me__):+        f{arity=0} = __inline_me__ (let v = expensive in \xy. e)+When InlineMe notes go away this won't happen any more.  But+it seems good for CorePrep to be robust.+-}++---------------+cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr+            -> UniqSM (JoinId, CpeRhs)+-- Used for all join bindings+cpeJoinPair env bndr rhs+  = ASSERT(isJoinId bndr)+    do { let Just join_arity = isJoinId_maybe bndr+             (bndrs, body)   = collectNBinders join_arity rhs++       ; (env', bndrs') <- cpCloneBndrs env bndrs++       ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts+                                      -- with a lambda++       ; let rhs'  = mkCoreLams bndrs' body'+             bndr' = bndr `setIdUnfolding` evaldUnfolding+                          `setIdArity` count isId bndrs+                            -- See Note [Arity and join points]++       ; return (bndr', rhs') }++{-+Note [Arity and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Up to now, we've allowed a join point to have an arity greater than its join+arity (minus type arguments), since this is what's useful for eta expansion.+However, for code gen purposes, its arity must be exactly the number of value+arguments it will be called with, and it must have exactly that many value+lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS:++  join j x y z = \w -> ... in ...+    =>+  join j x y z = (let f = \w -> ... in f) in ...++This is also what happens with Note [Silly extra arguments]. Note that it's okay+for us to mess with the arity because a join point is never exported.+-}++-- ---------------------------------------------------------------------------+--              CpeRhs: produces a result satisfying CpeRhs+-- ---------------------------------------------------------------------------++cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)+-- If+--      e  ===>  (bs, e')+-- then+--      e = let bs in e'        (semantically, that is!)+--+-- For example+--      f (g x)   ===>   ([v = g x], f v)++cpeRhsE _env expr@(Type {})      = return (emptyFloats, expr)+cpeRhsE _env expr@(Coercion {})  = return (emptyFloats, expr)+cpeRhsE env (Lit (LitNumber LitNumInteger i _))+    = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)+                   (cpe_integerSDataCon env) i)+cpeRhsE env (Lit (LitNumber LitNumNatural i _))+    = cpeRhsE env (cvtLitNatural (cpe_dynFlags env) (getMkNaturalId env)+                   (cpe_naturalSDataCon env) i)+cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)+cpeRhsE env expr@(Var {})  = cpeApp env expr+cpeRhsE env expr@(App {}) = cpeApp env expr++cpeRhsE env (Let bind body)+  = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind+       ; (body_floats, body') <- cpeRhsE env' body+       ; let expr' = case maybe_bind' of Just bind' -> Let bind' body'+                                         Nothing    -> body'+       ; return (bind_floats `appendFloats` body_floats, expr') }++cpeRhsE env (Tick tickish expr)+  | tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope+  = do { (floats, body) <- cpeRhsE env expr+         -- See [Floating Ticks in CorePrep]+       ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }+  | otherwise+  = do { body <- cpeBodyNF env expr+       ; return (emptyFloats, mkTick tickish' body) }+  where+    tickish' | Breakpoint n fvs <- tickish+             -- See also 'substTickish'+             = Breakpoint n (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)+             | otherwise+             = tickish++cpeRhsE env (Cast expr co)+   = do { (floats, expr') <- cpeRhsE env expr+        ; return (floats, Cast expr' co) }++cpeRhsE env expr@(Lam {})+   = do { let (bndrs,body) = collectBinders expr+        ; (env', bndrs') <- cpCloneBndrs env bndrs+        ; body' <- cpeBodyNF env' body+        ; return (emptyFloats, mkLams bndrs' body') }++cpeRhsE env (Case scrut bndr ty alts)+  = do { (floats, scrut') <- cpeBody env scrut+       ; (env', bndr2) <- cpCloneBndr env bndr+       ; let alts'+                 -- This flag is intended to aid in debugging strictness+                 -- analysis bugs. These are particularly nasty to chase down as+                 -- they may manifest as segmentation faults. When this flag is+                 -- enabled we instead produce an 'error' expression to catch+                 -- the case where a function we think should bottom+                 -- unexpectedly returns.+               | gopt Opt_CatchBottoms (cpe_dynFlags env)+               , not (altsAreExhaustive alts)+               = addDefault alts (Just err)+               | otherwise = alts+               where err = mkRuntimeErrorApp rUNTIME_ERROR_ID ty+                                             "Bottoming expression returned"+       ; alts'' <- mapM (sat_alt env') alts'+       ; return (floats, Case scrut' bndr2 ty alts'') }+  where+    sat_alt env (con, bs, rhs)+       = do { (env2, bs') <- cpCloneBndrs env bs+            ; rhs' <- cpeBodyNF env2 rhs+            ; return (con, bs', rhs') }++cvtLitInteger :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr+-- Here we convert a literal Integer to the low-level+-- representation. Exactly how we do this depends on the+-- library that implements Integer.  If it's GMP we+-- use the S# data constructor for small literals.+-- See Note [Integer literals] in Literal+cvtLitInteger dflags _ (Just sdatacon) i+  | inIntRange dflags i -- Special case for small integers+    = mkConApp sdatacon [Lit (mkLitInt dflags i)]++cvtLitInteger dflags mk_integer _ i+    = mkApps (Var mk_integer) [isNonNegative, ints]+  where isNonNegative = if i < 0 then mkConApp falseDataCon []+                                 else mkConApp trueDataCon  []+        ints = mkListExpr intTy (f (abs i))+        f 0 = []+        f x = let low  = x .&. mask+                  high = x `shiftR` bits+              in mkConApp intDataCon [Lit (mkLitInt dflags low)] : f high+        bits = 31+        mask = 2 ^ bits - 1++cvtLitNatural :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr+-- Here we convert a literal Natural to the low-level+-- representation.+-- See Note [Natural literals] in Literal+cvtLitNatural dflags _ (Just sdatacon) i+  | inWordRange dflags i -- Special case for small naturals+    = mkConApp sdatacon [Lit (mkLitWord dflags i)]++cvtLitNatural dflags mk_natural _ i+    = mkApps (Var mk_natural) [words]+  where words = mkListExpr wordTy (f i)+        f 0 = []+        f x = let low  = x .&. mask+                  high = x `shiftR` bits+              in mkConApp wordDataCon [Lit (mkLitWord dflags low)] : f high+        bits = 32+        mask = 2 ^ bits - 1++-- ---------------------------------------------------------------------------+--              CpeBody: produces a result satisfying CpeBody+-- ---------------------------------------------------------------------------++-- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without+-- producing any floats (any generated floats are immediately+-- let-bound using 'wrapBinds').  Generally you want this, esp.+-- when you've reached a binding form (e.g., a lambda) and+-- floating any further would be incorrect.+cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody+cpeBodyNF env expr+  = do { (floats, body) <- cpeBody env expr+       ; return (wrapBinds floats body) }++-- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce+-- a list of 'Floats' which are being propagated upwards.  In+-- fact, this function is used in only two cases: to+-- implement 'cpeBodyNF' (which is what you usually want),+-- and in the case when a let-binding is in a case scrutinee--here,+-- we can always float out:+--+--      case (let x = y in z) of ...+--      ==> let x = y in case z of ...+--+cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)+cpeBody env expr+  = do { (floats1, rhs) <- cpeRhsE env expr+       ; (floats2, body) <- rhsToBody rhs+       ; return (floats1 `appendFloats` floats2, body) }++--------+rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)+-- Remove top level lambdas by let-binding++rhsToBody (Tick t expr)+  | tickishScoped t == NoScope  -- only float out of non-scoped annotations+  = do { (floats, expr') <- rhsToBody expr+       ; return (floats, mkTick t expr') }++rhsToBody (Cast e co)+        -- You can get things like+        --      case e of { p -> coerce t (\s -> ...) }+  = do { (floats, e') <- rhsToBody e+       ; return (floats, Cast e' co) }++rhsToBody expr@(Lam {})+  | Just no_lam_result <- tryEtaReducePrep bndrs body+  = return (emptyFloats, no_lam_result)+  | all isTyVar bndrs           -- Type lambdas are ok+  = return (emptyFloats, expr)+  | otherwise                   -- Some value lambdas+  = do { fn <- newVar (exprType expr)+       ; let rhs   = cpeEtaExpand (exprArity expr) expr+             float = FloatLet (NonRec fn rhs)+       ; return (unitFloat float, Var fn) }+  where+    (bndrs,body) = collectBinders expr++rhsToBody expr = return (emptyFloats, expr)++++-- ---------------------------------------------------------------------------+--              CpeApp: produces a result satisfying CpeApp+-- ---------------------------------------------------------------------------++data ArgInfo = CpeApp  CoreArg+             | CpeCast Coercion+             | CpeTick (Tickish Id)++{- Note [runRW arg]+~~~~~~~~~~~~~~~~~~~+If we got, say+   runRW# (case bot of {})+which happened in #11291, we do /not/ want to turn it into+   (case bot of {}) realWorldPrimId#+because that gives a panic in CoreToStg.myCollectArgs, which expects+only variables in function position.  But if we are sure to make+runRW# strict (which we do in MkId), this can't happen+-}++cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)+-- May return a CpeRhs because of saturating primops+cpeApp top_env expr+  = do { let (terminal, args, depth) = collect_args expr+       ; cpe_app top_env terminal args depth+       }++  where+    -- We have a nested data structure of the form+    -- e `App` a1 `App` a2 ... `App` an, convert it into+    -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth)+    -- We use 'ArgInfo' because we may also need to+    -- record casts and ticks.  Depth counts the number+    -- of arguments that would consume strictness information+    -- (so, no type or coercion arguments.)+    collect_args :: CoreExpr -> (CoreExpr, [ArgInfo], Int)+    collect_args e = go e [] 0+      where+        go (App fun arg)      as !depth+            = go fun (CpeApp arg : as)+                (if isTyCoArg arg then depth else depth + 1)+        go (Cast fun co)      as depth+            = go fun (CpeCast co : as) depth+        go (Tick tickish fun) as depth+            | tickishPlace tickish == PlaceNonLam+            && tickish `tickishScopesLike` SoftScope+            = go fun (CpeTick tickish : as) depth+        go terminal as depth = (terminal, as, depth)++    cpe_app :: CorePrepEnv+            -> CoreExpr+            -> [ArgInfo]+            -> Int+            -> UniqSM (Floats, CpeRhs)+    cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args) depth+        | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and+       || f `hasKey` noinlineIdKey      -- Replace (noinline a) with a+        -- Consider the code:+        --+        --      lazy (f x) y+        --+        -- We need to make sure that we need to recursively collect arguments on+        -- "f x", otherwise we'll float "f x" out (it's not a variable) and+        -- end up with this awful -ddump-prep:+        --+        --      case f x of f_x {+        --        __DEFAULT -> f_x y+        --      }+        --+        -- rather than the far superior "f x y".  Test case is par01.+        = let (terminal, args', depth') = collect_args arg+          in cpe_app env terminal (args' ++ args) (depth + depth' - 1)+    cpe_app env (Var f) [CpeApp _runtimeRep@Type{}, CpeApp _type@Type{}, CpeApp arg] 1+        | f `hasKey` runRWKey+        -- See Note [runRW magic]+        -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this+        -- is why we return a CorePrepEnv as well)+        = case arg of+            Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body [] 0+            _          -> cpe_app env arg [CpeApp (Var realWorldPrimId)] 1+    cpe_app env (Var v) args depth+      = do { v1 <- fiddleCCall v+           ; let e2 = lookupCorePrepEnv env v1+                 hd = getIdFromTrivialExpr_maybe e2+           -- NB: depth from collect_args is right, because e2 is a trivial expression+           -- and thus its embedded Id *must* be at the same depth as any+           -- Apps it is under are type applications only (c.f.+           -- exprIsTrivial).  But note that we need the type of the+           -- expression, not the id.+           ; (app, floats) <- rebuild_app args e2 (exprType e2) emptyFloats stricts+           ; mb_saturate hd app floats depth }+        where+          stricts = case idStrictness v of+                            StrictSig (DmdType _ demands _)+                              | listLengthCmp demands depth /= GT -> demands+                                    -- length demands <= depth+                              | otherwise                         -> []+                -- If depth < length demands, then we have too few args to+                -- satisfy strictness  info so we have to  ignore all the+                -- strictness info, e.g. + (error "urk")+                -- Here, we can't evaluate the arg strictly, because this+                -- partial application might be seq'd++        -- We inlined into something that's not a var and has no args.+        -- Bounce it back up to cpeRhsE.+    cpe_app env fun [] _ = cpeRhsE env fun++        -- N-variable fun, better let-bind it+    cpe_app env fun args depth+      = do { (fun_floats, fun') <- cpeArg env evalDmd fun ty+                          -- The evalDmd says that it's sure to be evaluated,+                          -- so we'll end up case-binding it+           ; (app, floats) <- rebuild_app args fun' ty fun_floats []+           ; mb_saturate Nothing app floats depth }+        where+          ty = exprType fun++    -- Saturate if necessary+    mb_saturate head app floats depth =+       case head of+         Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth+                          ; return (floats, sat_app) }+         _other              -> return (floats, app)++    -- Deconstruct and rebuild the application, floating any non-atomic+    -- arguments to the outside.  We collect the type of the expression,+    -- the head of the application, and the number of actual value arguments,+    -- all of which are used to possibly saturate this application if it+    -- has a constructor or primop at the head.+    rebuild_app+        :: [ArgInfo]                  -- The arguments (inner to outer)+        -> CpeApp+        -> Type+        -> Floats+        -> [Demand]+        -> UniqSM (CpeApp, Floats)+    rebuild_app [] app _ floats ss = do+      MASSERT(null ss) -- make sure we used all the strictness info+      return (app, floats)+    rebuild_app (a : as) fun' fun_ty floats ss = case a of+      CpeApp arg@(Type arg_ty) ->+        rebuild_app as (App fun' arg) (piResultTy fun_ty arg_ty) floats ss+      CpeApp arg@(Coercion {}) ->+        rebuild_app as (App fun' arg) (funResultTy fun_ty) floats ss+      CpeApp arg -> do+        let (ss1, ss_rest)  -- See Note [lazyId magic] in MkId+               = case (ss, isLazyExpr arg) of+                   (_   : ss_rest, True)  -> (topDmd, ss_rest)+                   (ss1 : ss_rest, False) -> (ss1,    ss_rest)+                   ([],            _)     -> (topDmd, [])+            (arg_ty, res_ty) = expectJust "cpeBody:collect_args" $+                               splitFunTy_maybe fun_ty+        (fs, arg') <- cpeArg top_env ss1 arg arg_ty+        rebuild_app as (App fun' arg') res_ty (fs `appendFloats` floats) ss_rest+      CpeCast co ->+        let Pair _ty1 ty2 = coercionKind co+        in rebuild_app as (Cast fun' co) ty2 floats ss+      CpeTick tickish ->+        -- See [Floating Ticks in CorePrep]+        rebuild_app as fun' fun_ty (addFloat floats (FloatTick tickish)) ss++isLazyExpr :: CoreExpr -> Bool+-- See Note [lazyId magic] in MkId+isLazyExpr (Cast e _)              = isLazyExpr e+isLazyExpr (Tick _ e)              = isLazyExpr e+isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey+isLazyExpr _                       = False++{- Note [runRW magic]+~~~~~~~~~~~~~~~~~~~~~+Some definitions, for instance @runST@, must have careful control over float out+of the bindings in their body. Consider this use of @runST@,++    f x = runST ( \ s -> let (a, s')  = newArray# 100 [] s+                             (_, s'') = fill_in_array_or_something a x s'+                         in freezeArray# a s'' )++If we inline @runST@, we'll get:++    f x = let (a, s')  = newArray# 100 [] realWorld#{-NB-}+              (_, s'') = fill_in_array_or_something a x s'+          in freezeArray# a s''++And now if we allow the @newArray#@ binding to float out to become a CAF,+we end up with a result that is totally and utterly wrong:++    f = let (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!+        in \ x ->+            let (_, s'') = fill_in_array_or_something a x s'+            in freezeArray# a s''++All calls to @f@ will share a {\em single} array! Clearly this is nonsense and+must be prevented.++This is what @runRW#@ gives us: by being inlined extremely late in the+optimization (right before lowering to STG, in CorePrep), we can ensure that+no further floating will occur. This allows us to safely inline things like+@runST@, which are otherwise needlessly expensive (see #10678 and #5916).++'runRW' is defined (for historical reasons) in GHC.Magic, with a NOINLINE+pragma.  It is levity-polymorphic.++    runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r)+           => (State# RealWorld -> (# State# RealWorld, o #))+                              -> (# State# RealWorld, o #)++It needs no special treatment in GHC except this special inlining here+in CorePrep (and in ByteCodeGen).++-- ---------------------------------------------------------------------------+--      CpeArg: produces a result satisfying CpeArg+-- ---------------------------------------------------------------------------++Note [ANF-ising literal string arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Consider a program like,++    data Foo = Foo Addr#++    foo = Foo "turtle"#++When we go to ANFise this we might think that we want to float the string+literal like we do any other non-trivial argument. This would look like,++    foo = u\ [] case "turtle"# of s { __DEFAULT__ -> Foo s }++However, this 1) isn't necessary since strings are in a sense "trivial"; and 2)+wreaks havoc on the CAF annotations that we produce here since we the result+above is caffy since it is updateable. Ideally at some point in the future we+would like to just float the literal to the top level as suggested in #11312,++    s = "turtle"#+    foo = Foo s++However, until then we simply add a special case excluding literals from the+floating done by cpeArg.+-}++-- | Is an argument okay to CPE?+okCpeArg :: CoreExpr -> Bool+-- Don't float literals. See Note [ANF-ising literal string arguments].+okCpeArg (Lit _) = False+-- Do not eta expand a trivial argument+okCpeArg expr    = not (exprIsTrivial expr)++-- This is where we arrange that a non-trivial argument is let-bound+cpeArg :: CorePrepEnv -> Demand+       -> CoreArg -> Type -> UniqSM (Floats, CpeArg)+cpeArg env dmd arg arg_ty+  = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda+       ; (floats2, arg2) <- if want_float floats1 arg1+                            then return (floats1, arg1)+                            else dontFloat floats1 arg1+                -- Else case: arg1 might have lambdas, and we can't+                --            put them inside a wrapBinds++       ; if okCpeArg arg2+         then do { v <- newVar arg_ty+                 ; let arg3      = cpeEtaExpand (exprArity arg2) arg2+                       arg_float = mkFloat dmd is_unlifted v arg3+                 ; return (addFloat floats2 arg_float, varToCoreExpr v) }+         else return (floats2, arg2)+       }+  where+    is_unlifted = isUnliftedType arg_ty+    want_float  = wantFloatNested NonRecursive dmd is_unlifted++{-+Note [Floating unlifted arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider    C (let v* = expensive in v)++where the "*" indicates "will be demanded".  Usually v will have been+inlined by now, but let's suppose it hasn't (see #2756).  Then we+do *not* want to get++     let v* = expensive in C v++because that has different strictness.  Hence the use of 'allLazy'.+(NB: the let v* turns into a FloatCase, in mkLocalNonRec.)+++------------------------------------------------------------------------------+-- Building the saturated syntax+-- ---------------------------------------------------------------------------++maybeSaturate deals with saturating primops and constructors+The type is the type of the entire application+-}++maybeSaturate :: Id -> CpeApp -> Int -> UniqSM CpeRhs+maybeSaturate fn expr n_args+  | hasNoBinding fn        -- There's no binding+  = return sat_expr++  | otherwise+  = return expr+  where+    fn_arity     = idArity fn+    excess_arity = fn_arity - n_args+    sat_expr     = cpeEtaExpand excess_arity expr++{-+************************************************************************+*                                                                      *+                Simple CoreSyn operations+*                                                                      *+************************************************************************+-}++{-+-- -----------------------------------------------------------------------------+--      Eta reduction+-- -----------------------------------------------------------------------------++Note [Eta expansion]+~~~~~~~~~~~~~~~~~~~~~+Eta expand to match the arity claimed by the binder Remember,+CorePrep must not change arity++Eta expansion might not have happened already, because it is done by+the simplifier only when there at least one lambda already.++NB1:we could refrain when the RHS is trivial (which can happen+    for exported things).  This would reduce the amount of code+    generated (a little) and make things a little words for+    code compiled without -O.  The case in point is data constructor+    wrappers.++NB2: we have to be careful that the result of etaExpand doesn't+   invalidate any of the assumptions that CorePrep is attempting+   to establish.  One possible cause is eta expanding inside of+   an SCC note - we're now careful in etaExpand to make sure the+   SCC is pushed inside any new lambdas that are generated.++Note [Eta expansion and the CorePrep invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It turns out to be much much easier to do eta expansion+*after* the main CorePrep stuff.  But that places constraints+on the eta expander: given a CpeRhs, it must return a CpeRhs.++For example here is what we do not want:+                f = /\a -> g (h 3)      -- h has arity 2+After ANFing we get+                f = /\a -> let s = h 3 in g s+and now we do NOT want eta expansion to give+                f = /\a -> \ y -> (let s = h 3 in g s) y++Instead CoreArity.etaExpand gives+                f = /\a -> \y -> let s = h 3 in g s y+-}++cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs+cpeEtaExpand arity expr+  | arity == 0 = expr+  | otherwise  = etaExpand arity expr++{-+-- -----------------------------------------------------------------------------+--      Eta reduction+-- -----------------------------------------------------------------------------++Why try eta reduction?  Hasn't the simplifier already done eta?+But the simplifier only eta reduces if that leaves something+trivial (like f, or f Int).  But for deLam it would be enough to+get to a partial application:+        case x of { p -> \xs. map f xs }+    ==> case x of { p -> map f }+-}++tryEtaReducePrep :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr+tryEtaReducePrep bndrs expr@(App _ _)+  | ok_to_eta_reduce f+  , n_remaining >= 0+  , and (zipWith ok bndrs last_args)+  , not (any (`elemVarSet` fvs_remaining) bndrs)+  , exprIsHNF remaining_expr   -- Don't turn value into a non-value+                               -- else the behaviour with 'seq' changes+  = Just remaining_expr+  where+    (f, args) = collectArgs expr+    remaining_expr = mkApps f remaining_args+    fvs_remaining = exprFreeVars remaining_expr+    (remaining_args, last_args) = splitAt n_remaining args+    n_remaining = length args - length bndrs++    ok bndr (Var arg) = bndr == arg+    ok _    _         = False++          -- We can't eta reduce something which must be saturated.+    ok_to_eta_reduce (Var f) = not (hasNoBinding f)+    ok_to_eta_reduce _       = False -- Safe. ToDo: generalise++tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)+  | not (any (`elemVarSet` fvs) bndrs)+  = case tryEtaReducePrep bndrs body of+        Just e -> Just (Let bind e)+        Nothing -> Nothing+  where+    fvs = exprFreeVars r++-- NB: do not attempt to eta-reduce across ticks+-- Otherwise we risk reducing+--       \x. (Tick (Breakpoint {x}) f x)+--   ==> Tick (breakpoint {x}) f+-- which is bogus (#17228)+-- tryEtaReducePrep bndrs (Tick tickish e)+--   = fmap (mkTick tickish) $ tryEtaReducePrep bndrs e++tryEtaReducePrep _ _ = Nothing++{-+************************************************************************+*                                                                      *+                Floats+*                                                                      *+************************************************************************++Note [Pin demand info on floats]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We pin demand info on floated lets, so that we can see the one-shot thunks.+-}++data FloatingBind+  = FloatLet CoreBind    -- Rhs of bindings are CpeRhss+                         -- They are always of lifted type;+                         -- unlifted ones are done with FloatCase++ | FloatCase+      Id CpeBody+      Bool              -- The bool indicates "ok-for-speculation"++ -- | See Note [Floating Ticks in CorePrep]+ | FloatTick (Tickish Id)++data Floats = Floats OkToSpec (OrdList FloatingBind)++instance Outputable FloatingBind where+  ppr (FloatLet b) = ppr b+  ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r+  ppr (FloatTick t) = ppr t++instance Outputable Floats where+  ppr (Floats flag fs) = text "Floats" <> brackets (ppr flag) <+>+                         braces (vcat (map ppr (fromOL fs)))++instance Outputable OkToSpec where+  ppr OkToSpec    = text "OkToSpec"+  ppr IfUnboxedOk = text "IfUnboxedOk"+  ppr NotOkToSpec = text "NotOkToSpec"++-- Can we float these binds out of the rhs of a let?  We cache this decision+-- to avoid having to recompute it in a non-linear way when there are+-- deeply nested lets.+data OkToSpec+   = OkToSpec           -- Lazy bindings of lifted type+   | IfUnboxedOk        -- A mixture of lazy lifted bindings and n+                        -- ok-to-speculate unlifted bindings+   | NotOkToSpec        -- Some not-ok-to-speculate unlifted bindings++mkFloat :: Demand -> Bool -> Id -> CpeRhs -> FloatingBind+mkFloat dmd is_unlifted bndr rhs+  | use_case  = FloatCase bndr rhs (exprOkForSpeculation rhs)+  | is_hnf    = FloatLet (NonRec bndr                       rhs)+  | otherwise = FloatLet (NonRec (setIdDemandInfo bndr dmd) rhs)+                   -- See Note [Pin demand info on floats]+  where+    is_hnf    = exprIsHNF rhs+    is_strict = isStrictDmd dmd+    use_case  = is_unlifted || is_strict && not is_hnf+                -- Don't make a case for a value binding,+                -- even if it's strict.  Otherwise we get+                --      case (\x -> e) of ...!++emptyFloats :: Floats+emptyFloats = Floats OkToSpec nilOL++isEmptyFloats :: Floats -> Bool+isEmptyFloats (Floats _ bs) = isNilOL bs++wrapBinds :: Floats -> CpeBody -> CpeBody+wrapBinds (Floats _ binds) body+  = foldrOL mk_bind body binds+  where+    mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]+    mk_bind (FloatLet bind)        body = Let bind body+    mk_bind (FloatTick tickish)    body = mkTick tickish body++addFloat :: Floats -> FloatingBind -> Floats+addFloat (Floats ok_to_spec floats) new_float+  = Floats (combine ok_to_spec (check new_float)) (floats `snocOL` new_float)+  where+    check (FloatLet _) = OkToSpec+    check (FloatCase _ _ ok_for_spec)+        | ok_for_spec  =  IfUnboxedOk+        | otherwise    =  NotOkToSpec+    check FloatTick{}  = OkToSpec+        -- The ok-for-speculation flag says that it's safe to+        -- float this Case out of a let, and thereby do it more eagerly+        -- We need the top-level flag because it's never ok to float+        -- an unboxed binding to the top level++unitFloat :: FloatingBind -> Floats+unitFloat = addFloat emptyFloats++appendFloats :: Floats -> Floats -> Floats+appendFloats (Floats spec1 floats1) (Floats spec2 floats2)+  = Floats (combine spec1 spec2) (floats1 `appOL` floats2)++concatFloats :: [Floats] -> OrdList FloatingBind+concatFloats = foldr (\ (Floats _ bs1) bs2 -> appOL bs1 bs2) nilOL++combine :: OkToSpec -> OkToSpec -> OkToSpec+combine NotOkToSpec _ = NotOkToSpec+combine _ NotOkToSpec = NotOkToSpec+combine IfUnboxedOk _ = IfUnboxedOk+combine _ IfUnboxedOk = IfUnboxedOk+combine _ _           = OkToSpec++deFloatTop :: Floats -> [CoreBind]+-- For top level only; we don't expect any FloatCases+deFloatTop (Floats _ floats)+  = foldrOL get [] floats+  where+    get (FloatLet b) bs = occurAnalyseRHSs b : bs+    get (FloatCase var body _) bs  =+      occurAnalyseRHSs (NonRec var body) : bs+    get b _ = pprPanic "corePrepPgm" (ppr b)++    -- See Note [Dead code in CorePrep]+    occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e)+    occurAnalyseRHSs (Rec xes)    = Rec [(x, occurAnalyseExpr_NoBinderSwap e) | (x, e) <- xes]++---------------------------------------------------------------------------++canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs)+       -- Note [CafInfo and floating]+canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs+  | OkToSpec <- ok_to_spec           -- Worth trying+  , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs)+  = Just (Floats OkToSpec fs', subst_expr subst rhs)+  | otherwise+  = Nothing+  where+    subst_expr = substExpr (text "CorePrep")++    go :: (Subst, OrdList FloatingBind) -> [FloatingBind]+       -> Maybe (Subst, OrdList FloatingBind)++    go (subst, fbs_out) [] = Just (subst, fbs_out)++    go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in)+      | rhs_ok r+      = go (subst', fbs_out `snocOL` new_fb) fbs_in+      where+        (subst', b') = set_nocaf_bndr subst b+        new_fb = FloatLet (NonRec b' (subst_expr subst r))++    go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in)+      | all rhs_ok rs+      = go (subst', fbs_out `snocOL` new_fb) fbs_in+      where+        (bs,rs) = unzip prs+        (subst', bs') = mapAccumL set_nocaf_bndr subst bs+        rs' = map (subst_expr subst') rs+        new_fb = FloatLet (Rec (bs' `zip` rs'))++    go (subst, fbs_out) (ft@FloatTick{} : fbs_in)+      = go (subst, fbs_out `snocOL` ft) fbs_in++    go _ _ = Nothing      -- Encountered a caffy binding++    ------------+    set_nocaf_bndr subst bndr+      = (extendIdSubst subst bndr (Var bndr'), bndr')+      where+        bndr' = bndr `setIdCafInfo` NoCafRefs++    ------------+    rhs_ok :: CoreExpr -> Bool+    -- We can only float to top level from a NoCaf thing if+    -- the new binding is static. However it can't mention+    -- any non-static things or it would *already* be Caffy+    rhs_ok = rhsIsStatic platform (\_ -> False)+                         (\_nt i -> pprPanic "rhsIsStatic" (integer i))+                         -- Integer or Natural literals should not show up++wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool+wantFloatNested is_rec dmd is_unlifted floats rhs+  =  isEmptyFloats floats+  || isStrictDmd dmd+  || is_unlifted+  || (allLazyNested is_rec floats && exprIsHNF rhs)+        -- Why the test for allLazyNested?+        --      v = f (x `divInt#` y)+        -- we don't want to float the case, even if f has arity 2,+        -- because floating the case would make it evaluated too early++allLazyTop :: Floats -> Bool+allLazyTop (Floats OkToSpec _) = True+allLazyTop _                   = False++allLazyNested :: RecFlag -> Floats -> Bool+allLazyNested _      (Floats OkToSpec    _) = True+allLazyNested _      (Floats NotOkToSpec _) = False+allLazyNested is_rec (Floats IfUnboxedOk _) = isNonRec is_rec++{-+************************************************************************+*                                                                      *+                Cloning+*                                                                      *+************************************************************************+-}++-- ---------------------------------------------------------------------------+--                      The environment+-- ---------------------------------------------------------------------------++-- Note [Inlining in CorePrep]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- There is a subtle but important invariant that must be upheld in the output+-- of CorePrep: there are no "trivial" updatable thunks.  Thus, this Core+-- is impermissible:+--+--      let x :: ()+--          x = y+--+-- (where y is a reference to a GLOBAL variable).  Thunks like this are silly:+-- they can always be profitably replaced by inlining x with y. Consequently,+-- the code generator/runtime does not bother implementing this properly+-- (specifically, there is no implementation of stg_ap_0_upd_info, which is the+-- stack frame that would be used to update this thunk.  The "0" means it has+-- zero free variables.)+--+-- In general, the inliner is good at eliminating these let-bindings.  However,+-- there is one case where these trivial updatable thunks can arise: when+-- we are optimizing away 'lazy' (see Note [lazyId magic], and also+-- 'cpeRhsE'.)  Then, we could have started with:+--+--      let x :: ()+--          x = lazy @ () y+--+-- which is a perfectly fine, non-trivial thunk, but then CorePrep will+-- drop 'lazy', giving us 'x = y' which is trivial and impermissible.+-- The solution is CorePrep to have a miniature inlining pass which deals+-- with cases like this.  We can then drop the let-binding altogether.+--+-- Why does the removal of 'lazy' have to occur in CorePrep?+-- The gory details are in Note [lazyId magic] in MkId, but the+-- main reason is that lazy must appear in unfoldings (optimizer+-- output) and it must prevent call-by-value for catch# (which+-- is implemented by CorePrep.)+--+-- An alternate strategy for solving this problem is to have the+-- inliner treat 'lazy e' as a trivial expression if 'e' is trivial.+-- We decided not to adopt this solution to keep the definition+-- of 'exprIsTrivial' simple.+--+-- There is ONE caveat however: for top-level bindings we have+-- to preserve the binding so that we float the (hacky) non-recursive+-- binding for data constructors; see Note [Data constructor workers].+--+-- Note [CorePrep inlines trivial CoreExpr not Id]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Why does cpe_env need to be an IdEnv CoreExpr, as opposed to an+-- IdEnv Id?  Naively, we might conjecture that trivial updatable thunks+-- as per Note [Inlining in CorePrep] always have the form+-- 'lazy @ SomeType gbl_id'.  But this is not true: the following is+-- perfectly reasonable Core:+--+--      let x :: ()+--          x = lazy @ (forall a. a) y @ Bool+--+-- When we inline 'x' after eliminating 'lazy', we need to replace+-- occurrences of 'x' with 'y @ bool', not just 'y'.  Situations like+-- this can easily arise with higher-rank types; thus, cpe_env must+-- map to CoreExprs, not Ids.++data CorePrepEnv+  = CPE { cpe_dynFlags        :: DynFlags+        , cpe_env             :: IdEnv CoreExpr   -- Clone local Ids+        -- ^ This environment is used for three operations:+        --+        --      1. To support cloning of local Ids so that they are+        --      all unique (see item (6) of CorePrep overview).+        --+        --      2. To support beta-reduction of runRW, see+        --      Note [runRW magic] and Note [runRW arg].+        --+        --      3. To let us inline trivial RHSs of non top-level let-bindings,+        --      see Note [lazyId magic], Note [Inlining in CorePrep]+        --      and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)+        , cpe_mkIntegerId     :: Id+        , cpe_mkNaturalId     :: Id+        , cpe_integerSDataCon :: Maybe DataCon+        , cpe_naturalSDataCon :: Maybe DataCon+    }++lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id+lookupMkIntegerName dflags hsc_env+    = guardIntegerUse dflags $ liftM tyThingId $+      lookupGlobal hsc_env mkIntegerName++lookupMkNaturalName :: DynFlags -> HscEnv -> IO Id+lookupMkNaturalName dflags hsc_env+    = guardNaturalUse dflags $ liftM tyThingId $+      lookupGlobal hsc_env mkNaturalName++-- See Note [The integer library] in PrelNames+lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)+lookupIntegerSDataConName dflags hsc_env = case integerLibrary dflags of+    IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $+                  lookupGlobal hsc_env integerSDataConName+    IntegerSimple -> return Nothing++lookupNaturalSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)+lookupNaturalSDataConName dflags hsc_env = case integerLibrary dflags of+    IntegerGMP -> guardNaturalUse dflags $ liftM (Just . tyThingDataCon) $+                  lookupGlobal hsc_env naturalSDataConName+    IntegerSimple -> return Nothing++-- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName'+guardIntegerUse :: DynFlags -> IO a -> IO a+guardIntegerUse dflags act+  | thisPackage dflags == primUnitId+  = return $ panic "Can't use Integer in ghc-prim"+  | thisPackage dflags == integerUnitId+  = return $ panic "Can't use Integer in integer-*"+  | otherwise = act++-- | Helper for 'lookupMkNaturalName', 'lookupNaturalSDataConName'+--+-- Just like we can't use Integer literals in `integer-*`, we can't use Natural+-- literals in `base`. If we do, we get interface loading error for GHC.Natural.+guardNaturalUse :: DynFlags -> IO a -> IO a+guardNaturalUse dflags act+  | thisPackage dflags == primUnitId+  = return $ panic "Can't use Natural in ghc-prim"+  | thisPackage dflags == integerUnitId+  = return $ panic "Can't use Natural in integer-*"+  | thisPackage dflags == baseUnitId+  = return $ panic "Can't use Natural in base"+  | otherwise = act++mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv+mkInitialCorePrepEnv dflags hsc_env+    = do mkIntegerId <- lookupMkIntegerName dflags hsc_env+         mkNaturalId <- lookupMkNaturalName dflags hsc_env+         integerSDataCon <- lookupIntegerSDataConName dflags hsc_env+         naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env+         return $ CPE {+                      cpe_dynFlags = dflags,+                      cpe_env = emptyVarEnv,+                      cpe_mkIntegerId = mkIntegerId,+                      cpe_mkNaturalId = mkNaturalId,+                      cpe_integerSDataCon = integerSDataCon,+                      cpe_naturalSDataCon = naturalSDataCon+                  }++extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv+extendCorePrepEnv cpe id id'+    = cpe { cpe_env = extendVarEnv (cpe_env cpe) id (Var id') }++extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv+extendCorePrepEnvExpr cpe id expr+    = cpe { cpe_env = extendVarEnv (cpe_env cpe) id expr }++extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv+extendCorePrepEnvList cpe prs+    = cpe { cpe_env = extendVarEnvList (cpe_env cpe)+                        (map (\(id, id') -> (id, Var id')) prs) }++lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr+lookupCorePrepEnv cpe id+  = case lookupVarEnv (cpe_env cpe) id of+        Nothing  -> Var id+        Just exp -> exp++getMkIntegerId :: CorePrepEnv -> Id+getMkIntegerId = cpe_mkIntegerId++getMkNaturalId :: CorePrepEnv -> Id+getMkNaturalId = cpe_mkNaturalId++------------------------------------------------------------------------------+-- Cloning binders+-- ---------------------------------------------------------------------------++cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])+cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs++cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)+cpCloneBndr env bndr+  | not (isId bndr)+  = return (env, bndr)++  | otherwise+  = do { bndr' <- clone_it bndr++       -- Drop (now-useless) rules/unfoldings+       -- See Note [Drop unfoldings and rules]+       -- and Note [Preserve evaluatedness] in CoreTidy+       ; let unfolding' = zapUnfolding (realIdUnfolding bndr)+                          -- Simplifier will set the Id's unfolding++             bndr'' = bndr' `setIdUnfolding`      unfolding'+                            `setIdSpecialisation` emptyRuleInfo++       ; return (extendCorePrepEnv env bndr bndr'', bndr'') }+  where+    clone_it bndr+      | isLocalId bndr, not (isCoVar bndr)+      = do { uniq <- getUniqueM; return (setVarUnique bndr uniq) }+      | otherwise   -- Top level things, which we don't want+                    -- to clone, have become GlobalIds by now+                    -- And we don't clone tyvars, or coercion variables+      = return bndr++{- Note [Drop unfoldings and rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to drop the unfolding/rules on every Id:++  - We are now past interface-file generation, and in the+    codegen pipeline, so we really don't need full unfoldings/rules++  - The unfolding/rule may be keeping stuff alive that we'd like+    to discard.  See  Note [Dead code in CorePrep]++  - Getting rid of unnecessary unfoldings reduces heap usage++  - We are changing uniques, so if we didn't discard unfoldings/rules+    we'd have to substitute in them++HOWEVER, we want to preserve evaluated-ness;+see Note [Preserve evaluatedness] in CoreTidy.+-}++------------------------------------------------------------------------------+-- Cloning ccall Ids; each must have a unique name,+-- to give the code generator a handle to hang it on+-- ---------------------------------------------------------------------------++fiddleCCall :: Id -> UniqSM Id+fiddleCCall id+  | isFCallId id = (id `setVarUnique`) <$> getUniqueM+  | otherwise    = return id++------------------------------------------------------------------------------+-- Generating new binders+-- ---------------------------------------------------------------------------++newVar :: Type -> UniqSM Id+newVar ty+ = seqType ty `seq` do+     uniq <- getUniqueM+     return (mkSysLocalOrCoVar (fsLit "sat") uniq ty)+++------------------------------------------------------------------------------+-- Floating ticks+-- ---------------------------------------------------------------------------+--+-- Note [Floating Ticks in CorePrep]+--+-- It might seem counter-intuitive to float ticks by default, given+-- that we don't actually want to move them if we can help it. On the+-- other hand, nothing gets very far in CorePrep anyway, and we want+-- to preserve the order of let bindings and tick annotations in+-- relation to each other. For example, if we just wrapped let floats+-- when they pass through ticks, we might end up performing the+-- following transformation:+--+--   src<...> let foo = bar in baz+--   ==>  let foo = src<...> bar in src<...> baz+--+-- Because the let-binding would float through the tick, and then+-- immediately materialize, achieving nothing but decreasing tick+-- accuracy. The only special case is the following scenario:+--+--   let foo = src<...> (let a = b in bar) in baz+--   ==>  let foo = src<...> bar; a = src<...> b in baz+--+-- Here we would not want the source tick to end up covering "baz" and+-- therefore refrain from pushing ticks outside. Instead, we copy them+-- into the floating binds (here "a") in cpePair. Note that where "b"+-- or "bar" are (value) lambdas we have to push the annotations+-- further inside in order to uphold our rules.+--+-- All of this is implemented below in @wrapTicks@.++-- | Like wrapFloats, but only wraps tick floats+wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)+wrapTicks (Floats flag floats0) expr =+    (Floats flag (toOL $ reverse floats1), foldr mkTick expr (reverse ticks1))+  where (floats1, ticks1) = foldlOL go ([], []) $ floats0+        -- Deeply nested constructors will produce long lists of+        -- redundant source note floats here. We need to eliminate+        -- those early, as relying on mkTick to spot it after the fact+        -- can yield O(n^3) complexity [#11095]+        go (floats, ticks) (FloatTick t)+          = ASSERT(tickishPlace t == PlaceNonLam)+            (floats, if any (flip tickishContains t) ticks+                     then ticks else t:ticks)+        go (floats, ticks) f+          = (foldr wrap f (reverse ticks):floats, ticks)++        wrap t (FloatLet bind)    = FloatLet (wrapBind t bind)+        wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok+        wrap _ other              = pprPanic "wrapTicks: unexpected float!"+                                             (ppr other)+        wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)+        wrapBind t (Rec pairs)         = Rec (mapSnd (mkTick t) pairs)++------------------------------------------------------------------------------+-- Collecting cost centres+-- ---------------------------------------------------------------------------++-- | Collect cost centres defined in the current module, including those in+-- unfoldings.+collectCostCentres :: Module -> CoreProgram -> S.Set CostCentre+collectCostCentres mod_name+  = foldl' go_bind S.empty+  where+    go cs e = case e of+      Var{} -> cs+      Lit{} -> cs+      App e1 e2 -> go (go cs e1) e2+      Lam _ e -> go cs e+      Let b e -> go (go_bind cs b) e+      Case scrt _ _ alts -> go_alts (go cs scrt) alts+      Cast e _ -> go cs e+      Tick (ProfNote cc _ _) e ->+        go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e+      Tick _ e -> go cs e+      Type{} -> cs+      Coercion{} -> cs++    go_alts = foldl' (\cs (_con, _bndrs, e) -> go cs e)++    go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre+    go_bind cs (NonRec b e) =+      go (maybe cs (go cs) (get_unf b)) e+    go_bind cs (Rec bs) =+      foldl' (\cs' (b, e) -> go (maybe cs' (go cs') (get_unf b)) e) cs bs++    -- Unfoldings may have cost centres that in the original definion are+    -- optimized away, see #5889.+    get_unf = maybeUnfoldingTemplate . realIdUnfolding
+ compiler/deSugar/Check.hs view
@@ -0,0 +1,2753 @@+{-+Author: George Karachalias <george.karachalias@cs.kuleuven.be>++Pattern Matching Coverage Checking.+-}++{-# LANGUAGE CPP            #-}+{-# LANGUAGE GADTs          #-}+{-# LANGUAGE DataKinds      #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TupleSections  #-}+{-# LANGUAGE ViewPatterns   #-}+{-# LANGUAGE MultiWayIf     #-}++module Check (+        -- Checking and printing+        checkSingle, checkMatches, checkGuardMatches, isAnyPmCheckEnabled,++        -- See Note [Type and Term Equality Propagation]+        genCaseTmCs1, genCaseTmCs2+    ) where++#include "HsVersions.h"++import GhcPrelude++import TmOracle+import Unify( tcMatchTy )+import DynFlags+import HsSyn+import TcHsSyn+import Id+import ConLike+import Name+import FamInstEnv+import TysPrim (tYPETyCon)+import TysWiredIn+import TyCon+import SrcLoc+import Util+import Outputable+import FastString+import DataCon+import PatSyn+import HscTypes (CompleteMatch(..))++import DsMonad+import TcSimplify    (tcCheckSatisfiability)+import TcType        (isStringTy)+import Bag+import ErrUtils+import Var           (EvVar)+import TyCoRep+import Type+import UniqSupply+import DsUtils       (isTrueLHsExpr)+import Maybes        (expectJust)+import qualified GHC.LanguageExtensions as LangExt++import Data.List     (find)+import Data.Maybe    (catMaybes, isJust, fromMaybe)+import Control.Monad (forM, when, forM_, zipWithM, filterM)+import Coercion+import TcEvidence+import TcSimplify    (tcNormalise)+import IOEnv+import qualified Data.Semigroup as Semi++import ListT (ListT(..), fold, select)++{-+This module checks pattern matches for:+\begin{enumerate}+  \item Equations that are redundant+  \item Equations with inaccessible right-hand-side+  \item Exhaustiveness+\end{enumerate}++The algorithm is based on the paper:++  "GADTs Meet Their Match:+     Pattern-matching Warnings That Account for GADTs, Guards, and Laziness"++    http://people.cs.kuleuven.be/~george.karachalias/papers/p424-karachalias.pdf++%************************************************************************+%*                                                                      *+                     Pattern Match Check Types+%*                                                                      *+%************************************************************************+-}++-- We use the non-determinism monad to apply the algorithm to several+-- possible sets of constructors. Users can specify complete sets of+-- constructors by using COMPLETE pragmas.+-- The algorithm only picks out constructor+-- sets deep in the bowels which makes a simpler `mapM` more difficult to+-- implement. The non-determinism is only used in one place, see the ConVar+-- case in `pmCheckHd`.++type PmM a = ListT DsM a++liftD :: DsM a -> PmM a+liftD m = ListT $ \sk fk -> m >>= \a -> sk a fk++-- Pick the first match complete covered match or otherwise the "best" match.+-- The best match is the one with the least uncovered clauses, ties broken+-- by the number of inaccessible clauses followed by number of redundant+-- clauses.+--+-- This is specified in the+-- "Disambiguating between multiple ``COMPLETE`` pragmas" section of the+-- users' guide. If you update the implementation of this function, make sure+-- to update that section of the users' guide as well.+getResult :: PmM PmResult -> DsM PmResult+getResult ls+  = do { res <- fold ls goM (pure Nothing)+       ; case res of+            Nothing -> panic "getResult is empty"+            Just a  -> return a }+  where+    goM :: PmResult -> DsM (Maybe PmResult) -> DsM (Maybe PmResult)+    goM mpm dpm = do { pmr <- dpm+                     ; return $ Just $ go pmr mpm }++    -- Careful not to force unecessary results+    go :: Maybe PmResult -> PmResult -> PmResult+    go Nothing rs = rs+    go (Just old@(PmResult prov rs (UncoveredPatterns us) is)) new+      | null us && null rs && null is = old+      | otherwise =+        let PmResult prov' rs' (UncoveredPatterns us') is' = new+        in case compareLength us us'+                `mappend` (compareLength is is')+                `mappend` (compareLength rs rs')+                `mappend` (compare prov prov') of+              GT  -> new+              EQ  -> new+              LT  -> old+    go (Just (PmResult _ _ (TypeOfUncovered _) _)) _new+      = panic "getResult: No inhabitation candidates"++data PatTy = PAT | VA -- Used only as a kind, to index PmPat++-- The *arity* of a PatVec [p1,..,pn] is+-- the number of p1..pn that are not Guards++data PmPat :: PatTy -> * where+  PmCon  :: { pm_con_con     :: ConLike+            , pm_con_arg_tys :: [Type]+            , pm_con_tvs     :: [TyVar]+            , pm_con_dicts   :: [EvVar]+            , pm_con_args    :: [PmPat t] } -> PmPat t+            -- For PmCon arguments' meaning see @ConPatOut@ in hsSyn/HsPat.hs+  PmVar  :: { pm_var_id   :: Id } -> PmPat t+  PmLit  :: { pm_lit_lit  :: PmLit } -> PmPat t -- See Note [Literals in PmPat]+  PmNLit :: { pm_lit_id   :: Id+            , pm_lit_not  :: [PmLit] } -> PmPat 'VA+  PmGrd  :: { pm_grd_pv   :: PatVec+            , pm_grd_expr :: PmExpr } -> PmPat 'PAT+  -- | A fake guard pattern (True <- _) used to represent cases we cannot handle.+  PmFake :: PmPat 'PAT++instance Outputable (PmPat a) where+  ppr = pprPmPatDebug++-- data T a where+--     MkT :: forall p q. (Eq p, Ord q) => p -> q -> T [p]+-- or  MkT :: forall p q r. (Eq p, Ord q, [p] ~ r) => p -> q -> T r++type Pattern = PmPat 'PAT -- ^ Patterns+type ValAbs  = PmPat 'VA  -- ^ Value Abstractions++type PatVec = [Pattern]             -- ^ Pattern Vectors+data ValVec = ValVec [ValAbs] Delta -- ^ Value Vector Abstractions++-- | Term and type constraints to accompany each value vector abstraction.+-- For efficiency, we store the term oracle state instead of the term+-- constraints. TODO: Do the same for the type constraints?+data Delta = MkDelta { delta_ty_cs :: Bag EvVar+                     , delta_tm_cs :: TmState }++type ValSetAbs = [ValVec]  -- ^ Value Set Abstractions+type Uncovered = ValSetAbs++-- Instead of keeping the whole sets in memory, we keep a boolean for both the+-- covered and the divergent set (we store the uncovered set though, since we+-- want to print it). For both the covered and the divergent we have:+--+--   True <=> The set is non-empty+--+-- hence:+--  C = True             ==> Useful clause (no warning)+--  C = False, D = True  ==> Clause with inaccessible RHS+--  C = False, D = False ==> Redundant clause++data Covered = Covered | NotCovered+  deriving Show++instance Outputable Covered where+  ppr (Covered) = text "Covered"+  ppr (NotCovered) = text "NotCovered"++-- Like the or monoid for booleans+-- Covered = True, Uncovered = False+instance Semi.Semigroup Covered where+  Covered <> _ = Covered+  _ <> Covered = Covered+  NotCovered <> NotCovered = NotCovered++instance Monoid Covered where+  mempty = NotCovered+  mappend = (Semi.<>)++data Diverged = Diverged | NotDiverged+  deriving Show++instance Outputable Diverged where+  ppr Diverged = text "Diverged"+  ppr NotDiverged = text "NotDiverged"++instance Semi.Semigroup Diverged where+  Diverged <> _ = Diverged+  _ <> Diverged = Diverged+  NotDiverged <> NotDiverged = NotDiverged++instance Monoid Diverged where+  mempty = NotDiverged+  mappend = (Semi.<>)++-- | When we learned that a given match group is complete+data Provenance =+                  FromBuiltin -- ^  From the original definition of the type+                              --    constructor.+                | FromComplete -- ^ From a user-provided @COMPLETE@ pragma+  deriving (Show, Eq, Ord)++instance Outputable Provenance where+  ppr  = text . show++instance Semi.Semigroup Provenance where+  FromComplete <> _ = FromComplete+  _ <> FromComplete = FromComplete+  _ <> _ = FromBuiltin++instance Monoid Provenance where+  mempty = FromBuiltin+  mappend = (Semi.<>)++data PartialResult = PartialResult {+                        presultProvenance :: Provenance+                         -- keep track of provenance because we don't want+                         -- to warn about redundant matches if the result+                         -- is contaminated with a COMPLETE pragma+                      , presultCovered :: Covered+                      , presultUncovered :: Uncovered+                      , presultDivergent :: Diverged }++instance Outputable PartialResult where+  ppr (PartialResult prov c vsa d)+           = text "PartialResult" <+> ppr prov <+> ppr c+                                  <+> ppr d <+> ppr vsa+++instance Semi.Semigroup PartialResult where+  (PartialResult prov1 cs1 vsa1 ds1)+    <> (PartialResult prov2 cs2 vsa2 ds2)+      = PartialResult (prov1 Semi.<> prov2)+                      (cs1 Semi.<> cs2)+                      (vsa1 Semi.<> vsa2)+                      (ds1 Semi.<> ds2)+++instance Monoid PartialResult where+  mempty = PartialResult mempty mempty [] mempty+  mappend = (Semi.<>)++-- newtype ChoiceOf a = ChoiceOf [a]++-- | Pattern check result+--+-- * Redundant clauses+-- * Not-covered clauses (or their type, if no pattern is available)+-- * Clauses with inaccessible RHS+--+-- More details about the classification of clauses into useful, redundant+-- and with inaccessible right hand side can be found here:+--+--     https://gitlab.haskell.org/ghc/ghc/wikis/pattern-match-check+--+data PmResult =+  PmResult {+      pmresultProvenance   :: Provenance+    , pmresultRedundant    :: [Located [LPat GhcTc]]+    , pmresultUncovered    :: UncoveredCandidates+    , pmresultInaccessible :: [Located [LPat GhcTc]] }++instance Outputable PmResult where+  ppr pmr = hang (text "PmResult") 2 $ vcat+    [ text "pmresultProvenance" <+> ppr (pmresultProvenance pmr)+    , text "pmresultRedundant" <+> ppr (pmresultRedundant pmr)+    , text "pmresultUncovered" <+> ppr (pmresultUncovered pmr)+    , text "pmresultInaccessible" <+> ppr (pmresultInaccessible pmr)+    ]++-- | Either a list of patterns that are not covered, or their type, in case we+-- have no patterns at hand. Not having patterns at hand can arise when+-- handling EmptyCase expressions, in two cases:+--+-- * The type of the scrutinee is a trivially inhabited type (like Int or Char)+-- * The type of the scrutinee cannot be reduced to WHNF.+--+-- In both these cases we have no inhabitation candidates for the type at hand,+-- but we don't want to issue just a wildcard as missing. Instead, we print a+-- type annotated wildcard, so that the user knows what kind of patterns is+-- expected (e.g. (_ :: Int), or (_ :: F Int), where F Int does not reduce).+data UncoveredCandidates = UncoveredPatterns Uncovered+                         | TypeOfUncovered Type++instance Outputable UncoveredCandidates where+  ppr (UncoveredPatterns uc) = text "UnPat" <+> ppr uc+  ppr (TypeOfUncovered ty)   = text "UnTy" <+> ppr ty++-- | The empty pattern check result+emptyPmResult :: PmResult+emptyPmResult = PmResult FromBuiltin [] (UncoveredPatterns []) []++-- | Non-exhaustive empty case with unknown/trivial inhabitants+uncoveredWithTy :: Type -> PmResult+uncoveredWithTy ty = PmResult FromBuiltin [] (TypeOfUncovered ty) []++{-+%************************************************************************+%*                                                                      *+       Entry points to the checker: checkSingle and checkMatches+%*                                                                      *+%************************************************************************+-}++-- | Check a single pattern binding (let)+checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat GhcTc -> DsM ()+checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do+  tracePmD "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])+  mb_pm_res <- tryM (getResult (checkSingle' locn var p))+  case mb_pm_res of+    Left  _   -> warnPmIters dflags ctxt+    Right res -> dsPmWarn dflags ctxt res++-- | Check a single pattern binding (let)+checkSingle' :: SrcSpan -> Id -> Pat GhcTc -> PmM PmResult+checkSingle' locn var p = do+  liftD resetPmIterDs -- set the iter-no to zero+  fam_insts <- liftD dsGetFamInstEnvs+  clause    <- liftD $ translatePat fam_insts p+  missing   <- mkInitialUncovered [var]+  tracePm "checkSingle': missing" (vcat (map pprValVecDebug missing))+                                  -- no guards+  PartialResult prov cs us ds <- runMany (pmcheckI clause []) missing+  let us' = UncoveredPatterns us+  return $ case (cs,ds) of+    (Covered,  _    )         -> PmResult prov [] us' [] -- useful+    (NotCovered, NotDiverged) -> PmResult prov m  us' [] -- redundant+    (NotCovered, Diverged )   -> PmResult prov [] us' m  -- inaccessible rhs+  where m = [cL locn [cL locn p]]++-- | 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 ()+checkGuardMatches hs_ctx guards@(GRHSs _ grhss _) = do+    dflags <- getDynFlags+    let combinedLoc = foldl1 combineSrcSpans (map getLoc grhss)+        dsMatchContext = DsMatchContext hs_ctx combinedLoc+        match = cL combinedLoc $+                  Match { m_ext = noExt+                        , m_ctxt = hs_ctx+                        , m_pats = []+                        , m_grhss = guards }+    checkMatches dflags dsMatchContext [] [match]+checkGuardMatches _ (XGRHSs _) = panic "checkGuardMatches"++-- | Check a matchgroup (case, functions, etc.)+checkMatches :: DynFlags -> DsMatchContext+             -> [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> DsM ()+checkMatches dflags ctxt vars matches = do+  tracePmD "checkMatches" (hang (vcat [ppr ctxt+                               , ppr vars+                               , text "Matches:"])+                               2+                               (vcat (map ppr matches)))+  mb_pm_res <- tryM $ getResult $ case matches of+    -- Check EmptyCase separately+    -- See Note [Checking EmptyCase Expressions]+    [] | [var] <- vars -> checkEmptyCase' var+    _normal_match      -> checkMatches' vars matches+  case mb_pm_res of+    Left  _   -> warnPmIters dflags ctxt+    Right res -> dsPmWarn dflags ctxt res++-- | Check a matchgroup (case, functions, etc.). To be called on a non-empty+-- list of matches. For empty case expressions, use checkEmptyCase' instead.+checkMatches' :: [Id] -> [LMatch GhcTc (LHsExpr GhcTc)] -> PmM PmResult+checkMatches' vars matches+  | null matches = panic "checkMatches': EmptyCase"+  | otherwise = do+      liftD resetPmIterDs -- set the iter-no to zero+      missing    <- mkInitialUncovered vars+      tracePm "checkMatches': missing" (vcat (map pprValVecDebug missing))+      (prov, rs,us,ds) <- go matches missing+      return $ PmResult {+                   pmresultProvenance   = prov+                 , pmresultRedundant    = map hsLMatchToLPats rs+                 , pmresultUncovered    = UncoveredPatterns us+                 , pmresultInaccessible = map hsLMatchToLPats ds }+  where+    go :: [LMatch GhcTc (LHsExpr GhcTc)] -> Uncovered+       -> PmM (Provenance+              , [LMatch GhcTc (LHsExpr GhcTc)]+              , Uncovered+              , [LMatch GhcTc (LHsExpr GhcTc)])+    go []     missing = return (mempty, [], missing, [])+    go (m:ms) missing = do+      tracePm "checkMatches': go" (ppr m $$ ppr missing)+      fam_insts          <- liftD dsGetFamInstEnvs+      (clause, guards)   <- liftD $ translateMatch fam_insts m+      r@(PartialResult prov cs missing' ds)+        <- runMany (pmcheckI clause guards) missing+      tracePm "checkMatches': go: res" (ppr r)+      (ms_prov, rs, final_u, is)  <- go ms missing'+      let final_prov = prov `mappend` ms_prov+      return $ case (cs, ds) of+        -- useful+        (Covered,  _    )        -> (final_prov,  rs, final_u,   is)+        -- redundant+        (NotCovered, NotDiverged) -> (final_prov, m:rs, final_u,is)+        -- inaccessible+        (NotCovered, Diverged )   -> (final_prov,  rs, final_u, m:is)++    hsLMatchToLPats :: LMatch id body -> Located [LPat id]+    hsLMatchToLPats (dL->L l (Match { m_pats = pats })) = cL l pats+    hsLMatchToLPats _                                   = panic "checkMatches'"++-- | Check an empty case expression. Since there are no clauses to process, we+--   only compute the uncovered set. See Note [Checking EmptyCase Expressions]+--   for details.+checkEmptyCase' :: Id -> PmM PmResult+checkEmptyCase' var = do+  tm_ty_css     <- pmInitialTmTyCs+  mb_candidates <- inhabitationCandidates (delta_ty_cs tm_ty_css) (idType var)+  case mb_candidates of+    -- Inhabitation checking failed / the type is trivially inhabited+    Left ty -> return (uncoveredWithTy ty)++    -- A list of inhabitant candidates is available: Check for each+    -- one for the satisfiability of the constraints it gives rise to.+    Right (_, candidates) -> do+      missing_m <- flip mapMaybeM candidates $+          \InhabitationCandidate{ ic_val_abs = va, ic_tm_ct = tm_ct+                                , ic_ty_cs = ty_cs+                                , ic_strict_arg_tys = strict_arg_tys } -> do+        mb_sat <- pmIsSatisfiable tm_ty_css tm_ct ty_cs strict_arg_tys+        pure $ fmap (ValVec [va]) mb_sat+      return $ if null missing_m+        then emptyPmResult+        else PmResult FromBuiltin [] (UncoveredPatterns missing_m) []++-- | Returns 'True' if the argument 'Type' is a fully saturated application of+-- a closed type constructor.+--+-- Closed type constructors are those with a fixed right hand side, as+-- opposed to e.g. associated types. These are of particular interest for+-- pattern-match coverage checking, because GHC can exhaustively consider all+-- possible forms that values of a closed type can take on.+--+-- Note that this function is intended to be used to check types of value-level+-- patterns, so as a consequence, the 'Type' supplied as an argument to this+-- function should be of kind @Type@.+pmIsClosedType :: Type -> Bool+pmIsClosedType ty+  = case splitTyConApp_maybe ty of+      Just (tc, ty_args)+             | is_algebraic_like tc && not (isFamilyTyCon tc)+             -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True+      _other -> False+  where+    -- This returns True for TyCons which /act like/ algebraic types.+    -- (See "Type#type_classification" for what an algebraic type is.)+    --+    -- This is qualified with \"like\" because of a particular special+    -- case: TYPE (the underlyind kind behind Type, among others). TYPE+    -- is conceptually a datatype (and thus algebraic), but in practice it is+    -- a primitive builtin type, so we must check for it specially.+    --+    -- NB: it makes sense to think of TYPE as a closed type in a value-level,+    -- pattern-matching context. However, at the kind level, TYPE is certainly+    -- not closed! Since this function is specifically tailored towards pattern+    -- matching, however, it's OK to label TYPE as closed.+    is_algebraic_like :: TyCon -> Bool+    is_algebraic_like tc = isAlgTyCon tc || tc == tYPETyCon++pmTopNormaliseType_maybe :: FamInstEnvs -> Bag EvVar -> Type+                         -> PmM (Maybe (Type, [DataCon], Type))+-- ^ Get rid of *outermost* (or toplevel)+--      * type function redex+--      * data family redex+--      * newtypes+--+-- Behaves exactly like `topNormaliseType_maybe`, but instead of returning a+-- coercion, it returns useful information for issuing pattern matching+-- warnings. See Note [Type normalisation for EmptyCase] for details.+--+-- NB: Normalisation can potentially change kinds, if the head of the type+-- is a type family with a variable result kind. I (Richard E) can't think+-- of a way to cause trouble here, though.+pmTopNormaliseType_maybe env ty_cs typ+  = do (_, mb_typ') <- liftD $ initTcDsForSolver $ tcNormalise ty_cs typ+         -- Before proceeding, we chuck typ into the constraint solver, in case+         -- solving for given equalities may reduce typ some. See+         -- "Wrinkle: local equalities" in+         -- Note [Type normalisation for EmptyCase].+       pure $ do typ' <- mb_typ'+                 ((ty_f,tm_f), ty) <- topNormaliseTypeX stepper comb typ'+                 -- We need to do topNormaliseTypeX in addition to tcNormalise,+                 -- since topNormaliseX looks through newtypes, which+                 -- tcNormalise does not do.+                 Just (eq_src_ty ty (typ' : ty_f [ty]), tm_f [], ty)+  where+    -- Find the first type in the sequence of rewrites that is a data type,+    -- newtype, or a data family application (not the representation tycon!).+    -- This is the one that is equal (in source Haskell) to the initial type.+    -- If none is found in the list, then all of them are type family+    -- applications, so we simply return the last one, which is the *simplest*.+    eq_src_ty :: Type -> [Type] -> Type+    eq_src_ty ty tys = maybe ty id (find is_closed_or_data_family tys)++    is_closed_or_data_family :: Type -> Bool+    is_closed_or_data_family ty = pmIsClosedType ty || isDataFamilyAppType ty++    -- For efficiency, represent both lists as difference lists.+    -- comb performs the concatenation, for both lists.+    comb (tyf1, tmf1) (tyf2, tmf2) = (tyf1 . tyf2, tmf1 . tmf2)++    stepper = newTypeStepper `composeSteppers` tyFamStepper++    -- A 'NormaliseStepper' that unwraps newtypes, careful not to fall into+    -- a loop. If it would fall into a loop, it produces 'NS_Abort'.+    newTypeStepper :: NormaliseStepper ([Type] -> [Type],[DataCon] -> [DataCon])+    newTypeStepper rec_nts tc tys+      | Just (ty', _co) <- instNewTyCon_maybe tc tys+      = case checkRecTc rec_nts tc of+          Just rec_nts' -> let tyf = ((TyConApp tc tys):)+                               tmf = ((tyConSingleDataCon tc):)+                           in  NS_Step rec_nts' ty' (tyf, tmf)+          Nothing       -> NS_Abort+      | otherwise+      = NS_Done++    tyFamStepper :: NormaliseStepper ([Type] -> [Type], [DataCon] -> [DataCon])+    tyFamStepper rec_nts tc tys  -- Try to step a type/data family+      = let (_args_co, ntys, _res_co) = normaliseTcArgs env Representational tc tys in+          -- NB: It's OK to use normaliseTcArgs here instead of+          -- normalise_tc_args (which takes the LiftingContext described+          -- in Note [Normalising types]) because the reduceTyFamApp below+          -- works only at top level. We'll never recur in this function+          -- after reducing the kind of a bound tyvar.++        case reduceTyFamApp_maybe env Representational tc ntys of+          Just (_co, rhs) -> NS_Step rec_nts rhs ((rhs:), id)+          _               -> NS_Done++-- | Determine suitable constraints to use at the beginning of pattern-match+-- coverage checking by consulting the sets of term and type constraints+-- currently in scope. If one of these sets of constraints is unsatisfiable,+-- use an empty set in its place. (See+-- @Note [Recovering from unsatisfiable pattern-matching constraints]@+-- for why this is done.)+pmInitialTmTyCs :: PmM Delta+pmInitialTmTyCs = do+  ty_cs  <- liftD getDictsDs+  tm_cs  <- map toComplex . bagToList <$> liftD getTmCsDs+  sat_ty <- tyOracle ty_cs+  let initTyCs = if sat_ty then ty_cs else emptyBag+      initTmState = fromMaybe initialTmState (tmOracle initialTmState tm_cs)+  pure $ MkDelta{ delta_tm_cs = initTmState, delta_ty_cs = initTyCs }++{-+Note [Recovering from unsatisfiable pattern-matching constraints]+~~~~~~~~~~~~~~~~+Consider the following code (see #12957 and #15450):++  f :: Int ~ Bool => ()+  f = case True of { False -> () }++We want to warn that the pattern-matching in `f` is non-exhaustive. But GHC+used not to do this; in fact, it would warn that the match was /redundant/!+This is because the constraint (Int ~ Bool) in `f` is unsatisfiable, and the+coverage checker deems any matches with unsatifiable constraint sets to be+unreachable.++We decide to better than this. When beginning coverage checking, we first+check if the constraints in scope are unsatisfiable, and if so, we start+afresh with an empty set of constraints. This way, we'll get the warnings+that we expect.+-}++-- | Given a conlike's term constraints, type constraints, and strict argument+-- types, check if they are satisfiable.+-- (In other words, this is the ⊢_Sat oracle judgment from the GADTs Meet+-- Their Match paper.)+--+-- For the purposes of efficiency, this takes as separate arguments the+-- ambient term and type constraints (which are known beforehand to be+-- satisfiable), as well as the new term and type constraints (which may not+-- be satisfiable). This lets us implement two mini-optimizations:+--+-- * If there are no new type constraints, then don't bother initializing+--   the type oracle, since it's redundant to do so.+-- * Since the new term constraint is a separate argument, we only need to+--   execute one iteration of the term oracle (instead of traversing the+--   entire set of term constraints).+--+-- Taking strict argument types into account is something which was not+-- discussed in GADTs Meet Their Match. For an explanation of what role they+-- serve, see @Note [Extensions to GADTs Meet Their Match]@.+pmIsSatisfiable+  :: Delta     -- ^ The ambient term and type constraints+               --   (known to be satisfiable).+  -> ComplexEq -- ^ The new term constraint.+  -> Bag EvVar -- ^ The new type constraints.+  -> [Type]    -- ^ The strict argument types.+  -> PmM (Maybe Delta)+               -- ^ @'Just' delta@ if the constraints (@delta@) are+               -- satisfiable, and each strict argument type is inhabitable.+               -- 'Nothing' otherwise.+pmIsSatisfiable amb_cs new_tm_c new_ty_cs strict_arg_tys = do+  mb_sat <- tmTyCsAreSatisfiable amb_cs new_tm_c new_ty_cs+  case mb_sat of+    Nothing -> pure Nothing+    Just delta -> do+      -- We know that the term and type constraints are inhabitable, so now+      -- check if each strict argument type is inhabitable.+      all_non_void <- checkAllNonVoid initRecTc delta strict_arg_tys+      pure $ if all_non_void -- Check if each strict argument type+                             -- is inhabitable+                then Just delta+                else Nothing++-- | Like 'pmIsSatisfiable', but only checks if term and type constraints are+-- satisfiable, and doesn't bother checking anything related to strict argument+-- types.+tmTyCsAreSatisfiable+  :: Delta     -- ^ The ambient term and type constraints+               --   (known to be satisfiable).+  -> ComplexEq -- ^ The new term constraint.+  -> Bag EvVar -- ^ The new type constraints.+  -> PmM (Maybe Delta)+       -- ^ @'Just' delta@ if the constraints (@delta@) are+       -- satisfiable. 'Nothing' otherwise.+tmTyCsAreSatisfiable+    (MkDelta{ delta_tm_cs = amb_tm_cs, delta_ty_cs = amb_ty_cs })+    new_tm_c new_ty_cs = do+  let ty_cs = new_ty_cs `unionBags` amb_ty_cs+  sat_ty <- if isEmptyBag new_ty_cs+               then pure True+               else tyOracle ty_cs+  pure $ case (sat_ty, solveOneEq amb_tm_cs new_tm_c) of+           (True, Just term_cs) -> Just $ MkDelta{ delta_ty_cs = ty_cs+                                                 , delta_tm_cs = term_cs }+           _unsat               -> Nothing++-- | Implements two performance optimizations, as described in the+-- \"Strict argument type constraints\" section of+-- @Note [Extensions to GADTs Meet Their Match]@.+checkAllNonVoid :: RecTcChecker -> Delta -> [Type] -> PmM Bool+checkAllNonVoid rec_ts amb_cs strict_arg_tys = do+  fam_insts <- liftD dsGetFamInstEnvs+  let definitely_inhabited =+        definitelyInhabitedType fam_insts (delta_ty_cs amb_cs)+  tys_to_check <- filterOutM definitely_inhabited strict_arg_tys+  let rec_max_bound | tys_to_check `lengthExceeds` 1+                    = 1+                    | otherwise+                    = defaultRecTcMaxBound+      rec_ts' = setRecTcMaxBound rec_max_bound rec_ts+  allM (nonVoid rec_ts' amb_cs) tys_to_check++-- | Checks if a strict argument type of a conlike is inhabitable by a+-- terminating value (i.e, an 'InhabitationCandidate').+-- See @Note [Extensions to GADTs Meet Their Match]@.+nonVoid+  :: RecTcChecker -- ^ The per-'TyCon' recursion depth limit.+  -> Delta        -- ^ The ambient term/type constraints (known to be+                  --   satisfiable).+  -> Type         -- ^ The strict argument type.+  -> PmM Bool     -- ^ 'True' if the strict argument type might be inhabited by+                  --   a terminating value (i.e., an 'InhabitationCandidate').+                  --   'False' if it is definitely uninhabitable by anything+                  --   (except bottom).+nonVoid rec_ts amb_cs strict_arg_ty = do+  mb_cands <- inhabitationCandidates (delta_ty_cs amb_cs) strict_arg_ty+  case mb_cands of+    Right (tc, cands)+      |  Just rec_ts' <- checkRecTc rec_ts tc+      -> anyM (cand_is_inhabitable rec_ts' amb_cs) cands+           -- A strict argument type is inhabitable by a terminating value if+           -- at least one InhabitationCandidate is inhabitable.+    _ -> pure True+           -- Either the type is trivially inhabited or we have exceeded the+           -- recursion depth for some TyCon (so bail out and conservatively+           -- claim the type is inhabited).+  where+    -- Checks if an InhabitationCandidate for a strict argument type:+    --+    -- (1) Has satisfiable term and type constraints.+    -- (2) Has 'nonVoid' strict argument types (we bail out of this+    --     check if recursion is detected).+    --+    -- See Note [Extensions to GADTs Meet Their Match]+    cand_is_inhabitable :: RecTcChecker -> Delta+                        -> InhabitationCandidate -> PmM Bool+    cand_is_inhabitable rec_ts amb_cs+      (InhabitationCandidate{ ic_tm_ct          = new_term_c+                            , ic_ty_cs          = new_ty_cs+                            , ic_strict_arg_tys = new_strict_arg_tys }) = do+        mb_sat <- tmTyCsAreSatisfiable amb_cs new_term_c new_ty_cs+        case mb_sat of+          Nothing -> pure False+          Just new_delta -> do+            checkAllNonVoid rec_ts new_delta new_strict_arg_tys++-- | @'definitelyInhabitedType' ty@ returns 'True' if @ty@ has at least one+-- constructor @C@ such that:+--+-- 1. @C@ has no equality constraints.+-- 2. @C@ has no strict argument types.+--+-- See the \"Strict argument type constraints\" section of+-- @Note [Extensions to GADTs Meet Their Match]@.+definitelyInhabitedType :: FamInstEnvs -> Bag EvVar -> Type -> PmM Bool+definitelyInhabitedType env ty_cs ty = do+  mb_res <- pmTopNormaliseType_maybe env ty_cs ty+  pure $ case mb_res of+           Just (_, cons, _) -> any meets_criteria cons+           Nothing           -> False+  where+    meets_criteria :: DataCon -> Bool+    meets_criteria con =+      null (dataConEqSpec con) && -- (1)+      null (dataConImplBangs con) -- (2)++{- Note [Type normalisation for EmptyCase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+EmptyCase is an exception for pattern matching, since it is strict. This means+that it boils down to checking whether the type of the scrutinee is inhabited.+Function pmTopNormaliseType_maybe gets rid of the outermost type function/data+family redex and newtypes, in search of an algebraic type constructor, which is+easier to check for inhabitation.++It returns 3 results instead of one, because there are 2 subtle points:+1. Newtypes are isomorphic to the underlying type in core but not in the source+   language,+2. The representational data family tycon is used internally but should not be+   shown to the user++Hence, if pmTopNormaliseType_maybe env ty_cs ty = Just (src_ty, dcs, core_ty),+then+  (a) src_ty is the rewritten type which we can show to the user. That is, the+      type we get if we rewrite type families but not data families or+      newtypes.+  (b) dcs is the list of data constructors "skipped", every time we normalise a+      newtype to its core representation, we keep track of the source data+      constructor.+  (c) core_ty is the rewritten type. That is,+        pmTopNormaliseType_maybe env ty_cs ty = Just (src_ty, dcs, core_ty)+      implies+        topNormaliseType_maybe env ty = Just (co, core_ty)+      for some coercion co.++To see how all cases come into play, consider the following example:++  data family T a :: *+  data instance T Int = T1 | T2 Bool+  -- Which gives rise to FC:+  --   data T a+  --   data R:TInt = T1 | T2 Bool+  --   axiom ax_ti : T Int ~R R:TInt++  newtype G1 = MkG1 (T Int)+  newtype G2 = MkG2 G1++  type instance F Int  = F Char+  type instance F Char = G2++In this case pmTopNormaliseType_maybe env ty_cs (F Int) results in++  Just (G2, [MkG2,MkG1], R:TInt)++Which means that in source Haskell:+  - G2 is equivalent to F Int (in contrast, G1 isn't).+  - if (x : R:TInt) then (MkG2 (MkG1 x) : F Int).++-----+-- Wrinkle: Local equalities+-----++Given the following type family:++  type family F a+  type instance F Int = Void++Should the following program (from #14813) be considered exhaustive?++  f :: (i ~ Int) => F i -> a+  f x = case x of {}++You might think "of course, since `x` is obviously of type Void". But the+idType of `x` is technically F i, not Void, so if we pass F i to+inhabitationCandidates, we'll mistakenly conclude that `f` is non-exhaustive.+In order to avoid this pitfall, we need to normalise the type passed to+pmTopNormaliseType_maybe, using the constraint solver to solve for any local+equalities (such as i ~ Int) that may be in scope.+-}++-- | Generate all 'InhabitationCandidate's for a given type. The result is+-- either @'Left' ty@, if the type cannot be reduced to a closed algebraic type+-- (or if it's one trivially inhabited, like 'Int'), or @'Right' candidates@,+-- if it can. In this case, the candidates are the signature of the tycon, each+-- one accompanied by the term- and type- constraints it gives rise to.+-- See also Note [Checking EmptyCase Expressions]+inhabitationCandidates :: Bag EvVar -> Type+                       -> PmM (Either Type (TyCon, [InhabitationCandidate]))+inhabitationCandidates ty_cs ty = do+  fam_insts   <- liftD dsGetFamInstEnvs+  mb_norm_res <- pmTopNormaliseType_maybe fam_insts ty_cs ty+  case mb_norm_res of+    Just (src_ty, dcs, core_ty) -> alts_to_check src_ty core_ty dcs+    Nothing                     -> alts_to_check ty     ty      []+  where+    -- All these types are trivially inhabited+    trivially_inhabited = [ charTyCon, doubleTyCon, floatTyCon+                          , intTyCon, wordTyCon, word8TyCon ]++    -- Note: At the moment we leave all the typing and constraint fields of+    -- PmCon empty, since we know that they are not gonna be used. Is the+    -- right-thing-to-do to actually create them, even if they are never used?+    build_tm :: ValAbs -> [DataCon] -> ValAbs+    build_tm = foldr (\dc e -> PmCon (RealDataCon dc) [] [] [] [e])++    -- Inhabitation candidates, using the result of pmTopNormaliseType_maybe+    alts_to_check :: Type -> Type -> [DataCon]+                  -> PmM (Either Type (TyCon, [InhabitationCandidate]))+    alts_to_check src_ty core_ty dcs = case splitTyConApp_maybe core_ty of+      Just (tc, _)+        |  tc `elem` trivially_inhabited+        -> case dcs of+             []    -> return (Left src_ty)+             (_:_) -> do var <- liftD $ mkPmId core_ty+                         let va = build_tm (PmVar var) dcs+                         return $ Right (tc, [InhabitationCandidate+                           { ic_val_abs = va, ic_tm_ct = mkIdEq var+                           , ic_ty_cs = emptyBag, ic_strict_arg_tys = [] }])++        |  pmIsClosedType core_ty && not (isAbstractTyCon tc)+           -- Don't consider abstract tycons since we don't know what their+           -- constructors are, which makes the results of coverage checking+           -- them extremely misleading.+        -> liftD $ do+             var  <- mkPmId core_ty -- it would be wrong to unify x+             alts <- mapM (mkOneConFull var . RealDataCon) (tyConDataCons tc)+             return $ Right+               (tc, [ alt{ic_val_abs = build_tm (ic_val_abs alt) dcs}+                    | alt <- alts ])+      -- For other types conservatively assume that they are inhabited.+      _other -> return (Left src_ty)++{- Note [Checking EmptyCase Expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Empty case expressions are strict on the scrutinee. That is, `case x of {}`+will force argument `x`. Hence, `checkMatches` is not sufficient for checking+empty cases, because it assumes that the match is not strict (which is true+for all other cases, apart from EmptyCase). This gave rise to #10746. Instead,+we do the following:++1. We normalise the outermost type family redex, data family redex or newtype,+   using pmTopNormaliseType_maybe (in types/FamInstEnv.hs). This computes 3+   things:+   (a) A normalised type src_ty, which is equal to the type of the scrutinee in+       source Haskell (does not normalise newtypes or data families)+   (b) The actual normalised type core_ty, which coincides with the result+       topNormaliseType_maybe. This type is not necessarily equal to the input+       type in source Haskell. And this is precicely the reason we compute (a)+       and (c): the reasoning happens with the underlying types, but both the+       patterns and types we print should respect newtypes and also show the+       family type constructors and not the representation constructors.++   (c) A list of all newtype data constructors dcs, each one corresponding to a+       newtype rewrite performed in (b).++   For an example see also Note [Type normalisation for EmptyCase]+   in types/FamInstEnv.hs.++2. Function checkEmptyCase' performs the check:+   - If core_ty is not an algebraic type, then we cannot check for+     inhabitation, so we emit (_ :: src_ty) as missing, conservatively assuming+     that the type is inhabited.+   - If core_ty is an algebraic type, then we unfold the scrutinee to all+     possible constructor patterns, using inhabitationCandidates, and then+     check each one for constraint satisfiability, same as we for normal+     pattern match checking.++%************************************************************************+%*                                                                      *+              Transform source syntax to *our* syntax+%*                                                                      *+%************************************************************************+-}++-- -----------------------------------------------------------------------+-- * Utilities++nullaryConPattern :: ConLike -> Pattern+-- Nullary data constructor and nullary type constructor+nullaryConPattern con =+  PmCon { pm_con_con = con, pm_con_arg_tys = []+        , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = [] }+{-# INLINE nullaryConPattern #-}++truePattern :: Pattern+truePattern = nullaryConPattern (RealDataCon trueDataCon)+{-# INLINE truePattern #-}++-- | Generate a `canFail` pattern vector of a specific type+mkCanFailPmPat :: Type -> DsM PatVec+mkCanFailPmPat ty = do+  var <- mkPmVar ty+  return [var, PmFake]++vanillaConPattern :: ConLike -> [Type] -> PatVec -> Pattern+-- ADT constructor pattern => no existentials, no local constraints+vanillaConPattern con arg_tys args =+  PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys+        , pm_con_tvs = [], pm_con_dicts = [], pm_con_args = args }+{-# INLINE vanillaConPattern #-}++-- | Create an empty list pattern of a given type+nilPattern :: Type -> Pattern+nilPattern ty =+  PmCon { pm_con_con = RealDataCon nilDataCon, pm_con_arg_tys = [ty]+        , pm_con_tvs = [], pm_con_dicts = []+        , pm_con_args = [] }+{-# INLINE nilPattern #-}++mkListPatVec :: Type -> PatVec -> PatVec -> PatVec+mkListPatVec ty xs ys = [PmCon { pm_con_con = RealDataCon consDataCon+                               , pm_con_arg_tys = [ty]+                               , pm_con_tvs = [], pm_con_dicts = []+                               , pm_con_args = xs++ys }]+{-# INLINE mkListPatVec #-}++-- | Create a (non-overloaded) literal pattern+mkLitPattern :: HsLit GhcTc -> Pattern+mkLitPattern lit = PmLit { pm_lit_lit = PmSLit lit }+{-# INLINE mkLitPattern #-}++-- -----------------------------------------------------------------------+-- * Transform (Pat Id) into of (PmPat Id)++translatePat :: FamInstEnvs -> Pat GhcTc -> DsM PatVec+translatePat fam_insts pat = case pat of+  WildPat  ty  -> mkPmVars [ty]+  VarPat _ id  -> return [PmVar (unLoc id)]+  ParPat _ p   -> translatePat fam_insts (unLoc p)+  LazyPat _ _  -> mkPmVars [hsPatType pat] -- like a variable++  -- ignore strictness annotations for now+  BangPat _ p  -> translatePat fam_insts (unLoc p)++  AsPat _ lid p -> do+     -- Note [Translating As Patterns]+    ps <- translatePat fam_insts (unLoc p)+    let [e] = map vaToPmExpr (coercePatVec ps)+        g   = PmGrd [PmVar (unLoc lid)] e+    return (ps ++ [g])++  SigPat _ p _ty -> translatePat fam_insts (unLoc p)++  -- See Note [Translate CoPats]+  CoPat _ wrapper p ty+    | isIdHsWrapper wrapper                   -> translatePat fam_insts p+    | WpCast co <-  wrapper, isReflexiveCo co -> translatePat fam_insts p+    | otherwise -> do+        ps      <- translatePat fam_insts p+        (xp,xe) <- mkPmId2Forms ty+        g <- mkGuard ps (mkHsWrap wrapper (unLoc xe))+        return [xp,g]++  -- (n + k)  ===>   x (True <- x >= k) (n <- x-k)+  NPlusKPat ty (dL->L _ _n) _k1 _k2 _ge _minus -> mkCanFailPmPat ty++  -- (fun -> pat)   ===>   x (pat <- fun x)+  ViewPat arg_ty lexpr lpat -> do+    ps <- translatePat fam_insts (unLoc lpat)+    -- See Note [Guards and Approximation]+    res <- allM cantFailPattern ps+    case res of+      True  -> do+        (xp,xe) <- mkPmId2Forms arg_ty+        g <- mkGuard ps (HsApp noExt lexpr xe)+        return [xp,g]+      False -> mkCanFailPmPat arg_ty++  -- list+  ListPat (ListPatTc ty Nothing) ps -> do+    foldr (mkListPatVec ty) [nilPattern ty]+      <$> translatePatVec fam_insts (map unLoc ps)++  -- overloaded list+  ListPat (ListPatTc _elem_ty (Just (pat_ty, _to_list))) lpats -> do+    dflags <- getDynFlags+    if xopt LangExt.RebindableSyntax dflags+       then mkCanFailPmPat pat_ty+       else case splitListTyConApp_maybe pat_ty of+              Just e_ty -> translatePat fam_insts+                                        (ListPat (ListPatTc e_ty Nothing) lpats)+              Nothing   -> mkCanFailPmPat pat_ty+    -- (a) In the presence of RebindableSyntax, we don't know anything about+    --     `toList`, we should treat `ListPat` as any other view pattern.+    --+    -- (b) In the absence of RebindableSyntax,+    --     - If the pat_ty is `[a]`, then we treat the overloaded list pattern+    --       as ordinary list pattern. Although we can give an instance+    --       `IsList [Int]` (more specific than the default `IsList [a]`), in+    --       practice, we almost never do that. We assume the `_to_list` is+    --       the `toList` from `instance IsList [a]`.+    --+    --     - Otherwise, we treat the `ListPat` as ordinary view pattern.+    --+    -- See #14547, especially comment#9 and comment#10.+    --+    -- Here we construct CanFailPmPat directly, rather can construct a view+    -- pattern and do further translation as an optimization, for the reason,+    -- see Note [Guards and Approximation].++  ConPatOut { pat_con     = (dL->L _ con)+            , pat_arg_tys = arg_tys+            , pat_tvs     = ex_tvs+            , pat_dicts   = dicts+            , pat_args    = ps } -> do+    groups <- allCompleteMatches con arg_tys+    case groups of+      [] -> mkCanFailPmPat (conLikeResTy con arg_tys)+      _  -> do+        args <- translateConPatVec fam_insts arg_tys ex_tvs con ps+        return [PmCon { pm_con_con     = con+                      , pm_con_arg_tys = arg_tys+                      , pm_con_tvs     = ex_tvs+                      , pm_con_dicts   = dicts+                      , pm_con_args    = args }]++  -- See Note [Translate Overloaded Literal for Exhaustiveness Checking]+  NPat _ (dL->L _ olit) mb_neg _+    | OverLit (OverLitTc False ty) (HsIsString src s) _ <- olit+    , isStringTy ty ->+        foldr (mkListPatVec charTy) [nilPattern charTy] <$>+          translatePatVec fam_insts+            (map (LitPat noExt . HsChar src) (unpackFS s))+    | otherwise -> return [PmLit { pm_lit_lit = PmOLit (isJust mb_neg) olit }]++  -- See Note [Translate Overloaded Literal for Exhaustiveness Checking]+  LitPat _ lit+    | HsString src s <- lit ->+        foldr (mkListPatVec charTy) [nilPattern charTy] <$>+          translatePatVec fam_insts+            (map (LitPat noExt . HsChar src) (unpackFS s))+    | otherwise -> return [mkLitPattern lit]++  TuplePat tys ps boxity -> do+    tidy_ps <- translatePatVec fam_insts (map unLoc ps)+    let tuple_con = RealDataCon (tupleDataCon boxity (length ps))+    return [vanillaConPattern tuple_con tys (concat tidy_ps)]++  SumPat ty p alt arity -> do+    tidy_p <- translatePat fam_insts (unLoc p)+    let sum_con = RealDataCon (sumDataCon alt arity)+    return [vanillaConPattern sum_con ty tidy_p]++  -- --------------------------------------------------------------------------+  -- Not supposed to happen+  ConPatIn  {} -> panic "Check.translatePat: ConPatIn"+  SplicePat {} -> panic "Check.translatePat: SplicePat"+  XPat      {} -> panic "Check.translatePat: XPat"++{- Note [Translate Overloaded Literal for Exhaustiveness Checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The translation of @NPat@ in exhaustiveness checker is a bit different+from translation in pattern matcher.++  * In pattern matcher (see `tidyNPat' in deSugar/MatchLit.hs), we+    translate integral literals to HsIntPrim or HsWordPrim and translate+    overloaded strings to HsString.++  * In exhaustiveness checker, in `genCaseTmCs1/genCaseTmCs2`, we use+    `lhsExprToPmExpr` to generate uncovered set. In `hsExprToPmExpr`,+    however we generate `PmOLit` for HsOverLit, rather than refine+    `HsOverLit` inside `NPat` to HsIntPrim/HsWordPrim. If we do+    the same thing in `translatePat` as in `tidyNPat`, the exhaustiveness+    checker will fail to match the literals patterns correctly. See+    #14546.++  In Note [Undecidable Equality for Overloaded Literals], we say: "treat+  overloaded literals that look different as different", but previously we+  didn't do such things.++  Now, we translate the literal value to match and the literal patterns+  consistently:++  * For integral literals, we parse both the integral literal value and+    the patterns as OverLit HsIntegral. For example:++      case 0::Int of+          0 -> putStrLn "A"+          1 -> putStrLn "B"+          _ -> putStrLn "C"++    When checking the exhaustiveness of pattern matching, we translate the 0+    in value position as PmOLit, but translate the 0 and 1 in pattern position+    as PmSLit. The inconsistency leads to the failure of eqPmLit to detect the+    equality and report warning of "Pattern match is redundant" on pattern 0,+    as reported in #14546. In this patch we remove the specialization of+    OverLit patterns, and keep the overloaded number literal in pattern as it+    is to maintain the consistency. We know nothing about the `fromInteger`+    method (see Note [Undecidable Equality for Overloaded Literals]). Now we+    can capture the exhaustiveness of pattern 0 and the redundancy of pattern+    1 and _.++  * For string literals, we parse the string literals as HsString. When+    OverloadedStrings is enabled, it further be turned as HsOverLit HsIsString.+    For example:++      case "foo" of+          "foo" -> putStrLn "A"+          "bar" -> putStrLn "B"+          "baz" -> putStrLn "C"++    Previously, the overloaded string values are translated to PmOLit and the+    non-overloaded string values are translated to PmSLit. However the string+    patterns, both overloaded and non-overloaded, are translated to list of+    characters. The inconsistency leads to wrong warnings about redundant and+    non-exhaustive pattern matching warnings, as reported in #14546.++    In order to catch the redundant pattern in following case:++      case "foo" of+          ('f':_) -> putStrLn "A"+          "bar" -> putStrLn "B"++    in this patch, we translate non-overloaded string literals, both in value+    position and pattern position, as list of characters. For overloaded string+    literals, we only translate it to list of characters only when it's type+    is stringTy, since we know nothing about the toString methods. But we know+    that if two overloaded strings are syntax equal, then they are equal. Then+    if it's type is not stringTy, we just translate it to PmOLit. We can still+    capture the exhaustiveness of pattern "foo" and the redundancy of pattern+    "bar" and "baz" in the following code:++      {-# LANGUAGE OverloadedStrings #-}+      main = do+        case "foo" of+            "foo" -> putStrLn "A"+            "bar" -> putStrLn "B"+            "baz" -> putStrLn "C"++  We must ensure that doing the same translation to literal values and patterns+  in `translatePat` and `hsExprToPmExpr`. The previous inconsistent work led to+  #14546.+-}++-- | Translate a list of patterns (Note: each pattern is translated+-- to a pattern vector but we do not concatenate the results).+translatePatVec :: FamInstEnvs -> [Pat GhcTc] -> DsM [PatVec]+translatePatVec fam_insts pats = mapM (translatePat fam_insts) pats++-- | Translate a constructor pattern+translateConPatVec :: FamInstEnvs -> [Type] -> [TyVar]+                   -> ConLike -> HsConPatDetails GhcTc -> DsM PatVec+translateConPatVec fam_insts _univ_tys _ex_tvs _ (PrefixCon ps)+  = concat <$> translatePatVec fam_insts (map unLoc ps)+translateConPatVec fam_insts _univ_tys _ex_tvs _ (InfixCon p1 p2)+  = concat <$> translatePatVec fam_insts (map unLoc [p1,p2])+translateConPatVec fam_insts  univ_tys  ex_tvs c (RecCon (HsRecFields fs _))+    -- Nothing matched. Make up some fresh term variables+  | null fs        = mkPmVars arg_tys+    -- The data constructor was not defined using record syntax. For the+    -- pattern to be in record syntax it should be empty (e.g. Just {}).+    -- So just like the previous case.+  | null orig_lbls = ASSERT(null matched_lbls) mkPmVars arg_tys+    -- Some of the fields appear, in the original order (there may be holes).+    -- Generate a simple constructor pattern and make up fresh variables for+    -- the rest of the fields+  | matched_lbls `subsetOf` orig_lbls+  = ASSERT(orig_lbls `equalLength` arg_tys)+      let translateOne (lbl, ty) = case lookup lbl matched_pats of+            Just p  -> translatePat fam_insts p+            Nothing -> mkPmVars [ty]+      in  concatMapM translateOne (zip orig_lbls arg_tys)+    -- The fields that appear are not in the correct order. Make up fresh+    -- variables for all fields and add guards after matching, to force the+    -- evaluation in the correct order.+  | otherwise = do+      arg_var_pats    <- mkPmVars arg_tys+      translated_pats <- forM matched_pats $ \(x,pat) -> do+        pvec <- translatePat fam_insts pat+        return (x, pvec)++      let zipped = zip orig_lbls [ x | PmVar x <- arg_var_pats ]+          guards = map (\(name,pvec) -> case lookup name zipped of+                            Just x  -> PmGrd pvec (PmExprVar (idName x))+                            Nothing -> panic "translateConPatVec: lookup")+                       translated_pats++      return (arg_var_pats ++ guards)+  where+    -- The actual argument types (instantiated)+    arg_tys = conLikeInstOrigArgTys c (univ_tys ++ mkTyVarTys ex_tvs)++    -- Some label information+    orig_lbls    = map flSelector $ conLikeFieldLabels c+    matched_pats = [ (getName (unLoc (hsRecFieldId x)), unLoc (hsRecFieldArg x))+                   | (dL->L _ x) <- fs]+    matched_lbls = [ name | (name, _pat) <- matched_pats ]++    subsetOf :: Eq a => [a] -> [a] -> Bool+    subsetOf []     _  = True+    subsetOf (_:_)  [] = False+    subsetOf (x:xs) (y:ys)+      | x == y    = subsetOf    xs  ys+      | otherwise = subsetOf (x:xs) ys++-- Translate a single match+translateMatch :: FamInstEnvs -> LMatch GhcTc (LHsExpr GhcTc)+               -> DsM (PatVec,[PatVec])+translateMatch fam_insts (dL->L _ (Match { m_pats = lpats, m_grhss = grhss })) =+  do+  pats'   <- concat <$> translatePatVec fam_insts pats+  guards' <- mapM (translateGuards fam_insts) guards+  return (pats', guards')+  where+    extractGuards :: LGRHS GhcTc (LHsExpr GhcTc) -> [GuardStmt GhcTc]+    extractGuards (dL->L _ (GRHS _ gs _)) = map unLoc gs+    extractGuards _                       = panic "translateMatch"++    pats   = map unLoc lpats+    guards = map extractGuards (grhssGRHSs grhss)+translateMatch _ _ = panic "translateMatch"++-- -----------------------------------------------------------------------+-- * Transform source guards (GuardStmt Id) to PmPats (Pattern)++-- | Translate a list of guard statements to a pattern vector+translateGuards :: FamInstEnvs -> [GuardStmt GhcTc] -> DsM PatVec+translateGuards fam_insts guards = do+  all_guards <- concat <$> mapM (translateGuard fam_insts) guards+  let+    shouldKeep :: Pattern -> DsM Bool+    shouldKeep p+      | PmVar {} <- p = pure True+      | PmCon {} <- p = (&&)+                          <$> singleMatchConstructor (pm_con_con p) (pm_con_arg_tys p)+                          <*> allM shouldKeep (pm_con_args p)+    shouldKeep (PmGrd pv e)+      | isNotPmExprOther e = pure True  -- expensive but we want it+      | otherwise          = allM shouldKeep pv+    shouldKeep _other_pat  = pure False -- let the rest..++  all_handled <- allM shouldKeep all_guards+  -- It should have been @pure all_guards@ but it is too expressive.+  -- Since the term oracle does not handle all constraints we generate,+  -- we (hackily) replace all constraints the oracle cannot handle with a+  -- single one (we need to know if there is a possibility of failure).+  -- See Note [Guards and Approximation] for all guard-related approximations+  -- we implement.+  if all_handled+    then pure all_guards+    else do+      kept <- filterM shouldKeep all_guards+      pure (PmFake : kept)++-- | Check whether a pattern can fail to match+cantFailPattern :: Pattern -> DsM Bool+cantFailPattern PmVar {}      = pure True+cantFailPattern PmCon { pm_con_con = c, pm_con_arg_tys = tys, pm_con_args = ps}+  = (&&) <$> singleMatchConstructor c tys <*> allM cantFailPattern ps+cantFailPattern (PmGrd pv _e) = allM cantFailPattern pv+cantFailPattern _             = pure False++-- | Translate a guard statement to Pattern+translateGuard :: FamInstEnvs -> GuardStmt GhcTc -> DsM PatVec+translateGuard fam_insts guard = case guard of+  BodyStmt _   e _ _ -> translateBoolGuard e+  LetStmt  _   binds -> translateLet (unLoc binds)+  BindStmt _ p e _ _ -> translateBind fam_insts p e+  LastStmt        {} -> panic "translateGuard LastStmt"+  ParStmt         {} -> panic "translateGuard ParStmt"+  TransStmt       {} -> panic "translateGuard TransStmt"+  RecStmt         {} -> panic "translateGuard RecStmt"+  ApplicativeStmt {} -> panic "translateGuard ApplicativeLastStmt"+  XStmtLR         {} -> panic "translateGuard RecStmt"++-- | Translate let-bindings+translateLet :: HsLocalBinds GhcTc -> DsM PatVec+translateLet _binds = return []++-- | Translate a pattern guard+translateBind :: FamInstEnvs -> LPat GhcTc -> LHsExpr GhcTc -> DsM PatVec+translateBind fam_insts (dL->L _ p) e = do+  ps <- translatePat fam_insts p+  g <- mkGuard ps (unLoc e)+  return [g]++-- | Translate a boolean guard+translateBoolGuard :: LHsExpr GhcTc -> DsM PatVec+translateBoolGuard e+  | isJust (isTrueLHsExpr e) = return []+    -- The formal thing to do would be to generate (True <- True)+    -- but it is trivial to solve so instead we give back an empty+    -- PatVec for efficiency+  | otherwise = (:[]) <$> mkGuard [truePattern] (unLoc e)++{- Note [Guards and Approximation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Even if the algorithm is really expressive, the term oracle we use is not.+Hence, several features are not translated *properly* but we approximate.+The list includes:++1. View Patterns+----------------+A view pattern @(f -> p)@ should be translated to @x (p <- f x)@. The term+oracle does not handle function applications so we know that the generated+constraints will not be handled at the end. Hence, we distinguish between two+cases:+  a) Pattern @p@ cannot fail. Then this is just a binding and we do the *right+     thing*.+  b) Pattern @p@ can fail. This means that when checking the guard, we will+     generate several cases, with no useful information. E.g.:++       h (f -> [a,b]) = ...+       h x ([a,b] <- f x) = ...++       uncovered set = { [x |> { False ~ (f x ~ [])            }]+                       , [x |> { False ~ (f x ~ (t1:[]))       }]+                       , [x |> { False ~ (f x ~ (t1:t2:t3:t4)) }] }++     So we have two problems:+       1) Since we do not print the constraints in the general case (they may+          be too many), the warning will look like this:++            Pattern match(es) are non-exhaustive+            In an equation for `h':+                Patterns not matched:+                    _+                    _+                    _+          Which is not short and not more useful than a single underscore.+       2) The size of the uncovered set increases a lot, without gaining more+          expressivity in our warnings.++     Hence, in this case, we replace the guard @([a,b] <- f x)@ with a *dummy*+     @PmFake@: @True <- _@. That is, we record that there is a possibility+     of failure but we minimize it to a True/False. This generates a single+     warning and much smaller uncovered sets.++2. Overloaded Lists+-------------------+An overloaded list @[...]@ should be translated to @x ([...] <- toList x)@. The+problem is exactly like above, as its solution. For future reference, the code+below is the *right thing to do*:++   ListPat (ListPatTc elem_ty (Just (pat_ty, _to_list))) lpats+     otherwise -> do+       (xp, xe) <- mkPmId2Forms pat_ty+       ps       <- translatePatVec (map unLoc lpats)+       let pats = foldr (mkListPatVec elem_ty) [nilPattern elem_ty] ps+           g    = mkGuard pats (HsApp (noLoc to_list) xe)+       return [xp,g]++3. Overloaded Literals+----------------------+The case with literals is a bit different. a literal @l@ should be translated+to @x (True <- x == from l)@. Since we want to have better warnings for+overloaded literals as it is a very common feature, we treat them differently.+They are mainly covered in Note [Undecidable Equality for Overloaded Literals]+in PmExpr.++4. N+K Patterns & Pattern Synonyms+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An n+k pattern (n+k) should be translated to @x (True <- x >= k) (n <- x-k)@.+Since the only pattern of the three that causes failure is guard @(n <- x-k)@,+and has two possible outcomes. Hence, there is no benefit in using a dummy and+we implement the proper thing. Pattern synonyms are simply not implemented yet.+Hence, to be conservative, we generate a dummy pattern, assuming that the+pattern can fail.++5. Actual Guards+----------------+During translation, boolean guards and pattern guards are translated properly.+Let bindings though are omitted by function @translateLet@. Since they are lazy+bindings, we do not actually want to generate a (strict) equality (like we do+in the pattern bind case). Hence, we safely drop them.++Additionally, top-level guard translation (performed by @translateGuards@)+replaces guards that cannot be reasoned about (like the ones we described in+1-4) with a single @PmFake@ to record the possibility of failure to match.++Note [Translate CoPats]+~~~~~~~~~~~~~~~~~~~~~~~+The pattern match checker did not know how to handle coerced patterns `CoPat`+efficiently, which gave rise to #11276. The original approach translated+`CoPat`s:++    pat |> co    ===>    x (pat <- (e |> co))++Instead, we now check whether the coercion is a hole or if it is just refl, in+which case we can drop it. Unfortunately, data families generate useful+coercions so guards are still generated in these cases and checking data+families is not really efficient.++%************************************************************************+%*                                                                      *+                 Utilities for Pattern Match Checking+%*                                                                      *+%************************************************************************+-}++-- ----------------------------------------------------------------------------+-- * Basic utilities++-- | Get the type out of a PmPat. For guard patterns (ps <- e) we use the type+-- of the first (or the single -WHEREVER IT IS- valid to use?) pattern+pmPatType :: PmPat p -> Type+pmPatType (PmCon { pm_con_con = con, pm_con_arg_tys = tys })+  = conLikeResTy con tys+pmPatType (PmVar  { pm_var_id  = x }) = idType x+pmPatType (PmLit  { pm_lit_lit = l }) = pmLitType l+pmPatType (PmNLit { pm_lit_id  = x }) = idType x+pmPatType (PmGrd  { pm_grd_pv  = pv })+  = ASSERT(patVecArity pv == 1) (pmPatType p)+  where Just p = find ((==1) . patternArity) pv+pmPatType PmFake = pmPatType truePattern++-- | Information about a conlike that is relevant to coverage checking.+-- It is called an \"inhabitation candidate\" since it is a value which may+-- possibly inhabit some type, but only if its term constraint ('ic_tm_ct')+-- and type constraints ('ic_ty_cs') are permitting, and if all of its strict+-- argument types ('ic_strict_arg_tys') are inhabitable.+-- See @Note [Extensions to GADTs Meet Their Match]@.+data InhabitationCandidate =+  InhabitationCandidate+  { ic_val_abs        :: ValAbs+  , ic_tm_ct          :: ComplexEq+  , ic_ty_cs          :: Bag EvVar+  , ic_strict_arg_tys :: [Type]+  }++{-+Note [Extensions to GADTs Meet Their Match]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The GADTs Meet Their Match paper presents the formalism that GHC's coverage+checker adheres to. Since the paper's publication, there have been some+additional features added to the coverage checker which are not described in+the paper. This Note serves as a reference for these new features.++-----+-- Strict argument type constraints+-----++In the ConVar case of clause processing, each conlike K traditionally+generates two different forms of constraints:++* A term constraint (e.g., x ~ K y1 ... yn)+* Type constraints from the conlike's context (e.g., if K has type+  forall bs. Q => s1 .. sn -> T tys, then Q would be its type constraints)++As it turns out, these alone are not enough to detect a certain class of+unreachable code. Consider the following example (adapted from #15305):++  data K = K1 | K2 !Void++  f :: K -> ()+  f K1 = ()++Even though `f` doesn't match on `K2`, `f` is exhaustive in its patterns. Why?+Because it's impossible to construct a terminating value of type `K` using the+`K2` constructor, and thus it's impossible for `f` to ever successfully match+on `K2`.++The reason is because `K2`'s field of type `Void` is //strict//. Because there+are no terminating values of type `Void`, any attempt to construct something+using `K2` will immediately loop infinitely or throw an exception due to the+strictness annotation. (If the field were not strict, then `f` could match on,+say, `K2 undefined` or `K2 (let x = x in x)`.)++Since neither the term nor type constraints mentioned above take strict+argument types into account, we make use of the `nonVoid` function to+determine whether a strict type is inhabitable by a terminating value or not.++`nonVoid ty` returns True when either:+1. `ty` has at least one InhabitationCandidate for which both its term and type+   constraints are satifiable, and `nonVoid` returns `True` for all of the+   strict argument types in that InhabitationCandidate.+2. We're unsure if it's inhabited by a terminating value.++`nonVoid ty` returns False when `ty` is definitely uninhabited by anything+(except bottom). Some examples:++* `nonVoid Void` returns False, since Void has no InhabitationCandidates.+  (This is what lets us discard the `K2` constructor in the earlier example.)+* `nonVoid (Int :~: Int)` returns True, since it has an InhabitationCandidate+  (through the Refl constructor), and its term constraint (x ~ Refl) and+  type constraint (Int ~ Int) are satisfiable.+* `nonVoid (Int :~: Bool)` returns False. Although it has an+  InhabitationCandidate (by way of Refl), its type constraint (Int ~ Bool) is+  not satisfiable.+* Given the following definition of `MyVoid`:++    data MyVoid = MkMyVoid !Void++  `nonVoid MyVoid` returns False. The InhabitationCandidate for the MkMyVoid+  constructor contains Void as a strict argument type, and since `nonVoid Void`+  returns False, that InhabitationCandidate is discarded, leaving no others.++* Performance considerations++We must be careful when recursively calling `nonVoid` on the strict argument+types of an InhabitationCandidate, because doing so naïvely can cause GHC to+fall into an infinite loop. Consider the following example:++  data Abyss = MkAbyss !Abyss++  stareIntoTheAbyss :: Abyss -> a+  stareIntoTheAbyss x = case x of {}++In principle, stareIntoTheAbyss is exhaustive, since there is no way to+construct a terminating value using MkAbyss. However, both the term and type+constraints for MkAbyss are satisfiable, so the only way one could determine+that MkAbyss is unreachable is to check if `nonVoid Abyss` returns False.+There is only one InhabitationCandidate for Abyss—MkAbyss—and both its term+and type constraints are satisfiable, so we'd need to check if `nonVoid Abyss`+returns False... and now we've entered an infinite loop!++To avoid this sort of conundrum, `nonVoid` uses a simple test to detect the+presence of recursive types (through `checkRecTc`), and if recursion is+detected, we bail out and conservatively assume that the type is inhabited by+some terminating value. This avoids infinite loops at the expense of making+the coverage checker incomplete with respect to functions like+stareIntoTheAbyss above. Then again, the same problem occurs with recursive+newtypes, like in the following code:++  newtype Chasm = MkChasm Chasm++  gazeIntoTheChasm :: Chasm -> a+  gazeIntoTheChasm x = case x of {} -- Erroneously warned as non-exhaustive++So this limitation is somewhat understandable.++Note that even with this recursion detection, there is still a possibility that+`nonVoid` can run in exponential time. Consider the following data type:++  data T = MkT !T !T !T++If we call `nonVoid` on each of its fields, that will require us to once again+check if `MkT` is inhabitable in each of those three fields, which in turn will+require us to check if `MkT` is inhabitable again... As you can see, the+branching factor adds up quickly, and if the recursion depth limit is, say,+100, then `nonVoid T` will effectively take forever.++To mitigate this, we check the branching factor every time we are about to call+`nonVoid` on a list of strict argument types. If the branching factor exceeds 1+(i.e., if there is potential for exponential runtime), then we limit the+maximum recursion depth to 1 to mitigate the problem. If the branching factor+is exactly 1 (i.e., we have a linear chain instead of a tree), then it's okay+to stick with a larger maximum recursion depth.++Another microoptimization applies to data types like this one:++  data S a = ![a] !T++Even though there is a strict field of type [a], it's quite silly to call+nonVoid on it, since it's "obvious" that it is inhabitable. To make this+intuition formal, we say that a type is definitely inhabitable (DI) if:++  * It has at least one constructor C such that:+    1. C has no equality constraints (since they might be unsatisfiable)+    2. C has no strict argument types (since they might be uninhabitable)++It's relatively cheap to cheap if a type is DI, so before we call `nonVoid`+on a list of strict argument types, we filter out all of the DI ones.+-}++instance Outputable InhabitationCandidate where+  ppr (InhabitationCandidate { ic_val_abs = va, ic_tm_ct = tm_ct+                             , ic_ty_cs = ty_cs+                             , ic_strict_arg_tys = strict_arg_tys }) =+    text "InhabitationCandidate" <+>+      vcat [ text "ic_val_abs        =" <+> ppr va+           , text "ic_tm_ct          =" <+> ppr tm_ct+           , text "ic_ty_cs          =" <+> ppr ty_cs+           , text "ic_strict_arg_tys =" <+> ppr strict_arg_tys ]++-- | Generate an 'InhabitationCandidate' for a given conlike (generate+-- fresh variables of the appropriate type for arguments)+mkOneConFull :: Id -> ConLike -> DsM InhabitationCandidate+--  *  x :: T tys, where T is an algebraic data type+--     NB: in the case of a data family, T is the *representation* TyCon+--     e.g.   data instance T (a,b) = T1 a b+--       leads to+--            data TPair a b = T1 a b  -- The "representation" type+--       It is TPair, not T, that is given to mkOneConFull+--+--  * 'con' K is a conlike of data type T+--+-- After instantiating the universal tyvars of K we get+--          K tys :: forall bs. Q => s1 .. sn -> T tys+--+-- Suppose y1 is a strict field. Then we get+-- Results: ic_val_abs:        K (y1::s1) .. (yn::sn)+--          ic_tm_ct:          x ~ K y1..yn+--          ic_ty_cs:          Q+--          ic_strict_arg_tys: [s1]+mkOneConFull x con = do+  let res_ty  = idType x+      (univ_tvs, ex_tvs, eq_spec, thetas, _req_theta , arg_tys, con_res_ty)+        = conLikeFullSig con+      arg_is_banged = map isBanged $ conLikeImplBangs con+      tc_args = tyConAppArgs res_ty+      subst1  = case con of+                  RealDataCon {} -> zipTvSubst univ_tvs tc_args+                  PatSynCon {}   -> expectJust "mkOneConFull" (tcMatchTy con_res_ty res_ty)+                                    -- See Note [Pattern synonym result type] in PatSyn++  (subst, ex_tvs') <- cloneTyVarBndrs subst1 ex_tvs <$> getUniqueSupplyM++  let arg_tys' = substTys subst arg_tys+  -- Fresh term variables (VAs) as arguments to the constructor+  arguments <-  mapM mkPmVar arg_tys'+  -- All constraints bound by the constructor (alpha-renamed)+  let theta_cs = substTheta subst (eqSpecPreds eq_spec ++ thetas)+  evvars <- mapM (nameType "pm") theta_cs+  let con_abs  = PmCon { pm_con_con     = con+                       , pm_con_arg_tys = tc_args+                       , pm_con_tvs     = ex_tvs'+                       , pm_con_dicts   = evvars+                       , pm_con_args    = arguments }+      strict_arg_tys = filterByList arg_is_banged arg_tys'+  return $ InhabitationCandidate+           { ic_val_abs        = con_abs+           , ic_tm_ct          = (PmExprVar (idName x), vaToPmExpr con_abs)+           , ic_ty_cs          = listToBag evvars+           , ic_strict_arg_tys = strict_arg_tys+           }++-- ----------------------------------------------------------------------------+-- * More smart constructors and fresh variable generation++-- | Create a guard pattern+mkGuard :: PatVec -> HsExpr GhcTc -> DsM Pattern+mkGuard pv e = do+  res <- allM cantFailPattern pv+  let expr = hsExprToPmExpr e+  tracePmD "mkGuard" (vcat [ppr pv, ppr e, ppr res, ppr expr])+  if | res                    -> pure (PmGrd pv expr)+     | PmExprOther {} <- expr -> pure PmFake+     | otherwise              -> pure (PmGrd pv expr)++-- | Create a term equality of the form: `(False ~ (x ~ lit))`+mkNegEq :: Id -> PmLit -> ComplexEq+mkNegEq x l = (falsePmExpr, PmExprVar (idName x) `PmExprEq` PmExprLit l)+{-# INLINE mkNegEq #-}++-- | Create a term equality of the form: `(x ~ lit)`+mkPosEq :: Id -> PmLit -> ComplexEq+mkPosEq x l = (PmExprVar (idName x), PmExprLit l)+{-# INLINE mkPosEq #-}++-- | Create a term equality of the form: `(x ~ x)`+-- (always discharged by the term oracle)+mkIdEq :: Id -> ComplexEq+mkIdEq x = (PmExprVar name, PmExprVar name)+  where name = idName x+{-# INLINE mkIdEq #-}++-- | Generate a variable pattern of a given type+mkPmVar :: Type -> DsM (PmPat p)+mkPmVar ty = PmVar <$> mkPmId ty+{-# INLINE mkPmVar #-}++-- | Generate many variable patterns, given a list of types+mkPmVars :: [Type] -> DsM PatVec+mkPmVars tys = mapM mkPmVar tys+{-# INLINE mkPmVars #-}++-- | Generate a fresh `Id` of a given type+mkPmId :: Type -> DsM Id+mkPmId ty = getUniqueM >>= \unique ->+  let occname = mkVarOccFS $ fsLit "$pm"+      name    = mkInternalName unique occname noSrcSpan+  in  return (mkLocalId name ty)++-- | Generate a fresh term variable of a given and return it in two forms:+-- * A variable pattern+-- * A variable expression+mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc)+mkPmId2Forms ty = do+  x <- mkPmId ty+  return (PmVar x, noLoc (HsVar noExt (noLoc x)))++-- ----------------------------------------------------------------------------+-- * Converting between Value Abstractions, Patterns and PmExpr++-- | Convert a value abstraction an expression+vaToPmExpr :: ValAbs -> PmExpr+vaToPmExpr (PmCon  { pm_con_con = c, pm_con_args = ps })+  = PmExprCon c (map vaToPmExpr ps)+vaToPmExpr (PmVar  { pm_var_id  = x }) = PmExprVar (idName x)+vaToPmExpr (PmLit  { pm_lit_lit = l }) = PmExprLit l+vaToPmExpr (PmNLit { pm_lit_id  = x }) = PmExprVar (idName x)++-- | Convert a pattern vector to a list of value abstractions by dropping the+-- guards (See Note [Translating As Patterns])+coercePatVec :: PatVec -> [ValAbs]+coercePatVec pv = concatMap coercePmPat pv++-- | Convert a pattern to a list of value abstractions (will be either an empty+-- list if the pattern is a guard pattern, or a singleton list in all other+-- cases) by dropping the guards (See Note [Translating As Patterns])+coercePmPat :: Pattern -> [ValAbs]+coercePmPat (PmVar { pm_var_id  = x }) = [PmVar { pm_var_id  = x }]+coercePmPat (PmLit { pm_lit_lit = l }) = [PmLit { pm_lit_lit = l }]+coercePmPat (PmCon { pm_con_con = con, pm_con_arg_tys = arg_tys+                   , pm_con_tvs = tvs, pm_con_dicts = dicts+                   , pm_con_args = args })+  = [PmCon { pm_con_con  = con, pm_con_arg_tys = arg_tys+           , pm_con_tvs  = tvs, pm_con_dicts = dicts+           , pm_con_args = coercePatVec args }]+coercePmPat (PmGrd {}) = [] -- drop the guards+coercePmPat PmFake     = [] -- drop the guards++-- | Check whether a 'ConLike' has the /single match/ property, i.e. whether+-- it is the only possible match in the given context. See also+-- 'allCompleteMatches' and Note [Single match constructors].+singleMatchConstructor :: ConLike -> [Type] -> DsM Bool+singleMatchConstructor cl tys =+  any (isSingleton . snd) <$> allCompleteMatches cl tys++{-+Note [Single match constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When translating pattern guards for consumption by the checker, we desugar+every pattern guard that might fail ('cantFailPattern') to 'PmFake'+(True <- _). Which patterns can't fail? Exactly those that only match on+'singleMatchConstructor's.++Here are a few examples:+  * @f a | (a, b) <- foo a = 42@: Product constructors are generally+    single match. This extends to single constructors of GADTs like 'Refl'.+  * If @f | Id <- id () = 42@, where @pattern Id = ()@ and 'Id' is part of a+    singleton `COMPLETE` set, then 'Id' has the single match property.++In effect, we can just enumerate 'allCompleteMatches' and check if the conlike+occurs as a singleton set.+There's the chance that 'Id' is part of multiple `COMPLETE` sets. That's+irrelevant; If the user specified a singleton set, it is single-match.++Note that this doesn't really take into account incoming type constraints;+It might be obvious from type context that a particular GADT constructor has+the single-match property. We currently don't (can't) check this in the+translation step. See #15753 for why this yields surprising results.+-}++-- | For a given conlike, finds all the sets of patterns which could+-- be relevant to that conlike by consulting the result type.+--+-- These come from two places.+--  1. From data constructors defined with the result type constructor.+--  2. From `COMPLETE` pragmas which have the same type as the result+--     type constructor. Note that we only use `COMPLETE` pragmas+--     *all* of whose pattern types match. See #14135+allCompleteMatches :: ConLike -> [Type] -> DsM [(Provenance, [ConLike])]+allCompleteMatches cl tys = do+  let fam = case cl of+           RealDataCon dc ->+            [(FromBuiltin, map RealDataCon (tyConDataCons (dataConTyCon dc)))]+           PatSynCon _    -> []+      ty  = conLikeResTy cl tys+  pragmas <- case splitTyConApp_maybe ty of+               Just (tc, _) -> dsGetCompleteMatches tc+               Nothing      -> return []+  let fams cm = (FromComplete,) <$>+                mapM dsLookupConLike (completeMatchConLikes cm)+  from_pragma <- filter (\(_,m) -> isValidCompleteMatch ty m) <$>+                mapM fams pragmas+  let final_groups = fam ++ from_pragma+  return final_groups+    where+      -- Check that all the pattern synonym return types in a `COMPLETE`+      -- pragma subsume the type we're matching.+      -- See Note [Filtering out non-matching COMPLETE sets]+      isValidCompleteMatch :: Type -> [ConLike] -> Bool+      isValidCompleteMatch ty = all go+        where+          go (RealDataCon {}) = True+          go (PatSynCon psc)  = isJust $ flip tcMatchTy ty $ patSynResTy+                                       $ patSynSig psc++          patSynResTy (_, _, _, _, _, res_ty) = res_ty++{-+Note [Filtering out non-matching COMPLETE sets]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Currently, conlikes in a COMPLETE set are simply grouped by the+type constructor heading the return type. This is nice and simple, but it does+mean that there are scenarios when a COMPLETE set might be incompatible with+the type of a scrutinee. For instance, consider (from #14135):++  data Foo a = Foo1 a | Foo2 a++  pattern MyFoo2 :: Int -> Foo Int+  pattern MyFoo2 i = Foo2 i++  {-# COMPLETE Foo1, MyFoo2 #-}++  f :: Foo a -> a+  f (Foo1 x) = x++`f` has an incomplete pattern-match, so when choosing which constructors to+report as unmatched in a warning, GHC must choose between the original set of+data constructors {Foo1, Foo2} and the COMPLETE set {Foo1, MyFoo2}. But observe+that GHC shouldn't even consider the COMPLETE set as a possibility: the return+type of MyFoo2, Foo Int, does not match the type of the scrutinee, Foo a, since+there's no substitution `s` such that s(Foo Int) = Foo a.++To ensure that GHC doesn't pick this COMPLETE set, it checks each pattern+synonym constructor's return type matches the type of the scrutinee, and if one+doesn't, then we remove the whole COMPLETE set from consideration.++One might wonder why GHC only checks /pattern synonym/ constructors, and not+/data/ constructors as well. The reason is because that the type of a+GADT constructor very well may not match the type of a scrutinee, and that's+OK. Consider this example (from #14059):++  data SBool (z :: Bool) where+    SFalse :: SBool False+    STrue  :: SBool True++  pattern STooGoodToBeTrue :: forall (z :: Bool). ()+                           => z ~ True+                           => SBool z+  pattern STooGoodToBeTrue = STrue+  {-# COMPLETE SFalse, STooGoodToBeTrue #-}++  wobble :: SBool z -> Bool+  wobble STooGoodToBeTrue = True++In the incomplete pattern match for `wobble`, we /do/ want to warn that SFalse+should be matched against, even though its type, SBool False, does not match+the scrutinee type, SBool z.+-}++-- -----------------------------------------------------------------------+-- * Types and constraints++newEvVar :: Name -> Type -> EvVar+newEvVar name ty = mkLocalId name ty++nameType :: String -> Type -> DsM EvVar+nameType name ty = do+  unique <- getUniqueM+  let occname = mkVarOccFS (fsLit (name++"_"++show unique))+      idname  = mkInternalName unique occname noSrcSpan+  return (newEvVar idname ty)++{-+%************************************************************************+%*                                                                      *+                              The type oracle+%*                                                                      *+%************************************************************************+-}++-- | Check whether a set of type constraints is satisfiable.+tyOracle :: Bag EvVar -> PmM Bool+tyOracle evs+  = liftD $+    do { ((_warns, errs), res) <- initTcDsForSolver $ tcCheckSatisfiability evs+       ; case res of+            Just sat -> return sat+            Nothing  -> pprPanic "tyOracle" (vcat $ pprErrMsgBagWithLoc errs) }++{-+%************************************************************************+%*                                                                      *+                             Sanity Checks+%*                                                                      *+%************************************************************************+-}++-- | The arity of a pattern/pattern vector is the+-- number of top-level patterns that are not guards+type PmArity = Int++-- | Compute the arity of a pattern vector+patVecArity :: PatVec -> PmArity+patVecArity = sum . map patternArity++-- | Compute the arity of a pattern+patternArity :: Pattern -> PmArity+patternArity (PmGrd {}) = 0+patternArity _other_pat = 1++{-+%************************************************************************+%*                                                                      *+            Heart of the algorithm: Function pmcheck+%*                                                                      *+%************************************************************************++Main functions are:++* mkInitialUncovered :: [Id] -> PmM Uncovered++  Generates the initial uncovered set. Term and type constraints in scope+  are checked, if they are inconsistent, the set is empty, otherwise, the+  set contains only a vector of variables with the constraints in scope.++* pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult++  Checks redundancy, coverage and inaccessibility, using auxilary functions+  `pmcheckGuards` and `pmcheckHd`. Mainly handles the guard case which is+  common in all three checks (see paper) and calls `pmcheckGuards` when the+  whole clause is checked, or `pmcheckHd` when the pattern vector does not+  start with a guard.++* pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult++  Processes the guards.++* pmcheckHd :: Pattern -> PatVec -> [PatVec]+          -> ValAbs -> ValVec -> PmM PartialResult++  Worker: This function implements functions `covered`, `uncovered` and+  `divergent` from the paper at once. Slightly different from the paper because+  it does not even produce the covered and uncovered sets. Since we only care+  about whether a clause covers SOMETHING or if it may forces ANY argument, we+  only store a boolean in both cases, for efficiency.+-}++-- | Lift a pattern matching action from a single value vector abstration to a+-- value set abstraction, but calling it on every vector and the combining the+-- results.+runMany :: (ValVec -> PmM PartialResult) -> (Uncovered -> PmM PartialResult)+runMany _ [] = return mempty+runMany pm (m:ms) = mappend <$> pm m <*> runMany pm ms++-- | Generate the initial uncovered set. It initializes the+-- delta with all term and type constraints in scope.+mkInitialUncovered :: [Id] -> PmM Uncovered+mkInitialUncovered vars = do+  delta <- pmInitialTmTyCs+  let patterns = map PmVar vars+  return [ValVec patterns delta]++-- | Increase the counter for elapsed algorithm iterations, check that the+-- limit is not exceeded and call `pmcheck`+pmcheckI :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult+pmcheckI ps guards vva = do+  n <- liftD incrCheckPmIterDs+  tracePm "pmCheck" (ppr n <> colon <+> pprPatVec ps+                        $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))+                        $$ pprValVecDebug vva)+  res <- pmcheck ps guards vva+  tracePm "pmCheckResult:" (ppr res)+  return res+{-# INLINE pmcheckI #-}++-- | Increase the counter for elapsed algorithm iterations, check that the+-- limit is not exceeded and call `pmcheckGuards`+pmcheckGuardsI :: [PatVec] -> ValVec -> PmM PartialResult+pmcheckGuardsI gvs vva = liftD incrCheckPmIterDs >> pmcheckGuards gvs vva+{-# INLINE pmcheckGuardsI #-}++-- | Increase the counter for elapsed algorithm iterations, check that the+-- limit is not exceeded and call `pmcheckHd`+pmcheckHdI :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec+           -> PmM PartialResult+pmcheckHdI p ps guards va vva = do+  n <- liftD incrCheckPmIterDs+  tracePm "pmCheckHdI" (ppr n <> colon <+> pprPmPatDebug p+                        $$ pprPatVec ps+                        $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))+                        $$ pprPmPatDebug va+                        $$ pprValVecDebug vva)++  res <- pmcheckHd p ps guards va vva+  tracePm "pmCheckHdI: res" (ppr res)+  return res+{-# INLINE pmcheckHdI #-}++-- | Matching function: Check simultaneously a clause (takes separately the+-- patterns and the list of guards) for exhaustiveness, redundancy and+-- inaccessibility.+pmcheck :: PatVec -> [PatVec] -> ValVec -> PmM PartialResult+pmcheck [] guards vva@(ValVec [] _)+  | null guards = return $ mempty { presultCovered = Covered }+  | otherwise   = pmcheckGuardsI guards vva++-- Guard+pmcheck (PmFake : ps) guards vva =+  -- short-circuit if the guard pattern is useless.+  -- we just have two possible outcomes: fail here or match and recurse+  -- none of the two contains any useful information about the failure+  -- though. So just have these two cases but do not do all the boilerplate+  forces . mkCons vva <$> pmcheckI ps guards vva+pmcheck (p : ps) guards (ValVec vas delta)+  | PmGrd { pm_grd_pv = pv, pm_grd_expr = e } <- p+  = do+      y <- liftD $ mkPmId (pmPatType p)+      let tm_state = extendSubst y e (delta_tm_cs delta)+          delta'   = delta { delta_tm_cs = tm_state }+      utail <$> pmcheckI (pv ++ ps) guards (ValVec (PmVar y : vas) delta')++pmcheck [] _ (ValVec (_:_) _) = panic "pmcheck: nil-cons"+pmcheck (_:_) _ (ValVec [] _) = panic "pmcheck: cons-nil"++pmcheck (p:ps) guards (ValVec (va:vva) delta)+  = pmcheckHdI p ps guards va (ValVec vva delta)++-- | Check the list of guards+pmcheckGuards :: [PatVec] -> ValVec -> PmM PartialResult+pmcheckGuards []       vva = return (usimple [vva])+pmcheckGuards (gv:gvs) vva = do+  (PartialResult prov1 cs vsa ds) <- pmcheckI gv [] vva+  (PartialResult prov2 css vsas dss) <- runMany (pmcheckGuardsI gvs) vsa+  return $ PartialResult (prov1 `mappend` prov2)+                         (cs `mappend` css)+                         vsas+                         (ds `mappend` dss)++-- | Worker function: Implements all cases described in the paper for all three+-- functions (`covered`, `uncovered` and `divergent`) apart from the `Guard`+-- cases which are handled by `pmcheck`+pmcheckHd :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec+          -> PmM PartialResult++-- Var+pmcheckHd (PmVar x) ps guards va (ValVec vva delta)+  | Just tm_state <- solveOneEq (delta_tm_cs delta)+                                (PmExprVar (idName x), vaToPmExpr va)+  = ucon va <$> pmcheckI ps guards (ValVec vva (delta {delta_tm_cs = tm_state}))+  | otherwise = return mempty++-- ConCon+pmcheckHd ( p@(PmCon { pm_con_con = c1, pm_con_tvs = ex_tvs1+                     , pm_con_args = args1})) ps guards+          (va@(PmCon { pm_con_con = c2, pm_con_tvs = ex_tvs2+                     , pm_con_args = args2})) (ValVec vva delta)+  | c1 /= c2  =+    return (usimple [ValVec (va:vva) delta])+  | otherwise = do+    let to_evvar tv1 tv2 = nameType "pmConCon" $+                           mkPrimEqPred (mkTyVarTy tv1) (mkTyVarTy tv2)+        mb_to_evvar tv1 tv2+            -- If we have identical constructors but different existential+            -- tyvars, then generate extra equality constraints to ensure the+            -- existential tyvars.+            -- See Note [Coverage checking and existential tyvars].+          | tv1 == tv2 = pure Nothing+          | otherwise  = Just <$> to_evvar tv1 tv2+    evvars <- (listToBag . catMaybes) <$>+              ASSERT(ex_tvs1 `equalLength` ex_tvs2)+              liftD (zipWithM mb_to_evvar ex_tvs1 ex_tvs2)+    let delta' = delta { delta_ty_cs = evvars `unionBags` delta_ty_cs delta }+    kcon c1 (pm_con_arg_tys p) (pm_con_tvs p) (pm_con_dicts p)+      <$> pmcheckI (args1 ++ ps) guards (ValVec (args2 ++ vva) delta')++-- LitLit+pmcheckHd (PmLit l1) ps guards (va@(PmLit l2)) vva =+  case eqPmLit l1 l2 of+    True  -> ucon va <$> pmcheckI ps guards vva+    False -> return $ ucon va (usimple [vva])++-- ConVar+pmcheckHd (p@(PmCon { pm_con_con = con, pm_con_arg_tys = tys }))+          ps guards+          (PmVar x) (ValVec vva delta) = do+  (prov, complete_match) <- select =<< liftD (allCompleteMatches con tys)++  cons_cs <- mapM (liftD . mkOneConFull x) complete_match++  inst_vsa <- flip mapMaybeM cons_cs $+      \InhabitationCandidate{ ic_val_abs = va, ic_tm_ct = tm_ct+                            , ic_ty_cs = ty_cs+                            , ic_strict_arg_tys = strict_arg_tys } -> do+    mb_sat <- pmIsSatisfiable delta tm_ct ty_cs strict_arg_tys+    pure $ fmap (ValVec (va:vva)) mb_sat++  set_provenance prov .+    force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>+      runMany (pmcheckI (p:ps) guards) inst_vsa++-- LitVar+pmcheckHd (p@(PmLit l)) ps guards (PmVar x) (ValVec vva delta)+  = force_if (canDiverge (idName x) (delta_tm_cs delta)) <$>+      mkUnion non_matched <$>+        case solveOneEq (delta_tm_cs delta) (mkPosEq x l) of+          Just tm_state -> pmcheckHdI p ps guards (PmLit l) $+                             ValVec vva (delta {delta_tm_cs = tm_state})+          Nothing       -> return mempty+  where+    us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l)+       = [ValVec (PmNLit x [l] : vva) (delta { delta_tm_cs = tm_state })]+       | otherwise = []++    non_matched = usimple us++-- LitNLit+pmcheckHd (p@(PmLit l)) ps guards+          (PmNLit { pm_lit_id = x, pm_lit_not = lits }) (ValVec vva delta)+  | all (not . eqPmLit l) lits+  , Just tm_state <- solveOneEq (delta_tm_cs delta) (mkPosEq x l)+    -- Both guards check the same so it would be sufficient to have only+    -- the second one. Nevertheless, it is much cheaper to check whether+    -- the literal is in the list so we check it first, to avoid calling+    -- the term oracle (`solveOneEq`) if possible+  = mkUnion non_matched <$>+      pmcheckHdI p ps guards (PmLit l)+                (ValVec vva (delta { delta_tm_cs = tm_state }))+  | otherwise = return non_matched+  where+    us | Just tm_state <- solveOneEq (delta_tm_cs delta) (mkNegEq x l)+       = [ValVec (PmNLit x (l:lits) : vva) (delta { delta_tm_cs = tm_state })]+       | otherwise = []++    non_matched = usimple us++-- ----------------------------------------------------------------------------+-- The following three can happen only in cases like #322 where constructors+-- and overloaded literals appear in the same match. The general strategy is+-- to replace the literal (positive/negative) by a variable and recurse. The+-- fact that the variable is equal to the literal is recorded in `delta` so+-- no information is lost++-- LitCon+pmcheckHd p@PmLit{} ps guards va@PmCon{} (ValVec vva delta)+  = do y <- liftD $ mkPmId (pmPatType va)+       -- Analogous to the ConVar case, we have to case split the value+       -- abstraction on possible literals. We do so by introducing a fresh+       -- variable that is equated to the constructor. LitVar will then take+       -- care of the case split by resorting to NLit.+       let tm_state = extendSubst y (vaToPmExpr va) (delta_tm_cs delta)+           delta'   = delta { delta_tm_cs = tm_state }+       pmcheckHdI p ps guards (PmVar y) (ValVec vva delta')++-- ConLit+pmcheckHd p@PmCon{} ps guards (PmLit l) (ValVec vva delta)+  = do y <- liftD $ mkPmId (pmPatType p)+       -- This desugars to the ConVar case by introducing a fresh variable that+       -- is equated to the literal via a constraint. ConVar will then properly+       -- case split on all possible constructors.+       let tm_state = extendSubst y (PmExprLit l) (delta_tm_cs delta)+           delta'   = delta { delta_tm_cs = tm_state }+       pmcheckHdI p ps guards (PmVar y) (ValVec vva delta')++-- ConNLit+pmcheckHd (p@(PmCon {})) ps guards (PmNLit { pm_lit_id = x }) vva+  = pmcheckHdI p ps guards (PmVar x) vva++-- Impossible: handled by pmcheck+pmcheckHd PmFake     _ _ _ _ = panic "pmcheckHd: Fake"+pmcheckHd (PmGrd {}) _ _ _ _ = panic "pmcheckHd: Guard"++{-+Note [Coverage checking and existential tyvars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC's implementation of the pattern-match coverage algorithm (as described in+the GADTs Meet Their Match paper) must take some care to emit enough type+constraints when handling data constructors with exisentially quantified type+variables. To better explain what the challenge is, consider a constructor K+of the form:++  K @e_1 ... @e_m ev_1 ... ev_v ty_1 ... ty_n :: T u_1 ... u_p++Where:++* e_1, ..., e_m are the existentially bound type variables.+* ev_1, ..., ev_v are evidence variables, which may inhabit a dictionary type+  (e.g., Eq) or an equality constraint (e.g., e_1 ~ Int).+* ty_1, ..., ty_n are the types of K's fields.+* T u_1 ... u_p is the return type, where T is the data type constructor, and+  u_1, ..., u_p are the universally quantified type variables.++In the ConVar case, the coverage algorithm will have in hand the constructor+K as well as a pattern variable (pv :: T PV_1 ... PV_p), where PV_1, ..., PV_p+are some types that instantiate u_1, ... u_p. The idea is that we should+substitute PV_1 for u_1, ..., and PV_p for u_p when forming a PmCon (the+mkOneConFull function accomplishes this) and then hand this PmCon off to the+ConCon case.++The presence of existentially quantified type variables adds a significant+wrinkle. We always grab e_1, ..., e_m from the definition of K to begin with,+but we don't want them to appear in the final PmCon, because then+calling (mkOneConFull K) for other pattern variables might reuse the same+existential tyvars, which is certainly wrong.++Previously, GHC's solution to this wrinkle was to always create fresh names+for the existential tyvars and put them into the PmCon. This works well for+many cases, but it can break down if you nest GADT pattern matches in just+the right way. For instance, consider the following program:++    data App f a where+      App :: f a -> App f (Maybe a)++    data Ty a where+      TBool :: Ty Bool+      TInt  :: Ty Int++    data T f a where+      C :: T Ty (Maybe Bool)++    foo :: T f a -> App f a -> ()+    foo C (App TBool) = ()++foo is a total program, but with the previous approach to handling existential+tyvars, GHC would mark foo's patterns as non-exhaustive.++When foo is desugared to Core, it looks roughly like so:++    foo @f @a (C co1 _co2) (App @a1 _co3 (TBool |> co1)) = ()++(Where `a1` is an existential tyvar.)++That, in turn, is processed by the coverage checker to become:++    foo @f @a (C co1 _co2) (App @a1 _co3 (pmvar123 :: f a1))+      | TBool <- pmvar123 |> co1+      = ()++Note that the type of pmvar123 is `f a1`—this will be important later.++Now, we proceed with coverage-checking as usual. When we come to the+ConVar case for App, we create a fresh variable `a2` to represent its+existential tyvar. At this point, we have the equality constraints+`(a ~ Maybe a2, a ~ Maybe Bool, f ~ Ty)` in scope.++However, when we check the guard, it will use the type of pmvar123, which is+`f a1`. Thus, when considering if pmvar123 can match the constructor TInt,+it will generate the constraint `a1 ~ Int`. This means our final set of+equality constraints would be:++    f  ~ Ty+    a  ~ Maybe Bool+    a  ~ Maybe a2+    a1 ~ Int++Which is satisfiable! Freshening the existential tyvar `a` to `a2` doomed us,+because GHC is unable to relate `a2` to `a1`, which really should be the same+tyvar.++Luckily, we can avoid this pitfall. Recall that the ConVar case was where we+generated a PmCon with too-fresh existentials. But after ConVar, we have the+ConCon case, which considers whether each constructor of a particular data type+can be matched on in a particular spot.++In the case of App, when we get to the ConCon case, we will compare our+original App PmCon (from the source program) to the App PmCon created from the+ConVar case. In the former PmCon, we have `a1` in hand, which is exactly the+existential tyvar we want! Thus, we can force `a1` to be the same as `a2` here+by emitting an additional `a1 ~ a2` constraint. Now our final set of equality+constraints will be:++    f  ~ Ty+    a  ~ Maybe Bool+    a  ~ Maybe a2+    a1 ~ Int+    a1 ~ a2++Which is unsatisfiable, as we desired, since we now have that+Int ~ a1 ~ a2 ~ Bool.++In general, App might have more than one constructor, in which case we+couldn't reuse the existential tyvar for App for a different constructor. This+means that we can only use this trick in ConCon when the constructors are the+same. But this is fine, since this is the only scenario where this situation+arises in the first place!+-}++-- ----------------------------------------------------------------------------+-- * Utilities for main checking++updateVsa :: (ValSetAbs -> ValSetAbs) -> (PartialResult -> PartialResult)+updateVsa f p@(PartialResult { presultUncovered = old })+  = p { presultUncovered = f old }+++-- | Initialise with default values for covering and divergent information.+usimple :: ValSetAbs -> PartialResult+usimple vsa = mempty { presultUncovered = vsa }++-- | Take the tail of all value vector abstractions in the uncovered set+utail :: PartialResult -> PartialResult+utail = updateVsa upd+  where upd vsa = [ ValVec vva delta | ValVec (_:vva) delta <- vsa ]++-- | Prepend a value abstraction to all value vector abstractions in the+-- uncovered set+ucon :: ValAbs -> PartialResult -> PartialResult+ucon va = updateVsa upd+  where+    upd vsa = [ ValVec (va:vva) delta | ValVec vva delta <- vsa ]++-- | Given a data constructor of arity `a` and an uncovered set containing+-- value vector abstractions of length `(a+n)`, pass the first `n` value+-- abstractions to the constructor (Hence, the resulting value vector+-- abstractions will have length `n+1`)+kcon :: ConLike -> [Type] -> [TyVar] -> [EvVar]+     -> PartialResult -> PartialResult+kcon con arg_tys ex_tvs dicts+  = let n = conLikeArity con+        upd vsa =+          [ ValVec (va:vva) delta+          | ValVec vva' delta <- vsa+          , let (args, vva) = splitAt n vva'+          , let va = PmCon { pm_con_con     = con+                            , pm_con_arg_tys = arg_tys+                            , pm_con_tvs     = ex_tvs+                            , pm_con_dicts   = dicts+                            , pm_con_args    = args } ]+    in updateVsa upd++-- | Get the union of two covered, uncovered and divergent value set+-- abstractions. Since the covered and divergent sets are represented by a+-- boolean, union means computing the logical or (at least one of the two is+-- non-empty).++mkUnion :: PartialResult -> PartialResult -> PartialResult+mkUnion = mappend++-- | Add a value vector abstraction to a value set abstraction (uncovered).+mkCons :: ValVec -> PartialResult -> PartialResult+mkCons vva = updateVsa (vva:)++-- | Set the divergent set to not empty+forces :: PartialResult -> PartialResult+forces pres = pres { presultDivergent = Diverged }++-- | Set the divergent set to non-empty if the flag is `True`+force_if :: Bool -> PartialResult -> PartialResult+force_if True  pres = forces pres+force_if False pres = pres++set_provenance :: Provenance -> PartialResult -> PartialResult+set_provenance prov pr = pr { presultProvenance = prov }++-- ----------------------------------------------------------------------------+-- * Propagation of term constraints inwards when checking nested matches++{- Note [Type and Term Equality Propagation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When checking a match it would be great to have all type and term information+available so we can get more precise results. For this reason we have functions+`addDictsDs' and `addTmCsDs' in PmMonad 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 HsPat.hs. This handles bug #4139 ( see example+  https://gitlab.haskell.org/ghc/ghc/snippets/672 )+where this is needed.++For term equalities we do less, we just generate equalities for HsCase. For+example we accurately give 2 redundancy warnings for the marked cases:++f :: [a] -> Bool+f x = case x of++  []    -> case x of        -- brings (x ~ []) in scope+             []    -> True+             (_:_) -> False -- can't happen++  (_:_) -> case x of        -- brings (x ~ (_:_)) in scope+             (_:_) -> True+             []    -> False -- can't happen++Functions `genCaseTmCs1' and `genCaseTmCs2' are responsible for generating+these constraints.+-}++-- | Generate equalities when checking a case expression:+--     case x of { p1 -> e1; ... pn -> en }+-- When we go deeper to check e.g. e1 we record two equalities:+-- (x ~ y), where y is the initial uncovered when checking (p1; .. ; pn)+-- and (x ~ p1).+genCaseTmCs2 :: Maybe (LHsExpr GhcTc) -- Scrutinee+             -> [Pat GhcTc]           -- LHS       (should have length 1)+             -> [Id]                  -- MatchVars (should have length 1)+             -> DsM (Bag SimpleEq)+genCaseTmCs2 Nothing _ _ = return emptyBag+genCaseTmCs2 (Just scr) [p] [var] = do+  fam_insts <- dsGetFamInstEnvs+  [e] <- map vaToPmExpr . coercePatVec <$> translatePat fam_insts p+  let scr_e = lhsExprToPmExpr scr+  return $ listToBag [(var, e), (var, scr_e)]+genCaseTmCs2 _ _ _ = panic "genCaseTmCs2: HsCase"++-- | Generate a simple equality when checking a case expression:+--     case x of { matches }+-- When checking matches we record that (x ~ y) where y is the initial+-- uncovered. All matches will have to satisfy this equality.+genCaseTmCs1 :: Maybe (LHsExpr GhcTc) -> [Id] -> Bag SimpleEq+genCaseTmCs1 Nothing     _    = emptyBag+genCaseTmCs1 (Just scr) [var] = unitBag (var, lhsExprToPmExpr scr)+genCaseTmCs1 _ _              = panic "genCaseTmCs1: HsCase"++{- Note [Literals in PmPat]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Instead of translating a literal to a variable accompanied with a guard, we+treat them like constructor patterns. The following example from+"./libraries/base/GHC/IO/Encoding.hs" shows why:++mkTextEncoding' :: CodingFailureMode -> String -> IO TextEncoding+mkTextEncoding' cfm enc = case [toUpper c | c <- enc, c /= '-'] of+    "UTF8"    -> return $ UTF8.mkUTF8 cfm+    "UTF16"   -> return $ UTF16.mkUTF16 cfm+    "UTF16LE" -> return $ UTF16.mkUTF16le cfm+    ...++Each clause gets translated to a list of variables with an equal number of+guards. For every guard we generate two cases (equals True/equals False) which+means that we generate 2^n cases to feed the oracle with, where n is the sum of+the length of all strings that appear in the patterns. For this particular+example this means over 2^40 cases. Instead, by representing them like with+constructor we get the following:+  1. We exploit the common prefix with our representation of VSAs+  2. We prune immediately non-reachable cases+     (e.g. False == (x == "U"), True == (x == "U"))++Note [Translating As Patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Instead of translating x@p as:  x (p <- x)+we instead translate it as:     p (x <- coercePattern p)+for performance reasons. For example:++  f x@True  = 1+  f y@False = 2++Gives the following with the first translation:++  x |> {x == False, x == y, y == True}++If we use the second translation we get an empty set, independently of the+oracle. Since the pattern `p' may contain guard patterns though, it cannot be+used as an expression. That's why we call `coercePatVec' to drop the guard and+`vaToPmExpr' to transform the value abstraction to an expression in the+guard pattern (value abstractions are a subset of expressions). We keep the+guards in the first pattern `p' though.+++%************************************************************************+%*                                                                      *+      Pretty printing of exhaustiveness/redundancy check warnings+%*                                                                      *+%************************************************************************+-}++-- | Check whether any part of pattern match checking is enabled (does not+-- matter whether it is the redundancy check or the exhaustiveness check).+isAnyPmCheckEnabled :: DynFlags -> DsMatchContext -> Bool+isAnyPmCheckEnabled dflags (DsMatchContext kind _loc)+  = wopt Opt_WarnOverlappingPatterns dflags || exhaustive dflags kind++instance Outputable ValVec where+  ppr (ValVec vva delta)+    = let (residual_eqs, subst) = wrapUpTmState (delta_tm_cs delta)+          vector                = substInValAbs subst vva+      in  ppr_uncovered (vector, residual_eqs)++-- | Apply a term substitution to a value vector abstraction. All VAs are+-- transformed to PmExpr (used only before pretty printing).+substInValAbs :: PmVarEnv -> [ValAbs] -> [PmExpr]+substInValAbs subst = map (exprDeepLookup subst . vaToPmExpr)++-- | Wrap up the term oracle's state once solving is complete. Drop any+-- information about unhandled constraints (involving HsExprs) and flatten+-- (height 1) the substitution.+wrapUpTmState :: TmState -> ([ComplexEq], PmVarEnv)+wrapUpTmState (residual, (_, subst)) = (residual, flattenPmVarEnv subst)++-- | Issue all the warnings (coverage, exhaustiveness, inaccessibility)+dsPmWarn :: DynFlags -> DsMatchContext -> PmResult -> DsM ()+dsPmWarn dflags ctx@(DsMatchContext kind loc) pm_result+  = when (flag_i || flag_u) $ do+      let exists_r = flag_i && notNull redundant && onlyBuiltin+          exists_i = flag_i && notNull inaccessible && onlyBuiltin && not is_rec_upd+          exists_u = flag_u && (case uncovered of+                                  TypeOfUncovered   _ -> True+                                  UncoveredPatterns u -> notNull u)++      when exists_r $ forM_ redundant $ \(dL->L l q) -> do+        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)+                               (pprEqn q "is redundant"))+      when exists_i $ forM_ inaccessible $ \(dL->L l q) -> do+        putSrcSpanDs l (warnDs (Reason Opt_WarnOverlappingPatterns)+                               (pprEqn q "has inaccessible right hand side"))+      when exists_u $ putSrcSpanDs loc $ warnDs flag_u_reason $+        case uncovered of+          TypeOfUncovered ty           -> warnEmptyCase ty+          UncoveredPatterns candidates -> pprEqns candidates+  where+    PmResult+      { pmresultProvenance = prov+      , pmresultRedundant = redundant+      , pmresultUncovered = uncovered+      , pmresultInaccessible = inaccessible } = pm_result++    flag_i = wopt Opt_WarnOverlappingPatterns dflags+    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]++    onlyBuiltin = prov == FromBuiltin++    maxPatterns = maxUncoveredPatterns dflags++    -- Print a single clause (for redundant/with-inaccessible-rhs)+    pprEqn q txt = pp_context True ctx (text txt) $ \f -> ppr_eqn f kind q++    -- Print several clauses (for uncovered clauses)+    pprEqns qs = pp_context False ctx (text "are non-exhaustive") $ \_ ->+      case qs of -- See #11245+           [ValVec [] _]+                    -> text "Guards do not cover entire pattern space"+           _missing -> let us = map ppr qs+                       in  hang (text "Patterns not matched:") 4+                                (vcat (take maxPatterns us)+                                 $$ dots maxPatterns us)++    -- Print a type-annotated wildcard (for non-exhaustive `EmptyCase`s for+    -- which we only know the type and have no inhabitants at hand)+    warnEmptyCase ty = pp_context False ctx (text "are non-exhaustive") $ \_ ->+      hang (text "Patterns not matched:") 4 (underscore <+> dcolon <+> ppr ty)++{- Note [Inaccessible warnings for record updates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#12957)+  data T a where+    T1 :: { x :: Int } -> T Bool+    T2 :: { x :: Int } -> T a+    T3 :: T a++  f :: T Char -> T a+  f r = r { x = 3 }++The desugarer will (conservatively generate a case for T1 even though+it's impossible:+  f r = case r of+          T1 x -> T1 3   -- Inaccessible branch+          T2 x -> T2 3+          _    -> error "Missing"++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.+-}++-- | Issue a warning when the predefined number of iterations is exceeded+-- for the pattern match checker+warnPmIters :: DynFlags -> DsMatchContext -> DsM ()+warnPmIters dflags (DsMatchContext kind loc)+  = when (flag_i || flag_u) $ do+      iters <- maxPmCheckIterations <$> getDynFlags+      putSrcSpanDs loc (warnDs NoReason (msg iters))+  where+    ctxt   = pprMatchContext kind+    msg is = fsep [ text "Pattern match checker exceeded"+                  , parens (ppr is), text "iterations in", ctxt <> dot+                  , text "(Use -fmax-pmcheck-iterations=n"+                  , text "to set the maximun number of iterations to n)" ]++    flag_i = wopt Opt_WarnOverlappingPatterns dflags+    flag_u = exhaustive dflags kind++dots :: Int -> [a] -> SDoc+dots maxPatterns qs+    | qs `lengthExceeds` maxPatterns = text "..."+    | otherwise                      = empty++-- | Check whether the exhaustiveness checker should run (exhaustiveness only)+exhaustive :: DynFlags -> HsMatchContext id -> Bool+exhaustive  dflags = maybe False (`wopt` dflags) . exhaustiveWarningFlag++-- | Denotes whether an exhaustiveness check is supported, and if so,+-- via which 'WarningFlag' it's controlled.+-- Returns 'Nothing' if check is not supported.+exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag+exhaustiveWarningFlag (FunRhs {})   = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag CaseAlt       = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag IfAlt         = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag LambdaExpr    = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag PatBindRhs    = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag ProcExpr      = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag RecUpd        = Just Opt_WarnIncompletePatternsRecUpd+exhaustiveWarningFlag ThPatSplice   = Nothing+exhaustiveWarningFlag PatSyn        = Nothing+exhaustiveWarningFlag ThPatQuote    = Nothing+exhaustiveWarningFlag (StmtCtxt {}) = Nothing -- Don't warn about incomplete patterns+                                       -- in list comprehensions, pattern guards+                                       -- etc. They are often *supposed* to be+                                       -- incomplete++-- True <==> singular+pp_context :: Bool -> DsMatchContext -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc+pp_context singular (DsMatchContext kind _loc) msg rest_of_msg_fun+  = vcat [text txt <+> msg,+          sep [ text "In" <+> ppr_match <> char ':'+              , nest 4 (rest_of_msg_fun pref)]]+  where+    txt | singular  = "Pattern match"+        | otherwise = "Pattern match(es)"++    (ppr_match, pref)+        = case kind of+             FunRhs { mc_fun = (dL->L _ fun) }+                  -> (pprMatchContext kind, \ pp -> ppr fun <+> pp)+             _    -> (pprMatchContext kind, \ pp -> pp)++ppr_pats :: HsMatchContext Name -> [Pat GhcTc] -> SDoc+ppr_pats kind pats+  = sep [sep (map ppr pats), matchSeparator kind, text "..."]++ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat GhcTc] -> SDoc+ppr_eqn prefixF kind eqn = prefixF (ppr_pats kind (map unLoc eqn))++ppr_constraint :: (SDoc,[PmLit]) -> SDoc+ppr_constraint (var, lits) = var <+> text "is not one of"+                                 <+> braces (pprWithCommas ppr lits)++ppr_uncovered :: ([PmExpr], [ComplexEq]) -> SDoc+ppr_uncovered (expr_vec, complex)+  | null cs   = fsep vec -- there are no literal constraints+  | otherwise = hang (fsep vec) 4 $+                  text "where" <+> vcat (map ppr_constraint cs)+  where+    sdoc_vec = mapM pprPmExprWithParens expr_vec+    (vec,cs) = runPmPprM sdoc_vec (filterComplex complex)++{- Note [Representation of Term Equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the paper, term constraints always take the form (x ~ e). Of course, a more+general constraint of the form (e1 ~ e1) can always be transformed to an+equivalent set of the former constraints, by introducing a fresh, intermediate+variable: { y ~ e1, y ~ e1 }. Yet, implementing this representation gave rise+to #11160 (incredibly bad performance for literal pattern matching). Two are+the main sources of this problem (the actual problem is how these two interact+with each other):++1. Pattern matching on literals generates twice as many constraints as needed.+   Consider the following (tests/ghci/should_run/ghcirun004):++    foo :: Int -> Int+    foo 1    = 0+    ...+    foo 5000 = 4999++   The covered and uncovered set *should* look like:+     U0 = { x |> {} }++     C1  = { 1  |> { x ~ 1 } }+     U1  = { x  |> { False ~ (x ~ 1) } }+     ...+     C10 = { 10 |> { False ~ (x ~ 1), .., False ~ (x ~ 9), x ~ 10 } }+     U10 = { x  |> { False ~ (x ~ 1), .., False ~ (x ~ 9), False ~ (x ~ 10) } }+     ...++     If we replace { False ~ (x ~ 1) } with { y ~ False, y ~ (x ~ 1) }+     we get twice as many constraints. Also note that half of them are just the+     substitution [x |-> False].++2. The term oracle (`tmOracle` in deSugar/TmOracle) uses equalities of the form+   (x ~ e) as substitutions [x |-> e]. More specifically, function+   `extendSubstAndSolve` applies such substitutions in the residual constraints+   and partitions them in the affected and non-affected ones, which are the new+   worklist. Essentially, this gives quadradic behaviour on the number of the+   residual constraints. (This would not be the case if the term oracle used+   mutable variables but, since we use it to handle disjunctions on value set+   abstractions (`Union` case), we chose a pure, incremental interface).++Now the problem becomes apparent (e.g. for clause 300):+  * Set U300 contains 300 substituting constraints [y_i |-> False] and 300+    constraints that we know that will not reduce (stay in the worklist).+  * To check for consistency, we apply the substituting constraints ONE BY ONE+    (since `tmOracle` is called incrementally, it does not have all of them+    available at once). Hence, we go through the (non-progressing) constraints+    over and over, achieving over-quadradic behaviour.++If instead we allow constraints of the form (e ~ e),+  * All uncovered sets Ui contain no substituting constraints and i+    non-progressing constraints of the form (False ~ (x ~ lit)) so the oracle+    behaves linearly.+  * All covered sets Ci contain exactly (i-1) non-progressing constraints and+    a single substituting constraint. So the term oracle goes through the+    constraints only once.++The performance improvement becomes even more important when more arguments are+involved.+-}++-- Debugging Infrastructre++tracePm :: String -> SDoc -> PmM ()+tracePm herald doc = liftD $ tracePmD herald doc+++tracePmD :: String -> SDoc -> DsM ()+tracePmD herald doc = do+  dflags <- getDynFlags+  printer <- mkPrintUnqualifiedDs+  liftIO $ dumpIfSet_dyn_printer printer dflags+            Opt_D_dump_ec_trace (text herald $$ (nest 2 doc))+++pprPmPatDebug :: PmPat a -> SDoc+pprPmPatDebug (PmCon cc _arg_tys _con_tvs _con_dicts con_args)+  = hsep [text "PmCon", ppr cc, hsep (map pprPmPatDebug con_args)]+pprPmPatDebug (PmVar vid) = text "PmVar" <+> ppr vid+pprPmPatDebug (PmLit li)  = text "PmLit" <+> ppr li+pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl+pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv)+                                           <+> ppr ge+pprPmPatDebug PmFake = text "PmFake"++pprPatVec :: PatVec -> SDoc+pprPatVec ps = hang (text "Pattern:") 2+                (brackets $ sep+                  $ punctuate (comma <> char '\n') (map pprPmPatDebug ps))++pprValAbs :: [ValAbs] -> SDoc+pprValAbs ps = hang (text "ValAbs:") 2+                (brackets $ sep+                  $ punctuate (comma) (map pprPmPatDebug ps))++pprValVecDebug :: ValVec -> SDoc+pprValVecDebug (ValVec vas _d) = text "ValVec" <+>+                                  parens (pprValAbs vas)
+ compiler/deSugar/Coverage.hs view
@@ -0,0 +1,1364 @@+{-+(c) Galois, 2006+(c) University of Glasgow, 2007+-}++{-# LANGUAGE NondecreasingIndentation, RecordWildCards #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}++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 HsSyn+import Module+import Outputable+import DynFlags+import ConLike+import Control.Monad+import SrcLoc+import ErrUtils+import NameSet hiding (FreeVars)+import Name+import Bag+import CostCentre+import CostCentreState+import CoreSyn+import Id+import VarSet+import Data.List+import FastString+import HscTypes+import TyCon+import BasicTypes+import MonadUtils+import Maybes+import CLabel+import Util++import Data.Time+import System.Directory++import Trace.Hpc.Mix+import Trace.Hpc.Util++import qualified Data.ByteString as BS+import Data.Map (Map)+import qualified Data.Map as Map++{-+************************************************************************+*                                                                      *+*              The main function: addTicksToBinds+*                                                                      *+************************************************************************+-}++addTicksToBinds+        :: HscEnv+        -> Module+        -> ModLocation          -- ... off the current module+        -> NameSet              -- Exported Ids.  When we call addTicksToBinds,+                                -- isExportedId doesn't work yet (the desugarer+                                -- hasn't set it), so we have to work from this set.+        -> [TyCon]              -- Type constructor in this module+        -> LHsBinds GhcTc+        -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)++addTicksToBinds hsc_env mod mod_loc exports tyCons binds+  | let dflags = hsc_dflags hsc_env+        passes = coveragePasses dflags, not (null passes),+    Just orig_file <- ml_hs_file mod_loc,+    not ("boot" `isSuffixOf` orig_file) = do++     let  orig_file2 = guessSourceFile binds orig_file++          tickPass tickish (binds,st) =+            let env = TTE+                      { fileName     = mkFastString orig_file2+                      , declPath     = []+                      , tte_dflags   = dflags+                      , exports      = exports+                      , inlines      = emptyVarSet+                      , inScope      = emptyVarSet+                      , blackList    = Map.fromList+                                          [ (getSrcSpan (tyConName tyCon),())+                                          | tyCon <- tyCons ]+                      , density      = mkDensity tickish dflags+                      , this_mod     = mod+                      , tickishType  = tickish+                      }+                (binds',_,st') = unTM (addTickLHsBinds binds) env st+            in (binds', st')++          initState = TT { tickBoxCount = 0+                         , mixEntries   = []+                         , ccIndices    = newCostCentreState+                         }++          (binds1,st) = foldr tickPass (binds, initState) passes++     let tickCount = tickBoxCount st+         entries = reverse $ mixEntries st+     hashNo <- writeMixEntries dflags mod tickCount entries orig_file2+     modBreaks <- mkModBreaks hsc_env mod tickCount entries++     dumpIfSet_dyn dflags Opt_D_dump_ticked "HPC" (pprLHsBinds binds1)++     return (binds1, HpcInfo tickCount hashNo, 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 $ foldrBag (\ (dL->L pos _) rest ->+                                 srcSpanFileName_maybe pos : rest) [] binds+     in+     case top_pos of+        (file_name:_) | ".hsc" `isSuffixOf` unpackFS file_name+                      -> unpackFS file_name+        _ -> orig_file+++mkModBreaks :: HscEnv -> Module -> Int -> [MixEntry_] -> IO 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 (dL->L pos bind@(AbsBinds { abs_binds   = binds,+                                       abs_exports = abs_exports })) = do+  withEnv add_exports $ do+  withEnv add_inlines $ do+  binds' <- addTickLHsBinds binds+  return $ cL pos $ bind { abs_binds = binds' }+ where+   -- in AbsBinds, the Id on each binding is not the actual top-level+   -- Id that we are defining, they are related by the abs_exports+   -- field of AbsBinds.  So if we're doing TickExportedFunctions we need+   -- to add the local Ids to the set of exported Names so that we know to+   -- tick the right bindings.+   add_exports env =+     env{ exports = exports env `extendNameSetList`+                      [ idName mid+                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports+                      , idName pid `elemNameSet` (exports env) ] }++   -- See Note [inline sccs]+   add_inlines env =+     env{ inlines = inlines env `extendVarSetList`+                      [ mid+                      | ABE{ abe_poly = pid, abe_mono = mid } <- abs_exports+                      , isInlinePragma (idInlinePragma pid) ] }++addTickLHsBind (dL->L pos (funBind@(FunBind { fun_id = (dL->L _ id)  }))) = do+  let name = getOccString id+  decl_path <- getPathEntry+  density <- getDensity++  inline_ids <- liftM inlines getEnv+  -- See Note [inline sccs]+  let inline   = isInlinePragma (idInlinePragma id)+                 || id `elemVarSet` inline_ids++  -- See Note [inline sccs]+  tickish <- tickishType `liftM` getEnv+  if inline && tickish == ProfNotes then return (cL pos funBind) else do++  (fvs, mg) <-+        getFreeVars $+        addPathEntry name $+        addTickMatchGroup False (fun_matches funBind)++  case mg of+    MG {} -> return ()+    _     -> panic "addTickLHsBind"++  blackListed <- isBlackListed pos+  exported_names <- liftM exports getEnv++  -- We don't want to generate code for blacklisted positions+  -- We don't want redundant ticks on simple pattern bindings+  -- We don't want to tick non-exported bindings in TickExportedFunctions+  let simple = isSimplePatBind funBind+      toplev = null decl_path+      exported = idName id `elemNameSet` exported_names++  tick <- if not blackListed &&+               shouldTickBind density toplev exported simple inline+             then+                bindTick density name pos fvs+             else+                return Nothing++  let mbCons = maybe Prelude.id (:)+  return $ cL pos $ funBind { fun_matches = mg+                            , fun_tick = tick `mbCons` fun_tick funBind }++   where+   -- a binding is a simple pattern binding if it is a funbind with+   -- zero patterns+   isSimplePatBind :: HsBind a -> Bool+   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0++-- TODO: Revisit this+addTickLHsBind (dL->L pos (pat@(PatBind { pat_lhs = lhs+                                        , pat_rhs = rhs }))) = do+  let name = "(...)"+  (fvs, rhs') <- getFreeVars $ addPathEntry name $ addTickGRHSs False False rhs+  let pat' = pat { pat_rhs = rhs'}++  -- Should create ticks here?+  density <- getDensity+  decl_path <- getPathEntry+  let top_lev = null decl_path+  if not (shouldTickPatBind density top_lev)+    then return (cL pos pat')+    else do++    -- Allocate the ticks+    rhs_tick <- bindTick density name pos fvs+    let patvars = map getOccString (collectPatBinders lhs)+    patvar_ticks <- mapM (\v -> bindTick density v pos fvs) patvars++    -- Add to pattern+    let mbCons = maybe id (:)+        rhs_ticks = rhs_tick `mbCons` fst (pat_ticks pat')+        patvar_tickss = zipWith mbCons patvar_ticks+                        (snd (pat_ticks pat') ++ repeat [])+    return $ cL pos $ pat' { pat_ticks = (rhs_ticks, patvar_tickss) }++-- Only internal stuff, not from source, uses VarBind, so we ignore it.+addTickLHsBind var_bind@(dL->L _ (VarBind {})) = return var_bind+addTickLHsBind patsyn_bind@(dL->L _ (PatSynBind {})) = return patsyn_bind+addTickLHsBind bind@(dL->L _ (XHsBindsLR {})) = return bind+addTickLHsBind _  = panic "addTickLHsBind: Impossible Match" -- due to #15884++++bindTick+  :: TickDensity -> String -> SrcSpan -> FreeVars -> TM (Maybe (Tickish Id))+bindTick density name pos fvs = do+  decl_path <- getPathEntry+  let+      toplev        = null decl_path+      count_entries = toplev || density == TickAllFunctions+      top_only      = density /= TickAllFunctions+      box_label     = if toplev then TopLevelBox [name]+                                else LocalBox (decl_path ++ [name])+  --+  allocATickBox box_label count_entries top_only pos fvs+++-- Note [inline sccs]+--+-- The reason not to add ticks to INLINE functions is that this is+-- sometimes handy for avoiding adding a tick to a particular function+-- (see #6131)+--+-- So for now we do not add any ticks to INLINE functions at all.+--+-- We used to use isAnyInlinePragma to figure out whether to avoid adding+-- ticks for this purpose. However, #12962 indicates that this contradicts+-- the documentation on profiling (which only mentions INLINE pragmas).+-- So now we're more careful about what we avoid adding ticks to.++-- -----------------------------------------------------------------------------+-- Decorate an LHsExpr with ticks++-- selectively add ticks to interesting expressions+addTickLHsExpr :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExpr e@(dL->L pos e0) = do+  d <- getDensity+  case d of+    TickForBreakPoints | isGoodBreakExpr e0 -> tick_it+    TickForCoverage    -> tick_it+    TickCallSites      | isCallSite e0      -> tick_it+    _other             -> dont_tick_it+ where+   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0+   dont_tick_it = addTickLHsExprNever e++-- Add a tick to an expression which is the RHS of an equation or a binding.+-- We always consider these to be breakpoints, unless the expression is a 'let'+-- (because the body will definitely have a tick somewhere).  ToDo: perhaps+-- we should treat 'case' and 'if' the same way?+addTickLHsExprRHS :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExprRHS e@(dL->L pos e0) = do+  d <- getDensity+  case d of+     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it+                        | otherwise     -> tick_it+     TickForCoverage -> tick_it+     TickCallSites   | isCallSite e0 -> tick_it+     _other          -> dont_tick_it+ where+   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0+   dont_tick_it = addTickLHsExprNever e++-- The inner expression of an evaluation context:+--    let binds in [], ( [] )+-- we never tick these if we're doing HPC, but otherwise+-- we treat it like an ordinary expression.+addTickLHsExprEvalInner :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExprEvalInner e = do+   d <- getDensity+   case d of+     TickForCoverage -> addTickLHsExprNever e+     _otherwise      -> addTickLHsExpr e++-- | A let body is treated differently from addTickLHsExprEvalInner+-- above with TickForBreakPoints, because for breakpoints we always+-- want to tick the body, even if it is not a redex.  See test+-- break012.  This gives the user the opportunity to inspect the+-- values of the let-bound variables.+addTickLHsExprLetBody :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExprLetBody e@(dL->L pos e0) = do+  d <- getDensity+  case d of+     TickForBreakPoints | HsLet{} <- e0 -> dont_tick_it+                        | otherwise     -> tick_it+     _other -> addTickLHsExprEvalInner e+ where+   tick_it      = allocTickBox (ExpBox False) False False pos $ addTickHsExpr e0+   dont_tick_it = addTickLHsExprNever e++-- version of addTick that does not actually add a tick,+-- because the scope of this tick is completely subsumed by+-- another.+addTickLHsExprNever :: LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExprNever (dL->L pos e0) = do+    e1 <- addTickHsExpr e0+    return $ cL pos e1++-- general heuristic: expressions which do not denote values are good+-- break points+isGoodBreakExpr :: HsExpr GhcTc -> Bool+isGoodBreakExpr (HsApp {})     = True+isGoodBreakExpr (HsAppType {}) = True+isGoodBreakExpr (OpApp {})     = True+isGoodBreakExpr _other         = False++isCallSite :: HsExpr GhcTc -> Bool+isCallSite HsApp{}     = True+isCallSite HsAppType{} = True+isCallSite OpApp{}     = True+isCallSite _ = False++addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickLHsExprOptAlt oneOfMany (dL->L pos e0)+  = ifDensity TickForCoverage+        (allocTickBox (ExpBox oneOfMany) False False pos $ addTickHsExpr e0)+        (addTickLHsExpr (cL pos e0))++addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addBinTickLHsExpr boxLabel (dL->L pos e0)+  = ifDensity TickForCoverage+        (allocBinTickBox boxLabel pos $ addTickHsExpr e0)+        (addTickLHsExpr (cL pos e0))+++-- -----------------------------------------------------------------------------+-- Decorate the body of an HsExpr with ticks.+-- (Whether to put a tick around the whole expression was already decided,+-- in the addTickLHsExpr family of functions.)++addTickHsExpr :: HsExpr GhcTc -> TM (HsExpr GhcTc)+addTickHsExpr e@(HsVar _ (dL->L _ id)) = do freeVar id; return e+addTickHsExpr (HsUnboundVar {})    = panic "addTickHsExpr.HsUnboundVar"+addTickHsExpr e@(HsConLikeOut _ con)+  | Just id <- conLikeWrapId_maybe con = do freeVar id; return e+addTickHsExpr e@(HsIPVar {})       = return e+addTickHsExpr e@(HsOverLit {})     = return e+addTickHsExpr e@(HsOverLabel{})    = return e+addTickHsExpr e@(HsLit {})         = return e+addTickHsExpr (HsLam x matchgroup) = liftM (HsLam x)+                                           (addTickMatchGroup True matchgroup)+addTickHsExpr (HsLamCase x mgs)    = liftM (HsLamCase x)+                                           (addTickMatchGroup True mgs)+addTickHsExpr (HsApp x e1 e2)      = liftM2 (HsApp x) (addTickLHsExprNever e1)+                                                      (addTickLHsExpr      e2)+addTickHsExpr (HsAppType x e ty)   = liftM3 HsAppType (return x)+                                                      (addTickLHsExprNever e)+                                                      (return ty)++addTickHsExpr (OpApp fix e1 e2 e3) =+        liftM4 OpApp+                (return fix)+                (addTickLHsExpr e1)+                (addTickLHsExprNever e2)+                (addTickLHsExpr e3)+addTickHsExpr (NegApp x e neg) =+        liftM2 (NegApp x)+                (addTickLHsExpr e)+                (addTickSyntaxExpr hpcSrcSpan neg)+addTickHsExpr (HsPar x e) =+        liftM (HsPar x) (addTickLHsExprEvalInner e)+addTickHsExpr (SectionL x e1 e2) =+        liftM2 (SectionL x)+                (addTickLHsExpr e1)+                (addTickLHsExprNever e2)+addTickHsExpr (SectionR x e1 e2) =+        liftM2 (SectionR x)+                (addTickLHsExprNever e1)+                (addTickLHsExpr e2)+addTickHsExpr (ExplicitTuple x es boxity) =+        liftM2 (ExplicitTuple x)+                (mapM addTickTupArg es)+                (return boxity)+addTickHsExpr (ExplicitSum ty tag arity e) = do+        e' <- addTickLHsExpr e+        return (ExplicitSum ty tag arity e')+addTickHsExpr (HsCase x e mgs) =+        liftM2 (HsCase x)+                (addTickLHsExpr e) -- not an EvalInner; e might not necessarily+                                   -- be evaluated.+                (addTickMatchGroup False mgs)+addTickHsExpr (HsIf x cnd e1 e2 e3) =+        liftM3 (HsIf x cnd)+                (addBinTickLHsExpr (BinBox CondBinBox) e1)+                (addTickLHsExprOptAlt True e2)+                (addTickLHsExprOptAlt True e3)+addTickHsExpr (HsMultiIf ty alts)+  = do { let isOneOfMany = case alts of [_] -> False; _ -> True+       ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts+       ; return $ HsMultiIf ty alts' }+addTickHsExpr (HsLet x (dL->L l binds) e) =+        bindLocals (collectLocalBinders binds) $+          liftM2 (HsLet x . cL l)+                  (addTickHsLocalBinds binds) -- to think about: !patterns.+                  (addTickLHsExprLetBody e)+addTickHsExpr (HsDo srcloc cxt (dL->L l stmts))+  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())+       ; return (HsDo srcloc cxt (cL l stmts')) }+  where+        forQual = case cxt of+                    ListComp -> Just $ BinBox QualBinBox+                    _        -> Nothing+addTickHsExpr (ExplicitList ty wit es) =+        liftM3 ExplicitList+                (return ty)+                (addTickWit wit)+                (mapM (addTickLHsExpr) es)+             where addTickWit Nothing = return Nothing+                   addTickWit (Just fln)+                     = do fln' <- addTickSyntaxExpr hpcSrcSpan fln+                          return (Just fln')++addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e++addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })+  = do { rec_binds' <- addTickHsRecordBinds rec_binds+       ; return (expr { rcon_flds = rec_binds' }) }++addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = flds })+  = do { e' <- addTickLHsExpr e+       ; flds' <- mapM addTickHsRecField flds+       ; return (expr { rupd_expr = e', rupd_flds = flds' }) }++addTickHsExpr (ExprWithTySig x e ty) =+        liftM3 ExprWithTySig+                (return x)+                (addTickLHsExprNever e) -- No need to tick the inner expression+                                        -- for expressions with signatures+                (return ty)+addTickHsExpr (ArithSeq ty wit arith_seq) =+        liftM3 ArithSeq+                (return ty)+                (addTickWit wit)+                (addTickArithSeqInfo arith_seq)+             where addTickWit Nothing = return Nothing+                   addTickWit (Just fl) = do fl' <- addTickSyntaxExpr hpcSrcSpan fl+                                             return (Just fl')++-- We might encounter existing ticks (multiple Coverage passes)+addTickHsExpr (HsTick x t e) =+        liftM (HsTick x t) (addTickLHsExprNever e)+addTickHsExpr (HsBinTick x t0 t1 e) =+        liftM (HsBinTick x t0 t1) (addTickLHsExprNever e)++addTickHsExpr (HsTickPragma _ _ _ _ (dL->L pos e0)) = do+    e2 <- allocTickBox (ExpBox False) False False pos $+                addTickHsExpr e0+    return $ unLoc e2+addTickHsExpr (HsSCC x src nm e) =+        liftM3 (HsSCC x)+                (return src)+                (return nm)+                (addTickLHsExpr e)+addTickHsExpr (HsCoreAnn x src nm e) =+        liftM3 (HsCoreAnn x)+                (return src)+                (return nm)+                (addTickLHsExpr e)+addTickHsExpr e@(HsBracket     {})   = return e+addTickHsExpr e@(HsTcBracketOut  {}) = return e+addTickHsExpr e@(HsRnBracketOut  {}) = return e+addTickHsExpr e@(HsSpliceE  {})      = return e+addTickHsExpr (HsProc x pat cmdtop) =+        liftM2 (HsProc x)+                (addTickLPat pat)+                (liftL (addTickHsCmdTop) cmdtop)+addTickHsExpr (HsWrap x w e) =+        liftM2 (HsWrap x)+                (return w)+                (addTickHsExpr e)       -- Explicitly no tick on inside++-- Others should never happen in expression content.+addTickHsExpr e  = pprPanic "addTickHsExpr" (ppr e)++addTickTupArg :: LHsTupArg GhcTc -> TM (LHsTupArg GhcTc)+addTickTupArg (dL->L l (Present x e))  = do { e' <- addTickLHsExpr e+                                            ; return (cL l (Present x e')) }+addTickTupArg (dL->L l (Missing ty)) = return (cL l (Missing ty))+addTickTupArg (dL->L _ (XTupArg _)) = panic "addTickTupArg"+addTickTupArg _  = panic "addTickTupArg: Impossible Match" -- due to #15884+++addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup GhcTc (LHsExpr GhcTc)+                  -> TM (MatchGroup GhcTc (LHsExpr GhcTc))+addTickMatchGroup is_lam mg@(MG { mg_alts = dL->L l matches }) = do+  let isOneOfMany = matchesOneOfMany matches+  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches+  return $ mg { mg_alts = cL l matches' }+addTickMatchGroup _ (XMatchGroup _) = panic "addTickMatchGroup"++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 _) = panic "addTickMatch"++addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)+             -> TM (GRHSs GhcTc (LHsExpr GhcTc))+addTickGRHSs isOneOfMany isLambda (GRHSs x guarded (dL->L l local_binds)) = do+  bindLocals binders $ do+    local_binds' <- addTickHsLocalBinds local_binds+    guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded+    return $ GRHSs x guarded' (cL l local_binds')+  where+    binders = collectLocalBinders local_binds+addTickGRHSs _ _ (XGRHSs _) = panic "addTickGRHSs"++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 _) = panic "addTickGRHS"++addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)+addTickGRHSBody isOneOfMany isLambda expr@(dL->L pos e0) = do+  d <- getDensity+  case d of+    TickForCoverage  -> addTickLHsExprOptAlt isOneOfMany expr+    TickAllFunctions | isLambda ->+       addPathEntry "\\" $+         allocTickBox (ExpBox False) True{-count-} False{-not top-} pos $+           addTickHsExpr e0+    _otherwise ->+       addTickLHsExprRHS expr++addTickLStmts :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc]+              -> TM [ExprLStmt GhcTc]+addTickLStmts isGuard stmts = do+  (stmts, _) <- addTickLStmts' isGuard stmts (return ())+  return stmts++addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [ExprLStmt GhcTc] -> TM a+               -> TM ([ExprLStmt GhcTc], a)+addTickLStmts' isGuard lstmts res+  = bindLocals (collectLStmtsBinders lstmts) $+    do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts+       ; a <- res+       ; return (lstmts', a) }++addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt GhcTc (LHsExpr GhcTc)+            -> TM (Stmt GhcTc (LHsExpr GhcTc))+addTickStmt _isGuard (LastStmt x e noret ret) = do+        liftM3 (LastStmt x)+                (addTickLHsExpr e)+                (pure noret)+                (addTickSyntaxExpr hpcSrcSpan ret)+addTickStmt _isGuard (BindStmt x pat e bind fail) = do+        liftM4 (BindStmt x)+                (addTickLPat pat)+                (addTickLHsExprRHS e)+                (addTickSyntaxExpr hpcSrcSpan bind)+                (addTickSyntaxExpr hpcSrcSpan fail)+addTickStmt isGuard (BodyStmt x e bind' guard') = do+        liftM3 (BodyStmt x)+                (addTick isGuard e)+                (addTickSyntaxExpr hpcSrcSpan bind')+                (addTickSyntaxExpr hpcSrcSpan guard')+addTickStmt _isGuard (LetStmt x (dL->L l binds)) = do+        liftM (LetStmt x . cL l)+                (addTickHsLocalBinds binds)+addTickStmt isGuard (ParStmt x pairs mzipExpr bindExpr) = do+    liftM3 (ParStmt x)+        (mapM (addTickStmtAndBinders isGuard) pairs)+        (unLoc <$> addTickLHsExpr (cL hpcSrcSpan mzipExpr))+        (addTickSyntaxExpr hpcSrcSpan bindExpr)+addTickStmt isGuard (ApplicativeStmt body_ty args mb_join) = do+    args' <- mapM (addTickApplicativeArg isGuard) args+    return (ApplicativeStmt body_ty args' mb_join)++addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts+                                    , trS_by = by, trS_using = using+                                    , trS_ret = returnExpr, trS_bind = bindExpr+                                    , trS_fmap = liftMExpr }) = do+    t_s <- addTickLStmts isGuard stmts+    t_y <- fmapMaybeM  addTickLHsExprRHS by+    t_u <- addTickLHsExprRHS using+    t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr+    t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr+    t_m <- fmap unLoc (addTickLHsExpr (cL hpcSrcSpan liftMExpr))+    return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u+                  , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m }++addTickStmt isGuard stmt@(RecStmt {})+  = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt)+       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)+       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)+       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)+       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'+                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }++addTickStmt _ (XStmtLR _) = panic "addTickStmt"++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) =+    (ApplicativeArgOne x)+      <$> addTickLPat pat+      <*> addTickLHsExpr expr+      <*> pure isBody+  addTickArg (ApplicativeArgMany x stmts ret pat) =+    (ApplicativeArgMany x)+      <$> addTickLStmts isGuard stmts+      <*> (unLoc <$> addTickLHsExpr (cL hpcSrcSpan ret))+      <*> addTickLPat pat+  addTickArg (XApplicativeArg _) = panic "addTickApplicativeArg"++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{}) = panic "addTickStmtAndBinders"++addTickHsLocalBinds :: HsLocalBinds GhcTc -> TM (HsLocalBinds GhcTc)+addTickHsLocalBinds (HsValBinds x binds) =+        liftM (HsValBinds x)+                (addTickHsValBinds binds)+addTickHsLocalBinds (HsIPBinds x binds)  =+        liftM (HsIPBinds x)+                (addTickHsIPBinds binds)+addTickHsLocalBinds (EmptyLocalBinds x)  = return (EmptyLocalBinds x)+addTickHsLocalBinds (XHsLocalBindsLR x)  = return (XHsLocalBindsLR x)++addTickHsValBinds :: HsValBindsLR GhcTc (GhcPass a)+                  -> TM (HsValBindsLR GhcTc (GhcPass b))+addTickHsValBinds (XValBindsLR (NValBinds binds sigs)) = do+        b <- liftM2 NValBinds+                (mapM (\ (rec,binds') ->+                                liftM2 (,)+                                        (return rec)+                                        (addTickLHsBinds binds'))+                        binds)+                (return sigs)+        return $ XValBindsLR b+addTickHsValBinds _ = panic "addTickHsValBinds"++addTickHsIPBinds :: HsIPBinds GhcTc -> TM (HsIPBinds GhcTc)+addTickHsIPBinds (IPBinds dictbinds ipbinds) =+        liftM2 IPBinds+                (return dictbinds)+                (mapM (liftL (addTickIPBind)) ipbinds)+addTickHsIPBinds (XHsIPBinds x) = return (XHsIPBinds x)++addTickIPBind :: IPBind GhcTc -> TM (IPBind GhcTc)+addTickIPBind (IPBind x nm e) =+        liftM2 (IPBind x)+                (return nm)+                (addTickLHsExpr e)+addTickIPBind (XIPBind x) = return (XIPBind x)++-- There is no location here, so we might need to use a context location??+addTickSyntaxExpr :: SrcSpan -> SyntaxExpr GhcTc -> TM (SyntaxExpr GhcTc)+addTickSyntaxExpr pos syn@(SyntaxExpr { syn_expr = x }) = do+        x' <- fmap unLoc (addTickLHsExpr (cL pos x))+        return $ syn { syn_expr = x' }+-- we do not walk into patterns.+addTickLPat :: LPat GhcTc -> TM (LPat GhcTc)+addTickLPat pat = return pat++addTickHsCmdTop :: HsCmdTop GhcTc -> TM (HsCmdTop GhcTc)+addTickHsCmdTop (HsCmdTop x cmd) =+        liftM2 HsCmdTop+                (return x)+                (addTickLHsCmd cmd)+addTickHsCmdTop (XCmdTop{}) = panic "addTickHsCmdTop"++addTickLHsCmd ::  LHsCmd GhcTc -> TM (LHsCmd GhcTc)+addTickLHsCmd (dL->L pos c0) = do+        c1 <- addTickHsCmd c0+        return $ cL pos c1++addTickHsCmd :: HsCmd GhcTc -> TM (HsCmd GhcTc)+addTickHsCmd (HsCmdLam x matchgroup) =+        liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)+addTickHsCmd (HsCmdApp x c e) =+        liftM2 (HsCmdApp x) (addTickLHsCmd c) (addTickLHsExpr e)+{-+addTickHsCmd (OpApp e1 c2 fix c3) =+        liftM4 OpApp+                (addTickLHsExpr e1)+                (addTickLHsCmd c2)+                (return fix)+                (addTickLHsCmd c3)+-}+addTickHsCmd (HsCmdPar x e) = liftM (HsCmdPar x) (addTickLHsCmd e)+addTickHsCmd (HsCmdCase x e mgs) =+        liftM2 (HsCmdCase x)+                (addTickLHsExpr e)+                (addTickCmdMatchGroup mgs)+addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =+        liftM3 (HsCmdIf x cnd)+                (addBinTickLHsExpr (BinBox CondBinBox) e1)+                (addTickLHsCmd c2)+                (addTickLHsCmd c3)+addTickHsCmd (HsCmdLet x (dL->L l binds) c) =+        bindLocals (collectLocalBinders binds) $+          liftM2 (HsCmdLet x . cL l)+                   (addTickHsLocalBinds binds) -- to think about: !patterns.+                   (addTickLHsCmd c)+addTickHsCmd (HsCmdDo srcloc (dL->L l stmts))+  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())+       ; return (HsCmdDo srcloc (cL l stmts')) }++addTickHsCmd (HsCmdArrApp  arr_ty e1 e2 ty1 lr) =+        liftM5 HsCmdArrApp+               (return arr_ty)+               (addTickLHsExpr e1)+               (addTickLHsExpr e2)+               (return ty1)+               (return lr)+addTickHsCmd (HsCmdArrForm x e f fix cmdtop) =+        liftM4 (HsCmdArrForm x)+               (addTickLHsExpr e)+               (return f)+               (return fix)+               (mapM (liftL (addTickHsCmdTop)) cmdtop)++addTickHsCmd (HsCmdWrap x w cmd)+  = liftM2 (HsCmdWrap x) (return w) (addTickHsCmd cmd)++addTickHsCmd e@(XCmd {})  = pprPanic "addTickHsCmd" (ppr e)++-- Others should never happen in a command context.+--addTickHsCmd e  = pprPanic "addTickHsCmd" (ppr e)++addTickCmdMatchGroup :: MatchGroup GhcTc (LHsCmd GhcTc)+                     -> TM (MatchGroup GhcTc (LHsCmd GhcTc))+addTickCmdMatchGroup mg@(MG { mg_alts = (dL->L l matches) }) = do+  matches' <- mapM (liftL addTickCmdMatch) matches+  return $ mg { mg_alts = cL l matches' }+addTickCmdMatchGroup (XMatchGroup _) = panic "addTickCmdMatchGroup"++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 _) = panic "addTickCmdMatch"++addTickCmdGRHSs :: GRHSs GhcTc (LHsCmd GhcTc) -> TM (GRHSs GhcTc (LHsCmd GhcTc))+addTickCmdGRHSs (GRHSs x guarded (dL->L l local_binds)) = do+  bindLocals binders $ do+    local_binds' <- addTickHsLocalBinds local_binds+    guarded' <- mapM (liftL addTickCmdGRHS) guarded+    return $ GRHSs x guarded' (cL l local_binds')+  where+    binders = collectLocalBinders local_binds+addTickCmdGRHSs (XGRHSs _) = panic "addTickCmdGRHSs"++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 _) = panic "addTickCmdGRHS"++addTickLCmdStmts :: [LStmt GhcTc (LHsCmd GhcTc)]+                 -> TM [LStmt GhcTc (LHsCmd GhcTc)]+addTickLCmdStmts stmts = do+  (stmts, _) <- addTickLCmdStmts' stmts (return ())+  return stmts++addTickLCmdStmts' :: [LStmt GhcTc (LHsCmd GhcTc)] -> TM a+                  -> TM ([LStmt GhcTc (LHsCmd GhcTc)], a)+addTickLCmdStmts' lstmts res+  = bindLocals binders $ do+        lstmts' <- mapM (liftL addTickCmdStmt) lstmts+        a <- res+        return (lstmts', a)+  where+        binders = collectLStmtsBinders lstmts++addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))+addTickCmdStmt (BindStmt x pat c bind fail) = do+        liftM4 (BindStmt x)+                (addTickLPat pat)+                (addTickLHsCmd c)+                (return bind)+                (return fail)+addTickCmdStmt (LastStmt x c noret ret) = do+        liftM3 (LastStmt x)+                (addTickLHsCmd c)+                (pure noret)+                (addTickSyntaxExpr hpcSrcSpan ret)+addTickCmdStmt (BodyStmt x c bind' guard') = do+        liftM3 (BodyStmt x)+                (addTickLHsCmd c)+                (addTickSyntaxExpr hpcSrcSpan bind')+                (addTickSyntaxExpr hpcSrcSpan guard')+addTickCmdStmt (LetStmt x (dL->L l binds)) = do+        liftM (LetStmt x . cL l)+                (addTickHsLocalBinds binds)+addTickCmdStmt stmt@(RecStmt {})+  = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)+       ; ret'   <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)+       ; mfix'  <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt)+       ; bind'  <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt)+       ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret'+                      , recS_mfix_fn = mfix', recS_bind_fn = bind' }) }+addTickCmdStmt ApplicativeStmt{} =+  panic "ToDo: addTickCmdStmt ApplicativeLastStmt"+addTickCmdStmt XStmtLR{} =+  panic "addTickCmdStmt XStmtLR"++-- Others should never happen in a command context.+addTickCmdStmt stmt  = pprPanic "addTickHsCmd" (ppr stmt)++addTickHsRecordBinds :: HsRecordBinds GhcTc -> TM (HsRecordBinds GhcTc)+addTickHsRecordBinds (HsRecFields fields dd)+  = do  { fields' <- mapM addTickHsRecField fields+        ; return (HsRecFields fields' dd) }++addTickHsRecField :: LHsRecField' id (LHsExpr GhcTc)+                  -> TM (LHsRecField' id (LHsExpr GhcTc))+addTickHsRecField (dL->L l (HsRecField id expr pun))+        = do { expr' <- addTickLHsExpr expr+             ; return (cL l (HsRecField id expr' pun)) }+++addTickArithSeqInfo :: ArithSeqInfo GhcTc -> TM (ArithSeqInfo GhcTc)+addTickArithSeqInfo (From e1) =+        liftM From+                (addTickLHsExpr e1)+addTickArithSeqInfo (FromThen e1 e2) =+        liftM2 FromThen+                (addTickLHsExpr e1)+                (addTickLHsExpr e2)+addTickArithSeqInfo (FromTo e1 e2) =+        liftM2 FromTo+                (addTickLHsExpr e1)+                (addTickLHsExpr e2)+addTickArithSeqInfo (FromThenTo e1 e2 e3) =+        liftM3 FromThenTo+                (addTickLHsExpr e1)+                (addTickLHsExpr e2)+                (addTickLHsExpr e3)++data TickTransState = TT { tickBoxCount:: Int+                         , mixEntries  :: [MixEntry_]+                         , ccIndices   :: CostCentreState+                         }++data TickTransEnv = TTE { fileName     :: FastString+                        , density      :: TickDensity+                        , tte_dflags   :: DynFlags+                        , exports      :: NameSet+                        , inlines      :: VarSet+                        , declPath     :: [String]+                        , inScope      :: VarSet+                        , blackList    :: Map SrcSpan ()+                        , this_mod     :: Module+                        , tickishType  :: TickishType+                        }++--      deriving Show++data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes+                 deriving (Eq)++coveragePasses :: DynFlags -> [TickishType]+coveragePasses dflags =+    ifa (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.++data TM a = TM { unTM :: TickTransEnv -> TickTransState -> (a,FreeVars,TickTransState) }+        -- a combination of a state monad (TickTransState) and a writer+        -- monad (FreeVars).++instance Functor TM where+    fmap = liftM++instance Applicative TM where+    pure a = TM $ \ _env st -> (a,noFVs,st)+    (<*>) = ap++instance Monad TM where+  (TM m) >>= k = TM $ \ env st ->+                                case m env st of+                                  (r1,fv1,st1) ->+                                     case unTM (k r1) env st1 of+                                       (r2,fv2,st2) ->+                                          (r2, fv1 `plusOccEnv` fv2, st2)++instance HasDynFlags TM where+  getDynFlags = TM $ \ env st -> (tte_dflags env, noFVs, st)++-- | Get the next HPC cost centre index for a given centre name+getCCIndexM :: FastString -> TM CostCentreIndex+getCCIndexM n = TM $ \_ st -> let (idx, is') = getCCIndex n $+                                                 ccIndices st+                              in (idx, noFVs, st { ccIndices = is' })++getState :: TM TickTransState+getState = TM $ \ _ st -> (st, noFVs, st)++setState :: (TickTransState -> TickTransState) -> TM ()+setState f = TM $ \ _ st -> ((), noFVs, f st)++getEnv :: TM TickTransEnv+getEnv = TM $ \ env st -> (env, noFVs, st)++withEnv :: (TickTransEnv -> TickTransEnv) -> TM a -> TM a+withEnv f (TM m) = TM $ \ env st ->+                                 case m (f env) st of+                                   (a, fvs, st') -> (a, fvs, st')++getDensity :: TM TickDensity+getDensity = TM $ \env st -> (density env, noFVs, st)++ifDensity :: TickDensity -> TM a -> TM a -> TM a+ifDensity d th el = do d0 <- getDensity; if d == d0 then th else el++getFreeVars :: TM a -> TM (FreeVars, a)+getFreeVars (TM m)+  = TM $ \ env st -> case m env st of (a, fv, st') -> ((fv,a), fv, st')++freeVar :: Id -> TM ()+freeVar id = TM $ \ env st ->+                if id `elemVarSet` inScope env+                   then ((), unitOccEnv (nameOccName (idName id)) id, st)+                   else ((), noFVs, st)++addPathEntry :: String -> TM a -> TM a+addPathEntry nm = withEnv (\ env -> env { declPath = declPath env ++ [nm] })++getPathEntry :: TM [String]+getPathEntry = declPath `liftM` getEnv++getFileName :: TM FastString+getFileName = fileName `liftM` getEnv++isGoodSrcSpan' :: SrcSpan -> Bool+isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos+isGoodSrcSpan' (UnhelpfulSpan _) = False++isGoodTickSrcSpan :: SrcSpan -> TM Bool+isGoodTickSrcSpan pos = do+  file_name <- getFileName+  tickish <- tickishType `liftM` getEnv+  let need_same_file = tickSameFileOnly tickish+      same_file      = Just file_name == srcSpanFileName_maybe pos+  return (isGoodSrcSpan' pos && (not need_same_file || same_file))++ifGoodTickSrcSpan :: SrcSpan -> TM a -> TM a -> TM a+ifGoodTickSrcSpan pos then_code else_code = do+  good <- isGoodTickSrcSpan pos+  if good then then_code else else_code++bindLocals :: [Id] -> TM a -> TM a+bindLocals new_ids (TM m)+  = TM $ \ env st ->+                 case m env{ inScope = inScope env `extendVarSetList` new_ids } st of+                   (r, fv, st') -> (r, fv `delListFromOccEnv` occs, st')+  where occs = [ nameOccName (idName id) | id <- new_ids ]++isBlackListed :: SrcSpan -> TM Bool+isBlackListed pos = TM $ \ env st ->+              case Map.lookup pos (blackList env) of+                Nothing -> (False,noFVs,st)+                Just () -> (True,noFVs,st)++-- the tick application inherits the source position of its+-- expression argument to support nested box allocations+allocTickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> TM (HsExpr GhcTc)+             -> TM (LHsExpr GhcTc)+allocTickBox boxLabel countEntries topOnly pos m =+  ifGoodTickSrcSpan pos (do+    (fvs, e) <- getFreeVars m+    env <- getEnv+    tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)+    return (cL pos (HsTick noExt tickish (cL pos e)))+  ) (do+    e <- m+    return (cL pos e)+  )++-- the tick application inherits the source position of its+-- expression argument to support nested box allocations+allocATickBox :: BoxLabel -> Bool -> Bool -> SrcSpan -> FreeVars+              -> TM (Maybe (Tickish Id))+allocATickBox boxLabel countEntries topOnly  pos fvs =+  ifGoodTickSrcSpan pos (do+    let+      mydecl_path = case boxLabel of+                      TopLevelBox x -> x+                      LocalBox xs  -> xs+                      _ -> panic "allocATickBox"+    tickish <- mkTickish boxLabel countEntries topOnly pos fvs mydecl_path+    return (Just tickish)+  ) (return Nothing)+++mkTickish :: BoxLabel -> Bool -> Bool -> SrcSpan -> OccEnv Id -> [String]+          -> TM (Tickish Id)+mkTickish boxLabel countEntries topOnly pos fvs decl_path = do++  let ids = filter (not . isUnliftedType . idType) $ occEnvElts fvs+          -- unlifted types cause two problems here:+          --   * we can't bind them  at the GHCi prompt+          --     (bindLocalsAtBreakpoint already fliters them out),+          --   * the simplifier might try to substitute a literal for+          --     the Id, and we can't handle that.++      me = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)++      cc_name | topOnly   = head decl_path+              | otherwise = concat (intersperse "." decl_path)++  dflags <- getDynFlags+  env <- getEnv+  case tickishType env of+    HpcTicks -> do+      c <- liftM tickBoxCount getState+      setState $ \st -> st { tickBoxCount = c + 1+                           , mixEntries = me : mixEntries st }+      return $ HpcTick (this_mod env) c++    ProfNotes -> do+      let nm = mkFastString cc_name+      flavour <- HpcCC <$> getCCIndexM nm+      let cc = mkUserCC nm (this_mod env) pos flavour+          count = countEntries && gopt Opt_ProfCountEntries dflags+      return $ ProfNote cc count True{-scopes-}++    Breakpoints -> do+      c <- liftM tickBoxCount getState+      setState $ \st -> st { tickBoxCount = c + 1+                           , mixEntries = me:mixEntries st }+      return $ Breakpoint c ids++    SourceNotes | RealSrcSpan pos' <- pos ->+      return $ SourceNote pos' cc_name++    _otherwise -> panic "mkTickish: bad source span!"+++allocBinTickBox :: (Bool -> BoxLabel) -> SrcSpan -> TM (HsExpr GhcTc)+                -> TM (LHsExpr GhcTc)+allocBinTickBox boxLabel pos m = do+  env <- getEnv+  case tickishType env of+    HpcTicks -> do e <- liftM (cL pos) m+                   ifGoodTickSrcSpan pos+                     (mkBinTickBoxHpc boxLabel pos e)+                     (return e)+    _other   -> allocTickBox (ExpBox False) False False pos m++mkBinTickBoxHpc :: (Bool -> BoxLabel) -> SrcSpan -> LHsExpr GhcTc+                -> TM (LHsExpr GhcTc)+mkBinTickBoxHpc boxLabel pos e =+ TM $ \ env st ->+  let meT = (pos,declPath env, [],boxLabel True)+      meF = (pos,declPath env, [],boxLabel False)+      meE = (pos,declPath env, [],ExpBox False)+      c = tickBoxCount st+      mes = mixEntries st+  in+     ( cL pos $ HsTick noExt (HpcTick (this_mod env) c)+          $ cL pos $ HsBinTick noExt (c+1) (c+2) e+   -- notice that F and T are reversed,+   -- because we are building the list in+   -- reverse...+     , noFVs+     , st {tickBoxCount=c+3 , mixEntries=meF:meT:meE:mes}+     )++mkHpcPos :: SrcSpan -> HpcPos+mkHpcPos pos@(RealSrcSpan s)+   | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s,+                                    srcSpanStartCol s,+                                    srcSpanEndLine s,+                                    srcSpanEndCol s - 1)+                              -- the end column of a SrcSpan is one+                              -- greater than the last column of the+                              -- span (see SrcLoc), whereas HPC+                              -- expects to the column range to be+                              -- inclusive, hence we subtract one above.+mkHpcPos _ = panic "bad source span; expected such spans to be filtered out"++hpcSrcSpan :: SrcSpan+hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals")++matchesOneOfMany :: [LMatch GhcTc body] -> Bool+matchesOneOfMany lmatches = sum (map matchCount lmatches) > 1+  where+        matchCount (dL->L _ (Match { m_grhss = GRHSs _ grhss _ }))+          = length grhss+        matchCount (dL->L _ (Match { m_grhss = XGRHSs _ }))+          = panic "matchesOneOfMany"+        matchCount (dL->L _ (XMatch _)) = panic "matchesOneOfMany"+        matchCount _ = panic "matchCount: Impossible Match" -- due to #15884++type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel)++-- For the hash value, we hash everything: the file name,+--  the timestamp of the original source file, the tab stop,+--  and the mix entries. We cheat, and hash the show'd string.+-- This hash only has to be hashed at Mix creation time,+-- and is for sanity checking only.++mixHash :: FilePath -> UTCTime -> Int -> [MixEntry] -> Int+mixHash file tm tabstop entries = fromIntegral $ hashString+        (show $ Mix file tm 0 tabstop entries)++{-+************************************************************************+*                                                                      *+*              initialisation+*                                                                      *+************************************************************************++Each module compiled with -fhpc declares an initialisation function of+the form `hpc_init_<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 view
@@ -0,0 +1,546 @@+{-+(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 HsSyn+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 (pure dflags)+                     (text "Desugar"<+>brackets (ppr mod))+                     (const ()) $+     do { -- Desugar the program+        ; let export_set = availsToNameSet exports+              target     = hscTarget dflags+              hpcInfo    = emptyHpcInfo other_hpc_info++        ; (binds_cvr, ds_hpc_info, modBreaks)+                         <- if not (isHsBootOrSig hsc_src)+                              then addTicksToBinds hsc_env mod mod_loc+                                       export_set (typeEnvTyCons type_env) binds+                              else return (binds, hpcInfo, Nothing)+        ; (msgs, mb_res) <- initDs hsc_env tcg_env $+                       do { ds_ev_binds <- dsEvBinds ev_binds+                          ; core_prs <- dsTopLHsBinds binds_cvr+                          ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs+                          ; (ds_fords, foreign_prs) <- dsForeigns fords+                          ; ds_rules <- mapMaybeM dsRule rules+                          ; let hpc_init+                                  | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info+                                  | otherwise = empty+                          ; return ( ds_ev_binds+                                   , foreign_prs `appOL` core_prs `appOL` spec_prs+                                   , spec_rules ++ ds_rules+                                   , ds_fords `appendStubC` hpc_init) }++        ; case mb_res of {+           Nothing -> return (msgs, Nothing) ;+           Just (ds_ev_binds, all_prs, all_rules, ds_fords) ->++     do {       -- Add export flags to bindings+          keep_alive <- readIORef keep_var+        ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules+              final_prs = addExportFlagsAndRules target export_set keep_alive+                                                 rules_for_locals (fromOL all_prs)++              final_pgm = combineEvBinds ds_ev_binds final_prs+        -- Notice that we put the whole lot in a big Rec, even the foreign binds+        -- When compiling PrelFloat, which defines data Float = F# Float#+        -- we want F# to be in scope in the foreign marshalling code!+        -- You might think it doesn't matter, but the simplifier brings all top-level+        -- things into the in-scope set before simplifying; so we get no unfolding for F#!++        ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps+        ; (ds_binds, ds_rules_for_imps)+            <- simpleOptPgm dflags mod final_pgm rules_for_imps+                         -- The simpleOptPgm gets rid of type+                         -- bindings plus any stupid dead code++        ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps++        ; let used_names = mkUsedNames tcg_env+              pluginModules =+                map lpModule (cachedPlugins (hsc_dflags hsc_env))+        ; deps <- mkDependencies (thisInstalledUnitId (hsc_dflags hsc_env))+                                 (map mi_module pluginModules) tcg_env++        ; used_th <- readIORef tc_splice_used+        ; dep_files <- readIORef dependent_files+        ; safe_mode <- finalSafeMode dflags tcg_env+        ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names+                      dep_files merged pluginModules+        -- id_mod /= mod when we are processing an hsig, but hsigs+        -- never desugared and compiled (there's no code!)+        -- Consequently, this should hold for any ModGuts that make+        -- past desugaring. See Note [Identity versus semantic module].+        ; MASSERT( id_mod == mod )++        ; foreign_files <- readIORef th_foreign_files_var++        ; let (doc_hdr, decl_docs, arg_docs) = extractDocs tcg_env++        ; let mod_guts = ModGuts {+                mg_module       = mod,+                mg_hsc_src      = hsc_src,+                mg_loc          = mkFileSrcSpan mod_loc,+                mg_exports      = exports,+                mg_usages       = usages,+                mg_deps         = deps,+                mg_used_th      = used_th,+                mg_rdr_env      = rdr_env,+                mg_fix_env      = fix_env,+                mg_warns        = warns,+                mg_anns         = anns,+                mg_tcs          = tcs,+                mg_insts        = fixSafeInstances safe_mode insts,+                mg_fam_insts    = fam_insts,+                mg_inst_env     = inst_env,+                mg_fam_inst_env = fam_inst_env,+                mg_patsyns      = patsyns,+                mg_rules        = ds_rules_for_imps,+                mg_binds        = ds_binds,+                mg_foreign      = ds_fords,+                mg_foreign_files = foreign_files,+                mg_hpc_info     = ds_hpc_info,+                mg_modBreaks    = modBreaks,+                mg_safe_haskell = safe_mode,+                mg_trust_pkg    = imp_trust_own_pkg imports,+                mg_complete_sigs = complete_matches,+                mg_doc_hdr      = doc_hdr,+                mg_decl_docs    = decl_docs,+                mg_arg_docs     = arg_docs+              }+        ; return (msgs, Just mod_guts)+        }}}}++mkFileSrcSpan :: ModLocation -> SrcSpan+mkFileSrcSpan mod_loc+  = case ml_hs_file mod_loc of+      Just file_path -> mkGeneralSrcSpan (mkFastString file_path)+      Nothing        -> interactiveSrcSpan   -- Presumably++dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])+dsImpSpecs imp_specs+ = do { spec_prs <- mapMaybeM (dsSpec Nothing) imp_specs+      ; let (spec_binds, spec_rules) = unzip spec_prs+      ; return (concatOL spec_binds, spec_rules) }++combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]+-- Top-level bindings can include coercion bindings, but not via superclasses+-- See Note [Top-level evidence]+combineEvBinds [] val_prs+  = [Rec val_prs]+combineEvBinds (NonRec b r : bs) val_prs+  | isId b    = combineEvBinds bs ((b,r):val_prs)+  | otherwise = NonRec b r : combineEvBinds bs val_prs+combineEvBinds (Rec prs : bs) val_prs+  = combineEvBinds bs (prs ++ val_prs)++{-+Note [Top-level evidence]+~~~~~~~~~~~~~~~~~~~~~~~~~+Top-level evidence bindings may be mutually recursive with the top-level value+bindings, so we must put those in a Rec.  But we can't put them *all* in a Rec+because the occurrence analyser doesn't take account of type/coercion variables+when computing dependencies.++So we pull out the type/coercion variables (which are in dependency order),+and Rec the rest.+-}++deSugarExpr :: HscEnv -> LHsExpr GhcTc -> IO (Messages, Maybe CoreExpr)++deSugarExpr hsc_env tc_expr = do {+         let dflags = hsc_dflags hsc_env++       ; showPass dflags "Desugar"++         -- Do desugaring+       ; (msgs, mb_core_expr) <- runTcInteractive hsc_env $ initDsTc $+                                 dsLExpr tc_expr++       ; case mb_core_expr of+            Nothing   -> return ()+            Just expr -> dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared"+                         (pprCoreExpr expr)++       ; return (msgs, mb_core_expr) }++{-+************************************************************************+*                                                                      *+*              Add rules and export flags to binders+*                                                                      *+************************************************************************+-}++addExportFlagsAndRules+    :: HscTarget -> NameSet -> NameSet -> [CoreRule]+    -> [(Id, t)] -> [(Id, t)]+addExportFlagsAndRules target exports keep_alive rules prs+  = mapFst add_one prs+  where+    add_one bndr = add_rules name (add_export name bndr)+       where+         name = idName bndr++    ---------- Rules --------+        -- See Note [Attach rules to local ids]+        -- NB: the binder might have some existing rules,+        -- arising from specialisation pragmas+    add_rules name bndr+        | Just rules <- lookupNameEnv rule_base name+        = bndr `addIdSpecialisations` rules+        | otherwise+        = bndr+    rule_base = extendRuleBaseList emptyRuleBase rules++    ---------- Export flag --------+    -- See Note [Adding export flags]+    add_export name bndr+        | dont_discard name = setIdExported bndr+        | otherwise         = bndr++    dont_discard :: Name -> Bool+    dont_discard name = is_exported name+                     || name `elemNameSet` keep_alive++        -- In interactive mode, we don't want to discard any top-level+        -- entities at all (eg. do not inline them away during+        -- simplification), and retain them all in the TypeEnv so they are+        -- available from the command line.+        --+        -- isExternalName separates the user-defined top-level names from those+        -- introduced by the type checker.+    is_exported :: Name -> Bool+    is_exported | targetRetainsAllBindings target = isExternalName+                | otherwise                       = (`elemNameSet` exports)++{-+Note [Adding export flags]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Set the no-discard flag if either+        a) the Id is exported+        b) it's mentioned in the RHS of an orphan rule+        c) it's in the keep-alive set++It means that the binding won't be discarded EVEN if the binding+ends up being trivial (v = w) -- the simplifier would usually just+substitute w for v throughout, but we don't apply the substitution to+the rules (maybe we should?), so this substitution would make the rule+bogus.++You might wonder why exported Ids aren't already marked as such;+it's just because the type checker is rather busy already and+I didn't want to pass in yet another mapping.++Note [Attach rules to local ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Find the rules for locally-defined Ids; then we can attach them+to the binders in the top-level bindings++Reason+  - It makes the rules easier to look up+  - It means that transformation rules and specialisations for+    locally defined Ids are handled uniformly+  - It keeps alive things that are referred to only from a rule+    (the occurrence analyser knows about rules attached to Ids)+  - It makes sure that, when we apply a rule, the free vars+    of the RHS are more likely to be in scope+  - The imported rules are carried in the in-scope set+    which is extended on each iteration by the new wave of+    local binders; any rules which aren't on the binding will+    thereby get dropped+++************************************************************************+*                                                                      *+*              Desugaring transformation rules+*                                                                      *+************************************************************************+-}++dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule)+dsRule (dL->L loc (HsRule { rd_name = name+                          , rd_act  = rule_act+                          , rd_tmvs = vars+                          , rd_lhs  = lhs+                          , rd_rhs  = rhs }))+  = putSrcSpanDs loc $+    do  { let bndrs' = [var | (dL->L _ (RuleBndr _ (dL->L _ var))) <- vars]++        ; lhs' <- unsetGOptM Opt_EnableRewriteRules $+                  unsetWOptM Opt_WarnIdentities $+                  dsLExpr lhs   -- Note [Desugaring RULE left hand sides]++        ; rhs' <- dsLExpr rhs+        ; this_mod <- getModule++        ; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'++        -- Substitute the dict bindings eagerly,+        -- and take the body apart into a (f args) form+        ; dflags <- getDynFlags+        ; case decomposeRuleLhs dflags bndrs'' lhs'' of {+                Left msg -> do { warnDs NoReason msg; return Nothing } ;+                Right (final_bndrs, fn_id, args) -> do++        { let is_local = isLocalId fn_id+                -- NB: isLocalId is False of implicit Ids.  This is good because+                -- we don't want to attach rules to the bindings of implicit Ids,+                -- because they don't show up in the bindings until just before code gen+              fn_name   = idName fn_id+              final_rhs = simpleOptExpr dflags rhs''    -- De-crap it+              rule_name = snd (unLoc name)+              final_bndrs_set = mkVarSet final_bndrs+              arg_ids = filterOut (`elemVarSet` final_bndrs_set) $+                        exprsSomeFreeVarsList isId args++        ; rule <- dsMkUserRule this_mod is_local+                         rule_name rule_act fn_name final_bndrs args+                         final_rhs+        ; when (wopt Opt_WarnInlineRuleShadowing dflags) $+          warnRuleShadowing rule_name rule_act fn_id arg_ids++        ; return (Just rule)+        } } }+dsRule (dL->L _ (XRuleDecl _)) = panic "dsRule"+dsRule _ = panic "dsRule: Impossible Match" -- due to #15884++warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()+-- See Note [Rules and inlining/other rules]+warnRuleShadowing rule_name rule_act fn_id arg_ids+  = do { check False fn_id    -- We often have multiple rules for the same Id in a+                              -- module. Maybe we should check that they don't overlap+                              -- but currently we don't+       ; mapM_ (check True) arg_ids }+  where+    check check_rules_too lhs_id+      | isLocalId lhs_id || canUnfold (idUnfolding lhs_id)+                       -- If imported with no unfolding, no worries+      , idInlineActivation lhs_id `competesWith` rule_act+      = warnDs (Reason Opt_WarnInlineRuleShadowing)+               (vcat [ hang (text "Rule" <+> pprRuleName rule_name+                               <+> text "may never fire")+                            2 (text "because" <+> quotes (ppr lhs_id)+                               <+> text "might inline first")+                     , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for"+                       <+> quotes (ppr lhs_id)+                     , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ])++      | check_rules_too+      , bad_rule : _ <- get_bad_rules lhs_id+      = warnDs (Reason Opt_WarnInlineRuleShadowing)+               (vcat [ hang (text "Rule" <+> pprRuleName rule_name+                               <+> text "may never fire")+                            2 (text "because rule" <+> pprRuleName (ruleName bad_rule)+                               <+> text "for"<+> quotes (ppr lhs_id)+                               <+> text "might fire first")+                      , text "Probable fix: add phase [n] or [~n] to the competing rule"+                      , whenPprDebug (ppr bad_rule) ])++      | otherwise+      = return ()++    get_bad_rules lhs_id+      = [ rule | rule <- idCoreRules lhs_id+               , ruleActivation rule `competesWith` rule_act ]++-- See Note [Desugaring coerce as cast]+unfold_coerce :: [Id] -> CoreExpr -> CoreExpr -> DsM ([Var], CoreExpr, CoreExpr)+unfold_coerce bndrs lhs rhs = do+    (bndrs', wrap) <- go bndrs+    return (bndrs', wrap lhs, wrap rhs)+  where+    go :: [Id] -> DsM ([Id], CoreExpr -> CoreExpr)+    go []     = return ([], id)+    go (v:vs)+        | Just (tc, [k, t1, t2]) <- splitTyConApp_maybe (idType v)+        , tc `hasKey` coercibleTyConKey = do+            u <- newUnique++            let ty' = mkTyConApp eqReprPrimTyCon [k, k, t1, t2]+                v'  = mkLocalCoVar+                        (mkDerivedInternalName mkRepEqOcc u (getName v)) ty'+                box = Var (dataConWrapId coercibleDataCon) `mkTyApps`+                      [k, t1, t2] `App`+                      Coercion (mkCoVarCo v')++            (bndrs, wrap) <- go vs+            return (v':bndrs, mkCoreLet (NonRec v box) . wrap)+        | otherwise = do+            (bndrs,wrap) <- go vs+            return (v:bndrs, wrap)++{- Note [Desugaring RULE left hand sides]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For the LHS of a RULE we do *not* want to desugar+    [x]   to    build (\cn. x `c` n)+We want to leave explicit lists simply as chains+of cons's. We can achieve that slightly indirectly by+switching off EnableRewriteRules.  See DsExpr.dsExplicitList.++That keeps the desugaring of list comprehensions simple too.++Nor do we want to warn of conversion identities on the LHS;+the rule is precisely to optimise them:+  {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}++Note [Desugaring coerce as cast]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want the user to express a rule saying roughly “mapping a coercion over a+list can be replaced by a coercion”. But the cast operator of Core (▷) cannot+be written in Haskell. So we use `coerce` for that (#2110). The user writes+    map coerce = coerce+as a RULE, and this optimizes any kind of mapped' casts away, including `map+MkNewtype`.++For that we replace any forall'ed `c :: Coercible a b` value in a RULE by+corresponding `co :: a ~#R b` and wrap the LHS and the RHS in+`let c = MkCoercible co in ...`. This is later simplified to the desired form+by simpleOptExpr (for the LHS) resp. the simplifiers (for the RHS).+See also Note [Getting the map/coerce RULE to work] in CoreSubst.++Note [Rules and inlining/other rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If you have+  f x = ...+  g x = ...+  {-# RULES "rule-for-f" forall x. f (g x) = ... #-}+then there's a good chance that in a potential rule redex+    ...f (g e)...+then 'f' or 'g' will inline befor the rule can fire.  Solution: add an+INLINE [n] or NOINLINE [n] pragma to 'f' and 'g'.++Note that this applies to all the free variables on the LHS, both the+main function and things in its arguments.++We also check if there are Ids on the LHS that have competing RULES.+In the above example, suppose we had+  {-# RULES "rule-for-g" forally. g [y] = ... #-}+Then "rule-for-f" and "rule-for-g" would compete.  Better to add phase+control, so "rule-for-f" has a chance to fire before "rule-for-g" becomes+active; or perhpas after "rule-for-g" has become inactive. This is checked+by 'competesWith'++Class methods have a built-in RULE to select the method from the dictionary,+so you can't change the phase on this.  That makes id very dubious to+match on class methods in RULE lhs's.   See #10595.   I'm not happy+about this. For example in Control.Arrow we have++{-# RULES "compose/arr"   forall f g .+                          (arr f) . (arr g) = arr (f . g) #-}++and similar, which will elicit exactly these warnings, and risk never+firing.  But it's not clear what to do instead.  We could make the+class method rules inactive in phase 2, but that would delay when+subsequent transformations could fire.+-}
+ compiler/deSugar/DsArrows.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 #-}++module DsArrows ( dsProcExpr ) where++#include "HsVersions.h"++import GhcPrelude++import Match+import DsUtils+import DsMonad++import HsSyn    hiding (collectPatBinders, collectPatsBinders,+                        collectLStmtsBinders, collectLStmtBinders,+                        collectStmtBinders )+import TcHsSyn+import qualified 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 Bag+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 HsExpr+mkCmdEnv tc_meths+  = do { (meth_binds, prs) <- mapAndUnzipM mk_bind tc_meths++       -- NB: Some of these lookups might fail, but that's OK if the+       -- symbol is never used. That's why we use Maybe first and then+       -- panic. An eager panic caused trouble in typecheck/should_compile/tc192+       ; let the_arr_id     = assocMaybe prs arrAName+             the_compose_id = assocMaybe prs composeAName+             the_first_id   = assocMaybe prs firstAName+             the_app_id     = assocMaybe prs appAName+             the_choice_id  = assocMaybe prs choiceAName+             the_loop_id    = assocMaybe prs loopAName++           -- used as an argument in, e.g., do_premap+       ; check_lev_poly 3 the_arr_id++           -- used as an argument in, e.g., dsCmdStmt/BodyStmt+       ; check_lev_poly 5 the_compose_id++           -- used as an argument in, e.g., dsCmdStmt/BodyStmt+       ; check_lev_poly 4 the_first_id++           -- the result of the_app_id is used as an argument in, e.g.,+           -- dsCmd/HsCmdArrApp/HsHigherOrderApp+       ; check_lev_poly 2 the_app_id++           -- used as an argument in, e.g., HsCmdIf+       ; check_lev_poly 5 the_choice_id++           -- used as an argument in, e.g., RecStmt+       ; check_lev_poly 4 the_loop_id++       ; return (meth_binds, DsCmdEnv {+               arr_id     = Var (unmaybe the_arr_id arrAName),+               compose_id = Var (unmaybe the_compose_id composeAName),+               first_id   = Var (unmaybe the_first_id firstAName),+               app_id     = Var (unmaybe the_app_id appAName),+               choice_id  = Var (unmaybe the_choice_id choiceAName),+               loop_id    = Var (unmaybe the_loop_id loopAName)+             }) }+  where+    mk_bind (std_name, expr)+      = do { rhs <- dsExpr expr+           ; id <- newSysLocalDs (exprType rhs)+           -- no check needed; these are functions+           ; return (NonRec id rhs, (std_name, id)) }++    unmaybe Nothing name = pprPanic "mkCmdEnv" (text "Not found:" <+> ppr name)+    unmaybe (Just id) _  = id++      -- returns the result type of a pi-type (that is, a forall or a function)+      -- Note that this result type may be ill-scoped.+    res_type :: Type -> Type+    res_type ty = res_ty+      where+        (_, res_ty) = splitPiTy ty++    check_lev_poly :: Int -- arity+                   -> Maybe Id -> DsM ()+    check_lev_poly _     Nothing = return ()+    check_lev_poly arity (Just id)+      = dsNoLevPoly (nTimes arity res_type (idType id))+          (text "In the result of the function" <+> quotes (ppr id))+++-- arr :: forall b c. (b -> c) -> a b c+do_arr :: DsCmdEnv -> Type -> Type -> CoreExpr -> CoreExpr+do_arr ids b_ty c_ty f = mkApps (arr_id ids) [Type b_ty, Type c_ty, f]++-- (>>>) :: forall b c d. a b c -> a c d -> a b d+do_compose :: DsCmdEnv -> Type -> Type -> Type ->+                CoreExpr -> CoreExpr -> CoreExpr+do_compose ids b_ty c_ty d_ty f g+  = mkApps (compose_id ids) [Type b_ty, Type c_ty, Type d_ty, f, g]++-- first :: forall b c d. a b c -> a (b,d) (c,d)+do_first :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr+do_first ids b_ty c_ty d_ty f+  = mkApps (first_id ids) [Type b_ty, Type c_ty, Type d_ty, f]++-- app :: forall b c. a (a b c, b) c+do_app :: DsCmdEnv -> Type -> Type -> CoreExpr+do_app ids b_ty c_ty = mkApps (app_id ids) [Type b_ty, Type c_ty]++-- (|||) :: forall b d c. a b d -> a c d -> a (Either b c) d+-- note the swapping of d and c+do_choice :: DsCmdEnv -> Type -> Type -> Type ->+                CoreExpr -> CoreExpr -> CoreExpr+do_choice ids b_ty c_ty d_ty f g+  = mkApps (choice_id ids) [Type b_ty, Type d_ty, Type c_ty, f, g]++-- loop :: forall b d c. a (b,d) (c,d) -> a b c+-- note the swapping of d and c+do_loop :: DsCmdEnv -> Type -> Type -> Type -> CoreExpr -> CoreExpr+do_loop ids b_ty c_ty d_ty f+  = mkApps (loop_id ids) [Type b_ty, Type d_ty, Type c_ty, f]++-- premap :: forall b c d. (b -> c) -> a c d -> a b d+-- premap f g = arr f >>> g+do_premap :: DsCmdEnv -> Type -> Type -> Type ->+                CoreExpr -> CoreExpr -> CoreExpr+do_premap ids b_ty c_ty d_ty f g+   = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) g++mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr+mkFailExpr ctxt ty+  = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt)++-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a+mkFstExpr :: Type -> Type -> DsM CoreExpr+mkFstExpr a_ty b_ty = do+    a_var <- newSysLocalDs a_ty+    b_var <- newSysLocalDs b_ty+    pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)+    return (Lam pair_var+               (coreCasePair pair_var a_var b_var (Var a_var)))++-- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> b+mkSndExpr :: Type -> Type -> DsM CoreExpr+mkSndExpr a_ty b_ty = do+    a_var <- newSysLocalDs a_ty+    b_var <- newSysLocalDs b_ty+    pair_var <- newSysLocalDs (mkCorePairTy a_ty b_ty)+    return (Lam pair_var+               (coreCasePair pair_var a_var b_var (Var b_var)))++{-+Build case analysis of a tuple.  This cannot be done in the DsM monad,+because the list of variables is typically not yet defined.+-}++-- coreCaseTuple [u1..] v [x1..xn] body+--      = case v of v { (x1, .., xn) -> body }+-- But the matching may be nested if the tuple is very big++coreCaseTuple :: UniqSupply -> Id -> [Id] -> CoreExpr -> CoreExpr+coreCaseTuple uniqs scrut_var vars body+  = mkTupleCase uniqs vars body scrut_var (Var scrut_var)++coreCasePair :: Id -> Id -> Id -> CoreExpr -> CoreExpr+coreCasePair scrut_var var1 var2 body+  = Case (Var scrut_var) scrut_var (exprType body)+         [(DataAlt (tupleDataCon Boxed 2), [var1, var2], body)]++mkCorePairTy :: Type -> Type -> Type+mkCorePairTy t1 t2 = mkBoxedTupleTy [t1, t2]++mkCorePairExpr :: CoreExpr -> CoreExpr -> CoreExpr+mkCorePairExpr e1 e2 = mkCoreTup [e1, e2]++mkCoreUnitExpr :: CoreExpr+mkCoreUnitExpr = mkCoreTup []++{-+The input is divided into a local environment, which is a flat tuple+(unless it's too big), and a stack, which is a right-nested pair.+In general, the input has the form++        ((x1,...,xn), (s1,...(sk,())...))++where xi are the environment values, and si the ones on the stack,+with s1 being the "top", the first one to be matched with a lambda.+-}++envStackType :: [Id] -> Type -> Type+envStackType ids stack_ty = mkCorePairTy (mkBigCoreVarTupTy ids) stack_ty++-- splitTypeAt n (t1,... (tn,t)...) = ([t1, ..., tn], t)+splitTypeAt :: Int -> Type -> ([Type], Type)+splitTypeAt n ty+  | n == 0 = ([], ty)+  | otherwise = case tcTyConAppArgs ty of+      [t, ty'] -> let (ts, ty_r) = splitTypeAt (n-1) ty' in (t:ts, ty_r)+      _ -> pprPanic "splitTypeAt" (ppr ty)++----------------------------------------------+--              buildEnvStack+--+--      ((x1,...,xn),stk)++buildEnvStack :: [Id] -> Id -> CoreExpr+buildEnvStack env_ids stack_id+  = mkCorePairExpr (mkBigCoreVarTup env_ids) (Var stack_id)++----------------------------------------------+--              matchEnvStack+--+--      \ ((x1,...,xn),stk) -> body+--      =>+--      \ pair ->+--      case pair of (tup,stk) ->+--      case tup of (x1,...,xn) ->+--      body++matchEnvStack   :: [Id]         -- x1..xn+                -> Id           -- stk+                -> CoreExpr     -- e+                -> DsM CoreExpr+matchEnvStack env_ids stack_id body = do+    uniqs <- newUniqueSupply+    tup_var <- newSysLocalDs (mkBigCoreVarTupTy env_ids)+    let match_env = coreCaseTuple uniqs tup_var env_ids body+    pair_id <- newSysLocalDs (mkCorePairTy (idType tup_var) (idType stack_id))+    return (Lam pair_id (coreCasePair pair_id tup_var stack_id match_env))++----------------------------------------------+--              matchEnv+--+--      \ (x1,...,xn) -> body+--      =>+--      \ tup ->+--      case tup of (x1,...,xn) ->+--      body++matchEnv :: [Id]        -- x1..xn+         -> CoreExpr    -- e+         -> DsM CoreExpr+matchEnv env_ids body = do+    uniqs <- newUniqueSupply+    tup_id <- newSysLocalDs (mkBigCoreVarTupTy env_ids)+    return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body))++----------------------------------------------+--              matchVarStack+--+--      case (x1, ...(xn, s)...) -> e+--      =>+--      case z0 of (x1,z1) ->+--      case zn-1 of (xn,s) ->+--      e+matchVarStack :: [Id] -> Id -> CoreExpr -> DsM (Id, CoreExpr)+matchVarStack [] stack_id body = return (stack_id, body)+matchVarStack (param_id:param_ids) stack_id body = do+    (tail_id, tail_code) <- matchVarStack param_ids stack_id body+    pair_id <- newSysLocalDs (mkCorePairTy (idType param_id) (idType tail_id))+    return (pair_id, coreCasePair pair_id param_id tail_id tail_code)++mkHsEnvStackExpr :: [Id] -> Id -> LHsExpr GhcTc+mkHsEnvStackExpr env_ids stack_id+  = mkLHsTupleExpr [mkLHsVarTuple env_ids, nlHsVar stack_id]++-- Translation of arrow abstraction++-- D; xs |-a c : () --> t'      ---> c'+-- --------------------------+-- D |- proc p -> c :: a t t'   ---> premap (\ p -> ((xs),())) c'+--+--              where (xs) is the tuple of variables bound by p++dsProcExpr+        :: LPat GhcTc+        -> LHsCmdTop GhcTc+        -> DsM CoreExpr+dsProcExpr pat (dL->L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do+    (meth_binds, meth_ids) <- mkCmdEnv ids+    let locals = mkVarSet (collectPatBinders pat)+    (core_cmd, _free_vars, env_ids)+       <- dsfixCmd meth_ids locals unitTy cmd_ty cmd+    let env_ty = mkBigCoreVarTupTy env_ids+    let env_stk_ty = mkCorePairTy env_ty unitTy+    let env_stk_expr = mkCorePairExpr (mkBigCoreVarTup env_ids) mkCoreUnitExpr+    fail_expr <- mkFailExpr ProcExpr env_stk_ty+    var <- selectSimpleMatchVarL pat+    match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr+    let pat_ty = hsLPatType pat+    let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty+                    (Lam var match_code)+                    core_cmd+    return (mkLets meth_binds proc_code)+dsProcExpr _ _ = panic "dsProcExpr"++{-+Translation of a command judgement of the form++        D; xs |-a c : stk --> t++to an expression e such that++        D |- e :: a (xs, stk) t+-}++dsLCmd :: DsCmdEnv -> IdSet -> Type -> Type -> LHsCmd GhcTc -> [Id]+       -> DsM (CoreExpr, DIdSet)+dsLCmd ids local_vars stk_ty res_ty cmd env_ids+  = dsCmd ids local_vars stk_ty res_ty (unLoc cmd) env_ids++dsCmd   :: DsCmdEnv             -- arrow combinators+        -> IdSet                -- set of local vars available to this command+        -> Type                 -- type of the stack (right-nested tuple)+        -> Type                 -- return type of the command+        -> HsCmd GhcTc           -- command to desugar+        -> [Id]           -- list of vars in the input to this command+                                -- This is typically fed back,+                                -- so don't pull on it too early+        -> DsM (CoreExpr,       -- desugared expression+                DIdSet)         -- subset of local vars that occur free++-- D |- fun :: a t1 t2+-- D, xs |- arg :: t1+-- -----------------------------+-- D; xs |-a fun -< arg : stk --> t2+--+--              ---> premap (\ ((xs), _stk) -> arg) fun++dsCmd ids local_vars stack_ty res_ty+        (HsCmdArrApp arrow_ty arrow arg HsFirstOrderApp _)+        env_ids = do+    let+        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty+        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty+    core_arrow <- dsLExprNoLP arrow+    core_arg   <- dsLExpr arg+    stack_id   <- newSysLocalDs stack_ty+    core_make_arg <- matchEnvStack env_ids stack_id core_arg+    return (do_premap ids+              (envStackType env_ids stack_ty)+              arg_ty+              res_ty+              core_make_arg+              core_arrow,+            exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars)++-- D, xs |- fun :: a t1 t2+-- D, xs |- arg :: t1+-- ------------------------------+-- D; xs |-a fun -<< arg : stk --> t2+--+--              ---> premap (\ ((xs), _stk) -> (fun, arg)) app++dsCmd ids local_vars stack_ty res_ty+        (HsCmdArrApp arrow_ty arrow arg HsHigherOrderApp _)+        env_ids = do+    let+        (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty+        (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty++    core_arrow <- dsLExpr arrow+    core_arg   <- dsLExpr arg+    stack_id   <- newSysLocalDs stack_ty+    core_make_pair <- matchEnvStack env_ids stack_id+          (mkCorePairExpr core_arrow core_arg)++    return (do_premap ids+              (envStackType env_ids stack_ty)+              (mkCorePairTy arrow_ty arg_ty)+              res_ty+              core_make_pair+              (do_app ids arg_ty res_ty),+            (exprsFreeIdsDSet [core_arrow, core_arg])+              `uniqDSetIntersectUniqSet` local_vars)++-- D; ys |-a cmd : (t,stk) --> t'+-- D, xs |-  exp :: t+-- ------------------------+-- D; xs |-a cmd exp : stk --> t'+--+--              ---> premap (\ ((xs),stk) -> ((ys),(e,stk))) cmd++dsCmd ids local_vars stack_ty res_ty (HsCmdApp _ cmd arg) env_ids = do+    core_arg <- dsLExpr arg+    let+        arg_ty = exprType core_arg+        stack_ty' = mkCorePairTy arg_ty stack_ty+    (core_cmd, free_vars, env_ids')+             <- dsfixCmd ids local_vars stack_ty' res_ty cmd+    stack_id <- newSysLocalDs stack_ty+    arg_id <- newSysLocalDsNoLP arg_ty+    -- push the argument expression onto the stack+    let+        stack' = mkCorePairExpr (Var arg_id) (Var stack_id)+        core_body = bindNonRec arg_id core_arg+                        (mkCorePairExpr (mkBigCoreVarTup env_ids') stack')++    -- match the environment and stack against the input+    core_map <- matchEnvStack env_ids stack_id core_body+    return (do_premap ids+                      (envStackType env_ids stack_ty)+                      (envStackType env_ids' stack_ty')+                      res_ty+                      core_map+                      core_cmd,+            free_vars `unionDVarSet`+              (exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars))++-- D; ys |-a cmd : stk t'+-- -----------------------------------------------+-- D; xs |-a \ p1 ... pk -> cmd : (t1,...(tk,stk)...) t'+--+--              ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd++dsCmd ids local_vars stack_ty res_ty+        (HsCmdLam _ (MG { mg_alts+          = (dL->L _ [dL->L _ (Match { m_pats  = pats+                       , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] body)] _ })]) }))+        env_ids = do+    let pat_vars = mkVarSet (collectPatsBinders pats)+    let+        local_vars' = pat_vars `unionVarSet` local_vars+        (pat_tys, stack_ty') = splitTypeAt (length pats) stack_ty+    (core_body, free_vars, env_ids')+       <- dsfixCmd ids local_vars' stack_ty' res_ty body+    param_ids <- mapM newSysLocalDsNoLP pat_tys+    stack_id' <- newSysLocalDs stack_ty'++    -- the expression is built from the inside out, so the actions+    -- are presented in reverse order++    let+        -- build a new environment, plus what's left of the stack+        core_expr = buildEnvStack env_ids' stack_id'+        in_ty = envStackType env_ids stack_ty+        in_ty' = envStackType env_ids' stack_ty'++    fail_expr <- mkFailExpr LambdaExpr in_ty'+    -- match the patterns against the parameters+    match_code <- matchSimplys (map Var param_ids) LambdaExpr pats core_expr+                    fail_expr+    -- match the parameters against the top of the old stack+    (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code+    -- match the old environment and stack against the input+    select_code <- matchEnvStack env_ids stack_id param_code+    return (do_premap ids in_ty in_ty' res_ty select_code core_body,+            free_vars `uniqDSetMinusUniqSet` pat_vars)++dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids+  = dsLCmd ids local_vars stack_ty res_ty cmd env_ids++-- D, xs |- e :: Bool+-- D; xs1 |-a c1 : stk --> t+-- D; xs2 |-a c2 : stk --> t+-- ----------------------------------------+-- D; xs |-a if e then c1 else c2 : stk --> t+--+--              ---> premap (\ ((xs),stk) ->+--                       if e then Left ((xs1),stk) else Right ((xs2),stk))+--                     (c1 ||| c2)++dsCmd ids local_vars stack_ty res_ty (HsCmdIf _ mb_fun cond then_cmd else_cmd)+        env_ids = do+    core_cond <- dsLExpr cond+    (core_then, fvs_then, then_ids)+       <- dsfixCmd ids local_vars stack_ty res_ty then_cmd+    (core_else, fvs_else, else_ids)+       <- dsfixCmd ids local_vars stack_ty res_ty else_cmd+    stack_id   <- newSysLocalDs stack_ty+    either_con <- dsLookupTyCon eitherTyConName+    left_con   <- dsLookupDataCon leftDataConName+    right_con  <- dsLookupDataCon rightDataConName++    let mk_left_expr ty1 ty2 e = mkCoreConApps left_con   [Type ty1,Type ty2, e]+        mk_right_expr ty1 ty2 e = mkCoreConApps right_con [Type ty1,Type ty2, e]++        in_ty = envStackType env_ids stack_ty+        then_ty = envStackType then_ids stack_ty+        else_ty = envStackType else_ids stack_ty+        sum_ty = mkTyConApp either_con [then_ty, else_ty]+        fvs_cond = exprFreeIdsDSet core_cond+                   `uniqDSetIntersectUniqSet` local_vars++        core_left  = mk_left_expr  then_ty else_ty+                       (buildEnvStack then_ids stack_id)+        core_right = mk_right_expr then_ty else_ty+                       (buildEnvStack else_ids stack_id)++    core_if <- case mb_fun of+       Just fun -> do { fun_apps <- dsSyntaxExpr fun+                                      [core_cond, core_left, core_right]+                      ; matchEnvStack env_ids stack_id fun_apps }+       Nothing  -> matchEnvStack env_ids stack_id $+                   mkIfThenElse core_cond core_left core_right++    return (do_premap ids in_ty sum_ty res_ty+                core_if+                (do_choice ids then_ty else_ty res_ty core_then core_else),+        fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else)++{-+Case commands are treated in much the same way as if commands+(see above) except that there are more alternatives.  For example++        case e of { p1 -> c1; p2 -> c2; p3 -> c3 }++is translated to++        premap (\ ((xs)*ts) -> case e of+                p1 -> (Left (Left (xs1)*ts))+                p2 -> Left ((Right (xs2)*ts))+                p3 -> Right ((xs3)*ts))+        ((c1 ||| c2) ||| c3)++The idea is to extract the commands from the case, build a balanced tree+of choices, and replace the commands with expressions that build tagged+tuples, obtaining a case expression that can be desugared normally.+To build all this, we use triples describing segments of the list of+case bodies, containing the following fields:+ * a list of expressions of the form (Left|Right)* ((xs)*ts), to be put+   into the case replacing the commands+ * a sum type that is the common type of these expressions, and also the+   input type of the arrow+ * a CoreExpr for an arrow built by combining the translated command+   bodies with |||.+-}++dsCmd ids local_vars stack_ty res_ty+      (HsCmdCase _ exp (MG { mg_alts = (dL->L l matches)+                           , mg_ext = MatchGroupTc arg_tys _+                           , mg_origin = origin }))+      env_ids = do+    stack_id <- newSysLocalDs stack_ty++    -- Extract and desugar the leaf commands in the case, building tuple+    -- expressions that will (after tagging) replace these leaves++    let+        leaves = concatMap leavesMatch matches+        make_branch (leaf, bound_vars) = do+            (core_leaf, _fvs, leaf_ids)+               <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty+                    res_ty leaf+            return ([mkHsEnvStackExpr leaf_ids stack_id],+                    envStackType leaf_ids stack_ty,+                    core_leaf)++    branches <- mapM make_branch leaves+    either_con <- dsLookupTyCon eitherTyConName+    left_con <- dsLookupDataCon leftDataConName+    right_con <- dsLookupDataCon rightDataConName+    let+        left_id  = HsConLikeOut noExt (RealDataCon left_con)+        right_id = HsConLikeOut noExt (RealDataCon right_con)+        left_expr  ty1 ty2 e = noLoc $ HsApp noExt+                           (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e+        right_expr ty1 ty2 e = noLoc $ HsApp noExt+                           (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 noExt exp+                         (MG { mg_alts = cL l matches'+                             , mg_ext = MatchGroupTc arg_tys sum_ty+                             , mg_origin = origin }))+        -- Note that we replace the HsCase result type by sum_ty,+        -- which is the type of matches'++    core_matches <- matchEnvStack env_ids stack_id core_body+    return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,+            exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars)++-- D; ys |-a cmd : stk --> t+-- ----------------------------------+-- D; xs |-a let binds in cmd : stk --> t+--+--              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c++dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@(dL->L _ binds) body)+                                                                    env_ids = do+    let+        defined_vars = mkVarSet (collectLocalBinders binds)+        local_vars' = defined_vars `unionVarSet` local_vars++    (core_body, _free_vars, env_ids')+       <- dsfixCmd ids local_vars' stack_ty res_ty body+    stack_id <- newSysLocalDs stack_ty+    -- build a new environment, plus the stack, using the let bindings+    core_binds <- dsLocalBinds lbinds (buildEnvStack env_ids' stack_id)+    -- match the old environment and stack against the input+    core_map <- matchEnvStack env_ids stack_id core_binds+    return (do_premap ids+                        (envStackType env_ids stack_ty)+                        (envStackType env_ids' stack_ty)+                        res_ty+                        core_map+                        core_body,+        exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars)++-- D; xs |-a ss : t+-- ----------------------------------+-- D; xs |-a do { ss } : () --> t+--+--              ---> premap (\ (env,stk) -> env) c++dsCmd ids local_vars stack_ty res_ty do_block@(HsCmdDo stmts_ty+                                               (dL->L loc stmts))+                                                                   env_ids = do+    putSrcSpanDs loc $+      dsNoLevPoly stmts_ty+        (text "In the do-command:" <+> ppr do_block)+    (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids+    let env_ty = mkBigCoreVarTupTy env_ids+    core_fst <- mkFstExpr env_ty stack_ty+    return (do_premap ids+                (mkCorePairTy env_ty stack_ty)+                env_ty+                res_ty+                core_fst+                core_stmts,+        env_ids')++-- D |- e :: forall e. a1 (e,stk1) t1 -> ... an (e,stkn) tn -> a (e,stk) t+-- D; xs |-a ci :: stki --> ti+-- -----------------------------------+-- D; xs |-a (|e c1 ... cn|) :: stk --> t       ---> e [t_xs] c1 ... cn++dsCmd _ local_vars _stack_ty _res_ty (HsCmdArrForm _ op _ _ args) env_ids = do+    let env_ty = mkBigCoreVarTupTy env_ids+    core_op <- dsLExpr op+    (core_args, fv_sets) <- mapAndUnzipM (dsTrimCmdArg local_vars env_ids) args+    return (mkApps (App core_op (Type env_ty)) core_args,+            unionDVarSets fv_sets)++dsCmd ids local_vars stack_ty res_ty (HsCmdWrap _ wrap cmd) env_ids = do+    (core_cmd, env_ids') <- dsCmd ids local_vars stack_ty res_ty cmd env_ids+    core_wrap <- dsHsWrapper wrap+    return (core_wrap core_cmd, env_ids')++dsCmd _ _ _ _ _ c = pprPanic "dsCmd" (ppr c)++-- D; ys |-a c : stk --> t      (ys <= xs)+-- ---------------------+-- D; xs |-a c : stk --> t      ---> premap (\ ((xs),stk) -> ((ys),stk)) c++dsTrimCmdArg+        :: IdSet                -- set of local vars available to this command+        -> [Id]           -- list of vars in the input to this command+        -> LHsCmdTop GhcTc       -- command argument to desugar+        -> DsM (CoreExpr,       -- desugared expression+                DIdSet)         -- subset of local vars that occur free+dsTrimCmdArg local_vars env_ids+                       (dL->L _ (HsCmdTop+                                 (CmdTopTc stack_ty cmd_ty ids) cmd )) = do+    (meth_binds, meth_ids) <- mkCmdEnv ids+    (core_cmd, free_vars, env_ids')+       <- dsfixCmd meth_ids local_vars stack_ty cmd_ty cmd+    stack_id <- newSysLocalDs stack_ty+    trim_code+      <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)+    let+        in_ty = envStackType env_ids stack_ty+        in_ty' = envStackType env_ids' stack_ty+        arg_code = if env_ids' == env_ids then core_cmd else+                do_premap meth_ids in_ty in_ty' cmd_ty trim_code core_cmd+    return (mkLets meth_binds arg_code, free_vars)+dsTrimCmdArg _ _ _ = panic "dsTrimCmdArg"++-- Given D; xs |-a c : stk --> t, builds c with xs fed back.+-- Typically needs to be prefixed with arr (\(p, stk) -> ((xs),stk))++dsfixCmd+        :: DsCmdEnv             -- arrow combinators+        -> IdSet                -- set of local vars available to this command+        -> Type                 -- type of the stack (right-nested tuple)+        -> Type                 -- return type of the command+        -> LHsCmd GhcTc         -- command to desugar+        -> DsM (CoreExpr,       -- desugared expression+                DIdSet,         -- subset of local vars that occur free+                [Id])           -- the same local vars as a list, fed back+dsfixCmd ids local_vars stk_ty cmd_ty cmd+  = do { putSrcSpanDs (getLoc cmd) $ dsNoLevPoly cmd_ty+           (text "When desugaring the command:" <+> ppr cmd)+       ; trimInput (dsLCmd ids local_vars stk_ty cmd_ty cmd) }++-- Feed back the list of local variables actually used a command,+-- for use as the input tuple of the generated arrow.++trimInput+        :: ([Id] -> DsM (CoreExpr, DIdSet))+        -> DsM (CoreExpr,       -- desugared expression+                DIdSet,         -- subset of local vars that occur free+                [Id])           -- same local vars as a list, fed back to+                                -- the inner function to form the tuple of+                                -- inputs to the arrow.+trimInput build_arrow+  = fixDs (\ ~(_,_,env_ids) -> do+        (core_cmd, free_vars) <- build_arrow env_ids+        return (core_cmd, free_vars, dVarSetElems free_vars))++{-+Translation of command judgements of the form++        D |-a do { ss } : t+-}++dsCmdDo :: DsCmdEnv             -- arrow combinators+        -> IdSet                -- set of local vars available to this statement+        -> Type                 -- return type of the statement+        -> [CmdLStmt GhcTc]     -- statements to desugar+        -> [Id]                 -- list of vars in the input to this statement+                                -- This is typically fed back,+                                -- so don't pull on it too early+        -> DsM (CoreExpr,       -- desugared expression+                DIdSet)         -- subset of local vars that occur free++dsCmdDo _ _ _ [] _ = panic "dsCmdDo"++-- D; xs |-a c : () --> t+-- --------------------------+-- D; xs |-a do { c } : t+--+--              ---> premap (\ (xs) -> ((xs), ())) c++dsCmdDo ids local_vars res_ty [dL->L loc (LastStmt _ body _ _)] env_ids = do+    putSrcSpanDs loc $ dsNoLevPoly res_ty+                         (text "In the command:" <+> ppr body)+    (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids+    let env_ty = mkBigCoreVarTupTy env_ids+    env_var <- newSysLocalDs env_ty+    let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)+    return (do_premap ids+                        env_ty+                        (mkCorePairTy env_ty unitTy)+                        res_ty+                        core_map+                        core_body,+        env_ids')++dsCmdDo ids local_vars res_ty (stmt:stmts) env_ids = do+    let bound_vars  = mkVarSet (collectLStmtBinders stmt)+    let local_vars' = bound_vars `unionVarSet` local_vars+    (core_stmts, _, env_ids') <- trimInput (dsCmdDo ids local_vars' res_ty stmts)+    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids+    return (do_compose ids+                (mkBigCoreVarTupTy env_ids)+                (mkBigCoreVarTupTy env_ids')+                res_ty+                core_stmt+                core_stmts,+              fv_stmt)++{-+A statement maps one local environment to another, and is represented+as an arrow from one tuple type to another.  A statement sequence is+translated to a composition of such arrows.+-}++dsCmdLStmt :: DsCmdEnv -> IdSet -> [Id] -> CmdLStmt GhcTc -> [Id]+           -> DsM (CoreExpr, DIdSet)+dsCmdLStmt ids local_vars out_ids cmd env_ids+  = dsCmdStmt ids local_vars out_ids (unLoc cmd) env_ids++dsCmdStmt+        :: DsCmdEnv             -- arrow combinators+        -> IdSet                -- set of local vars available to this statement+        -> [Id]                 -- list of vars in the output of this statement+        -> CmdStmt GhcTc        -- statement to desugar+        -> [Id]                 -- list of vars in the input to this statement+                                -- This is typically fed back,+                                -- so don't pull on it too early+        -> DsM (CoreExpr,       -- desugared expression+                DIdSet)         -- subset of local vars that occur free++-- D; xs1 |-a c : () --> t+-- D; xs' |-a do { ss } : t'+-- ------------------------------+-- D; xs  |-a do { c; ss } : t'+--+--              ---> premap (\ ((xs)) -> (((xs1),()),(xs')))+--                      (first c >>> arr snd) >>> ss++dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do+    (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy c_ty cmd+    core_mux <- matchEnv env_ids+        (mkCorePairExpr+            (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)+            (mkBigCoreVarTup out_ids))+    let+        in_ty = mkBigCoreVarTupTy env_ids+        in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy+        out_ty = mkBigCoreVarTupTy out_ids+        before_c_ty = mkCorePairTy in_ty1 out_ty+        after_c_ty = mkCorePairTy c_ty out_ty+    dsNoLevPoly c_ty empty -- I (Richard E, Dec '16) have no idea what to say here+    snd_fn <- mkSndExpr c_ty out_ty+    return (do_premap ids in_ty before_c_ty out_ty core_mux $+                do_compose ids before_c_ty after_c_ty out_ty+                        (do_first ids in_ty1 c_ty out_ty core_cmd) $+                do_arr ids after_c_ty out_ty snd_fn,+              extendDVarSetList fv_cmd out_ids)++-- D; xs1 |-a c : () --> t+-- D; xs' |-a do { ss } : t'            xs2 = xs' - defs(p)+-- -----------------------------------+-- D; xs  |-a do { p <- c; ss } : t'+--+--              ---> premap (\ (xs) -> (((xs1),()),(xs2)))+--                      (first c >>> arr (\ (p, (xs2)) -> (xs'))) >>> ss+--+-- It would be simpler and more consistent to do this using second,+-- but that's likely to be defined in terms of first.++dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do+    let pat_ty = hsLPatType pat+    (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd+    let pat_vars = mkVarSet (collectPatBinders pat)+    let+        env_ids2 = filterOut (`elemVarSet` pat_vars) out_ids+        env_ty2 = mkBigCoreVarTupTy env_ids2++    -- multiplexing function+    --          \ (xs) -> (((xs1),()),(xs2))++    core_mux <- matchEnv env_ids+        (mkCorePairExpr+            (mkCorePairExpr (mkBigCoreVarTup env_ids1) mkCoreUnitExpr)+            (mkBigCoreVarTup env_ids2))++    -- projection function+    --          \ (p, (xs2)) -> (zs)++    env_id <- newSysLocalDs env_ty2+    uniqs <- newUniqueSupply+    let+       after_c_ty = mkCorePairTy pat_ty env_ty2+       out_ty = mkBigCoreVarTupTy out_ids+       body_expr = coreCaseTuple uniqs env_id env_ids2 (mkBigCoreVarTup out_ids)++    fail_expr <- mkFailExpr (StmtCtxt DoExpr) out_ty+    pat_id    <- selectSimpleMatchVarL pat+    match_code+      <- matchSimply (Var pat_id) (StmtCtxt DoExpr) pat body_expr fail_expr+    pair_id   <- newSysLocalDs after_c_ty+    let+        proj_expr = Lam pair_id (coreCasePair pair_id pat_id env_id match_code)++    -- put it all together+    let+        in_ty = mkBigCoreVarTupTy env_ids+        in_ty1 = mkCorePairTy (mkBigCoreVarTupTy env_ids1) unitTy+        in_ty2 = mkBigCoreVarTupTy env_ids2+        before_c_ty = mkCorePairTy in_ty1 in_ty2+    return (do_premap ids in_ty before_c_ty out_ty core_mux $+                do_compose ids before_c_ty after_c_ty out_ty+                        (do_first ids in_ty1 pat_ty in_ty2 core_cmd) $+                do_arr ids after_c_ty out_ty proj_expr,+              fv_cmd `unionDVarSet` (mkDVarSet out_ids+                                     `uniqDSetMinusUniqSet` pat_vars))++-- D; xs' |-a do { ss } : t+-- --------------------------------------+-- D; xs  |-a do { let binds; ss } : t+--+--              ---> arr (\ (xs) -> let binds in (xs')) >>> ss++dsCmdStmt ids local_vars out_ids (LetStmt _ binds) env_ids = do+    -- build a new environment using the let bindings+    core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)+    -- match the old environment against the input+    core_map <- matchEnv env_ids core_binds+    return (do_arr ids+                        (mkBigCoreVarTupTy env_ids)+                        (mkBigCoreVarTupTy out_ids)+                        core_map,+            exprFreeIdsDSet core_binds `uniqDSetIntersectUniqSet` local_vars)++-- D; ys  |-a do { ss; returnA -< ((xs1), (ys2)) } : ...+-- D; xs' |-a do { ss' } : t+-- ------------------------------------+-- D; xs  |-a do { rec ss; ss' } : t+--+--                      xs1 = xs' /\ defs(ss)+--                      xs2 = xs' - defs(ss)+--                      ys1 = ys - defs(ss)+--                      ys2 = ys /\ defs(ss)+--+--              ---> arr (\(xs) -> ((ys1),(xs2))) >>>+--                      first (loop (arr (\((ys1),~(ys2)) -> (ys)) >>> ss)) >>>+--                      arr (\((xs1),(xs2)) -> (xs')) >>> ss'++dsCmdStmt ids local_vars out_ids+        (RecStmt { recS_stmts = stmts+                 , recS_later_ids = later_ids, recS_rec_ids = rec_ids+                 , recS_ext = RecStmtTc { recS_later_rets = later_rets+                                        , recS_rec_rets = rec_rets } })+        env_ids = do+    let+        later_ids_set = mkVarSet later_ids+        env2_ids = filterOut (`elemVarSet` later_ids_set) out_ids+        env2_id_set = mkDVarSet env2_ids+        env2_ty = mkBigCoreVarTupTy env2_ids++    -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids)++    uniqs <- newUniqueSupply+    env2_id <- newSysLocalDs env2_ty+    let+        later_ty = mkBigCoreVarTupTy later_ids+        post_pair_ty = mkCorePairTy later_ty env2_ty+        post_loop_body = coreCaseTuple uniqs env2_id env2_ids (mkBigCoreVarTup out_ids)++    post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body++    --- loop (...)++    (core_loop, env1_id_set, env1_ids)+               <- dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets++    -- pre_loop_fn = \(env_ids) -> ((env1_ids),(env2_ids))++    let+        env1_ty = mkBigCoreVarTupTy env1_ids+        pre_pair_ty = mkCorePairTy env1_ty env2_ty+        pre_loop_body = mkCorePairExpr (mkBigCoreVarTup env1_ids)+                                        (mkBigCoreVarTup env2_ids)++    pre_loop_fn <- matchEnv env_ids pre_loop_body++    -- arr pre_loop_fn >>> first (loop (...)) >>> arr post_loop_fn++    let+        env_ty = mkBigCoreVarTupTy env_ids+        out_ty = mkBigCoreVarTupTy out_ids+        core_body = do_premap ids env_ty pre_pair_ty out_ty+                pre_loop_fn+                (do_compose ids pre_pair_ty post_pair_ty out_ty+                        (do_first ids env1_ty later_ty env2_ty+                                core_loop)+                        (do_arr ids post_pair_ty out_ty+                                post_loop_fn))++    return (core_body, env1_id_set `unionDVarSet` env2_id_set)++dsCmdStmt _ _ _ _ s = pprPanic "dsCmdStmt" (ppr s)++--      loop (premap (\ ((env1_ids), ~(rec_ids)) -> (env_ids))+--            (ss >>> arr (\ (out_ids) -> ((later_rets),(rec_rets))))) >>>++dsRecCmd+        :: DsCmdEnv             -- arrow combinators+        -> IdSet                -- set of local vars available to this statement+        -> [CmdLStmt GhcTc]     -- list of statements inside the RecCmd+        -> [Id]                 -- list of vars defined here and used later+        -> [HsExpr GhcTc]       -- expressions corresponding to later_ids+        -> [Id]                 -- list of vars fed back through the loop+        -> [HsExpr GhcTc]       -- expressions corresponding to rec_ids+        -> DsM (CoreExpr,       -- desugared statement+                DIdSet,         -- subset of local vars that occur free+                [Id])           -- same local vars as a list++dsRecCmd ids local_vars stmts later_ids later_rets rec_ids rec_rets = do+    let+        later_id_set = mkVarSet later_ids+        rec_id_set = mkVarSet rec_ids+        local_vars' = rec_id_set `unionVarSet` later_id_set `unionVarSet` local_vars++    -- mk_pair_fn = \ (out_ids) -> ((later_rets),(rec_rets))++    core_later_rets <- mapM dsExpr later_rets+    core_rec_rets <- mapM dsExpr rec_rets+    let+        -- possibly polymorphic version of vars of later_ids and rec_ids+        out_ids = exprsFreeIdsList (core_later_rets ++ core_rec_rets)+        out_ty = mkBigCoreVarTupTy out_ids++        later_tuple = mkBigCoreTup core_later_rets+        later_ty = mkBigCoreVarTupTy later_ids++        rec_tuple = mkBigCoreTup core_rec_rets+        rec_ty = mkBigCoreVarTupTy rec_ids++        out_pair = mkCorePairExpr later_tuple rec_tuple+        out_pair_ty = mkCorePairTy later_ty rec_ty++    mk_pair_fn <- matchEnv out_ids out_pair++    -- ss++    (core_stmts, fv_stmts, env_ids) <- dsfixCmdStmts ids local_vars' out_ids stmts++    -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids)++    rec_id <- newSysLocalDs rec_ty+    let+        env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set+        env1_ids = dVarSetElems env1_id_set+        env1_ty = mkBigCoreVarTupTy env1_ids+        in_pair_ty = mkCorePairTy env1_ty rec_ty+        core_body = mkBigCoreTup (map selectVar env_ids)+          where+            selectVar v+                | v `elemVarSet` rec_id_set+                  = mkTupleSelector rec_ids v rec_id (Var rec_id)+                | otherwise = Var v++    squash_pair_fn <- matchEnvStack env1_ids rec_id core_body++    -- loop (premap squash_pair_fn (ss >>> arr mk_pair_fn))++    let+        env_ty = mkBigCoreVarTupTy env_ids+        core_loop = do_loop ids env1_ty later_ty rec_ty+                (do_premap ids in_pair_ty env_ty out_pair_ty+                        squash_pair_fn+                        (do_compose ids env_ty out_ty out_pair_ty+                                core_stmts+                                (do_arr ids out_ty out_pair_ty mk_pair_fn)))++    return (core_loop, env1_id_set, env1_ids)++{-+A sequence of statements (as in a rec) is desugared to an arrow between+two environments (no stack)+-}++dsfixCmdStmts+        :: DsCmdEnv             -- arrow combinators+        -> IdSet                -- set of local vars available to this statement+        -> [Id]                 -- output vars of these statements+        -> [CmdLStmt GhcTc]     -- statements to desugar+        -> DsM (CoreExpr,       -- desugared expression+                DIdSet,         -- subset of local vars that occur free+                [Id])           -- same local vars as a list++dsfixCmdStmts ids local_vars out_ids stmts+  = trimInput (dsCmdStmts ids local_vars out_ids stmts)+   -- TODO: Add levity polymorphism check for the resulting expression.+   -- But I (Richard E.) don't know enough about arrows to do so.++dsCmdStmts+        :: DsCmdEnv             -- arrow combinators+        -> IdSet                -- set of local vars available to this statement+        -> [Id]                 -- output vars of these statements+        -> [CmdLStmt GhcTc]     -- statements to desugar+        -> [Id]                 -- list of vars in the input to these statements+        -> DsM (CoreExpr,       -- desugared expression+                DIdSet)         -- subset of local vars that occur free++dsCmdStmts ids local_vars out_ids [stmt] env_ids+  = dsCmdLStmt ids local_vars out_ids stmt env_ids++dsCmdStmts ids local_vars out_ids (stmt:stmts) env_ids = do+    let bound_vars  = mkVarSet (collectLStmtBinders stmt)+    let local_vars' = bound_vars `unionVarSet` local_vars+    (core_stmts, _fv_stmts, env_ids') <- dsfixCmdStmts ids local_vars' out_ids stmts+    (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids' stmt env_ids+    return (do_compose ids+                (mkBigCoreVarTupTy env_ids)+                (mkBigCoreVarTupTy env_ids')+                (mkBigCoreVarTupTy out_ids)+                core_stmt+                core_stmts,+              fv_stmt)++dsCmdStmts _ _ _ [] _ = panic "dsCmdStmts []"++-- Match a list of expressions against a list of patterns, left-to-right.++matchSimplys :: [CoreExpr]              -- Scrutinees+             -> HsMatchContext Name     -- Match kind+             -> [LPat GhcTc]            -- Patterns they should match+             -> CoreExpr                -- Return this if they all match+             -> CoreExpr                -- Return this if they don't+             -> DsM CoreExpr+matchSimplys [] _ctxt [] result_expr _fail_expr = return result_expr+matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr = do+    match_code <- matchSimplys exps ctxt pats result_expr fail_expr+    matchSimply exp ctxt pat match_code fail_expr+matchSimplys _ _ _ _ _ = panic "matchSimplys"++-- List of leaf expressions, with set of variables bound in each++leavesMatch :: LMatch GhcTc (Located (body GhcTc))+            -> [(Located (body GhcTc), IdSet)]+leavesMatch (dL->L _ (Match { m_pats = pats+                            , m_grhss = GRHSs _ grhss (dL->L _ binds) }))+  = let+        defined_vars = mkVarSet (collectPatsBinders pats)+                        `unionVarSet`+                       mkVarSet (collectLocalBinders binds)+    in+    [(body,+      mkVarSet (collectLStmtsBinders stmts)+        `unionVarSet` defined_vars)+    | (dL->L _ (GRHS _ stmts body)) <- grhss]+leavesMatch _ = panic "leavesMatch"++-- Replace the leaf commands in a match++replaceLeavesMatch+        :: Type                                 -- new result type+        -> [Located (body' GhcTc)] -- replacement leaf expressions of that type+        -> LMatch GhcTc (Located (body GhcTc))  -- the matches of a case command+        -> ([Located (body' GhcTc)],            -- remaining leaf expressions+            LMatch GhcTc (Located (body' GhcTc))) -- updated match+replaceLeavesMatch _res_ty leaves+                        (dL->L loc+                          match@(Match { m_grhss = GRHSs x grhss binds }))+  = let+        (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss+    in+    (leaves', cL loc (match { m_ext = noExt, m_grhss = GRHSs x grhss' binds }))+replaceLeavesMatch _ _ _ = panic "replaceLeavesMatch"++replaceLeavesGRHS+        :: [Located (body' GhcTc)]  -- replacement leaf expressions of that type+        -> LGRHS GhcTc (Located (body GhcTc))     -- rhss of a case command+        -> ([Located (body' GhcTc)],              -- remaining leaf expressions+            LGRHS GhcTc (Located (body' GhcTc)))  -- updated GRHS+replaceLeavesGRHS (leaf:leaves) (dL->L loc (GRHS x stmts _))+  = (leaves, cL loc (GRHS x stmts leaf))+replaceLeavesGRHS [] _ = panic "replaceLeavesGRHS []"+replaceLeavesGRHS _ _ = panic "replaceLeavesGRHS"++-- Balanced fold of a non-empty list.++foldb :: (a -> a -> a) -> [a] -> a+foldb _ [] = error "foldb of empty list"+foldb _ [x] = x+foldb f xs = foldb f (fold_pairs xs)+  where+    fold_pairs [] = []+    fold_pairs [x] = [x]+    fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs++{-+Note [Dictionary binders in ConPatOut] See also same Note in HsUtils+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The following functions to collect value variables from patterns are+copied from HsUtils, 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 HsUtils for why the other version does not include+these bindings.+-}++collectPatBinders :: LPat GhcTc -> [Id]+collectPatBinders pat = collectl pat []++collectPatsBinders :: [LPat GhcTc] -> [Id]+collectPatsBinders pats = foldr collectl [] pats++---------------------+collectl :: LPat GhcTc -> [Id] -> [Id]+-- See Note [Dictionary binders in ConPatOut]+collectl (dL->L _ pat) bndrs+  = go pat+  where+    go (VarPat _ (dL->L _ var))   = var : bndrs+    go (WildPat _)                = bndrs+    go (LazyPat _ pat)            = collectl pat bndrs+    go (BangPat _ pat)            = collectl pat bndrs+    go (AsPat _ (dL->L _ a) pat)  = a : collectl pat bndrs+    go (ParPat _ pat)             = collectl pat bndrs++    go (ListPat _ pats)           = foldr collectl bndrs pats+    go (TuplePat _ pats _)        = foldr collectl bndrs pats+    go (SumPat _ pat _ _)         = collectl pat bndrs++    go (ConPatIn _ ps)            = foldr collectl bndrs (hsConPatArgs ps)+    go (ConPatOut {pat_args=ps, pat_binds=ds}) =+                                    collectEvBinders ds+                                    ++ foldr collectl bndrs (hsConPatArgs ps)+    go (LitPat _ _)               = bndrs+    go (NPat {})                  = bndrs+    go (NPlusKPat _ (dL->L _ n) _ _ _ _) = n : bndrs++    go (SigPat _ pat _)           = collectl pat bndrs+    go (CoPat _ _ pat _)          = collectl (noLoc pat) bndrs+    go (ViewPat _ _ pat)          = collectl pat bndrs+    go p@(SplicePat {})           = pprPanic "collectl/go" (ppr p)+    go p@(XPat {})                = pprPanic "collectl/go" (ppr p)++collectEvBinders :: TcEvBinds -> [Id]+collectEvBinders (EvBinds bs)   = foldrBag 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 view
@@ -0,0 +1,1324 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Pattern-matching bindings (HsBinds and MonoBinds)++Handles @HsBinds@; those at the top level require different handling,+in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at+lower levels it is preserved with @let@/@letrec@s).+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE FlexibleContexts #-}++module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,+                 dsHsWrapper, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule+  ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-}   DsExpr( dsLExpr )+import {-# SOURCE #-}   Match( matchWrapper )++import DsMonad+import DsGRHSs+import DsUtils+import Check ( checkGuardMatches )++import HsSyn            -- 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 PrelNames+import TyCon+import TcEvidence+import TcType+import Type+import Coercion+import TysWiredIn ( typeNatKind, typeSymbolKind )+import Id+import MkId(proxyHashId)+import Name+import VarSet+import Rules+import VarEnv+import Var( EvVar )+import Outputable+import Module+import SrcLoc+import Maybes+import OrdList+import Bag+import BasicTypes+import DynFlags+import FastString+import Util+import UniqSet( nonDetEltsUniqSet )+import MonadUtils+import qualified GHC.LanguageExtensions as LangExt+import Control.Monad++{-**********************************************************************+*                                                                      *+           Desugaring a MonoBinds+*                                                                      *+**********************************************************************-}++-- | Desugar top level binds, strict binds are treated like normal+-- binds since there is no good time to force before first usage.+dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr))+dsTopLHsBinds binds+     -- see Note [Strict binds checks]+  | not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)+  = do { mapBagM_ (top_level_err "bindings for unlifted types") unlifted_binds+       ; mapBagM_ (top_level_err "strict bindings")             bang_binds+       ; return nilOL }++  | otherwise+  = do { (force_vars, prs) <- dsLHsBinds binds+       ; when debugIsOn $+         do { xstrict <- xoptM LangExt.Strict+            ; MASSERT2( null force_vars || xstrict, ppr binds $$ ppr force_vars ) }+              -- with -XStrict, even top-level vars are listed as force vars.++       ; return (toOL prs) }++  where+    unlifted_binds = filterBag (isUnliftedHsBind . unLoc) binds+    bang_binds     = filterBag (isBangedHsBind   . unLoc) binds++    top_level_err desc (dL->L loc bind)+      = putSrcSpanDs loc $+        errDs (hang (text "Top-level" <+> text desc <+> text "aren't allowed:")+                  2 (ppr bind))+++-- | Desugar all other kind of bindings, Ids of strict binds are returned to+-- later be forced in the binding group body, see Note [Desugar Strict binds]+dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])+dsLHsBinds binds+  = do { ds_bs <- mapBagM dsLHsBind binds+       ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))+                         id ([], []) ds_bs) }++------------------------+dsLHsBind :: LHsBind GhcTc+          -> DsM ([Id], [(Id,CoreExpr)])+dsLHsBind (dL->L loc bind) = do dflags <- getDynFlags+                                putSrcSpanDs loc $ dsHsBind dflags bind++-- | Desugar a single binding (or group of recursive binds).+dsHsBind :: DynFlags+         -> HsBind GhcTc+         -> DsM ([Id], [(Id,CoreExpr)])+         -- ^ The Ids of strict binds, to be forced in the body of the+         -- binding group see Note [Desugar Strict binds] and all+         -- bindings and their desugared right hand sides.++dsHsBind dflags (VarBind { var_id = var+                         , var_rhs = expr+                         , var_inline = inline_regardless })+  = do  { core_expr <- dsLExpr expr+                -- Dictionary bindings are always VarBinds,+                -- so we only need do this here+        ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr+                   | otherwise         = var+        ; let core_bind@(id,_) = makeCorePair dflags var' False 0 core_expr+              force_var = if xopt LangExt.Strict dflags+                          then [id]+                          else []+        ; return (force_var, [core_bind]) }++dsHsBind dflags b@(FunBind { fun_id = (dL->L _ fun)+                           , fun_matches = matches+                           , fun_co_fn = co_fn+                           , fun_tick = tick })+ = do   { (args, body) <- matchWrapper+                           (mkPrefixFunRhs (noLoc $ idName fun))+                           Nothing matches+        ; core_wrap <- dsHsWrapper co_fn+        ; let body' = mkOptTickBox tick body+              rhs   = core_wrap (mkLams args body')+              core_binds@(id,_) = makeCorePair dflags fun False 0 rhs+              force_var+                  -- Bindings are strict when -XStrict is enabled+                | xopt LangExt.Strict dflags+                , matchGroupArity matches == 0 -- no need to force lambdas+                = [id]+                | isBangedHsBind b+                = [id]+                | otherwise+                = []+        ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun)+          --                          , ppr (mg_alts matches)+          --                          , ppr args, ppr core_binds]) $+          return (force_var, [core_binds]) }++dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss+                         , pat_ext = NPatBindTc _ ty+                         , pat_ticks = (rhs_tick, var_ticks) })+  = do  { body_expr <- dsGuarded grhss ty+        ; checkGuardMatches PatBindGuards grhss+        ; let body' = mkOptTickBox rhs_tick body_expr+              pat'  = decideBangHood dflags pat+        ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat body'+          -- We silently ignore inline pragmas; no makeCorePair+          -- Not so cool, but really doesn't matter+        ; let force_var' = if isBangedLPat pat'+                           then [force_var]+                           else []+        ; return (force_var', sel_binds) }++dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts+                          , abs_exports = exports+                          , abs_ev_binds = ev_binds+                          , abs_binds = binds, abs_sig = has_sig })+  = do { ds_binds <- addDictsDs (listToBag dicts) $+                     dsLHsBinds binds+                         -- addDictsDs: push type constraints deeper+                         --             for inner pattern match check+                         -- See Check, Note [Type and Term Equality Propagation]++       ; ds_ev_binds <- dsTcEvBinds_s ev_binds++       -- dsAbsBinds does the hard work+       ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }++dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"+dsHsBind _ (XHsBindsLR{}) = panic "dsHsBind: XHsBindsLR"+++-----------------------+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 _) = panic "dsAbsBinds"+       ; 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 _) = panic "dsAbsBinds"++       ; 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   = noExt+                     , abe_poly  = global+                     , abe_mono  = local+                     , abe_wrap  = WpHole+                     , abe_prags = SpecPrags [] })++-- | This is where we apply INLINE and INLINABLE pragmas. All we need to+-- do is to attach the unfolding information to the Id.+--+-- Other decisions about whether to inline are made in+-- `calcUnfoldingGuidance` but the decision about whether to then expose+-- the unfolding in the interface file is made in `TidyPgm.addExternal`+-- using this information.+------------------------+makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr+             -> (Id, CoreExpr)+makeCorePair dflags gbl_id is_default_method dict_arity rhs+  | is_default_method    -- Default methods are *always* inlined+                         -- See Note [INLINE and default methods] in TcInstDcls+  = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding rhs, rhs)++  | otherwise+  = case inlinePragmaSpec inline_prag of+          NoUserInline -> (gbl_id, rhs)+          NoInline     -> (gbl_id, rhs)+          Inlinable    -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)+          Inline       -> inline_pair++  where+    inline_prag   = idInlinePragma gbl_id+    inlinable_unf = mkInlinableUnfolding dflags rhs+    inline_pair+       | Just arity <- inlinePragmaSat inline_prag+        -- Add an Unfolding for an INLINE (but not for NOINLINE)+        -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]+       , let real_arity = dict_arity + arity+        -- NB: The arity in the InlineRule takes account of the dictionaries+       = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity real_arity rhs+         , etaExpand real_arity rhs)++       | otherwise+       = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $+         (gbl_id `setIdUnfolding` mkInlineUnfolding rhs, rhs)++dictArity :: [Var] -> Arity+-- Don't count coercion variables in arity+dictArity dicts = count isId dicts++{-+Note [Desugaring AbsBinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~+In the general AbsBinds case we desugar the binding to this:++       tup a (d:Num a) = let fm = ...gm...+                             gm = ...fm...+                         in (fm,gm)+       f a d = case tup a d of { (fm,gm) -> fm }+       g a d = case tup a d of { (fm,gm) -> fm }++Note [Rules and inlining]+~~~~~~~~~~~~~~~~~~~~~~~~~+Common special case: no type or dictionary abstraction+This is a bit less trivial than you might suppose+The naive way would be to desugar to something like+        f_lcl = ...f_lcl...     -- The "binds" from AbsBinds+        M.f = f_lcl             -- Generated from "exports"+But we don't want that, because if M.f isn't exported,+it'll be inlined unconditionally at every call site (its rhs is+trivial).  That would be ok unless it has RULES, which would+thereby be completely lost.  Bad, bad, bad.++Instead we want to generate+        M.f = ...f_lcl...+        f_lcl = M.f+Now all is cool. The RULES are attached to M.f (by SimplCore),+and f_lcl is rapidly inlined away.++This does not happen in the same way to polymorphic binds,+because they desugar to+        M.f = /\a. let f_lcl = ...f_lcl... in f_lcl+Although I'm a bit worried about whether full laziness might+float the f_lcl binding out and then inline M.f at its call site++Note [Specialising in no-dict case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Even if there are no tyvars or dicts, we may have specialisation pragmas.+Class methods can generate+      AbsBinds [] [] [( ... spec-prag]+         { AbsBinds [tvs] [dicts] ...blah }+So the overloading is in the nested AbsBinds. A good example is in GHC.Float:++  class  (Real a, Fractional a) => RealFrac a  where+    round :: (Integral b) => a -> b++  instance  RealFrac Float  where+    {-# SPECIALIZE round :: Float -> Int #-}++The top-level AbsBinds for $cround has no tyvars or dicts (because the+instance does not).  But the method is locally overloaded!++Note [Abstracting over tyvars only]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When abstracting over type variable only (not dictionaries), we don't really need to+built a tuple and select from it, as we do in the general case. Instead we can take++        AbsBinds [a,b] [ ([a,b], fg, fl, _),+                         ([b],   gg, gl, _) ]+                { fl = e1+                  gl = e2+                   h = e3 }++and desugar it to++        fg = /\ab. let B in e1+        gg = /\b. let a = () in let B in S(e2)+        h  = /\ab. let B in e3++where B is the *non-recursive* binding+        fl = fg a b+        gl = gg b+        h  = h a b    -- See (b); note shadowing!++Notice (a) g has a different number of type variables to f, so we must+             use the mkArbitraryType thing to fill in the gaps.+             We use a type-let to do that.++         (b) The local variable h isn't in the exports, and rather than+             clone a fresh copy we simply replace h by (h a b), where+             the two h's have different types!  Shadowing happens here,+             which looks confusing but works fine.++         (c) The result is *still* quadratic-sized if there are a lot of+             small bindings.  So if there are more than some small+             number (10), we filter the binding set B by the free+             variables of the particular RHS.  Tiresome.++Why got to this trouble?  It's a common case, and it removes the+quadratic-sized tuple desugaring.  Less clutter, hopefully faster+compilation, especially in a case where there are a *lot* of+bindings.+++Note [Eta-expanding INLINE things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   foo :: Eq a => a -> a+   {-# INLINE foo #-}+   foo x = ...++If (foo d) ever gets floated out as a common sub-expression (which can+happen as a result of method sharing), there's a danger that we never+get to do the inlining, which is a Terribly Bad thing given that the+user said "inline"!++To avoid this we pre-emptively eta-expand the definition, so that foo+has the arity with which it is declared in the source code.  In this+example it has arity 2 (one for the Eq and one for x). Doing this+should mean that (foo d) is a PAP and we don't share it.++Note [Nested arities]+~~~~~~~~~~~~~~~~~~~~~+For reasons that are not entirely clear, method bindings come out looking like+this:++  AbsBinds [] [] [$cfromT <= [] fromT]+    $cfromT [InlPrag=INLINE] :: T Bool -> Bool+    { AbsBinds [] [] [fromT <= [] fromT_1]+        fromT :: T Bool -> Bool+        { fromT_1 ((TBool b)) = not b } } }++Note the nested AbsBind.  The arity for the InlineRule on $cfromT should be+gotten from the binding for fromT_1.++It might be better to have just one level of AbsBinds, but that requires more+thought!+++Note [Desugar Strict binds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma++Desugaring strict variable bindings looks as follows (core below ==>)++  let !x = rhs+  in  body+==>+  let x = rhs+  in x `seq` body -- seq the variable++and if it is a pattern binding the desugaring looks like++  let !pat = rhs+  in body+==>+  let x = rhs -- bind the rhs to a new variable+      pat = x+  in x `seq` body -- seq the new variable++if there is no variable in the pattern desugaring looks like++  let False = rhs+  in body+==>+  let x = case rhs of {False -> (); _ -> error "Match failed"}+  in x `seq` body++In order to force the Ids in the binding group they are passed around+in the dsHsBind family of functions, and later seq'ed in DsExpr.ds_val_bind.++Consider a recursive group like this++  letrec+     f : g = rhs[f,g]+  in <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 HsUtils.isUnliftedHsBind.++Define a "banged bind" to have a top-level bang. Detected by HsPat.isBangedHsBind.+Define a "strict bind" to be either an unlifted bind or a banged bind.++The restrictions are:+  1. Strict binds may not be top-level. Checked in dsTopLHsBinds.++  2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged+     unlifted bind, but an unbanged bind looks lazy, and we don't want users to be+     surprised by the strictness of an unlifted bind.) Checked in first clause+     of DsExpr.ds_val_bind.++  3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type+     variables or constraints.) Checked in first clause+     of DsExpr.ds_val_bind.++  4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind.++-}++------------------------+dsSpecs :: CoreExpr     -- Its rhs+        -> TcSpecPrags+        -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids+               , [CoreRule] )           -- Rules for the Global Ids+-- See Note [Handling SPECIALISE pragmas] in TcBinds+dsSpecs _ IsDefaultMethod = return (nilOL, [])+dsSpecs poly_rhs (SpecPrags sps)+  = do { pairs <- mapMaybeM (dsSpec (Just poly_rhs)) sps+       ; let (spec_binds_s, rules) = unzip pairs+       ; return (concatOL spec_binds_s, rules) }++dsSpec :: Maybe CoreExpr        -- Just rhs => RULE is for a local binding+                                -- Nothing => RULE is for an imported Id+                                --            rhs is in the Id's unfolding+       -> Located TcSpecPrag+       -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))+dsSpec mb_poly_rhs (dL->L loc (SpecPrag poly_id spec_co spec_inl))+  | isJust (isClassOpId_maybe poly_id)+  = putSrcSpanDs loc $+    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for class method selector"+                          <+> quotes (ppr poly_id))+       ; return Nothing  }  -- There is no point in trying to specialise a class op+                            -- Moreover, classops don't (currently) have an inl_sat arity set+                            -- (it would be Just 0) and that in turn makes makeCorePair bleat++  | no_act_spec && isNeverActive rule_act+  = putSrcSpanDs loc $+    do { warnDs NoReason (text "Ignoring useless SPECIALISE pragma for NOINLINE function:"+                          <+> quotes (ppr poly_id))+       ; return Nothing  }  -- Function is NOINLINE, and the specialisation inherits that+                            -- See Note [Activation pragmas for SPECIALISE]++  | otherwise+  = putSrcSpanDs loc $+    do { uniq <- newUnique+       ; let poly_name = idName poly_id+             spec_occ  = mkSpecOcc (getOccName poly_name)+             spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)+             (spec_bndrs, spec_app) = collectHsWrapBinders spec_co+               -- spec_co looks like+               --         \spec_bndrs. [] spec_args+               -- perhaps with the body of the lambda wrapped in some WpLets+               -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2++       ; core_app <- dsHsWrapper spec_app++       ; let ds_lhs  = core_app (Var poly_id)+             spec_ty = mkLamTypes spec_bndrs (exprType ds_lhs)+       ; -- pprTrace "dsRule" (vcat [ text "Id:" <+> ppr poly_id+         --                         , text "spec_co:" <+> ppr spec_co+         --                         , text "ds_rhs:" <+> ppr ds_lhs ]) $+         dflags <- getDynFlags+       ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of {+           Left msg -> do { warnDs NoReason msg; return Nothing } ;+           Right (rule_bndrs, _fn, 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 overriden by SPEC INLINE++* Activation of RULE: from SPECIALISE pragma (if activation given)+                      otherwise from f's inline pragma++This is not obvious (see #5237)!++Examples      Rule activation   Inline prag on spec'd fn+---------------------------------------------------------------------+SPEC [n] f :: ty            [n]   Always, or NOINLINE [n]+                                  copy f's prag++NOINLINE f+SPEC [n] f :: ty            [n]   NOINLINE+                                  copy f's prag++NOINLINE [k] f+SPEC [n] f :: ty            [n]   NOINLINE [k]+                                  copy f's prag++INLINE [k] f+SPEC [n] f :: ty            [n]   INLINE [k]+                                  copy f's prag++SPEC INLINE [n] f :: ty     [n]   INLINE [n]+                                  (ignore INLINE prag on f,+                                  same activation for rule and spec'd fn)++NOINLINE [k] f+SPEC f :: ty                [n]   INLINE [k]+++************************************************************************+*                                                                      *+\subsection{Adding inline pragmas}+*                                                                      *+************************************************************************+-}++decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr+                 -> Either SDoc ([Var], Id, [CoreExpr])+-- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,+-- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs+-- may add some extra dictionary binders (see Note [Free dictionaries])+--+-- Returns an error message if the LHS isn't of the expected shape+-- Note [Decomposing the left-hand side of a RULE]+decomposeRuleLhs dflags orig_bndrs orig_lhs+  | not (null unbound)    -- Check for things unbound on LHS+                          -- See Note [Unused spec binders]+  = Left (vcat (map dead_msg unbound))+  | Var funId <- fun2+  , Just con <- isDataConId_maybe funId+  = Left (constructor_msg con) -- See Note [No RULES on datacons]+  | Just (fn_id, args) <- decompose fun2 args2+  , let extra_bndrs = mk_extra_bndrs fn_id args+  = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs+    --                                  , text "orig_lhs:" <+> ppr orig_lhs+    --                                  , text "lhs1:"     <+> ppr lhs1+    --                                  , text "extra_dict_bndrs:" <+> ppr extra_dict_bndrs+    --                                  , text "fn_id:" <+> ppr fn_id+    --                                  , text "args:"   <+> ppr args]) $+    Right (orig_bndrs ++ extra_bndrs, fn_id, args)++  | otherwise+  = Left bad_shape_msg+ where+   lhs1         = drop_dicts orig_lhs+   lhs2         = simpleOptExpr dflags lhs1  -- See Note [Simplify rule LHS]+   (fun2,args2) = collectArgs lhs2++   lhs_fvs    = exprFreeVars lhs2+   unbound    = filterOut (`elemVarSet` lhs_fvs) orig_bndrs++   orig_bndr_set = mkVarSet orig_bndrs++        -- Add extra tyvar binders: Note [Free tyvars in rule LHS]+        -- and extra dict binders: Note [Free dictionaries in rule LHS]+   mk_extra_bndrs fn_id args+     = scopedSort unbound_tvs ++ unbound_dicts+     where+       unbound_tvs   = [ v | v <- unbound_vars, isTyVar v ]+       unbound_dicts = [ mkLocalId (localiseName (idName d)) (idType d)+                       | d <- unbound_vars, isDictId d ]+       unbound_vars  = [ v | v <- exprsFreeVarsList args+                           , not (v `elemVarSet` orig_bndr_set)+                           , not (v == fn_id) ]+         -- fn_id: do not quantify over the function itself, which may+         -- itself be a dictionary (in pathological cases, #10251)++   decompose (Var fn_id) args+      | not (fn_id `elemVarSet` orig_bndr_set)+      = Just (fn_id, args)++   decompose _ _ = Nothing++   bad_shape_msg = hang (text "RULE left-hand side too complicated to desugar")+                      2 (vcat [ text "Optimised lhs:" <+> ppr lhs2+                              , text "Orig lhs:" <+> ppr orig_lhs])+   dead_msg bndr = hang (sep [ text "Forall'd" <+> pp_bndr bndr+                             , text "is not bound in RULE lhs"])+                      2 (vcat [ text "Orig bndrs:" <+> ppr orig_bndrs+                              , text "Orig lhs:" <+> ppr orig_lhs+                              , text "optimised lhs:" <+> ppr lhs2 ])+   pp_bndr bndr+    | isTyVar bndr = text "type variable" <+> quotes (ppr bndr)+    | isEvVar bndr = text "constraint"    <+> quotes (ppr (varType bndr))+    | otherwise    = text "variable"      <+> quotes (ppr bndr)++   constructor_msg con = vcat+     [ text "A constructor," <+> ppr con <>+         text ", appears as outermost match in RULE lhs."+     , text "This rule will be ignored." ]++   drop_dicts :: CoreExpr -> CoreExpr+   drop_dicts e+       = wrap_lets needed bnds body+     where+       needed = orig_bndr_set `minusVarSet` exprFreeVars body+       (bnds, body) = split_lets (occurAnalyseExpr e)+           -- The occurAnalyseExpr drops dead bindings which is+           -- crucial to ensure that every binding is used later;+           -- which in turn makes wrap_lets work right++   split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)+   split_lets (Let (NonRec d r) body)+     | isDictId d+     = ((d,r):bs, body')+     where (bs, body') = split_lets body++    -- handle "unlifted lets" too, needed for "map/coerce"+   split_lets (Case r d _ [(DEFAULT, _, body)])+     | isCoVar d+     = ((d,r):bs, body')+     where (bs, body') = split_lets body++   split_lets e = ([], e)++   wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr+   wrap_lets _ [] body = body+   wrap_lets needed ((d, r) : bs) body+     | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body)+     | otherwise                         = wrap_lets needed bs body+     where+       rhs_fvs = exprFreeVars r+       needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d++{-+Note [Decomposing the left-hand side of a RULE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are several things going on here.+* drop_dicts: see Note [Drop dictionary bindings on rule LHS]+* simpleOptExpr: see Note [Simplify rule LHS]+* extra_dict_bndrs: see Note [Free dictionaries]++Note [Free tyvars on rule LHS]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data T a = C++  foo :: T a -> Int+  foo C = 1++  {-# RULES "myrule"  foo C = 1 #-}++After type checking the LHS becomes (foo alpha (C alpha)), where alpha+is an unbound meta-tyvar.  The zonker in TcHsSyn is careful not to+turn the free alpha into Any (as it usually does).  Instead it turns it+into a TyVar 'a'.  See TcHsSyn Note [Zonking the LHS of a RULE].++Now we must quantify over that 'a'.  It's /really/ inconvenient to do that+in the zonker, because the HsExpr data type is very large.  But it's /easy/+to do it here in the desugarer.++Moreover, we have to do something rather similar for dictionaries;+see Note [Free dictionaries on rule LHS].   So that's why we look for+type variables free on the LHS, and quantify over them.++Note [Free dictionaries on rule LHS]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,+which is presumably in scope at the function definition site, we can quantify+over it too.  *Any* dict with that type will do.++So for example when you have+        f :: Eq a => a -> a+        f = <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 [Matching seqId]+~~~~~~~~~~~~~~~~~~~+The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack+and this code turns it back into an application of seq!+See Note [Rules for seq] in MkId for the details.++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 = foldrBag ((:) . 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/DsCCall.hs view
@@ -0,0 +1,379 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1994-1998+++Desugaring foreign calls+-}++{-# LANGUAGE CPP #-}+module DsCCall+        ( dsCCall+        , mkFCall+        , unboxArg+        , boxResult+        , resultWrapper+        ) where++#include "HsVersions.h"+++import GhcPrelude++import CoreSyn++import DsMonad+import CoreUtils+import MkCore+import MkId+import ForeignCall+import DataCon+import DsUtils++import TcType+import Type+import Id   ( Id )+import Coercion+import PrimOp+import TysPrim+import TyCon+import TysWiredIn+import BasicTypes+import Literal+import PrelNames+import DynFlags+import Outputable+import Util++import Data.Maybe++{-+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 view
@@ -0,0 +1,1168 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Desugaring expressions.+-}++{-# LANGUAGE CPP, MultiWayIf #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds+              , dsValBinds, dsLit, dsSyntaxExpr ) where++#include "HsVersions.h"++import GhcPrelude++import Match+import MatchLit+import DsBinds+import DsGRHSs+import DsListComp+import DsUtils+import DsArrows+import DsMonad+import Check ( checkGuardMatches )+import Name+import NameEnv+import FamInstEnv( topNormaliseType )+import DsMeta+import HsSyn++-- NB: The desugarer, which straddles the source and Core worlds, sometimes+--     needs to see source types+import TcType+import TcEvidence+import TcRnMonad+import TcHsSyn+import Type+import CoreSyn+import CoreUtils+import MkCore++import DynFlags+import CostCentre+import Id+import MkId+import Module+import ConLike+import DataCon+import TysWiredIn+import PrelNames+import BasicTypes+import Maybes+import VarEnv+import SrcLoc+import Util+import Bag+import Outputable+import PatSyn++import Control.Monad++{-+************************************************************************+*                                                                      *+                dsLocalBinds, dsValBinds+*                                                                      *+************************************************************************+-}++dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr+dsLocalBinds (dL->L _   (EmptyLocalBinds _))  body = return body+dsLocalBinds (dL->L loc (HsValBinds _ binds)) body = putSrcSpanDs loc $+                                                   dsValBinds binds body+dsLocalBinds (dL->L _ (HsIPBinds _ binds))    body = dsIPBinds  binds body+dsLocalBinds _                                _    = panic "dsLocalBinds"++-------------------------+-- caller sets location+dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr+dsValBinds (XValBindsLR (NValBinds binds _)) body+  = foldrM ds_val_bind body binds+dsValBinds (ValBinds {})       _    = panic "dsValBinds ValBindsIn"++-------------------------+dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr+dsIPBinds (IPBinds ev_binds ip_binds) body+  = do  { ds_binds <- dsTcEvBinds ev_binds+        ; let inner = mkCoreLets ds_binds body+                -- The dict bindings may not be in+                -- dependency order; hence Rec+        ; foldrM ds_ip_bind inner ip_binds }+  where+    ds_ip_bind (dL->L _ (IPBind _ ~(Right n) e)) body+      = do e' <- dsLExpr e+           return (Let (NonRec n e') body)+    ds_ip_bind _ _ = panic "dsIPBinds"+dsIPBinds (XHsIPBinds _) _ = panic "dsIPBinds"++-------------------------+-- caller sets location+ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr+-- Special case for bindings which bind unlifted variables+-- We need to do a case right away, rather than building+-- a tuple and doing selections.+-- Silently ignore INLINE and SPECIALISE pragmas...+ds_val_bind (NonRecursive, hsbinds) body+  | [dL->L loc bind] <- bagToList hsbinds+        -- Non-recursive, non-overloaded bindings only come in ones+        -- ToDo: in some bizarre case it's conceivable that there+        --       could be dict binds in the 'binds'.  (See the notes+        --       below.  Then pattern-match would fail.  Urk.)+  , isUnliftedHsBind bind+  = putSrcSpanDs loc $+     -- see Note [Strict binds checks] in DsBinds+    if is_polymorphic bind+    then errDsCoreExpr (poly_bind_err bind)+            -- data Ptr a = Ptr Addr#+            -- f x = let p@(Ptr y) = ... in ...+            -- Here the binding for 'p' is polymorphic, but does+            -- not mix with an unlifted binding for 'y'.  You should+            -- use a bang pattern.  #6078.++    else do { when (looksLazyPatBind bind) $+              warnIfSetDs Opt_WarnUnbangedStrictPatterns (unlifted_must_be_bang bind)+        -- Complain about a binding that looks lazy+        --    e.g.    let I# y = x in ...+        -- Remember, in checkStrictBinds we are going to do strict+        -- matching, so (for software engineering reasons) we insist+        -- that the strictness is manifest on each binding+        -- However, lone (unboxed) variables are ok+++            ; dsUnliftedBind bind body }+  where+    is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })+                     = not (null tvs && null evs)+    is_polymorphic _ = False++    unlifted_must_be_bang bind+      = hang (text "Pattern bindings containing unlifted types should use" $$+              text "an outermost bang pattern:")+           2 (ppr bind)++    poly_bind_err bind+      = hang (text "You can't mix polymorphic and unlifted bindings:")+           2 (ppr bind) $$+        text "Probable fix: add a type signature"++ds_val_bind (is_rec, binds) _body+  | anyBag (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in DsBinds+  = ASSERT( isRec is_rec )+    errDsCoreExpr $+    hang (text "Recursive bindings for unlifted types aren't allowed:")+       2 (vcat (map ppr (bagToList binds)))++-- Ordinary case for bindings; none should be unlifted+ds_val_bind (is_rec, binds) body+  = do  { MASSERT( isRec is_rec || isSingletonBag binds )+               -- we should never produce a non-recursive list of multiple binds++        ; (force_vars,prs) <- dsLHsBinds binds+        ; let body' = foldr seqVar body force_vars+        ; ASSERT2( not (any (isUnliftedType . idType . fst) prs), ppr is_rec $$ ppr binds )+          case prs of+            [] -> return body+            _  -> return (Let (Rec prs) body') }+        -- Use a Rec regardless of is_rec.+        -- Why? Because it allows the binds to be all+        -- mixed up, which is what happens in one rare case+        -- Namely, for an AbsBind with no tyvars and no dicts,+        --         but which does have dictionary bindings.+        -- See notes with TcSimplify.inferLoop [NO TYVARS]+        -- It turned out that wrapping a Rec here was the easiest solution+        --+        -- NB The previous case dealt with unlifted bindings, so we+        --    only have to deal with lifted ones now; so Rec is ok++------------------+dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr+dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []+               , abs_exports = exports+               , abs_ev_binds = ev_binds+               , abs_binds = lbinds }) body+  = do { let body1 = foldr bind_export body exports+             bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b+       ; body2 <- foldlBagM (\body lbind -> dsUnliftedBind (unLoc lbind) body)+                            body1 lbinds+       ; ds_binds <- dsTcEvBinds_s ev_binds+       ; return (mkCoreLets ds_binds body2) }++dsUnliftedBind (FunBind { fun_id = (dL->L l fun)+                        , fun_matches = matches+                        , fun_co_fn = co_fn+                        , fun_tick = tick }) body+               -- Can't be a bang pattern (that looks like a PatBind)+               -- so must be simply unboxed+  = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (cL l $ idName fun))+                                     Nothing matches+       ; MASSERT( null args ) -- Functions aren't lifted+       ; MASSERT( isIdHsWrapper co_fn )+       ; let rhs' = mkOptTickBox tick rhs+       ; return (bindNonRec fun rhs' body) }++dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss+                        , pat_ext = NPatBindTc _ ty }) body+  =     -- let C x# y# = rhs in body+        -- ==> case rhs of C x# y# -> body+    do { rhs <- dsGuarded grhss ty+       ; checkGuardMatches PatBindGuards grhss+       ; let upat = unLoc pat+             eqn = EqnInfo { eqn_pats = [upat],+                             eqn_orig = FromSource,+                             eqn_rhs = cantFailMatchResult body }+       ; var    <- selectMatchVar upat+       ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)+       ; return (bindNonRec var rhs result) }++dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)++{-+************************************************************************+*                                                                      *+\subsection[DsExpr-vars-and-cons]{Variables, constructors, literals}+*                                                                      *+************************************************************************+-}++dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr++dsLExpr (dL->L loc e)+  = putSrcSpanDs loc $+    do { core_expr <- dsExpr e+   -- uncomment this check to test the hsExprType function in TcHsSyn+   --    ; MASSERT2( exprType core_expr `eqType` hsExprType e+   --              , ppr e <+> dcolon <+> ppr (hsExprType e) $$+   --                ppr core_expr <+> dcolon <+> ppr (exprType core_expr) )+       ; return core_expr }++-- | Variant of 'dsLExpr' that ensures that the result is not levity+-- polymorphic. This should be used when the resulting expression will+-- be an argument to some other function.+-- See Note [Levity polymorphism checking] in DsMonad+-- See Note [Levity polymorphism invariants] in CoreSyn+dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr+dsLExprNoLP (dL->L loc e)+  = putSrcSpanDs loc $+    do { e' <- dsExpr e+       ; dsNoLevPolyExpr e' (text "In the type of expression:" <+> ppr e)+       ; return e' }++dsExpr :: HsExpr GhcTc -> DsM CoreExpr+dsExpr = ds_expr False++ds_expr :: Bool   -- are we directly inside an HsWrap?+                  -- See Wrinkle in Note [Detecting forced eta expansion]+        -> HsExpr GhcTc -> DsM CoreExpr+ds_expr _ (HsPar _ e)            = dsLExpr e+ds_expr _ (ExprWithTySig _ e _)  = dsLExpr e+ds_expr w (HsVar _ (dL->L _ var)) = dsHsVar w var+ds_expr _ (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them+ds_expr w (HsConLikeOut _ con)   = dsConLike w con+ds_expr _ (HsIPVar {})           = panic "dsExpr: HsIPVar"+ds_expr _ (HsOverLabel{})        = panic "dsExpr: HsOverLabel"++ds_expr _ (HsLit _ lit)+  = do { warnAboutOverflowedLit lit+       ; dsLit (convertLit lit) }++ds_expr _ (HsOverLit _ lit)+  = do { warnAboutOverflowedOverLit lit+       ; dsOverLit lit }++ds_expr _ (HsWrap _ co_fn e)+  = do { e' <- ds_expr True e    -- This is the one place where we recurse to+                                 -- ds_expr (passing True), rather than dsExpr+       ; wrap' <- dsHsWrapper co_fn+       ; dflags <- getDynFlags+       ; let wrapped_e = wrap' e'+             wrapped_ty = exprType wrapped_e+       ; checkForcedEtaExpansion e wrapped_ty -- See Note [Detecting forced eta expansion]+       ; warnAboutIdentities dflags e' wrapped_ty+       ; return wrapped_e }++ds_expr _ (NegApp _ (dL->L loc+                      (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))+                  neg_expr)+  = do { expr' <- putSrcSpanDs loc $ do+          { warnAboutOverflowedOverLit+              (lit { ol_val = HsIntegral (negateIntegralLit i) })+          ; dsOverLit lit }+       ; dsSyntaxExpr neg_expr [expr'] }++ds_expr _ (NegApp _ expr neg_expr)+  = do { expr' <- dsLExpr expr+       ; dsSyntaxExpr neg_expr [expr'] }++ds_expr _ (HsLam _ a_Match)+  = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match++ds_expr _ (HsLamCase _ matches)+  = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches+       ; return $ Lam discrim_var matching_code }++ds_expr _ e@(HsApp _ fun arg)+  = do { fun' <- dsLExpr fun+       ; dsWhenNoErrs (dsLExprNoLP arg)+                      (\arg' -> mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg') }++ds_expr _ (HsAppType _ e _)+    -- ignore type arguments here; they're in the wrappers instead at this point+  = dsLExpr e++{-+Note [Desugaring vars]+~~~~~~~~~~~~~~~~~~~~~~+In one situation we can get a *coercion* variable in a HsVar, namely+the support method for an equality superclass:+   class (a~b) => C a b where ...+   instance (blah) => C (T a) (T b) where ..+Then we get+   $dfCT :: forall ab. blah => C (T a) (T b)+   $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)++   $c$p1C :: forall ab. blah => (T a ~ T b)+   $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g++That 'g' in the 'in' part is an evidence variable, and when+converting to core it must become a CO.++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) (dL->L _ (Missing ty))+                    -- For every missing expression, we need+                    -- another lambda in the desugaring.+               = do { lam_var <- newSysLocalDsNoLP ty+                    ; return (lam_var : lam_vars, Var lam_var : args) }+             go (lam_vars, args) (dL->L _ (Present _ expr))+                    -- Expressions that are present don't generate+                    -- lambdas, just arguments.+               = do { core_expr <- dsLExprNoLP expr+                    ; return (lam_vars, core_expr : args) }+             go _ _ = panic "ds_expr"++       ; dsWhenNoErrs (foldM go ([], []) (reverse tup_args))+                -- The reverse is because foldM goes left-to-right+                      (\(lam_vars, args) -> mkCoreLams lam_vars $+                                            mkCoreTupBoxity boxity args) }++ds_expr _ (ExplicitSum types alt arity expr)+  = do { dsWhenNoErrs (dsLExprNoLP expr)+                      (\core_expr -> mkCoreConApps (sumDataCon alt arity)+                                     (map (Type . getRuntimeRep) types +++                                      map Type types +++                                      [core_expr]) ) }++ds_expr _ (HsSCC _ _ cc expr@(dL->L loc _)) = do+    dflags <- getDynFlags+    if gopt Opt_SccProfilingOn dflags+      then do+        mod_name <- getModule+        count <- goptM Opt_ProfCountEntries+        let nm = sl_fs cc+        flavour <- ExprCC <$> getCCIndexM nm+        Tick (ProfNote (mkUserCC nm mod_name loc flavour) count True)+               <$> dsLExpr expr+      else dsLExpr expr++ds_expr _ (HsCoreAnn _ _ _ expr)+  = dsLExpr expr++ds_expr _ (HsCase _ discrim matches)+  = do { core_discrim <- dsLExpr discrim+       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches+       ; return (bindNonRec discrim_var core_discrim matching_code) }++-- Pepe: The binds are in scope in the body but NOT in the binding group+--       This is to avoid silliness in breakpoints+ds_expr _ (HsLet _ binds body) = do+    body' <- dsLExpr body+    dsLocalBinds binds body'++-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)+-- because the interpretation of `stmts' depends on what sort of thing it is.+--+ds_expr _ (HsDo res_ty ListComp (dL->L _ stmts)) = dsListComp stmts res_ty+ds_expr _ (HsDo _ DoExpr        (dL->L _ stmts)) = dsDo stmts+ds_expr _ (HsDo _ GhciStmtCtxt  (dL->L _ stmts)) = dsDo stmts+ds_expr _ (HsDo _ MDoExpr       (dL->L _ stmts)) = dsDo stmts+ds_expr _ (HsDo _ MonadComp     (dL->L _ stmts)) = dsMonadComp stmts++ds_expr _ (HsIf _ mb_fun guard_expr then_expr else_expr)+  = do { pred <- dsLExpr guard_expr+       ; b1 <- dsLExpr then_expr+       ; b2 <- dsLExpr else_expr+       ; case mb_fun of+           Just fun -> dsSyntaxExpr fun [pred, b1, b2]+           Nothing  -> return $ mkIfThenElse pred b1 b2 }++ds_expr _ (HsMultiIf res_ty alts)+  | null alts+  = mkErrorExpr++  | otherwise+  = do { match_result <- liftM (foldr1 combineMatchResults)+                               (mapM (dsGRHS IfAlt res_ty) alts)+       ; checkGuardMatches IfAlt (GRHSs noExt alts (noLoc emptyLocalBinds))+       ; error_expr   <- mkErrorExpr+       ; extractMatchResult match_result error_expr }+  where+    mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty+                               (text "multi-way if")++{-+\noindent+\underline{\bf Various data construction things}+             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-}++ds_expr _ (ExplicitList elt_ty wit xs)+  = dsExplicitList elt_ty wit xs++ds_expr _ (ArithSeq expr witness seq)+  = case witness of+     Nothing -> dsArithSeq expr seq+     Just fl -> do { newArithSeq <- dsArithSeq expr seq+                   ; dsSyntaxExpr fl [newArithSeq] }++{-+Static Pointers+~~~~~~~~~~~~~~~++See Note [Grand plan for static forms] in StaticPtrTable for an overview.++    g = ... static f ...+==>+    g = ... makeStatic loc f ...+-}++ds_expr _ (HsStatic _ expr@(dL->L loc _)) = do+    expr_ds <- dsLExprNoLP expr+    let ty = exprType expr_ds+    makeStaticId <- dsLookupGlobalId makeStaticName++    dflags <- getDynFlags+    let (line, col) = case loc of+           RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r+                            , srcLocCol  $ realSrcSpanStart r+                            )+           _             -> (0, 0)+        srcLoc = mkCoreConApps (tupleDataCon Boxed 2)+                     [ Type intTy              , Type intTy+                     , mkIntExprInt dflags line, mkIntExprInt dflags col+                     ]++    putSrcSpanDs loc $ return $+      mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]++{-+\noindent+\underline{\bf Record construction and update}+             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For record construction we do this (assuming T has three arguments)+\begin{verbatim}+        T { op2 = e }+==>+        let err = /\a -> recConErr a+        T (recConErr t1 "M.hs/230/op1")+          e+          (recConErr t1 "M.hs/230/op3")+\end{verbatim}+@recConErr@ then converts its argument string into a proper message+before printing it as+\begin{verbatim}+        M.hs, line 230: missing field op1 was evaluated+\end{verbatim}++We also handle @C{}@ as valid construction syntax for an unlabelled+constructor @C@, setting all of @C@'s fields to bottom.+-}++ds_expr _ (RecordCon { rcon_flds = rbinds+                     , rcon_ext = RecordConTc { rcon_con_expr = con_expr+                                              , rcon_con_like = con_like }})+  = do { con_expr' <- dsExpr con_expr+       ; let+             (arg_tys, _) = tcSplitFunTys (exprType con_expr')+             -- A newtype in the corner should be opaque;+             -- hence TcType.tcSplitFunTys++             mk_arg (arg_ty, fl)+               = case findField (rec_flds rbinds) (flSelector fl) of+                   (rhs:rhss) -> ASSERT( null rhss )+                                 dsLExprNoLP rhs+                   []         -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))+             unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty++             labels = conLikeFieldLabels con_like++       ; con_args <- if null labels+                     then mapM unlabelled_bottom arg_tys+                     else mapM mk_arg (zipEqual "dsExpr:RecordCon" arg_tys labels)++       ; return (mkCoreApps con_expr' con_args) }++{-+Record update is a little harder. Suppose we have the decl:+\begin{verbatim}+        data T = T1 {op1, op2, op3 :: Int}+               | T2 {op4, op2 :: Int}+               | T3+\end{verbatim}+Then we translate as follows:+\begin{verbatim}+        r { op2 = e }+===>+        let op2 = e in+        case r of+          T1 op1 _ op3 -> T1 op1 op2 op3+          T2 op4 _     -> T2 op4 op2+          other        -> recUpdError "M.hs/230"+\end{verbatim}+It's important that we use the constructor Ids for @T1@, @T2@ etc on the+RHSs, and do not generate a Core constructor application directly, because the constructor+might do some argument-evaluation first; and may have to throw away some+dictionaries.++Note [Update for GADTs]+~~~~~~~~~~~~~~~~~~~~~~~+Consider+   data T a b where+     T1 :: { f1 :: a } -> T a Int++Then the wrapper function for T1 has type+   $WT1 :: a -> T a Int+But if x::T a b, then+   x { f1 = v } :: T a b   (not T a Int!)+So we need to cast (T a Int) to (T a b).  Sigh.++-}++ds_expr _ expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields+                          , rupd_ext = RecordUpdTc+                              { rupd_cons = cons_to_upd+                              , rupd_in_tys = in_inst_tys+                              , rupd_out_tys = out_inst_tys+                              , rupd_wrap = dict_req_wrap }} )+  | null fields+  = dsLExpr record_expr+  | otherwise+  = ASSERT2( notNull cons_to_upd, ppr expr )++    do  { record_expr' <- dsLExpr record_expr+        ; field_binds' <- mapM ds_field fields+        ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding+              upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']++        -- It's important to generate the match with matchWrapper,+        -- and the right hand sides with applications of the wrapper Id+        -- so that everything works when we are doing fancy unboxing on the+        -- constructor arguments.+        ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd+        ; ([discrim_var], matching_code)+                <- matchWrapper RecUpd Nothing+                                      (MG { mg_alts = noLoc alts+                                          , mg_ext = MatchGroupTc [in_ty] out_ty+                                          , mg_origin = FromSource })+                                     -- FromSource is not strictly right, but we+                                     -- want incomplete pattern-match warnings++        ; return (add_field_binds field_binds' $+                  bindNonRec discrim_var record_expr' matching_code) }+  where+    ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr)+      -- Clone the Id in the HsRecField, because its Name is that+      -- of the record selector, and we must not make that a local binder+      -- else we shadow other uses of the record selector+      -- Hence 'lcl_id'.  Cf #2735+    ds_field (dL->L _ rec_field)+      = do { rhs <- dsLExpr (hsRecFieldArg rec_field)+           ; let fld_id = unLoc (hsRecUpdFieldId rec_field)+           ; lcl_id <- newSysLocalDs (idType fld_id)+           ; return (idName fld_id, lcl_id, rhs) }++    add_field_binds [] expr = expr+    add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)++        -- Awkwardly, for families, the match goes+        -- from instance type to family type+    (in_ty, out_ty) =+      case (head cons_to_upd) of+        RealDataCon data_con ->+          let tycon = dataConTyCon data_con in+          (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys)+        PatSynCon pat_syn ->+          ( patSynInstResTy pat_syn in_inst_tys+          , patSynInstResTy pat_syn out_inst_tys)+    mk_alt upd_fld_env con+      = do { let (univ_tvs, ex_tvs, eq_spec,+                  prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con+                 user_tvs =+                   case con of+                     RealDataCon data_con -> dataConUserTyVars data_con+                     PatSynCon _          -> univ_tvs ++ ex_tvs+                       -- The order here is because of the order in `TcPatSyn`.+                 in_subst  = zipTvSubst univ_tvs in_inst_tys+                 out_subst = zipTvSubst univ_tvs out_inst_tys++                -- I'm not bothering to clone the ex_tvs+           ; eqs_vars   <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec))+           ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta)+           ; arg_ids    <- newSysLocalsDs (substTysUnchecked in_subst arg_tys)+           ; let field_labels = conLikeFieldLabels con+                 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg+                                         field_labels arg_ids+                 mk_val_arg fl pat_arg_id+                     = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)++                 inst_con = noLoc $ mkHsWrap wrap (HsConLikeOut noExt con)+                        -- Reconstruct with the WrapId so that unpacking happens+                 wrap = mkWpEvVarApps theta_vars                                <.>+                        dict_req_wrap                                           <.>+                        mkWpTyApps    [ lookupTyVar out_subst tv+                                          `orElse` mkTyVarTy tv+                                      | tv <- user_tvs+                                      , not (tv `elemVarEnv` wrap_subst) ]+                          -- Be sure to use user_tvs (which may be ordered+                          -- differently than `univ_tvs ++ ex_tvs) above.+                          -- See Note [DataCon user type variable binders]+                          -- in DataCon.+                 rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args++                        -- Tediously wrap the application in a cast+                        -- Note [Update for GADTs]+                 wrapped_rhs =+                  case con of+                    RealDataCon data_con ->+                      let+                        wrap_co =+                          mkTcTyConAppCo Nominal+                            (dataConTyCon data_con)+                            [ lookup tv ty+                              | (tv,ty) <- univ_tvs `zip` out_inst_tys ]+                        lookup univ_tv ty =+                          case lookupVarEnv wrap_subst univ_tv of+                            Just co' -> co'+                            Nothing  -> mkTcReflCo Nominal ty+                        in if null eq_spec+                             then rhs+                             else mkLHsWrap (mkWpCastN wrap_co) rhs+                    -- eq_spec is always null for a PatSynCon+                    PatSynCon _ -> rhs++                 wrap_subst =+                  mkVarEnv [ (tv, mkTcSymCo (mkTcCoVarCo eq_var))+                           | (spec, eq_var) <- eq_spec `zip` eqs_vars+                           , let tv = eqSpecTyVar spec ]++                 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys++                 pat = noLoc $ ConPatOut { pat_con = noLoc con+                                         , pat_tvs = ex_tvs+                                         , pat_dicts = eqs_vars ++ theta_vars+                                         , pat_binds = emptyTcEvBinds+                                         , pat_args = PrefixCon $ map nlVarPat arg_ids+                                         , pat_arg_tys = in_inst_tys+                                         , pat_wrap = req_wrap }+           ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }++-- Here is where we desugar the Template Haskell brackets and escapes++-- Template Haskell stuff++ds_expr _ (HsRnBracketOut _ _ _)  = panic "dsExpr HsRnBracketOut"+ds_expr _ (HsTcBracketOut _ x ps) = dsBracket x ps+ds_expr _ (HsSpliceE _ s)         = pprPanic "dsExpr:splice" (ppr s)++-- Arrow notation extension+ds_expr _ (HsProc _ pat cmd) = dsProcExpr pat cmd++-- Hpc Support++ds_expr _ (HsTick _ tickish e) = do+  e' <- dsLExpr e+  return (Tick tickish e')++-- There is a problem here. The then and else branches+-- have no free variables, so they are open to lifting.+-- We need someway of stopping this.+-- This will make no difference to binary coverage+-- (did you go here: YES or NO), but will effect accurate+-- tick counting.++ds_expr _ (HsBinTick _ ixT ixF e) = do+  e2 <- dsLExpr e+  do { ASSERT(exprType e2 `eqType` boolTy)+       mkBinaryTickBox ixT ixF e2+     }++ds_expr _ (HsTickPragma _ _ _ _ expr) = do+  dflags <- getDynFlags+  if gopt Opt_Hpc dflags+    then panic "dsExpr:HsTickPragma"+    else dsLExpr expr++-- HsSyn constructs that just shouldn't be here:+ds_expr _ (HsBracket     {})  = panic "dsExpr:HsBracket"+ds_expr _ (HsDo          {})  = panic "dsExpr:HsDo"+ds_expr _ (HsRecFld      {})  = panic "dsExpr:HsRecFld"+ds_expr _ (XExpr         {})  = panic "dsExpr: XExpr"+++------------------------------+dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr+dsSyntaxExpr (SyntaxExpr { syn_expr      = expr+                         , syn_arg_wraps = arg_wraps+                         , syn_res_wrap  = res_wrap })+             arg_exprs+  = do { fun            <- dsExpr expr+       ; core_arg_wraps <- mapM dsHsWrapper arg_wraps+       ; core_res_wrap  <- dsHsWrapper res_wrap+       ; let wrapped_args = zipWith ($) core_arg_wraps arg_exprs+       ; dsWhenNoErrs (zipWithM_ dsNoLevPolyExpr wrapped_args [ mk_doc n | n <- [1..] ])+                      (\_ -> core_res_wrap (mkApps fun wrapped_args)) }+  where+    mk_doc n = text "In the" <+> speakNth n <+> text "argument of" <+> quotes (ppr expr)++findField :: [LHsRecField GhcTc arg] -> Name -> [arg]+findField rbinds sel+  = [hsRecFieldArg fld | (dL->L _ fld) <- rbinds+                       , sel == idName (unLoc $ hsRecFieldId fld) ]++{-+%--------------------------------------------------------------------++Note [Desugaring explicit lists]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Explicit lists are desugared in a cleverer way to prevent some+fruitless allocations.  Essentially, whenever we see a list literal+[x_1, ..., x_n] we generate the corresponding expression in terms of+build:++Explicit lists (literals) are desugared to allow build/foldr fusion when+beneficial. This is a bit of a trade-off,++ * build/foldr fusion can generate far larger code than the corresponding+   cons-chain (e.g. see #11707)++ * even when it doesn't produce more code, build can still fail to fuse,+   requiring that the simplifier do more work to bring the expression+   back into cons-chain form; this costs compile time++ * when it works, fusion can be a significant win. Allocations are reduced+   by up to 25% in some nofib programs. Specifically,++        Program           Size    Allocs   Runtime  CompTime+        rewrite          +0.0%    -26.3%      0.02     -1.8%+           ansi          -0.3%    -13.8%      0.00     +0.0%+           lift          +0.0%     -8.7%      0.00     -2.3%++At the moment we use a simple heuristic to determine whether build will be+fruitful: for small lists we assume the benefits of fusion will be worthwhile;+for long lists we assume that the benefits will be outweighted by the cost of+code duplication. This magic length threshold is @maxBuildLength@. Also, fusion+won't work at all if rewrite rules are disabled, so we don't use the build-based+desugaring in this case.++We used to have a more complex heuristic which would try to break the list into+"static" and "dynamic" parts and only build-desugar the dynamic part.+Unfortunately, determining "static-ness" reliably is a bit tricky and the+heuristic at times produced surprising behavior (see #11710) so it was dropped.+-}++{- | The longest list length which we will desugar using @build@.++This is essentially a magic number and its setting is unfortunate rather+arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists],+is to avoid deforesting large static data into large(r) code. Ideally we'd+want a smaller threshold with larger consumers and vice-versa, but we have no+way of knowing what will be consuming our list in the desugaring impossible to+set generally correctly.++The effect of reducing this number will be that 'build' fusion is applied+less often. From a runtime performance perspective, applying 'build' more+liberally on "moderately" sized lists should rarely hurt and will often it can+only expose further optimization opportunities; if no fusion is possible it will+eventually get rule-rewritten back to a list). We do, however, pay in compile+time.+-}+maxBuildLength :: Int+maxBuildLength = 32++dsExplicitList :: Type -> Maybe (SyntaxExpr GhcTc) -> [LHsExpr GhcTc]+               -> DsM CoreExpr+-- See Note [Desugaring explicit lists]+dsExplicitList elt_ty Nothing xs+  = do { dflags <- getDynFlags+       ; xs' <- mapM dsLExprNoLP xs+       ; if xs' `lengthExceeds` maxBuildLength+                -- Don't generate builds if the list is very long.+         || null xs'+                -- Don't generate builds when the [] constructor will do+         || not (gopt Opt_EnableRewriteRules dflags)  -- Rewrite rules off+                -- Don't generate a build if there are no rules to eliminate it!+                -- See Note [Desugaring RULE left hand sides] in Desugar+         then return $ mkListExpr elt_ty xs'+         else mkBuildExpr elt_ty (mk_build_list xs') }+  where+    mk_build_list xs' (cons, _) (nil, _)+      = return (foldr (App . App (Var cons)) (Var nil) xs')++dsExplicitList elt_ty (Just fln) xs+  = do { list <- dsExplicitList elt_ty Nothing xs+       ; dflags <- getDynFlags+       ; dsSyntaxExpr fln [mkIntExprInt dflags (length xs), list] }++dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr+dsArithSeq expr (From from)+  = App <$> dsExpr expr <*> dsLExprNoLP from+dsArithSeq expr (FromTo from to)+  = do dflags <- getDynFlags+       warnAboutEmptyEnumerations dflags from Nothing to+       expr' <- dsExpr expr+       from' <- dsLExprNoLP from+       to'   <- dsLExprNoLP to+       return $ mkApps expr' [from', to']+dsArithSeq expr (FromThen from thn)+  = mkApps <$> dsExpr expr <*> mapM dsLExprNoLP [from, thn]+dsArithSeq expr (FromThenTo from thn to)+  = do dflags <- getDynFlags+       warnAboutEmptyEnumerations dflags from (Just thn) to+       expr' <- dsExpr expr+       from' <- dsLExprNoLP from+       thn'  <- dsLExprNoLP thn+       to'   <- dsLExprNoLP to+       return $ mkApps expr' [from', thn', to']++{-+Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're+handled in DsListComp).  Basically does the translation given in the+Haskell 98 report:+-}++dsDo :: [ExprLStmt GhcTc] -> DsM CoreExpr+dsDo stmts+  = goL stmts+  where+    goL [] = panic "dsDo"+    goL ((dL->L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts)++    go _ (LastStmt _ body _ _) stmts+      = ASSERT( null stmts ) dsLExpr body+        -- The 'return' op isn't used for 'do' expressions++    go _ (BodyStmt _ rhs then_expr _) stmts+      = do { rhs2 <- dsLExpr rhs+           ; warnDiscardedDoBindings rhs (exprType rhs2)+           ; rest <- goL stmts+           ; dsSyntaxExpr then_expr [rhs2, rest] }++    go _ (LetStmt _ binds) stmts+      = do { rest <- goL stmts+           ; dsLocalBinds binds rest }++    go _ (BindStmt res1_ty pat rhs bind_op fail_op) stmts+      = do  { body     <- goL stmts+            ; rhs'     <- dsLExpr rhs+            ; var   <- selectSimpleMatchVarL pat+            ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat+                                      res1_ty (cantFailMatchResult body)+            ; match_code <- handle_failure pat match fail_op+            ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }++    go _ (ApplicativeStmt body_ty args mb_join) stmts+      = do {+             let+               (pats, rhss) = unzip (map (do_arg . snd) args)++               do_arg (ApplicativeArgOne _ pat expr _) =+                 (pat, dsLExpr expr)+               do_arg (ApplicativeArgMany _ stmts ret pat) =+                 (pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))+               do_arg (XApplicativeArg _) = panic "dsDo"++               arg_tys = map hsLPatType pats++           ; rhss' <- sequence rhss++           ; let body' = noLoc $ HsDo body_ty DoExpr (noLoc stmts)++           ; let fun = cL noSrcSpan $ HsLam noExt $+                   MG { mg_alts = noLoc [mkSimpleMatch LambdaExpr pats+                                                       body']+                      , mg_ext = MatchGroupTc arg_tys body_ty+                      , mg_origin = Generated }++           ; fun' <- dsLExpr fun+           ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]+           ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')+           ; case mb_join of+               Nothing -> return expr+               Just join_op -> dsSyntaxExpr join_op [expr] }++    go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids+                    , recS_rec_ids = rec_ids, recS_ret_fn = return_op+                    , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op+                    , recS_ext = RecStmtTc+                        { recS_bind_ty = bind_ty+                        , recS_rec_rets = rec_rets+                        , recS_ret_ty = body_ty} }) stmts+      = goL (new_bind_stmt : stmts)  -- rec_ids can be empty; eg  rec { print 'x' }+      where+        new_bind_stmt = cL loc $ BindStmt bind_ty (mkBigLHsPatTupId later_pats)+                                         mfix_app bind_op+                                         noSyntaxExpr  -- Tuple cannot fail++        tup_ids      = rec_ids ++ filterOut (`elem` rec_ids) later_ids+        tup_ty       = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case+        rec_tup_pats = map nlVarPat tup_ids+        later_pats   = rec_tup_pats+        rets         = map noLoc rec_rets+        mfix_app     = nlHsSyntaxApps mfix_op [mfix_arg]+        mfix_arg     = noLoc $ HsLam noExt+                           (MG { mg_alts = noLoc [mkSimpleMatch+                                                    LambdaExpr+                                                    [mfix_pat] body]+                               , mg_ext = MatchGroupTc [tup_ty] body_ty+                               , mg_origin = Generated })+        mfix_pat     = noLoc $ LazyPat noExt $ 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   {}) _ = panic "dsDo XStmtLR"++handle_failure :: LPat GhcTc -> MatchResult -> SyntaxExpr GhcTc -> DsM CoreExpr+    -- In a do expression, pattern-match failure just calls+    -- the monadic 'fail' rather than throwing an exception+handle_failure pat match fail_op+  | matchCanFail match+  = do { dflags <- getDynFlags+       ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)+       ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]+       ; extractMatchResult match fail_expr }+  | otherwise+  = extractMatchResult match (error "It can't fail")++mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String+mk_fail_msg dflags pat = "Pattern match failure in do expression at " +++                         showPpr dflags (getLoc pat)++{-+************************************************************************+*                                                                      *+   Desugaring Variables+*                                                                      *+************************************************************************+-}++dsHsVar :: Bool  -- are we directly inside an HsWrap?+                 -- See Wrinkle in Note [Detecting forced eta expansion]+        -> Id -> DsM CoreExpr+dsHsVar w var+  | not w+  , let bad_tys = badUseOfLevPolyPrimop var ty+  , not (null bad_tys)+  = do { levPolyPrimopErr var ty bad_tys+       ; return unitExpr }  -- return something eminently safe++  | otherwise+  = return (varToCoreExpr var)   -- See Note [Desugaring vars]++  where+    ty = idType var++dsConLike :: Bool  -- as in dsHsVar+          -> ConLike -> DsM CoreExpr+dsConLike w (RealDataCon dc) = dsHsVar w (dataConWrapId dc)+dsConLike _ (PatSynCon ps)   = return $ case patSynBuilder ps of+  Just (id, add_void)+    | add_void  -> mkCoreApp (text "dsConLike" <+> ppr ps) (Var id) (Var voidPrimId)+    | otherwise -> Var id+  _ -> pprPanic "dsConLike" (ppr ps)++{-+************************************************************************+*                                                                      *+\subsection{Errors and contexts}+*                                                                      *+************************************************************************+-}++-- Warn about certain types of values discarded in monadic bindings (#3263)+warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()+warnDiscardedDoBindings rhs rhs_ty+  | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty+  = do { warn_unused <- woptM Opt_WarnUnusedDoBind+       ; warn_wrong <- woptM Opt_WarnWrongDoBind+       ; when (warn_unused || warn_wrong) $+    do { fam_inst_envs <- dsGetFamInstEnvs+       ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty++           -- Warn about discarding non-() things in 'monadic' binding+       ; if warn_unused && not (isUnitTy norm_elt_ty)+         then warnDs (Reason Opt_WarnUnusedDoBind)+                     (badMonadBind rhs elt_ty)+         else++           -- Warn about discarding m a things in 'monadic' binding of the same type,+           -- but only if we didn't already warn due to Opt_WarnUnusedDoBind+           when warn_wrong $+                do { case tcSplitAppTy_maybe norm_elt_ty of+                         Just (elt_m_ty, _)+                            | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty+                            -> warnDs (Reason Opt_WarnWrongDoBind)+                                      (badMonadBind rhs elt_ty)+                         _ -> return () } } }++  | otherwise   -- RHS does have type of form (m ty), which is weird+  = return ()   -- but at lesat this warning is irrelevant++badMonadBind :: LHsExpr GhcTc -> Type -> SDoc+badMonadBind rhs elt_ty+  = vcat [ hang (text "A do-notation statement discarded a result of type")+              2 (quotes (ppr elt_ty))+         , hang (text "Suppress this warning by saying")+              2 (quotes $ text "_ <-" <+> ppr rhs)+         ]++{-+************************************************************************+*                                                                      *+   Forced eta expansion and levity polymorphism+*                                                                      *+************************************************************************++Note [Detecting forced eta expansion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We cannot have levity polymorphic function arguments. See+Note [Levity polymorphism invariants] in CoreSyn. But we *can* have+functions that take levity polymorphism arguments, as long as these+functions are eta-reduced. (See #12708 for an example.)++However, we absolutely cannot do this for functions that have no+binding (i.e., say True to Id.hasNoBinding), like primops and unboxed+tuple constructors. These get eta-expanded in CorePrep.maybeSaturate.++Detecting when this is about to happen is a bit tricky, though. When+the desugarer is looking at the Id itself (let's be concrete and+suppose we have (#,#)), we don't know whether it will be levity+polymorphic. So the right spot seems to be to look after the Id has+been applied to its type arguments. To make the algorithm efficient,+it's important to be able to spot ((#,#) @a @b @c @d) without looking+past all the type arguments. We thus require that+  * The body of an HsWrap is not an HsWrap.+With that representation invariant, we simply look inside every HsWrap+to see if its body is an HsVar whose Id hasNoBinding. Then, we look+at the wrapped type. If it has any levity polymorphic arguments, reject.++Interestingly, this approach does not look to see whether the Id in+question will be eta expanded. The logic is this:+  * Either the Id in question is saturated or not.+  * If it is, then it surely can't have levity polymorphic arguments.+    If its wrapped type contains levity polymorphic arguments, reject.+  * If it's not, then it can't be eta expanded with levity polymorphic+    argument. If its wrapped type contains levity polymorphic arguments, reject.+So, either way, we're good to reject.++Wrinkle+~~~~~~~+Not all polymorphic Ids are wrapped in+HsWrap, due to the lazy instantiation of TypeApplications. (See "Visible type+application", ESOP '16.) But if we spot a levity-polymorphic hasNoBinding Id+without a wrapper, then that is surely problem and we can reject.++We thus have a parameter to `dsExpr` that tracks whether or not we are+directly in an HsWrap. If we find a levity-polymorphic hasNoBinding Id when+we're not directly in an HsWrap, reject.++-}++-- | Takes an expression and its instantiated type. If the expression is an+-- HsVar with a hasNoBinding primop and the type has levity-polymorphic arguments,+-- issue an error. See Note [Detecting forced eta expansion]+checkForcedEtaExpansion :: HsExpr GhcTc -> Type -> DsM ()+checkForcedEtaExpansion expr ty+  | Just var <- case expr of+                  HsVar _ (dL->L _ var)           -> Just var+                  HsConLikeOut _ (RealDataCon dc) -> Just (dataConWrapId dc)+                  _                               -> Nothing+  , let bad_tys = badUseOfLevPolyPrimop var ty+  , not (null bad_tys)+  = levPolyPrimopErr var ty bad_tys+checkForcedEtaExpansion _ _ = return ()++-- | Is this a hasNoBinding Id with a levity-polymorphic type?+-- Returns the arguments that are levity polymorphic if they are bad;+-- or an empty list otherwise+-- See Note [Detecting forced eta expansion]+badUseOfLevPolyPrimop :: Id -> Type -> [Type]+badUseOfLevPolyPrimop id ty+  | hasNoBinding id+  = filter isTypeLevPoly arg_tys+  | otherwise+  = []+  where+    (binders, _) = splitPiTys ty+    arg_tys      = mapMaybe binderRelevantType_maybe binders++levPolyPrimopErr :: Id -> Type -> [Type] -> DsM ()+levPolyPrimopErr primop ty bad_tys+  = errDs $ vcat [ hang (text "Cannot use primitive 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 view
@@ -0,0 +1,10 @@+module DsExpr where+import HsSyn       ( HsExpr, LHsExpr, LHsLocalBinds, SyntaxExpr )+import DsMonad     ( DsM )+import CoreSyn     ( CoreExpr )+import HsExtension ( GhcTc)++dsExpr  :: HsExpr GhcTc -> DsM CoreExpr+dsLExpr, dsLExprNoLP :: LHsExpr GhcTc -> DsM CoreExpr+dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr+dsLocalBinds :: LHsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
+ compiler/deSugar/DsForeign.hs view
@@ -0,0 +1,819 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1998+++Desugaring foreign declarations (see also DsCCall).+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module DsForeign ( dsForeigns ) where++#include "HsVersions.h"+import GhcPrelude++import TcRnMonad        -- temp++import CoreSyn++import DsCCall+import DsMonad++import HsSyn+import DataCon+import CoreUnfold+import Id+import Literal+import Module+import Name+import Type+import RepType+import TyCon+import Coercion+import TcEnv+import TcType++import CmmExpr+import CmmUtils+import HscTypes+import ForeignCall+import TysWiredIn+import TysPrim+import PrelNames+import BasicTypes+import SrcLoc+import Outputable+import FastString+import DynFlags+import Platform+import OrdList+import Pair+import Util+import Hooks+import Encoding++import Data.Maybe+import Data.List++{-+Desugaring of @foreign@ declarations is naturally split up into+parts, an @import@ and an @export@  part. A @foreign import@+declaration+\begin{verbatim}+  foreign import cc nm f :: prim_args -> IO prim_res+\end{verbatim}+is the same as+\begin{verbatim}+  f :: prim_args -> IO prim_res+  f a1 ... an = _ccall_ nm cc a1 ... an+\end{verbatim}+so we reuse the desugaring code in @DsCCall@ to deal with these.+-}++type Binding = (Id, CoreExpr) -- No rec/nonrec structure;+                              -- the occurrence analyser will sort it all out++dsForeigns :: [LForeignDecl GhcTc]+           -> DsM (ForeignStubs, OrdList Binding)+dsForeigns fos = getHooked dsForeignsHook dsForeigns' >>= ($ fos)++dsForeigns' :: [LForeignDecl GhcTc]+            -> DsM (ForeignStubs, OrdList Binding)+dsForeigns' []+  = return (NoStubs, nilOL)+dsForeigns' fos = do+    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 (dL->L loc decl) = putSrcSpanDs loc (do_decl decl)++   do_decl (ForeignImport { fd_name = id, fd_i_ext = co, fd_fi = spec }) = do+      traceIf (text "fi start" <+> ppr id)+      let id' = unLoc id+      (bs, h, c) <- dsFImport id' co spec+      traceIf (text "fi end" <+> ppr id)+      return (h, c, [], bs)++   do_decl (ForeignExport { fd_name = (dL->L _ id)+                          , fd_e_ext = co+                          , fd_fe = CExport+                              (dL->L _ (CExportStatic _ ext_nm cconv)) _ }) = do+      (h, c, _, _) <- dsFExport id co ext_nm cconv False+      return (h, c, [id], [])+   do_decl (XForeignDecl _) = panic "dsForeigns'"++{-+************************************************************************+*                                                                      *+\subsection{Foreign import}+*                                                                      *+************************************************************************++Desugaring foreign imports is just the matter of creating a binding+that on its RHS unboxes its arguments, performs the external call+(using the @CCallOp@ primop), before boxing the result up and returning it.++However, we create a worker/wrapper pair, thus:++        foreign import f :: Int -> IO Int+==>+        f x = IO ( \s -> case x of { I# x# ->+                         case fw s x# of { (# s1, y# #) ->+                         (# s1, I# y# #)}})++        fw s x# = ccall f s x#++The strictness/CPR analyser won't do this automatically because it doesn't look+inside returned tuples; but inlining this wrapper is a Really Good Idea+because it exposes the boxing to the call site.+-}++dsFImport :: Id+          -> Coercion+          -> ForeignImport+          -> DsM ([Binding], SDoc, SDoc)+dsFImport id co (CImport cconv safety mHeader spec _) =+    dsCImport id co spec (unLoc cconv) (unLoc safety) mHeader++dsCImport :: Id+          -> Coercion+          -> CImportSpec+          -> CCallConv+          -> Safety+          -> Maybe Header+          -> DsM ([Binding], SDoc, SDoc)+dsCImport id co (CLabel cid) cconv _ _ = do+   dflags <- getDynFlags+   let ty  = pFst $ coercionKind co+       fod = case tyConAppTyCon_maybe (dropForAlls ty) of+             Just tycon+              | tyConUnique tycon == funPtrTyConKey ->+                 IsFunction+             _ -> IsData+   (resTy, foRhs) <- resultWrapper ty+   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this+    let+        rhs = foRhs (Lit (LitLabel cid stdcall_info fod))+        rhs' = Cast rhs co+        stdcall_info = fun_type_arg_stdcall_info dflags cconv ty+    in+    return ([(id, rhs')], empty, empty)++dsCImport id co (CFunction target) cconv@PrimCallConv safety _+  = dsPrimCall id co (CCall (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                   = pFst $ coercionKind co+        (tv_bndrs, rho)      = tcSplitForAllVarBndrs ty+        (arg_tys, io_res_ty) = tcSplitFunTys rho++    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism+    (val_args, arg_wrappers) <- mapAndUnzipM unboxArg (map Var args)++    let+        work_arg_ids  = [v | Var v <- val_args] -- All guaranteed to be vars++    (ccall_result_ty, res_wrapper) <- boxResult io_res_ty++    ccall_uniq <- newUnique+    work_uniq  <- newUnique++    dflags <- getDynFlags+    (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                   = pFst $ coercionKind co+        (tvs, fun_ty)        = tcSplitForAllTys ty+        (arg_tys, io_res_ty) = tcSplitFunTys fun_ty++    args <- newSysLocalsDs arg_tys  -- no FFI levity-polymorphism++    ccall_uniq <- newUnique+    dflags <- getDynFlags+    let+        call_app = mkFCall dflags ccall_uniq fcall (map Var args) io_res_ty+        rhs      = mkLams tvs (mkLams args call_app)+        rhs'     = Cast rhs co+    return ([(fn_id, rhs')], empty, empty)++{-+************************************************************************+*                                                                      *+\subsection{Foreign export}+*                                                                      *+************************************************************************++The function that does most of the work for `@foreign export@' declarations.+(see below for the boilerplate code a `@foreign export@' declaration expands+ into.)++For each `@foreign export foo@' in a module M we generate:+\begin{itemize}+\item a C function `@foo@', which calls+\item a Haskell stub `@M.\$ffoo@', which calls+\end{itemize}+the user-written Haskell function `@M.foo@'.+-}++dsFExport :: Id                 -- Either the exported Id,+                                -- or the foreign-export-dynamic constructor+          -> Coercion           -- Coercion between the Haskell type callable+                                -- from C, and its representation type+          -> CLabelString       -- The name to export to C land+          -> CCallConv+          -> Bool               -- True => foreign export dynamic+                                --         so invoke IO action that's hanging off+                                --         the first argument's stable pointer+          -> DsM ( SDoc         -- contents of Module_stub.h+                 , SDoc         -- contents of Module_stub.c+                 , String       -- string describing type to pass to createAdj.+                 , Int          -- size of args to stub function+                 )++dsFExport fn_id co ext_name cconv isDyn = do+    let+       ty                     = pSnd $ coercionKind co+       (bndrs, orig_res_ty)   = tcSplitPiTys ty+       fe_arg_tys'            = mapMaybe binderRelevantType_maybe bndrs+       -- We must use tcSplits here, because we want to see+       -- the (IO t) in the corner of the type!+       fe_arg_tys | isDyn     = tail fe_arg_tys'+                  | otherwise = fe_arg_tys'++       -- Look at the result type of the exported function, orig_res_ty+       -- If it's IO t, return         (t, True)+       -- If it's plain t, return      (t, False)+       (res_ty, is_IO_res_ty) = case tcSplitIOType_maybe orig_res_ty of+                                -- The function already returns IO t+                                Just (_ioTyCon, res_ty) -> (res_ty, True)+                                -- The function returns t+                                Nothing                 -> (orig_res_ty, False)++    dflags <- getDynFlags+    return $+      mkFExportCBits dflags ext_name+                     (if isDyn then Nothing else Just fn_id)+                     fe_arg_tys res_ty is_IO_res_ty cconv++{-+@foreign import "wrapper"@ (previously "foreign export dynamic") lets+you dress up Haskell IO actions of some fixed type behind an+externally callable interface (i.e., as a C function pointer). Useful+for callbacks and stuff.++\begin{verbatim}+type Fun = Bool -> Int -> IO Int+foreign import "wrapper" f :: Fun -> IO (FunPtr Fun)++-- Haskell-visible constructor, which is generated from the above:+-- SUP: No check for NULL from createAdjustor anymore???++f :: Fun -> IO (FunPtr Fun)+f cback =+   bindIO (newStablePtr cback)+          (\StablePtr sp# -> IO (\s1# ->+              case _ccall_ createAdjustor cconv sp# ``f_helper'' <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                       = pFst (coercionKind co0)+  (tvs,sans_foralls)       = tcSplitForAllTys ty+  ([arg_ty], fn_res_ty)    = tcSplitFunTys sans_foralls+  Just (io_tc, res_ty)     = tcSplitIOType_maybe fn_res_ty+        -- Must have an IO type; hence Just+++toCName :: DynFlags -> Id -> String+toCName dflags i = showSDoc dflags (pprCode CStyle (ppr (idName i)))++{-+*++\subsection{Generating @foreign export@ stubs}++*++For each @foreign export@ function, a C stub function is generated.+The C stub constructs the application of the exported Haskell function+using the hugs/ghc rts invocation API.+-}++mkFExportCBits :: DynFlags+               -> FastString+               -> Maybe Id      -- Just==static, Nothing==dynamic+               -> [Type]+               -> Type+               -> Bool          -- True <=> returns an IO type+               -> CCallConv+               -> (SDoc,+                   SDoc,+                   String,      -- the argument reps+                   Int          -- total size of arguments+                  )+mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc+ = (header_bits, c_bits, type_string,+    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args+         -- NB. the calculation here isn't strictly speaking correct.+         -- We have a primitive Haskell type (eg. Int#, Double#), and+         -- we want to know the size, when passed on the C stack, of+         -- the associated C type (eg. HsInt, HsDouble).  We don't have+         -- this information to hand, but we know what GHC's conventions+         -- are for passing around the primitive Haskell types, so we+         -- use that instead.  I hope the two coincide --SDM+    )+ where+  -- list the arguments to the C function+  arg_info :: [(SDoc,           -- arg name+                SDoc,           -- C type+                Type,           -- Haskell type+                CmmType)]       -- the CmmType+  arg_info  = [ let stg_type = showStgType ty in+                (arg_cname n stg_type,+                 stg_type,+                 ty,+                 typeCmmType dflags (getPrimTyOf ty))+              | (ty,n) <- zip arg_htys [1::Int ..] ]++  arg_cname n stg_ty+        | libffi    = char '*' <> parens (stg_ty <> char '*') <>+                      text "args" <> brackets (int (n-1))+        | otherwise = text ('a':show n)++  -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled+  libffi = sLibFFI (settings 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 view
@@ -0,0 +1,150 @@+{-+(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 HsSyn+import MkCore+import CoreSyn+import CoreUtils (bindNonRec)++import Check (genCaseTmCs2)+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 _) _ = panic "dsGRHSs"++dsGRHS :: HsMatchContext Name -> Type -> LGRHS GhcTc (LHsExpr GhcTc)+       -> DsM MatchResult+dsGRHS hs_ctx rhs_ty (dL->L _ (GRHS _ guards rhs))+  = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty+dsGRHS _ _ (dL->L _ (XGRHS _)) = panic "dsGRHS"+dsGRHS _ _ _ = panic "dsGRHS: Impossible Match" -- due to #15884++{-+************************************************************************+*                                                                      *+*  matchGuard : make a MatchResult from a guarded RHS                  *+*                                                                      *+************************************************************************+-}++matchGuards :: [GuardStmt GhcTc]     -- Guard+            -> HsStmtContext Name    -- Context+            -> LHsExpr GhcTc         -- RHS+            -> Type                  -- Type of RHS of guard+            -> DsM MatchResult++-- See comments with HsExpr.Stmt re what a BodyStmt means+-- Here we must be in a guard context (not do-expression, nor list-comp)++matchGuards [] _ rhs _+  = do  { core_rhs <- dsLExpr rhs+        ; return (cantFailMatchResult core_rhs) }++        -- BodyStmts must be guards+        -- Turn an "otherwise" guard is a no-op.  This ensures that+        -- you don't get a "non-exhaustive eqns" message when the guards+        -- finish in "otherwise".+        -- NB:  The success of this clause depends on the typechecker not+        --      wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors+        --      If it does, you'll get bogus overlap warnings+matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty+  | Just addTicks <- isTrueLHsExpr e = do+    match_result <- matchGuards stmts ctx rhs rhs_ty+    return (adjustMatchResultDs addTicks match_result)+matchGuards (BodyStmt _ expr _ _ : stmts) ctx rhs rhs_ty = do+    match_result <- matchGuards stmts ctx rhs rhs_ty+    pred_expr <- dsLExpr expr+    return (mkGuardedMatchResult pred_expr match_result)++matchGuards (LetStmt _ binds : stmts) ctx rhs rhs_ty = do+    match_result <- matchGuards stmts ctx rhs rhs_ty+    return (adjustMatchResultDs (dsLocalBinds binds) match_result)+        -- NB the dsLet occurs inside the match_result+        -- Reason: dsLet takes the body expression as its argument+        --         so we can't desugar the bindings without the+        --         body expression in hand++matchGuards (BindStmt _ pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do+    let upat = unLoc pat+        dicts = collectEvVarsPat upat+    match_var <- selectMatchVar upat+    tm_cs <- genCaseTmCs2 (Just bind_rhs) [upat] [match_var]+    match_result <- addDictsDs dicts $+                    addTmCsDs tm_cs  $+                      -- See Note [Type and Term Equality Propagation] in Check+                    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 {} : _) _ _ _ =+  panic "matchGuards XStmtLR"++{-+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 view
@@ -0,0 +1,693 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Desugaring list comprehensions, monad comprehensions and array comprehensions+-}++{-# LANGUAGE CPP, NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module DsListComp ( dsListComp, dsMonadComp ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLExprNoLP, dsLocalBinds, dsSyntaxExpr )++import HsSyn+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{}) = panic "dsInnerListComp"++-- 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 noExt 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 {} : _) _ =+  panic "deListComp XStmtLR"++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 {} : _) =+  panic "dfListComp XStmtLR"++dfBindComp :: Id -> Id             -- 'c' and 'n'+           -> (LPat GhcTc, CoreExpr)+           -> [ExprStmt GhcTc]     -- the rest of the qual's+           -> DsM CoreExpr+dfBindComp c_id n_id (pat, core_list1) quals = do+    -- find the required type+    let x_ty   = hsLPatType pat+    let b_ty   = idType n_id++    -- create some new local id's+    b <- newSysLocalDs b_ty+    x <- newSysLocalDs x_ty++    -- build rest of the comprehesion+    core_rest <- dfListComp c_id b quals++    -- build the pattern match+    core_expr <- matchSimply (Var x) (StmtCtxt ListComp)+                pat core_rest (Var b)++    -- now build the outermost foldr, and return+    mkFoldrExpr x_ty b_ty (mkLams [x, b] core_expr) (Var n_id) core_list1++{-+************************************************************************+*                                                                      *+\subsection[DsFunGeneration]{Generation of zip/unzip functions for use in desugaring}+*                                                                      *+************************************************************************+-}++mkZipBind :: [Type] -> DsM (Id, CoreExpr)+-- mkZipBind [t1, t2]+-- = (zip, \as1:[t1] as2:[t2]+--         -> case as1 of+--              [] -> []+--              (a1:as'1) -> case as2 of+--                              [] -> []+--                              (a2:as'2) -> (a1, a2) : zip as'1 as'2)]++mkZipBind elt_tys = do+    ass  <- mapM newSysLocalDs  elt_list_tys+    as'  <- mapM newSysLocalDs  elt_tys+    as's <- mapM newSysLocalDs  elt_list_tys++    zip_fn <- newSysLocalDs zip_fn_ty++    let inner_rhs = mkConsExpr elt_tuple_ty+                        (mkBigCoreVarTup as')+                        (mkVarApps (Var zip_fn) as's)+        zip_body  = foldr mk_case inner_rhs (zip3 ass as' as's)++    return (zip_fn, mkLams ass zip_body)+  where+    elt_list_tys      = map mkListTy elt_tys+    elt_tuple_ty      = mkBigCoreTupTy elt_tys+    elt_tuple_list_ty = mkListTy elt_tuple_ty++    zip_fn_ty         = mkVisFunTys elt_list_tys elt_tuple_list_ty++    mk_case (as, a', as') rest+          = Case (Var as) as elt_tuple_list_ty+                  [(DataAlt nilDataCon,  [],        mkNilExpr elt_tuple_ty),+                   (DataAlt consDataCon, [a', as'], rest)]+                        -- Increasing order of tag+++mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr))+-- mkUnzipBind [t1, t2]+-- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2])+--     -> case ax of+--      (x1, x2) -> case axs of+--                (xs1, xs2) -> (x1 : xs1, x2 : xs2))+--      ([], [])+--      ys)+--+-- We use foldr here in all cases, even if rules are turned off, because we may as well!+mkUnzipBind ThenForm _+ = return Nothing    -- No unzipping for ThenForm+mkUnzipBind _ elt_tys+  = do { ax  <- newSysLocalDs elt_tuple_ty+       ; axs <- newSysLocalDs elt_list_tuple_ty+       ; ys  <- newSysLocalDs elt_tuple_list_ty+       ; xs  <- mapM newSysLocalDs elt_tys+       ; xss <- mapM newSysLocalDs elt_list_tys++       ; unzip_fn <- newSysLocalDs unzip_fn_ty++       ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]++       ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys)+             concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss))+             tupled_concat_expression = mkBigCoreTup concat_expressions++             folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs)+             folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax)+             folder_body = mkLams [ax, axs] folder_body_outer_case++       ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys)+       ; return (Just (unzip_fn, mkLams [ys] unzip_body)) }+  where+    elt_tuple_ty       = mkBigCoreTupTy elt_tys+    elt_tuple_list_ty  = mkListTy elt_tuple_ty+    elt_list_tys       = map mkListTy elt_tys+    elt_list_tuple_ty  = mkBigCoreTupTy elt_list_tys++    unzip_fn_ty        = elt_tuple_list_ty `mkVisFunTy` elt_list_tuple_ty++    mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail++-- Translation for monad comprehensions++-- Entry point for monad comprehension desugaring+dsMonadComp :: [ExprLStmt GhcTc] -> DsM CoreExpr+dsMonadComp stmts = dsMcStmts stmts++dsMcStmts :: [ExprLStmt GhcTc] -> DsM CoreExpr+dsMcStmts []                          = panic "dsMcStmts"+dsMcStmts ((dL->L loc stmt) : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts)++---------------+dsMcStmt :: ExprStmt GhcTc -> [ExprLStmt GhcTc] -> DsM CoreExpr++dsMcStmt (LastStmt _ body _ ret_op) stmts+  = ASSERT( null stmts )+    do { body' <- dsLExpr body+       ; dsSyntaxExpr ret_op [body'] }++--   [ .. | let binds, stmts ]+dsMcStmt (LetStmt _ binds) stmts+  = do { rest <- dsMcStmts stmts+       ; dsLocalBinds binds rest }++--   [ .. | a <- m, stmts ]+dsMcStmt (BindStmt bind_ty pat rhs bind_op fail_op) stmts+  = do { rhs' <- dsLExpr rhs+       ; dsMcBindStmt pat rhs' bind_op fail_op bind_ty stmts }++-- Apply `guard` to the `exp` expression+--+--   [ .. | exp, stmts ]+--+dsMcStmt (BodyStmt _ exp then_exp guard_exp) stmts+  = do { exp'       <- dsLExpr exp+       ; rest       <- dsMcStmts stmts+       ; guard_exp' <- dsSyntaxExpr guard_exp [exp']+       ; dsSyntaxExpr then_exp [guard_exp', rest] }++-- Group statements desugar like this:+--+--   [| (q, then group by e using f); rest |]+--   --->  f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup ->+--         case unzip n_tup of qv' -> [| rest |]+--+-- where   variables (v1:t1, ..., vk:tk) are bound by q+--         qv = (v1, ..., vk)+--         qt = (t1, ..., tk)+--         (>>=) :: m2 a -> (a -> m3 b) -> m3 b+--         f :: forall a. (a -> t) -> m1 a -> m2 (n a)+--         n_tup :: n qt+--         unzip :: n qt -> (n t1, ..., n tk)    (needs Functor n)++dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs+                    , trS_by = by, trS_using = using+                    , trS_ret = return_op, trS_bind = bind_op+                    , trS_ext = n_tup_ty'  -- n (a,b,c)+                    , trS_fmap = fmap_op, trS_form = form }) stmts_rest+  = do { let (from_bndrs, to_bndrs) = unzip bndrs++       ; let from_bndr_tys = map idType from_bndrs     -- Types ty+++       -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders+       ; expr' <- dsInnerMonadComp stmts from_bndrs return_op++       -- Work out what arguments should be supplied to that expression: i.e. is an extraction+       -- function required? If so, create that desugared function and add to arguments+       ; usingExpr' <- dsLExpr using+       ; usingArgs' <- case by of+                         Nothing   -> return [expr']+                         Just by_e -> do { by_e' <- dsLExpr by_e+                                         ; lam' <- matchTuple from_bndrs by_e'+                                         ; return [lam', expr'] }++       -- Generate the expressions to build the grouped list+       -- Build a pattern that ensures the consumer binds into the NEW binders,+       -- which hold monads rather than single values+       ; let tup_n_ty' = mkBigCoreVarTupTy to_bndrs++       ; body        <- dsMcStmts stmts_rest+       ; n_tup_var'  <- newSysLocalDsNoLP n_tup_ty'+       ; tup_n_var'  <- newSysLocalDs tup_n_ty'+       ; tup_n_expr' <- mkMcUnzipM form fmap_op n_tup_var' from_bndr_tys+       ; us          <- newUniqueSupply+       ; let rhs'  = mkApps usingExpr' usingArgs'+             body' = mkTupleCase us to_bndrs body tup_n_var' tup_n_expr'++       ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] }++-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel+-- statements, for example:+--+--   [ body | qs1 | qs2 | qs3 ]+--     ->  [ body | (bndrs1, (bndrs2, bndrs3))+--                     <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ]+--+-- where `mzip` has type+--   mzip :: forall a b. m a -> m b -> m (a,b)+-- NB: we need a polymorphic mzip because we call it several times++dsMcStmt (ParStmt bind_ty blocks mzip_op bind_op) stmts_rest+ = do  { exps_w_tys  <- mapM ds_inner blocks   -- Pairs (exp :: m ty, ty)+       ; mzip_op'    <- dsExpr mzip_op++       ; let -- The pattern variables+             pats = [ mkBigLHsVarPatTupId bs | ParStmtBlock _ _ bs _ <- blocks]+             -- Pattern with tuples of variables+             -- [v1,v2,v3]  =>  (v1, (v2, v3))+             pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats+             (rhs, _) = foldr1 (\(e1,t1) (e2,t2) ->+                                 (mkApps mzip_op' [Type t1, Type t2, e1, e2],+                                  mkBoxedTupleTy [t1,t2]))+                               exps_w_tys++       ; dsMcBindStmt pat rhs bind_op noSyntaxExpr bind_ty stmts_rest }+  where+    ds_inner (ParStmtBlock _ stmts bndrs return_op)+       = do { exp <- dsInnerMonadComp stmts bndrs return_op+            ; return (exp, mkBigCoreVarTupTy bndrs) }+    ds_inner (XParStmtBlock{}) = panic "dsMcStmt"++dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)+++matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr+-- (matchTuple [a,b,c] body)+--       returns the Core term+--  \x. case x of (a,b,c) -> body+matchTuple ids body+  = do { us <- newUniqueSupply+       ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids)+       ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }++-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a+-- desugared `CoreExpr`+dsMcBindStmt :: LPat GhcTc+             -> CoreExpr        -- ^ the desugared rhs of the bind statement+             -> SyntaxExpr GhcTc+             -> SyntaxExpr GhcTc+             -> Type            -- ^ S in (>>=) :: Q -> (R -> S) -> T+             -> [ExprLStmt GhcTc]+             -> DsM CoreExpr+dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts+  = do  { body     <- dsMcStmts stmts+        ; var      <- selectSimpleMatchVarL pat+        ; match <- matchSinglePatVar var (StmtCtxt DoExpr) pat+                                  res1_ty (cantFailMatchResult body)+        ; match_code <- handle_failure pat match fail_op+        ; dsSyntaxExpr bind_op [rhs', Lam var match_code] }++  where+    -- In a monad comprehension expression, pattern-match failure just calls+    -- the monadic `fail` rather than throwing an exception+    handle_failure pat match fail_op+      | matchCanFail match+        = do { dflags <- getDynFlags+             ; fail_msg <- mkStringExpr (mk_fail_msg dflags pat)+             ; fail_expr <- dsSyntaxExpr fail_op [fail_msg]+             ; extractMatchResult match fail_expr }+      | otherwise+        = extractMatchResult match (error "It can't fail")++    mk_fail_msg :: HasSrcSpan e => DynFlags -> e -> String+    mk_fail_msg dflags pat+        = "Pattern match failure in monad comprehension at " +++          showPpr dflags (getLoc pat)++-- Desugar nested monad comprehensions, for example in `then..` constructs+--    dsInnerMonadComp quals [a,b,c] ret_op+-- returns the desugaring of+--       [ (a,b,c) | quals ]++dsInnerMonadComp :: [ExprLStmt GhcTc]+                 -> [Id]               -- Return a tuple of these variables+                 -> SyntaxExpr GhcTc   -- The monomorphic "return" operator+                 -> DsM CoreExpr+dsInnerMonadComp stmts bndrs ret_op+  = dsMcStmts (stmts +++                 [noLoc (LastStmt noExt (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 view
@@ -0,0 +1,2738 @@+{-# LANGUAGE CPP, TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}++-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 2006+--+-- The purpose of this module is to transform an HsExpr into a CoreExpr which+-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the+-- input HsExpr. We do this in the DsM monad, which supplies access to+-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype.+--+-- It also defines a bunch of knownKeyNames, in the same way as is done+-- in prelude/PrelNames.  It's much more convenient to do it here, because+-- otherwise we have to recompile PrelNames whenever we add a Name, which is+-- a Royal Pain (triggers other recompilation).+-----------------------------------------------------------------------------++module DsMeta( dsBracket ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-}   DsExpr ( dsExpr )++import MatchLit+import DsMonad++import qualified Language.Haskell.TH as TH++import HsSyn+import PrelNames+-- To avoid clashes with DsMeta.varName we must make a local alias for+-- OccName.varName we do this by removing varName from the import of+-- OccName above, making a qualified instance of OccName and using+-- OccNameAlias.varName where varName ws previously used in this file.+import qualified OccName( isDataOcc, isVarOcc, isTcOcc )++import Module+import Id+import Name hiding( isVarOcc, isTcOcc, varName, tcName )+import THNames+import NameEnv+import TcType+import TyCon+import TysWiredIn+import CoreSyn+import MkCore+import CoreUtils+import SrcLoc+import Unique+import BasicTypes+import Outputable+import Bag+import DynFlags+import FastString+import ForeignCall+import Util+import Maybes+import MonadUtils++import Data.ByteString ( unpack )+import Control.Monad+import Data.List++-----------------------------------------------------------------------------+dsBracket :: HsBracket GhcRn -> [PendingTcSplice] -> DsM CoreExpr+-- Returns a CoreExpr of type TH.ExpQ+-- The quoted thing is parameterised over Name, even though it has+-- been type checked.  We don't want all those type decorations!++dsBracket brack splices+  = dsExtendMetaEnv new_bit (do_brack brack)+  where+    new_bit = mkNameEnv [(n, DsSplice (unLoc e))+                        | PendingTcSplice n e <- splices]++    do_brack (VarBr _ _ n) = do { MkC e1  <- lookupOcc n ; return e1 }+    do_brack (ExpBr _ e)   = do { MkC e1  <- repLE e     ; return e1 }+    do_brack (PatBr _ p)   = do { MkC p1  <- repTopP p   ; return p1 }+    do_brack (TypBr _ t)   = do { MkC t1  <- repLTy t    ; return t1 }+    do_brack (DecBrG _ gp) = do { MkC ds1 <- repTopDs gp ; return ds1 }+    do_brack (DecBrL {})   = panic "dsBracket: unexpected DecBrL"+    do_brack (TExpBr _ e)  = do { MkC e1  <- repLE e     ; return e1 }+    do_brack (XBracket {}) = panic "dsBracket: unexpected XBracket"++{- -------------- Examples --------------------++  [| \x -> x |]+====>+  gensym (unpackString "x"#) `bindQ` \ x1::String ->+  lam (pvar x1) (var x1)+++  [| \x -> $(f [| x |]) |]+====>+  gensym (unpackString "x"#) `bindQ` \ x1::String ->+  lam (pvar x1) (f (var x1))+-}+++-------------------------------------------------------+--                      Declarations+-------------------------------------------------------++repTopP :: LPat GhcRn -> DsM (Core TH.PatQ)+repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)+                 ; pat' <- addBinds ss (repLP pat)+                 ; wrapGenSyms ss pat' }++repTopDs :: HsGroup GhcRn -> DsM (Core (TH.Q [TH.Dec]))+repTopDs group@(HsGroup { hs_valds   = valds+                        , hs_splcds  = splcds+                        , hs_tyclds  = tyclds+                        , hs_derivds = derivds+                        , hs_fixds   = fixds+                        , hs_defds   = defds+                        , hs_fords   = fords+                        , hs_warnds  = warnds+                        , hs_annds   = annds+                        , hs_ruleds  = ruleds+                        , hs_docs    = docs })+ = do { let { bndrs  = hsScopedTvBinders valds+                       ++ hsGroupBinders group+                       ++ hsPatSynSelectors valds+            ; instds = tyclds >>= group_instds } ;+        ss <- mkGenSyms bndrs ;++        -- Bind all the names mainly to avoid repeated use of explicit strings.+        -- Thus we get+        --      do { t :: String <- genSym "T" ;+        --           return (Data t [] ...more t's... }+        -- The other important reason is that the output must mention+        -- only "T", not "Foo:T" where Foo is the current module++        decls <- addBinds ss (+                  do { val_ds   <- rep_val_binds valds+                     ; _        <- mapM no_splice splcds+                     ; tycl_ds  <- mapM repTyClD (tyClGroupTyClDecls tyclds)+                     ; role_ds  <- mapM repRoleD (concatMap group_roles tyclds)+                     ; inst_ds  <- mapM repInstD instds+                     ; deriv_ds <- mapM repStandaloneDerivD derivds+                     ; fix_ds   <- mapM repFixD fixds+                     ; _        <- mapM no_default_decl defds+                     ; for_ds   <- mapM repForD fords+                     ; _        <- mapM no_warn (concatMap (wd_warnings . unLoc)+                                                           warnds)+                     ; ann_ds   <- mapM repAnnD annds+                     ; rule_ds  <- mapM repRuleD (concatMap (rds_rules . unLoc)+                                                            ruleds)+                     ; _        <- mapM no_doc docs++                        -- more needed+                     ;  return (de_loc $ sort_by_loc $+                                val_ds ++ catMaybes tycl_ds ++ role_ds+                                       ++ (concat fix_ds)+                                       ++ inst_ds ++ rule_ds ++ for_ds+                                       ++ ann_ds ++ deriv_ds) }) ;++        decl_ty <- lookupType decQTyConName ;+        let { core_list = coreList' decl_ty decls } ;++        dec_ty <- lookupType decTyConName ;+        q_decs  <- repSequenceQ dec_ty core_list ;++        wrapGenSyms ss q_decs+      }+  where+    no_splice (dL->L loc _)+      = notHandledL loc "Splices within declaration brackets" empty+    no_default_decl (dL->L loc decl)+      = notHandledL loc "Default declarations" (ppr decl)+    no_warn (dL->L loc (Warning _ thing _))+      = notHandledL loc "WARNING and DEPRECATION pragmas" $+                    text "Pragma for declaration of" <+> ppr thing+    no_warn _ = panic "repTopDs"+    no_doc (dL->L loc _)+      = notHandledL loc "Haddock documentation" empty+repTopDs (XHsGroup _) = panic "repTopDs"++hsScopedTvBinders :: HsValBinds GhcRn -> [Name]+-- See Note [Scoped type variables in bindings]+hsScopedTvBinders binds+  = concatMap get_scoped_tvs sigs+  where+    sigs = case binds of+             ValBinds           _ _ sigs  -> sigs+             XValBindsLR (NValBinds _ sigs) -> sigs++get_scoped_tvs :: LSig GhcRn -> [Name]+get_scoped_tvs (dL->L _ signature)+  | TypeSig _ _ sig <- signature+  = get_scoped_tvs_from_sig (hswc_body sig)+  | ClassOpSig _ _ _ sig <- signature+  = get_scoped_tvs_from_sig sig+  | PatSynSig _ _ sig <- signature+  = get_scoped_tvs_from_sig sig+  | otherwise+  = []+  where+    get_scoped_tvs_from_sig sig+      -- Both implicit and explicit quantified variables+      -- We need the implicit ones for   f :: forall (a::k). blah+      --    here 'k' scopes too+      | HsIB { hsib_ext = implicit_vars+             , hsib_body = hs_ty } <- sig+      , (explicit_vars, _) <- splitLHsForAllTy hs_ty+      = implicit_vars ++ hsLTyVarNames explicit_vars+    get_scoped_tvs_from_sig (XHsImplicitBndrs _)+      = panic "get_scoped_tvs_from_sig"++{- Notes++Note [Scoped type variables in bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f :: forall a. a -> a+   f x = x::a+Here the 'forall a' brings 'a' into scope over the binding group.+To achieve this we++  a) Gensym a binding for 'a' at the same time as we do one for 'f'+     collecting the relevant binders with hsScopedTvBinders++  b) When processing the 'forall', don't gensym++The relevant places are signposted with references to this Note++Note [Scoped type variables in class and instance declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Scoped type variables may occur in default methods and default+signatures. We need to bring the type variables in 'foralls'+into the scope of the method bindings.++Consider+   class Foo a where+     foo :: forall (b :: k). a -> Proxy b -> Proxy b+     foo _ x = (x :: Proxy b)++We want to ensure that the 'b' in the type signature and the default+implementation are the same, so we do the following:++  a) Before desugaring the signature and binding of 'foo', use+     get_scoped_tvs to collect type variables in 'forall' and+     create symbols for them.+  b) Use 'addBinds' to bring these symbols into the scope of the type+     signatures and bindings.+  c) Use these symbols to generate Core for the class/instance declaration.++Note that when desugaring the signatures, we lookup the type variables+from the scope rather than recreate symbols for them. See more details+in "rep_ty_sig" and in Trac#14885.++Note [Binders and occurrences]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we desugar [d| data T = MkT |]+we want to get+        Data "T" [] [Con "MkT" []] []+and *not*+        Data "Foo:T" [] [Con "Foo:MkT" []] []+That is, the new data decl should fit into whatever new module it is+asked to fit in.   We do *not* clone, though; no need for this:+        Data "T79" ....++But if we see this:+        data T = MkT+        foo = reifyDecl T++then we must desugar to+        foo = Data "Foo:T" [] [Con "Foo:MkT" []] []++So in repTopDs we bring the binders into scope with mkGenSyms and addBinds.+And we use lookupOcc, rather than lookupBinder+in repTyClD and repC.++Note [Don't quantify implicit type variables in quotes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If you're not careful, it's suprisingly easy to take this quoted declaration:++  [d| idProxy :: forall proxy (b :: k). proxy b -> proxy b+      idProxy x = x+    |]++and have Template Haskell turn it into this:++  idProxy :: forall k proxy (b :: k). proxy b -> proxy b+  idProxy x = x++Notice that we explicitly quantified the variable `k`! The latter declaration+isn't what the user wrote in the first place.++Usually, the culprit behind these bugs is taking implicitly quantified type+variables (often from the hsib_vars field of HsImplicitBinders) and putting+them into a `ForallT` or `ForallC`. Doing so caused #13018 and #13123.+-}++-- represent associated family instances+--+repTyClD :: LTyClDecl GhcRn -> DsM (Maybe (SrcSpan, Core TH.DecQ))++repTyClD (dL->L loc (FamDecl { tcdFam = fam })) = liftM Just $+                                                  repFamilyDecl (L loc fam)++repTyClD (dL->L loc (SynDecl { tcdLName = tc, tcdTyVars = tvs, tcdRhs = rhs }))+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->+                repSynDecl tc1 bndrs rhs+       ; return (Just (loc, dec)) }++repTyClD (dL->L loc (DataDecl { tcdLName = tc+                              , tcdTyVars = tvs+                              , tcdDataDefn = defn }))+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->+                repDataDefn tc1 (Left bndrs) defn+       ; return (Just (loc, dec)) }++repTyClD (dL->L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls,+                             tcdTyVars = tvs, tcdFDs = fds,+                             tcdSigs = sigs, tcdMeths = meth_binds,+                             tcdATs = ats, tcdATDefs = atds }))+  = do { cls1 <- lookupLOcc cls         -- See note [Binders and occurrences]+       ; dec  <- addTyVarBinds tvs $ \bndrs ->+           do { cxt1   <- repLContext cxt+          -- See Note [Scoped type variables in class and instance declarations]+              ; (ss, sigs_binds) <- rep_sigs_binds sigs meth_binds+              ; fds1   <- repLFunDeps fds+              ; ats1   <- repFamilyDecls ats+              ; atds1  <- mapM (repAssocTyFamDefaultD . unLoc) atds+              ; decls1 <- coreList decQTyConName (ats1 ++ atds1 ++ sigs_binds)+              ; decls2 <- repClass cxt1 cls1 bndrs fds1 decls1+              ; wrapGenSyms ss decls2 }+       ; return $ Just (loc, dec)+       }++repTyClD _ = panic "repTyClD"++-------------------------+repRoleD :: LRoleAnnotDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)+repRoleD (dL->L loc (RoleAnnotDecl _ tycon roles))+  = do { tycon1 <- lookupLOcc tycon+       ; roles1 <- mapM repRole roles+       ; roles2 <- coreList roleTyConName roles1+       ; dec <- repRoleAnnotD tycon1 roles2+       ; return (loc, dec) }+repRoleD _ = panic "repRoleD"++-------------------------+repDataDefn :: Core TH.Name+            -> Either (Core [TH.TyVarBndrQ])+                        -- the repTyClD case+                      (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)+                        -- the repDataFamInstD case+            -> HsDataDefn GhcRn+            -> DsM (Core TH.DecQ)+repDataDefn tc opts+          (HsDataDefn { dd_ND = new_or_data, dd_ctxt = cxt, dd_kindSig = ksig+                      , dd_cons = cons, dd_derivs = mb_derivs })+  = do { cxt1     <- repLContext cxt+       ; derivs1  <- repDerivs mb_derivs+       ; case (new_or_data, cons) of+           (NewType, [con])  -> do { con'  <- repC con+                                   ; ksig' <- repMaybeLTy ksig+                                   ; repNewtype cxt1 tc opts ksig' con'+                                                derivs1 }+           (NewType, _) -> failWithDs (text "Multiple constructors for newtype:"+                                       <+> pprQuotedList+                                       (getConNames $ unLoc $ head cons))+           (DataType, _) -> do { ksig' <- repMaybeLTy ksig+                               ; consL <- mapM repC cons+                               ; cons1 <- coreList conQTyConName consL+                               ; repData cxt1 tc opts ksig' cons1+                                         derivs1 }+       }+repDataDefn _ _ (XHsDataDefn _) = panic "repDataDefn"++repSynDecl :: Core TH.Name -> Core [TH.TyVarBndrQ]+           -> LHsType GhcRn+           -> DsM (Core TH.DecQ)+repSynDecl tc bndrs ty+  = do { ty1 <- repLTy ty+       ; repTySyn tc bndrs ty1 }++repFamilyDecl :: LFamilyDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)+repFamilyDecl decl@(dL->L loc (FamilyDecl { fdInfo      = info+                                          , fdLName     = tc+                                          , fdTyVars    = tvs+                                          , fdResultSig = dL->L _ resultSig+                                          , fdInjectivityAnn = injectivity }))+  = do { tc1 <- lookupLOcc tc           -- See note [Binders and occurrences]+       ; let mkHsQTvs :: [LHsTyVarBndr GhcRn] -> LHsQTyVars GhcRn+             mkHsQTvs tvs = HsQTvs { hsq_ext = []+                                   , hsq_explicit = tvs }+             resTyVar = case resultSig of+                     TyVarSig _ bndr -> mkHsQTvs [bndr]+                     _               -> mkHsQTvs []+       ; dec <- addTyClTyVarBinds tvs $ \bndrs ->+                addTyClTyVarBinds resTyVar $ \_ ->+           case info of+             ClosedTypeFamily Nothing ->+                 notHandled "abstract closed type family" (ppr decl)+             ClosedTypeFamily (Just eqns) ->+               do { eqns1  <- mapM (repTyFamEqn . unLoc) eqns+                  ; eqns2  <- coreList tySynEqnQTyConName eqns1+                  ; result <- repFamilyResultSig resultSig+                  ; inj    <- repInjectivityAnn injectivity+                  ; repClosedFamilyD tc1 bndrs result inj eqns2 }+             OpenTypeFamily ->+               do { result <- repFamilyResultSig resultSig+                  ; inj    <- repInjectivityAnn injectivity+                  ; repOpenFamilyD tc1 bndrs result inj }+             DataFamily ->+               do { kind <- repFamilyResultSigToMaybeKind resultSig+                  ; repDataFamilyD tc1 bndrs kind }+       ; return (loc, dec)+       }+repFamilyDecl _ = panic "repFamilyDecl"++-- | Represent result signature of a type family+repFamilyResultSig :: FamilyResultSig GhcRn -> DsM (Core TH.FamilyResultSigQ)+repFamilyResultSig (NoSig _)         = repNoSig+repFamilyResultSig (KindSig _ ki)    = do { ki' <- repLTy ki+                                          ; repKindSig ki' }+repFamilyResultSig (TyVarSig _ bndr) = do { bndr' <- repTyVarBndr bndr+                                          ; repTyVarSig bndr' }+repFamilyResultSig (XFamilyResultSig _) = panic "repFamilyResultSig"++-- | Represent result signature using a Maybe Kind. Used with data families,+-- where the result signature can be either missing or a kind but never a named+-- result variable.+repFamilyResultSigToMaybeKind :: FamilyResultSig GhcRn+                              -> DsM (Core (Maybe TH.KindQ))+repFamilyResultSigToMaybeKind (NoSig _) =+    do { coreNothing kindQTyConName }+repFamilyResultSigToMaybeKind (KindSig _ ki) =+    do { ki' <- repLTy ki+       ; coreJust kindQTyConName ki' }+repFamilyResultSigToMaybeKind _ = panic "repFamilyResultSigToMaybeKind"++-- | Represent injectivity annotation of a type family+repInjectivityAnn :: Maybe (LInjectivityAnn GhcRn)+                  -> DsM (Core (Maybe TH.InjectivityAnn))+repInjectivityAnn Nothing =+    do { coreNothing injAnnTyConName }+repInjectivityAnn (Just (dL->L _ (InjectivityAnn lhs rhs))) =+    do { lhs'   <- lookupBinder (unLoc lhs)+       ; rhs1   <- mapM (lookupBinder . unLoc) rhs+       ; rhs2   <- coreList nameTyConName rhs1+       ; injAnn <- rep2 injectivityAnnName [unC lhs', unC rhs2]+       ; coreJust injAnnTyConName injAnn }++repFamilyDecls :: [LFamilyDecl GhcRn] -> DsM [Core TH.DecQ]+repFamilyDecls fds = liftM de_loc (mapM repFamilyDecl fds)++repAssocTyFamDefaultD :: TyFamDefltDecl GhcRn -> DsM (Core TH.DecQ)+repAssocTyFamDefaultD = repTyFamInstD++-------------------------+-- represent fundeps+--+repLFunDeps :: [LHsFunDep GhcRn] -> DsM (Core [TH.FunDep])+repLFunDeps fds = repList funDepTyConName repLFunDep fds++repLFunDep :: LHsFunDep GhcRn -> DsM (Core TH.FunDep)+repLFunDep (dL->L _ (xs, ys))+   = do xs' <- repList nameTyConName (lookupBinder . unLoc) xs+        ys' <- repList nameTyConName (lookupBinder . unLoc) ys+        repFunDep xs' ys'++-- Represent instance declarations+--+repInstD :: LInstDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)+repInstD (dL->L loc (TyFamInstD { tfid_inst = fi_decl }))+  = do { dec <- repTyFamInstD fi_decl+       ; return (loc, dec) }+repInstD (dL->L loc (DataFamInstD { dfid_inst = fi_decl }))+  = do { dec <- repDataFamInstD fi_decl+       ; return (loc, dec) }+repInstD (dL->L loc (ClsInstD { cid_inst = cls_decl }))+  = do { dec <- repClsInstD cls_decl+       ; return (loc, dec) }+repInstD _ = panic "repInstD"++repClsInstD :: ClsInstDecl GhcRn -> DsM (Core TH.DecQ)+repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds+                         , cid_sigs = sigs, cid_tyfam_insts = ats+                         , cid_datafam_insts = adts+                         , cid_overlap_mode = overlap+                         })+  = addSimpleTyVarBinds tvs $+            -- We must bring the type variables into scope, so their+            -- occurrences don't fail, even though the binders don't+            -- appear in the resulting data structure+            --+            -- But we do NOT bring the binders of 'binds' into scope+            -- because they are properly regarded as occurrences+            -- For example, the method names should be bound to+            -- the selector Ids, not to fresh names (#5410)+            --+            do { cxt1     <- repLContext cxt+               ; inst_ty1 <- repLTy inst_ty+          -- See Note [Scoped type variables in class and instance declarations]+               ; (ss, sigs_binds) <- rep_sigs_binds sigs binds+               ; ats1   <- mapM (repTyFamInstD . unLoc) ats+               ; adts1  <- mapM (repDataFamInstD . unLoc) adts+               ; decls1 <- coreList decQTyConName (ats1 ++ adts1 ++ sigs_binds)+               ; rOver  <- repOverlap (fmap unLoc overlap)+               ; decls2 <- repInst rOver cxt1 inst_ty1 decls1+               ; wrapGenSyms ss decls2 }+ where+   (tvs, cxt, inst_ty) = splitLHsInstDeclTy ty+repClsInstD (XClsInstDecl _) = panic "repClsInstD"++repStandaloneDerivD :: LDerivDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)+repStandaloneDerivD (dL->L loc (DerivDecl { deriv_strategy = strat+                                          , deriv_type     = ty }))+  = do { dec <- addSimpleTyVarBinds tvs $+                do { cxt'     <- repLContext cxt+                   ; strat'   <- repDerivStrategy strat+                   ; inst_ty' <- repLTy inst_ty+                   ; repDeriv strat' cxt' inst_ty' }+       ; return (loc, dec) }+  where+    (tvs, cxt, inst_ty) = splitLHsInstDeclTy (dropWildCards ty)+repStandaloneDerivD _ = panic "repStandaloneDerivD"++repTyFamInstD :: TyFamInstDecl GhcRn -> DsM (Core TH.DecQ)+repTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })+  = do { eqn1 <- repTyFamEqn eqn+       ; repTySynInst eqn1 }++repTyFamEqn :: TyFamInstEqn GhcRn -> DsM (Core TH.TySynEqnQ)+repTyFamEqn (HsIB { hsib_ext = var_names+                  , hsib_body = FamEqn { feqn_tycon = tc_name+                                       , feqn_bndrs = mb_bndrs+                                       , feqn_pats = tys+                                       , feqn_fixity = fixity+                                       , feqn_rhs  = rhs }})+  = do { tc <- lookupLOcc tc_name     -- See note [Binders and occurrences]+       ; let hs_tvs = HsQTvs { hsq_ext = var_names+                             , hsq_explicit = fromMaybe [] mb_bndrs }+       ; addTyClTyVarBinds hs_tvs $ \ _ ->+         do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName+                                        repTyVarBndr+                                        mb_bndrs+            ; tys1 <- case fixity of+                        Prefix -> repTyArgs (repNamedTyCon tc) tys+                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys+                                     ; t1' <- repLTy t1+                                     ; t2'  <- repLTy t2+                                     ; repTyArgs (repTInfix t1' tc t2') args }+            ; rhs1 <- repLTy rhs+            ; repTySynEqn mb_bndrs1 tys1 rhs1 } }+     where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]+           checkTys tys@(HsValArg _:HsValArg _:_) = return tys+           checkTys _ = panic "repTyFamEqn:checkTys"+repTyFamEqn (XHsImplicitBndrs _) = panic "repTyFamEqn"+repTyFamEqn (HsIB _ (XFamEqn _)) = panic "repTyFamEqn"++repTyArgs :: DsM (Core TH.TypeQ) -> [LHsTypeArg GhcRn] -> DsM (Core TH.TypeQ)+repTyArgs f [] = f+repTyArgs f (HsValArg ty : as) = do { f' <- f+                                    ; ty' <- repLTy ty+                                    ; repTyArgs (repTapp f' ty') as }+repTyArgs f (HsTypeArg _ ki : as) = do { f' <- f+                                       ; ki' <- repLTy ki+                                       ; repTyArgs (repTappKind f' ki') as }+repTyArgs f (HsArgPar _ : as) = repTyArgs f as++repDataFamInstD :: DataFamInstDecl GhcRn -> DsM (Core TH.DecQ)+repDataFamInstD (DataFamInstDecl { dfid_eqn =+                  (HsIB { hsib_ext = var_names+                        , hsib_body = FamEqn { feqn_tycon = tc_name+                                             , feqn_bndrs = mb_bndrs+                                             , feqn_pats  = tys+                                             , feqn_fixity = fixity+                                             , feqn_rhs   = defn }})})+  = do { tc <- lookupLOcc tc_name         -- See note [Binders and occurrences]+       ; let hs_tvs = HsQTvs { hsq_ext = var_names+                             , hsq_explicit = fromMaybe [] mb_bndrs }+       ; addTyClTyVarBinds hs_tvs $ \ _ ->+         do { mb_bndrs1 <- repMaybeList tyVarBndrQTyConName+                                        repTyVarBndr+                                        mb_bndrs+            ; tys1 <- case fixity of+                        Prefix -> repTyArgs (repNamedTyCon tc) tys+                        Infix  -> do { (HsValArg t1: HsValArg t2: args) <- checkTys tys+                                     ; t1' <- repLTy t1+                                     ; t2'  <- repLTy t2+                                     ; repTyArgs (repTInfix t1' tc t2') args }+            ; repDataDefn tc (Right (mb_bndrs1, tys1)) defn } }++      where checkTys :: [LHsTypeArg GhcRn] -> DsM [LHsTypeArg GhcRn]+            checkTys tys@(HsValArg _: HsValArg _: _) = return tys+            checkTys _ = panic "repDataFamInstD:checkTys"++repDataFamInstD (DataFamInstDecl (XHsImplicitBndrs _))+  = panic "repDataFamInstD"+repDataFamInstD (DataFamInstDecl (HsIB _ (XFamEqn _)))+  = panic "repDataFamInstD"++repForD :: Located (ForeignDecl GhcRn) -> DsM (SrcSpan, Core TH.DecQ)+repForD (dL->L loc (ForeignImport { fd_name = name, fd_sig_ty = typ+                                  , fd_fi = CImport (dL->L _ cc)+                                                    (dL->L _ s) mch cis _ }))+ = do MkC name' <- lookupLOcc name+      MkC typ' <- repHsSigType typ+      MkC cc' <- repCCallConv cc+      MkC s' <- repSafety s+      cis' <- conv_cimportspec cis+      MkC str <- coreStringLit (static ++ chStr ++ cis')+      dec <- rep2 forImpDName [cc', s', str, name', typ']+      return (loc, dec)+ where+    conv_cimportspec (CLabel cls)+      = notHandled "Foreign label" (doubleQuotes (ppr cls))+    conv_cimportspec (CFunction DynamicTarget) = return "dynamic"+    conv_cimportspec (CFunction (StaticTarget _ fs _ True))+                            = return (unpackFS fs)+    conv_cimportspec (CFunction (StaticTarget _ _  _ False))+                            = panic "conv_cimportspec: values not supported yet"+    conv_cimportspec CWrapper = return "wrapper"+    -- these calling conventions do not support headers and the static keyword+    raw_cconv = cc == PrimCallConv || cc == JavaScriptCallConv+    static = case cis of+                 CFunction (StaticTarget _ _ _ _) | not raw_cconv -> "static "+                 _ -> ""+    chStr = case mch of+            Just (Header _ h) | not raw_cconv -> unpackFS h ++ " "+            _ -> ""+repForD decl = notHandled "Foreign declaration" (ppr decl)++repCCallConv :: CCallConv -> DsM (Core TH.Callconv)+repCCallConv CCallConv          = rep2 cCallName []+repCCallConv StdCallConv        = rep2 stdCallName []+repCCallConv CApiConv           = rep2 cApiCallName []+repCCallConv PrimCallConv       = rep2 primCallName []+repCCallConv JavaScriptCallConv = rep2 javaScriptCallName []++repSafety :: Safety -> DsM (Core TH.Safety)+repSafety PlayRisky = rep2 unsafeName []+repSafety PlayInterruptible = rep2 interruptibleName []+repSafety PlaySafe = rep2 safeName []++repFixD :: LFixitySig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]+repFixD (dL->L loc (FixitySig _ names (Fixity _ prec dir)))+  = do { MkC prec' <- coreIntLit prec+       ; let rep_fn = case dir of+                        InfixL -> infixLDName+                        InfixR -> infixRDName+                        InfixN -> infixNDName+       ; let do_one name+              = do { MkC name' <- lookupLOcc name+                   ; dec <- rep2 rep_fn [prec', name']+                   ; return (loc,dec) }+       ; mapM do_one names }+repFixD _ = panic "repFixD"++repRuleD :: LRuleDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)+repRuleD (dL->L loc (HsRule { rd_name = n+                            , rd_act = act+                            , rd_tyvs = ty_bndrs+                            , rd_tmvs = tm_bndrs+                            , rd_lhs = lhs+                            , rd_rhs = rhs }))+  = do { rule <- addHsTyVarBinds (fromMaybe [] ty_bndrs) $ \ ex_bndrs ->+         do { let tm_bndr_names = concatMap ruleBndrNames tm_bndrs+            ; ss <- mkGenSyms tm_bndr_names+            ; rule <- addBinds ss $+                      do { ty_bndrs' <- case ty_bndrs of+                             Nothing -> coreNothingList tyVarBndrQTyConName+                             Just _  -> coreJustList tyVarBndrQTyConName+                                          ex_bndrs+                         ; tm_bndrs' <- repList ruleBndrQTyConName+                                                repRuleBndr+                                                tm_bndrs+                         ; n'   <- coreStringLit $ unpackFS $ snd $ unLoc n+                         ; act' <- repPhases act+                         ; lhs' <- repLE lhs+                         ; rhs' <- repLE rhs+                         ; repPragRule n' ty_bndrs' tm_bndrs' lhs' rhs' act' }+           ; wrapGenSyms ss rule  }+       ; return (loc, rule) }+repRuleD _ = panic "repRuleD"++ruleBndrNames :: LRuleBndr GhcRn -> [Name]+ruleBndrNames (dL->L _ (RuleBndr _ n))      = [unLoc n]+ruleBndrNames (dL->L _ (RuleBndrSig _ n sig))+  | HsWC { hswc_body = HsIB { hsib_ext = vars }} <- sig+  = unLoc n : vars+ruleBndrNames (dL->L _ (RuleBndrSig _ _ (HsWC _ (XHsImplicitBndrs _))))+  = panic "ruleBndrNames"+ruleBndrNames (dL->L _ (RuleBndrSig _ _ (XHsWildCardBndrs _)))+  = panic "ruleBndrNames"+ruleBndrNames (dL->L _ (XRuleBndr _)) = panic "ruleBndrNames"+ruleBndrNames _ = panic "ruleBndrNames: Impossible Match" -- due to #15884++repRuleBndr :: LRuleBndr GhcRn -> DsM (Core TH.RuleBndrQ)+repRuleBndr (dL->L _ (RuleBndr _ n))+  = do { MkC n' <- lookupLBinder n+       ; rep2 ruleVarName [n'] }+repRuleBndr (dL->L _ (RuleBndrSig _ n sig))+  = do { MkC n'  <- lookupLBinder n+       ; MkC ty' <- repLTy (hsSigWcType sig)+       ; rep2 typedRuleVarName [n', ty'] }+repRuleBndr _ = panic "repRuleBndr"++repAnnD :: LAnnDecl GhcRn -> DsM (SrcSpan, Core TH.DecQ)+repAnnD (dL->L loc (HsAnnotation _ _ ann_prov (dL->L _ exp)))+  = do { target <- repAnnProv ann_prov+       ; exp'   <- repE exp+       ; dec    <- repPragAnn target exp'+       ; return (loc, dec) }+repAnnD _ = panic "repAnnD"++repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget)+repAnnProv (ValueAnnProvenance (dL->L _ n))+  = do { MkC n' <- globalVar n  -- ANNs are allowed only at top-level+       ; rep2 valueAnnotationName [ n' ] }+repAnnProv (TypeAnnProvenance (dL->L _ n))+  = do { MkC n' <- globalVar n+       ; rep2 typeAnnotationName [ n' ] }+repAnnProv ModuleAnnProvenance+  = rep2 moduleAnnotationName []++-------------------------------------------------------+--                      Constructors+-------------------------------------------------------++repC :: LConDecl GhcRn -> DsM (Core TH.ConQ)+repC (dL->L _ (ConDeclH98 { con_name   = con+                          , con_forall = (dL->L _ False)+                          , con_mb_cxt = Nothing+                          , con_args   = args }))+  = repDataCon con args++repC (dL->L _ (ConDeclH98 { con_name = con+                          , con_forall = (dL->L _ is_existential)+                          , con_ex_tvs = con_tvs+                          , con_mb_cxt = mcxt+                          , con_args = args }))+  = do { addHsTyVarBinds con_tvs $ \ ex_bndrs ->+         do { c'    <- repDataCon con args+            ; ctxt' <- repMbContext mcxt+            ; if not is_existential && isNothing mcxt+              then return c'+              else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c'])+            }+       }++repC (dL->L _ (ConDeclGADT { con_names  = cons+                           , con_qvars  = qtvs+                           , con_mb_cxt = mcxt+                           , con_args   = args+                           , con_res_ty = res_ty }))+  | isEmptyLHsQTvs qtvs  -- No implicit or explicit variables+  , Nothing <- mcxt      -- No context+                         -- ==> no need for a forall+  = repGadtDataCons cons args res_ty++  | otherwise+  = addTyVarBinds qtvs $ \ ex_bndrs ->+             -- See Note [Don't quantify implicit type variables in quotes]+    do { c'    <- repGadtDataCons cons args res_ty+       ; ctxt' <- repMbContext mcxt+       ; if null (hsQTvExplicit qtvs) && isNothing mcxt+         then return c'+         else rep2 forallCName ([unC ex_bndrs, unC ctxt', unC c']) }++repC _ = panic "repC"+++repMbContext :: Maybe (LHsContext GhcRn) -> DsM (Core TH.CxtQ)+repMbContext Nothing          = repContext []+repMbContext (Just (dL->L _ cxt)) = repContext cxt++repSrcUnpackedness :: SrcUnpackedness -> DsM (Core TH.SourceUnpackednessQ)+repSrcUnpackedness SrcUnpack   = rep2 sourceUnpackName         []+repSrcUnpackedness SrcNoUnpack = rep2 sourceNoUnpackName       []+repSrcUnpackedness NoSrcUnpack = rep2 noSourceUnpackednessName []++repSrcStrictness :: SrcStrictness -> DsM (Core TH.SourceStrictnessQ)+repSrcStrictness SrcLazy     = rep2 sourceLazyName         []+repSrcStrictness SrcStrict   = rep2 sourceStrictName       []+repSrcStrictness NoSrcStrict = rep2 noSourceStrictnessName []++repBangTy :: LBangType GhcRn -> DsM (Core (TH.BangTypeQ))+repBangTy ty = do+  MkC u <- repSrcUnpackedness su'+  MkC s <- repSrcStrictness ss'+  MkC b <- rep2 bangName [u, s]+  MkC t <- repLTy ty'+  rep2 bangTypeName [b, t]+  where+    (su', ss', ty') = case unLoc ty of+            HsBangTy _ (HsSrcBang _ su ss) ty -> (su, ss, ty)+            _ -> (NoSrcUnpack, NoSrcStrict, ty)++-------------------------------------------------------+--                      Deriving clauses+-------------------------------------------------------++repDerivs :: HsDeriving GhcRn -> DsM (Core [TH.DerivClauseQ])+repDerivs (dL->L _ clauses)+  = repList derivClauseQTyConName repDerivClause clauses++repDerivClause :: LHsDerivingClause GhcRn+               -> DsM (Core TH.DerivClauseQ)+repDerivClause (dL->L _ (HsDerivingClause+                          { deriv_clause_strategy = dcs+                          , deriv_clause_tys      = (dL->L _ dct) }))+  = do MkC dcs' <- repDerivStrategy dcs+       MkC dct' <- repList typeQTyConName (rep_deriv_ty . hsSigType) dct+       rep2 derivClauseName [dcs',dct']+  where+    rep_deriv_ty :: LHsType GhcRn -> DsM (Core TH.TypeQ)+    rep_deriv_ty ty = repLTy ty+repDerivClause _ = panic "repDerivClause"++rep_sigs_binds :: [LSig GhcRn] -> LHsBinds GhcRn+               -> DsM ([GenSymBind], [Core TH.DecQ])+-- Represent signatures and methods in class/instance declarations.+-- See Note [Scoped type variables in class and instance declarations]+--+-- Why not use 'repBinds': we have already created symbols for methods in+-- 'repTopDs' via 'hsGroupBinders'. However in 'repBinds', we recreate+-- these fun_id via 'collectHsValBinders decs', which would lead to the+-- instance declarations failing in TH.+rep_sigs_binds sigs binds+  = do { let tvs = concatMap get_scoped_tvs sigs+       ; ss <- mkGenSyms tvs+       ; sigs1 <- addBinds ss $ rep_sigs sigs+       ; binds1 <- addBinds ss $ rep_binds binds+       ; return (ss, de_loc (sort_by_loc (sigs1 ++ binds1))) }++-------------------------------------------------------+--   Signatures in a class decl, or a group of bindings+-------------------------------------------------------++rep_sigs :: [LSig GhcRn] -> DsM [(SrcSpan, Core TH.DecQ)]+        -- We silently ignore ones we don't recognise+rep_sigs = concatMapM rep_sig++rep_sig :: LSig GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]+rep_sig (dL->L loc (TypeSig _ nms ty))+  = mapM (rep_wc_ty_sig sigDName loc ty) nms+rep_sig (dL->L loc (PatSynSig _ nms ty))+  = mapM (rep_patsyn_ty_sig loc ty) nms+rep_sig (dL->L loc (ClassOpSig _ is_deflt nms ty))+  | is_deflt     = mapM (rep_ty_sig defaultSigDName loc ty) nms+  | otherwise    = mapM (rep_ty_sig sigDName loc ty) nms+rep_sig d@(dL->L _ (IdSig {}))           = pprPanic "rep_sig IdSig" (ppr d)+rep_sig (dL->L _   (FixSig {}))          = return [] -- fixity sigs at top level+rep_sig (dL->L loc (InlineSig _ nm ispec))= rep_inline nm ispec loc+rep_sig (dL->L loc (SpecSig _ nm tys ispec))+  = concatMapM (\t -> rep_specialise nm t ispec loc) tys+rep_sig (dL->L loc (SpecInstSig _ _ ty))  = rep_specialiseInst ty loc+rep_sig (dL->L _   (MinimalSig {}))       = notHandled "MINIMAL pragmas" empty+rep_sig (dL->L _   (SCCFunSig {}))        = notHandled "SCC pragmas" empty+rep_sig (dL->L loc (CompleteMatchSig _ _st cls mty))+  = rep_complete_sig cls mty loc+rep_sig _ = panic "rep_sig"++rep_ty_sig :: Name -> SrcSpan -> LHsSigType GhcRn -> Located Name+           -> DsM (SrcSpan, Core TH.DecQ)+-- Don't create the implicit and explicit variables when desugaring signatures,+-- see Note [Scoped type variables in class and instance declarations].+-- and Note [Don't quantify implicit type variables in quotes]+rep_ty_sig mk_sig loc sig_ty nm+  | HsIB { hsib_body = hs_ty } <- sig_ty+  , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty+  = do { nm1 <- lookupLOcc nm+       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)+                                     ; repTyVarBndrWithKind tv name }+       ; th_explicit_tvs <- repList tyVarBndrQTyConName rep_in_scope_tv+                                    explicit_tvs++         -- NB: Don't pass any implicit type variables to repList above+         -- See Note [Don't quantify implicit type variables in quotes]++       ; th_ctxt <- repLContext ctxt+       ; th_ty   <- repLTy ty+       ; ty1     <- if null explicit_tvs && null (unLoc ctxt)+                       then return th_ty+                       else repTForall th_explicit_tvs th_ctxt th_ty+       ; sig     <- repProto mk_sig nm1 ty1+       ; return (loc, sig) }+rep_ty_sig _ _ (XHsImplicitBndrs _) _ = panic "rep_ty_sig"++rep_patsyn_ty_sig :: SrcSpan -> LHsSigType GhcRn -> Located Name+                  -> DsM (SrcSpan, Core TH.DecQ)+-- represents a pattern synonym type signature;+-- see Note [Pattern synonym type signatures and Template Haskell] in Convert+--+-- Don't create the implicit and explicit variables when desugaring signatures,+-- see Note [Scoped type variables in class and instance declarations]+-- and Note [Don't quantify implicit type variables in quotes]+rep_patsyn_ty_sig loc sig_ty nm+  | HsIB { hsib_body = hs_ty } <- sig_ty+  , (univs, reqs, exis, provs, ty) <- splitLHsPatSynTy hs_ty+  = do { nm1 <- lookupLOcc nm+       ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv)+                                     ; repTyVarBndrWithKind tv name }+       ; th_univs <- repList tyVarBndrQTyConName rep_in_scope_tv univs+       ; th_exis  <- repList tyVarBndrQTyConName rep_in_scope_tv exis++         -- NB: Don't pass any implicit type variables to repList above+         -- See Note [Don't quantify implicit type variables in quotes]++       ; th_reqs  <- repLContext reqs+       ; th_provs <- repLContext provs+       ; th_ty    <- repLTy ty+       ; ty1      <- repTForall th_univs th_reqs =<<+                       repTForall th_exis th_provs th_ty+       ; sig      <- repProto patSynSigDName nm1 ty1+       ; return (loc, sig) }+rep_patsyn_ty_sig _ (XHsImplicitBndrs _) _ = panic "rep_patsyn_ty_sig"++rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType GhcRn -> Located Name+              -> DsM (SrcSpan, Core TH.DecQ)+rep_wc_ty_sig mk_sig loc sig_ty nm+  = rep_ty_sig mk_sig loc (hswc_body sig_ty) nm++rep_inline :: Located Name+           -> InlinePragma      -- Never defaultInlinePragma+           -> SrcSpan+           -> DsM [(SrcSpan, Core TH.DecQ)]+rep_inline nm ispec loc+  = do { nm1    <- lookupLOcc nm+       ; inline <- repInline $ inl_inline ispec+       ; rm     <- repRuleMatch $ inl_rule ispec+       ; phases <- repPhases $ inl_act ispec+       ; pragma <- repPragInl nm1 inline rm phases+       ; return [(loc, pragma)]+       }++rep_specialise :: Located Name -> LHsSigType GhcRn -> InlinePragma+               -> SrcSpan+               -> DsM [(SrcSpan, Core TH.DecQ)]+rep_specialise nm ty ispec loc+  = do { nm1 <- lookupLOcc nm+       ; ty1 <- repHsSigType ty+       ; phases <- repPhases $ inl_act ispec+       ; let inline = inl_inline ispec+       ; pragma <- if noUserInlineSpec inline+                   then -- SPECIALISE+                     repPragSpec nm1 ty1 phases+                   else -- SPECIALISE INLINE+                     do { inline1 <- repInline inline+                        ; repPragSpecInl nm1 ty1 inline1 phases }+       ; return [(loc, pragma)]+       }++rep_specialiseInst :: LHsSigType GhcRn -> SrcSpan+                   -> DsM [(SrcSpan, Core TH.DecQ)]+rep_specialiseInst ty loc+  = do { ty1    <- repHsSigType ty+       ; pragma <- repPragSpecInst ty1+       ; return [(loc, pragma)] }++repInline :: InlineSpec -> DsM (Core TH.Inline)+repInline NoInline  = dataCon noInlineDataConName+repInline Inline    = dataCon inlineDataConName+repInline Inlinable = dataCon inlinableDataConName+repInline spec      = notHandled "repInline" (ppr spec)++repRuleMatch :: RuleMatchInfo -> DsM (Core TH.RuleMatch)+repRuleMatch ConLike = dataCon conLikeDataConName+repRuleMatch FunLike = dataCon funLikeDataConName++repPhases :: Activation -> DsM (Core TH.Phases)+repPhases (ActiveBefore _ i) = do { MkC arg <- coreIntLit i+                                  ; dataCon' beforePhaseDataConName [arg] }+repPhases (ActiveAfter _ i)  = do { MkC arg <- coreIntLit i+                                  ; dataCon' fromPhaseDataConName [arg] }+repPhases _                  = dataCon allPhasesDataConName++rep_complete_sig :: Located [Located Name]+                 -> Maybe (Located Name)+                 -> SrcSpan+                 -> DsM [(SrcSpan, Core TH.DecQ)]+rep_complete_sig (dL->L _ cls) mty loc+  = do { mty' <- repMaybe nameTyConName lookupLOcc mty+       ; cls' <- repList nameTyConName lookupLOcc cls+       ; sig <- repPragComplete cls' mty'+       ; return [(loc, sig)] }++-------------------------------------------------------+--                      Types+-------------------------------------------------------++addSimpleTyVarBinds :: [Name]                -- the binders to be added+                    -> DsM (Core (TH.Q a))   -- action in the ext env+                    -> DsM (Core (TH.Q a))+addSimpleTyVarBinds names thing_inside+  = do { fresh_names <- mkGenSyms names+       ; term <- addBinds fresh_names thing_inside+       ; wrapGenSyms fresh_names term }++addHsTyVarBinds :: [LHsTyVarBndr GhcRn]  -- the binders to be added+                -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env+                -> DsM (Core (TH.Q a))+addHsTyVarBinds exp_tvs thing_inside+  = do { fresh_exp_names <- mkGenSyms (hsLTyVarNames exp_tvs)+       ; term <- addBinds fresh_exp_names $+                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr+                                     (exp_tvs `zip` fresh_exp_names)+                    ; thing_inside kbs }+       ; wrapGenSyms fresh_exp_names term }+  where+    mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v)++addTyVarBinds :: LHsQTyVars GhcRn                    -- the binders to be added+              -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))  -- action in the ext env+              -> DsM (Core (TH.Q a))+-- gensym a list of type variables and enter them into the meta environment;+-- the computations passed as the second argument is executed in that extended+-- meta environment and gets the *new* names on Core-level as an argument+addTyVarBinds (HsQTvs { hsq_ext = imp_tvs+                      , hsq_explicit = exp_tvs })+              thing_inside+  = addSimpleTyVarBinds imp_tvs $+    addHsTyVarBinds exp_tvs $+    thing_inside+addTyVarBinds (XLHsQTyVars _) _ = panic "addTyVarBinds"++addTyClTyVarBinds :: LHsQTyVars GhcRn+                  -> (Core [TH.TyVarBndrQ] -> DsM (Core (TH.Q a)))+                  -> DsM (Core (TH.Q a))++-- Used for data/newtype declarations, and family instances,+-- so that the nested type variables work right+--    instance C (T a) where+--      type W (T a) = blah+-- The 'a' in the type instance is the one bound by the instance decl+addTyClTyVarBinds tvs m+  = do { let tv_names = hsAllLTyVarNames tvs+       ; env <- dsGetMetaEnv+       ; freshNames <- mkGenSyms (filterOut (`elemNameEnv` env) tv_names)+            -- Make fresh names for the ones that are not already in scope+            -- This makes things work for family declarations++       ; term <- addBinds freshNames $+                 do { kbs <- repList tyVarBndrQTyConName mk_tv_bndr+                                     (hsQTvExplicit tvs)+                    ; m kbs }++       ; wrapGenSyms freshNames term }+  where+    mk_tv_bndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)+    mk_tv_bndr tv = do { v <- lookupBinder (hsLTyVarName tv)+                       ; repTyVarBndrWithKind tv v }++-- Produce kinded binder constructors from the Haskell tyvar binders+--+repTyVarBndrWithKind :: LHsTyVarBndr GhcRn+                     -> Core TH.Name -> DsM (Core TH.TyVarBndrQ)+repTyVarBndrWithKind (dL->L _ (UserTyVar _ _)) nm+  = repPlainTV nm+repTyVarBndrWithKind (dL->L _ (KindedTyVar _ _ ki)) nm+  = repLTy ki >>= repKindedTV nm+repTyVarBndrWithKind _ _ = panic "repTyVarBndrWithKind"++-- | Represent a type variable binder+repTyVarBndr :: LHsTyVarBndr GhcRn -> DsM (Core TH.TyVarBndrQ)+repTyVarBndr (dL->L _ (UserTyVar _ (dL->L _ nm)) )+  = do { nm' <- lookupBinder nm+       ; repPlainTV nm' }+repTyVarBndr (dL->L _ (KindedTyVar _ (dL->L _ nm) ki))+  = do { nm' <- lookupBinder nm+       ; ki' <- repLTy ki+       ; repKindedTV nm' ki' }+repTyVarBndr _ = panic "repTyVarBndr"++-- represent a type context+--+repLContext :: LHsContext GhcRn -> DsM (Core TH.CxtQ)+repLContext ctxt = repContext (unLoc ctxt)++repContext :: HsContext GhcRn -> DsM (Core TH.CxtQ)+repContext ctxt = do preds <- repList typeQTyConName repLTy ctxt+                     repCtxt preds++repHsSigType :: LHsSigType GhcRn -> DsM (Core TH.TypeQ)+repHsSigType (HsIB { hsib_ext = implicit_tvs+                   , hsib_body = body })+  | (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy 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 _) = panic "repHsSigType"++repHsSigWcType :: LHsSigWcType GhcRn -> DsM (Core TH.TypeQ)+repHsSigWcType (HsWC { hswc_body = sig1 })+  = repHsSigType sig1+repHsSigWcType (XHsWildCardBndrs _) = panic "repHsSigWcType"++-- yield the representation of a list of types+repLTys :: [LHsType GhcRn] -> DsM [Core TH.TypeQ]+repLTys tys = mapM repLTy tys++-- represent a type+repLTy :: LHsType GhcRn -> DsM (Core TH.TypeQ)+repLTy ty = repTy (unLoc ty)++repForall :: ForallVisFlag -> HsType GhcRn -> DsM (Core TH.TypeQ)+-- Arg of repForall is always HsForAllTy or HsQualTy+repForall fvf ty+ | (tvs, ctxt, tau) <- splitLHsSigmaTy (noLoc ty)+ = addHsTyVarBinds tvs $ \bndrs ->+   do { ctxt1  <- repLContext ctxt+      ; ty1    <- repLTy tau+      ; case fvf of+          ForallVis   -> repTForallVis bndrs ty1    -- forall a      -> {...}+          ForallInvis -> repTForall bndrs ctxt1 ty1 -- forall a. C a => {...}+      }++repTy :: HsType GhcRn -> DsM (Core TH.TypeQ)+repTy ty@(HsForAllTy {hst_fvf = fvf}) = repForall fvf         ty+repTy ty@(HsQualTy {})                = repForall ForallInvis ty++repTy (HsTyVar _ _ (dL->L _ n))+  | isLiftedTypeKindTyConName n       = repTStar+  | n `hasKey` constraintKindTyConKey = repTConstraint+  | n `hasKey` funTyConKey            = repArrowTyCon+  | isTvOcc occ   = do tv1 <- lookupOcc n+                       repTvar tv1+  | isDataOcc occ = do tc1 <- lookupOcc n+                       repPromotedDataCon tc1+  | n == eqTyConName = repTequality+  | otherwise     = do tc1 <- lookupOcc n+                       repNamedTyCon tc1+  where+    occ = nameOccName n++repTy (HsAppTy _ f a)       = do+                                f1 <- repLTy f+                                a1 <- repLTy a+                                repTapp f1 a1+repTy (HsAppKindTy _ ty ki) = do+                                ty1 <- repLTy ty+                                ki1 <- repLTy ki+                                repTappKind ty1 ki1+repTy (HsFunTy _ f a)       = do+                                f1   <- repLTy f+                                a1   <- repLTy a+                                tcon <- repArrowTyCon+                                repTapps tcon [f1, a1]+repTy (HsListTy _ t)        = do+                                t1   <- repLTy t+                                tcon <- repListTyCon+                                repTapp tcon t1+repTy (HsTupleTy _ HsUnboxedTuple tys) = do+                                tys1 <- repLTys tys+                                tcon <- repUnboxedTupleTyCon (length tys)+                                repTapps tcon tys1+repTy (HsTupleTy _ _ tys)   = do tys1 <- repLTys tys+                                 tcon <- repTupleTyCon (length tys)+                                 repTapps tcon tys1+repTy (HsSumTy _ tys)       = do tys1 <- repLTys tys+                                 tcon <- repUnboxedSumTyCon (length tys)+                                 repTapps tcon tys1+repTy (HsOpTy _ ty1 n ty2)  = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)+                                   `nlHsAppTy` ty2)+repTy (HsParTy _ t)         = repLTy t+repTy (HsStarTy _ _) =  repTStar+repTy (HsKindSig _ t k)     = do+                                t1 <- repLTy t+                                k1 <- repLTy k+                                repTSig t1 k1+repTy (HsSpliceTy _ splice)      = repSplice splice+repTy (HsExplicitListTy _ _ tys) = do+                                    tys1 <- repLTys tys+                                    repTPromotedList tys1+repTy (HsExplicitTupleTy _ tys) = do+                                    tys1 <- repLTys tys+                                    tcon <- repPromotedTupleTyCon (length tys)+                                    repTapps tcon tys1+repTy (HsTyLit _ lit) = do+                          lit' <- repTyLit lit+                          repTLit lit'+repTy (HsWildCardTy _) = repTWildCard+repTy (HsIParamTy _ n t) = do+                             n' <- rep_implicit_param_name (unLoc n)+                             t' <- repLTy t+                             repTImplicitParam n' t'++repTy ty                      = notHandled "Exotic form of type" (ppr ty)++repTyLit :: HsTyLit -> DsM (Core TH.TyLitQ)+repTyLit (HsNumTy _ i) = do iExpr <- mkIntegerExpr i+                            rep2 numTyLitName [iExpr]+repTyLit (HsStrTy _ s) = do { s' <- mkStringExprFS s+                            ; rep2 strTyLitName [s']+                            }++-- | Represent a type wrapped in a Maybe+repMaybeLTy :: Maybe (LHsKind GhcRn)+            -> DsM (Core (Maybe TH.TypeQ))+repMaybeLTy = repMaybe kindQTyConName repLTy++repRole :: Located (Maybe Role) -> DsM (Core TH.Role)+repRole (dL->L _ (Just Nominal))          = rep2 nominalRName []+repRole (dL->L _ (Just Representational)) = rep2 representationalRName []+repRole (dL->L _ (Just Phantom))          = rep2 phantomRName []+repRole (dL->L _ Nothing)                 = rep2 inferRName []+repRole _ = panic "repRole: Impossible Match" -- due to #15884++-----------------------------------------------------------------------------+--              Splices+-----------------------------------------------------------------------------++repSplice :: HsSplice GhcRn -> DsM (Core a)+-- See Note [How brackets and nested splices are handled] in TcSplice+-- We return a CoreExpr of any old type; the context should know+repSplice (HsTypedSplice   _ _ n _) = rep_splice n+repSplice (HsUntypedSplice _ _ n _) = rep_splice n+repSplice (HsQuasiQuote _ n _ _ _)  = rep_splice n+repSplice e@(HsSpliced {})          = pprPanic "repSplice" (ppr e)+repSplice e@(HsSplicedT {})         = pprPanic "repSpliceT" (ppr e)+repSplice e@(XSplice {})            = pprPanic "repSplice" (ppr e)++rep_splice :: Name -> DsM (Core a)+rep_splice splice_name+ = do { mb_val <- dsLookupMetaEnv splice_name+       ; case mb_val of+           Just (DsSplice e) -> do { e' <- dsExpr e+                                   ; return (MkC e') }+           _ -> pprPanic "HsSplice" (ppr splice_name) }+                        -- Should not happen; statically checked++-----------------------------------------------------------------------------+--              Expressions+-----------------------------------------------------------------------------++repLEs :: [LHsExpr GhcRn] -> DsM (Core [TH.ExpQ])+repLEs es = repList expQTyConName repLE es++-- FIXME: some of these panics should be converted into proper error messages+--        unless we can make sure that constructs, which are plainly not+--        supported in TH already lead to error messages at an earlier stage+repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ)+repLE (dL->L loc e) = putSrcSpanDs loc (repE e)++repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)+repE (HsVar _ (dL->L _ x)) =+  do { mb_val <- dsLookupMetaEnv x+     ; case mb_val of+        Nothing            -> do { str <- globalVar x+                                 ; repVarOrCon x str }+        Just (DsBound y)   -> repVarOrCon x (coreVar y)+        Just (DsSplice e)  -> do { e' <- dsExpr e+                                 ; return (MkC e') } }+repE (HsIPVar _ n) = rep_implicit_param_name n >>= repImplicitParamVar+repE (HsOverLabel _ _ s) = repOverLabel s++repE e@(HsRecFld _ f) = case f of+  Unambiguous x _ -> repE (HsVar noExt (noLoc x))+  Ambiguous{}     -> notHandled "Ambiguous record selectors" (ppr e)+  XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e)++        -- Remember, we're desugaring renamer output here, so+        -- HsOverlit can definitely occur+repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }+repE (HsLit _ l)     = do { a <- repLiteral l;           repLit a }+repE (HsLam _ (MG { mg_alts = (dL->L _ [m]) })) = repLambda m+repE (HsLamCase _ (MG { mg_alts = (dL->L _ ms) }))+                   = do { ms' <- mapM repMatchTup ms+                        ; core_ms <- coreList matchQTyConName ms'+                        ; repLamCase core_ms }+repE (HsApp _ x y)   = do {a <- repLE x; b <- repLE y; repApp a b}+repE (HsAppType _ e t) = do { a <- repLE e+                            ; s <- repLTy (hswc_body t)+                            ; repAppType a s }++repE (OpApp _ e1 op e2) =+  do { arg1 <- repLE e1;+       arg2 <- repLE e2;+       the_op <- repLE op ;+       repInfixApp arg1 the_op arg2 }+repE (NegApp _ x _)      = do+                              a         <- repLE x+                              negateVar <- lookupOcc negateName >>= repVar+                              negateVar `repApp` a+repE (HsPar _ x)            = repLE x+repE (SectionL _ x y)       = do { a <- repLE x; b <- repLE y; repSectionL a b }+repE (SectionR _ x y)       = do { a <- repLE x; b <- repLE y; repSectionR a b }+repE (HsCase _ e (MG { mg_alts = (dL->L _ ms) }))+                          = do { arg <- repLE e+                               ; ms2 <- mapM repMatchTup ms+                               ; core_ms2 <- coreList matchQTyConName ms2+                               ; repCaseE arg core_ms2 }+repE (HsIf _ _ x y z)       = do+                              a <- repLE x+                              b <- repLE y+                              c <- repLE z+                              repCond a b c+repE (HsMultiIf _ alts)+  = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts+       ; expr' <- repMultiIf (nonEmptyCoreList alts')+       ; wrapGenSyms (concat binds) expr' }+repE (HsLet _ (dL->L _ bs) e)       = do { (ss,ds) <- repBinds bs+                                     ; e2 <- addBinds ss (repLE e)+                                     ; z <- repLetE ds e2+                                     ; wrapGenSyms ss z }++-- FIXME: I haven't got the types here right yet+repE e@(HsDo _ ctxt (dL->L _ sts))+ | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }+ = do { (ss,zs) <- repLSts sts;+        e'      <- repDoE (nonEmptyCoreList zs);+        wrapGenSyms ss e' }++ | ListComp <- ctxt+ = do { (ss,zs) <- repLSts sts;+        e'      <- repComp (nonEmptyCoreList zs);+        wrapGenSyms ss e' }++ | MDoExpr <- ctxt+ = do { (ss,zs) <- repLSts sts;+        e'      <- repMDoE (nonEmptyCoreList zs);+        wrapGenSyms ss e' }++  | otherwise+  = notHandled "monad comprehension and [: :]" (ppr e)++repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }+repE e@(ExplicitTuple _ es boxed)+  | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)+  | isBoxed boxed = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]+                       ; repTup xs }+  | otherwise     = do { xs <- repLEs [e | (dL->L _ (Present _ e)) <- es]+                       ; repUnboxedTup xs }++repE (ExplicitSum _ alt arity e)+ = do { e1 <- repLE e+      ; repUnboxedSum e1 alt arity }++repE (RecordCon { rcon_con_name = c, rcon_flds = flds })+ = do { x <- lookupLOcc c;+        fs <- repFields flds;+        repRecCon x fs }+repE (RecordUpd { rupd_expr = e, rupd_flds = flds })+ = do { x <- repLE e;+        fs <- repUpdFields flds;+        repRecUpd x fs }++repE (ExprWithTySig _ e ty)+  = do { e1 <- repLE e+       ; t1 <- repHsSigWcType ty+       ; repSigExp e1 t1 }++repE (ArithSeq _ _ aseq) =+  case aseq of+    From e              -> do { ds1 <- repLE e; repFrom ds1 }+    FromThen e1 e2      -> do+                             ds1 <- repLE e1+                             ds2 <- repLE e2+                             repFromThen ds1 ds2+    FromTo   e1 e2      -> do+                             ds1 <- repLE e1+                             ds2 <- repLE e2+                             repFromTo ds1 ds2+    FromThenTo e1 e2 e3 -> do+                             ds1 <- repLE e1+                             ds2 <- repLE e2+                             ds3 <- repLE e3+                             repFromThenTo ds1 ds2 ds3++repE (HsSpliceE _ splice)  = repSplice splice+repE (HsStatic _ e)        = repLE e >>= rep2 staticEName . (:[]) . unC+repE (HsUnboundVar _ uv)   = do+                               occ   <- occNameLit (unboundVarOcc uv)+                               sname <- repNameS occ+                               repUnboundVar sname++repE e@(HsCoreAnn {})      = notHandled "Core annotations" (ppr e)+repE e@(HsSCC {})          = notHandled "Cost centres" (ppr e)+repE e@(HsTickPragma {})   = notHandled "Tick Pragma" (ppr e)+repE e                     = notHandled "Expression form" (ppr e)++-----------------------------------------------------------------------------+-- Building representations of auxillary structures like Match, Clause, Stmt,++repMatchTup ::  LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.MatchQ)+repMatchTup (dL->L _ (Match { m_pats = [p]+                            , m_grhss = GRHSs _ guards (dL->L _ wheres) })) =+  do { ss1 <- mkGenSyms (collectPatBinders p)+     ; addBinds ss1 $ do {+     ; p1 <- repLP p+     ; (ss2,ds) <- repBinds wheres+     ; addBinds ss2 $ do {+     ; gs    <- repGuards guards+     ; match <- repMatch p1 gs ds+     ; wrapGenSyms (ss1++ss2) match }}}+repMatchTup _ = panic "repMatchTup: case alt with more than one arg"++repClauseTup ::  LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ClauseQ)+repClauseTup (dL->L _ (Match { m_pats = ps+                             , m_grhss = GRHSs _ guards (dL->L _ wheres) })) =+  do { ss1 <- mkGenSyms (collectPatsBinders ps)+     ; addBinds ss1 $ do {+       ps1 <- repLPs ps+     ; (ss2,ds) <- repBinds wheres+     ; addBinds ss2 $ do {+       gs <- repGuards guards+     ; clause <- repClause ps1 gs ds+     ; wrapGenSyms (ss1++ss2) clause }}}+repClauseTup (dL->L _ (Match _ _ _ (XGRHSs _))) = panic "repClauseTup"+repClauseTup _ = panic "repClauseTup"++repGuards ::  [LGRHS GhcRn (LHsExpr GhcRn)] ->  DsM (Core TH.BodyQ)+repGuards [dL->L _ (GRHS _ [] e)]+  = do {a <- repLE e; repNormal a }+repGuards other+  = do { zs <- mapM repLGRHS other+       ; let (xs, ys) = unzip zs+       ; gd <- repGuarded (nonEmptyCoreList ys)+       ; wrapGenSyms (concat xs) gd }++repLGRHS :: LGRHS GhcRn (LHsExpr GhcRn)+         -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp))))+repLGRHS (dL->L _ (GRHS _ [dL->L _ (BodyStmt _ e1 _ _)] e2))+  = do { guarded <- repLNormalGE e1 e2+       ; return ([], guarded) }+repLGRHS (dL->L _ (GRHS _ ss rhs))+  = do { (gs, ss') <- repLSts ss+       ; rhs' <- addBinds gs $ repLE rhs+       ; guarded <- repPatGE (nonEmptyCoreList ss') rhs'+       ; return (gs, guarded) }+repLGRHS _ = panic "repLGRHS"++repFields :: HsRecordBinds GhcRn -> DsM (Core [TH.Q TH.FieldExp])+repFields (HsRecFields { rec_flds = flds })+  = repList fieldExpQTyConName rep_fld flds+  where+    rep_fld :: LHsRecField GhcRn (LHsExpr GhcRn)+            -> DsM (Core (TH.Q TH.FieldExp))+    rep_fld (dL->L _ fld) = do { fn <- lookupLOcc (hsRecFieldSel fld)+                               ; e  <- repLE (hsRecFieldArg fld)+                               ; repFieldExp fn e }++repUpdFields :: [LHsRecUpdField GhcRn] -> DsM (Core [TH.Q TH.FieldExp])+repUpdFields = repList fieldExpQTyConName rep_fld+  where+    rep_fld :: LHsRecUpdField GhcRn -> DsM (Core (TH.Q TH.FieldExp))+    rep_fld (dL->L l fld) = case unLoc (hsRecFieldLbl fld) of+      Unambiguous sel_name _ -> do { fn <- lookupLOcc (cL l sel_name)+                                   ; e  <- repLE (hsRecFieldArg fld)+                                   ; repFieldExp fn e }+      _                      -> notHandled "Ambiguous record updates" (ppr fld)++++-----------------------------------------------------------------------------+-- Representing Stmt's is tricky, especially if bound variables+-- shadow each other. Consider:  [| do { x <- f 1; x <- f x; g x } |]+-- First gensym new names for every variable in any of the patterns.+-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y"))+-- if variables didn't shaddow, the static gensym wouldn't be necessary+-- and we could reuse the original names (x and x).+--+-- do { x'1 <- gensym "x"+--    ; x'2 <- gensym "x"+--    ; doE [ BindSt (pvar x'1) [| f 1 |]+--          , BindSt (pvar x'2) [| f x |]+--          , NoBindSt [| g x |]+--          ]+--    }++-- The strategy is to translate a whole list of do-bindings by building a+-- bigger environment, and a bigger set of meta bindings+-- (like:  x'1 <- gensym "x" ) and then combining these with the translations+-- of the expressions within the Do++-----------------------------------------------------------------------------+-- The helper function repSts computes the translation of each sub expression+-- and a bunch of prefix bindings denoting the dynamic renaming.++repLSts :: [LStmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])+repLSts stmts = repSts (map unLoc stmts)++repSts :: [Stmt GhcRn (LHsExpr GhcRn)] -> DsM ([GenSymBind], [Core TH.StmtQ])+repSts (BindStmt _ p e _ _ : ss) =+   do { e2 <- repLE e+      ; ss1 <- mkGenSyms (collectPatBinders p)+      ; addBinds ss1 $ do {+      ; p1 <- repLP p;+      ; (ss2,zs) <- repSts ss+      ; z <- repBindSt p1 e2+      ; return (ss1++ss2, z : zs) }}+repSts (LetStmt _ (dL->L _ bs) : ss) =+   do { (ss1,ds) <- repBinds bs+      ; z <- repLetSt ds+      ; (ss2,zs) <- addBinds ss1 (repSts ss)+      ; return (ss1++ss2, z : zs) }+repSts (BodyStmt _ e _ _ : ss) =+   do { e2 <- repLE e+      ; z <- repNoBindSt e2+      ; (ss2,zs) <- repSts ss+      ; return (ss2, z : zs) }+repSts (ParStmt _ stmt_blocks _ _ : ss) =+   do { (ss_s, stmt_blocks1) <- mapAndUnzipM rep_stmt_block stmt_blocks+      ; let stmt_blocks2 = nonEmptyCoreList stmt_blocks1+            ss1 = concat ss_s+      ; z <- repParSt stmt_blocks2+      ; (ss2, zs) <- addBinds ss1 (repSts ss)+      ; return (ss1++ss2, z : zs) }+   where+     rep_stmt_block :: ParStmtBlock GhcRn GhcRn+                    -> DsM ([GenSymBind], Core [TH.StmtQ])+     rep_stmt_block (ParStmtBlock _ stmts _ _) =+       do { (ss1, zs) <- repSts (map unLoc stmts)+          ; zs1 <- coreList stmtQTyConName zs+          ; return (ss1, zs1) }+     rep_stmt_block (XParStmtBlock{}) = panic "repSts"+repSts [LastStmt _ e _ _]+  = do { e2 <- repLE e+       ; z <- repNoBindSt e2+       ; return ([], [z]) }+repSts (stmt@RecStmt{} : ss)+  = do { let binders = collectLStmtsBinders (recS_stmts stmt)+       ; ss1 <- mkGenSyms binders+       -- Bring all of binders in the recursive group into scope for the+       -- whole group.+       ; (ss1_other,rss) <- addBinds ss1 $ repSts (map unLoc (recS_stmts stmt))+       ; MASSERT(sort ss1 == sort ss1_other)+       ; z <- repRecSt (nonEmptyCoreList rss)+       ; (ss2,zs) <- addBinds ss1 (repSts ss)+       ; return (ss1++ss2, z : zs) }+repSts []    = return ([],[])+repSts other = notHandled "Exotic statement" (ppr other)+++-----------------------------------------------------------+--                      Bindings+-----------------------------------------------------------++repBinds :: HsLocalBinds GhcRn -> DsM ([GenSymBind], Core [TH.DecQ])+repBinds (EmptyLocalBinds _)+  = do  { core_list <- coreList decQTyConName []+        ; return ([], core_list) }++repBinds (HsIPBinds _ (IPBinds _ decs))+ = do   { ips <- mapM rep_implicit_param_bind decs+        ; core_list <- coreList decQTyConName+                                (de_loc (sort_by_loc ips))+        ; return ([], core_list)+        }++repBinds b@(HsIPBinds _ XHsIPBinds {})+ = notHandled "Implicit parameter binds extension" (ppr b)++repBinds (HsValBinds _ decs)+ = do   { let { bndrs = hsScopedTvBinders decs ++ collectHsValBinders decs }+                -- No need to worry about detailed scopes within+                -- the binding group, because we are talking Names+                -- here, so we can safely treat it as a mutually+                -- recursive group+                -- For hsScopedTvBinders see Note [Scoped type variables in bindings]+        ; ss        <- mkGenSyms bndrs+        ; prs       <- addBinds ss (rep_val_binds decs)+        ; core_list <- coreList decQTyConName+                                (de_loc (sort_by_loc prs))+        ; return (ss, core_list) }+repBinds b@(XHsLocalBindsLR {}) = notHandled "Local binds extensions" (ppr b)++rep_implicit_param_bind :: LIPBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)+rep_implicit_param_bind (dL->L loc (IPBind _ ename (dL->L _ rhs)))+ = do { name <- case ename of+                    Left (dL->L _ n) -> rep_implicit_param_name n+                    Right _ ->+                        panic "rep_implicit_param_bind: post typechecking"+      ; rhs' <- repE rhs+      ; ipb <- repImplicitParamBind name rhs'+      ; return (loc, ipb) }+rep_implicit_param_bind (dL->L _ b@(XIPBind _))+ = notHandled "Implicit parameter bind extension" (ppr b)+rep_implicit_param_bind _ = panic "rep_implicit_param_bind: Impossible Match"+                            -- due to #15884++rep_implicit_param_name :: HsIPName -> DsM (Core String)+rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)++rep_val_binds :: HsValBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]+-- Assumes: all the binders of the binding are already in the meta-env+rep_val_binds (XValBindsLR (NValBinds binds sigs))+ = do { core1 <- rep_binds (unionManyBags (map snd binds))+      ; core2 <- rep_sigs sigs+      ; return (core1 ++ core2) }+rep_val_binds (ValBinds _ _ _)+ = panic "rep_val_binds: ValBinds"++rep_binds :: LHsBinds GhcRn -> DsM [(SrcSpan, Core TH.DecQ)]+rep_binds = mapM rep_bind . bagToList++rep_bind :: LHsBind GhcRn -> DsM (SrcSpan, Core TH.DecQ)+-- Assumes: all the binders of the binding are already in the meta-env++-- Note GHC treats declarations of a variable (not a pattern)+-- e.g.  x = g 5 as a Fun MonoBinds. This is indicated by a single match+-- with an empty list of patterns+rep_bind (dL->L loc (FunBind+                 { fun_id = fn,+                   fun_matches = MG { mg_alts+                           = (dL->L _ [dL->L _ (Match+                                       { m_pats = []+                                       , m_grhss = GRHSs _ guards+                                                     (dL->L _ wheres) }+                                      )]) } }))+ = do { (ss,wherecore) <- repBinds wheres+        ; guardcore <- addBinds ss (repGuards guards)+        ; fn'  <- lookupLBinder fn+        ; p    <- repPvar fn'+        ; ans  <- repVal p guardcore wherecore+        ; ans' <- wrapGenSyms ss ans+        ; return (loc, ans') }++rep_bind (dL->L loc (FunBind { fun_id = fn+                             , fun_matches = MG { mg_alts = (dL->L _ ms) } }))+ =   do { ms1 <- mapM repClauseTup ms+        ; fn' <- lookupLBinder fn+        ; ans <- repFun fn' (nonEmptyCoreList ms1)+        ; return (loc, ans) }++rep_bind (dL->L _ (FunBind { fun_matches = XMatchGroup _ })) = panic "rep_bind"++rep_bind (dL->L loc (PatBind { pat_lhs = pat+                             , pat_rhs = GRHSs _ guards (dL->L _ wheres) }))+ =   do { patcore <- repLP pat+        ; (ss,wherecore) <- repBinds wheres+        ; guardcore <- addBinds ss (repGuards guards)+        ; ans  <- repVal patcore guardcore wherecore+        ; ans' <- wrapGenSyms ss ans+        ; return (loc, ans') }+rep_bind (dL->L _ (PatBind _ _ (XGRHSs _) _)) = panic "rep_bind"++rep_bind (dL->L _ (VarBind { var_id = v, var_rhs = e}))+ =   do { v' <- lookupBinder v+        ; e2 <- repLE e+        ; x <- repNormal e2+        ; patcore <- repPvar v'+        ; empty_decls <- coreList decQTyConName []+        ; ans <- repVal patcore x empty_decls+        ; return (srcLocSpan (getSrcLoc v), ans) }++rep_bind (dL->L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds"+rep_bind (dL->L loc (PatSynBind _ (PSB { psb_id   = syn+                                       , psb_args = args+                                       , psb_def  = pat+                                       , psb_dir  = dir })))+  = do { syn'      <- lookupLBinder syn+       ; dir'      <- repPatSynDir dir+       ; ss        <- mkGenArgSyms args+       ; patSynD'  <- addBinds ss (+         do { args'  <- repPatSynArgs args+            ; pat'   <- repLP pat+            ; repPatSynD syn' args' dir' pat' })+       ; patSynD'' <- wrapGenArgSyms args ss patSynD'+       ; return (loc, patSynD'') }+  where+    mkGenArgSyms :: HsPatSynDetails (Located Name) -> DsM [GenSymBind]+    -- for Record Pattern Synonyms we want to conflate the selector+    -- and the pattern-only names in order to provide a nicer TH+    -- API. Whereas inside GHC, record pattern synonym selectors and+    -- their pattern-only bound right hand sides have different names,+    -- we want to treat them the same in TH. This is the reason why we+    -- need an adjusted mkGenArgSyms in the `RecCon` case below.+    mkGenArgSyms (PrefixCon args)     = mkGenSyms (map unLoc args)+    mkGenArgSyms (InfixCon arg1 arg2) = mkGenSyms [unLoc arg1, unLoc arg2]+    mkGenArgSyms (RecCon fields)+      = do { let pats = map (unLoc . recordPatSynPatVar) fields+                 sels = map (unLoc . recordPatSynSelectorId) fields+           ; ss <- mkGenSyms sels+           ; return $ replaceNames (zip sels pats) ss }++    replaceNames selsPats genSyms+      = [ (pat, id) | (sel, id) <- genSyms, (sel', pat) <- selsPats+                    , sel == sel' ]++    wrapGenArgSyms :: HsPatSynDetails (Located Name)+                   -> [GenSymBind] -> Core TH.DecQ -> DsM (Core TH.DecQ)+    wrapGenArgSyms (RecCon _) _  dec = return dec+    wrapGenArgSyms _          ss dec = wrapGenSyms ss dec++rep_bind (dL->L _ (PatSynBind _ (XPatSynBind _)))+  = panic "rep_bind: XPatSynBind"+rep_bind (dL->L _ (XHsBindsLR {}))  = panic "rep_bind: XHsBindsLR"+rep_bind _                          = panic "rep_bind: Impossible match!"+                                      -- due to #15884++repPatSynD :: Core TH.Name+           -> Core TH.PatSynArgsQ+           -> Core TH.PatSynDirQ+           -> Core TH.PatQ+           -> DsM (Core TH.DecQ)+repPatSynD (MkC syn) (MkC args) (MkC dir) (MkC pat)+  = rep2 patSynDName [syn, args, dir, pat]++repPatSynArgs :: HsPatSynDetails (Located Name) -> DsM (Core TH.PatSynArgsQ)+repPatSynArgs (PrefixCon args)+  = do { args' <- repList nameTyConName lookupLOcc args+       ; repPrefixPatSynArgs args' }+repPatSynArgs (InfixCon arg1 arg2)+  = do { arg1' <- lookupLOcc arg1+       ; arg2' <- lookupLOcc arg2+       ; repInfixPatSynArgs arg1' arg2' }+repPatSynArgs (RecCon fields)+  = do { sels' <- repList nameTyConName lookupLOcc sels+       ; repRecordPatSynArgs sels' }+  where sels = map recordPatSynSelectorId fields++repPrefixPatSynArgs :: Core [TH.Name] -> DsM (Core TH.PatSynArgsQ)+repPrefixPatSynArgs (MkC nms) = rep2 prefixPatSynName [nms]++repInfixPatSynArgs :: Core TH.Name -> Core TH.Name -> DsM (Core TH.PatSynArgsQ)+repInfixPatSynArgs (MkC nm1) (MkC nm2) = rep2 infixPatSynName [nm1, nm2]++repRecordPatSynArgs :: Core [TH.Name]+                    -> DsM (Core TH.PatSynArgsQ)+repRecordPatSynArgs (MkC sels) = rep2 recordPatSynName [sels]++repPatSynDir :: HsPatSynDir GhcRn -> DsM (Core TH.PatSynDirQ)+repPatSynDir Unidirectional        = rep2 unidirPatSynName []+repPatSynDir ImplicitBidirectional = rep2 implBidirPatSynName []+repPatSynDir (ExplicitBidirectional (MG { mg_alts = (dL->L _ clauses) }))+  = do { clauses' <- mapM repClauseTup clauses+       ; repExplBidirPatSynDir (nonEmptyCoreList clauses') }+repPatSynDir (ExplicitBidirectional (XMatchGroup _)) = panic "repPatSynDir"++repExplBidirPatSynDir :: Core [TH.ClauseQ] -> DsM (Core TH.PatSynDirQ)+repExplBidirPatSynDir (MkC cls) = rep2 explBidirPatSynName [cls]+++-----------------------------------------------------------------------------+-- Since everything in a Bind is mutually recursive we need rename all+-- all the variables simultaneously. For example:+-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to+-- do { f'1 <- gensym "f"+--    ; g'2 <- gensym "g"+--    ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]},+--        do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]}+--      ]}+-- This requires collecting the bindings (f'1 <- gensym "f"), and the+-- environment ( f |-> f'1 ) from each binding, and then unioning them+-- together. As we do this we collect GenSymBinds's which represent the renamed+-- variables bound by the Bindings. In order not to lose track of these+-- representations we build a shadow datatype MB with the same structure as+-- MonoBinds, but which has slots for the representations+++-----------------------------------------------------------------------------+-- GHC allows a more general form of lambda abstraction than specified+-- by Haskell 98. In particular it allows guarded lambda's like :+-- (\  x | even x -> 0 | odd x -> 1) at the moment we can't represent this in+-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like+-- (\ p1 .. pn -> exp) by causing an error.++repLambda :: LMatch GhcRn (LHsExpr GhcRn) -> DsM (Core TH.ExpQ)+repLambda (dL->L _ (Match { m_pats = ps+                          , m_grhss = GRHSs _ [dL->L _ (GRHS _ [] e)]+                                              (dL->L _ (EmptyLocalBinds _)) } ))+ = do { let bndrs = collectPatsBinders ps ;+      ; ss  <- mkGenSyms bndrs+      ; lam <- addBinds ss (+                do { xs <- repLPs ps; body <- repLE e; repLam xs body })+      ; wrapGenSyms ss lam }++repLambda (dL->L _ m) = notHandled "Guarded labmdas" (pprMatch m)+++-----------------------------------------------------------------------------+--                      Patterns+-- repP deals with patterns.  It assumes that we have already+-- walked over the pattern(s) once to collect the binders, and+-- have extended the environment.  So every pattern-bound+-- variable should already appear in the environment.++-- Process a list of patterns+repLPs :: [LPat GhcRn] -> DsM (Core [TH.PatQ])+repLPs ps = repList patQTyConName repLP ps++repLP :: LPat GhcRn -> DsM (Core TH.PatQ)+repLP p = repP (unLoc p)++repP :: Pat GhcRn -> DsM (Core TH.PatQ)+repP (WildPat _)        = repPwild+repP (LitPat _ l)       = do { l2 <- repLiteral l; repPlit l2 }+repP (VarPat _ x)       = do { x' <- lookupBinder (unLoc x); repPvar x' }+repP (LazyPat _ p)      = do { p1 <- repLP p; repPtilde p1 }+repP (BangPat _ p)      = do { p1 <- repLP p; repPbang p1 }+repP (AsPat _ x p)      = do { x' <- lookupLBinder x; p1 <- repLP p+                             ; repPaspat x' p1 }+repP (ParPat _ p)       = repLP p+repP (ListPat Nothing ps)  = do { qs <- repLPs ps; repPlist qs }+repP (ListPat (Just e) ps) = do { p <- repP (ListPat Nothing ps)+                                ; e' <- repE (syn_expr e)+                                ; repPview e' p}+repP (TuplePat _ ps boxed)+  | isBoxed boxed       = do { qs <- repLPs ps; repPtup qs }+  | otherwise           = do { qs <- repLPs ps; repPunboxedTup qs }+repP (SumPat _ p alt arity) = do { p1 <- repLP p+                                 ; repPunboxedSum p1 alt arity }+repP (ConPatIn dc details)+ = do { con_str <- lookupLOcc dc+      ; case details of+         PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs }+         RecCon rec   -> do { fps <- repList fieldPatQTyConName rep_fld (rec_flds rec)+                            ; repPrec con_str fps }+         InfixCon p1 p2 -> do { p1' <- repLP p1;+                                p2' <- repLP p2;+                                repPinfix p1' con_str p2' }+   }+ where+   rep_fld :: LHsRecField GhcRn (LPat GhcRn) -> DsM (Core (TH.Name,TH.PatQ))+   rep_fld (dL->L _ fld) = do { MkC v <- lookupLOcc (hsRecFieldSel fld)+                              ; MkC p <- repLP (hsRecFieldArg fld)+                              ; rep2 fieldPatName [v,p] }++repP (NPat _ (dL->L _ l) Nothing _) = do { a <- repOverloadedLiteral l+                                         ; repPlit a }+repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }+repP p@(NPat _ _ (Just _) _) = notHandled "Negative overloaded patterns" (ppr p)+repP (SigPat _ p t) = do { p' <- repLP p+                         ; t' <- repLTy (hsSigWcType t)+                         ; repPsig p' t' }+repP (SplicePat _ splice) = repSplice splice++repP other = notHandled "Exotic pattern" (ppr other)++----------------------------------------------------------+-- Declaration ordering helpers++sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)]+sort_by_loc xs = sortBy comp xs+    where comp x y = compare (fst x) (fst y)++de_loc :: [(a, b)] -> [b]+de_loc = map snd++----------------------------------------------------------+--      The meta-environment++-- A name/identifier association for fresh names of locally bound entities+type GenSymBind = (Name, Id)    -- Gensym the string and bind it to the Id+                                -- I.e.         (x, x_id) means+                                --      let x_id = gensym "x" in ...++-- Generate a fresh name for a locally bound entity++mkGenSyms :: [Name] -> DsM [GenSymBind]+-- We can use the existing name.  For example:+--      [| \x_77 -> x_77 + x_77 |]+-- desugars to+--      do { x_77 <- genSym "x"; .... }+-- We use the same x_77 in the desugared program, but with the type Bndr+-- instead of Int+--+-- We do make it an Internal name, though (hence localiseName)+--+-- Nevertheless, it's monadic because we have to generate nameTy+mkGenSyms ns = do { var_ty <- lookupType nameTyConName+                  ; return [(nm, mkLocalId (localiseName nm) var_ty) | nm <- ns] }+++addBinds :: [GenSymBind] -> DsM a -> DsM a+-- Add a list of fresh names for locally bound entities to the+-- meta environment (which is part of the state carried around+-- by the desugarer monad)+addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m++-- Look up a locally bound name+--+lookupLBinder :: Located Name -> DsM (Core TH.Name)+lookupLBinder n = lookupBinder (unLoc n)++lookupBinder :: Name -> DsM (Core TH.Name)+lookupBinder = lookupOcc+  -- Binders are brought into scope before the pattern or what-not is+  -- desugared.  Moreover, in instance declaration the binder of a method+  -- will be the selector Id and hence a global; so we need the+  -- globalVar case of lookupOcc++-- Look up a name that is either locally bound or a global name+--+--  * If it is a global name, generate the "original name" representation (ie,+--   the <module>:<name> form) for the associated entity+--+lookupLOcc :: Located Name -> DsM (Core TH.Name)+-- Lookup an occurrence; it can't be a splice.+-- Use the in-scope bindings if they exist+lookupLOcc n = lookupOcc (unLoc n)++lookupOcc :: Name -> DsM (Core TH.Name)+lookupOcc n+  = do {  mb_val <- dsLookupMetaEnv n ;+          case mb_val of+                Nothing           -> globalVar n+                Just (DsBound x)  -> return (coreVar x)+                Just (DsSplice _) -> pprPanic "repE:lookupOcc" (ppr n)+    }++globalVar :: Name -> DsM (Core TH.Name)+-- Not bound by the meta-env+-- Could be top-level; or could be local+--      f x = $(g [| x |])+-- Here the x will be local+globalVar name+  | isExternalName name+  = do  { MkC mod <- coreStringLit name_mod+        ; MkC pkg <- coreStringLit name_pkg+        ; MkC occ <- nameLit name+        ; rep2 mk_varg [pkg,mod,occ] }+  | otherwise+  = do  { MkC occ <- nameLit name+        ; MkC uni <- coreIntegerLit (toInteger $ getKey (getUnique name))+        ; rep2 mkNameLName [occ,uni] }+  where+      mod = ASSERT( isExternalName name) nameModule name+      name_mod = moduleNameString (moduleName mod)+      name_pkg = unitIdString (moduleUnitId mod)+      name_occ = nameOccName name+      mk_varg | OccName.isDataOcc name_occ = mkNameG_dName+              | OccName.isVarOcc  name_occ = mkNameG_vName+              | OccName.isTcOcc   name_occ = mkNameG_tcName+              | otherwise                  = pprPanic "DsMeta.globalVar" (ppr name)++lookupType :: Name      -- Name of type constructor (e.g. TH.ExpQ)+           -> DsM Type  -- The type+lookupType tc_name = do { tc <- dsLookupTyCon tc_name ;+                          return (mkTyConApp tc []) }++wrapGenSyms :: [GenSymBind]+            -> Core (TH.Q a) -> DsM (Core (TH.Q a))+-- wrapGenSyms [(nm1,id1), (nm2,id2)] y+--      --> bindQ (gensym nm1) (\ id1 ->+--          bindQ (gensym nm2 (\ id2 ->+--          y))++wrapGenSyms binds body@(MkC b)+  = do  { var_ty <- lookupType nameTyConName+        ; go var_ty binds }+  where+    [elt_ty] = tcTyConAppArgs (exprType b)+        -- b :: Q a, so we can get the type 'a' by looking at the+        -- argument type. NB: this relies on Q being a data/newtype,+        -- not a type synonym++    go _ [] = return body+    go var_ty ((name,id) : binds)+      = do { MkC body'  <- go var_ty binds+           ; lit_str    <- nameLit name+           ; gensym_app <- repGensym lit_str+           ; repBindQ var_ty elt_ty+                      gensym_app (MkC (Lam id body')) }++nameLit :: Name -> DsM (Core String)+nameLit n = coreStringLit (occNameString (nameOccName n))++occNameLit :: OccName -> DsM (Core String)+occNameLit name = coreStringLit (occNameString name)+++-- %*********************************************************************+-- %*                                                                   *+--              Constructing code+-- %*                                                                   *+-- %*********************************************************************++-----------------------------------------------------------------------------+-- PHANTOM TYPES for consistency. In order to make sure we do this correct+-- we invent a new datatype which uses phantom types.++newtype Core a = MkC CoreExpr+unC :: Core a -> CoreExpr+unC (MkC x) = x++rep2 :: Name -> [ CoreExpr ] -> DsM (Core a)+rep2 n xs = do { id <- dsLookupGlobalId n+               ; return (MkC (foldl' App (Var id) xs)) }++dataCon' :: Name -> [CoreExpr] -> DsM (Core a)+dataCon' n args = do { id <- dsLookupDataCon n+                     ; return $ MkC $ mkCoreConApps id args }++dataCon :: Name -> DsM (Core a)+dataCon n = dataCon' n []+++-- %*********************************************************************+-- %*                                                                   *+--              The 'smart constructors'+-- %*                                                                   *+-- %*********************************************************************++--------------- Patterns -----------------+repPlit   :: Core TH.Lit -> DsM (Core TH.PatQ)+repPlit (MkC l) = rep2 litPName [l]++repPvar :: Core TH.Name -> DsM (Core TH.PatQ)+repPvar (MkC s) = rep2 varPName [s]++repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)+repPtup (MkC ps) = rep2 tupPName [ps]++repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ)+repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps]++repPunboxedSum :: Core TH.PatQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.PatQ)+-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here+repPunboxedSum (MkC p) alt arity+ = do { dflags <- getDynFlags+      ; rep2 unboxedSumPName [ p+                             , mkIntExprInt dflags alt+                             , mkIntExprInt dflags arity ] }++repPcon   :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ)+repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps]++repPrec   :: Core TH.Name -> Core [(TH.Name,TH.PatQ)] -> DsM (Core TH.PatQ)+repPrec (MkC c) (MkC rps) = rep2 recPName [c,rps]++repPinfix :: Core TH.PatQ -> Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)+repPinfix (MkC p1) (MkC n) (MkC p2) = rep2 infixPName [p1, n, p2]++repPtilde :: Core TH.PatQ -> DsM (Core TH.PatQ)+repPtilde (MkC p) = rep2 tildePName [p]++repPbang :: Core TH.PatQ -> DsM (Core TH.PatQ)+repPbang (MkC p) = rep2 bangPName [p]++repPaspat :: Core TH.Name -> Core TH.PatQ -> DsM (Core TH.PatQ)+repPaspat (MkC s) (MkC p) = rep2 asPName [s, p]++repPwild  :: DsM (Core TH.PatQ)+repPwild = rep2 wildPName []++repPlist :: Core [TH.PatQ] -> DsM (Core TH.PatQ)+repPlist (MkC ps) = rep2 listPName [ps]++repPview :: Core TH.ExpQ -> Core TH.PatQ -> DsM (Core TH.PatQ)+repPview (MkC e) (MkC p) = rep2 viewPName [e,p]++repPsig :: Core TH.PatQ -> Core TH.TypeQ -> DsM (Core TH.PatQ)+repPsig (MkC p) (MkC t) = rep2 sigPName [p, t]++--------------- Expressions -----------------+repVarOrCon :: Name -> Core TH.Name -> DsM (Core TH.ExpQ)+repVarOrCon vc str | isDataOcc (nameOccName vc) = repCon str+                   | otherwise                  = repVar str++repVar :: Core TH.Name -> DsM (Core TH.ExpQ)+repVar (MkC s) = rep2 varEName [s]++repCon :: Core TH.Name -> DsM (Core TH.ExpQ)+repCon (MkC s) = rep2 conEName [s]++repLit :: Core TH.Lit -> DsM (Core TH.ExpQ)+repLit (MkC c) = rep2 litEName [c]++repApp :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repApp (MkC x) (MkC y) = rep2 appEName [x,y]++repAppType :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)+repAppType (MkC x) (MkC y) = rep2 appTypeEName [x,y]++repLam :: Core [TH.PatQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repLam (MkC ps) (MkC e) = rep2 lamEName [ps, e]++repLamCase :: Core [TH.MatchQ] -> DsM (Core TH.ExpQ)+repLamCase (MkC ms) = rep2 lamCaseEName [ms]++repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)+repTup (MkC es) = rep2 tupEName [es]++repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)+repUnboxedTup (MkC es) = rep2 unboxedTupEName [es]++repUnboxedSum :: Core TH.ExpQ -> TH.SumAlt -> TH.SumArity -> DsM (Core TH.ExpQ)+-- Note: not Core TH.SumAlt or Core TH.SumArity; it's easier to be direct here+repUnboxedSum (MkC e) alt arity+ = do { dflags <- getDynFlags+      ; rep2 unboxedSumEName [ e+                             , mkIntExprInt dflags alt+                             , mkIntExprInt dflags arity ] }++repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z]++repMultiIf :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.ExpQ)+repMultiIf (MkC alts) = rep2 multiIfEName [alts]++repLetE :: Core [TH.DecQ] -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e]++repCaseE :: Core TH.ExpQ -> Core [TH.MatchQ] -> DsM( Core TH.ExpQ)+repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms]++repDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)+repDoE (MkC ss) = rep2 doEName [ss]++repMDoE :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)+repMDoE (MkC ss) = rep2 mdoEName [ss]++repComp :: Core [TH.StmtQ] -> DsM (Core TH.ExpQ)+repComp (MkC ss) = rep2 compEName [ss]++repListExp :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ)+repListExp (MkC es) = rep2 listEName [es]++repSigExp :: Core TH.ExpQ -> Core TH.TypeQ -> DsM (Core TH.ExpQ)+repSigExp (MkC e) (MkC t) = rep2 sigEName [e,t]++repRecCon :: Core TH.Name -> Core [TH.Q TH.FieldExp]-> DsM (Core TH.ExpQ)+repRecCon (MkC c) (MkC fs) = rep2 recConEName [c,fs]++repRecUpd :: Core TH.ExpQ -> Core [TH.Q TH.FieldExp] -> DsM (Core TH.ExpQ)+repRecUpd (MkC e) (MkC fs) = rep2 recUpdEName [e,fs]++repFieldExp :: Core TH.Name -> Core TH.ExpQ -> DsM (Core (TH.Q TH.FieldExp))+repFieldExp (MkC n) (MkC x) = rep2 fieldExpName [n,x]++repInfixApp :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z]++repSectionL :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repSectionL (MkC x) (MkC y) = rep2 sectionLName [x,y]++repSectionR :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repSectionR (MkC x) (MkC y) = rep2 sectionRName [x,y]++repImplicitParamVar :: Core String -> DsM (Core TH.ExpQ)+repImplicitParamVar (MkC x) = rep2 implicitParamVarEName [x]++------------ Right hand sides (guarded expressions) ----+repGuarded :: Core [TH.Q (TH.Guard, TH.Exp)] -> DsM (Core TH.BodyQ)+repGuarded (MkC pairs) = rep2 guardedBName [pairs]++repNormal :: Core TH.ExpQ -> DsM (Core TH.BodyQ)+repNormal (MkC e) = rep2 normalBName [e]++------------ Guards ----+repLNormalGE :: LHsExpr GhcRn -> LHsExpr GhcRn+             -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))+repLNormalGE g e = do g' <- repLE g+                      e' <- repLE e+                      repNormalGE g' e'++repNormalGE :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))+repNormalGE (MkC g) (MkC e) = rep2 normalGEName [g, e]++repPatGE :: Core [TH.StmtQ] -> Core TH.ExpQ -> DsM (Core (TH.Q (TH.Guard, TH.Exp)))+repPatGE (MkC ss) (MkC e) = rep2 patGEName [ss, e]++------------- Stmts -------------------+repBindSt :: Core TH.PatQ -> Core TH.ExpQ -> DsM (Core TH.StmtQ)+repBindSt (MkC p) (MkC e) = rep2 bindSName [p,e]++repLetSt :: Core [TH.DecQ] -> DsM (Core TH.StmtQ)+repLetSt (MkC ds) = rep2 letSName [ds]++repNoBindSt :: Core TH.ExpQ -> DsM (Core TH.StmtQ)+repNoBindSt (MkC e) = rep2 noBindSName [e]++repParSt :: Core [[TH.StmtQ]] -> DsM (Core TH.StmtQ)+repParSt (MkC sss) = rep2 parSName [sss]++repRecSt :: Core [TH.StmtQ] -> DsM (Core TH.StmtQ)+repRecSt (MkC ss) = rep2 recSName [ss]++-------------- Range (Arithmetic sequences) -----------+repFrom :: Core TH.ExpQ -> DsM (Core TH.ExpQ)+repFrom (MkC x) = rep2 fromEName [x]++repFromThen :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repFromThen (MkC x) (MkC y) = rep2 fromThenEName [x,y]++repFromTo :: Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repFromTo (MkC x) (MkC y) = rep2 fromToEName [x,y]++repFromThenTo :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ)+repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToEName [x,y,z]++------------ Match and Clause Tuples -----------+repMatch :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.MatchQ)+repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds]++repClause :: Core [TH.PatQ] -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.ClauseQ)+repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds]++-------------- Dec -----------------------------+repVal :: Core TH.PatQ -> Core TH.BodyQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)+repVal (MkC p) (MkC b) (MkC ds) = rep2 valDName [p, b, ds]++repFun :: Core TH.Name -> Core [TH.ClauseQ] -> DsM (Core TH.DecQ)+repFun (MkC nm) (MkC b) = rep2 funDName [nm, b]++repData :: Core TH.CxtQ -> Core TH.Name+        -> Either (Core [TH.TyVarBndrQ])+                  (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)+        -> Core (Maybe TH.KindQ) -> Core [TH.ConQ] -> Core [TH.DerivClauseQ]+        -> DsM (Core TH.DecQ)+repData (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC cons) (MkC derivs)+  = rep2 dataDName [cxt, nm, tvs, ksig, cons, derivs]+repData (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC cons)+        (MkC derivs)+  = rep2 dataInstDName [cxt, mb_bndrs, ty, ksig, cons, derivs]++repNewtype :: Core TH.CxtQ -> Core TH.Name+           -> Either (Core [TH.TyVarBndrQ])+                     (Core (Maybe [TH.TyVarBndrQ]), Core TH.TypeQ)+           -> Core (Maybe TH.KindQ) -> Core TH.ConQ -> Core [TH.DerivClauseQ]+           -> DsM (Core TH.DecQ)+repNewtype (MkC cxt) (MkC nm) (Left (MkC tvs)) (MkC ksig) (MkC con)+           (MkC derivs)+  = rep2 newtypeDName [cxt, nm, tvs, ksig, con, derivs]+repNewtype (MkC cxt) (MkC _) (Right (MkC mb_bndrs, MkC ty)) (MkC ksig) (MkC con)+           (MkC derivs)+  = rep2 newtypeInstDName [cxt, mb_bndrs, ty, ksig, con, derivs]++repTySyn :: Core TH.Name -> Core [TH.TyVarBndrQ]+         -> Core TH.TypeQ -> DsM (Core TH.DecQ)+repTySyn (MkC nm) (MkC tvs) (MkC rhs)+  = rep2 tySynDName [nm, tvs, rhs]++repInst :: Core (Maybe TH.Overlap) ->+           Core TH.CxtQ -> Core TH.TypeQ -> Core [TH.DecQ] -> DsM (Core TH.DecQ)+repInst (MkC o) (MkC cxt) (MkC ty) (MkC ds) = rep2 instanceWithOverlapDName+                                                              [o, cxt, ty, ds]++repDerivStrategy :: Maybe (LDerivStrategy GhcRn)+                 -> DsM (Core (Maybe TH.DerivStrategyQ))+repDerivStrategy mds =+  case mds of+    Nothing -> nothing+    Just ds ->+      case unLoc ds of+        StockStrategy    -> just =<< repStockStrategy+        AnyclassStrategy -> just =<< repAnyclassStrategy+        NewtypeStrategy  -> just =<< repNewtypeStrategy+        ViaStrategy ty   -> do ty' <- repLTy (hsSigType ty)+                               via_strat <- repViaStrategy ty'+                               just via_strat+  where+  nothing = coreNothing derivStrategyQTyConName+  just    = coreJust    derivStrategyQTyConName++repStockStrategy :: DsM (Core TH.DerivStrategyQ)+repStockStrategy = rep2 stockStrategyName []++repAnyclassStrategy :: DsM (Core TH.DerivStrategyQ)+repAnyclassStrategy = rep2 anyclassStrategyName []++repNewtypeStrategy :: DsM (Core TH.DerivStrategyQ)+repNewtypeStrategy = rep2 newtypeStrategyName []++repViaStrategy :: Core TH.TypeQ -> DsM (Core TH.DerivStrategyQ)+repViaStrategy (MkC t) = rep2 viaStrategyName [t]++repOverlap :: Maybe OverlapMode -> DsM (Core (Maybe TH.Overlap))+repOverlap mb =+  case mb of+    Nothing -> nothing+    Just o ->+      case o of+        NoOverlap _    -> nothing+        Overlappable _ -> just =<< dataCon overlappableDataConName+        Overlapping _  -> just =<< dataCon overlappingDataConName+        Overlaps _     -> just =<< dataCon overlapsDataConName+        Incoherent _   -> just =<< dataCon incoherentDataConName+  where+  nothing = coreNothing overlapTyConName+  just    = coreJust overlapTyConName+++repClass :: Core TH.CxtQ -> Core TH.Name -> Core [TH.TyVarBndrQ]+         -> Core [TH.FunDep] -> Core [TH.DecQ]+         -> DsM (Core TH.DecQ)+repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC fds) (MkC ds)+  = rep2 classDName [cxt, cls, tvs, fds, ds]++repDeriv :: Core (Maybe TH.DerivStrategyQ)+         -> Core TH.CxtQ -> Core TH.TypeQ+         -> DsM (Core TH.DecQ)+repDeriv (MkC ds) (MkC cxt) (MkC ty)+  = rep2 standaloneDerivWithStrategyDName [ds, cxt, ty]++repPragInl :: Core TH.Name -> Core TH.Inline -> Core TH.RuleMatch+           -> Core TH.Phases -> DsM (Core TH.DecQ)+repPragInl (MkC nm) (MkC inline) (MkC rm) (MkC phases)+  = rep2 pragInlDName [nm, inline, rm, phases]++repPragSpec :: Core TH.Name -> Core TH.TypeQ -> Core TH.Phases+            -> DsM (Core TH.DecQ)+repPragSpec (MkC nm) (MkC ty) (MkC phases)+  = rep2 pragSpecDName [nm, ty, phases]++repPragSpecInl :: Core TH.Name -> Core TH.TypeQ -> Core TH.Inline+               -> Core TH.Phases -> DsM (Core TH.DecQ)+repPragSpecInl (MkC nm) (MkC ty) (MkC inline) (MkC phases)+  = rep2 pragSpecInlDName [nm, ty, inline, phases]++repPragSpecInst :: Core TH.TypeQ -> DsM (Core TH.DecQ)+repPragSpecInst (MkC ty) = rep2 pragSpecInstDName [ty]++repPragComplete :: Core [TH.Name] -> Core (Maybe TH.Name) -> DsM (Core TH.DecQ)+repPragComplete (MkC cls) (MkC mty) = rep2 pragCompleteDName [cls, mty]++repPragRule :: Core String -> Core (Maybe [TH.TyVarBndrQ])+            -> Core [TH.RuleBndrQ] -> Core TH.ExpQ -> Core TH.ExpQ+            -> Core TH.Phases -> DsM (Core TH.DecQ)+repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phases)+  = rep2 pragRuleDName [nm, ty_bndrs, tm_bndrs, lhs, rhs, phases]++repPragAnn :: Core TH.AnnTarget -> Core TH.ExpQ -> DsM (Core TH.DecQ)+repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]++repTySynInst :: Core TH.TySynEqnQ -> DsM (Core TH.DecQ)+repTySynInst (MkC eqn)+    = rep2 tySynInstDName [eqn]++repDataFamilyD :: Core TH.Name -> Core [TH.TyVarBndrQ]+               -> Core (Maybe TH.KindQ) -> DsM (Core TH.DecQ)+repDataFamilyD (MkC nm) (MkC tvs) (MkC kind)+    = rep2 dataFamilyDName [nm, tvs, kind]++repOpenFamilyD :: Core TH.Name+               -> Core [TH.TyVarBndrQ]+               -> Core TH.FamilyResultSigQ+               -> Core (Maybe TH.InjectivityAnn)+               -> DsM (Core TH.DecQ)+repOpenFamilyD (MkC nm) (MkC tvs) (MkC result) (MkC inj)+    = rep2 openTypeFamilyDName [nm, tvs, result, inj]++repClosedFamilyD :: Core TH.Name+                 -> Core [TH.TyVarBndrQ]+                 -> Core TH.FamilyResultSigQ+                 -> Core (Maybe TH.InjectivityAnn)+                 -> Core [TH.TySynEqnQ]+                 -> DsM (Core TH.DecQ)+repClosedFamilyD (MkC nm) (MkC tvs) (MkC res) (MkC inj) (MkC eqns)+    = rep2 closedTypeFamilyDName [nm, tvs, res, inj, eqns]++repTySynEqn :: Core (Maybe [TH.TyVarBndrQ]) ->+               Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TySynEqnQ)+repTySynEqn (MkC mb_bndrs) (MkC lhs) (MkC rhs)+  = rep2 tySynEqnName [mb_bndrs, lhs, rhs]++repRoleAnnotD :: Core TH.Name -> Core [TH.Role] -> DsM (Core TH.DecQ)+repRoleAnnotD (MkC n) (MkC roles) = rep2 roleAnnotDName [n, roles]++repFunDep :: Core [TH.Name] -> Core [TH.Name] -> DsM (Core TH.FunDep)+repFunDep (MkC xs) (MkC ys) = rep2 funDepName [xs, ys]++repProto :: Name -> Core TH.Name -> Core TH.TypeQ -> DsM (Core TH.DecQ)+repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty]++repImplicitParamBind :: Core String -> Core TH.ExpQ -> DsM (Core TH.DecQ)+repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e]++repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ)+repCtxt (MkC tys) = rep2 cxtName [tys]++repDataCon :: Located Name+           -> HsConDeclDetails GhcRn+           -> DsM (Core TH.ConQ)+repDataCon con details+    = do con' <- lookupLOcc con -- See Note [Binders and occurrences]+         repConstr details Nothing [con']++repGadtDataCons :: [Located Name]+                -> HsConDeclDetails GhcRn+                -> LHsType GhcRn+                -> DsM (Core TH.ConQ)+repGadtDataCons cons details res_ty+    = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences]+         repConstr details (Just res_ty) cons'++-- Invariant:+--   * for plain H98 data constructors second argument is Nothing and third+--     argument is a singleton list+--   * for GADTs data constructors second argument is (Just return_type) and+--     third argument is a non-empty list+repConstr :: HsConDeclDetails GhcRn+          -> Maybe (LHsType GhcRn)+          -> [Core TH.Name]+          -> DsM (Core TH.ConQ)+repConstr (PrefixCon ps) Nothing [con]+    = do arg_tys  <- repList bangTypeQTyConName repBangTy ps+         rep2 normalCName [unC con, unC arg_tys]++repConstr (PrefixCon ps) (Just res_ty) cons+    = do arg_tys     <- repList bangTypeQTyConName repBangTy ps+         res_ty' <- repLTy res_ty+         rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty']++repConstr (RecCon ips) resTy cons+    = do args     <- concatMapM rep_ip (unLoc ips)+         arg_vtys <- coreList varBangTypeQTyConName args+         case resTy of+           Nothing -> rep2 recCName [unC (head cons), unC arg_vtys]+           Just res_ty -> do+             res_ty' <- repLTy res_ty+             rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys,+                                unC res_ty']++    where+      rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip)++      rep_one_ip :: LBangType GhcRn -> LFieldOcc GhcRn -> DsM (Core a)+      rep_one_ip t n = do { MkC v  <- lookupOcc (extFieldOcc $ unLoc n)+                          ; MkC ty <- repBangTy  t+                          ; rep2 varBangTypeName [v,ty] }++repConstr (InfixCon st1 st2) Nothing [con]+    = do arg1 <- repBangTy st1+         arg2 <- repBangTy st2+         rep2 infixCName [unC arg1, unC con, unC arg2]++repConstr (InfixCon {}) (Just _) _ =+    panic "repConstr: infix GADT constructor should be in a PrefixCon"+repConstr _ _ _ =+    panic "repConstr: invariant violated"++------------ Types -------------------++repTForall :: Core [TH.TyVarBndrQ] -> Core TH.CxtQ -> Core TH.TypeQ+           -> DsM (Core TH.TypeQ)+repTForall (MkC tvars) (MkC ctxt) (MkC ty)+    = rep2 forallTName [tvars, ctxt, ty]++repTForallVis :: Core [TH.TyVarBndrQ] -> Core TH.TypeQ+              -> DsM (Core TH.TypeQ)+repTForallVis (MkC tvars) (MkC ty) = rep2 forallVisTName [tvars, ty]++repTvar :: Core TH.Name -> DsM (Core TH.TypeQ)+repTvar (MkC s) = rep2 varTName [s]++repTapp :: Core TH.TypeQ -> Core TH.TypeQ -> DsM (Core TH.TypeQ)+repTapp (MkC t1) (MkC t2) = rep2 appTName [t1, t2]++repTappKind :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)+repTappKind (MkC ty) (MkC ki) = rep2 appKindTName [ty,ki]++repTapps :: Core TH.TypeQ -> [Core TH.TypeQ] -> DsM (Core TH.TypeQ)+repTapps f []     = return f+repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts }++repTSig :: Core TH.TypeQ -> Core TH.KindQ -> DsM (Core TH.TypeQ)+repTSig (MkC ty) (MkC ki) = rep2 sigTName [ty, ki]++repTequality :: DsM (Core TH.TypeQ)+repTequality = rep2 equalityTName []++repTPromotedList :: [Core TH.TypeQ] -> DsM (Core TH.TypeQ)+repTPromotedList []     = repPromotedNilTyCon+repTPromotedList (t:ts) = do  { tcon <- repPromotedConsTyCon+                              ; f <- repTapp tcon t+                              ; t' <- repTPromotedList ts+                              ; repTapp f t'+                              }++repTLit :: Core TH.TyLitQ -> DsM (Core TH.TypeQ)+repTLit (MkC lit) = rep2 litTName [lit]++repTWildCard :: DsM (Core TH.TypeQ)+repTWildCard = rep2 wildCardTName []++repTImplicitParam :: Core String -> Core TH.TypeQ -> DsM (Core TH.TypeQ)+repTImplicitParam (MkC n) (MkC e) = rep2 implicitParamTName [n, e]++repTStar :: DsM (Core TH.TypeQ)+repTStar = rep2 starKName []++repTConstraint :: DsM (Core TH.TypeQ)+repTConstraint = rep2 constraintKName []++--------- Type constructors --------------++repNamedTyCon :: Core TH.Name -> DsM (Core TH.TypeQ)+repNamedTyCon (MkC s) = rep2 conTName [s]++repTInfix :: Core TH.TypeQ -> Core TH.Name -> Core TH.TypeQ+             -> DsM (Core TH.TypeQ)+repTInfix (MkC t1) (MkC name) (MkC t2) = rep2 infixTName [t1,name,t2]++repTupleTyCon :: Int -> DsM (Core TH.TypeQ)+-- Note: not Core Int; it's easier to be direct here+repTupleTyCon i = do dflags <- getDynFlags+                     rep2 tupleTName [mkIntExprInt dflags i]++repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ)+-- Note: not Core Int; it's easier to be direct here+repUnboxedTupleTyCon i = do dflags <- getDynFlags+                            rep2 unboxedTupleTName [mkIntExprInt dflags i]++repUnboxedSumTyCon :: TH.SumArity -> DsM (Core TH.TypeQ)+-- Note: not Core TH.SumArity; it's easier to be direct here+repUnboxedSumTyCon arity = do dflags <- getDynFlags+                              rep2 unboxedSumTName [mkIntExprInt dflags arity]++repArrowTyCon :: DsM (Core TH.TypeQ)+repArrowTyCon = rep2 arrowTName []++repListTyCon :: DsM (Core TH.TypeQ)+repListTyCon = rep2 listTName []++repPromotedDataCon :: Core TH.Name -> DsM (Core TH.TypeQ)+repPromotedDataCon (MkC s) = rep2 promotedTName [s]++repPromotedTupleTyCon :: Int -> DsM (Core TH.TypeQ)+repPromotedTupleTyCon i = do dflags <- getDynFlags+                             rep2 promotedTupleTName [mkIntExprInt dflags i]++repPromotedNilTyCon :: DsM (Core TH.TypeQ)+repPromotedNilTyCon = rep2 promotedNilTName []++repPromotedConsTyCon :: DsM (Core TH.TypeQ)+repPromotedConsTyCon = rep2 promotedConsTName []++------------ TyVarBndrs -------------------++repPlainTV :: Core TH.Name -> DsM (Core TH.TyVarBndrQ)+repPlainTV (MkC nm) = rep2 plainTVName [nm]++repKindedTV :: Core TH.Name -> Core TH.KindQ -> DsM (Core TH.TyVarBndrQ)+repKindedTV (MkC nm) (MkC ki) = rep2 kindedTVName [nm, ki]++----------------------------------------------------------+--       Type family result signature++repNoSig :: DsM (Core TH.FamilyResultSigQ)+repNoSig = rep2 noSigName []++repKindSig :: Core TH.KindQ -> DsM (Core TH.FamilyResultSigQ)+repKindSig (MkC ki) = rep2 kindSigName [ki]++repTyVarSig :: Core TH.TyVarBndrQ -> DsM (Core TH.FamilyResultSigQ)+repTyVarSig (MkC bndr) = rep2 tyVarSigName [bndr]++----------------------------------------------------------+--              Literals++repLiteral :: HsLit GhcRn -> DsM (Core TH.Lit)+repLiteral (HsStringPrim _ bs)+  = do dflags   <- getDynFlags+       word8_ty <- lookupType word8TyConName+       let w8s = unpack bs+           w8s_expr = map (\w8 -> mkCoreConApps word8DataCon+                                  [mkWordLit dflags (toInteger w8)]) w8s+       rep2 stringPrimLName [mkListExpr word8_ty w8s_expr]+repLiteral lit+  = do lit' <- case lit of+                   HsIntPrim _ i    -> mk_integer i+                   HsWordPrim _ w   -> mk_integer w+                   HsInt _ i        -> mk_integer (il_value i)+                   HsFloatPrim _ r  -> mk_rational r+                   HsDoublePrim _ r -> mk_rational r+                   HsCharPrim _ c   -> mk_char c+                   _ -> return lit+       lit_expr <- dsLit lit'+       case mb_lit_name of+          Just lit_name -> rep2 lit_name [lit_expr]+          Nothing -> notHandled "Exotic literal" (ppr lit)+  where+    mb_lit_name = case lit of+                 HsInteger _ _ _  -> Just integerLName+                 HsInt _ _        -> Just integerLName+                 HsIntPrim _ _    -> Just intPrimLName+                 HsWordPrim _ _   -> Just wordPrimLName+                 HsFloatPrim _ _  -> Just floatPrimLName+                 HsDoublePrim _ _ -> Just doublePrimLName+                 HsChar _ _       -> Just charLName+                 HsCharPrim _ _   -> Just charPrimLName+                 HsString _ _     -> Just stringLName+                 HsRat _ _ _      -> Just rationalLName+                 _                -> Nothing++mk_integer :: Integer -> DsM (HsLit GhcRn)+mk_integer  i = do integer_ty <- lookupType integerTyConName+                   return $ HsInteger NoSourceText i integer_ty++mk_rational :: FractionalLit -> DsM (HsLit GhcRn)+mk_rational r = do rat_ty <- lookupType rationalTyConName+                   return $ HsRat noExt r rat_ty+mk_string :: FastString -> DsM (HsLit GhcRn)+mk_string s = return $ HsString NoSourceText s++mk_char :: Char -> DsM (HsLit GhcRn)+mk_char c = return $ HsChar NoSourceText c++repOverloadedLiteral :: HsOverLit GhcRn -> DsM (Core TH.Lit)+repOverloadedLiteral (OverLit { ol_val = val})+  = do { lit <- mk_lit val; repLiteral lit }+        -- The type Rational will be in the environment, because+        -- the smart constructor 'TH.Syntax.rationalL' uses it in its type,+        -- and rationalL is sucked in when any TH stuff is used+repOverloadedLiteral XOverLit{} = panic "repOverloadedLiteral"++mk_lit :: OverLitVal -> DsM (HsLit GhcRn)+mk_lit (HsIntegral i)     = mk_integer  (il_value i)+mk_lit (HsFractional f)   = mk_rational f+mk_lit (HsIsString _ s)   = mk_string   s++repNameS :: Core String -> DsM (Core TH.Name)+repNameS (MkC name) = rep2 mkNameSName [name]++--------------- Miscellaneous -------------------++repGensym :: Core String -> DsM (Core (TH.Q TH.Name))+repGensym (MkC lit_str) = rep2 newNameName [lit_str]++repBindQ :: Type -> Type        -- a and b+         -> Core (TH.Q a) -> Core (a -> TH.Q b) -> DsM (Core (TH.Q b))+repBindQ ty_a ty_b (MkC x) (MkC y)+  = rep2 bindQName [Type ty_a, Type ty_b, x, y]++repSequenceQ :: Type -> Core [TH.Q a] -> DsM (Core (TH.Q [a]))+repSequenceQ ty_a (MkC list)+  = rep2 sequenceQName [Type ty_a, list]++repUnboundVar :: Core TH.Name -> DsM (Core TH.ExpQ)+repUnboundVar (MkC name) = rep2 unboundVarEName [name]++repOverLabel :: FastString -> DsM (Core TH.ExpQ)+repOverLabel fs = do+                    (MkC s) <- coreStringLit $ unpackFS fs+                    rep2 labelEName [s]+++------------ Lists -------------------+-- turn a list of patterns into a single pattern matching a list++repList :: Name -> (a  -> DsM (Core b))+                    -> [a] -> DsM (Core [b])+repList tc_name f args+  = do { args1 <- mapM f args+       ; coreList tc_name args1 }++coreList :: Name    -- Of the TyCon of the element type+         -> [Core a] -> DsM (Core [a])+coreList tc_name es+  = do { elt_ty <- lookupType tc_name; return (coreList' elt_ty es) }++coreList' :: Type       -- The element type+          -> [Core a] -> Core [a]+coreList' elt_ty es = MkC (mkListExpr elt_ty (map unC es ))++nonEmptyCoreList :: [Core a] -> Core [a]+  -- The list must be non-empty so we can get the element type+  -- Otherwise use coreList+nonEmptyCoreList []           = panic "coreList: empty argument"+nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs))++coreStringLit :: String -> DsM (Core String)+coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }++------------------- Maybe ------------------++repMaybe :: Name -> (a -> DsM (Core b))+                    -> Maybe a -> DsM (Core (Maybe b))+repMaybe tc_name _ Nothing   = coreNothing tc_name+repMaybe tc_name f (Just es) = coreJust tc_name =<< f es++-- | Construct Core expression for Nothing of a given type name+coreNothing :: Name        -- ^ Name of the TyCon of the element type+            -> DsM (Core (Maybe a))+coreNothing tc_name =+    do { elt_ty <- lookupType tc_name; return (coreNothing' elt_ty) }++-- | Construct Core expression for Nothing of a given type+coreNothing' :: Type       -- ^ The element type+             -> Core (Maybe a)+coreNothing' elt_ty = MkC (mkNothingExpr elt_ty)++-- | Store given Core expression in a Just of a given type name+coreJust :: Name        -- ^ Name of the TyCon of the element type+         -> Core a -> DsM (Core (Maybe a))+coreJust tc_name es+  = do { elt_ty <- lookupType tc_name; return (coreJust' elt_ty es) }++-- | Store given Core expression in a Just of a given type+coreJust' :: Type       -- ^ The element type+          -> Core a -> Core (Maybe a)+coreJust' elt_ty es = MkC (mkJustExpr elt_ty (unC es))++------------------- Maybe Lists ------------------++repMaybeList :: Name -> (a -> DsM (Core b))+                        -> Maybe [a] -> DsM (Core (Maybe [b]))+repMaybeList tc_name _ Nothing = coreNothingList tc_name+repMaybeList tc_name f (Just args)+  = do { elt_ty <- lookupType tc_name+       ; args1 <- mapM f args+       ; return $ coreJust' (mkListTy elt_ty) (coreList' elt_ty args1) }++coreNothingList :: Name -> DsM (Core (Maybe [a]))+coreNothingList tc_name+  = do { elt_ty <- lookupType tc_name+       ; return $ coreNothing' (mkListTy elt_ty) }++coreJustList :: Name -> Core [a] -> DsM (Core (Maybe [a]))+coreJustList tc_name args+  = do { elt_ty <- lookupType tc_name+       ; return $ coreJust' (mkListTy elt_ty) args }++------------ Literals & Variables -------------------++coreIntLit :: Int -> DsM (Core Int)+coreIntLit i = do dflags <- getDynFlags+                  return (MkC (mkIntExprInt dflags i))++coreIntegerLit :: Integer -> DsM (Core Integer)+coreIntegerLit i = fmap MkC (mkIntegerExpr i)++coreVar :: Id -> Core TH.Name   -- The Id has type Name+coreVar id = MkC (Var id)++----------------- Failure -----------------------+notHandledL :: SrcSpan -> String -> SDoc -> DsM a+notHandledL loc what doc+  | isGoodSrcSpan loc+  = putSrcSpanDs loc $ notHandled what doc+  | otherwise+  = notHandled what doc++notHandled :: String -> SDoc -> DsM a+notHandled what doc = failWithDs msg+  where+    msg = hang (text what <+> text "not (yet) handled by Template Haskell")+             2 doc
+ compiler/deSugar/DsMonad.hs view
@@ -0,0 +1,628 @@+{-+(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 EvVars and term constraints in local environment+        getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,++        -- Iterations for pm checking+        incrCheckPmIterDs, resetPmIterDs, 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 HsSyn+import TcIface+import TcMType ( checkForLevPolyX, formatLevPolyErr )+import PrelNames+import RdrName+import HscTypes+import Bag+import BasicTypes ( Origin )+import DataCon+import ConLike+import TyCon+import PmExpr+import Id+import Module+import Outputable+import SrcLoc+import Type+import UniqSupply+import Name+import NameEnv+import DynFlags+import ErrUtils+import FastString+import Var (EvVar)+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 { pm_iter_var <- liftIO $ newIORef 0+       ; 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 pm_iter_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 { pm_iter_var <- newIORef 0+       ; 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 pm_iter_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 Int -> IORef CostCentreState+         -> [CompleteMatch] -> (DsGblEnv, DsLclEnv)+mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar 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_dicts   = emptyBag+                           , dsl_tm_cs   = emptyBag+                           , dsl_pm_iter = pmvar+                           }+    in (gbl_env, lcl_env)+++{-+************************************************************************+*                                                                      *+                Operations in the monad+*                                                                      *+************************************************************************++And all this mysterious stuff is so we can occasionally reach out and+grab one or more names.  @newLocalDs@ isn't exported---exported+functions are defined with it.  The difference in name-strings makes+it easier to read debugging output.++Note [Levity polymorphism checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+According to the "Levity Polymorphism" paper (PLDI '17), levity+polymorphism is forbidden in precisely two places: in the type of a bound+term-level argument and in the type of an argument to a function. The paper+explains it more fully, but briefly: expressions in these contexts need to be+stored in registers, and it's hard (read, impossible) to store something+that's levity polymorphic.++We cannot check for bad levity polymorphism conveniently in the type checker,+because we can't tell, a priori, which levity metavariables will be solved.+At one point, I (Richard) thought we could check in the zonker, but it's hard+to know where precisely are the abstracted variables and the arguments. So+we check in the desugarer, the only place where we can see the Core code and+still report respectable syntax to the user. This covers the vast majority+of cases; see calls to DsMonad.dsNoLevPoly and friends.++Levity polymorphism is also prohibited in the types of binders, and the+desugarer checks for this in GHC-generated Ids. (The zonker handles+the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP.+The newSysLocalDs variant is used in the vast majority of cases where+the binder is obviously not levity polymorphic, omitting the check.+It would be nice to ASSERT that there is no levity polymorphism here,+but we can't, because of the fixM in DsArrows. It's all OK, though:+Core Lint will catch an error here.++However, the desugarer is the wrong place for certain checks. In particular,+the desugarer can't report a sensible error message if an HsWrapper is malformed.+After all, GHC itself produced the HsWrapper. So we store some message text+in the appropriate HsWrappers (e.g. WpFun) that we can print out in the+desugarer.++There are a few more checks in places where Core is generated outside the+desugarer. For example, in datatype and class declarations, where levity+polymorphism is checked for during validity checking. It would be nice to+have one central place for all this, but that doesn't seem possible while+still reporting nice error messages.++-}++-- Make a new Id with the same print name, but different type, and new unique+newUniqueId :: Id -> Type -> DsM Id+newUniqueId id = mk_local (occNameFS (nameOccName (idName id)))++duplicateLocalDs :: Id -> DsM Id+duplicateLocalDs old_local+  = do  { uniq <- newUnique+        ; return (setIdUnique old_local uniq) }++newPredVarDs :: PredType -> DsM Var+newPredVarDs pred+ = newSysLocalDs pred++newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id+newSysLocalDsNoLP  = mk_local (fsLit "ds")++-- this variant should be used when the caller can be sure that the variable type+-- is not levity-polymorphic. It is necessary when the type is knot-tied because+-- of the fixM used in DsArrows. See Note [Levity polymorphism checking]+newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds")+newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail")+  -- the fail variable is used only in a situation where we can tell that+  -- levity-polymorphism is impossible.++newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id]+newSysLocalsDsNoLP = mapM newSysLocalDsNoLP+newSysLocalsDs = mapM newSysLocalDs++mk_local :: FastString -> Type -> DsM Id+mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>+                                      ppr ty)  -- could improve the msg with another+                                               -- parameter indicating context+                    ; mkSysLocalOrCoVarM fs ty }++{-+We can also reach out and either set/grab location information from+the @SrcSpan@ being carried around.+-}++getGhcModeDs :: DsM GhcMode+getGhcModeDs =  getDynFlags >>= return . ghcMode++-- | Get in-scope type constraints (pm check)+getDictsDs :: DsM (Bag EvVar)+getDictsDs = do { env <- getLclEnv; return (dsl_dicts env) }++-- | Add in-scope type constraints (pm check)+addDictsDs :: Bag EvVar -> DsM a -> DsM a+addDictsDs ev_vars+  = updLclEnv (\env -> env { dsl_dicts = unionBags ev_vars (dsl_dicts env) })++-- | Get in-scope term constraints (pm check)+getTmCsDs :: DsM (Bag SimpleEq)+getTmCsDs = do { env <- getLclEnv; return (dsl_tm_cs env) }++-- | Add in-scope term constraints (pm check)+addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a+addTmCsDs tm_cs+  = updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) })++-- | Increase the counter for elapsed pattern match check iterations.+-- If the current counter is already over the limit, fail+incrCheckPmIterDs :: DsM Int+incrCheckPmIterDs = do+  env <- getLclEnv+  cnt <- readTcRef (dsl_pm_iter env)+  max_iters <- maxPmCheckIterations <$> getDynFlags+  if cnt >= max_iters+    then failM+    else updTcRef (dsl_pm_iter env) (+1)+  return cnt++-- | Reset the counter for pattern match check iterations to zero+resetPmIterDs :: DsM ()+resetPmIterDs = do { env <- getLclEnv; writeTcRef (dsl_pm_iter env) 0 }++getSrcSpanDs :: DsM SrcSpan+getSrcSpanDs = do { env <- getLclEnv+                  ; return (RealSrcSpan (dsl_loc env)) }++putSrcSpanDs :: SrcSpan -> DsM a -> DsM a+putSrcSpanDs (UnhelpfulSpan {}) thing_inside+  = thing_inside+putSrcSpanDs (RealSrcSpan real_span) thing_inside+  = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside++-- | Emit a warning for the current source location+-- NB: Warns whether or not -Wxyz is set+warnDs :: WarnReason -> SDoc -> DsM ()+warnDs reason warn+  = do { env <- getGblEnv+       ; loc <- getSrcSpanDs+       ; dflags <- getDynFlags+       ; let msg = makeIntoWarning reason $+                   mkWarnMsg dflags loc (ds_unqual env) warn+       ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }++-- | Emit a warning only if the correct WarnReason is set in the DynFlags+warnIfSetDs :: WarningFlag -> SDoc -> DsM ()+warnIfSetDs flag warn+  = whenWOptM flag $+    warnDs (Reason flag) warn++errDs :: SDoc -> DsM ()+errDs err+  = do  { env <- getGblEnv+        ; loc <- getSrcSpanDs+        ; dflags <- getDynFlags+        ; let msg = mkErrMsg dflags loc (ds_unqual env) err+        ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) }++-- | Issue an error, but return the expression for (), so that we can continue+-- reporting errors.+errDsCoreExpr :: SDoc -> DsM CoreExpr+errDsCoreExpr err+  = do { errDs err+       ; return unitExpr }++failWithDs :: SDoc -> DsM a+failWithDs err+  = do  { errDs err+        ; failM }++failDs :: DsM a+failDs = failM++-- (askNoErrsDs m) runs m+-- If m fails,+--    then (askNoErrsDs m) fails+-- If m succeeds with result r,+--    then (askNoErrsDs m) succeeds with result (r, b),+--         where b is True iff m generated no errors+-- Regardless of success or failure,+--   propagate any errors/warnings generated by m+--+-- c.f. TcRnMonad.askNoErrs+askNoErrsDs :: DsM a -> DsM (a, Bool)+askNoErrsDs thing_inside+ = do { errs_var <- newMutVar emptyMessages+      ; env <- getGblEnv+      ; mb_res <- tryM $  -- Be careful to catch exceptions+                          -- so that we propagate errors correctly+                          -- (#13642)+                  setGblEnv (env { ds_msgs = errs_var }) $+                  thing_inside++      -- Propagate errors+      ; msgs@(warns, errs) <- readMutVar errs_var+      ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))++      -- And return+      ; case mb_res of+           Left _    -> failM+           Right res -> do { dflags <- getDynFlags+                           ; let errs_found = errorsFound dflags msgs+                           ; return (res, not errs_found) } }++mkPrintUnqualifiedDs :: DsM PrintUnqualified+mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv++instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where+    lookupThing = dsLookupGlobal++dsLookupGlobal :: Name -> DsM TyThing+-- Very like TcEnv.tcLookupGlobal+dsLookupGlobal name+  = do  { env <- getGblEnv+        ; setEnvs (ds_if_env env)+                  (tcIfaceGlobal name) }++dsLookupGlobalId :: Name -> DsM Id+dsLookupGlobalId name+  = tyThingId <$> dsLookupGlobal name++dsLookupTyCon :: Name -> DsM TyCon+dsLookupTyCon name+  = tyThingTyCon <$> dsLookupGlobal name++dsLookupDataCon :: Name -> DsM DataCon+dsLookupDataCon name+  = tyThingDataCon <$> dsLookupGlobal name++dsLookupConLike :: Name -> DsM ConLike+dsLookupConLike name+  = tyThingConLike <$> dsLookupGlobal name+++dsGetFamInstEnvs :: DsM FamInstEnvs+-- Gets both the external-package inst-env+-- and the home-pkg inst env (includes module being compiled)+dsGetFamInstEnvs+  = do { eps <- getEps; env <- getGblEnv+       ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }++dsGetMetaEnv :: DsM (NameEnv DsMetaVal)+dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }++-- | The @COMPLETE@ pragmas provided by the user for a given `TyCon`.+dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]+dsGetCompleteMatches tc = do+  eps <- getEps+  env <- getGblEnv+  let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc+      eps_matches_list = lookup_completes $ eps_complete_matches eps+      env_matches_list = lookup_completes $ ds_complete_matches env+  return $ eps_matches_list ++ env_matches_list++dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)+dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }++dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a+dsExtendMetaEnv menv thing_inside+  = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside++discardWarningsDs :: DsM a -> DsM a+-- Ignore warnings inside the thing inside;+-- used to ignore inaccessable cases etc. inside generated code+discardWarningsDs thing_inside+  = do  { env <- getGblEnv+        ; old_msgs <- readTcRef (ds_msgs env)++        ; result <- thing_inside++        -- Revert messages to old_msgs+        ; writeTcRef (ds_msgs env) old_msgs++        ; return result }++-- | Fail with an error message if the type is levity polymorphic.+dsNoLevPoly :: Type -> SDoc -> DsM ()+-- See Note [Levity polymorphism checking]+dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty++-- | Check an expression for levity polymorphism, failing if it is+-- levity polymorphic.+dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()+-- See Note [Levity polymorphism checking]+dsNoLevPolyExpr e doc+  | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)+  | otherwise       = return ()++-- | Runs the thing_inside. If there are no errors, then returns the expr+-- given. Otherwise, returns unitExpr. This is useful for doing a bunch+-- of levity polymorphism checks and then avoiding making a core App.+-- (If we make a core App on a levity polymorphic argument, detecting how+-- to handle the let/app invariant might call isUnliftedType, which panics+-- on a levity polymorphic type.)+-- See #12709 for an example of why this machinery is necessary.+dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr+dsWhenNoErrs thing_inside mk_expr+  = do { (result, no_errs) <- askNoErrsDs thing_inside+       ; return $ if no_errs+                  then mk_expr result+                  else unitExpr }++-- | Inject a trace message into the compiled program. Whereas+-- pprTrace prints out information *while compiling*, pprRuntimeTrace+-- captures that information and causes it to be printed *at runtime*+-- using Debug.Trace.trace.+--+--   pprRuntimeTrace hdr doc expr+--+-- will produce an expression that looks like+--+--   trace (hdr + doc) expr+--+-- When using this to debug a module that Debug.Trace depends on,+-- it is necessary to import {-# SOURCE #-} Debug.Trace () in that+-- module. We could avoid this inconvenience by wiring in Debug.Trace.trace,+-- but that doesn't seem worth the effort and maintenance cost.+pprRuntimeTrace :: String   -- ^ header+                -> SDoc     -- ^ information to output+                -> CoreExpr -- ^ expression+                -> DsM CoreExpr+pprRuntimeTrace str doc expr = do+  traceId <- dsLookupGlobalId traceName+  unpackCStringId <- dsLookupGlobalId unpackCStringName+  dflags <- getDynFlags+  let message :: CoreExpr+      message = App (Var unpackCStringId) $+                Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc)+  return $ mkApps (Var traceId) [Type (exprType expr), message, expr]
+ compiler/deSugar/DsUsage.hs view
@@ -0,0 +1,373 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++module DsUsage (+    -- * Dependency/fingerprinting code (used by MkIface)+    mkUsageInfo, mkUsedNames, mkDependencies+    ) where++#include "HsVersions.h"++import GhcPrelude++import DynFlags+import HscTypes+import TcRnTypes+import Name+import NameSet+import Module+import Outputable+import Util+import UniqSet+import UniqFM+import Fingerprint+import Maybes+import Packages+import Finder++import Control.Monad (filterM)+import Data.List+import Data.IORef+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Set as Set+import System.Directory+import System.FilePath++{- Note [Module self-dependency]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++RnNames.calculateAvails asserts the invariant that a module must not occur in+its own dep_orphs or dep_finsts. However, if we aren't careful this can occur+in the presence of hs-boot files: Consider that we have two modules, A and B,+both with hs-boot files,++    A.hs contains a SOURCE import of B B.hs-boot contains a SOURCE import of A+    A.hs-boot declares an orphan instance A.hs defines the orphan instance++In this case, B's dep_orphs will contain A due to its SOURCE import of A.+Consequently, A will contain itself in its imp_orphs due to its import of B.+This fact would end up being recorded in A's interface file. This would then+break the invariant asserted by calculateAvails that a module does not itself in+its dep_orphs. This was the cause of #14128.++-}++-- | Extract information from the rename and typecheck phases to produce+-- a dependencies information for the module being compiled.+--+-- The first argument is additional dependencies from plugins+mkDependencies :: InstalledUnitId -> [Module] -> TcGblEnv -> IO Dependencies+mkDependencies iuid pluginModules+          (TcGblEnv{ tcg_mod = mod,+                    tcg_imports = imports,+                    tcg_th_used = th_var+                  })+ = do+      -- Template Haskell used?+      let (dep_plgins, ms) = unzip [ (moduleName mn, mn) | mn <- pluginModules ]+          plugin_dep_pkgs = filter (/= iuid) (map (toInstalledUnitId . moduleUnitId) ms)+      th_used <- readIORef th_var+      let dep_mods = modDepsElts (delFromUFM (imp_dep_mods imports)+                                             (moduleName mod))+                -- M.hi-boot can be in the imp_dep_mods, but we must remove+                -- it before recording the modules on which this one depends!+                -- (We want to retain M.hi-boot in imp_dep_mods so that+                --  loadHiBootInterface can see if M's direct imports depend+                --  on M.hi-boot, and hence that we should do the hi-boot consistency+                --  check.)++          dep_orphs = filter (/= mod) (imp_orphs imports)+                -- We must also remove self-references from imp_orphs. See+                -- Note [Module self-dependency]++          raw_pkgs = foldr Set.insert (imp_dep_pkgs imports) plugin_dep_pkgs++          pkgs | th_used   = Set.insert (toInstalledUnitId thUnitId) raw_pkgs+               | otherwise = raw_pkgs++          -- Set the packages required to be Safe according to Safe Haskell.+          -- See Note [RnNames . Tracking Trust Transitively]+          sorted_pkgs = sort (Set.toList pkgs)+          trust_pkgs  = imp_trust_pkgs imports+          dep_pkgs'   = map (\x -> (x, x `Set.member` trust_pkgs)) sorted_pkgs++      return Deps { dep_mods   = dep_mods,+                    dep_pkgs   = dep_pkgs',+                    dep_orphs  = dep_orphs,+                    dep_plgins = dep_plgins,+                    dep_finsts = sortBy stableModuleCmp (imp_finsts imports) }+                    -- sort to get into canonical order+                    -- NB. remember to use lexicographic ordering++mkUsedNames :: TcGblEnv -> NameSet+mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus++mkUsageInfo :: HscEnv -> Module -> ImportedMods -> NameSet -> [FilePath]+            -> [(Module, Fingerprint)] -> [ModIface] -> IO [Usage]+mkUsageInfo hsc_env this_mod dir_imp_mods used_names dependent_files merged+  pluginModules+  = do+    eps <- hscEPS hsc_env+    hashes <- mapM getFileHash dependent_files+    plugin_usages <- mapM (mkPluginUsage hsc_env) pluginModules+    let mod_usages = mk_mod_usage_info (eps_PIT eps) hsc_env this_mod+                                       dir_imp_mods used_names+        usages = mod_usages ++ [ UsageFile { usg_file_path = f+                                           , usg_file_hash = hash }+                               | (f, hash) <- zip dependent_files hashes ]+                            ++ [ UsageMergedRequirement+                                    { usg_mod = mod,+                                      usg_mod_hash = hash+                                    }+                               | (mod, hash) <- merged ]+                            ++ concat plugin_usages+    usages `seqList` return usages+    -- seq the list of Usages returned: occasionally these+    -- don't get evaluated for a while and we can end up hanging on to+    -- the entire collection of Ifaces.++{- Note [Plugin dependencies]+Modules for which plugins were used in the compilation process, should be+recompiled whenever one of those plugins changes. But how do we know if a+plugin changed from the previous time a module was compiled?++We could try storing the fingerprints of the interface files of plugins in+the interface file of the module. And see if there are changes between+compilation runs. However, this is pretty much a non-option because interface+fingerprints of plugin modules are fairly stable, unless you compile plugins+with optimisations turned on, and give basically all binders an INLINE pragma.++So instead:++  * For plugins that were built locally: we store the filepath and hash of the+    object files of the module with the `plugin` binder, and the object files of+    modules that are dependencies of the plugin module and belong to the same+    `UnitId` as the plugin+  * For plugins in an external package: we store the filepath and hash of+    the dynamic library containing the plugin module.++During recompilation we then compare the hashes of those files again to see+if anything has changed.++One issue with this approach is that object files are currently (GHC 8.6.1)+not created fully deterministicly, which could sometimes induce accidental+recompilation of a module for which plugins were used in the compile process.++One way to improve this is to either:++  * Have deterministic object file creation+  * Create and store implementation hashes, which would be based on the Core+    of the module and the implementation hashes of its dependencies, and then+    compare implementation hashes for recompilation. Creation of implementation+    hashes is however potentially expensive.+-}+mkPluginUsage :: HscEnv -> ModIface -> IO [Usage]+mkPluginUsage hsc_env pluginModule+  = case lookupPluginModuleWithSuggestions dflags pNm Nothing of+    LookupFound _ pkg -> do+    -- The plugin is from an external package:+    -- search for the library files containing the plugin.+      let searchPaths = collectLibraryPaths dflags [pkg]+          useDyn = WayDyn `elem` ways dflags+          suffix = if useDyn then soExt platform else "a"+          libLocs = [ searchPath </> "lib" ++ libLoc <.> suffix+                    | searchPath <- searchPaths+                    , libLoc     <- packageHsLibs dflags pkg+                    ]+          -- we also try to find plugin library files by adding WayDyn way,+          -- if it isn't already present (see trac #15492)+          paths =+            if useDyn+              then libLocs+              else+                let dflags'  = updateWays (addWay' WayDyn dflags)+                    dlibLocs = [ searchPath </> mkHsSOName platform dlibLoc+                               | searchPath <- searchPaths+                               , dlibLoc    <- packageHsLibs dflags' pkg+                               ]+                in libLocs ++ dlibLocs+      files <- filterM doesFileExist paths+      case files of+        [] ->+          pprPanic+             ( "mkPluginUsage: missing plugin library, tried:\n"+              ++ unlines paths+             )+             (ppr pNm)+        _  -> mapM hashFile (nub files)+    _ -> do+      foundM <- findPluginModule hsc_env pNm+      case foundM of+      -- The plugin was built locally: look up the object file containing+      -- the `plugin` binder, and all object files belong to modules that are+      -- transitive dependencies of the plugin that belong to the same package.+        Found ml _ -> do+          pluginObject <- hashFile (ml_obj_file ml)+          depObjects   <- catMaybes <$> mapM lookupObjectFile deps+          return (nub (pluginObject : depObjects))+        _ -> pprPanic "mkPluginUsage: no object file found" (ppr pNm)+  where+    dflags   = hsc_dflags hsc_env+    platform = targetPlatform dflags+    pNm      = moduleName (mi_module pluginModule)+    pPkg     = moduleUnitId (mi_module pluginModule)+    deps     = map fst (dep_mods (mi_deps pluginModule))++    -- Lookup object file for a plugin dependency,+    -- from the same package as the plugin.+    lookupObjectFile nm = do+      foundM <- findImportedModule hsc_env nm Nothing+      case foundM of+        Found ml m+          | moduleUnitId m == pPkg -> Just <$> hashFile (ml_obj_file ml)+          | otherwise              -> return Nothing+        _ -> pprPanic "mkPluginUsage: no object for dependency"+                      (ppr pNm <+> ppr nm)++    hashFile f = do+      fExist <- doesFileExist f+      if fExist+         then do+            h <- getFileHash f+            return (UsageFile f h)+         else pprPanic "mkPluginUsage: file not found" (ppr pNm <+> text f)++mk_mod_usage_info :: PackageIfaceTable+              -> HscEnv+              -> Module+              -> ImportedMods+              -> NameSet+              -> [Usage]+mk_mod_usage_info pit hsc_env this_mod direct_imports used_names+  = mapMaybe mkUsage usage_mods+  where+    hpt = hsc_HPT hsc_env+    dflags = hsc_dflags hsc_env+    this_pkg = thisPackage dflags++    used_mods    = moduleEnvKeys ent_map+    dir_imp_mods = moduleEnvKeys direct_imports+    all_mods     = used_mods ++ filter (`notElem` used_mods) dir_imp_mods+    usage_mods   = sortBy stableModuleCmp all_mods+                        -- canonical order is imported, to avoid interface-file+                        -- wobblage.++    -- ent_map groups together all the things imported and used+    -- from a particular module+    ent_map :: ModuleEnv [OccName]+    ent_map  = nonDetFoldUniqSet add_mv emptyModuleEnv used_names+     -- nonDetFoldUFM is OK here. If you follow the logic, we sort by OccName+     -- in ent_hashs+     where+      add_mv name mv_map+        | isWiredInName name = mv_map  -- ignore wired-in names+        | otherwise+        = case nameModule_maybe name of+             Nothing  -> ASSERT2( isSystemName name, ppr name ) mv_map+                -- See Note [Internal used_names]++             Just mod ->+                -- See Note [Identity versus semantic module]+                let mod' = if isHoleModule mod+                            then mkModule this_pkg (moduleName mod)+                            else mod+                -- This lambda function is really just a+                -- specialised (++); originally came about to+                -- avoid quadratic behaviour (trac #2680)+                in extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod' [occ]+            where occ = nameOccName name++    -- We want to create a Usage for a home module if+    --  a) we used something from it; has something in used_names+    --  b) we imported it, even if we used nothing from it+    --     (need to recompile if its export list changes: export_fprint)+    mkUsage :: Module -> Maybe Usage+    mkUsage mod+      | isNothing maybe_iface           -- We can't depend on it if we didn't+                                        -- load its interface.+      || mod == this_mod                -- We don't care about usages of+                                        -- things in *this* module+      = Nothing++      | moduleUnitId mod /= this_pkg+      = Just UsagePackageModule{ usg_mod      = mod,+                                 usg_mod_hash = mod_hash,+                                 usg_safe     = imp_safe }+        -- for package modules, we record the module hash only++      | (null used_occs+          && isNothing export_hash+          && not is_direct_import+          && not finsts_mod)+      = Nothing                 -- Record no usage info+        -- for directly-imported modules, we always want to record a usage+        -- on the orphan hash.  This is what triggers a recompilation if+        -- an orphan is added or removed somewhere below us in the future.++      | otherwise+      = Just UsageHomeModule {+                      usg_mod_name = moduleName mod,+                      usg_mod_hash = mod_hash,+                      usg_exports  = export_hash,+                      usg_entities = Map.toList ent_hashs,+                      usg_safe     = imp_safe }+      where+        maybe_iface  = lookupIfaceByModule dflags 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    iface+        hash_env     = mi_hash_fn   iface+        mod_hash     = mi_mod_hash  iface+        export_hash | depend_on_exports = Just (mi_exp_hash 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 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 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+        mkLHsVarPatTup, 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 HsSyn+import TcHsSyn+import TcType( tcSplitTyConApp )+import CoreSyn+import DsMonad++import CoreUtils+import MkCore+import MkId+import Id+import Literal+import TyCon+import DataCon+import PatSyn+import Type+import Coercion+import TysPrim+import TysWiredIn+import BasicTypes+import ConLike+import UniqSet+import UniqSupply+import Module+import PrelNames+import Name( isInternalName )+import Outputable+import SrcLoc+import Util+import DynFlags+import FastString+import qualified GHC.LanguageExtensions as LangExt++import TcEvidence++import Control.Monad    ( zipWithM )++{-+************************************************************************+*                                                                      *+\subsection{ Selecting match variables}+*                                                                      *+************************************************************************++We're about to match against some patterns.  We want to make some+@Ids@ to use as match variables.  If a pattern has an @Id@ readily at+hand, which should indeed be bound to the pattern as a whole, then use it;+otherwise, make one up.+-}++selectSimpleMatchVarL :: LPat GhcTc -> DsM Id+-- Postcondition: the returned Id has an Internal Name+selectSimpleMatchVarL pat = selectMatchVar (unLoc pat)++-- (selectMatchVars ps tys) chooses variables of type tys+-- to use for matching ps against.  If the pattern is a variable,+-- we try to use that, to save inventing lots of fresh variables.+--+-- OLD, but interesting note:+--    But even if it is a variable, its type might not match.  Consider+--      data T a where+--        T1 :: Int -> T Int+--        T2 :: a   -> T a+--+--      f :: T a -> a -> Int+--      f (T1 i) (x::Int) = x+--      f (T2 i) (y::a)   = 0+--    Then we must not choose (x::Int) as the matching variable!+-- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat++selectMatchVars :: [Pat GhcTc] -> DsM [Id]+-- Postcondition: the returned Ids have Internal Names+selectMatchVars ps = mapM selectMatchVar ps++selectMatchVar :: Pat GhcTc -> DsM Id+-- Postcondition: the returned Id has an Internal Name+selectMatchVar (BangPat _ pat) = selectMatchVar (unLoc pat)+selectMatchVar (LazyPat _ pat) = selectMatchVar (unLoc pat)+selectMatchVar (ParPat _ pat)  = selectMatchVar (unLoc pat)+selectMatchVar (VarPat _ var)  = return (localiseId (unLoc var))+                                  -- Note [Localise pattern binders]+selectMatchVar (AsPat _ var _) = return (unLoc var)+selectMatchVar other_pat       = newSysLocalDsNoLP (hsPatType other_pat)+                                  -- OK, better make up one...++{- Note [Localise pattern binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider     module M where+               [Just a] = e+After renaming it looks like+             module M where+               [Just M.a] = e++We don't generalise, since it's a pattern binding, monomorphic, etc,+so after desugaring we may get something like+             M.a = case e of (v:_) ->+                   case v of Just M.a -> M.a+Notice the "M.a" in the pattern; after all, it was in the original+pattern.  However, after optimisation those pattern binders can become+let-binders, and then end up floated to top level.  They have a+different *unique* by then (the simplifier is good about maintaining+proper scoping), but it's BAD to have two top-level bindings with the+External Name M.a, because that turns into two linker symbols for M.a.+It's quite rare for this to actually *happen* -- the only case I know+of is tc003 compiled with the 'hpc' way -- but that only makes it+all the more annoying.++To avoid this, we craftily call 'localiseId' in the desugarer, which+simply turns the External Name for the Id into an Internal one, but+doesn't change the unique.  So the desugarer produces this:+             M.a{r8} = case e of (v:_) ->+                       case v of Just a{r8} -> M.a{r8}+The unique is still 'r8', but the binding site in the pattern+is now an Internal Name.  Now the simplifier's usual mechanisms+will propagate that Name to all the occurrence sites, as well as+un-shadowing it, so we'll get+             M.a{r8} = case e of (v:_) ->+                       case v of Just a{s77} -> a{s77}+In fact, even CoreSubst.simplOptExpr will do this, and simpleOptExpr+runs on the output of the desugarer, so all is well by the end of+the desugaring pass.++See also Note [MatchIds] in Match.hs++************************************************************************+*                                                                      *+* type synonym EquationInfo and access functions for its pieces        *+*                                                                      *+************************************************************************+\subsection[EquationInfo-synonym]{@EquationInfo@: a useful synonym}++The ``equation info'' used by @match@ is relatively complicated and+worthy of a type synonym and a few handy functions.+-}++firstPat :: EquationInfo -> Pat GhcTc+firstPat eqn = ASSERT( notNull (eqn_pats eqn) ) head (eqn_pats eqn)++shiftEqns :: [EquationInfo] -> [EquationInfo]+-- Drop the first pattern in each equation+shiftEqns eqns = [ eqn { eqn_pats = tail (eqn_pats eqn) } | eqn <- eqns ]++-- Functions on MatchResults++matchCanFail :: MatchResult -> Bool+matchCanFail (MatchResult CanFail _)  = True+matchCanFail (MatchResult CantFail _) = False++alwaysFailMatchResult :: MatchResult+alwaysFailMatchResult = MatchResult CanFail (\fail -> return fail)++cantFailMatchResult :: CoreExpr -> MatchResult+cantFailMatchResult expr = MatchResult CantFail (\_ -> return expr)++extractMatchResult :: MatchResult -> CoreExpr -> DsM CoreExpr+extractMatchResult (MatchResult CantFail match_fn) _+  = match_fn (error "It can't fail!")++extractMatchResult (MatchResult CanFail match_fn) fail_expr = do+    (fail_bind, if_it_fails) <- mkFailurePair fail_expr+    body <- match_fn if_it_fails+    return (mkCoreLet fail_bind body)+++combineMatchResults :: MatchResult -> MatchResult -> MatchResult+combineMatchResults (MatchResult CanFail      body_fn1)+                    (MatchResult can_it_fail2 body_fn2)+  = MatchResult can_it_fail2 body_fn+  where+    body_fn fail = do body2 <- body_fn2 fail+                      (fail_bind, duplicatable_expr) <- mkFailurePair body2+                      body1 <- body_fn1 duplicatable_expr+                      return (Let fail_bind body1)++combineMatchResults match_result1@(MatchResult CantFail _) _+  = match_result1++adjustMatchResult :: DsWrapper -> MatchResult -> MatchResult+adjustMatchResult encl_fn (MatchResult can_it_fail body_fn)+  = MatchResult can_it_fail (\fail -> encl_fn <$> body_fn fail)++adjustMatchResultDs :: (CoreExpr -> DsM CoreExpr) -> MatchResult -> MatchResult+adjustMatchResultDs encl_fn (MatchResult can_it_fail body_fn)+  = MatchResult can_it_fail (\fail -> encl_fn =<< body_fn fail)++wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr+wrapBinds [] e = e+wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)++wrapBind :: Var -> Var -> CoreExpr -> CoreExpr+wrapBind new old body   -- NB: this function must deal with term+  | new==old    = body  -- variables, type variables or coercion variables+  | otherwise   = Let (NonRec new (varToCoreExpr old)) body++seqVar :: Var -> CoreExpr -> CoreExpr+seqVar var body = Case (Var var) var (exprType body)+                        [(DEFAULT, [], body)]++mkCoLetMatchResult :: CoreBind -> MatchResult -> MatchResult+mkCoLetMatchResult bind = adjustMatchResult (mkCoreLet bind)++-- (mkViewMatchResult var' viewExpr mr) makes the expression+-- let var' = viewExpr in mr+mkViewMatchResult :: Id -> CoreExpr -> MatchResult -> MatchResult+mkViewMatchResult var' viewExpr =+    adjustMatchResult (mkCoreLet (NonRec var' viewExpr))++mkEvalMatchResult :: Id -> Type -> MatchResult -> MatchResult+mkEvalMatchResult var ty+  = adjustMatchResult (\e -> Case (Var var) var ty [(DEFAULT, [], e)])++mkGuardedMatchResult :: CoreExpr -> MatchResult -> MatchResult+mkGuardedMatchResult pred_expr (MatchResult _ body_fn)+  = MatchResult CanFail (\fail -> do body <- body_fn fail+                                     return (mkIfThenElse pred_expr body fail))++mkCoPrimCaseMatchResult :: Id                  -- Scrutinee+                        -> Type                      -- Type of the case+                        -> [(Literal, MatchResult)]  -- Alternatives+                        -> MatchResult               -- Literals are all unlifted+mkCoPrimCaseMatchResult var ty match_alts+  = MatchResult CanFail mk_case+  where+    mk_case fail = do+        alts <- mapM (mk_alt fail) sorted_alts+        return (Case (Var var) var ty ((DEFAULT, [], fail) : alts))++    sorted_alts = sortWith fst match_alts       -- Right order for a Case+    mk_alt fail (lit, MatchResult _ body_fn)+       = ASSERT( not (litIsLifted lit) )+         do body <- body_fn fail+            return (LitAlt lit, [], body)++data CaseAlt a = MkCaseAlt{ alt_pat :: a,+                            alt_bndrs :: [Var],+                            alt_wrapper :: HsWrapper,+                            alt_result :: MatchResult }++mkCoAlgCaseMatchResult+  :: Id                 -- Scrutinee+  -> Type               -- Type of exp+  -> [CaseAlt DataCon]  -- Alternatives (bndrs *include* tyvars, dicts)+  -> MatchResult+mkCoAlgCaseMatchResult var ty match_alts+  | isNewtype  -- Newtype case; use a let+  = ASSERT( null (tail match_alts) && null (tail arg_ids1) )+    mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1++  | otherwise+  = mkDataConCase var ty match_alts+  where+    isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))++        -- [Interesting: because of GADTs, we can't rely on the type of+        --  the scrutinised Id to be sufficiently refined to have a TyCon in it]++    alt1@MkCaseAlt{ alt_bndrs = arg_ids1, alt_result = match_result1 }+      = ASSERT( notNull match_alts ) head match_alts+    -- Stuff for newtype+    arg_id1       = ASSERT( notNull arg_ids1 ) head arg_ids1+    var_ty        = idType var+    (tc, ty_args) = tcSplitTyConApp var_ty      -- Don't look through newtypes+                                                -- (not that splitTyConApp does, these days)+    newtype_rhs = unwrapNewTypeBody tc ty_args (Var var)++mkCoSynCaseMatchResult :: Id -> Type -> CaseAlt PatSyn -> MatchResult+mkCoSynCaseMatchResult var ty alt = MatchResult CanFail $ mkPatSynCase var ty alt++sort_alts :: [CaseAlt DataCon] -> [CaseAlt DataCon]+sort_alts = sortWith (dataConTag . alt_pat)++mkPatSynCase :: Id -> Type -> CaseAlt PatSyn -> CoreExpr -> DsM CoreExpr+mkPatSynCase var ty alt fail = do+    matcher <- dsLExpr $ mkLHsWrap wrapper $+                         nlHsTyApp matcher [getRuntimeRep ty, ty]+    let MatchResult _ mkCont = match_result+    cont <- mkCoreLams bndrs <$> mkCont fail+    return $ mkCoreAppsDs (text "patsyn" <+> ppr var) matcher [Var var, ensure_unstrict cont, Lam voidArgId fail]+  where+    MkCaseAlt{ alt_pat = psyn,+               alt_bndrs = bndrs,+               alt_wrapper = wrapper,+               alt_result = match_result} = alt+    (matcher, needs_void_lam) = patSynMatcher psyn++    -- See Note [Matchers and builders for pattern synonyms] in PatSyns+    -- on these extra Void# arguments+    ensure_unstrict cont | needs_void_lam = Lam voidArgId cont+                         | otherwise      = cont++mkDataConCase :: Id -> Type -> [CaseAlt DataCon] -> MatchResult+mkDataConCase _   _  []            = panic "mkDataConCase: no alternatives"+mkDataConCase var ty alts@(alt1:_) = MatchResult fail_flag mk_case+  where+    con1          = alt_pat alt1+    tycon         = dataConTyCon con1+    data_cons     = tyConDataCons tycon+    match_results = map alt_result alts++    sorted_alts :: [CaseAlt DataCon]+    sorted_alts  = sort_alts alts++    var_ty       = idType var+    (_, ty_args) = tcSplitTyConApp var_ty -- Don't look through newtypes+                                          -- (not that splitTyConApp does, these days)++    mk_case :: CoreExpr -> DsM CoreExpr+    mk_case fail = do+        alts <- mapM (mk_alt fail) sorted_alts+        return $ mkWildCase (Var var) (idType var) ty (mk_default fail ++ alts)++    mk_alt :: CoreExpr -> CaseAlt DataCon -> DsM CoreAlt+    mk_alt fail MkCaseAlt{ alt_pat = con,+                           alt_bndrs = args,+                           alt_result = MatchResult _ body_fn }+      = do { body <- body_fn fail+           ; case dataConBoxer con of {+                Nothing -> return (DataAlt con, args, body) ;+                Just (DCB boxer) ->+        do { us <- newUniqueSupply+           ; let (rep_ids, binds) = initUs_ us (boxer ty_args args)+           ; return (DataAlt con, rep_ids, mkLets binds body) } } }++    mk_default :: CoreExpr -> [CoreAlt]+    mk_default fail | exhaustive_case = []+                    | otherwise       = [(DEFAULT, [], fail)]++    fail_flag :: CanItFail+    fail_flag | exhaustive_case+              = foldr orFail CantFail [can_it_fail | MatchResult can_it_fail _ <- match_results]+              | otherwise+              = CanFail++    mentioned_constructors = mkUniqSet $ map alt_pat alts+    un_mentioned_constructors+        = mkUniqSet data_cons `minusUniqSet` mentioned_constructors+    exhaustive_case = isEmptyUniqSet un_mentioned_constructors++{-+************************************************************************+*                                                                      *+\subsection{Desugarer's versions of some Core functions}+*                                                                      *+************************************************************************+-}++mkErrorAppDs :: Id              -- The error function+             -> Type            -- Type to which it should be applied+             -> SDoc            -- The error message string to pass+             -> DsM CoreExpr++mkErrorAppDs err_id ty msg = do+    src_loc <- getSrcSpanDs+    dflags <- getDynFlags+    let+        full_msg = showSDoc dflags (hcat [ppr src_loc, vbar, msg])+        core_msg = Lit (mkLitString full_msg)+        -- mkLitString returns a result of type String#+    return (mkApps (Var err_id) [Type (getRuntimeRep ty), Type ty, core_msg])++{-+'mkCoreAppDs' and 'mkCoreAppsDs' hand the special-case desugaring of 'seq'.++Note [Desugaring seq (1)]  cf #1031+~~~~~~~~~~~~~~~~~~~~~~~~~+   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 #)++Note [Desugaring seq (2)]  cf #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.++Note [Desugaring seq (3)] cf #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 ty1 `App` Type ty2 `App` arg1) arg2+  | f `hasKey` seqIdKey            -- Note [Desugaring seq (1), (2)]+  = Case arg1 case_bndr ty2 [(DEFAULT,[],arg2)]+  where+    case_bndr = case arg1 of+                   Var v1 | isInternalName (idName v1)+                          -> v1        -- Note [Desugaring seq (2) and (3)]+                   _      -> mkWildValBinder ty1++mkCoreAppDs s fun arg = mkCoreApp s fun arg  -- The rest is done in MkCore++-- NB: No argument can be levity polymorphic+mkCoreAppsDs :: SDoc -> CoreExpr -> [CoreExpr] -> CoreExpr+mkCoreAppsDs s fun args = foldl' (mkCoreAppDs s) fun args++mkCastDs :: CoreExpr -> Coercion -> CoreExpr+-- We define a desugarer-specific version of CoreUtils.mkCast,+-- because in the immediate output of the desugarer, we can have+-- apparently-mis-matched coercions:  E.g.+--     let a = b+--     in (x :: a) |> (co :: b ~ Int)+-- Lint know about type-bindings for let and does not complain+-- So here we do not make the assertion checks that we make in+-- CoreUtils.mkCast; and we do less peephole optimisation too+mkCastDs e co | isReflCo co = e+              | otherwise   = Cast e co++{-+************************************************************************+*                                                                      *+               Tuples and selector bindings+*                                                                      *+************************************************************************++This is used in various places to do with lazy patterns.+For each binder $b$ in the pattern, we create a binding:+\begin{verbatim}+    b = case v of pat' -> b'+\end{verbatim}+where @pat'@ is @pat@ with each binder @b@ cloned into @b'@.++ToDo: making these bindings should really depend on whether there's+much work to be done per binding.  If the pattern is complex, it+should be de-mangled once, into a tuple (and then selected from).+Otherwise the demangling can be in-line in the bindings (as here).++Boring!  Boring!  One error message per binder.  The above ToDo is+even more helpful.  Something very similar happens for pattern-bound+expressions.++Note [mkSelectorBinds]+~~~~~~~~~~~~~~~~~~~~~~+mkSelectorBinds is used to desugar a pattern binding {p = e},+in a binding group:+  let { ...; p = e; ... } in body+where p binds x,y (this list of binders can be empty).+There are two cases.++------ Special case (A) -------+  For a pattern that is just a variable,+     let !x = e in body+  ==>+     let x = e in x `seq` body+  So we return the binding, with 'x' as the variable to seq.++------ Special case (B) -------+  For a pattern that is essentially just a tuple:+      * A product type, so cannot fail+      * Only one level, so that+          - generating multiple matches is fine+          - seq'ing it evaluates the same as matching it+  Then instead we generate+       { v = e+       ; x = case v of p -> x+       ; y = case v of p -> y }+  with 'v' as the variable to force++------ General case (C) -------+  In the general case we generate these bindings:+       let { ...; p = e; ... } in body+  ==>+       let { t = case e of p -> (x,y)+           ; x = case t of (x,y) -> x+           ; y = case t of (x,y) -> y }+       in t `seq` body++  Note that we return 't' as the variable to force if the pattern+  is strict (i.e. with -XStrict or an outermost-bang-pattern)++  Note that (A) /includes/ the situation where++   * The pattern binds exactly one variable+        let !(Just (Just x) = e in body+     ==>+       let { t = case e of Just (Just v) -> Unit v+           ; v = case t of Unit v -> v }+       in t `seq` body+    The 'Unit' is a one-tuple; see Note [One-tuples] in TysWiredIn+    Note that forcing 't' makes the pattern match happen,+    but does not force 'v'.++  * The pattern binds no variables+        let !(True,False) = e in body+    ==>+        let t = case e of (True,False) -> ()+        in t `seq` body+++------ Examples ----------+  *   !(_, (_, a)) = e+    ==>+      t = case e of (_, (_, a)) -> Unit a+      a = case t of Unit a -> a++    Note that+     - Forcing 't' will force the pattern to match fully;+       e.g. will diverge if (snd e) is bottom+     - But 'a' itself is not forced; it is wrapped in a one-tuple+       (see Note [One-tuples] in TysWiredIn)++  *   !(Just x) = e+    ==>+      t = case e of Just x -> Unit x+      x = case t of Unit x -> x++    Again, forcing 't' will fail if 'e' yields Nothing.++Note that even though this is rather general, the special cases+work out well:++* One binder, not -XStrict:++    let Just (Just v) = e in body+  ==>+    let t = case e of Just (Just v) -> Unit v+        v = case t of Unit v -> v+    in body+  ==>+    let v = case (case e of Just (Just v) -> Unit v) of+              Unit v -> v+    in body+  ==>+    let v = case e of Just (Just v) -> v+    in body++* Non-recursive, -XStrict+     let p = e in body+  ==>+     let { t = case e of p -> (x,y)+         ; x = case t of (x,y) -> x+         ; y = case t of (x,y) -> x }+     in t `seq` body+  ==> {inline seq, float x,y bindings inwards}+     let t = case e of p -> (x,y) in+     case t of t' ->+     let { x = case t' of (x,y) -> x+         ; y = case t' of (x,y) -> x } in+     body+  ==> {inline t, do case of case}+     case e of p ->+     let t = (x,y) in+     let { x = case t' of (x,y) -> x+         ; y = case t' of (x,y) -> x } in+     body+  ==> {case-cancellation, drop dead code}+     case e of p -> body++* Special case (B) is there to avoid fruitlessly taking the tuple+  apart and rebuilding it. For example, consider+     { K x y = e }+  where K is a product constructor.  Then general case (A) does:+     { t = case e of K x y -> (x,y)+     ; x = case t of (x,y) -> x+     ; y = case t of (x,y) -> y }+  In the lazy case we can't optimise out this fruitless taking apart+  and rebuilding.  Instead (B) builds+     { v = e+     ; x = case v of K x y -> x+     ; y = case v of K x y -> y }+  which is better.+-}++mkSelectorBinds :: [[Tickish Id]] -- ^ ticks to add, possibly+                -> LPat GhcTc     -- ^ The pattern+                -> CoreExpr       -- ^ Expression to which the pattern is bound+                -> DsM (Id,[(Id,CoreExpr)])+                -- ^ Id the rhs is bound to, for desugaring strict+                -- binds (see Note [Desugar Strict binds] in DsBinds)+                -- and all the desugared binds++mkSelectorBinds ticks pat val_expr+  | (dL->L _ (VarPat _ (dL->L _ v))) <- pat'     -- Special case (A)+  = return (v, [(v, val_expr)])++  | is_flat_prod_lpat pat'           -- Special case (B)+  = do { let pat_ty = hsLPatType pat'+       ; val_var <- newSysLocalDsNoLP pat_ty++       ; let mk_bind tick bndr_var+               -- (mk_bind sv bv)  generates  bv = case sv of { pat -> bv }+               -- Remember, 'pat' binds 'bv'+               = do { rhs_expr <- matchSimply (Var val_var) PatBindRhs pat'+                                       (Var bndr_var)+                                       (Var bndr_var)  -- Neat hack+                      -- Neat hack: since 'pat' can't fail, the+                      -- "fail-expr" passed to matchSimply is not+                      -- used. But it /is/ used for its type, and for+                      -- that bndr_var is just the ticket.+                    ; return (bndr_var, mkOptTickBox tick rhs_expr) }++       ; binds <- zipWithM mk_bind ticks' binders+       ; return ( val_var, (val_var, val_expr) : binds) }++  | otherwise                          -- General case (C)+  = do { tuple_var  <- newSysLocalDs tuple_ty+       ; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')+       ; tuple_expr <- matchSimply val_expr PatBindRhs pat+                                   local_tuple error_expr+       ; let mk_tup_bind tick binder+               = (binder, mkOptTickBox tick $+                          mkTupleSelector1 local_binders binder+                                           tuple_var (Var tuple_var))+             tup_binds = zipWith mk_tup_bind ticks' binders+       ; return (tuple_var, (tuple_var, tuple_expr) : tup_binds) }+  where+    pat' = strip_bangs pat+           -- Strip the bangs before looking for case (A) or (B)+           -- The incoming pattern may well have a bang on it++    binders = collectPatBinders pat'+    ticks'  = ticks ++ repeat []++    local_binders = map localiseId binders      -- See Note [Localise pattern binders]+    local_tuple   = mkBigCoreVarTup1 binders+    tuple_ty      = exprType local_tuple++strip_bangs :: LPat (GhcPass p) -> LPat (GhcPass p)+-- Remove outermost bangs and parens+strip_bangs (dL->L _ (ParPat _ p))  = strip_bangs p+strip_bangs (dL->L _ (BangPat _ p)) = strip_bangs p+strip_bangs lp                      = lp++is_flat_prod_lpat :: LPat (GhcPass p) -> Bool+is_flat_prod_lpat = is_flat_prod_pat . unLoc++is_flat_prod_pat :: Pat (GhcPass p) -> Bool+is_flat_prod_pat (ParPat _ p)          = is_flat_prod_lpat p+is_flat_prod_pat (TuplePat _ ps Boxed) = all is_triv_lpat ps+is_flat_prod_pat (ConPatOut { pat_con  = (dL->L _ pcon)+                            , pat_args = ps})+  | RealDataCon con <- pcon+  , isProductTyCon (dataConTyCon con)+  = all is_triv_lpat (hsConPatArgs ps)+is_flat_prod_pat _ = False++is_triv_lpat :: LPat (GhcPass p) -> Bool+is_triv_lpat = is_triv_pat . unLoc++is_triv_pat :: Pat (GhcPass p) -> Bool+is_triv_pat (VarPat {})  = True+is_triv_pat (WildPat{})  = True+is_triv_pat (ParPat _ p) = is_triv_lpat p+is_triv_pat _            = False+++{- *********************************************************************+*                                                                      *+  Creating big tuples and their types for full Haskell expressions.+  They work over *Ids*, and create tuples replete with their types,+  which is whey they are not in HsUtils.+*                                                                      *+********************************************************************* -}++mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc+mkLHsPatTup []     = noLoc $ mkVanillaTuplePat [] Boxed+mkLHsPatTup [lpat] = lpat+mkLHsPatTup lpats  = cL (getLoc (head lpats)) $+                     mkVanillaTuplePat lpats Boxed++mkLHsVarPatTup :: [Id] -> LPat GhcTc+mkLHsVarPatTup bs  = mkLHsPatTup (map nlVarPat bs)++mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc+-- A vanilla tuple pattern simply gets its type from its sub-patterns+mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box++-- The Big equivalents for the source tuple expressions+mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc+mkBigLHsVarTupId ids = mkBigLHsTupId (map nlHsVar ids)++mkBigLHsTupId :: [LHsExpr GhcTc] -> LHsExpr GhcTc+mkBigLHsTupId = mkChunkified mkLHsTupleExpr++-- The Big equivalents for the source tuple patterns+mkBigLHsVarPatTupId :: [Id] -> LPat GhcTc+mkBigLHsVarPatTupId bs = mkBigLHsPatTupId (map nlVarPat bs)++mkBigLHsPatTupId :: [LPat GhcTc] -> LPat GhcTc+mkBigLHsPatTupId = mkChunkified mkLHsPatTup++{-+************************************************************************+*                                                                      *+        Code for pattern-matching and other failures+*                                                                      *+************************************************************************++Generally, we handle pattern matching failure like this: let-bind a+fail-variable, and use that variable if the thing fails:+\begin{verbatim}+        let fail.33 = error "Help"+        in+        case x of+                p1 -> ...+                p2 -> fail.33+                p3 -> fail.33+                p4 -> ...+\end{verbatim}+Then+\begin{itemize}+\item+If the case can't fail, then there'll be no mention of @fail.33@, and the+simplifier will later discard it.++\item+If it can fail in only one way, then the simplifier will inline it.++\item+Only if it is used more than once will the let-binding remain.+\end{itemize}++There's a problem when the result of the case expression is of+unboxed type.  Then the type of @fail.33@ is unboxed too, and+there is every chance that someone will change the let into a case:+\begin{verbatim}+        case error "Help" of+          fail.33 -> case ....+\end{verbatim}++which is of course utterly wrong.  Rather than drop the condition that+only boxed types can be let-bound, we just turn the fail into a function+for the primitive case:+\begin{verbatim}+        let fail.33 :: Void -> Int#+            fail.33 = \_ -> error "Help"+        in+        case x of+                p1 -> ...+                p2 -> fail.33 void+                p3 -> fail.33 void+                p4 -> ...+\end{verbatim}++Now @fail.33@ is a function, so it can be let-bound.++We would *like* to use join points here; in fact, these "fail variables" are+paradigmatic join points! Sadly, this breaks pattern synonyms, which desugar as+CPS functions - i.e. they take "join points" as parameters. It's not impossible+to imagine extending our type system to allow passing join points around (very+carefully), but we certainly don't support it now.++99.99% of the time, the fail variables wind up as join points in short order+anyway, and the Void# doesn't do much harm.+-}++mkFailurePair :: CoreExpr       -- Result type of the whole case expression+              -> DsM (CoreBind, -- Binds the newly-created fail variable+                                -- to \ _ -> expression+                      CoreExpr) -- Fail variable applied to realWorld#+-- See Note [Failure thunks and CPR]+mkFailurePair expr+  = do { fail_fun_var <- newFailLocalDs (voidPrimTy `mkVisFunTy` ty)+       ; fail_fun_arg <- newSysLocalDs voidPrimTy+       ; let real_arg = setOneShotLambda fail_fun_arg+       ; return (NonRec fail_fun_var (Lam real_arg expr),+                 App (Var fail_fun_var) (Var voidPrimId)) }+  where+    ty = exprType expr++{-+Note [Failure thunks and CPR]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(This note predates join points as formal entities (hence the quotation marks).+We can't use actual join points here (see above); if we did, this would also+solve the CPR problem, since join points don't get CPR'd. See Note [Don't CPR+join points] in WorkWrap.)++When we make a failure point we ensure that it+does not look like a thunk. Example:++   let fail = \rw -> error "urk"+   in case x of+        [] -> fail realWorld#+        (y:ys) -> case ys of+                    [] -> fail realWorld#+                    (z:zs) -> (y,z)++Reason: we know that a failure point is always a "join point" and is+entered at most once.  Adding a dummy 'realWorld' token argument makes+it clear that sharing is not an issue.  And that in turn makes it more+CPR-friendly.  This matters a lot: if you don't get it right, you lose+the tail call property.  For example, see #3403.+++************************************************************************+*                                                                      *+              Ticks+*                                                                      *+********************************************************************* -}++mkOptTickBox :: [Tickish Id] -> CoreExpr -> CoreExpr+mkOptTickBox = flip (foldr Tick)++mkBinaryTickBox :: Int -> Int -> CoreExpr -> DsM CoreExpr+mkBinaryTickBox ixT ixF e = do+       uq <- newUnique+       this_mod <- getModule+       let bndr1 = mkSysLocal (fsLit "t1") uq boolTy+       let+           falseBox = Tick (HpcTick this_mod ixF) (Var falseDataConId)+           trueBox  = Tick (HpcTick this_mod ixT) (Var trueDataConId)+       --+       return $ Case e bndr1 boolTy+                       [ (DataAlt falseDataCon, [], falseBox)+                       , (DataAlt trueDataCon,  [], trueBox)+                       ]++++-- *******************************************************************++{- Note [decideBangHood]+~~~~~~~~~~~~~~~~~~~~~~~~+With -XStrict we may make /outermost/ patterns more strict.+E.g.+       let (Just x) = e in ...+          ==>+       let !(Just x) = e in ...+and+       f x = e+          ==>+       f !x = e++This adjustment is done by decideBangHood,++  * Just before constructing an EqnInfo, in Match+      (matchWrapper and matchSinglePat)++  * When desugaring a pattern-binding in DsBinds.dsHsBind++Note that it is /not/ done recursively.  See the -XStrict+spec in the user manual.++Specifically:+   ~pat    => pat    -- when -XStrict (even if pat = ~pat')+   !pat    => !pat   -- always+   pat     => !pat   -- when -XStrict+   pat     => pat    -- otherwise+-}+++-- | Use -XStrict to add a ! or remove a ~+-- See Note [decideBangHood]+decideBangHood :: DynFlags+               -> LPat GhcTc  -- ^ Original pattern+               -> LPat GhcTc  -- Pattern with bang if necessary+decideBangHood dflags lpat+  | not (xopt LangExt.Strict dflags)+  = lpat+  | otherwise   --  -XStrict+  = go lpat+  where+    go lp@(dL->L l p)+      = case p of+           ParPat x p    -> cL l (ParPat x (go p))+           LazyPat _ lp' -> lp'+           BangPat _ _   -> lp+           _             -> cL l (BangPat noExt lp)++-- | Unconditionally make a 'Pat' strict.+addBang :: LPat GhcTc -- ^ Original pattern+        -> LPat GhcTc -- ^ Banged pattern+addBang = go+  where+    go lp@(dL->L l p)+      = case p of+           ParPat x p    -> cL l (ParPat x (go p))+           LazyPat _ lp' -> cL l (BangPat noExt lp')+                                  -- Should we bring the extension value over?+           BangPat _ _   -> lp+           _             -> cL l (BangPat noExt lp)++isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)++-- Returns Just {..} if we're sure that the expression is True+-- I.e.   * 'True' datacon+--        * 'otherwise' Id+--        * Trivial wappings of these+-- The arguments to Just are any HsTicks that we have found,+-- because we still want to tick then, even it they are always evaluated.+isTrueLHsExpr (dL->L _ (HsVar _ (dL->L _ v)))+  |  v `hasKey` otherwiseIdKey+     || v `hasKey` getUnique trueDataConId+                                              = Just return+        -- trueDataConId doesn't have the same unique as trueDataCon+isTrueLHsExpr (dL->L _ (HsConLikeOut _ con))+  | con `hasKey` getUnique trueDataCon = Just return+isTrueLHsExpr (dL->L _ (HsTick _ tickish e))+    | Just ticks <- isTrueLHsExpr e+    = Just (\x -> do wrapped <- ticks x+                     return (Tick tickish wrapped))+   -- This encodes that the result is constant True for Hpc tick purposes;+   -- which is specifically what isTrueLHsExpr is trying to find out.+isTrueLHsExpr (dL->L _ (HsBinTick _ ixT _ e))+    | Just ticks <- isTrueLHsExpr e+    = Just (\x -> do e <- ticks x+                     this_mod <- getModule+                     return (Tick (HpcTick this_mod ixT) e))++isTrueLHsExpr (dL->L _ (HsPar _ e))   = isTrueLHsExpr e+isTrueLHsExpr _                       = Nothing
+ compiler/deSugar/ExtractDocs.hs view
@@ -0,0 +1,350 @@+-- | Extract docs from the renamer output so they can be be serialized.+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}++module ExtractDocs (extractDocs) where++import GhcPrelude+import Bag+import HsBinds+import HsDoc+import HsDecls+import HsExtension+import HsTypes+import HsUtils+import Name+import NameSet+import SrcLoc+import TcRnTypes++import Control.Applicative+import Data.List+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import Data.Semigroup++-- | Extract docs from renamer output.+extractDocs :: TcGblEnv+            -> (Maybe HsDocString, DeclDocMap, ArgDocMap)+            -- ^+            -- 1. Module header+            -- 2. Docs on top level declarations+            -- 3. Docs on arguments+extractDocs TcGblEnv { tcg_semantic_mod = mod+                     , tcg_rn_decls = mb_rn_decls+                     , tcg_insts = insts+                     , tcg_fam_insts = fam_insts+                     , tcg_doc_hdr = mb_doc_hdr+                     } =+    (unLoc <$> mb_doc_hdr, DeclDocMap doc_map, ArgDocMap arg_map)+  where+    (doc_map, arg_map) = maybe (M.empty, M.empty)+                               (mkMaps local_insts)+                               mb_decls_with_docs+    mb_decls_with_docs = topDecls <$> mb_rn_decls+    local_insts = filter (nameIsLocalOrFrom mod)+                         $ map getName insts ++ map getName fam_insts++-- | Create decl and arg doc-maps by looping through the declarations.+-- For each declaration, find its names, its subordinates, and its doc strings.+mkMaps :: [Name]+       -> [(LHsDecl GhcRn, [HsDocString])]+       -> (Map Name (HsDocString), Map Name (Map Int (HsDocString)))+mkMaps instances decls =+    ( f' (map (nubByName fst) decls')+    , f  (filterMapping (not . M.null) args)+    )+  where+    (decls', args) = unzip (map mappings decls)++    f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b+    f = M.fromListWith (<>) . concat++    f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString+    f' = M.fromListWith appendDocs . concat++    filterMapping :: (b -> Bool) ->  [[(a, b)]] -> [[(a, b)]]+    filterMapping p = map (filter (p . snd))++    mappings :: (LHsDecl GhcRn, [HsDocString])+             -> ( [(Name, HsDocString)]+                , [(Name, Map Int (HsDocString))]+                )+    mappings (L l decl, docStrs) =+           (dm, am)+      where+        doc = concatDocs docStrs+        args = declTypeDocs decl++        subs :: [(Name, [(HsDocString)], Map Int (HsDocString))]+        subs = subordinates instanceMap decl++        (subDocs, subArgs) =+          unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs)++        ns = names l decl+        subNs = [ n | (n, _, _) <- subs ]+        dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs]+        am = [(n, args) | n <- ns] ++ zip subNs subArgs++    instanceMap :: Map SrcSpan Name+    instanceMap = M.fromList [(getSrcSpan n, n) | n <- instances]++    names :: SrcSpan -> HsDecl GhcRn -> [Name]+    names l (InstD _ d) = maybeToList (M.lookup loc instanceMap) -- See+                                                                 -- Note [1].+      where loc = case d of+              TyFamInstD _ _ -> l -- The CoAx's loc is the whole line, but only+                                  -- for TFs+              _ -> getInstLoc d+    names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1].+    names _ decl = getMainDeclBinder decl++{-+Note [1]:+---------+We relate ClsInsts to InstDecls and DerivDecls using the SrcSpans buried+inside them. That should work for normal user-written instances (from+looking at GHC sources). We can assume that commented instances are+user-written. This lets us relate Names (from ClsInsts) to comments+(associated with InstDecls and DerivDecls).+-}++getMainDeclBinder :: HsDecl (GhcPass p) -> [IdP (GhcPass p)]+getMainDeclBinder (TyClD _ d) = [tcdName d]+getMainDeclBinder (ValD _ d) =+  case collectHsBindBinders d of+    []       -> []+    (name:_) -> [name]+getMainDeclBinder (SigD _ d) = sigNameNoLoc d+getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]+getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []+getMainDeclBinder _ = []++sigNameNoLoc :: Sig pass -> [IdP pass]+sigNameNoLoc (TypeSig    _   ns _)         = map unLoc ns+sigNameNoLoc (ClassOpSig _ _ ns _)         = map unLoc ns+sigNameNoLoc (PatSynSig  _   ns _)         = map unLoc ns+sigNameNoLoc (SpecSig    _   n _ _)        = [unLoc n]+sigNameNoLoc (InlineSig  _   n _)          = [unLoc n]+sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map unLoc ns+sigNameNoLoc _                             = []++-- Extract the source location where an instance is defined. This is used+-- to correlate InstDecls with their Instance/CoAxiom Names, via the+-- instanceMap.+getInstLoc :: InstDecl name -> SrcSpan+getInstLoc = \case+  ClsInstD _ (ClsInstDecl { cid_poly_ty = ty }) -> getLoc (hsSigType ty)+  DataFamInstD _ (DataFamInstDecl+    { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_tycon = (dL->L l _) }}}) -> l+  TyFamInstD _ (TyFamInstDecl+    -- Since CoAxioms' Names refer to the whole line for type family instances+    -- in particular, we need to dig a bit deeper to pull out the entire+    -- equation. This does not happen for data family instances, for some+    -- reason.+    { tfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = (dL->L l _) }}}) -> l+  ClsInstD _ (XClsInstDecl _) -> error "getInstLoc"+  DataFamInstD _ (DataFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"+  TyFamInstD _ (TyFamInstDecl (HsIB _ (XFamEqn _))) -> error "getInstLoc"+  XInstDecl _ -> error "getInstLoc"+  DataFamInstD _ (DataFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"+  TyFamInstD _ (TyFamInstDecl (XHsImplicitBndrs _)) -> error "getInstLoc"++-- | Get all subordinate declarations inside a declaration, and their docs.+-- A subordinate declaration is something like the associate type or data+-- family of a type class.+subordinates :: Map SrcSpan Name+             -> HsDecl GhcRn+             -> [(Name, [(HsDocString)], Map Int (HsDocString))]+subordinates instMap decl = case decl of+  InstD _ (ClsInstD _ d) -> do+    DataFamInstDecl { dfid_eqn = HsIB { hsib_body =+      FamEqn { feqn_tycon = (dL->L l _)+             , feqn_rhs   = defn }}} <- unLoc <$> cid_datafam_insts d+    [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs defn++  InstD _ (DataFamInstD _ (DataFamInstDecl (HsIB { hsib_body = d })))+    -> dataSubs (feqn_rhs d)+  TyClD _ d | isClassDecl d -> classSubs d+            | isDataDecl  d -> dataSubs (tcdDataDefn d)+  _ -> []+  where+    classSubs dd = [ (name, doc, declTypeDocs d)+                   | (dL->L _ d, doc) <- classDecls dd+                   , name <- getMainDeclBinder d, not (isValD d)+                   ]+    dataSubs :: HsDataDefn GhcRn+             -> [(Name, [HsDocString], Map Int (HsDocString))]+    dataSubs dd = constrs ++ fields ++ derivs+      where+        cons = map unLoc $ (dd_cons dd)+        constrs = [ ( unLoc cname+                    , maybeToList $ fmap unLoc $ con_doc c+                    , conArgDocs c)+                  | c <- cons, cname <- getConNames c ]+        fields  = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty)+                  | RecCon flds <- map getConArgs cons+                  , (dL->L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)+                  , (dL->L _ n) <- ns ]+        derivs  = [ (instName, [unLoc doc], M.empty)+                  | HsIB { hsib_body = (dL->L l (HsDocTy _ _ doc)) }+                      <- concatMap (unLoc . deriv_clause_tys . unLoc) $+                           unLoc $ dd_derivs dd+                  , Just instName <- [M.lookup l instMap] ]++-- | 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 (HsDocTy _ _ (dL->L _ ds) : tys) = M.insert n ds $ go (n+1) tys+    go n (_ : tys) = go (n+1) tys+    go _ [] = M.empty++    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 noExt) class_+    defs  = mkDecls (bagToList . tcdMeths) (ValD noExt) class_+    sigs  = mkDecls tcdSigs (SigD noExt) class_+    ats   = mkDecls tcdATs (TyClD noExt . FamDecl noExt) 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 (HsForAllTy { hst_body = ty }) = go n (unLoc ty)+    go n (HsQualTy   { hst_body = ty }) = go n (unLoc ty)+    go n (HsFunTy _ (dL->L _+                      (HsDocTy _ _ (dL->L _ x))) (dL->L _ ty)) =+       M.insert n x $ go (n+1) ty+    go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty)+    go n (HsDocTy _ _ (dL->L _ doc)) = M.singleton n doc+    go _ _ = 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 noExt)  group_ +++  mkDecls hs_derivds             (DerivD noExt) group_ +++  mkDecls hs_defds               (DefD noExt)   group_ +++  mkDecls hs_fords               (ForD noExt)   group_ +++  mkDecls hs_docs                (DocD noExt)   group_ +++  mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExt)  group_ +++  mkDecls (typesigs . hs_valds)  (SigD noExt)   group_ +++  mkDecls (valbinds . hs_valds)  (ValD noExt)   group_+  where+    typesigs (XValBindsLR (NValBinds _ sigs)) = filter (isUserSig . unLoc) sigs+    typesigs _ = error "expected ValBindsOut"++    valbinds (XValBindsLR (NValBinds binds _)) =+      concatMap bagToList . snd . unzip $ binds+    valbinds _ = error "expected ValBindsOut"++-- | 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 Nothing _ [] = []+    go (Just prev) docs [] = finished prev docs []+    go prev docs ((dL->L _ (DocD _ (DocCommentNext str))) : ds)+      | Nothing <- prev = go Nothing (str:docs) ds+      | Just decl <- prev = finished decl docs (go Nothing [str] ds)+    go prev docs ((dL->L _ (DocD _ (DocCommentPrev str))) : ds) =+      go prev (str:docs) ds+    go Nothing docs (d:ds) = go (Just d) docs ds+    go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds)++    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 decls = [ if isClassD d then (cL loc (filterClass d), doc) else x+                      | x@(dL->L loc d, doc) <- decls ]+  where+    filterClass (TyClD x c) =+      TyClD x $ c { tcdSigs =+        filter (liftA2 (||) (isUserSig . unLoc) isMinimalLSig) (tcdSigs c) }+    filterClass _ = error "expected TyClD"++-- | Was this signature given by the user?+isUserSig :: Sig name -> Bool+isUserSig TypeSig {}    = True+isUserSig ClassOpSig {} = True+isUserSig PatSynSig {}  = True+isUserSig _             = False++isClassD :: HsDecl a -> Bool+isClassD (TyClD _ d) = isClassDecl d+isClassD _ = False++-- | Take a field of declarations from a data structure and create HsDecls+-- using the given constructor+mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c]+mkDecls field con struct = [ cL loc (con decl)+                           | (dL->L loc decl) <- field struct ]
+ compiler/deSugar/Match.hs view
@@ -0,0 +1,1129 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++The @match@ function+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module Match ( match, matchEquations, matchWrapper, matchSimply+             , matchSinglePat, matchSinglePatVar ) where++#include "HsVersions.h"++import GhcPrelude++import {-#SOURCE#-} DsExpr (dsLExpr, dsSyntaxExpr)++import BasicTypes ( Origin(..) )+import DynFlags+import HsSyn+import TcHsSyn+import TcEvidence+import TcRnMonad+import Check+import CoreSyn+import Literal+import CoreUtils+import MkCore+import DsMonad+import DsBinds+import DsGRHSs+import DsUtils+import Id+import ConLike+import DataCon+import PatSyn+import MatchCon+import MatchLit+import Type+import Coercion ( eqCoercion )+import TyCon( isNewTyCon )+import TysWiredIn+import SrcLoc+import Maybes+import Util+import Name+import Outputable+import BasicTypes ( isGenerated, il_value, fl_value )+import FastString+import Unique+import UniqDFM++import Control.Monad( when, unless )+import Data.List ( groupBy )+import qualified Data.Map as Map++{-+************************************************************************+*                                                                      *+                The main matching function+*                                                                      *+************************************************************************++The function @match@ is basically the same as in the Wadler chapter+from "The Implementation of Functional Programming Languages",+except it is monadised, to carry around the name supply, info about+annotations, etc.++Notes on @match@'s arguments, assuming $m$ equations and $n$ patterns:+\begin{enumerate}+\item+A list of $n$ variable names, those variables presumably bound to the+$n$ expressions being matched against the $n$ patterns.  Using the+list of $n$ expressions as the first argument showed no benefit and+some inelegance.++\item+The second argument, a list giving the ``equation info'' for each of+the $m$ equations:+\begin{itemize}+\item+the $n$ patterns for that equation, and+\item+a list of Core bindings [@(Id, CoreExpr)@ pairs] to be ``stuck on+the front'' of the matching code, as in:+\begin{verbatim}+let <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 vars@(v:_) ty eqns    -- Eqns *can* be empty+  = ASSERT2( all (isInternalName . idName) vars, ppr vars )+    do  { dflags <- getDynFlags+                -- Tidy the first pattern, generating+                -- auxiliary bindings if necessary+        ; (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns++                -- Group the equations and match each group in turn+        ; let grouped = groupEquations dflags tidy_eqns++         -- print the view patterns that are commoned up to help debug+        ; whenDOptM Opt_D_dump_view_pattern_commoning (debug grouped)++        ; match_results <- match_groups grouped+        ; return (adjustMatchResult (foldr (.) id aux_binds) $+                  foldr1 combineMatchResults match_results) }+  where+    dropGroup :: [(PatGroup,EquationInfo)] -> [EquationInfo]+    dropGroup = map snd++    match_groups :: [[(PatGroup,EquationInfo)]] -> DsM [MatchResult]+    -- Result list of [MatchResult] is always non-empty+    match_groups [] = matchEmpty v ty+    match_groups gs = mapM match_group gs++    match_group :: [(PatGroup,EquationInfo)] -> DsM MatchResult+    match_group [] = panic "match_group"+    match_group eqns@((group,_) : _)+        = case group of+            PgCon {}  -> matchConFamily  vars ty (subGroupUniq [(c,e) | (PgCon c, e) <- eqns])+            PgSyn {}  -> matchPatSyn     vars ty (dropGroup eqns)+            PgLit {}  -> matchLiterals   vars ty (subGroupOrd [(l,e) | (PgLit l, e) <- eqns])+            PgAny     -> matchVariables  vars ty (dropGroup eqns)+            PgN {}    -> matchNPats      vars ty (dropGroup eqns)+            PgOverS {}-> matchNPats      vars ty (dropGroup eqns)+            PgNpK {}  -> matchNPlusKPats vars ty (dropGroup eqns)+            PgBang    -> matchBangs      vars ty (dropGroup eqns)+            PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)+            PgView {} -> matchView       vars ty (dropGroup eqns)+            PgOverloadedList -> matchOverloadedList vars ty (dropGroup eqns)++    -- FIXME: we should also warn about view patterns that should be+    -- commoned up but are not++    -- print some stuff to see what's getting grouped+    -- use -dppr-debug to see the resolution of overloaded literals+    debug eqns =+        let gs = map (\group -> foldr (\ (p,_) -> \acc ->+                                           case p of PgView e _ -> e:acc+                                                     _ -> acc) [] group) eqns+            maybeWarn [] = return ()+            maybeWarn l = warnDs NoReason (vcat l)+        in+          maybeWarn $ (map (\g -> text "Putting these view expressions into the same case:" <+> (ppr g))+                       (filter (not . null) gs))++matchEmpty :: MatchId -> Type -> DsM [MatchResult]+-- See Note [Empty case expressions]+matchEmpty var res_ty+  = return [MatchResult CanFail mk_seq]+  where+    mk_seq fail = return $ mkWildCase (Var var) (idType var) res_ty+                                      [(DEFAULT, [], fail)]++matchVariables :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult+-- Real true variables, just like in matchVar, SLPJ p 94+-- No binding to do: they'll all be wildcards by now (done in tidy)+matchVariables (_:vars) ty eqns = match vars ty (shiftEqns eqns)+matchVariables [] _ _ = panic "matchVariables"++matchBangs :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult+matchBangs (var:vars) ty eqns+  = do  { match_result <- match (var:vars) ty $+                          map (decomposeFirstPat getBangPat) eqns+        ; return (mkEvalMatchResult var ty match_result) }+matchBangs [] _ _ = panic "matchBangs"++matchCoercion :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult+-- Apply the coercion to the match variable and then match that+matchCoercion (var:vars) ty (eqns@(eqn1:_))+  = do  { let CoPat _ co pat _ = firstPat eqn1+        ; let pat_ty' = hsPatType pat+        ; var' <- newUniqueId var pat_ty'+        ; match_result <- match (var':vars) ty $+                          map (decomposeFirstPat getCoPat) eqns+        ; core_wrap <- dsHsWrapper co+        ; let bind = NonRec var' (core_wrap (Var var))+        ; return (mkCoLetMatchResult bind match_result) }+matchCoercion _ _ _ = panic "matchCoercion"++matchView :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult+-- Apply the view function to the match variable and then match that+matchView (var:vars) ty (eqns@(eqn1:_))+  = do  { -- we could pass in the expr from the PgView,+         -- but this needs to extract the pat anyway+         -- to figure out the type of the fresh variable+         let ViewPat _ viewExpr (dL->L _ pat) = firstPat eqn1+         -- do the rest of the compilation+        ; let pat_ty' = hsPatType pat+        ; var' <- newUniqueId var pat_ty'+        ; match_result <- match (var':vars) ty $+                          map (decomposeFirstPat getViewPat) eqns+         -- compile the view expressions+        ; viewExpr' <- dsLExpr viewExpr+        ; return (mkViewMatchResult var'+                    (mkCoreAppDs (text "matchView") viewExpr' (Var var))+                    match_result) }+matchView _ _ _ = panic "matchView"++matchOverloadedList :: [MatchId] -> Type -> [EquationInfo] -> DsM MatchResult+matchOverloadedList (var:vars) ty (eqns@(eqn1:_))+-- Since overloaded list patterns are treated as view patterns,+-- the code is roughly the same as for matchView+  = do { let ListPat (ListPatTc elt_ty (Just (_,e))) _ = firstPat eqn1+       ; var' <- newUniqueId var (mkListTy elt_ty)  -- we construct the overall type by hand+       ; match_result <- match (var':vars) ty $+                            map (decomposeFirstPat getOLPat) eqns -- getOLPat builds the pattern inside as a non-overloaded version of the overloaded list pattern+       ; e' <- dsSyntaxExpr e [Var var]+       ; return (mkViewMatchResult var' e' match_result) }+matchOverloadedList _ _ _ = panic "matchOverloadedList"++-- decompose the first pattern and leave the rest alone+decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo+decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))+        = eqn { eqn_pats = extractpat pat : pats}+decomposeFirstPat _ _ = panic "decomposeFirstPat"++getCoPat, getBangPat, getViewPat, getOLPat :: Pat GhcTc -> Pat GhcTc+getCoPat (CoPat _ _ pat _)   = pat+getCoPat _                   = panic "getCoPat"+getBangPat (BangPat _ pat  ) = unLoc pat+getBangPat _                 = panic "getBangPat"+getViewPat (ViewPat _ _ pat) = unLoc pat+getViewPat _                 = panic "getViewPat"+getOLPat (ListPat (ListPatTc ty (Just _)) pats)+        = ListPat (ListPatTc ty Nothing)  pats+getOLPat _                   = panic "getOLPat"++{-+Note [Empty case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The list of EquationInfo can be empty, arising from+    case x of {}   or    \case {}+In that situation we desugar to+    case x of { _ -> error "pattern match failure" }+The *desugarer* isn't certain whether there really should be no+alternatives, so it adds a default case, as it always does.  A later+pass may remove it if it's inaccessible.  (See also Note [Empty case+alternatives] in CoreSyn.)++We do *not* desugar simply to+   error "empty case"+or some such, because 'x' might be bound to (error "hello"), in which+case we want to see that "hello" exception, not (error "empty case").+See also Note [Case elimination: lifted case] in Simplify.+++************************************************************************+*                                                                      *+                Tidying patterns+*                                                                      *+************************************************************************++Tidy up the leftmost pattern in an @EquationInfo@, given the variable @v@+which will be scrutinised.++This makes desugaring the pattern match simpler by transforming some of+the patterns to simpler forms. (Tuples to Constructor Patterns)++Among other things in the resulting Pattern:+* Variables and irrefutable(lazy) patterns are replaced by Wildcards+* As patterns are replaced by the patterns they wrap.++The bindings created by the above patterns are put into the returned wrapper+instead.++This means a definition of the form:+  f x = rhs+when called with v get's desugared to the equivalent of:+  let x = v+  in+  f _ = rhs++The same principle holds for as patterns (@) and+irrefutable/lazy patterns (~).+In the case of irrefutable patterns the irrefutable pattern is pushed into+the binding.++Pattern Constructors which only represent syntactic sugar are converted into+their desugared representation.+This usually means converting them to Constructor patterns but for some+depends on enabled extensions. (Eg OverloadedLists)++GHC also tries to convert overloaded Literals into regular ones.++The result of this tidying is that the column of patterns will include+only these which can be assigned a PatternGroup (see patGroup).++-}++tidyEqnInfo :: Id -> EquationInfo+            -> DsM (DsWrapper, EquationInfo)+        -- DsM'd because of internal call to dsLHsBinds+        --      and mkSelectorBinds.+        -- "tidy1" does the interesting stuff, looking at+        -- one pattern and fiddling the list of bindings.+        --+        -- POST CONDITION: head pattern in the EqnInfo is+        --      one of these for which patGroup is defined.++tidyEqnInfo _ (EqnInfo { eqn_pats = [] })+  = panic "tidyEqnInfo"++tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig })+  = do { (wrap, pat') <- tidy1 v orig pat+       ; return (wrap, eqn { eqn_pats = do pat' : pats }) }++tidy1 :: Id                  -- The Id being scrutinised+      -> Origin              -- Was this a pattern the user wrote?+      -> Pat GhcTc           -- The pattern against which it is to be matched+      -> DsM (DsWrapper,     -- Extra bindings to do before the match+              Pat GhcTc)     -- Equivalent pattern++-------------------------------------------------------+--      (pat', mr') = tidy1 v pat mr+-- tidies the *outer level only* of pat, giving pat'+-- It eliminates many pattern forms (as-patterns, variable patterns,+-- list patterns, etc) and returns any created bindings in the wrapper.++tidy1 v o (ParPat _ pat)      = tidy1 v o (unLoc pat)+tidy1 v o (SigPat _ pat _)    = tidy1 v o (unLoc pat)+tidy1 _ _ (WildPat ty)        = return (idDsWrapper, WildPat ty)+tidy1 v o (BangPat _ (dL->L l p)) = tidy_bang_pat v o l p++        -- case v of { x -> mr[] }+        -- = case v of { _ -> let x=v in mr[] }+tidy1 v _ (VarPat _ (dL->L _ var))+  = return (wrapBind var v, WildPat (idType var))++        -- case v of { x@p -> mr[] }+        -- = case v of { p -> let x=v in mr[] }+tidy1 v o (AsPat _ (dL->L _ var) pat)+  = do  { (wrap, pat') <- tidy1 v o (unLoc pat)+        ; return (wrapBind var v . wrap, pat') }++{- now, here we handle lazy patterns:+    tidy1 v ~p bs = (v, v1 = case v of p -> v1 :+                        v2 = case v of p -> v2 : ... : bs )++    where the v_i's are the binders in the pattern.++    ToDo: in "v_i = ... -> v_i", are the v_i's really the same thing?++    The case expr for v_i is just: match [v] [(p, [], \ x -> Var v_i)] any_expr+-}++tidy1 v _ (LazyPat _ pat)+    -- This is a convenient place to check for unlifted types under a lazy pattern.+    -- Doing this check during type-checking is unsatisfactory because we may+    -- not fully know the zonked types yet. We sure do here.+  = do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders pat)+        ; unless (null unlifted_bndrs) $+          putSrcSpanDs (getLoc pat) $+          errDs (hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$+                       text "Unlifted variables:")+                    2 (vcat (map (\id -> ppr id <+> dcolon <+> ppr (idType id))+                                 unlifted_bndrs)))++        ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)+        ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]+        ; return (mkCoreLets sel_binds, WildPat (idType v)) }++tidy1 _ _ (ListPat (ListPatTc ty Nothing) pats )+  = return (idDsWrapper, unLoc list_ConPat)+  where+    list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] [ty])+                        (mkNilPat ty)+                        pats++tidy1 _ _ (TuplePat tys pats boxity)+  = return (idDsWrapper, unLoc tuple_ConPat)+  where+    arity = length pats+    tuple_ConPat = mkPrefixConPat (tupleDataCon boxity arity) pats tys++tidy1 _ _ (SumPat tys pat alt arity)+  = return (idDsWrapper, unLoc sum_ConPat)+  where+    sum_ConPat = mkPrefixConPat (sumDataCon alt arity) [pat] tys++-- LitPats: we *might* be able to replace these w/ a simpler form+tidy1 _ o (LitPat _ lit)+  = do { unless (isGenerated o) $+           warnAboutOverflowedLit lit+       ; return (idDsWrapper, tidyLitPat lit) }++-- NPats: we *might* be able to replace these w/ a simpler form+tidy1 _ o (NPat ty (dL->L _ lit@OverLit { ol_val = v }) mb_neg eq)+  = do { unless (isGenerated o) $+           let lit' | Just _ <- mb_neg = lit{ ol_val = negateOverLitVal v }+                    | otherwise = lit+           in warnAboutOverflowedOverLit lit'+       ; return (idDsWrapper, tidyNPat lit mb_neg eq ty) }++-- NPlusKPat: we may want to warn about the literals+tidy1 _ o n@(NPlusKPat _ _ (dL->L _ lit1) lit2 _ _)+  = do { unless (isGenerated o) $ do+           warnAboutOverflowedOverLit lit1+           warnAboutOverflowedOverLit lit2+       ; return (idDsWrapper, n) }++-- Everything else goes through unchanged...+tidy1 _ _ non_interesting_pat+  = return (idDsWrapper, non_interesting_pat)++--------------------+tidy_bang_pat :: Id -> Origin -> SrcSpan -> Pat GhcTc+              -> DsM (DsWrapper, Pat GhcTc)++-- Discard par/sig under a bang+tidy_bang_pat v o _ (ParPat _ (dL->L l p)) = tidy_bang_pat v o l p+tidy_bang_pat v o _ (SigPat _ (dL->L l p) _) = tidy_bang_pat v o l p++-- Push the bang-pattern inwards, in the hope that+-- it may disappear next time+tidy_bang_pat v o l (AsPat x v' p)+  = tidy1 v o (AsPat x v' (cL l (BangPat noExt p)))+tidy_bang_pat v o l (CoPat x w p t)+  = tidy1 v o (CoPat x w (BangPat noExt (cL l p)) t)++-- Discard bang around strict pattern+tidy_bang_pat v o _ p@(LitPat {})    = tidy1 v o p+tidy_bang_pat v o _ p@(ListPat {})   = tidy1 v o p+tidy_bang_pat v o _ p@(TuplePat {})  = tidy1 v o p+tidy_bang_pat v o _ p@(SumPat {})    = tidy1 v o p++-- Data/newtype constructors+tidy_bang_pat v o l p@(ConPatOut { pat_con = (dL->L _ (RealDataCon dc))+                                 , pat_args = args+                                 , pat_arg_tys = arg_tys })+  -- Newtypes: push bang inwards (#9844)+  =+    if isNewTyCon (dataConTyCon dc)+      then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l ty args })+      else tidy1 v o p  -- Data types: discard the bang+    where+      (ty:_) = dataConInstArgTys dc arg_tys++-------------------+-- Default case, leave the bang there:+--    VarPat,+--    LazyPat,+--    WildPat,+--    ViewPat,+--    pattern synonyms (ConPatOut with PatSynCon)+--    NPat,+--    NPlusKPat+--+-- For LazyPat, remember that it's semantically like a VarPat+--  i.e.  !(~p) is not like ~p, or p!  (#8952)+--+-- NB: SigPatIn, ConPatIn should not happen++tidy_bang_pat _ _ l p = return (idDsWrapper, BangPat noExt (cL l p))++-------------------+push_bang_into_newtype_arg :: SrcSpan+                           -> Type -- The type of the argument we are pushing+                                   -- onto+                           -> HsConPatDetails GhcTc -> HsConPatDetails GhcTc+-- See Note [Bang patterns and newtypes]+-- We are transforming   !(N p)   into   (N !p)+push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))+  = ASSERT( null args)+    PrefixCon [cL l (BangPat noExt arg)]+push_bang_into_newtype_arg l _ty (RecCon rf)+  | HsRecFields { rec_flds = (dL->L lf fld) : flds } <- rf+  , HsRecField { hsRecFieldArg = arg } <- fld+  = ASSERT( null flds)+    RecCon (rf { rec_flds = [cL lf (fld { hsRecFieldArg+                                           = cL l (BangPat noExt arg) })] })+push_bang_into_newtype_arg l ty (RecCon rf) -- If a user writes !(T {})+  | HsRecFields { rec_flds = [] } <- rf+  = PrefixCon [cL l (BangPat noExt (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, if we check a case expr+  -> MatchGroup GhcTc (LHsExpr GhcTc)  -- ^ Matches being desugared+  -> DsM ([Id], CoreExpr)              -- ^ Results (usually passed to 'match')++{-+ There is one small problem with the Lambda Patterns, when somebody+ writes something similar to:+\begin{verbatim}+    (\ (x:xs) -> ...)+\end{verbatim}+ he/she don't want a warning about incomplete patterns, that is done with+ the flag @opt_WarnSimplePatterns@.+ This problem also appears in the:+\begin{itemize}+\item @do@ patterns, but if the @do@ can fail+      it creates another equation if the match can fail+      (see @DsExpr.doDo@ function)+\item @let@ patterns, are treated by @matchSimply@+   List Comprension Patterns, are treated by @matchSimply@ also+\end{itemize}++We can't call @matchSimply@ with Lambda patterns,+due to the fact that lambda patterns can have more than+one pattern, and match simply only accepts one pattern.++JJQC 30-Nov-1997+-}++matchWrapper ctxt mb_scr (MG { mg_alts = (dL->L _ matches)+                             , mg_ext = MatchGroupTc arg_tys rhs_ty+                             , mg_origin = origin })+  = do  { dflags <- getDynFlags+        ; locn   <- getSrcSpanDs++        ; new_vars    <- case matches of+                           []    -> mapM newSysLocalDsNoLP arg_tys+                           (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))++        ; eqns_info   <- mapM (mk_eqn_info new_vars) matches++        -- pattern match check warnings+        ; unless (isGenerated origin) $+          when (isAnyPmCheckEnabled dflags (DsMatchContext ctxt locn)) $+          addTmCsDs (genCaseTmCs1 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+    mk_eqn_info vars (dL->L _ (Match { m_pats = pats, m_grhss = grhss }))+      = do { dflags <- getDynFlags+           ; let upats = map (unLoc . decideBangHood dflags) pats+                 dicts = collectEvVarsPats upats+           ; tm_cs <- genCaseTmCs2 mb_scr upats vars+           ; match_result <- addDictsDs dicts $ -- See Note [Type and Term Equality Propagation]+                             addTmCsDs tm_cs  $ -- See Note [Type and Term Equality Propagation]+                             dsGRHSs ctxt grhss rhs_ty+           ; return (EqnInfo { eqn_pats = upats+                             , eqn_orig = FromSource+                             , eqn_rhs = match_result }) }+    mk_eqn_info _ (dL->L _ (XMatch _)) = panic "matchWrapper"+    mk_eqn_info _ _  = panic "mk_eqn_info: Impossible Match" -- due to #15884++    handleWarnings = if isGenerated origin+                     then discardWarningsDs+                     else id+matchWrapper _ _ (XMatchGroup _) = panic "matchWrapper"++matchEquations  :: HsMatchContext Name+                -> [MatchId] -> [EquationInfo] -> Type+                -> DsM CoreExpr+matchEquations ctxt vars eqns_info rhs_ty+  = do  { let error_doc = matchContextErrString ctxt++        ; match_result <- match vars rhs_ty eqns_info++        ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc+        ; extractMatchResult match_result fail_expr }++{-+************************************************************************+*                                                                      *+\subsection[matchSimply]{@matchSimply@: match a single expression against a single pattern}+*                                                                      *+************************************************************************++@mkSimpleMatch@ is a wrapper for @match@ which deals with the+situation where we want to match a single expression against a single+pattern. It returns an expression.+-}++matchSimply :: CoreExpr                 -- ^ Scrutinee+            -> HsMatchContext Name      -- ^ Match kind+            -> LPat GhcTc               -- ^ Pattern it should match+            -> CoreExpr                 -- ^ Return this if it matches+            -> CoreExpr                 -- ^ Return this if it doesn't+            -> DsM CoreExpr+-- Do not warn about incomplete patterns; see matchSinglePat comments+matchSimply scrut hs_ctx pat result_expr fail_expr = do+    let+      match_result = cantFailMatchResult result_expr+      rhs_ty       = exprType fail_expr+        -- Use exprType of fail_expr, because won't refine in the case of failure!+    match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result+    extractMatchResult match_result' fail_expr++matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat GhcTc+               -> Type -> MatchResult -> DsM MatchResult+-- matchSinglePat ensures that the scrutinee is a variable+-- and then calls matchSinglePatVar+--+-- matchSinglePat does not warn about incomplete patterns+-- Used for things like [ e | pat <- stuff ], where+-- incomplete patterns are just fine++matchSinglePat (Var var) ctx pat ty match_result+  | not (isExternalName (idName var))+  = matchSinglePatVar var ctx pat ty match_result++matchSinglePat scrut hs_ctx pat ty match_result+  = do { var           <- selectSimpleMatchVarL pat+       ; match_result' <- matchSinglePatVar var hs_ctx pat ty match_result+       ; return (adjustMatchResult (bindNonRec var scrut) match_result') }++matchSinglePatVar :: Id   -- See Note [Match Ids]+                  -> HsMatchContext Name -> LPat GhcTc+                  -> Type -> MatchResult -> DsM MatchResult+matchSinglePatVar var ctx pat ty match_result+  = ASSERT2( isInternalName (idName var), ppr var )+    do { dflags <- getDynFlags+       ; locn   <- getSrcSpanDs++                    -- Pattern match check warnings+       ; checkSingle dflags (DsMatchContext ctx locn) var (unLoc pat)++       ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]+                                , eqn_orig = FromSource+                                , eqn_rhs  = match_result }+       ; match [var] ty [eqn_info] }+++{-+************************************************************************+*                                                                      *+                Pattern classification+*                                                                      *+************************************************************************+-}++data PatGroup+  = PgAny               -- Immediate match: variables, wildcards,+                        --                  lazy patterns+  | PgCon DataCon       -- Constructor patterns (incl list, tuple)+  | PgSyn PatSyn [Type] -- See Note [Pattern synonym groups]+  | PgLit Literal       -- Literal patterns+  | PgN   Rational      -- Overloaded numeric literals;+                        -- see Note [Don't use Literal for PgN]+  | PgOverS FastString  -- Overloaded string literals+  | PgNpK Integer       -- n+k patterns+  | PgBang              -- Bang patterns+  | PgCo Type           -- Coercion patterns; the type is the type+                        --      of the pattern *inside*+  | PgView (LHsExpr GhcTc) -- view pattern (e -> p):+                        -- the LHsExpr is the expression e+           Type         -- the Type is the type of p (equivalently, the result type of e)+  | PgOverloadedList++{- Note [Don't use Literal for PgN]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Previously we had, as PatGroup constructors++  | ...+  | PgN   Literal       -- Overloaded literals+  | PgNpK Literal       -- n+k patterns+  | ...++But Literal is really supposed to represent an *unboxed* literal, like Int#.+We were sticking the literal from, say, an overloaded numeric literal pattern+into a LitInt constructor. This didn't really make sense; and we now have+the invariant that value in a LitInt must be in the range of the target+machine's Int# type, and an overloaded literal could meaningfully be larger.++Solution: For pattern grouping purposes, just store the literal directly in+the PgN constructor as a Rational if numeric, and add a PgOverStr constructor+for overloaded strings.+-}++groupEquations :: DynFlags -> [EquationInfo] -> [[(PatGroup, EquationInfo)]]+-- If the result is of form [g1, g2, g3],+-- (a) all the (pg,eq) pairs in g1 have the same pg+-- (b) none of the gi are empty+-- The ordering of equations is unchanged+groupEquations dflags eqns+  = groupBy same_gp [(patGroup dflags (firstPat eqn), eqn) | eqn <- eqns]+  where+    same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool+    (pg1,_) `same_gp` (pg2,_) = pg1 `sameGroup` pg2++subGroup :: (m -> [[EquationInfo]]) -- Map.elems+         -> m -- Map.empty+         -> (a -> m -> Maybe [EquationInfo]) -- Map.lookup+         -> (a -> [EquationInfo] -> m -> m) -- Map.insert+         -> [(a, EquationInfo)] -> [[EquationInfo]]+-- Input is a particular group.  The result sub-groups the+-- equations by with particular constructor, literal etc they match.+-- Each sub-list in the result has the same PatGroup+-- See Note [Take care with pattern order]+-- Parameterized by map operations to allow different implementations+-- and constraints, eg. types without Ord instance.+subGroup elems empty lookup insert group+    = map reverse $ elems $ foldl' accumulate empty group+  where+    accumulate pg_map (pg, eqn)+      = case lookup pg pg_map of+          Just eqns -> insert pg (eqn:eqns) pg_map+          Nothing   -> insert pg [eqn]      pg_map+    -- pg_map :: Map a [EquationInfo]+    -- Equations seen so far in reverse order of appearance++subGroupOrd :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]+subGroupOrd = subGroup Map.elems Map.empty Map.lookup Map.insert++subGroupUniq :: Uniquable a => [(a, EquationInfo)] -> [[EquationInfo]]+subGroupUniq =+  subGroup eltsUDFM emptyUDFM (flip lookupUDFM) (\k v m -> addToUDFM m k v)++{- Note [Pattern synonym groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we see+  f (P a) = e1+  f (P b) = e2+    ...+where P is a pattern synonym, can we put (P a -> e1) and (P b -> e2) in the+same group?  We can if P is a constructor, but /not/ if P is a pattern synonym.+Consider (#11224)+   -- readMaybe :: Read a => String -> Maybe a+   pattern PRead :: Read a => () => a -> String+   pattern PRead a <- (readMaybe -> Just a)++   f (PRead (x::Int))  = e1+   f (PRead (y::Bool)) = e2+This is all fine: we match the string by trying to read an Int; if that+fails we try to read a Bool. But clearly we can't combine the two into a single+match.++Conclusion: we can combine when we invoke PRead /at the same type/.  Hence+in PgSyn we record the instantiaing types, and use them in sameGroup.++Note [Take care with pattern order]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the subGroup function we must be very careful about pattern re-ordering,+Consider the patterns [ (True, Nothing), (False, x), (True, y) ]+Then in bringing together the patterns for True, we must not+swap the Nothing and y!+-}++sameGroup :: PatGroup -> PatGroup -> Bool+-- Same group means that a single case expression+-- or test will suffice to match both, *and* the order+-- of testing within the group is insignificant.+sameGroup PgAny         PgAny         = True+sameGroup PgBang        PgBang        = True+sameGroup (PgCon _)     (PgCon _)     = True    -- One case expression+sameGroup (PgSyn p1 t1) (PgSyn p2 t2) = p1==p2 && eqTypes t1 t2+                                                -- eqTypes: See Note [Pattern synonym groups]+sameGroup (PgLit _)     (PgLit _)     = True    -- One case expression+sameGroup (PgN l1)      (PgN l2)      = l1==l2  -- Order is significant+sameGroup (PgOverS s1)  (PgOverS s2)  = s1==s2+sameGroup (PgNpK l1)    (PgNpK l2)    = l1==l2  -- See Note [Grouping overloaded literal patterns]+sameGroup (PgCo t1)     (PgCo t2)     = t1 `eqType` t2+        -- CoPats are in the same goup only if the type of the+        -- enclosed pattern is the same. The patterns outside the CoPat+        -- always have the same type, so this boils down to saying that+        -- the two coercions are identical.+sameGroup (PgView e1 t1) (PgView e2 t2) = viewLExprEq (e1,t1) (e2,t2)+       -- ViewPats are in the same group iff the expressions+       -- are "equal"---conservatively, we use syntactic equality+sameGroup _          _          = False++-- An approximation of syntactic equality used for determining when view+-- exprs are in the same group.+-- This function can always safely return false;+-- but doing so will result in the application of the view function being repeated.+--+-- Currently: compare applications of literals and variables+--            and anything else that we can do without involving other+--            HsSyn types in the recursion+--+-- NB we can't assume that the two view expressions have the same type.  Consider+--   f (e1 -> True) = ...+--   f (e2 -> "hi") = ...+viewLExprEq :: (LHsExpr GhcTc,Type) -> (LHsExpr GhcTc,Type) -> Bool+viewLExprEq (e1,_) (e2,_) = lexp e1 e2+  where+    lexp :: LHsExpr GhcTc -> LHsExpr GhcTc -> Bool+    lexp e e' = exp (unLoc e) (unLoc e')++    ---------+    exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool+    -- real comparison is on HsExpr's+    -- strip parens+    exp (HsPar _ (dL->L _ e)) e'   = exp e e'+    exp e (HsPar _ (dL->L _ e'))   = exp e e'+    -- because the expressions do not necessarily have the same type,+    -- we have to compare the wrappers+    exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e'+    exp (HsVar _ i) (HsVar _ i') =  i == i'+    exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c'+    -- the instance for IPName derives using the id, so this works if the+    -- above does+    exp (HsIPVar _ i) (HsIPVar _ i') = i == i'+    exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x'+    exp (HsOverLit _ l) (HsOverLit _ l') =+        -- Overloaded lits are equal if they have the same type+        -- and the data is the same.+        -- this is coarser than comparing the SyntaxExpr's in l and l',+        -- which resolve the overloading (e.g., fromInteger 1),+        -- because these expressions get written as a bunch of different variables+        -- (presumably to improve sharing)+        eqType (overLitType l) (overLitType l') && l == l'+    exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'+    -- the fixities have been straightened out by now, so it's safe+    -- to ignore them?+    exp (OpApp _ l o ri) (OpApp _ l' o' ri') =+        lexp l l' && lexp o o' && lexp ri ri'+    exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'+    exp (SectionL _ e1 e2) (SectionL _ e1' e2') =+        lexp e1 e1' && lexp e2 e2'+    exp (SectionR _ e1 e2) (SectionR _ e1' e2') =+        lexp e1 e1' && lexp e2 e2'+    exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) =+        eq_list tup_arg es1 es2+    exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e'+    exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') =+        lexp e e' && lexp e1 e1' && lexp e2 e2'++    -- Enhancement: could implement equality for more expressions+    --   if it seems useful+    -- But no need for HsLit, ExplicitList, ExplicitTuple,+    -- because they cannot be functions+    exp _ _  = False++    ---------+    syn_exp :: SyntaxExpr GhcTc -> SyntaxExpr GhcTc -> Bool+    syn_exp (SyntaxExpr { syn_expr      = expr1+                        , syn_arg_wraps = arg_wraps1+                        , syn_res_wrap  = res_wrap1 })+            (SyntaxExpr { syn_expr      = expr2+                        , syn_arg_wraps = arg_wraps2+                        , syn_res_wrap  = res_wrap2 })+      = exp expr1 expr2 &&+        and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) &&+        wrap res_wrap1 res_wrap2++    ---------+    tup_arg (dL->L _ (Present _ e1)) (dL->L _ (Present _ e2)) = lexp e1 e2+    tup_arg (dL->L _ (Missing t1))   (dL->L _ (Missing t2))   = eqType t1 t2+    tup_arg _ _ = False++    ---------+    wrap :: HsWrapper -> HsWrapper -> Bool+    -- Conservative, in that it demands that wrappers be+    -- syntactically identical and doesn't look under binders+    --+    -- Coarser notions of equality are possible+    -- (e.g., reassociating compositions,+    --        equating different ways of writing a coercion)+    wrap WpHole WpHole = True+    wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'+    wrap (WpFun w1 w2 _ _) (WpFun w1' w2' _ _) = wrap w1 w1' && wrap w2 w2'+    wrap (WpCast co)       (WpCast co')        = co `eqCoercion` co'+    wrap (WpEvApp et1)     (WpEvApp et2)       = et1 `ev_term` et2+    wrap (WpTyApp t)       (WpTyApp t')        = eqType t t'+    -- Enhancement: could implement equality for more wrappers+    --   if it seems useful (lams and lets)+    wrap _ _ = False++    ---------+    ev_term :: EvTerm -> EvTerm -> Bool+    ev_term (EvExpr (Var a)) (EvExpr  (Var b)) = a==b+    ev_term (EvExpr (Coercion a)) (EvExpr (Coercion b)) = a `eqCoercion` b+    ev_term _ _ = False++    ---------+    eq_list :: (a->a->Bool) -> [a] -> [a] -> Bool+    eq_list _  []     []     = True+    eq_list _  []     (_:_)  = False+    eq_list _  (_:_)  []     = False+    eq_list eq (x:xs) (y:ys) = eq x y && eq_list eq xs ys++patGroup :: DynFlags -> Pat GhcTc -> PatGroup+patGroup _ (ConPatOut { pat_con = (dL->L _ con)+                      , pat_arg_tys = tys })+ | RealDataCon dcon <- con              = PgCon dcon+ | PatSynCon psyn <- con                = PgSyn psyn tys+patGroup _ (WildPat {})                 = PgAny+patGroup _ (BangPat {})                 = PgBang+patGroup _ (NPat _ (dL->L _ (OverLit {ol_val=oval})) mb_neg _) =+  case (oval, isJust mb_neg) of+   (HsIntegral   i, False) -> PgN (fromInteger (il_value i))+   (HsIntegral   i, True ) -> PgN (-fromInteger (il_value i))+   (HsFractional r, False) -> PgN (fl_value r)+   (HsFractional r, True ) -> PgN (-fl_value r)+   (HsIsString _ s, _) -> ASSERT(isNothing mb_neg)+                          PgOverS s+patGroup _ (NPlusKPat _ _ (dL->L _ (OverLit {ol_val=oval})) _ _ _) =+  case oval of+   HsIntegral i -> PgNpK (il_value i)+   _ -> pprPanic "patGroup NPlusKPat" (ppr oval)+patGroup _ (CoPat _ _ p _)              = PgCo  (hsPatType p)+                                                    -- Type of innelexp pattern+patGroup _ (ViewPat _ expr p)           = PgView expr (hsPatType (unLoc p))+patGroup _ (ListPat (ListPatTc _ (Just _)) _) = PgOverloadedList+patGroup dflags (LitPat _ lit)          = PgLit (hsLitKey dflags lit)+patGroup _ pat                          = pprPanic "patGroup" (ppr pat)++{-+Note [Grouping overloaded literal patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+WATCH OUT!  Consider++        f (n+1) = ...+        f (n+2) = ...+        f (n+1) = ...++We can't group the first and third together, because the second may match+the same thing as the first.  Same goes for *overloaded* literal patterns+        f 1 True = ...+        f 2 False = ...+        f 1 False = ...+If the first arg matches '1' but the second does not match 'True', we+cannot jump to the third equation!  Because the same argument might+match '2'!+Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.+-}
+ compiler/deSugar/Match.hs-boot view
@@ -0,0 +1,37 @@+module Match where++import GhcPrelude+import Var      ( Id )+import TcType   ( Type )+import DsMonad  ( DsM, EquationInfo, MatchResult )+import CoreSyn  ( CoreExpr )+import HsSyn    ( LPat, HsMatchContext, MatchGroup, LHsExpr )+import Name     ( Name )+import HsExtension ( 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 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 #-}++module MatchCon ( matchConFamily, matchPatSyn ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-} Match     ( match )++import HsSyn+import DsBinds+import ConLike+import BasicTypes ( Origin(..) )+import TcType+import DsMonad+import DsUtils+import MkCore   ( mkCoreLets )+import Util+import Id+import NameEnv+import FieldLabel ( flSelector )+import SrcLoc+import Outputable+import Control.Monad(liftM)+import Data.List (groupBy)++{-+We are confronted with the first column of patterns in a set of+equations, all beginning with constructors from one ``family'' (e.g.,+@[]@ and @:@ make up the @List@ ``family'').  We want to generate the+alternatives for a @Case@ expression.  There are several choices:+\begin{enumerate}+\item+Generate an alternative for every constructor in the family, whether+they are used in this set of equations or not; this is what the Wadler+chapter does.+\begin{description}+\item[Advantages:]+(a)~Simple.  (b)~It may also be that large sparsely-used constructor+families are mainly handled by the code for literals.+\item[Disadvantages:]+(a)~Not practical for large sparsely-used constructor families, e.g.,+the ASCII character set.  (b)~Have to look up a list of what+constructors make up the whole family.+\end{description}++\item+Generate an alternative for each constructor used, then add a default+alternative in case some constructors in the family weren't used.+\begin{description}+\item[Advantages:]+(a)~Alternatives aren't generated for unused constructors.  (b)~The+STG is quite happy with defaults.  (c)~No lookup in an environment needed.+\item[Disadvantages:]+(a)~A spurious default alternative may be generated.+\end{description}++\item+``Do it right:'' generate an alternative for each constructor used,+and add a default alternative if all constructors in the family+weren't used.+\begin{description}+\item[Advantages:]+(a)~You will get cases with only one alternative (and no default),+which should be amenable to optimisation.  Tuples are a common example.+\item[Disadvantages:]+(b)~Have to look up constructor families in TDE (as above).+\end{description}+\end{enumerate}++We are implementing the ``do-it-right'' option for now.  The arguments+to @matchConFamily@ are the same as to @match@; the extra @Int@+returned is the number of constructors in the family.++The function @matchConFamily@ is concerned with this+have-we-used-all-the-constructors? question; the local function+@match_cons_used@ does all the real work.+-}++matchConFamily :: [Id]+               -> Type+               -> [[EquationInfo]]+               -> DsM MatchResult+-- Each group of eqns is for a single constructor+matchConFamily (var:vars) ty groups+  = do alts <- mapM (fmap toRealAlt . matchOneConLike vars ty) groups+       return (mkCoAlgCaseMatchResult var ty alts)+  where+    toRealAlt alt = case alt_pat alt of+        RealDataCon dcon -> alt{ alt_pat = dcon }+        _ -> panic "matchConFamily: not RealDataCon"+matchConFamily [] _ _ = panic "matchConFamily []"++matchPatSyn :: [Id]+            -> Type+            -> [EquationInfo]+            -> DsM MatchResult+matchPatSyn (var:vars) ty eqns+  = do alt <- fmap toSynAlt $ matchOneConLike vars ty eqns+       return (mkCoSynCaseMatchResult var ty alt)+  where+    toSynAlt alt = case alt_pat alt of+        PatSynCon psyn -> alt{ alt_pat = psyn }+        _ -> panic "matchPatSyn: not PatSynCon"+matchPatSyn _ _ _ = panic "matchPatSyn []"++type ConArgPats = HsConDetails (LPat GhcTc) (HsRecFields GhcTc (LPat GhcTc))++matchOneConLike :: [Id]+                -> Type+                -> [EquationInfo]+                -> DsM (CaseAlt ConLike)+matchOneConLike vars ty (eqn1 : eqns)   -- All eqns for a single constructor+  = do  { let inst_tys = ASSERT( all tcIsTcTyVar ex_tvs )+                           -- ex_tvs can only be tyvars as data types in source+                           -- Haskell cannot mention covar yet (Aug 2018).+                         ASSERT( tvs1 `equalLength` ex_tvs )+                         arg_tys ++ mkTyVarTys tvs1++              val_arg_tys = conLikeInstOrigArgTys con1 inst_tys+        -- dataConInstOrigArgTys takes the univ and existential tyvars+        -- and returns the types of the *value* args, which is what we want++              match_group :: [Id]+                          -> [(ConArgPats, EquationInfo)] -> DsM MatchResult+              -- All members of the group have compatible ConArgPats+              match_group arg_vars arg_eqn_prs+                = ASSERT( notNull arg_eqn_prs )+                  do { (wraps, eqns') <- liftM unzip (mapM shift arg_eqn_prs)+                     ; let group_arg_vars = select_arg_vars arg_vars arg_eqn_prs+                     ; match_result <- match (group_arg_vars ++ vars) ty eqns'+                     ; return (adjustMatchResult (foldr1 (.) wraps) match_result) }++              shift (_, eqn@(EqnInfo { eqn_pats = ConPatOut{ pat_tvs = tvs, pat_dicts = ds,+                                                             pat_binds = bind, pat_args = args+                                                  } : pats }))+                = do ds_bind <- dsTcEvBinds bind+                     return ( wrapBinds (tvs `zip` tvs1)+                            . wrapBinds (ds  `zip` dicts1)+                            . mkCoreLets ds_bind+                            , eqn { eqn_orig = Generated+                                  , eqn_pats = conArgPats val_arg_tys args ++ pats }+                            )+              shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)++        ; arg_vars <- selectConMatchVars val_arg_tys args1+                -- Use the first equation as a source of+                -- suggestions for the new variables++        -- Divide into sub-groups; see Note [Record patterns]+        ; let groups :: [[(ConArgPats, EquationInfo)]]+              groups = groupBy compatible_pats [ (pat_args (firstPat eqn), eqn)+                                               | eqn <- eqn1:eqns ]++        ; match_results <- mapM (match_group arg_vars) groups++        ; return $ MkCaseAlt{ alt_pat = con1,+                              alt_bndrs = tvs1 ++ dicts1 ++ arg_vars,+                              alt_wrapper = wrapper1,+                              alt_result = foldr1 combineMatchResults match_results } }+  where+    ConPatOut { pat_con = (dL->L _ con1)+              , pat_arg_tys = arg_tys, pat_wrap = wrapper1,+                pat_tvs = tvs1, pat_dicts = dicts1, pat_args = args1 }+              = firstPat eqn1+    fields1 = map flSelector (conLikeFieldLabels con1)++    ex_tvs = conLikeExTyCoVars con1++    -- Choose the right arg_vars in the right order for this group+    -- Note [Record patterns]+    select_arg_vars :: [Id] -> [(ConArgPats, EquationInfo)] -> [Id]+    select_arg_vars arg_vars ((arg_pats, _) : _)+      | RecCon flds <- arg_pats+      , let rpats = rec_flds flds+      , not (null rpats)     -- Treated specially; cf conArgPats+      = ASSERT2( fields1 `equalLength` arg_vars,+                 ppr con1 $$ ppr fields1 $$ ppr arg_vars )+        map lookup_fld rpats+      | otherwise+      = arg_vars+      where+        fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars+        lookup_fld (dL->L _ rpat) = lookupNameEnv_NF fld_var_env+                                            (idName (unLoc (hsRecFieldId rpat)))+    select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"+matchOneConLike _ _ [] = panic "matchOneCon []"++-----------------+compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool+-- Two constructors have compatible argument patterns if the number+-- and order of sub-matches is the same in both cases+compatible_pats (RecCon flds1, _) (RecCon flds2, _) = same_fields flds1 flds2+compatible_pats (RecCon flds1, _) _                 = null (rec_flds flds1)+compatible_pats _                 (RecCon flds2, _) = null (rec_flds flds2)+compatible_pats _                 _                 = True -- Prefix or infix con++same_fields :: HsRecFields GhcTc (LPat GhcTc) -> HsRecFields GhcTc (LPat GhcTc)+            -> Bool+same_fields flds1 flds2+  = all2 (\(dL->L _ f1) (dL->L _ f2)+                          -> unLoc (hsRecFieldId f1) == unLoc (hsRecFieldId f2))+         (rec_flds flds1) (rec_flds flds2)+++-----------------+selectConMatchVars :: [Type] -> ConArgPats -> DsM [Id]+selectConMatchVars arg_tys (RecCon {})      = newSysLocalsDsNoLP arg_tys+selectConMatchVars _       (PrefixCon ps)   = selectMatchVars (map unLoc ps)+selectConMatchVars _       (InfixCon p1 p2) = selectMatchVars [unLoc p1, unLoc p2]++conArgPats :: [Type]      -- Instantiated argument types+                          -- Used only to fill in the types of WildPats, which+                          -- are probably never looked at anyway+           -> ConArgPats+           -> [Pat GhcTc]+conArgPats _arg_tys (PrefixCon ps)   = map unLoc ps+conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]+conArgPats  arg_tys (RecCon (HsRecFields { rec_flds = rpats }))+  | null rpats = map WildPat arg_tys+        -- Important special case for C {}, which can be used for a+        -- datacon that isn't declared to have fields at all+  | otherwise  = map (unLoc . hsRecFieldArg . unLoc) rpats++{-+Note [Record patterns]+~~~~~~~~~~~~~~~~~~~~~~+Consider+         data T = T { x,y,z :: Bool }++         f (T { y=True, x=False }) = ...++We must match the patterns IN THE ORDER GIVEN, thus for the first+one we match y=True before x=False.  See #246; or imagine+matching against (T { y=False, x=undefined }): should fail without+touching the undefined.++Now consider:++         f (T { y=True, x=False }) = ...+         f (T { x=True, y= False}) = ...++In the first we must test y first; in the second we must test x+first.  So we must divide even the equations for a single constructor+T into sub-goups, based on whether they match the same field in the+same order.  That's what the (groupBy compatible_pats) grouping.++All non-record patterns are "compatible" in this sense, because the+positional patterns (T a b) and (a `T` b) all match the arguments+in order.  Also T {} is special because it's equivalent to (T _ _).+Hence the (null rpats) checks here and there.+++Note [Existentials in shift_con_pat]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        data T = forall a. Ord a => T a (a->Int)++        f (T x f) True  = ...expr1...+        f (T y g) False = ...expr2..++When we put in the tyvars etc we get++        f (T a (d::Ord a) (x::a) (f::a->Int)) True =  ...expr1...+        f (T b (e::Ord b) (y::a) (g::a->Int)) True =  ...expr2...++After desugaring etc we'll get a single case:++        f = \t::T b::Bool ->+            case t of+               T a (d::Ord a) (x::a) (f::a->Int)) ->+            case b of+                True  -> ...expr1...+                False -> ...expr2...++*** We have to substitute [a/b, d/e] in expr2! **+Hence+                False -> ....((/\b\(e:Ord b).expr2) a d)....++Originally I tried to use+        (\b -> let e = d in expr2) a+to do this substitution.  While this is "correct" in a way, it fails+Lint, because e::Ord b but d::Ord a.++-}
+ compiler/deSugar/MatchLit.hs view
@@ -0,0 +1,521 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Pattern-matching literal patterns+-}++{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++module MatchLit ( dsLit, dsOverLit, hsLitKey+                , tidyLitPat, tidyNPat+                , matchLiterals, matchNPlusKPats, matchNPats+                , warnAboutIdentities+                , warnAboutOverflowedOverLit, warnAboutOverflowedLit+                , warnAboutEmptyEnumerations+                ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-} Match  ( match )+import {-# SOURCE #-} DsExpr ( dsExpr, dsSyntaxExpr )++import DsMonad+import DsUtils++import HsSyn++import Id+import CoreSyn+import MkCore+import TyCon+import DataCon+import TcHsSyn ( shortCutLit )+import TcType+import Name+import Type+import PrelNames+import TysWiredIn+import TysPrim+import Literal+import SrcLoc+import Data.Ratio+import Outputable+import BasicTypes+import DynFlags+import Util+import FastString+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.Int+import Data.Word+import Data.Proxy++{-+************************************************************************+*                                                                      *+                Desugaring literals+        [used to be in DsExpr, but DsMeta needs it,+         and it's nice to avoid a loop]+*                                                                      *+************************************************************************++We give int/float literals type @Integer@ and @Rational@, respectively.+The typechecker will (presumably) have put \tr{from{Integer,Rational}s}+around them.++ToDo: put in range checks for when converting ``@i@''+(or should that be in the typechecker?)++For numeric literals, we try to detect there use at a standard type+(@Int@, @Float@, etc.) are directly put in the right constructor.+[NB: down with the @App@ conversion.]++See also below where we look for @DictApps@ for \tr{plusInt}, etc.+-}++dsLit :: HsLit GhcRn -> DsM CoreExpr+dsLit l = do+  dflags <- getDynFlags+  case l of+    HsStringPrim _ s -> return (Lit (LitString s))+    HsCharPrim   _ c -> return (Lit (LitChar c))+    HsIntPrim    _ i -> return (Lit (mkLitIntWrap dflags i))+    HsWordPrim   _ w -> return (Lit (mkLitWordWrap dflags w))+    HsInt64Prim  _ i -> return (Lit (mkLitInt64Wrap dflags i))+    HsWord64Prim _ w -> return (Lit (mkLitWord64Wrap dflags w))+    HsFloatPrim  _ f -> return (Lit (LitFloat (fl_value f)))+    HsDoublePrim _ d -> return (Lit (LitDouble (fl_value d)))+    HsChar _ c       -> return (mkCharExpr c)+    HsString _ str   -> mkStringExprFS str+    HsInteger _ i _  -> mkIntegerExpr i+    HsInt _ i        -> return (mkIntExpr dflags (il_value i))+    XLit x           -> pprPanic "dsLit" (ppr x)+    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{} = panic "dsOverLit"+{-+Note [Literal short cut]+~~~~~~~~~~~~~~~~~~~~~~~~+The type checker tries to do this short-cutting as early as possible, but+because of unification etc, more information is available to the desugarer.+And where it's possible to generate the correct literal right away, it's+much better to do so.+++************************************************************************+*                                                                      *+                 Warnings about overflowed literals+*                                                                      *+************************************************************************++Warn about functions like toInteger, fromIntegral, that convert+between one type and another when the to- and from- types are the+same.  Then it's probably (albeit not definitely) the identity+-}++warnAboutIdentities :: DynFlags -> CoreExpr -> Type -> DsM ()+warnAboutIdentities dflags (Var conv_fn) type_of_conv+  | wopt Opt_WarnIdentities dflags+  , idName conv_fn `elem` conversionNames+  , Just (arg_ty, res_ty) <- splitFunTy_maybe type_of_conv+  , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty+  = warnDs (Reason Opt_WarnIdentities)+           (vcat [ text "Call of" <+> ppr conv_fn <+> dcolon <+> ppr type_of_conv+                 , nest 2 $ text "can probably be omitted"+           ])+warnAboutIdentities _ _ _ = return ()++conversionNames :: [Name]+conversionNames+  = [ toIntegerName, toRationalName+    , fromIntegralName, realToFracName ]+ -- We can't easily add fromIntegerName, fromRationalName,+ -- because they are generated by literals+++-- | Emit warnings on overloaded integral literals which overflow the bounds+-- implied by their type.+warnAboutOverflowedOverLit :: HsOverLit GhcTc -> DsM ()+warnAboutOverflowedOverLit hsOverLit = do+  dflags <- getDynFlags+  warnAboutOverflowedLiterals dflags (getIntegralLit hsOverLit)++-- | Emit warnings on integral literals which overflow the boudns implied by+-- their type.+warnAboutOverflowedLit :: HsLit GhcTc -> DsM ()+warnAboutOverflowedLit hsLit = do+  dflags <- getDynFlags+  warnAboutOverflowedLiterals dflags (getSimpleIntegralLit hsLit)++-- | Emit warnings on integral literals which overflow the bounds implied by+-- their type.+warnAboutOverflowedLiterals+  :: DynFlags+  -> Maybe (Integer, Name)  -- ^ the literal value and name of its tycon+  -> DsM ()+warnAboutOverflowedLiterals dflags lit+ | wopt Opt_WarnOverflowedLiterals dflags+ , Just (i, tc) <- lit+ =  if      tc == intTyConName     then check i tc (Proxy :: Proxy Int)++    -- These only show up via the 'HsOverLit' route+    else if tc == int8TyConName    then check i tc (Proxy :: Proxy Int8)+    else if tc == int16TyConName   then check i tc (Proxy :: Proxy Int16)+    else if tc == int32TyConName   then check i tc (Proxy :: Proxy Int32)+    else if tc == int64TyConName   then check i tc (Proxy :: Proxy Int64)+    else if tc == wordTyConName    then check i tc (Proxy :: Proxy Word)+    else if tc == word8TyConName   then check i tc (Proxy :: Proxy Word8)+    else if tc == word16TyConName  then check i tc (Proxy :: Proxy Word16)+    else if tc == word32TyConName  then check i tc (Proxy :: Proxy Word32)+    else if tc == word64TyConName  then check i tc (Proxy :: Proxy Word64)+    else if tc == naturalTyConName then checkPositive i tc++    -- These only show up via the 'HsLit' route+    else if tc == intPrimTyConName    then check i tc (Proxy :: Proxy Int)+    else if tc == int8PrimTyConName   then check i tc (Proxy :: Proxy Int8)+    else if tc == int32PrimTyConName  then check i tc (Proxy :: Proxy Int32)+    else if tc == int64PrimTyConName  then check i tc (Proxy :: Proxy Int64)+    else if tc == wordPrimTyConName   then check i tc (Proxy :: Proxy Word)+    else if tc == word8PrimTyConName  then check i tc (Proxy :: Proxy Word8)+    else if tc == word32PrimTyConName then check i tc (Proxy :: Proxy Word32)+    else if tc == word64PrimTyConName then check i tc (Proxy :: Proxy Word64)++    else return ()++  | otherwise = return ()+  where++    checkPositive :: Integer -> Name -> DsM ()+    checkPositive i tc+      = when (i < 0) $ do+        warnDs (Reason Opt_WarnOverflowedLiterals)+               (vcat [ text "Literal" <+> integer i+                       <+> text "is negative but" <+> ppr tc+                       <+> ptext (sLit "only supports positive numbers")+                     ])++    check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM ()+    check i tc _proxy+      = when (i < minB || i > maxB) $ do+        warnDs (Reason Opt_WarnOverflowedLiterals)+               (vcat [ text "Literal" <+> integer i+                       <+> text "is out of the" <+> ppr tc <+> ptext (sLit "range")+                       <+> integer minB <> text ".." <> integer maxB+                     , sug ])+      where+        minB = toInteger (minBound :: a)+        maxB = toInteger (maxBound :: a)+        sug | minB == -i   -- Note [Suggest NegativeLiterals]+            , i > 0+            , not (xopt LangExt.NegativeLiterals dflags)+            = text "If you are trying to write a large negative literal, use NegativeLiterals"+            | otherwise = Outputable.empty++{-+Note [Suggest NegativeLiterals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If you write+  x :: Int8+  x = -128+it'll parse as (negate 128), and overflow.  In this case, suggest NegativeLiterals.+We get an erroneous suggestion for+  x = 128+but perhaps that does not matter too much.+-}++warnAboutEmptyEnumerations :: DynFlags -> LHsExpr GhcTc -> Maybe (LHsExpr GhcTc)+                           -> LHsExpr GhcTc -> DsM ()+-- ^ Warns about @[2,3 .. 1]@ which returns the empty list.+-- Only works for integral types, not floating point.+warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr+  | wopt Opt_WarnEmptyEnumerations dflags+  , Just (from,tc) <- getLHsIntegralLit fromExpr+  , Just mThn      <- traverse getLHsIntegralLit mThnExpr+  , Just (to,_)    <- getLHsIntegralLit toExpr+  , let check :: forall a. (Enum a, Num a) => Proxy a -> DsM ()+        check _proxy+          = when (null enumeration) $+            warnDs (Reason Opt_WarnEmptyEnumerations) (text "Enumeration is empty")+          where+            enumeration :: [a]+            enumeration = case mThn of+                            Nothing      -> [fromInteger from                    .. fromInteger to]+                            Just (thn,_) -> [fromInteger from, fromInteger thn   .. fromInteger to]++  = if      tc == intTyConName    then check (Proxy :: Proxy Int)+    else if tc == int8TyConName   then check (Proxy :: Proxy Int8)+    else if tc == int16TyConName  then check (Proxy :: Proxy Int16)+    else if tc == int32TyConName  then check (Proxy :: Proxy Int32)+    else if tc == int64TyConName  then check (Proxy :: Proxy Int64)+    else if tc == wordTyConName   then check (Proxy :: Proxy Word)+    else if tc == word8TyConName  then check (Proxy :: Proxy Word8)+    else if tc == word16TyConName then check (Proxy :: Proxy Word16)+    else if tc == word32TyConName then check (Proxy :: Proxy Word32)+    else if tc == word64TyConName then check (Proxy :: Proxy Word64)+    else if tc == integerTyConName then check (Proxy :: Proxy Integer)+    else if tc == naturalTyConName then check (Proxy :: Proxy Integer)+      -- We use 'Integer' because otherwise a negative 'Natural' literal+      -- could cause a compile time crash (instead of a runtime one).+      -- See the T10930b test case for an example of where this matters.+    else return ()++  | otherwise = return ()++getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)+-- ^ See if the expression is an 'Integral' literal.+-- Remember to look through automatically-added tick-boxes! (#8384)+getLHsIntegralLit (dL->L _ (HsPar _ e))            = getLHsIntegralLit e+getLHsIntegralLit (dL->L _ (HsTick _ _ e))         = getLHsIntegralLit e+getLHsIntegralLit (dL->L _ (HsBinTick _ _ _ e))    = getLHsIntegralLit e+getLHsIntegralLit (dL->L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit+getLHsIntegralLit (dL->L _ (HsLit _ lit))          = getSimpleIntegralLit lit+getLHsIntegralLit _ = Nothing++-- | If 'Integral', extract the value and type name of the overloaded literal.+getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)+getIntegralLit (OverLit { ol_val = HsIntegral i, ol_ext = OverLitTc _ ty })+  | Just tc <- tyConAppTyCon_maybe ty+  = Just (il_value i, tyConName tc)+getIntegralLit _ = Nothing++-- | If 'Integral', extract the value and type name of the non-overloaded+-- literal.+getSimpleIntegralLit :: HsLit GhcTc -> Maybe (Integer, Name)+getSimpleIntegralLit (HsInt _ IL{ il_value = i }) = Just (i, intTyConName)+getSimpleIntegralLit (HsIntPrim _ i) = Just (i, intPrimTyConName)+getSimpleIntegralLit (HsWordPrim _ i) = Just (i, wordPrimTyConName)+getSimpleIntegralLit (HsInt64Prim _ i) = Just (i, int64PrimTyConName)+getSimpleIntegralLit (HsWord64Prim _ i) = Just (i, word64PrimTyConName)+getSimpleIntegralLit (HsInteger _ i ty)+  | Just tc <- tyConAppTyCon_maybe ty+  = Just (i, tyConName tc)+getSimpleIntegralLit _ = Nothing++{-+************************************************************************+*                                                                      *+        Tidying lit pats+*                                                                      *+************************************************************************+-}++tidyLitPat :: HsLit GhcTc -> Pat GhcTc+-- Result has only the following HsLits:+--      HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim+--      HsDoublePrim, HsStringPrim, HsString+--  * HsInteger, HsRat, HsInt can't show up in LitPats+--  * We get rid of HsChar right here+tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c)+tidyLitPat (HsString src s)+  | lengthFS s <= 1     -- Short string literals only+  = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon+                                             [mkCharLitPat src c, pat] [charTy])+                  (mkNilPat charTy) (unpackFS s)+        -- The stringTy is the type of the whole pattern, not+        -- the type to instantiate (:) or [] with!+tidyLitPat lit = LitPat noExt 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 noExt lit] [])++    mb_int_lit :: Maybe Integer+    mb_int_lit = case (mb_neg, val) of+                   (Nothing, HsIntegral i) -> Just (il_value i)+                   (Just _,  HsIntegral i) -> Just (-(il_value i))+                   _ -> Nothing++    mb_str_lit :: Maybe FastString+    mb_str_lit = case (mb_neg, val) of+                   (Nothing, HsIsString _ s) -> Just s+                   _ -> Nothing++tidyNPat over_lit mb_neg eq outer_ty+  = NPat outer_ty (noLoc over_lit) mb_neg eq++{-+************************************************************************+*                                                                      *+                Pattern matching on LitPat+*                                                                      *+************************************************************************+-}++matchLiterals :: [Id]+              -> Type                   -- Type of the whole case expression+              -> [[EquationInfo]]       -- All PgLits+              -> DsM MatchResult++matchLiterals (var:vars) ty sub_groups+  = ASSERT( notNull sub_groups && all notNull sub_groups )+    do  {       -- Deal with each group+        ; alts <- mapM match_group sub_groups++                -- Combine results.  For everything except String+                -- we can use a case expression; for String we need+                -- a chain of if-then-else+        ; if isStringTy (idType var) then+            do  { eq_str <- dsLookupGlobalId eqStringName+                ; mrs <- mapM (wrap_str_guard eq_str) alts+                ; return (foldr1 combineMatchResults mrs) }+          else+            return (mkCoPrimCaseMatchResult var ty alts)+        }+  where+    match_group :: [EquationInfo] -> DsM (Literal, MatchResult)+    match_group eqns+        = do { dflags <- getDynFlags+             ; let LitPat _ hs_lit = firstPat (head eqns)+             ; match_result <- match vars ty (shiftEqns eqns)+             ; return (hsLitKey dflags hs_lit, match_result) }++    wrap_str_guard :: Id -> (Literal,MatchResult) -> DsM MatchResult+        -- Equality check for string literals+    wrap_str_guard eq_str (LitString s, mr)+        = do { -- We now have to convert back to FastString. Perhaps there+               -- should be separate LitBytes and LitString constructors?+               let s'  = mkFastStringByteString s+             ; lit    <- mkStringExprFS s'+             ; let pred = mkApps (Var eq_str) [Var var, lit]+             ; return (mkGuardedMatchResult pred mr) }+    wrap_str_guard _ (l, _) = pprPanic "matchLiterals/wrap_str_guard" (ppr l)++matchLiterals [] _ _ = panic "matchLiterals []"++---------------------------+hsLitKey :: DynFlags -> HsLit GhcTc -> Literal+-- Get the Core literal corresponding to a HsLit.+-- It only works for primitive types and strings;+-- others have been removed by tidy+-- For HsString, it produces a LitString, which really represents an _unboxed_+-- string literal; and we deal with it in matchLiterals above. Otherwise, it+-- produces a primitive Literal of type matching the original HsLit.+-- In the case of the fixed-width numeric types, we need to wrap here+-- because Literal has an invariant that the literal is in range, while+-- HsLit does not.+hsLitKey dflags (HsIntPrim    _ i) = mkLitIntWrap  dflags i+hsLitKey dflags (HsWordPrim   _ w) = mkLitWordWrap dflags w+hsLitKey dflags (HsInt64Prim  _ i) = mkLitInt64Wrap  dflags i+hsLitKey dflags (HsWord64Prim _ w) = mkLitWord64Wrap dflags w+hsLitKey _      (HsCharPrim   _ c) = mkLitChar            c+hsLitKey _      (HsFloatPrim  _ f) = mkLitFloat           (fl_value f)+hsLitKey _      (HsDoublePrim _ d) = mkLitDouble          (fl_value d)+hsLitKey _      (HsString _ s)     = LitString (bytesFS s)+hsLitKey _      l                  = pprPanic "hsLitKey" (ppr l)++{-+************************************************************************+*                                                                      *+                Pattern matching on NPat+*                                                                      *+************************************************************************+-}++matchNPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult+matchNPats (var:vars) ty (eqn1:eqns)    -- All for the same literal+  = do  { let NPat _ (dL->L _ lit) mb_neg eq_chk = firstPat eqn1+        ; lit_expr <- dsOverLit lit+        ; neg_lit <- case mb_neg of+                            Nothing  -> return lit_expr+                            Just neg -> dsSyntaxExpr neg [lit_expr]+        ; pred_expr <- dsSyntaxExpr eq_chk [Var var, neg_lit]+        ; match_result <- match vars ty (shiftEqns (eqn1:eqns))+        ; return (mkGuardedMatchResult pred_expr match_result) }+matchNPats vars _ eqns = pprPanic "matchOneNPat" (ppr (vars, eqns))++{-+************************************************************************+*                                                                      *+                Pattern matching on n+k patterns+*                                                                      *+************************************************************************++For an n+k pattern, we use the various magic expressions we've been given.+We generate:+\begin{verbatim}+    if ge var lit then+        let n = sub var lit+        in  <expr-for-a-successful-match>+    else+        <try-next-pattern-or-whatever>+\end{verbatim}+-}++matchNPlusKPats :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult+-- All NPlusKPats, for the *same* literal k+matchNPlusKPats (var:vars) ty (eqn1:eqns)+  = do  { let NPlusKPat _ (dL->L _ n1) (dL->L _ lit1) lit2 ge minus+                = firstPat eqn1+        ; lit1_expr   <- dsOverLit lit1+        ; lit2_expr   <- dsOverLit lit2+        ; pred_expr   <- dsSyntaxExpr ge    [Var var, lit1_expr]+        ; minusk_expr <- dsSyntaxExpr minus [Var var, lit2_expr]+        ; let (wraps, eqns') = mapAndUnzip (shift n1) (eqn1:eqns)+        ; match_result <- match vars ty eqns'+        ; return  (mkGuardedMatchResult pred_expr               $+                   mkCoLetMatchResult (NonRec n1 minusk_expr)   $+                   adjustMatchResult (foldr1 (.) wraps)         $+                   match_result) }+  where+    shift n1 eqn@(EqnInfo { eqn_pats = NPlusKPat _ (dL->L _ n) _ _ _ _ : pats })+        = (wrapBind n n1, eqn { eqn_pats = pats })+        -- The wrapBind is a no-op for the first equation+    shift _ e = pprPanic "matchNPlusKPats/shift" (ppr e)++matchNPlusKPats vars _ eqns = pprPanic "matchNPlusKPats" (ppr (vars, eqns))
+ compiler/deSugar/TmOracle.hs view
@@ -0,0 +1,265 @@+{-+Author: George Karachalias <george.karachalias@cs.kuleuven.be>++The term equality oracle. The main export of the module is function `tmOracle'.+-}++{-# LANGUAGE CPP, MultiWayIf #-}++module TmOracle (++        -- re-exported from PmExpr+        PmExpr(..), PmLit(..), SimpleEq, ComplexEq, PmVarEnv, falsePmExpr,+        eqPmLit, filterComplex, isNotPmExprOther, runPmPprM, lhsExprToPmExpr,+        hsExprToPmExpr, pprPmExprWithParens,++        -- the term oracle+        tmOracle, TmState, initialTmState, solveOneEq, extendSubst, canDiverge,++        -- misc.+        toComplex, exprDeepLookup, pmLitType, flattenPmVarEnv+    ) where++#include "HsVersions.h"++import GhcPrelude++import PmExpr++import Id+import Name+import Type+import HsLit+import TcHsSyn+import MonadUtils+import Util+import Outputable++import NameEnv++{-+%************************************************************************+%*                                                                      *+                      The term equality oracle+%*                                                                      *+%************************************************************************+-}++-- | The type of substitutions.+type PmVarEnv = NameEnv PmExpr++-- | The environment of the oracle contains+--     1. A Bool (are there any constraints we cannot handle? (PmExprOther)).+--     2. A substitution we extend with every step and return as a result.+type TmOracleEnv = (Bool, PmVarEnv)++-- | Check whether a constraint (x ~ BOT) can succeed,+-- given the resulting state of the term oracle.+canDiverge :: Name -> TmState -> Bool+canDiverge x (standby, (_unhandled, env))+  -- If the variable seems not evaluated, there is a possibility for+  -- constraint x ~ BOT to be satisfiable.+  | PmExprVar y <- varDeepLookup env x -- seems not forced+  -- If it is involved (directly or indirectly) in any equality in the+  -- worklist, we can assume that it is already indirectly evaluated,+  -- as a side-effect of equality checking. If not, then we can assume+  -- that the constraint is satisfiable.+  = not $ any (isForcedByEq x) standby || any (isForcedByEq y) standby+  -- Variable x is already in WHNF so the constraint is non-satisfiable+  | otherwise = False++  where+    isForcedByEq :: Name -> ComplexEq -> Bool+    isForcedByEq y (e1, e2) = varIn y e1 || varIn y e2++-- | Check whether a variable is in the free variables of an expression+varIn :: Name -> PmExpr -> Bool+varIn x e = case e of+  PmExprVar y    -> x == y+  PmExprCon _ es -> any (x `varIn`) es+  PmExprLit _    -> False+  PmExprEq e1 e2 -> (x `varIn` e1) || (x `varIn` e2)+  PmExprOther _  -> False++-- | Flatten the DAG (Could be improved in terms of performance.).+flattenPmVarEnv :: PmVarEnv -> PmVarEnv+flattenPmVarEnv env = mapNameEnv (exprDeepLookup env) env++-- | The state of the term oracle (includes complex constraints that cannot+-- progress unless we get more information).+type TmState = ([ComplexEq], TmOracleEnv)++-- | Initial state of the oracle.+initialTmState :: TmState+initialTmState = ([], (False, emptyNameEnv))++-- | Solve a complex equality (top-level).+solveOneEq :: TmState -> ComplexEq -> Maybe TmState+solveOneEq solver_env@(_,(_,env)) complex+  = solveComplexEq solver_env -- do the actual *merging* with existing state+  $ simplifyComplexEq               -- simplify as much as you can+  $ applySubstComplexEq env complex -- replace everything we already know++-- | Solve a complex equality.+-- Nothing => definitely unsatisfiable+-- Just tms => I have added the complex equality and added+--             it to the tmstate; the result may or may not be+--             satisfiable+solveComplexEq :: TmState -> ComplexEq -> Maybe TmState+solveComplexEq solver_state@(standby, (unhandled, env)) eq@(e1, e2) = case eq of+  -- We cannot do a thing about these cases+  (PmExprOther _,_)            -> Just (standby, (True, env))+  (_,PmExprOther _)            -> Just (standby, (True, env))++  (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of+    -- See Note [Undecidable Equality for Overloaded Literals]+    True  -> Just solver_state+    False -> Nothing++  (PmExprCon c1 ts1, PmExprCon c2 ts2)+    | c1 == c2  -> foldlM solveComplexEq solver_state (zip ts1 ts2)+    | otherwise -> Nothing+  (PmExprCon _ [], PmExprEq t1 t2)+    | isTruePmExpr e1  -> solveComplexEq solver_state (t1, t2)+    | isFalsePmExpr e1 -> Just (eq:standby, (unhandled, env))+  (PmExprEq t1 t2, PmExprCon _ [])+    | isTruePmExpr e2   -> solveComplexEq solver_state (t1, t2)+    | isFalsePmExpr e2  -> Just (eq:standby, (unhandled, env))++  (PmExprVar x, PmExprVar y)+    | x == y    -> Just solver_state+    | otherwise -> extendSubstAndSolve x e2 solver_state++  (PmExprVar x, _) -> extendSubstAndSolve x e2 solver_state+  (_, PmExprVar x) -> extendSubstAndSolve x e1 solver_state++  (PmExprEq _ _, PmExprEq _ _) -> Just (eq:standby, (unhandled, env))++  _ -> WARN( True, text "solveComplexEq: Catch all" <+> ppr eq )+       Just (standby, (True, env)) -- I HATE CATCH-ALLS++-- | Extend the substitution and solve the (possibly updated) constraints.+extendSubstAndSolve :: Name -> PmExpr -> TmState -> Maybe TmState+extendSubstAndSolve x e (standby, (unhandled, env))+  = foldlM solveComplexEq new_incr_state (map simplifyComplexEq changed)+  where+    -- Apply the substitution to the worklist and partition them to the ones+    -- that had some progress and the rest. Then, recurse over the ones that+    -- had some progress. Careful about performance:+    -- See Note [Representation of Term Equalities] in deSugar/Check.hs+    (changed, unchanged) = partitionWith (substComplexEq x e) standby+    new_incr_state       = (unchanged, (unhandled, extendNameEnv env x e))++-- | When we know that a variable is fresh, we do not actually have to+-- check whether anything changes, we know that nothing does. Hence,+-- `extendSubst` simply extends the substitution, unlike what+-- `extendSubstAndSolve` does.+extendSubst :: Id -> PmExpr -> TmState -> TmState+extendSubst y e (standby, (unhandled, env))+  | isNotPmExprOther simpl_e+  = (standby, (unhandled, extendNameEnv env x simpl_e))+  | otherwise = (standby, (True, env))+  where+    x = idName y+    simpl_e = fst $ simplifyPmExpr $ exprDeepLookup env e++-- | Simplify a complex equality.+simplifyComplexEq :: ComplexEq -> ComplexEq+simplifyComplexEq (e1, e2) = (fst $ simplifyPmExpr e1, fst $ simplifyPmExpr e2)++-- | Simplify an expression. The boolean indicates if there has been any+-- simplification or if the operation was a no-op.+simplifyPmExpr :: PmExpr -> (PmExpr, Bool)+-- See Note [Deep equalities]+simplifyPmExpr e = case e of+  PmExprCon c ts -> case mapAndUnzip simplifyPmExpr ts of+                      (ts', bs) -> (PmExprCon c ts', or bs)+  PmExprEq t1 t2 -> simplifyEqExpr t1 t2+  _other_expr    -> (e, False) -- the others are terminals++-- | Simplify an equality expression. The equality is given in parts.+simplifyEqExpr :: PmExpr -> PmExpr -> (PmExpr, Bool)+-- See Note [Deep equalities]+simplifyEqExpr e1 e2 = case (e1, e2) of+  -- Varables+  (PmExprVar x, PmExprVar y)+    | x == y -> (truePmExpr, True)++  -- Literals+  (PmExprLit l1, PmExprLit l2) -> case eqPmLit l1 l2 of+    -- See Note [Undecidable Equality for Overloaded Literals]+    True  -> (truePmExpr,  True)+    False -> (falsePmExpr, True)++  -- Can potentially be simplified+  (PmExprEq {}, _) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of+    ((e1', True ), (e2', _    )) -> simplifyEqExpr e1' e2'+    ((e1', _    ), (e2', True )) -> simplifyEqExpr e1' e2'+    ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress+  (_, PmExprEq {}) -> case (simplifyPmExpr e1, simplifyPmExpr e2) of+    ((e1', True ), (e2', _    )) -> simplifyEqExpr e1' e2'+    ((e1', _    ), (e2', True )) -> simplifyEqExpr e1' e2'+    ((e1', False), (e2', False)) -> (PmExprEq e1' e2', False) -- cannot progress++  -- Constructors+  (PmExprCon c1 ts1, PmExprCon c2 ts2)+    | c1 == c2 ->+        let (ts1', bs1) = mapAndUnzip simplifyPmExpr ts1+            (ts2', bs2) = mapAndUnzip simplifyPmExpr ts2+            (tss, _bss) = zipWithAndUnzip simplifyEqExpr ts1' ts2'+            worst_case  = PmExprEq (PmExprCon c1 ts1') (PmExprCon c2 ts2')+        in  if | not (or bs1 || or bs2) -> (worst_case, False) -- no progress+               | all isTruePmExpr  tss  -> (truePmExpr, True)+               | any isFalsePmExpr tss  -> (falsePmExpr, True)+               | otherwise              -> (worst_case, False)+    | otherwise -> (falsePmExpr, True)++  -- We cannot do anything about the rest..+  _other_equality -> (original, False)++  where+    original = PmExprEq e1 e2 -- reconstruct equality++-- | Apply an (un-flattened) substitution to a simple equality.+applySubstComplexEq :: PmVarEnv -> ComplexEq -> ComplexEq+applySubstComplexEq env (e1,e2) = (exprDeepLookup env e1, exprDeepLookup env e2)++-- | Apply an (un-flattened) substitution to a variable.+varDeepLookup :: PmVarEnv -> Name -> PmExpr+varDeepLookup env x+  | Just e <- lookupNameEnv env x = exprDeepLookup env e -- go deeper+  | otherwise                  = PmExprVar x          -- terminal+{-# INLINE varDeepLookup #-}++-- | Apply an (un-flattened) substitution to an expression.+exprDeepLookup :: PmVarEnv -> PmExpr -> PmExpr+exprDeepLookup env (PmExprVar x)    = varDeepLookup env x+exprDeepLookup env (PmExprCon c es) = PmExprCon c (map (exprDeepLookup env) es)+exprDeepLookup env (PmExprEq e1 e2) = PmExprEq (exprDeepLookup env e1)+                                               (exprDeepLookup env e2)+exprDeepLookup _   other_expr       = other_expr -- PmExprLit, PmExprOther++-- | External interface to the term oracle.+tmOracle :: TmState -> [ComplexEq] -> Maybe TmState+tmOracle tm_state eqs = foldlM solveOneEq tm_state eqs++-- | Type of a PmLit+pmLitType :: PmLit -> Type -- should be in PmExpr but gives cyclic imports :(+pmLitType (PmSLit   lit) = hsLitType   lit+pmLitType (PmOLit _ lit) = overLitType lit++{- Note [Deep equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~+Solving nested equalities is the most difficult part. The general strategy+is the following:++  * Equalities of the form (True ~ (e1 ~ e2)) are transformed to just+    (e1 ~ e2) and then treated recursively.++  * Equalities of the form (False ~ (e1 ~ e2)) cannot be analyzed unless+    we know more about the inner equality (e1 ~ e2). That's exactly what+    `simplifyEqExpr' tries to do: It takes e1 and e2 and either returns+    truePmExpr, falsePmExpr or (e1' ~ e2') in case it is uncertain. Note+    that it is not e but rather e', since it may perform some+    simplifications deeper.+-}
+ compiler/ghci/ByteCodeAsm.hs view
@@ -0,0 +1,564 @@+{-# LANGUAGE BangPatterns, CPP, 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 StgCmmLayout     ( ArgRep(..) )+import SMRep+import DynFlags+import Outputable+import 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 nm instrs bitmap bsize arity _origin _malloced) = 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++instance Functor Assembler where+    fmap = liftM++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 view
@@ -0,0 +1,1960 @@+{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# OPTIONS_GHC -fprof-auto-top #-}+--+--  (c) The University of Glasgow 2002-2006+--++-- | ByteCodeGen: Generate bytecode from Core+module ByteCodeGen ( UnlinkedBCO, byteCodeGen, coreExprToBCOs ) where++#include "HsVersions.h"++import GhcPrelude++import ByteCodeInstr+import ByteCodeAsm+import ByteCodeTypes++import GHCi+import GHCi.FFI+import GHCi.RemoteTypes+import BasicTypes+import DynFlags+import Outputable+import Platform+import Name+import MkId+import Id+import ForeignCall+import HscTypes+import CoreUtils+import CoreSyn+import PprCore+import Literal+import PrimOp+import CoreFVs+import Type+import RepType+import Kind            ( isLiftedTypeKind )+import DataCon+import TyCon+import Util+import VarSet+import TysPrim+import ErrUtils+import Unique+import FastString+import Panic+import StgCmmClosure    ( NonVoid(..), fromNonVoid, nonVoidIds )+import StgCmmLayout+import SMRep hiding (WordOff, ByteOff, wordsToBytes)+import Bitmap+import OrdList+import Maybes+import VarEnv++import Data.List+import Foreign+import Control.Monad+import Data.Char++import UniqSupply+import Module+import Control.Arrow ( second )++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 (pure 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+                (bndr, rhs) <- flattenBinds binds+                return $ case exprIsTickedString_maybe rhs of+                    Just str -> Left (bndr, str)+                    _ -> Right (bndr, simpleFreeVars rhs)+        stringPtrs <- allocateTopStrings hsc_env strings++        us <- mkSplitUniqSupply 'y'+        (BcM_State{..}, proto_bcos) <-+           runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $+             mapM schemeTopBind flatBinds++        when (notNull ffis)+             (panic "ByteCodeGen.byteCodeGen: missing final emitBc?")++        dumpIfSet_dyn dflags Opt_D_dump_BCOs+           "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))++        cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs)+          (case modBreaks of+             Nothing -> Nothing+             Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })++        -- Squash space leaks in the CompiledByteCode.  This is really+        -- important, because when loading a set of modules into GHCi+        -- we don't touch the CompiledByteCode until the end when we+        -- do linking.  Forcing out the thunks here reduces space+        -- usage by more than 50% when loading a large number of+        -- modules.+        evaluate (seqCompiledByteCode cbc)++        return cbc++  where dflags = hsc_dflags hsc_env++allocateTopStrings+  :: HscEnv+  -> [(Id, ByteString)]+  -> IO [(Var, RemotePtr ())]+allocateTopStrings hsc_env topStrings = do+  let !(bndrs, strings) = unzip topStrings+  ptrs <- iservCmd hsc_env $ MallocStrings strings+  return $ zip bndrs ptrs++{-+Note [generating code for top-level string literal bindings]++Here is a summary on how the byte code generator deals with top-level string+literals:++1. Top-level string literal bindings are separated from the rest of the module.++2. The strings are allocated via iservCmd, in allocateTopStrings++3. The mapping from binders to allocated strings (topStrings) are maintained in+   BcM and used when generating code for variable references.+-}++-- -----------------------------------------------------------------------------+-- Generating byte code for an expression++-- Returns: the root BCO for this expression+coreExprToBCOs :: HscEnv+               -> Module+               -> CoreExpr+               -> IO UnlinkedBCO+coreExprToBCOs hsc_env this_mod expr+ = withTiming (pure dflags)+              (text "ByteCodeGen"<+>brackets (ppr this_mod))+              (const ()) $ do+      -- create a totally bogus name for the top-level BCO; this+      -- should be harmless, since it's never used for anything+      let invented_name  = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel")+          invented_id    = Id.mkLocalId invented_name (panic "invented_id's type")++      -- the uniques are needed to generate fresh variables when we introduce new+      -- let bindings for ticked expressions+      us <- mkSplitUniqSupply 'y'+      (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco)+         <- runBc hsc_env us this_mod Nothing emptyVarEnv $+              schemeTopBind (invented_id, simpleFreeVars expr)++      when (notNull mallocd)+           (panic "ByteCodeGen.coreExprToBCOs: missing final emitBc?")++      dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco)++      assembleOneBCO hsc_env proto_bco+  where dflags = hsc_dflags hsc_env++-- The regular freeVars function gives more information than is useful to+-- us here. simpleFreeVars does the impedance matching.+simpleFreeVars :: CoreExpr -> AnnExpr Id DVarSet+simpleFreeVars = go . freeVars+  where+    go :: AnnExpr Id FVAnn -> AnnExpr Id DVarSet+    go (ann, e) = (freeVarsOfAnn ann, go' e)++    go' :: AnnExpr' Id FVAnn -> AnnExpr' Id DVarSet+    go' (AnnVar id)                  = AnnVar id+    go' (AnnLit lit)                 = AnnLit lit+    go' (AnnLam bndr body)           = AnnLam bndr (go body)+    go' (AnnApp fun arg)             = AnnApp (go fun) (go arg)+    go' (AnnCase scrut bndr ty alts) = AnnCase (go scrut) bndr ty (map go_alt alts)+    go' (AnnLet bind body)           = AnnLet (go_bind bind) (go body)+    go' (AnnCast expr (ann, co))     = AnnCast (go expr) (freeVarsOfAnn ann, co)+    go' (AnnTick tick body)          = AnnTick tick (go body)+    go' (AnnType ty)                 = AnnType ty+    go' (AnnCoercion co)             = AnnCoercion co++    go_alt (con, args, expr) = (con, args, go expr)++    go_bind (AnnNonRec bndr rhs) = AnnNonRec bndr (go rhs)+    go_bind (AnnRec pairs)       = AnnRec (map (second go) pairs)++-- -----------------------------------------------------------------------------+-- 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)+   -> Int+   -> Word16+   -> [StgWord]+   -> Bool      -- True <=> is a return point, rather than a function+   -> [FFIInfo]+   -> ProtoBCO name+mkProtoBCO dflags nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis+   = ProtoBCO {+        protoBCOName = nm,+        protoBCOInstrs = maybe_with_stack_check,+        protoBCOBitmap = bitmap,+        protoBCOBitmapSize = bitmap_size,+        protoBCOArity = arity,+        protoBCOExpr = origin,+        protoBCOFFIs = ffis+      }+     where+        -- Overestimate the stack usage (in words) of this BCO,+        -- and if >= iNTERP_STACK_CHECK_THRESH, add an explicit+        -- stack check.  (The interpreter always does a stack check+        -- for iNTERP_STACK_CHECK_THRESH words at the start of each+        -- BCO anyway, so we only need to add an explicit one in the+        -- (hopefully rare) cases when the (overestimated) stack use+        -- exceeds iNTERP_STACK_CHECK_THRESH.+        maybe_with_stack_check+           | is_ret && stack_usage < fromIntegral (aP_STACK_SPLIM dflags) = peep_d+                -- don't do stack checks at return points,+                -- everything is aggregated up to the top BCO+                -- (which must be a function).+                -- That is, unless the stack usage is >= AP_STACK_SPLIM,+                -- see bug #1466.+           | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH+           = STKCHECK stack_usage : peep_d+           | otherwise+           = peep_d     -- the supposedly common case++        -- We assume that this sum doesn't wrap+        stack_usage = sum (map bciStackUse peep_d)++        -- Merge local pushes+        peep_d = peep (fromOL instrs_ordlist)++        peep (PUSH_L off1 : PUSH_L off2 : PUSH_L off3 : rest)+           = PUSH_LLL off1 (off2-1) (off3-2) : peep rest+        peep (PUSH_L off1 : PUSH_L off2 : rest)+           = PUSH_LL off1 (off2-1) : peep rest+        peep (i:rest)+           = i : peep rest+        peep []+           = []++argBits :: DynFlags -> [ArgRep] -> [Bool]+argBits _      [] = []+argBits dflags (rep : args)+  | isFollowableArg rep  = False : argBits dflags args+  | otherwise = take (argRepSizeW dflags rep) (repeat True) ++ argBits dflags args++-- -----------------------------------------------------------------------------+-- schemeTopBind++-- Compile code for the right-hand side of a top-level binding++schemeTopBind :: (Id, AnnExpr Id DVarSet) -> BcM (ProtoBCO Name)+schemeTopBind (id, rhs)+  | Just data_con <- isDataConWorkId_maybe id,+    isNullaryRepDataCon data_con = do+    dflags <- getDynFlags+        -- Special case for the worker of a nullary data con.+        -- It'll look like this:        Nil = /\a -> Nil a+        -- If we feed it into schemeR, we'll get+        --      Nil = Nil+        -- because mkConAppCode treats nullary constructor applications+        -- by just re-using the single top-level definition.  So+        -- for the worker itself, we must allocate it directly.+    -- ioToBc (putStrLn $ "top level BCO")+    emitBc (mkProtoBCO dflags (getName id) (toOL [PACK data_con 0, ENTER])+                       (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})++  | otherwise+  = schemeR [{- No free variables -}] (id, rhs)+++-- -----------------------------------------------------------------------------+-- schemeR++-- Compile code for a right-hand side, to give a BCO that,+-- when executed with the free variables and arguments on top of the stack,+-- will return with a pointer to the result on top of the stack, after+-- removing the free variables and arguments.+--+-- Park the resulting BCO in the monad.  Also requires the+-- variable to which this value was bound, so as to give the+-- resulting BCO a name.++schemeR :: [Id]                 -- Free vars of the RHS, ordered as they+                                -- will appear in the thunk.  Empty for+                                -- top-level things, which have no free vars.+        -> (Id, AnnExpr Id DVarSet)+        -> BcM (ProtoBCO Name)+schemeR fvs (nm, rhs)+{-+   | trace (showSDoc (+              (char ' '+               $$ (ppr.filter (not.isTyVar).dVarSetElems.fst) rhs+               $$ pprCoreExpr (deAnnotate rhs)+               $$ char ' '+              ))) False+   = undefined+   | otherwise+-}+   = schemeR_wrk fvs nm rhs (collect rhs)++collect :: AnnExpr Id DVarSet -> ([Var], AnnExpr' Id DVarSet)+collect (_, e) = go [] e+  where+    go xs e | Just e' <- bcView e = go xs e'+    go xs (AnnLam x (_,e))+      | typePrimRep (idType x) `lengthExceeds` 1+      = multiValException+      | otherwise+      = go (x:xs) e+    go xs not_lambda = (reverse xs, not_lambda)++schemeR_wrk+    :: [Id]+    -> Id+    -> AnnExpr Id DVarSet+    -> ([Var], AnnExpr' Var DVarSet)+    -> BcM (ProtoBCO Name)+schemeR_wrk fvs nm original_body (args, body)+   = do+     dflags <- getDynFlags+     let+         all_args  = reverse args ++ fvs+         arity     = length all_args+         -- all_args are the args in reverse order.  We're compiling a function+         -- \fv1..fvn x1..xn -> e+         -- i.e. the fvs come first++         -- Stack arguments always take a whole number of words, we never pack+         -- them unlike constructor fields.+         szsb_args = map (wordsToBytes dflags . idSizeW dflags) all_args+         sum_szsb_args  = sum szsb_args+         p_init    = Map.fromList (zip all_args (mkStackOffsets 0 szsb_args))++         -- make the arg bitmap+         bits = argBits dflags (reverse (map bcIdArgRep all_args))+         bitmap_size = genericLength bits+         bitmap = mkBitmap dflags bits+     body_code <- schemeER_wrk sum_szsb_args p_init body++     emitBc (mkProtoBCO dflags (getName nm) body_code (Right original_body)+                 arity bitmap_size bitmap False{-not alts-})++-- introduce break instructions for ticked expressions+schemeER_wrk :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM BCInstrList+schemeER_wrk d p rhs+  | AnnTick (Breakpoint tick_no fvs) (_annot, newRhs) <- rhs+  = do  code <- schemeE d 0 p newRhs+        cc_arr <- getCCArray+        this_mod <- moduleName <$> getCurrentModule+        dflags <- getDynFlags+        let idOffSets = getVarOffSets dflags d p fvs+        let breakInfo = CgBreakInfo+                        { cgb_vars = idOffSets+                        , cgb_resty = exprType (deAnnotate' newRhs)+                        }+        newBreakInfo tick_no breakInfo+        dflags <- getDynFlags+        let cc | interpreterProfiled dflags = cc_arr ! tick_no+               | otherwise = toRemotePtr nullPtr+        let breakInstr = BRK_FUN (fromIntegral tick_no) (getUnique this_mod) cc+        return $ breakInstr `consOL` code+   | otherwise = schemeE d 0 p rhs++getVarOffSets :: DynFlags -> StackDepth -> BCEnv -> [Id] -> [(Id, Word16)]+getVarOffSets dflags depth env = catMaybes . 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)+    | 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++         -- Sizes of free vars+         size_w = trunc16W . idSizeW dflags+         sizes = map (\rhs_fvs -> sum (map size_w rhs_fvs)) fvss++         -- the arity of each rhs+         arities = map (genericLength . fst . collect) rhss++         -- This p', d' defn is safe because all the items being pushed+         -- are ptrs, so all have size 1 word.  d' and p' reflect the stack+         -- after the closures have been allocated in the heap (but not+         -- filled in), and pointers to them parked on the stack.+         offsets = mkStackOffsets d (genericReplicate n_binds (wordSize dflags))+         p' = Map.insertList (zipE xs offsets) p+         d' = d + wordsToBytes dflags n_binds+         zipE = zipEqual "schemeE"++         -- ToDo: don't build thunks for things with no free variables+         build_thunk+             :: StackDepth+             -> [Id]+             -> Word16+             -> ProtoBCO Name+             -> Word16+             -> Word16+             -> BcM BCInstrList+         build_thunk _ [] size bco off arity+            = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size))+           where+                mkap | arity == 0 = MKAP+                     | otherwise  = MKPAP+         build_thunk dd (fv:fvs) size bco off arity = do+              (push_code, pushed_szb) <- pushAtom dd p' (AnnVar fv)+              more_push_code <-+                  build_thunk (dd + pushed_szb) fvs size bco off arity+              return (push_code `appOL` more_push_code)++         alloc_code = toOL (zipWith mkAlloc sizes arities)+           where mkAlloc sz 0+                    | is_tick     = ALLOC_AP_NOUPD sz+                    | otherwise   = ALLOC_AP sz+                 mkAlloc sz arity = ALLOC_PAP arity sz++         is_tick = case binds of+                     AnnNonRec id _ -> occNameFS (getOccName id) == tickFS+                     _other -> False++         compile_bind d' fvs x rhs size arity off = do+                bco <- schemeR fvs (x,rhs)+                build_thunk d' fvs size bco off arity++         compile_binds =+            [ compile_bind d' fvs x rhs size arity (trunc16W n)+            | (fvs, x, rhs, size, arity, n) <-+                zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1]+            ]+     body_code <- schemeE d' s p' body+     thunk_codes <- sequence compile_binds+     return (alloc_code `appOL` concatOL thunk_codes `appOL` body_code)++-- Introduce a let binding for a ticked case expression. This rule+-- *should* only fire when the expression was not already let-bound+-- (the code gen for let bindings should take care of that).  Todo: we+-- call exprFreeVars on a deAnnotated expression, this may not be the+-- best way to calculate the free vars but it seemed like the least+-- intrusive thing to do+schemeE d s p exp@(AnnTick (Breakpoint _id _fvs) _rhs)+   | isLiftedTypeKind (typeKind ty)+   = do   id <- newId ty+          -- Todo: is emptyVarSet correct on the next line?+          let letExp = AnnLet (AnnNonRec id (fvs, exp)) (emptyDVarSet, AnnVar id)+          schemeE d s p letExp++   | otherwise+   = do   -- If the result type is not definitely lifted, then we must generate+          --   let f = \s . tick<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))++{-+   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.++-}++-- 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/restor the CCCS when profiling+        save_ccs_size_b | profiling = 2 * wordSize dflags+                        | otherwise = 0++        -- An unlifted value gets an extra info table pushed on top+        -- when it is returned.+        unlifted_itbl_size_b :: StackDepth+        unlifted_itbl_size_b | isAlgCase = 0+                            | otherwise = wordSize dflags++        -- depth of stack after the return value has been pushed+        d_bndr =+            d + ret_frame_size_b + wordsToBytes dflags (idSizeW dflags bndr)++        -- depth of stack after the extra info table for an unboxed return+        -- has been pushed, if any.  This is the stack depth at the+        -- continuation.+        d_alts = d_bndr + unlifted_itbl_size_b++        -- Env in which to compile the alts, not including+        -- any vars bound by the alts themselves+        p_alts0 = Map.insert bndr d_bndr p++        p_alts = case is_unboxed_tuple of+                   Just ubx_bndr -> Map.insert ubx_bndr d_bndr p_alts0+                   Nothing       -> p_alts0++        bndr_ty = idType bndr+        isAlgCase = not (isUnliftedType bndr_ty) && isNothing is_unboxed_tuple++        -- given an alt, return a discr and code for it.+        codeAlt (DEFAULT, _, (_,rhs))+           = do rhs_code <- schemeE d_alts s p_alts rhs+                return (NoDiscr, rhs_code)++        codeAlt alt@(_, bndrs, (_,rhs))+           -- primitive or nullary constructor alt: no need to UNPACK+           | null real_bndrs = do+                rhs_code <- schemeE d_alts s p_alts rhs+                return (my_discr alt, rhs_code)+           -- If an alt attempts to match on an unboxed tuple or sum, we must+           -- bail out, as the bytecode compiler can't handle them.+           -- (See #14608.)+           | any (\bndr -> typePrimRep (idType bndr) `lengthExceeds` 1) bndrs+           = multiValException+           -- algebraic alt with some binders+           | otherwise =+             let (tot_wds, _ptrs_wds, args_offsets) =+                     mkVirtHeapOffsets dflags NoHeader+                         [ NonVoid (bcIdPrimRep id, id)+                         | NonVoid id <- nonVoidIds real_bndrs+                         ]+                 size = WordOff tot_wds++                 stack_bot = d_alts + wordsToBytes dflags size++                 -- convert offsets from Sp into offsets into the virtual stack+                 p' = Map.insertList+                        [ (arg, stack_bot - ByteOff offset)+                        | (NonVoid arg, offset) <- args_offsets ]+                        p_alts+             in do+             MASSERT(isAlgCase)+             rhs_code <- schemeE stack_bot s p' rhs+             return (my_discr alt,+                     unitOL (UNPACK (trunc16W size)) `appOL` rhs_code)+           where+             real_bndrs = filterOut isTyVar bndrs++        my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}+        my_discr (DataAlt dc, _, _)+           | isUnboxedTupleCon dc || isUnboxedSumCon dc+           = multiValException+           | otherwise+           = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))+        my_discr (LitAlt l, _, _)+           = case l of LitNumber LitNumInt i  _  -> DiscrI (fromInteger i)+                       LitNumber LitNumWord w _  -> DiscrW (fromInteger w)+                       LitFloat r   -> DiscrF (fromRational r)+                       LitDouble r  -> DiscrD (fromRational r)+                       LitChar i    -> DiscrI (ord i)+                       _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l)++        maybe_ncons+           | not isAlgCase = Nothing+           | otherwise+           = case [dc | (DataAlt dc, _, _) <- alts] of+                []     -> Nothing+                (dc:_) -> Just (tyConFamilySize (dataConTyCon dc))++        -- the bitmap is relative to stack depth d, i.e. before the+        -- BCO, info table and return value are pushed on.+        -- This bit of code is v. similar to buildLivenessMask in CgBindery,+        -- except that here we build the bitmap from the known bindings of+        -- things that are pointers, whereas in CgBindery the code builds the+        -- bitmap from the free slots and unboxed bindings.+        -- (ToDo: merge?)+        --+        -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002.+        -- The bitmap must cover the portion of the stack up to the sequel only.+        -- Previously we were building a bitmap for the whole depth (d), but we+        -- really want a bitmap up to depth (d-s).  This affects compilation of+        -- case-of-case expressions, which is the only time we can be compiling a+        -- case expression with s /= 0.+        bitmap_size = trunc16W $ bytesToWords dflags (d - s)+        bitmap_size' :: Int+        bitmap_size' = fromIntegral bitmap_size+        bitmap = intsToReverseBitmap dflags bitmap_size'{-size-}+                        (sort (filter (< bitmap_size') rel_slots))+          where+          binds = Map.toList p+          -- NB: unboxed tuple cases bind the scrut binder to the same offset+          -- as one of the alt binders, so we have to remove any duplicates here:+          rel_slots = nub $ map fromIntegral $ concat (map spread binds)+          spread (id, offset) | isFollowableArg (bcIdArgRep id) = [ rel_offset ]+                              | otherwise                      = []+                where rel_offset = trunc16W $ bytesToWords dflags (d - offset)++     alt_stuff <- mapM codeAlt alts+     alt_final <- mkMultiBranch maybe_ncons alt_stuff++     let+         alt_bco_name = getName bndr+         alt_bco = mkProtoBCO dflags alt_bco_name alt_final (Left alts)+                       0{-no arity-} bitmap_size bitmap True{-is alts-}+--     trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) +++--            "\n      bitmap = " ++ show bitmap) $ do++     scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)+                           (d + ret_frame_size_b + save_ccs_size_b)+                           p scrut+     alt_bco' <- emitBc alt_bco+     let push_alts+            | isAlgCase = PUSH_ALTS alt_bco'+            | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeArgRep bndr_ty)+     return (push_alts `consOL` scrut_code)+++-- -----------------------------------------------------------------------------+-- Deal with a CCall.++-- Taggedly push the args onto the stack R->L,+-- deferencing ForeignObj#s and adjusting addrs to point to+-- payloads in Ptr/Byte arrays.  Then, generate the marshalling+-- (machine) code for the ccall, and create bytecodes to call that and+-- then return in the right way.++generateCCall+    :: StackDepth+    -> Sequel+    -> BCEnv+    -> CCallSpec               -- where to call+    -> Id                      -- of target, for type info+    -> [AnnExpr' Id DVarSet]   -- args (atoms)+    -> BcM BCInstrList+generateCCall d0 s p (CCallSpec target cconv safety) 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 || head a_reps_pushed_r_to_l /= VoidRep+            = 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 acutally need an info-table here; we just+need to have the argument to be one-from-top on the stack, hence pushing+a 1-word null. See #8383.+-}+++implement_tagToId+    :: StackDepth+    -> Sequel+    -> BCEnv+    -> AnnExpr' Id DVarSet+    -> [Name]+    -> BcM BCInstrList+-- See Note [Implementing tagToEnum#]+implement_tagToId d s p arg names+  = ASSERT( notNull names )+    do (push_arg, arg_bytes) <- pushAtom d p arg+       labels <- getLabelsBc (genericLength names)+       label_fail <- getLabelBc+       label_exit <- getLabelBc+       dflags <- getDynFlags+       let infos = zip4 labels (tail labels ++ [label_fail])+                               [0 ..] names+           steps = map (mkStep label_exit) infos+           slide_ws = bytesToWords dflags (d - s + arg_bytes)++       return (push_arg+               `appOL` unitOL (PUSH_UBX LitNullAddr 1)+                   -- Push bogus word (see Note [Implementing tagToEnum#])+               `appOL` concatOL steps+               `appOL` toOL [ LABEL label_fail, CASEFAIL,+                              LABEL label_exit ]+               `appOL` mkSlideW 1 (slide_ws + 1)+                   -- "+1" to account for bogus word+                   --      (see Note [Implementing tagToEnum#])+               `appOL` unitOL ENTER)+  where+        mkStep l_exit (my_label, next_label, n, name_for_n)+           = toOL [LABEL my_label,+                   TESTEQ_I n next_label,+                   PUSH_G name_for_n,+                   JMP l_exit]+++-- -----------------------------------------------------------------------------+-- pushAtom++-- Push an atom onto the stack, returning suitable code & number of+-- stack words used.+--+-- The env p must map each variable to the highest- numbered stack+-- slot for it.  For example, if the stack has depth 4 and we+-- tagged-ly push (v :: Int#) on it, the value will be in stack[4],+-- the tag in stack[5], the stack will have depth 6, and p must map v+-- to 5 and not to 4.  Stack locations are numbered from zero, so a+-- depth 6 stack has valid words 0 .. 5.++pushAtom+    :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)+pushAtom d p e+   | Just e' <- bcView e+   = pushAtom d p e'++pushAtom _ _ (AnnCoercion {})   -- Coercions are zero-width things,+   = return (nilOL, 0)          -- treated just like a variable V++-- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs+-- and Note [Bottoming expressions] in coreSyn/CoreUtils.hs:+-- The scrutinee of an empty case evaluates to bottom+pushAtom d p (AnnCase (_, a) _ _ []) -- trac #12128+   = pushAtom d p a++pushAtom d p (AnnVar var)+   | [] <- typePrimRep (idType var)+   = return (nilOL, 0)++   | isFCallId var+   = pprPanic "pushAtom: shouldn't get an FCallId here" (ppr var)++   | Just primop <- isPrimOpId_maybe var+   = do+       dflags <-getDynFlags+       return (unitOL (PUSH_PRIMOP primop), wordSize dflags)++   | Just d_v <- lookupBCEnv_maybe var p  -- var is a local variable+   = do dflags <- getDynFlags++        let !szb = idSizeCon dflags var+            with_instr instr = do+                let !off_b = trunc16B $ d - d_v+                return (unitOL (instr off_b), wordSize dflags)++        case szb of+            1 -> with_instr PUSH8_W+            2 -> with_instr PUSH16_W+            4 -> with_instr PUSH32_W+            _ -> do+                let !szw = bytesToWords dflags szb+                    !off_w = trunc16W $ bytesToWords dflags (d - d_v) + szw - 1+                return (toOL (genericReplicate szw (PUSH_L off_w)), szb)+        -- d - d_v           offset from TOS to the first slot of the object+        --+        -- d - d_v + sz - 1  offset from the TOS of the last slot of the object+        --+        -- Having found the last slot, we proceed to copy the right number of+        -- slots on to the top of the stack.++   | otherwise  -- var must be a global variable+   = do topStrings <- getTopStrings+        dflags <- getDynFlags+        case lookupVarEnv topStrings var of+            Just ptr -> pushAtom d p $ AnnLit $ mkLitWord dflags $+              fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr+            Nothing -> do+                let sz = idSizeCon dflags var+                MASSERT( sz == wordSize dflags )+                return (unitOL (PUSH_G (getName var)), sz)+++pushAtom _ _ (AnnLit lit) = do+     dflags <- getDynFlags+     let code rep+             = let size_words = WordOff (argRepSizeW dflags rep)+               in  return (unitOL (PUSH_UBX lit (trunc16W size_words)),+                           wordsToBytes dflags size_words)++     case lit of+        LitLabel _ _ _   -> code N+        LitFloat _       -> code F+        LitDouble _      -> code D+        LitChar _        -> code N+        LitNullAddr      -> code N+        LitString _      -> code N+        LitRubbish       -> code N+        LitNumber nt _ _ -> case nt of+          LitNumInt     -> code N+          LitNumWord    -> code N+          LitNumInt64   -> code L+          LitNumWord64  -> code L+          -- No LitInteger's or LitNatural's should be left by the time this is+          -- called. CorePrep should have converted them all to a real core+          -- representation.+          LitNumInteger -> panic "pushAtom: LitInteger"+          LitNumNatural -> panic "pushAtom: LitNatural"++pushAtom _ _ expr+   = pprPanic "ByteCodeGen.pushAtom"+              (pprCoreExpr (deAnnotate' expr))+++-- | Push an atom for constructor (i.e., PACK instruction) onto the stack.+-- This is slightly different to @pushAtom@ due to the fact that we allow+-- packing constructor fields. See also @mkConAppCode@ and @pushPadding@.+pushConstrAtom+    :: StackDepth -> BCEnv -> AnnExpr' Id DVarSet -> BcM (BCInstrList, ByteOff)++pushConstrAtom _ _ (AnnLit lit@(LitFloat _)) =+    return (unitOL (PUSH_UBX32 lit), 4)++pushConstrAtom d p (AnnVar v)+    | Just d_v <- lookupBCEnv_maybe v p = do  -- v is a local variable+        dflags <- getDynFlags+        let !szb = idSizeCon dflags v+            done instr = do+                let !off = trunc16B $ d - d_v+                return (unitOL (instr off), szb)+        case szb of+            1 -> done PUSH8+            2 -> done PUSH16+            4 -> done PUSH32+            _ -> pushAtom d p (AnnVar v)++pushConstrAtom d p expr = pushAtom d p expr++pushPadding :: Int -> (BCInstrList, ByteOff)+pushPadding !n = go n (nilOL, 0)+  where+    go n acc@(!instrs, !off) = case n of+        0 -> acc+        1 -> (instrs `mappend` unitOL PUSH_PAD8, off + 1)+        2 -> (instrs `mappend` unitOL PUSH_PAD16, off + 2)+        3 -> go 1 (go 2 acc)+        4 -> (instrs `mappend` unitOL PUSH_PAD32, off + 4)+        _ -> go (n - 4) (go 4 acc)++-- -----------------------------------------------------------------------------+-- Given a bunch of alts code and their discrs, do the donkey work+-- of making a multiway branch using a switch tree.+-- What a load of hassle!++mkMultiBranch :: Maybe Int      -- # datacons in tycon, if alg alt+                                -- a hint; generates better code+                                -- Nothing is always safe+              -> [(Discr, BCInstrList)]+              -> BcM BCInstrList+mkMultiBranch maybe_ncons raw_ways = do+     lbl_default <- getLabelBc++     let+         mkTree :: [(Discr, BCInstrList)] -> Discr -> Discr -> BcM BCInstrList+         mkTree [] _range_lo _range_hi = return (unitOL (JMP lbl_default))+             -- shouldn't happen?++         mkTree [val] range_lo range_hi+            | range_lo == range_hi+            = return (snd val)+            | null defaults -- Note [CASEFAIL]+            = do lbl <- getLabelBc+                 return (testEQ (fst val) lbl+                            `consOL` (snd val+                            `appOL`  (LABEL lbl `consOL` unitOL CASEFAIL)))+            | otherwise+            = return (testEQ (fst val) lbl_default `consOL` snd val)++            -- Note [CASEFAIL] It may be that this case has no default+            -- branch, but the alternatives are not exhaustive - this+            -- happens for GADT cases for example, where the types+            -- prove that certain branches are impossible.  We could+            -- just assume that the other cases won't occur, but if+            -- this assumption was wrong (because of a bug in GHC)+            -- then the result would be a segfault.  So instead we+            -- emit an explicit test and a CASEFAIL instruction that+            -- causes the interpreter to barf() if it is ever+            -- executed.++         mkTree vals range_lo range_hi+            = let n = length vals `div` 2+                  vals_lo = take n vals+                  vals_hi = drop n vals+                  v_mid = fst (head vals_hi)+              in do+              label_geq <- getLabelBc+              code_lo <- mkTree vals_lo range_lo (dec v_mid)+              code_hi <- mkTree vals_hi v_mid range_hi+              return (testLT v_mid label_geq+                      `consOL` (code_lo+                      `appOL`   unitOL (LABEL label_geq)+                      `appOL`   code_hi))++         the_default+            = case defaults of+                []         -> nilOL+                [(_, def)] -> LABEL lbl_default `consOL` def+                _          -> panic "mkMultiBranch/the_default"+     instrs <- mkTree notd_ways init_lo init_hi+     return (instrs `appOL` the_default)+  where+         (defaults, not_defaults) = partition (isNoDiscr.fst) raw_ways+         notd_ways = sortBy (comparing fst) not_defaults++         testLT (DiscrI i) fail_label = TESTLT_I i fail_label+         testLT (DiscrW i) fail_label = TESTLT_W i fail_label+         testLT (DiscrF i) fail_label = TESTLT_F i fail_label+         testLT (DiscrD i) fail_label = TESTLT_D i fail_label+         testLT (DiscrP i) fail_label = TESTLT_P i fail_label+         testLT NoDiscr    _          = panic "mkMultiBranch NoDiscr"++         testEQ (DiscrI i) fail_label = TESTEQ_I i fail_label+         testEQ (DiscrW i) fail_label = TESTEQ_W i fail_label+         testEQ (DiscrF i) fail_label = TESTEQ_F i fail_label+         testEQ (DiscrD i) fail_label = TESTEQ_D i fail_label+         testEQ (DiscrP i) fail_label = TESTEQ_P i fail_label+         testEQ NoDiscr    _          = panic "mkMultiBranch NoDiscr"++         -- None of these will be needed if there are no non-default alts+         (init_lo, init_hi)+            | null notd_ways+            = panic "mkMultiBranch: awesome foursome"+            | otherwise+            = case fst (head notd_ways) of+                DiscrI _ -> ( DiscrI minBound,  DiscrI maxBound )+                DiscrW _ -> ( DiscrW minBound,  DiscrW maxBound )+                DiscrF _ -> ( DiscrF minF,      DiscrF maxF )+                DiscrD _ -> ( DiscrD minD,      DiscrD maxD )+                DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound )+                NoDiscr -> panic "mkMultiBranch NoDiscr"++         (algMinBound, algMaxBound)+            = case maybe_ncons of+                 -- XXX What happens when n == 0?+                 Just n  -> (0, fromIntegral n - 1)+                 Nothing -> (minBound, maxBound)++         isNoDiscr NoDiscr = True+         isNoDiscr _       = False++         dec (DiscrI i) = DiscrI (i-1)+         dec (DiscrW w) = DiscrW (w-1)+         dec (DiscrP i) = DiscrP (i-1)+         dec other      = other         -- not really right, but if you+                -- do cases on floating values, you'll get what you deserve++         -- same snotty comment applies to the following+         minF, maxF :: Float+         minD, maxD :: Double+         minF = -1.0e37+         maxF =  1.0e37+         minD = -1.0e308+         maxD =  1.0e308+++-- -----------------------------------------------------------------------------+-- Supporting junk for the compilation schemes++-- Describes case alts+data Discr+   = DiscrI Int+   | DiscrW Word+   | DiscrF Float+   | DiscrD Double+   | DiscrP Word16+   | NoDiscr+    deriving (Eq, Ord)++instance Outputable Discr where+   ppr (DiscrI i) = int i+   ppr (DiscrW w) = text (show w)+   ppr (DiscrF f) = text (show f)+   ppr (DiscrD d) = text (show d)+   ppr (DiscrP i) = ppr i+   ppr NoDiscr    = text "DEF"+++lookupBCEnv_maybe :: Id -> BCEnv -> Maybe ByteOff+lookupBCEnv_maybe = Map.lookup++idSizeW :: DynFlags -> Id -> WordOff+idSizeW dflags = WordOff . argRepSizeW dflags . bcIdArgRep++idSizeCon :: DynFlags -> Id -> ByteOff+idSizeCon dflags = ByteOff . primRepSizeB dflags . bcIdPrimRep++bcIdArgRep :: Id -> ArgRep+bcIdArgRep = toArgRep . bcIdPrimRep++bcIdPrimRep :: Id -> PrimRep+bcIdPrimRep id+  | [rep] <- typePrimRepArgs (idType id)+  = rep+  | otherwise+  = pprPanic "bcIdPrimRep" (ppr id <+> dcolon <+> ppr (idType id))++repSizeWords :: DynFlags -> PrimRep -> WordOff+repSizeWords dflags rep = WordOff $ argRepSizeW dflags (toArgRep rep)++isFollowableArg :: ArgRep -> Bool+isFollowableArg P = True+isFollowableArg _ = False++isVoidArg :: ArgRep -> Bool+isVoidArg V = True+isVoidArg _ = False++-- See bug #1257+multiValException :: a+multiValException = throwGhcException (ProgramError+  ("Error: bytecode compiler can't handle unboxed tuples and sums.\n"+++   "  Possibly due to foreign import/export decls in source.\n"+++   "  Workaround: use -fobject-code, or compile this module to .o separately."))++-- | Indicate if the calling convention is supported+isSupportedCConv :: CCallSpec -> Bool+isSupportedCConv (CCallSpec _ cconv _) = case cconv of+   CCallConv            -> True     -- we explicitly pattern match on every+   StdCallConv          -> True     -- convention to ensure that a warning+   PrimCallConv         -> False    -- is triggered when a new one is added+   JavaScriptCallConv   -> False+   CApiConv             -> False++-- See bug #10462+unsupportedCConvException :: a+unsupportedCConvException = throwGhcException (ProgramError+  ("Error: bytecode compiler can't handle some foreign calling conventions\n"+++   "  Workaround: use -fobject-code, or compile this module to .o separately."))++mkSlideB :: DynFlags -> ByteOff -> ByteOff -> OrdList BCInstr+mkSlideB dflags !nb !db = mkSlideW n d+  where+    !n = trunc16W $ bytesToWords dflags nb+    !d = bytesToWords dflags db++mkSlideW :: Word16 -> WordOff -> OrdList BCInstr+mkSlideW !n !ws+    | ws > fromIntegral limit+    -- If the amount to slide doesn't fit in a Word16, generate multiple slide+    -- instructions+    = SLIDE n limit `consOL` mkSlideW n (ws - fromIntegral limit)+    | ws == 0+    = nilOL+    | otherwise+    = unitOL (SLIDE n $ fromIntegral ws)+  where+    limit :: Word16+    limit = maxBound++splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann])+        -- The arguments are returned in *right-to-left* order+splitApp e | Just e' <- bcView e = splitApp e'+splitApp (AnnApp (_,f) (_,a))    = case splitApp f of+                                      (f', as) -> (f', a:as)+splitApp e                       = (e, [])+++bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)+-- The "bytecode view" of a term discards+--  a) type abstractions+--  b) type applications+--  c) casts+--  d) ticks (but not breakpoints)+-- Type lambdas *can* occur in random expressions,+-- whereas value lambdas cannot; that is why they are nuked here+bcView (AnnCast (_,e) _)             = Just e+bcView (AnnLam v (_,e)) | isTyVar v  = Just e+bcView (AnnApp (_,e) (_, AnnType _)) = Just e+bcView (AnnTick Breakpoint{} _)      = Nothing+bcView (AnnTick _other_tick (_,e))   = Just e+bcView _                             = Nothing++isVAtom :: AnnExpr' Var ann -> Bool+isVAtom e | Just e' <- bcView e = isVAtom e'+isVAtom (AnnVar v)              = isVoidArg (bcIdArgRep v)+isVAtom (AnnCoercion {})        = True+isVAtom _                     = False++atomPrimRep :: AnnExpr' Id ann -> PrimRep+atomPrimRep e | Just e' <- bcView e = atomPrimRep e'+atomPrimRep (AnnVar v)              = bcIdPrimRep v+atomPrimRep (AnnLit l)              = typePrimRep1 (literalType l)++-- #12128:+-- A case expression can be an atom because empty cases evaluate to bottom.+-- See Note [Empty case alternatives] in coreSyn/CoreSyn.hs+atomPrimRep (AnnCase _ _ ty _)      = ASSERT(typePrimRep ty == [LiftedRep]) 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))++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 Functor BcM where+    fmap = liftM++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 view
@@ -0,0 +1,368 @@+{-# 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"+#include "../includes/MachDeps.h"++import GhcPrelude++import ByteCodeTypes+import GHCi.RemoteTypes+import GHCi.FFI (C_ffi_cif)+import StgCmmLayout     ( ArgRep(..) )+import PprCore+import Outputable+import FastString+import Name+import Unique+import Id+import CoreSyn+import Literal+import DataCon+import VarSet+import PrimOp+import SMRep++import Data.Word+import GHC.Stack.CCS (CostCentre)++-- ----------------------------------------------------------------------------+-- Bytecode instructions++data ProtoBCO a+   = ProtoBCO {+        protoBCOName       :: a,          -- name, in some sense+        protoBCOInstrs     :: [BCInstr],  -- instrs+        -- arity and GC info+        protoBCOBitmap     :: [StgWord],+        protoBCOBitmapSize :: Word16,+        protoBCOArity      :: Int,+        -- what the BCO came from+        protoBCOExpr       :: Either  [AnnAlt Id DVarSet] (AnnExpr Id DVarSet),+        -- malloc'd pointers+        protoBCOFFIs       :: [FFIInfo]+   }++type LocalLabel = Word16++data BCInstr+   -- Messing with the stack+   = STKCHECK  Word++   -- Push locals (existing bits of the stack)+   | PUSH_L    !Word16{-offset-}+   | PUSH_LL   !Word16 !Word16{-2 offsets-}+   | PUSH_LLL  !Word16 !Word16 !Word16{-3 offsets-}++   -- Push the specified local as a 8, 16, 32 bit value onto the stack. (i.e.,+   -- the stack will grow by 8, 16 or 32 bits)+   | PUSH8  !Word16+   | PUSH16 !Word16+   | PUSH32 !Word16++   -- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the+   -- value will take the whole word on the stack (i.e., the stack will gorw by+   -- a word)+   -- This is useful when extracting a packed constructor field for further use.+   -- Currently we expect all values on the stack to take full words, except for+   -- the ones used for PACK (i.e., actually constracting new data types, in+   -- which case we use PUSH{8,16,32})+   | PUSH8_W  !Word16+   | PUSH16_W !Word16+   | PUSH32_W !Word16++   -- Push a ptr  (these all map to PUSH_G really)+   | PUSH_G       Name+   | PUSH_PRIMOP  PrimOp+   | PUSH_BCO     (ProtoBCO Name)++   -- Push an alt continuation+   | PUSH_ALTS          (ProtoBCO Name)+   | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep++   -- Pushing 8, 16 and 32 bits of padding (for constructors).+   | PUSH_PAD8+   | PUSH_PAD16+   | PUSH_PAD32++   -- Pushing literals+   | PUSH_UBX8  Literal+   | PUSH_UBX16 Literal+   | PUSH_UBX32 Literal+   | PUSH_UBX   Literal Word16+        -- push this int/float/double/addr, on the stack. Word16+        -- is # of words to copy from literal pool.  Eitherness reflects+        -- the difficulty of dealing with MachAddr here, mostly due to+        -- the excessive (and unnecessary) restrictions imposed by the+        -- designers of the new Foreign library.  In particular it is+        -- quite impossible to convert an Addr to any other integral+        -- type, and it appears impossible to get hold of the bits of+        -- an addr, even though we need to assemble BCOs.++   -- various kinds of application+   | PUSH_APPLY_N+   | PUSH_APPLY_V+   | PUSH_APPLY_F+   | PUSH_APPLY_D+   | PUSH_APPLY_L+   | PUSH_APPLY_P+   | PUSH_APPLY_PP+   | PUSH_APPLY_PPP+   | PUSH_APPLY_PPPP+   | PUSH_APPLY_PPPPP+   | PUSH_APPLY_PPPPPP++   | SLIDE     Word16{-this many-} Word16{-down by this much-}++   -- To do with the heap+   | ALLOC_AP  !Word16 -- make an AP with this many payload words+   | ALLOC_AP_NOUPD !Word16 -- make an AP_NOUPD with this many payload words+   | ALLOC_PAP !Word16 !Word16 -- make a PAP with this arity / payload words+   | MKAP      !Word16{-ptr to AP is this far down stack-} !Word16{-number of words-}+   | MKPAP     !Word16{-ptr to PAP is this far down stack-} !Word16{-number of words-}+   | UNPACK    !Word16 -- unpack N words from t.o.s Constr+   | PACK      DataCon !Word16+                        -- after assembly, the DataCon is an index into the+                        -- itbl array+   -- For doing case trees+   | LABEL     LocalLabel+   | TESTLT_I  Int    LocalLabel+   | TESTEQ_I  Int    LocalLabel+   | TESTLT_W  Word   LocalLabel+   | TESTEQ_W  Word   LocalLabel+   | TESTLT_F  Float  LocalLabel+   | TESTEQ_F  Float  LocalLabel+   | TESTLT_D  Double LocalLabel+   | TESTEQ_D  Double LocalLabel++   -- The Word16 value is a constructor number and therefore+   -- stored in the insn stream rather than as an offset into+   -- the literal pool.+   | TESTLT_P  Word16 LocalLabel+   | TESTEQ_P  Word16 LocalLabel++   | CASEFAIL+   | JMP              LocalLabel++   -- For doing calls to C (via glue code generated by libffi)+   | CCALL            Word16    -- stack frame size+                      (RemotePtr C_ffi_cif) -- addr of the glue code+                      Word16    -- flags.+                                --+                                -- 0x1: call is interruptible+                                -- 0x2: call is unsafe+                                --+                                -- (XXX: inefficient, but I don't know+                                -- what the alignment constraints are.)++   -- For doing magic ByteArray passing to foreign calls+   | SWIZZLE          Word16 -- to the ptr N words down the stack,+                      Word16 -- add M (interpreted as a signed 16-bit entity)++   -- To Infinity And Beyond+   | ENTER+   | RETURN             -- return a lifted value+   | RETURN_UBX ArgRep -- return an unlifted value, here's its rep++   -- Breakpoints+   | BRK_FUN          Word16 Unique (RemotePtr CostCentre)++-- -----------------------------------------------------------------------------+-- Printing bytecode instructions++instance Outputable a => Outputable (ProtoBCO a) where+   ppr (ProtoBCO name instrs bitmap bsize arity origin 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 view
@@ -0,0 +1,76 @@+{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}+{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}+--+--  (c) The University of Glasgow 2002-2006+--++-- | ByteCodeItbls: Generate infotables for interpreter-made bytecodes+module ByteCodeItbls ( mkITbls ) where++#include "HsVersions.h"++import GhcPrelude++import ByteCodeTypes+import GHCi+import DynFlags+import HscTypes+import Name             ( Name, getName )+import NameEnv+import DataCon          ( DataCon, dataConRepArgTys, dataConIdentity )+import TyCon            ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )+import RepType+import StgCmmLayout     ( mkVirtConstrSizes )+import StgCmmClosure    ( 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 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+--++-- | 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 view
@@ -0,0 +1,234 @@+{-# LANGUAGE MagicHash #-}++-----------------------------------------------------------------------------+--+-- GHCi Interactive debugging commands+--+-- Pepe Iborra (supported by Google SoC) 2006+--+-- ToDo: lots of violation of layering here.  This module should+-- decide whether it is above the GHC API (import GHC and nothing+-- else) or below it.+--+-----------------------------------------------------------------------------++module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where++import GhcPrelude++import Linker+import RtClosureInspect++import GHCi+import GHCi.RemoteTypes+import GhcMonad+import HscTypes+import Id+import IfaceSyn ( showToHeader )+import IfaceEnv( newInteractiveBinder )+import Name+import Var hiding ( varName )+import VarSet+import UniqSet+import Type+import GHC+import Outputable+import PprTyThing+import ErrUtils+import MonadUtils+import DynFlags+import Exception++import Control.Monad+import Data.List+import Data.Maybe+import Data.IORef++-------------------------------------+-- | The :print & friends commands+-------------------------------------+pprintClosureCommand :: GhcMonad m => Bool -> Bool -> String -> m ()+pprintClosureCommand bindThings force str = do+  tythings <- (catMaybes . concat) `liftM`+                 mapM (\w -> GHC.parseName w >>=+                                mapM GHC.lookupName)+                      (words str)+  let ids = [id | AnId id <- tythings]++  -- Obtain the terms and the recovered type information+  (subst, terms) <- mapAccumLM go emptyTCvSubst ids++  -- Apply the substitutions obtained after recovering the types+  modifySession $ \hsc_env ->+    hsc_env{hsc_IC = substInteractiveContext (hsc_IC hsc_env) subst}++  -- Finally, print the Terms+  unqual  <- GHC.getPrintUnqual+  docterms <- mapM showTerm terms+  dflags <- getDynFlags+  liftIO $ (printOutputForUser dflags unqual . vcat)+           (zipWith (\id docterm -> ppr id <+> char '=' <+> docterm)+                    ids+                    docterms)+ where+   -- Do the obtainTerm--bindSuspensions-computeSubstitution dance+   go :: GhcMonad m => TCvSubst -> Id -> m (TCvSubst, Term)+   go subst id = do+       let id' = id `setIdType` substTy subst (idType id)+       term_    <- GHC.obtainTermFromId maxBound force id'+       term     <- tidyTermTyVars term_+       term'    <- if bindThings+                     then bindSuspensions term+                     else return term+     -- Before leaving, we compare the type obtained to see if it's more specific+     --  Then, we extract a substitution,+     --  mapping the old tyvars to the reconstructed types.+       let reconstructed_type = termType term+       hsc_env <- getSession+       case (improveRTTIType hsc_env (idType id) (reconstructed_type)) of+         Nothing     -> return (subst, term')+         Just subst' -> do { dflags <- GHC.getSessionDynFlags+                           ; liftIO $+                               dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"+                                 (fsep $ [text "RTTI Improvement for", ppr id,+                                  text "is the 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 view
@@ -0,0 +1,667 @@+{-# 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(GHCI)+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(GHCI)+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(GHCI)+   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(GHCI)+   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(GHCI)+  | 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 view
@@ -0,0 +1,1664 @@+{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections, RecordWildCards #-}+{-# LANGUAGE BangPatterns #-}+{-# OPTIONS_GHC -fno-cse #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++--+--  (c) The University of Glasgow 2002-2006+--+-- | The dynamic linker for GHCi.+--+-- This module deals with the top-level issues of dynamic linking,+-- calling the object-code linker and the byte-code linker where+-- necessary.+module Linker ( getHValue, showLinkerState,+                linkExpr, linkDecls, unload, withExtendedLinkEnv,+                extendLinkEnv, deleteFromLinkEnv,+                extendLoadedPkgs,+                linkPackages, initDynLinker, linkModule,+                linkCmdLineLibs,+                uninitializedLinker+        ) where++#include "HsVersions.h"++import GhcPrelude++import GHCi+import GHCi.RemoteTypes+import LoadIface+import ByteCodeLink+import ByteCodeAsm+import ByteCodeTypes+import TcRnMonad+import Packages+import DriverPhases+import Finder+import HscTypes+import Name+import NameEnv+import Module+import ListSetOps+import LinkerTypes (DynLinker(..), LinkerUnitId, PersistentLinkerState(..))+import DynFlags+import BasicTypes+import Outputable+import Panic+import Util+import ErrUtils+import SrcLoc+import qualified Maybes+import UniqDSet+import FastString+import 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 (fst $ sPgm_c $ settings 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++      pls1 <- foldM (preloadLib hsc_env lib_paths framework_paths) pls+                    cmdline_lib_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++{- 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 (Object 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+    Object static_ish -> do+      (b, pls1) <- preload_static lib_paths static_ish+      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_static _paths name+       = do b <- doesFileExist name+            if not b then return (False, pls)+                     else if dynamicGhc+                             then  do pls1 <- dynLoadObjs hsc_env pls [name]+                                      return (True, pls1)+                             else  do loadObj hsc_env name+                                      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 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 pls)+                        ++ concatMap (\lp -> [ Option ("-L" ++ lp)+                                                    , Option "-Xlinker"+                                                    , Option "-rpath"+                                                    , Option "-Xlinker"+                                                    , Option lp ])+                                     (nub $ fst <$> temp_sos pls)+                        ++ 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 pls)++    -- 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 pls }+        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.+      | otherwise+      = mapM_ (unloadObj hsc_env) [f | DotO f <- linkableUnlinked lnk]+                -- The components of a BCO linkable may contain+                -- dot-o files.  Which is very confusing.+                --+                -- But the BCO parts can be unlinked just by+                -- letting go of them (plus of course depopulating+                -- the symbol table which is done in the main body)++{- **********************************************************************++                Loading packages++  ********************************************************************* -}++data LibrarySpec+   = Object FilePath    -- Full path name of a .o file, including trailing .o+                        -- 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++-- 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 (Object nm)    = "(static) " ++ nm+showLS (Archive nm)   = "(static archive) " ++ nm+showLS (DLL nm)       = "(dynamic) " ++ nm+showLS (DLLPath nm)   = "(dynamic) " ++ nm+showLS (Framework nm) = "(framework) " ++ nm++-- | Link exactly the specified packages, and their dependents (unless of+-- course they are already linked).  The dependents are linked+-- automatically, and it doesn't matter what order you specify the input+-- packages.+--+linkPackages :: HscEnv -> [LinkerUnitId] -> IO ()+-- NOTE: in fact, since each module tracks all the packages it depends on,+--       we don't really need to use the package-config dependencies.+--+-- However we do need the package-config stuff (to find aux libs etc),+-- and following them lets us load libraries in the right order, which+-- perhaps makes the error message a bit more localised if we get a link+-- failure.  So the dependency walking code is still here.++linkPackages hsc_env new_pkgs = do+  -- It's probably not safe to try to load packages concurrently, so we take+  -- a lock.+  initDynLinker hsc_env+  let dl = hsc_dynLinker hsc_env+  modifyPLS_ dl $ \pls -> do+    linkPackages' hsc_env new_pkgs pls++linkPackages' :: HscEnv -> [LinkerUnitId] -> PersistentLinkerState+             -> IO PersistentLinkerState+linkPackages' hsc_env new_pks pls = do+    pkgs' <- link (pkgs_loaded pls) new_pks+    return $! pls { pkgs_loaded = pkgs' }+  where+     dflags = hsc_dflags hsc_env++     link :: [LinkerUnitId] -> [LinkerUnitId] -> IO [LinkerUnitId]+     link pkgs new_pkgs =+         foldM link_one pkgs new_pkgs++     link_one pkgs new_pkg+        | new_pkg `elem` pkgs   -- Already linked+        = return pkgs++        | Just pkg_cfg <- lookupInstalledPackage dflags new_pkg+        = do {  -- Link dependents first+               pkgs' <- link pkgs (depends pkg_cfg)+                -- Now link the package itself+             ; linkPackage hsc_env pkg_cfg+             ; return (new_pkg : pkgs') }++        | otherwise+        = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (installedUnitIdFS new_pkg)))+++linkPackage :: HscEnv -> PackageConfig -> IO ()+linkPackage hsc_env pkg+   = do+        let dflags    = hsc_dflags hsc_env+            platform  = targetPlatform dflags+            is_dyn = interpreterDynamic dflags+            dirs | is_dyn    = Packages.libraryDynDirs pkg+                 | otherwise = Packages.libraryDirs pkg++        let hs_libs   =  Packages.hsLibraries pkg+            -- The FFI GHCi import lib isn't needed as+            -- compiler/ghci/Linker.hs + rts/Linker.c link the+            -- interpreted references to FFI to the compiled FFI.+            -- We therefore filter it out so that we don't get+            -- duplicate symbol errors.+            hs_libs'  =  filter ("HSffi" /=) hs_libs++        -- Because of slight differences between the GHC dynamic linker and+        -- the native system linker some packages have to link with a+        -- different list of libraries when using GHCi. Examples include: libs+        -- that are actually gnu ld scripts, and the possibility that the .a+        -- libs do not exactly match the .so/.dll equivalents. So if the+        -- package file provides an "extra-ghci-libraries" field then we use+        -- that instead of the "extra-libraries" field.+            extra_libs =+                      (if null (Packages.extraGHCiLibraries pkg)+                            then Packages.extraLibraries pkg+                            else Packages.extraGHCiLibraries pkg)+                      ++ [ lib | '-':'l':lib <- Packages.ldOptions pkg ]+        -- See Note [Fork/Exec Windows]+        gcc_paths <- getGCCPaths dflags (platformOS platform)+        dirs_env <- addEnvPaths "LIBRARY_PATH" dirs++        hs_classifieds+           <- mapM (locateLib hsc_env True  dirs_env gcc_paths) hs_libs'+        extra_classifieds+           <- mapM (locateLib hsc_env False dirs_env gcc_paths) extra_libs+        let classifieds = hs_classifieds ++ extra_classifieds++        -- Complication: all the .so's must be loaded before any of the .o's.+        let known_dlls = [ dll  | DLLPath dll    <- classifieds ]+            dlls       = [ dll  | DLL dll        <- classifieds ]+            objs       = [ obj  | Object obj     <- classifieds ]+            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 -> PackageConfig -> IO ()+loadFrameworks hsc_env platform pkg+    = when (platformUsesFrameworks platform) $ mapM_ load frameworks+  where+    fw_dirs    = Packages.frameworkDirs pkg+    frameworks = Packages.frameworks pkg++    load fw = do  r <- loadFramework hsc_env fw_dirs fw+                  case r of+                    Nothing  -> return ()+                    Just err -> cmdLineErrorIO ("can't load framework: "+                                                ++ fw ++ " (" ++ err ++ ")" )++-- Try to find an object file for a given library in the given paths.+-- If it isn't present, we assume that addDLL in the RTS can find it,+-- which generally means that it should be a dynamic library in the+-- standard system search path.+-- For GHCi we tend to prefer dynamic libraries over static ones as+-- they are easier to load and manage, have less overhead.+locateLib :: HscEnv -> Bool -> [FilePath] -> [FilePath] -> String+          -> IO LibrarySpec+locateLib hsc_env is_hs lib_dirs gcc_dirs lib+  | not is_hs+    -- For non-Haskell libraries (e.g. gmp, iconv):+    --   first look in library-dirs for a dynamic library (on User paths only)+    --   (libfoo.so)+    --   then  try looking for import libraries on Windows (on User paths only)+    --   (.dll.a, .lib)+    --   first look in library-dirs for a dynamic library (on GCC paths only)+    --   (libfoo.so)+    --   then  check for system dynamic libraries (e.g. kernel32.dll on windows)+    --   then  try looking for import libraries on Windows (on GCC paths only)+    --   (.dll.a, .lib)+    --   then  look in library-dirs for a static library (libfoo.a)+    --   then look in library-dirs and inplace GCC for a dynamic library (libfoo.so)+    --   then  try looking for import libraries on Windows (.dll.a, .lib)+    --   then  look in library-dirs and inplace GCC for a static library (libfoo.a)+    --   then  try "gcc --print-file-name" to search gcc's search path+    --       for a dynamic library (#5289)+    --   otherwise, assume loadDLL can find it+    --+    --   The logic is a bit complicated, but the rationale behind it is that+    --   loading a shared library for us is O(1) while loading an archive is+    --   O(n). Loading an import library is also O(n) so in general we prefer+    --   shared libraries because they are simpler and faster.+    --+  = 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 Object)  $ findFile dirs obj_file+     findDynObject = liftM (fmap Object)  $ 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++     assumeDll   = return (DLL lib)+     infixr `orElse`+     f `orElse` g = f >>= maybe g return++     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 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 RtClosureInspect(+     -- * Entry points and types+     cvObtainTerm,+     cvReconstructType,+     improveRTTIType,+     Term(..),++     -- * Utils+     isFullyEvaluatedTerm,+     termType, mapTermType, termTyCoVars,+     foldTerm, TermFold(..),+     cPprTerm, cPprTermBase,++     constrClosToName -- exported to use in test T4891+ ) where++#include "HsVersions.h"++import GhcPrelude++import GHCi+import GHCi.RemoteTypes+import HscTypes++import DataCon+import Type+import RepType+import qualified Unify as U+import Var+import TcRnMonad+import TcType+import TcMType+import TcHsSyn ( zonkTcTypeToTypeX, mkEmptyZonkEnv, ZonkFlexi( RuntimeUnkFlexi ) )+import TcUnify+import TcEnv++import TyCon+import Name+import OccName+import Module+import IfaceEnv+import Util+import VarSet+import BasicTypes       ( Boxity(..) )+import TysPrim+import PrelNames+import TysWiredIn+import DynFlags+import Outputable as Ppr+import GHC.Char+import GHC.Exts.Heap+import SMRep ( roundUpTo )++import Control.Monad+import Data.Maybe+import Data.List+#if defined(INTEGER_GMP)+import GHC.Exts+import Data.Array.Base+import GHC.Integer.GMP.Internals+#elif defined(INTEGER_SIMPLE)+import GHC.Exts+import GHC.Integer.Simple.Internals+#endif+import qualified Data.Sequence as Seq+import Data.Sequence (viewl, ViewL(..))+import Foreign+import System.IO.Unsafe+++---------------------------------------------+-- * A representation of semi evaluated Terms+---------------------------------------------++data Term = Term { ty        :: RttiType+                 , dc        :: Either String DataCon+                               -- Carries a text representation if the datacon is+                               -- not exported by the .hi file, which is the case+                               -- for private constructors in -O0 compiled libraries+                 , val       :: ForeignHValue+                 , subTerms  :: [Term] }++          | Prim { ty        :: RttiType+                 , valRaw    :: [Word] }++          | Suspension { ctype    :: ClosureType+                       , ty       :: RttiType+                       , val      :: ForeignHValue+                       , bound_to :: Maybe Name   -- Useful for printing+                       }+          | NewtypeWrap{       -- At runtime there are no newtypes, and hence no+                               -- newtype constructors. A NewtypeWrap is just a+                               -- made-up tag saying "heads up, there used to be+                               -- a newtype constructor here".+                         ty           :: RttiType+                       , dc           :: Either String DataCon+                       , wrapped_term :: Term }+          | RefWrap    {       -- The contents of a reference+                         ty           :: RttiType+                       , wrapped_term :: Term }++termType :: Term -> RttiType+termType t = ty t++isFullyEvaluatedTerm :: Term -> Bool+isFullyEvaluatedTerm Term {subTerms=tt} = all isFullyEvaluatedTerm tt+isFullyEvaluatedTerm Prim {}            = True+isFullyEvaluatedTerm NewtypeWrap{wrapped_term=t} = isFullyEvaluatedTerm t+isFullyEvaluatedTerm RefWrap{wrapped_term=t}     = isFullyEvaluatedTerm t+isFullyEvaluatedTerm _                  = False++instance Outputable (Term) where+ ppr t | Just doc <- cPprTerm cPprTermBase t = doc+       | otherwise = panic "Outputable Term instance"++----------------------------------------+-- Runtime Closure information functions+----------------------------------------++isThunk :: GenClosure a -> Bool+isThunk ThunkClosure{} = True+isThunk APClosure{} = True+isThunk APStackClosure{} = True+isThunk _             = False++-- Lookup the name in a constructor closure+constrClosToName :: HscEnv -> GenClosure a -> IO (Either String Name)+constrClosToName hsc_env ConstrClosure{pkg=pkg,modl=mod,name=occ} = do+   let occName = mkOccName OccName.dataName occ+       modName = mkModule (stringToUnitId pkg) (mkModuleName mod)+   Right `fmap` lookupOrigIO hsc_env modName occName+constrClosToName _hsc_env clos =+   return (Left ("conClosToName: Expected ConstrClosure, got " ++ show (fmap (const ()) clos)))++-----------------------------------+-- * Traversals for Terms+-----------------------------------+type TermProcessor a b = RttiType -> Either String DataCon -> ForeignHValue -> [a] -> b++data TermFold a = TermFold { fTerm        :: TermProcessor a a+                           , fPrim        :: RttiType -> [Word] -> a+                           , fSuspension  :: ClosureType -> RttiType -> ForeignHValue+                                            -> Maybe Name -> a+                           , fNewtypeWrap :: RttiType -> Either String DataCon+                                            -> a -> a+                           , fRefWrap     :: RttiType -> a -> a+                           }+++data TermFoldM m a =+                   TermFoldM {fTermM        :: TermProcessor a (m a)+                            , fPrimM        :: RttiType -> [Word] -> m a+                            , fSuspensionM  :: ClosureType -> RttiType -> ForeignHValue+                                             -> Maybe Name -> m a+                            , fNewtypeWrapM :: RttiType -> Either String DataCon+                                            -> a -> m a+                            , fRefWrapM     :: RttiType -> a -> m a+                           }++foldTerm :: TermFold a -> Term -> a+foldTerm tf (Term ty dc v tt) = fTerm tf ty dc v (map (foldTerm tf) tt)+foldTerm tf (Prim ty    v   ) = fPrim tf ty v+foldTerm tf (Suspension ct ty v b) = fSuspension tf ct ty v b+foldTerm tf (NewtypeWrap ty dc t)  = fNewtypeWrap tf ty dc (foldTerm tf t)+foldTerm tf (RefWrap ty t)         = fRefWrap tf ty (foldTerm tf t)+++foldTermM :: Monad m => TermFoldM m a -> Term -> m a+foldTermM tf (Term ty dc v tt) = mapM (foldTermM tf) tt >>= fTermM tf ty dc v+foldTermM tf (Prim ty    v   ) = fPrimM tf ty v+foldTermM tf (Suspension ct ty v b) = fSuspensionM tf ct ty v b+foldTermM tf (NewtypeWrap ty dc t)  = foldTermM tf t >>=  fNewtypeWrapM tf ty dc+foldTermM tf (RefWrap ty t)         = foldTermM tf t >>= fRefWrapM tf ty++idTermFold :: TermFold Term+idTermFold = TermFold {+              fTerm = Term,+              fPrim = Prim,+              fSuspension  = Suspension,+              fNewtypeWrap = NewtypeWrap,+              fRefWrap = RefWrap+                      }++mapTermType :: (RttiType -> Type) -> Term -> Term+mapTermType f = foldTerm idTermFold {+          fTerm       = \ty dc hval tt -> Term (f ty) dc hval tt,+          fSuspension = \ct ty hval n ->+                          Suspension ct (f ty) hval n,+          fNewtypeWrap= \ty dc t -> NewtypeWrap (f ty) dc t,+          fRefWrap    = \ty t -> RefWrap (f ty) t}++mapTermTypeM :: Monad m =>  (RttiType -> m Type) -> Term -> m Term+mapTermTypeM f = foldTermM TermFoldM {+          fTermM       = \ty dc hval tt -> f ty >>= \ty' -> return $ Term ty'  dc hval tt,+          fPrimM       = (return.) . Prim,+          fSuspensionM = \ct ty hval n ->+                          f ty >>= \ty' -> return $ Suspension ct ty' hval n,+          fNewtypeWrapM= \ty dc t -> f ty >>= \ty' -> return $ NewtypeWrap ty' dc t,+          fRefWrapM    = \ty t -> f ty >>= \ty' -> return $ RefWrap ty' t}++termTyCoVars :: Term -> TyCoVarSet+termTyCoVars = foldTerm TermFold {+            fTerm       = \ty _ _ tt   ->+                          tyCoVarsOfType ty `unionVarSet` concatVarEnv tt,+            fSuspension = \_ ty _ _ -> tyCoVarsOfType ty,+            fPrim       = \ _ _ -> emptyVarSet,+            fNewtypeWrap= \ty _ t -> tyCoVarsOfType ty `unionVarSet` t,+            fRefWrap    = \ty t -> tyCoVarsOfType ty `unionVarSet` t}+    where concatVarEnv = foldr unionVarSet emptyVarSet++----------------------------------+-- Pretty printing of terms+----------------------------------++type Precedence        = Int+type TermPrinterM m    = Precedence -> Term -> m SDoc++app_prec,cons_prec, max_prec ::Int+max_prec  = 10+app_prec  = max_prec+cons_prec = 5 -- TODO Extract this info from GHC itself++pprTermM, ppr_termM, pprNewtypeWrap :: Monad m => TermPrinterM m -> TermPrinterM m+pprTermM y p t = pprDeeper `liftM` ppr_termM y p t++ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do+  tt_docs <- mapM (y app_prec) tt+  return $ cparen (not (null tt) && p >= app_prec)+                  (text dc_tag <+> pprDeeperList fsep tt_docs)++ppr_termM y p Term{dc=Right dc, subTerms=tt}+{-  | dataConIsInfix dc, (t1:t2:tt') <- tt  --TODO fixity+  = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)+    <+> hsep (map (ppr_term1 True) tt)+-} -- TODO Printing infix constructors properly+  = do { tt_docs' <- mapM (y app_prec) tt+       ; return $ ifPprDebug (show_tm tt_docs')+                             (show_tm (dropList (dataConTheta dc) tt_docs'))+                  -- Don't show the dictionary arguments to+                  -- constructors unless -dppr-debug is on+       }+  where+    show_tm tt_docs+      | null tt_docs = ppr dc+      | otherwise    = cparen (p >= app_prec) $+                       sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)]++ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t+ppr_termM y p RefWrap{wrapped_term=t}  = do+  contents <- y app_prec t+  return$ cparen (p >= app_prec) (text "GHC.Prim.MutVar#" <+> contents)+  -- The constructor name is wired in here ^^^ for the sake of simplicity.+  -- I don't think mutvars are going to change in a near future.+  -- In any case this is solely a presentation matter: MutVar# is+  -- a datatype with no constructors, implemented by the RTS+  -- (hence there is no way to obtain a datacon and print it).+ppr_termM _ _ t = ppr_termM1 t+++ppr_termM1 :: Monad m => Term -> m SDoc+ppr_termM1 Prim{valRaw=words, ty=ty} =+    return $ repPrim (tyConAppTyCon ty) words+ppr_termM1 Suspension{ty=ty, bound_to=Nothing} =+    return (char '_' <+> whenPprDebug (text "::" <> ppr ty))+ppr_termM1 Suspension{ty=ty, bound_to=Just n}+--  | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<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+          -- StgCmmLayout.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+              -- StgCmmLayout.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/hieFile/HieAst.hs view
@@ -0,0 +1,1760 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+module HieAst ( mkHieFile ) where++import GhcPrelude++import Avail                      ( Avails )+import Bag                        ( Bag, bagToList )+import BasicTypes+import BooleanFormula+import Class                      ( FunDep )+import CoreUtils                  ( exprType )+import ConLike                    ( conLikeName )+import Config                     ( cProjectVersion )+import Desugar                    ( deSugarExpr )+import FieldLabel+import HsSyn+import HscTypes+import Module                     ( ModuleName, ml_hs_file )+import MonadUtils                 ( concatMapM, liftIO )+import Name                       ( Name, nameSrcSpan, setNameLoc )+import NameEnv                    ( NameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv )+import SrcLoc+import TcHsSyn                    ( hsLitType, hsPatType )+import Type                       ( mkVisFunTys, Type )+import TysWiredIn                 ( mkListTy, mkSumTy )+import Var                        ( Id, Var, setVarName, varName, varType )+import TcRnTypes+import MkIface                    ( mkIfaceExports )++import HieTypes+import HieUtils++import qualified Data.Array as A+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BSC+import qualified Data.Map as M+import qualified Data.Set as S+import Data.Data                  ( Data, Typeable )+import Data.List                  ( foldl1' )+import Data.Maybe                 ( listToMaybe )+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Class  ( lift )++-- These synonyms match those defined in main/GHC.hs+type RenamedSource     = ( HsGroup GhcRn, [LImportDecl GhcRn]+                         , Maybe [(LIE GhcRn, Avails)]+                         , Maybe LHsDocString )+type TypecheckedSource = LHsBinds GhcTc+++{- Note [Name Remapping]+The Typechecker introduces new names for mono names in AbsBinds.+We don't care about the distinction between mono and poly bindings,+so we replace all occurrences of the mono name with the poly name.+-}+newtype HieState = HieState+  { name_remapping :: NameEnv Id+  }++initState :: HieState+initState = HieState emptyNameEnv++class ModifyState a where -- See Note [Name Remapping]+  addSubstitution :: a -> a -> HieState -> HieState++instance ModifyState Name where+  addSubstitution _ _ hs = hs++instance ModifyState Id where+  addSubstitution mono poly hs =+    hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly}++modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState+modifyState = foldr go id+  where+    go ABE{abe_poly=poly,abe_mono=mono} f = addSubstitution mono poly . f+    go _ f = f++type HieM = ReaderT HieState Hsc++-- | Construct an 'HieFile' from the outputs of the typechecker.+mkHieFile :: ModSummary+          -> TcGblEnv+          -> RenamedSource -> Hsc HieFile+mkHieFile ms ts rs = do+  let tc_binds = tcg_binds ts+  (asts', arr) <- getCompressedAsts tc_binds rs+  let Just src_file = ml_hs_file $ ms_location ms+  src <- liftIO $ BS.readFile src_file+  return $ HieFile+      { hie_version = curHieVersion+      , hie_ghc_version = BSC.pack cProjectVersion+      , hie_hs_file = src_file+      , hie_module = ms_mod ms+      , hie_types = arr+      , hie_asts = asts'+      -- mkIfaceExports sorts the AvailInfos for stability+      , hie_exports = mkIfaceExports (tcg_exports ts)+      , hie_hs_src = src+      }++getCompressedAsts :: TypecheckedSource -> RenamedSource+  -> Hsc (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)+getCompressedAsts ts rs = do+  asts <- enrichHie ts rs+  return $ compressTypes asts++enrichHie :: TypecheckedSource -> RenamedSource -> Hsc (HieASTs Type)+enrichHie ts (hsGrp, imports, exports, _) = flip runReaderT initState $ do+    tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts+    rasts <- processGrp hsGrp+    imps <- toHie $ filter (not . ideclImplicit . unLoc) imports+    exps <- toHie $ fmap (map $ IEC Export . fst) exports+    let spanFile children = case children of+          [] -> mkRealSrcSpan (mkRealSrcLoc "" 1 1) (mkRealSrcLoc "" 1 1)+          _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)+                             (realSrcSpanEnd   $ nodeSpan $ last children)++        modulify xs =+          Node (simpleNodeInfo "Module" "Module") (spanFile xs) xs++        asts = HieASTs+          $ resolveTyVarScopes+          $ M.map (modulify . mergeSortAsts)+          $ M.fromListWith (++)+          $ map (\x -> (srcSpanFile (nodeSpan x),[x])) flat_asts++        flat_asts = concat+          [ tasts+          , rasts+          , imps+          , exps+          ]+    return asts+  where+    processGrp grp = concatM+      [ toHie $ fmap (RS ModuleScope ) hs_valds grp+      , toHie $ hs_splcds grp+      , toHie $ hs_tyclds grp+      , toHie $ hs_derivds grp+      , toHie $ hs_fixds grp+      , toHie $ hs_defds grp+      , toHie $ hs_fords grp+      , toHie $ hs_warnds grp+      , toHie $ hs_annds grp+      , toHie $ hs_ruleds grp+      ]++getRealSpan :: SrcSpan -> Maybe Span+getRealSpan (RealSrcSpan sp) = Just sp+getRealSpan _ = Nothing++grhss_span :: GRHSs p body -> SrcSpan+grhss_span (GRHSs _ xs bs) = foldl' combineSrcSpans (getLoc bs) (map getLoc xs)+grhss_span (XGRHSs _) = error "XGRHS has no span"++bindingsOnly :: [Context Name] -> [HieAST a]+bindingsOnly [] = []+bindingsOnly (C c n : xs) = case nameSrcSpan n of+  RealSrcSpan span -> Node nodeinfo span [] : bindingsOnly xs+    where nodeinfo = NodeInfo S.empty [] (M.singleton (Right n) info)+          info = mempty{identInfo = S.singleton c}+  _ -> bindingsOnly xs++concatM :: Monad m => [m [a]] -> m [a]+concatM xs = concat <$> sequence xs++{- Note [Capturing Scopes and other non local information]+toHie is a local tranformation, but scopes of bindings cannot be known locally,+hence we have to push the relevant info down into the binding nodes.+We use the following types (*Context and *Scoped) to wrap things and+carry the required info+(Maybe Span) always carries the span of the entire binding, including rhs+-}+data Context a = C ContextInfo a -- Used for names and bindings++data RContext a = RC RecFieldContext a+data RFContext a = RFC RecFieldContext (Maybe Span) a+-- ^ context for record fields++data IEContext a = IEC IEType a+-- ^ context for imports/exports++data BindContext a = BC BindType Scope a+-- ^ context for imports/exports++data PatSynFieldContext a = PSC (Maybe Span) a+-- ^ context for pattern synonym fields.++data SigContext a = SC SigInfo a+-- ^ context for type signatures++data SigInfo = SI SigType (Maybe Span)++data SigType = BindSig | ClassSig | InstSig++data RScoped a = RS Scope a+-- ^ Scope spans over everything to the right of a, (mostly) not+-- including a itself+-- (Includes a in a few special cases like recursive do bindings) or+-- let/where bindings++-- | Pattern scope+data PScoped a = PS (Maybe Span)+                    Scope       -- ^ use site of the pattern+                    Scope       -- ^ pattern to the right of a, not including a+                    a+  deriving (Typeable, Data) -- Pattern Scope++{- Note [TyVar Scopes]+Due to -XScopedTypeVariables, type variables can be in scope quite far from+their original binding. We resolve the scope of these type variables+in a separate pass+-}+data TScoped a = TS TyVarScope a -- TyVarScope++data TVScoped a = TVS TyVarScope Scope a -- TyVarScope+-- ^ First scope remains constant+-- Second scope is used to build up the scope of a tyvar over+-- things to its right, ala RScoped++-- | Each element scopes over the elements to the right+listScopes :: Scope -> [Located a] -> [RScoped (Located a)]+listScopes _ [] = []+listScopes rhsScope [pat] = [RS rhsScope pat]+listScopes rhsScope (pat : pats) = RS sc pat : pats'+  where+    pats'@((RS scope p):_) = listScopes rhsScope pats+    sc = combineScopes scope $ mkScope $ getLoc p++-- | 'listScopes' specialised to 'PScoped' things+patScopes+  :: Maybe Span+  -> Scope+  -> Scope+  -> [LPat (GhcPass p)]+  -> [PScoped (LPat (GhcPass p))]+patScopes rsp useScope patScope xs =+  map (\(RS sc a) -> PS rsp useScope sc (unLoc a)) $+    listScopes patScope (map dL xs)++-- | 'listScopes' specialised to 'TVScoped' things+tvScopes+  :: TyVarScope+  -> Scope+  -> [LHsTyVarBndr a]+  -> [TVScoped (LHsTyVarBndr a)]+tvScopes tvScope rhsScope xs =+  map (\(RS sc a)-> TVS tvScope sc a) $ listScopes rhsScope xs++{- Note [Scoping Rules for SigPat]+Explicitly quantified variables in pattern type signatures are not+brought into scope in the rhs, but implicitly quantified variables+are (HsWC and HsIB).+This is unlike other signatures, where explicitly quantified variables+are brought into the RHS Scope+For example+foo :: forall a. ...;+foo = ... -- a is in scope here++bar (x :: forall a. a -> a) = ... -- a is not in scope here+--   ^ a is in scope here (pattern body)++bax (x :: a) = ... -- a is in scope here+Because of HsWC and HsIB pass on their scope to their children+we must wrap the LHsType in pattern signatures in a+Shielded explictly, so that the HsWC/HsIB scope is not passed+on the the LHsType+-}++data Shielded a = SH Scope a -- Ignores its TScope, uses its own scope instead++type family ProtectedSig a where+  ProtectedSig GhcRn = HsWildCardBndrs GhcRn (HsImplicitBndrs+                                                GhcRn+                                                (Shielded (LHsType GhcRn)))+  ProtectedSig GhcTc = NoExt++class ProtectSig a where+  protectSig :: Scope -> LHsSigWcType (NoGhcTc a) -> ProtectedSig a++instance (HasLoc a) => HasLoc (Shielded a) where+  loc (SH _ a) = loc a++instance (ToHie (TScoped a)) => ToHie (TScoped (Shielded a)) where+  toHie (TS _ (SH sc a)) = toHie (TS (ResolvedScopes [sc]) a)++instance ProtectSig GhcTc where+  protectSig _ _ = NoExt++instance ProtectSig GhcRn where+  protectSig sc (HsWC a (HsIB b sig)) =+    HsWC a (HsIB b (SH sc sig))+  protectSig _ _ = error "protectSig not given HsWC (HsIB)"++class HasLoc a where+  -- ^ defined so that HsImplicitBndrs and HsWildCardBndrs can+  -- know what their implicit bindings are scoping over+  loc :: a -> SrcSpan++instance HasLoc thing => HasLoc (TScoped thing) where+  loc (TS _ a) = loc a++instance HasLoc thing => HasLoc (PScoped thing) where+  loc (PS _ _ _ a) = loc a++instance HasLoc (LHsQTyVars GhcRn) where+  loc (HsQTvs _ vs) = loc vs+  loc _ = noSrcSpan++instance HasLoc thing => HasLoc (HsImplicitBndrs a thing) where+  loc (HsIB _ a) = loc a+  loc _ = noSrcSpan++instance HasLoc thing => HasLoc (HsWildCardBndrs a thing) where+  loc (HsWC _ a) = loc a+  loc _ = noSrcSpan++instance HasLoc (Located a) where+  loc (L l _) = l++instance HasLoc a => HasLoc [a] where+  loc [] = noSrcSpan+  loc xs = foldl1' combineSrcSpans $ map loc xs++instance HasLoc a => HasLoc (FamEqn s a) where+  loc (FamEqn _ a Nothing b _ c) = foldl1' combineSrcSpans [loc a, loc b, loc c]+  loc (FamEqn _ a (Just tvs) b _ c) = foldl1' combineSrcSpans+                                              [loc a, loc tvs, loc b, loc c]+  loc _ = noSrcSpan+instance (HasLoc tm, HasLoc ty) => HasLoc (HsArg tm ty) where+  loc (HsValArg tm) = loc tm+  loc (HsTypeArg _ ty) = loc ty+  loc (HsArgPar sp)  = sp++instance HasLoc (HsDataDefn GhcRn) where+  loc def@(HsDataDefn{}) = loc $ dd_cons def+    -- Only used for data family instances, so we only need rhs+    -- Most probably the rest will be unhelpful anyway+  loc _ = noSrcSpan++instance HasLoc (Pat (GhcPass a)) where+  loc (dL -> L l _) = l++-- | The main worker class+class ToHie a where+  toHie :: a -> HieM [HieAST Type]++-- | Used to collect type info+class Data a => HasType a where+  getTypeNode :: a -> HieM [HieAST Type]++instance (ToHie a) => ToHie [a] where+  toHie = concatMapM toHie++instance (ToHie a) => ToHie (Bag a) where+  toHie = toHie . bagToList++instance (ToHie a) => ToHie (Maybe a) where+  toHie = maybe (pure []) toHie++instance ToHie (Context (Located NoExt)) where+  toHie _ = pure []++instance ToHie (TScoped NoExt) where+  toHie _ = pure []++instance ToHie (IEContext (Located ModuleName)) where+  toHie (IEC c (L (RealSrcSpan span) mname)) =+      pure $ [Node (NodeInfo S.empty [] idents) span []]+    where details = mempty{identInfo = S.singleton (IEThing c)}+          idents = M.singleton (Left mname) details+  toHie _ = pure []++instance ToHie (Context (Located Var)) where+  toHie c = case c of+      C context (L (RealSrcSpan span) name')+        -> do+        m <- asks name_remapping+        let name = case lookupNameEnv m (varName name') of+              Just var -> var+              Nothing-> name'+        pure+          [Node+            (NodeInfo S.empty [] $+              M.singleton (Right $ varName name)+                          (IdentifierDetails (Just $ varType name')+                                             (S.singleton context)))+            span+            []]+      _ -> pure []++instance ToHie (Context (Located Name)) where+  toHie c = case c of+      C context (L (RealSrcSpan span) name') -> do+        m <- asks name_remapping+        let name = case lookupNameEnv m name' of+              Just var -> varName var+              Nothing -> name'+        pure+          [Node+            (NodeInfo S.empty [] $+              M.singleton (Right name)+                          (IdentifierDetails Nothing+                                             (S.singleton context)))+            span+            []]+      _ -> pure []++-- | Dummy instances - never called+instance ToHie (TScoped (LHsSigWcType GhcTc)) where+  toHie _ = pure []+instance ToHie (TScoped (LHsWcType GhcTc)) where+  toHie _ = pure []+instance ToHie (SigContext (LSig GhcTc)) where+  toHie _ = pure []+instance ToHie (TScoped Type) where+  toHie _ = pure []++instance HasType (LHsBind GhcRn) where+  getTypeNode (L spn bind) = makeNode bind spn++instance HasType (LHsBind GhcTc) where+  getTypeNode (L spn bind) = case bind of+      FunBind{fun_id = name} -> makeTypeNode bind spn (varType $ unLoc name)+      _ -> makeNode bind spn++instance HasType (LPat GhcRn) where+  getTypeNode (dL -> L spn pat) = makeNode pat spn++instance HasType (LPat GhcTc) where+  getTypeNode (dL -> L spn opat) = makeTypeNode opat spn (hsPatType opat)++instance HasType (LHsExpr GhcRn) where+  getTypeNode (L spn e) = makeNode e spn++-- | This instance tries to construct 'HieAST' nodes which include the type of+-- the expression. It is not yet possible to do this efficiently for all+-- expression forms, so we skip filling in the type for those inputs.+--+-- 'HsApp', for example, doesn't have any type information available directly on+-- the node. Our next recourse would be to desugar it into a 'CoreExpr' then+-- query the type of that. Yet both the desugaring call and the type query both+-- involve recursive calls to the function and argument! This is particularly+-- problematic when you realize that the HIE traversal will eventually visit+-- those nodes too and ask for their types again.+--+-- Since the above is quite costly, we just skip cases where computing the+-- expression's type is going to be expensive.+--+-- See #16233+instance HasType (LHsExpr GhcTc) where+  getTypeNode e@(L spn e') = lift $+    -- Some expression forms have their type immediately available+    let tyOpt = case e' of+          HsLit _ l -> Just (hsLitType l)+          HsOverLit _ o -> Just (overLitType o)++          HsLam     _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)+          HsLamCase _ (MG { mg_ext = groupTy }) -> Just (matchGroupType groupTy)+          HsCase _  _ (MG { mg_ext = groupTy }) -> Just (mg_res_ty groupTy)++          ExplicitList  ty _ _   -> Just (mkListTy ty)+          ExplicitSum   ty _ _ _ -> Just (mkSumTy ty)+          HsDo          ty _ _   -> Just ty+          HsMultiIf     ty _     -> Just ty++          _ -> Nothing++    in+    case tyOpt of+      _ | skipDesugaring e' -> fallback+        | otherwise -> do+            hs_env <- Hsc $ \e w -> return (e,w)+            (_,mbe) <- liftIO $ deSugarExpr hs_env e+            maybe fallback (makeTypeNode e' spn . exprType) mbe+    where+      fallback = makeNode e' spn++      matchGroupType :: MatchGroupTc -> Type+      matchGroupType (MatchGroupTc args res) = mkVisFunTys args res++      -- | Skip desugaring of these expressions for performance reasons.+      --+      -- See impact on Haddock output (esp. missing type annotations or links)+      -- before marking more things here as 'False'. See impact on Haddock+      -- performance before marking more things as 'True'.+      skipDesugaring :: HsExpr a -> Bool+      skipDesugaring e = case e of+        HsVar{}        -> False+        HsUnboundVar{} -> False+        HsConLikeOut{} -> False+        HsRecFld{}     -> False+        HsOverLabel{}  -> False+        HsIPVar{}      -> False+        HsWrap{}       -> False+        _              -> True++instance ( ToHie (Context (Located (IdP a)))+         , ToHie (MatchGroup a (LHsExpr a))+         , ToHie (PScoped (LPat a))+         , ToHie (GRHSs a (LHsExpr a))+         , ToHie (LHsExpr a)+         , ToHie (Located (PatSynBind a a))+         , HasType (LHsBind a)+         , ModifyState (IdP a)+         , Data (HsBind a)+         ) => ToHie (BindContext (LHsBind a)) where+  toHie (BC context scope b@(L span bind)) =+    concatM $ getTypeNode b : case bind of+      FunBind{fun_id = name, fun_matches = matches} ->+        [ toHie $ C (ValBind context scope $ getRealSpan span) name+        , toHie matches+        ]+      PatBind{pat_lhs = lhs, pat_rhs = rhs} ->+        [ toHie $ PS (getRealSpan span) scope NoScope lhs+        , toHie rhs+        ]+      VarBind{var_rhs = expr} ->+        [ toHie expr+        ]+      AbsBinds{abs_exports = xs, abs_binds = binds} ->+        [ local (modifyState xs) $ -- Note [Name Remapping]+            toHie $ fmap (BC context scope) binds+        ]+      PatSynBind _ psb ->+        [ toHie $ L span psb -- PatSynBinds only occur at the top level+        ]+      XHsBindsLR _ -> []++instance ( ToHie (LMatch a body)+         ) => ToHie (MatchGroup a body) where+  toHie mg = concatM $ case mg of+    MG{ mg_alts = (L span alts) , mg_origin = FromSource } ->+      [ pure $ locOnly span+      , toHie alts+      ]+    MG{} -> []+    XMatchGroup _ -> []++instance ( ToHie (Context (Located (IdP a)))+         , ToHie (PScoped (LPat a))+         , ToHie (HsPatSynDir a)+         ) => ToHie (Located (PatSynBind a a)) where+    toHie (L sp psb) = concatM $ case psb of+      PSB{psb_id=var, psb_args=dets, psb_def=pat, psb_dir=dir} ->+        [ toHie $ C (Decl PatSynDec $ getRealSpan sp) var+        , toHie $ toBind dets+        , toHie $ PS Nothing lhsScope NoScope pat+        , toHie dir+        ]+        where+          lhsScope = combineScopes varScope detScope+          varScope = mkLScope var+          detScope = case dets of+            (PrefixCon args) -> foldr combineScopes NoScope $ map mkLScope args+            (InfixCon a b) -> combineScopes (mkLScope a) (mkLScope b)+            (RecCon r) -> foldr go NoScope r+          go (RecordPatSynField a b) c = combineScopes c+            $ combineScopes (mkLScope a) (mkLScope b)+          detSpan = case detScope of+            LocalScope a -> Just a+            _ -> Nothing+          toBind (PrefixCon args) = PrefixCon $ map (C Use) args+          toBind (InfixCon a b) = InfixCon (C Use a) (C Use b)+          toBind (RecCon r) = RecCon $ map (PSC detSpan) r+      XPatSynBind _ -> []++instance ( ToHie (MatchGroup a (LHsExpr a))+         ) => ToHie (HsPatSynDir a) where+  toHie dir = case dir of+    ExplicitBidirectional mg -> toHie mg+    _ -> pure []++instance ( a ~ GhcPass p+         , ToHie body+         , ToHie (HsMatchContext (NameOrRdrName (IdP a)))+         , ToHie (PScoped (LPat a))+         , ToHie (GRHSs a body)+         , Data (Match a body)+         ) => ToHie (LMatch (GhcPass p) body) where+  toHie (L span m ) = concatM $ makeNode m span : case m of+    Match{m_ctxt=mctx, m_pats = pats, m_grhss =  grhss } ->+      [ toHie mctx+      , let rhsScope = mkScope $ grhss_span grhss+          in toHie $ patScopes Nothing rhsScope NoScope pats+      , toHie grhss+      ]+    XMatch _ -> []++instance ( ToHie (Context (Located a))+         ) => ToHie (HsMatchContext a) where+  toHie (FunRhs{mc_fun=name}) = toHie $ C MatchBind name+  toHie (StmtCtxt a) = toHie a+  toHie _ = pure []++instance ( ToHie (HsMatchContext a)+         ) => ToHie (HsStmtContext a) where+  toHie (PatGuard a) = toHie a+  toHie (ParStmtCtxt a) = toHie a+  toHie (TransStmtCtxt a) = toHie a+  toHie _ = pure []++instance ( a ~ GhcPass p+         , ToHie (Context (Located (IdP a)))+         , ToHie (RContext (HsRecFields a (PScoped (LPat a))))+         , ToHie (LHsExpr a)+         , ToHie (TScoped (LHsSigWcType a))+         , ProtectSig a+         , ToHie (TScoped (ProtectedSig a))+         , HasType (LPat a)+         , Data (HsSplice a)+         ) => ToHie (PScoped (LPat (GhcPass p))) where+  toHie (PS rsp scope pscope lpat@(dL -> L ospan opat)) =+    concatM $ getTypeNode lpat : case opat of+      WildPat _ ->+        []+      VarPat _ lname ->+        [ toHie $ C (PatternBind scope pscope rsp) lname+        ]+      LazyPat _ p ->+        [ toHie $ PS rsp scope pscope p+        ]+      AsPat _ lname pat ->+        [ toHie $ C (PatternBind scope+                                 (combineScopes (mkLScope (dL pat)) pscope)+                                 rsp)+                    lname+        , toHie $ PS rsp scope pscope pat+        ]+      ParPat _ pat ->+        [ toHie $ PS rsp scope pscope pat+        ]+      BangPat _ pat ->+        [ toHie $ PS rsp scope pscope pat+        ]+      ListPat _ pats ->+        [ toHie $ patScopes rsp scope pscope pats+        ]+      TuplePat _ pats _ ->+        [ toHie $ patScopes rsp scope pscope pats+        ]+      SumPat _ pat _ _ ->+        [ toHie $ PS rsp scope pscope pat+        ]+      ConPatIn c dets ->+        [ toHie $ C Use c+        , toHie $ contextify dets+        ]+      ConPatOut {pat_con = con, pat_args = dets}->+        [ toHie $ C Use $ fmap conLikeName con+        , toHie $ contextify dets+        ]+      ViewPat _ expr pat ->+        [ toHie expr+        , toHie $ PS rsp scope pscope pat+        ]+      SplicePat _ sp ->+        [ toHie $ L ospan sp+        ]+      LitPat _ _ ->+        []+      NPat _ _ _ _ ->+        []+      NPlusKPat _ n _ _ _ _ ->+        [ toHie $ C (PatternBind scope pscope rsp) n+        ]+      SigPat _ pat sig ->+        [ toHie $ PS rsp scope pscope pat+        , let cscope = mkLScope (dL pat) in+            toHie $ TS (ResolvedScopes [cscope, scope, pscope])+                       (protectSig @a cscope sig)+              -- See Note [Scoping Rules for SigPat]+        ]+      CoPat _ _ _ _ ->+        []+      XPat _ -> []+    where+      contextify (PrefixCon args) = PrefixCon $ patScopes rsp scope pscope args+      contextify (InfixCon a b) = InfixCon a' b'+        where [a', b'] = patScopes rsp scope pscope [a,b]+      contextify (RecCon r) = RecCon $ RC RecFieldMatch $ contextify_rec r+      contextify_rec (HsRecFields fds a) = HsRecFields (map go scoped_fds) a+        where+          go (RS fscope (L spn (HsRecField lbl pat pun))) =+            L spn $ HsRecField lbl (PS rsp scope fscope pat) pun+          scoped_fds = listScopes pscope fds++instance ( ToHie body+         , ToHie (LGRHS a body)+         , ToHie (RScoped (LHsLocalBinds a))+         ) => ToHie (GRHSs a body) where+  toHie grhs = concatM $ case grhs of+    GRHSs _ grhss binds ->+     [ toHie grhss+     , toHie $ RS (mkScope $ grhss_span grhs) binds+     ]+    XGRHSs _ -> []++instance ( ToHie (Located body)+         , ToHie (RScoped (GuardLStmt a))+         , Data (GRHS a (Located body))+         ) => ToHie (LGRHS a (Located body)) where+  toHie (L span g) = concatM $ makeNode g span : case g of+    GRHS _ guards body ->+      [ toHie $ listScopes (mkLScope body) guards+      , toHie body+      ]+    XGRHS _ -> []++instance ( a ~ GhcPass p+         , ToHie (Context (Located (IdP a)))+         , HasType (LHsExpr a)+         , ToHie (PScoped (LPat a))+         , ToHie (MatchGroup a (LHsExpr a))+         , ToHie (LGRHS a (LHsExpr a))+         , ToHie (RContext (HsRecordBinds a))+         , ToHie (RFContext (Located (AmbiguousFieldOcc a)))+         , ToHie (ArithSeqInfo a)+         , ToHie (LHsCmdTop a)+         , ToHie (RScoped (GuardLStmt a))+         , ToHie (RScoped (LHsLocalBinds a))+         , ToHie (TScoped (LHsWcType (NoGhcTc a)))+         , ToHie (TScoped (LHsSigWcType (NoGhcTc a)))+         , Data (HsExpr a)+         , Data (HsSplice a)+         , Data (HsTupArg a)+         , Data (AmbiguousFieldOcc a)+         ) => ToHie (LHsExpr (GhcPass p)) where+  toHie e@(L mspan oexpr) = concatM $ getTypeNode e : case oexpr of+      HsVar _ (L _ var) ->+        [ toHie $ C Use (L mspan var)+             -- Patch up var location since typechecker removes it+        ]+      HsUnboundVar _ _ ->+        []+      HsConLikeOut _ con ->+        [ toHie $ C Use $ L mspan $ conLikeName con+        ]+      HsRecFld _ fld ->+        [ toHie $ RFC RecFieldOcc Nothing (L mspan fld)+        ]+      HsOverLabel _ _ _ -> []+      HsIPVar _ _ -> []+      HsOverLit _ _ -> []+      HsLit _ _ -> []+      HsLam _ mg ->+        [ toHie mg+        ]+      HsLamCase _ mg ->+        [ toHie mg+        ]+      HsApp _ a b ->+        [ toHie a+        , toHie b+        ]+      HsAppType _ expr sig ->+        [ toHie expr+        , toHie $ TS (ResolvedScopes []) sig+        ]+      OpApp _ a b c ->+        [ toHie a+        , toHie b+        , toHie c+        ]+      NegApp _ a _ ->+        [ toHie a+        ]+      HsPar _ a ->+        [ toHie a+        ]+      SectionL _ a b ->+        [ toHie a+        , toHie b+        ]+      SectionR _ a b ->+        [ toHie a+        , toHie b+        ]+      ExplicitTuple _ args _ ->+        [ toHie args+        ]+      ExplicitSum _ _ _ expr ->+        [ toHie expr+        ]+      HsCase _ expr matches ->+        [ toHie expr+        , toHie matches+        ]+      HsIf _ _ a b c ->+        [ toHie a+        , toHie b+        , toHie c+        ]+      HsMultiIf _ grhss ->+        [ toHie grhss+        ]+      HsLet _ binds expr ->+        [ toHie $ RS (mkLScope expr) binds+        , toHie expr+        ]+      HsDo _ _ (L ispan stmts) ->+        [ pure $ locOnly ispan+        , toHie $ listScopes NoScope stmts+        ]+      ExplicitList _ _ exprs ->+        [ toHie exprs+        ]+      RecordCon {rcon_con_name = name, rcon_flds = binds}->+        [ toHie $ C Use name+        , toHie $ RC RecFieldAssign $ binds+        ]+      RecordUpd {rupd_expr = expr, rupd_flds = upds}->+        [ toHie expr+        , toHie $ map (RC RecFieldAssign) upds+        ]+      ExprWithTySig _ expr sig ->+        [ toHie expr+        , toHie $ TS (ResolvedScopes [mkLScope expr]) sig+        ]+      ArithSeq _ _ info ->+        [ toHie info+        ]+      HsSCC _ _ _ expr ->+        [ toHie expr+        ]+      HsCoreAnn _ _ _ expr ->+        [ toHie expr+        ]+      HsProc _ pat cmdtop ->+        [ toHie $ PS Nothing (mkLScope cmdtop) NoScope pat+        , toHie cmdtop+        ]+      HsStatic _ expr ->+        [ toHie expr+        ]+      HsTick _ _ expr ->+        [ toHie expr+        ]+      HsBinTick _ _ _ expr ->+        [ toHie expr+        ]+      HsTickPragma _ _ _ _ expr ->+        [ toHie expr+        ]+      HsWrap _ _ a ->+        [ toHie $ L mspan a+        ]+      HsBracket _ b ->+        [ toHie b+        ]+      HsRnBracketOut _ b p ->+        [ toHie b+        , toHie p+        ]+      HsTcBracketOut _ b p ->+        [ toHie b+        , toHie p+        ]+      HsSpliceE _ x ->+        [ toHie $ L mspan x+        ]+      XExpr _ -> []++instance ( a ~ GhcPass p+         , ToHie (LHsExpr a)+         , Data (HsTupArg a)+         ) => ToHie (LHsTupArg (GhcPass p)) where+  toHie (L span arg) = concatM $ makeNode arg span : case arg of+    Present _ expr ->+      [ toHie expr+      ]+    Missing _ -> []+    XTupArg _ -> []++instance ( a ~ GhcPass p+         , ToHie (PScoped (LPat a))+         , ToHie (LHsExpr a)+         , ToHie (SigContext (LSig a))+         , ToHie (RScoped (LHsLocalBinds a))+         , ToHie (RScoped (ApplicativeArg a))+         , ToHie (Located body)+         , Data (StmtLR a a (Located body))+         , Data (StmtLR a a (Located (HsExpr a)))+         ) => ToHie (RScoped (LStmt (GhcPass p) (Located body))) where+  toHie (RS scope (L span stmt)) = concatM $ makeNode stmt span : case stmt of+      LastStmt _ body _ _ ->+        [ toHie body+        ]+      BindStmt _ pat body _ _ ->+        [ toHie $ PS (getRealSpan $ getLoc body) scope NoScope pat+        , toHie body+        ]+      ApplicativeStmt _ stmts _ ->+        [ concatMapM (toHie . RS scope . snd) stmts+        ]+      BodyStmt _ body _ _ ->+        [ toHie body+        ]+      LetStmt _ binds ->+        [ toHie $ RS scope binds+        ]+      ParStmt _ parstmts _ _ ->+        [ concatMapM (\(ParStmtBlock _ stmts _ _) ->+                          toHie $ listScopes NoScope stmts)+                     parstmts+        ]+      TransStmt {trS_stmts = stmts, trS_using = using, trS_by = by} ->+        [ toHie $ listScopes scope stmts+        , toHie using+        , toHie by+        ]+      RecStmt {recS_stmts = stmts} ->+        [ toHie $ map (RS $ combineScopes scope (mkScope span)) stmts+        ]+      XStmtLR _ -> []++instance ( ToHie (LHsExpr a)+         , ToHie (PScoped (LPat a))+         , ToHie (BindContext (LHsBind a))+         , ToHie (SigContext (LSig a))+         , ToHie (RScoped (HsValBindsLR a a))+         , Data (HsLocalBinds a)+         ) => ToHie (RScoped (LHsLocalBinds a)) where+  toHie (RS scope (L sp binds)) = concatM $ makeNode binds sp : case binds of+      EmptyLocalBinds _ -> []+      HsIPBinds _ _ -> []+      HsValBinds _ valBinds ->+        [ toHie $ RS (combineScopes scope $ mkScope sp)+                      valBinds+        ]+      XHsLocalBindsLR _ -> []++instance ( ToHie (BindContext (LHsBind a))+         , ToHie (SigContext (LSig a))+         , ToHie (RScoped (XXValBindsLR a a))+         ) => ToHie (RScoped (HsValBindsLR a a)) where+  toHie (RS sc v) = concatM $ case v of+    ValBinds _ binds sigs ->+      [ toHie $ fmap (BC RegularBind sc) binds+      , toHie $ fmap (SC (SI BindSig Nothing)) sigs+      ]+    XValBindsLR x -> [ toHie $ RS sc x ]++instance ToHie (RScoped (NHsValBindsLR GhcTc)) where+  toHie (RS sc (NValBinds binds sigs)) = concatM $+    [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)+    , toHie $ fmap (SC (SI BindSig Nothing)) sigs+    ]+instance ToHie (RScoped (NHsValBindsLR GhcRn)) where+  toHie (RS sc (NValBinds binds sigs)) = concatM $+    [ toHie (concatMap (map (BC RegularBind sc) . bagToList . snd) binds)+    , toHie $ fmap (SC (SI BindSig Nothing)) sigs+    ]++instance ( ToHie (RContext (LHsRecField a arg))+         ) => ToHie (RContext (HsRecFields a arg)) where+  toHie (RC c (HsRecFields fields _)) = toHie $ map (RC c) fields++instance ( ToHie (RFContext (Located label))+         , ToHie arg+         , HasLoc arg+         , Data label+         , Data arg+         ) => ToHie (RContext (LHsRecField' label arg)) where+  toHie (RC c (L span recfld)) = concatM $ makeNode recfld span : case recfld of+    HsRecField label expr _ ->+      [ toHie $ RFC c (getRealSpan $ loc expr) label+      , toHie expr+      ]++removeDefSrcSpan :: Name -> Name+removeDefSrcSpan n = setNameLoc n noSrcSpan++instance ToHie (RFContext (LFieldOcc GhcRn)) where+  toHie (RFC c rhs (L nspan f)) = concatM $ case f of+    FieldOcc name _ ->+      [ toHie $ C (RecField c rhs) (L nspan $ removeDefSrcSpan name)+      ]+    XFieldOcc _ -> []++instance ToHie (RFContext (LFieldOcc GhcTc)) where+  toHie (RFC c rhs (L nspan f)) = concatM $ case f of+    FieldOcc var _ ->+      let var' = setVarName var (removeDefSrcSpan $ varName var)+      in [ toHie $ C (RecField c rhs) (L nspan var')+         ]+    XFieldOcc _ -> []++instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcRn))) where+  toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of+    Unambiguous name _ ->+      [ toHie $ C (RecField c rhs) $ L nspan $ removeDefSrcSpan name+      ]+    Ambiguous _name _ ->+      [ ]+    XAmbiguousFieldOcc _ -> []++instance ToHie (RFContext (Located (AmbiguousFieldOcc GhcTc))) where+  toHie (RFC c rhs (L nspan afo)) = concatM $ case afo of+    Unambiguous var _ ->+      let var' = setVarName var (removeDefSrcSpan $ varName var)+      in [ toHie $ C (RecField c rhs) (L nspan var')+         ]+    Ambiguous var _ ->+      let var' = setVarName var (removeDefSrcSpan $ varName var)+      in [ toHie $ C (RecField c rhs) (L nspan var')+         ]+    XAmbiguousFieldOcc _ -> []++instance ( a ~ GhcPass p+         , ToHie (PScoped (LPat a))+         , ToHie (BindContext (LHsBind a))+         , ToHie (LHsExpr a)+         , ToHie (SigContext (LSig a))+         , ToHie (RScoped (HsValBindsLR a a))+         , Data (StmtLR a a (Located (HsExpr a)))+         , Data (HsLocalBinds a)+         ) => ToHie (RScoped (ApplicativeArg (GhcPass p))) where+  toHie (RS sc (ApplicativeArgOne _ pat expr _)) = concatM+    [ toHie $ PS Nothing sc NoScope pat+    , toHie expr+    ]+  toHie (RS sc (ApplicativeArgMany _ stmts _ pat)) = concatM+    [ toHie $ listScopes NoScope stmts+    , toHie $ PS Nothing sc NoScope pat+    ]+  toHie (RS _ (XApplicativeArg _)) = pure []++instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where+  toHie (PrefixCon args) = toHie args+  toHie (RecCon rec) = toHie rec+  toHie (InfixCon a b) = concatM [ toHie a, toHie b]++instance ( ToHie (LHsCmd a)+         , Data  (HsCmdTop a)+         ) => ToHie (LHsCmdTop a) where+  toHie (L span top) = concatM $ makeNode top span : case top of+    HsCmdTop _ cmd ->+      [ toHie cmd+      ]+    XCmdTop _ -> []++instance ( a ~ GhcPass p+         , ToHie (PScoped (LPat a))+         , ToHie (BindContext (LHsBind a))+         , ToHie (LHsExpr a)+         , ToHie (MatchGroup a (LHsCmd a))+         , ToHie (SigContext (LSig a))+         , ToHie (RScoped (HsValBindsLR a a))+         , Data (HsCmd a)+         , Data (HsCmdTop a)+         , Data (StmtLR a a (Located (HsCmd a)))+         , Data (HsLocalBinds a)+         , Data (StmtLR a a (Located (HsExpr a)))+         ) => ToHie (LHsCmd (GhcPass p)) where+  toHie (L span cmd) = concatM $ makeNode cmd span : case cmd of+      HsCmdArrApp _ a b _ _ ->+        [ toHie a+        , toHie b+        ]+      HsCmdArrForm _ a _ _ cmdtops ->+        [ toHie a+        , toHie cmdtops+        ]+      HsCmdApp _ a b ->+        [ toHie a+        , toHie b+        ]+      HsCmdLam _ mg ->+        [ toHie mg+        ]+      HsCmdPar _ a ->+        [ toHie a+        ]+      HsCmdCase _ expr alts ->+        [ toHie expr+        , toHie alts+        ]+      HsCmdIf _ _ a b c ->+        [ toHie a+        , toHie b+        , toHie c+        ]+      HsCmdLet _ binds cmd' ->+        [ toHie $ RS (mkLScope cmd') binds+        , toHie cmd'+        ]+      HsCmdDo _ (L ispan stmts) ->+        [ pure $ locOnly ispan+        , toHie $ listScopes NoScope stmts+        ]+      HsCmdWrap _ _ _ -> []+      XCmd _ -> []++instance ToHie (TyClGroup GhcRn) where+  toHie (TyClGroup _ classes roles instances) = concatM+    [ toHie classes+    , toHie roles+    , toHie instances+    ]+  toHie (XTyClGroup _) = pure []++instance ToHie (LTyClDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      FamDecl {tcdFam = fdecl} ->+        [ toHie (L span fdecl)+        ]+      SynDecl {tcdLName = name, tcdTyVars = vars, tcdRhs = typ} ->+        [ toHie $ C (Decl SynDec $ getRealSpan span) name+        , toHie $ TS (ResolvedScopes [mkScope $ getLoc typ]) vars+        , toHie typ+        ]+      DataDecl {tcdLName = name, tcdTyVars = vars, tcdDataDefn = defn} ->+        [ toHie $ C (Decl DataDec $ getRealSpan span) name+        , toHie $ TS (ResolvedScopes [quant_scope, rhs_scope]) vars+        , toHie defn+        ]+        where+          quant_scope = mkLScope $ dd_ctxt defn+          rhs_scope = sig_sc `combineScopes` con_sc `combineScopes` deriv_sc+          sig_sc = maybe NoScope mkLScope $ dd_kindSig defn+          con_sc = foldr combineScopes NoScope $ map mkLScope $ dd_cons defn+          deriv_sc = mkLScope $ dd_derivs defn+      ClassDecl { tcdCtxt = context+                , tcdLName = name+                , tcdTyVars = vars+                , tcdFDs = deps+                , tcdSigs = sigs+                , tcdMeths = meths+                , tcdATs = typs+                , tcdATDefs = deftyps+                } ->+        [ toHie $ C (Decl ClassDec $ getRealSpan span) name+        , toHie context+        , toHie $ TS (ResolvedScopes [context_scope, rhs_scope]) vars+        , toHie deps+        , toHie $ map (SC $ SI ClassSig $ getRealSpan span) sigs+        , toHie $ fmap (BC InstanceBind ModuleScope) meths+        , toHie typs+        , concatMapM (pure . locOnly . getLoc) deftyps+        , toHie deftyps+        ]+        where+          context_scope = mkLScope context+          rhs_scope = foldl1' combineScopes $ map mkScope+            [ loc deps, loc sigs, loc (bagToList meths), loc typs, loc deftyps]+      XTyClDecl _ -> []++instance ToHie (LFamilyDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      FamilyDecl _ info name vars _ sig inj ->+        [ toHie $ C (Decl FamDec $ getRealSpan span) name+        , toHie $ TS (ResolvedScopes [rhsSpan]) vars+        , toHie info+        , toHie $ RS injSpan sig+        , toHie inj+        ]+        where+          rhsSpan = sigSpan `combineScopes` injSpan+          sigSpan = mkScope $ getLoc sig+          injSpan = maybe NoScope (mkScope . getLoc) inj+      XFamilyDecl _ -> []++instance ToHie (FamilyInfo GhcRn) where+  toHie (ClosedTypeFamily (Just eqns)) = concatM $+    [ concatMapM (pure . locOnly . getLoc) eqns+    , toHie $ map go eqns+    ]+    where+      go (L l ib) = TS (ResolvedScopes [mkScope l]) ib+  toHie _ = pure []++instance ToHie (RScoped (LFamilyResultSig GhcRn)) where+  toHie (RS sc (L span sig)) = concatM $ makeNode sig span : case sig of+      NoSig _ ->+        []+      KindSig _ k ->+        [ toHie k+        ]+      TyVarSig _ bndr ->+        [ toHie $ TVS (ResolvedScopes [sc]) NoScope bndr+        ]+      XFamilyResultSig _ -> []++instance ToHie (Located (FunDep (Located Name))) where+  toHie (L span fd@(lhs, rhs)) = concatM $+    [ makeNode fd span+    , toHie $ map (C Use) lhs+    , toHie $ map (C Use) rhs+    ]++instance (ToHie rhs, HasLoc rhs)+    => ToHie (TScoped (FamEqn GhcRn rhs)) where+  toHie (TS _ f) = toHie f++instance (ToHie rhs, HasLoc rhs)+    => ToHie (FamEqn GhcRn rhs) where+  toHie fe@(FamEqn _ var tybndrs pats _ rhs) = concatM $+    [ toHie $ C (Decl InstDec $ getRealSpan $ loc fe) var+    , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs+    , toHie pats+    , toHie rhs+    ]+    where scope = combineScopes patsScope rhsScope+          patsScope = mkScope (loc pats)+          rhsScope = mkScope (loc rhs)+  toHie (XFamEqn _) = pure []++instance ToHie (LInjectivityAnn GhcRn) where+  toHie (L span ann) = concatM $ makeNode ann span : case ann of+      InjectivityAnn lhs rhs ->+        [ toHie $ C Use lhs+        , toHie $ map (C Use) rhs+        ]++instance ToHie (HsDataDefn GhcRn) where+  toHie (HsDataDefn _ _ ctx _ mkind cons derivs) = concatM+    [ toHie ctx+    , toHie mkind+    , toHie cons+    , toHie derivs+    ]+  toHie (XHsDataDefn _) = pure []++instance ToHie (HsDeriving GhcRn) where+  toHie (L span clauses) = concatM+    [ pure $ locOnly span+    , toHie clauses+    ]++instance ToHie (LHsDerivingClause GhcRn) where+  toHie (L span cl) = concatM $ makeNode cl span : case cl of+      HsDerivingClause _ strat (L ispan tys) ->+        [ toHie strat+        , pure $ locOnly ispan+        , toHie $ map (TS (ResolvedScopes [])) tys+        ]+      XHsDerivingClause _ -> []++instance ToHie (Located (DerivStrategy GhcRn)) where+  toHie (L span strat) = concatM $ makeNode strat span : case strat of+      StockStrategy -> []+      AnyclassStrategy -> []+      NewtypeStrategy -> []+      ViaStrategy s -> [ toHie $ TS (ResolvedScopes []) s ]++instance ToHie (Located OverlapMode) where+  toHie (L span _) = pure $ locOnly span++instance ToHie (LConDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      ConDeclGADT { con_names = names, con_qvars = qvars+                  , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } ->+        [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names+        , toHie $ TS (ResolvedScopes [ctxScope, rhsScope]) qvars+        , toHie ctx+        , toHie args+        , toHie typ+        ]+        where+          rhsScope = combineScopes argsScope tyScope+          ctxScope = maybe NoScope mkLScope ctx+          argsScope = condecl_scope args+          tyScope = mkLScope typ+      ConDeclH98 { con_name = name, con_ex_tvs = qvars+                 , con_mb_cxt = ctx, con_args = dets } ->+        [ toHie $ C (Decl ConDec $ getRealSpan span) name+        , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars+        , toHie ctx+        , toHie dets+        ]+        where+          rhsScope = combineScopes ctxScope argsScope+          ctxScope = maybe NoScope mkLScope ctx+          argsScope = condecl_scope dets+      XConDecl _ -> []+    where condecl_scope args = case args of+            PrefixCon xs -> foldr combineScopes NoScope $ map mkLScope xs+            InfixCon a b -> combineScopes (mkLScope a) (mkLScope b)+            RecCon x -> mkLScope x++instance ToHie (Located [LConDeclField GhcRn]) where+  toHie (L span decls) = concatM $+    [ pure $ locOnly span+    , toHie decls+    ]++instance ( HasLoc thing+         , ToHie (TScoped thing)+         ) => ToHie (TScoped (HsImplicitBndrs GhcRn thing)) where+  toHie (TS sc (HsIB ibrn a)) = concatM $+      [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) ibrn+      , toHie $ TS sc a+      ]+    where span = loc a+  toHie (TS _ (XHsImplicitBndrs _)) = pure []++instance ( HasLoc thing+         , ToHie (TScoped thing)+         ) => ToHie (TScoped (HsWildCardBndrs GhcRn thing)) where+  toHie (TS sc (HsWC names a)) = concatM $+      [ pure $ bindingsOnly $ map (C $ TyVarBind (mkScope span) sc) names+      , toHie $ TS sc a+      ]+    where span = loc a+  toHie (TS _ (XHsWildCardBndrs _)) = pure []++instance ToHie (SigContext (LSig GhcRn)) where+  toHie (SC (SI styp msp) (L sp sig)) = concatM $ makeNode sig sp : case sig of+      TypeSig _ names typ ->+        [ toHie $ map (C TyDecl) names+        , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ+        ]+      PatSynSig _ names typ ->+        [ toHie $ map (C TyDecl) names+        , toHie $ TS (UnresolvedScope (map unLoc names) Nothing) typ+        ]+      ClassOpSig _ _ names typ ->+        [ case styp of+            ClassSig -> toHie $ map (C $ ClassTyDecl $ getRealSpan sp) names+            _  -> toHie $ map (C $ TyDecl) names+        , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ+        ]+      IdSig _ _ -> []+      FixSig _ fsig ->+        [ toHie $ L sp fsig+        ]+      InlineSig _ name _ ->+        [ toHie $ (C Use) name+        ]+      SpecSig _ name typs _ ->+        [ toHie $ (C Use) name+        , toHie $ map (TS (ResolvedScopes [])) typs+        ]+      SpecInstSig _ _ typ ->+        [ toHie $ TS (ResolvedScopes []) typ+        ]+      MinimalSig _ _ form ->+        [ toHie form+        ]+      SCCFunSig _ _ name mtxt ->+        [ toHie $ (C Use) name+        , pure $ maybe [] (locOnly . getLoc) mtxt+        ]+      CompleteMatchSig _ _ (L ispan names) typ ->+        [ pure $ locOnly ispan+        , toHie $ map (C Use) names+        , toHie $ fmap (C Use) typ+        ]+      XSig _ -> []++instance ToHie (LHsType GhcRn) where+  toHie x = toHie $ TS (ResolvedScopes []) x++instance ToHie (TScoped (LHsType GhcRn)) where+  toHie (TS tsc (L span t)) = concatM $ makeNode t span : case t of+      HsForAllTy _ _ bndrs body ->+        [ toHie $ tvScopes tsc (mkScope $ getLoc body) bndrs+        , toHie body+        ]+      HsQualTy _ ctx body ->+        [ toHie ctx+        , toHie body+        ]+      HsTyVar _ _ var ->+        [ toHie $ C Use var+        ]+      HsAppTy _ a b ->+        [ toHie a+        , toHie b+        ]+      HsAppKindTy _ ty ki ->+        [ toHie ty+        , toHie $ TS (ResolvedScopes []) ki+        ]+      HsFunTy _ a b ->+        [ toHie a+        , toHie b+        ]+      HsListTy _ a ->+        [ toHie a+        ]+      HsTupleTy _ _ tys ->+        [ toHie tys+        ]+      HsSumTy _ tys ->+        [ toHie tys+        ]+      HsOpTy _ a op b ->+        [ toHie a+        , toHie $ C Use op+        , toHie b+        ]+      HsParTy _ a ->+        [ toHie a+        ]+      HsIParamTy _ ip ty ->+        [ toHie ip+        , toHie ty+        ]+      HsKindSig _ a b ->+        [ toHie a+        , toHie b+        ]+      HsSpliceTy _ a ->+        [ toHie $ L span a+        ]+      HsDocTy _ a _ ->+        [ toHie a+        ]+      HsBangTy _ _ ty ->+        [ toHie ty+        ]+      HsRecTy _ fields ->+        [ toHie fields+        ]+      HsExplicitListTy _ _ tys ->+        [ toHie tys+        ]+      HsExplicitTupleTy _ tys ->+        [ toHie tys+        ]+      HsTyLit _ _ -> []+      HsWildCardTy _ -> []+      HsStarTy _ _ -> []+      XHsType _ -> []++instance (ToHie tm, ToHie ty) => ToHie (HsArg tm ty) where+  toHie (HsValArg tm) = toHie tm+  toHie (HsTypeArg _ ty) = toHie ty+  toHie (HsArgPar sp) = pure $ locOnly sp++instance ToHie (TVScoped (LHsTyVarBndr GhcRn)) where+  toHie (TVS tsc sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of+      UserTyVar _ var ->+        [ toHie $ C (TyVarBind sc tsc) var+        ]+      KindedTyVar _ var kind ->+        [ toHie $ C (TyVarBind sc tsc) var+        , toHie kind+        ]+      XTyVarBndr _ -> []++instance ToHie (TScoped (LHsQTyVars GhcRn)) where+  toHie (TS sc (HsQTvs implicits vars)) = concatM $+    [ pure $ bindingsOnly bindings+    , toHie $ tvScopes sc NoScope vars+    ]+    where+      varLoc = loc vars+      bindings = map (C $ TyVarBind (mkScope varLoc) sc) implicits+  toHie (TS _ (XLHsQTyVars _)) = pure []++instance ToHie (LHsContext GhcRn) where+  toHie (L span tys) = concatM $+      [ pure $ locOnly span+      , toHie tys+      ]++instance ToHie (LConDeclField GhcRn) where+  toHie (L span field) = concatM $ makeNode field span : case field of+      ConDeclField _ fields typ _ ->+        [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields+        , toHie typ+        ]+      XConDeclField _ -> []++instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where+  toHie (From expr) = toHie expr+  toHie (FromThen a b) = concatM $+    [ toHie a+    , toHie b+    ]+  toHie (FromTo a b) = concatM $+    [ toHie a+    , toHie b+    ]+  toHie (FromThenTo a b c) = concatM $+    [ toHie a+    , toHie b+    , toHie c+    ]++instance ToHie (LSpliceDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      SpliceDecl _ splice _ ->+        [ toHie splice+        ]+      XSpliceDecl _ -> []++instance ToHie (HsBracket a) where+  toHie _ = pure []++instance ToHie PendingRnSplice where+  toHie _ = pure []++instance ToHie PendingTcSplice where+  toHie _ = pure []++instance ToHie (LBooleanFormula (Located Name)) where+  toHie (L span form) = concatM $ makeNode form span : case form of+      Var a ->+        [ toHie $ C Use a+        ]+      And forms ->+        [ toHie forms+        ]+      Or forms ->+        [ toHie forms+        ]+      Parens f ->+        [ toHie f+        ]++instance ToHie (Located HsIPName) where+  toHie (L span e) = makeNode e span++instance ( ToHie (LHsExpr a)+         , Data (HsSplice a)+         ) => ToHie (Located (HsSplice a)) where+  toHie (L span sp) = concatM $ makeNode sp span : case sp of+      HsTypedSplice _ _ _ expr ->+        [ toHie expr+        ]+      HsUntypedSplice _ _ _ expr ->+        [ toHie expr+        ]+      HsQuasiQuote _ _ _ ispan _ ->+        [ pure $ locOnly ispan+        ]+      HsSpliced _ _ _ ->+        []+      HsSplicedT _ ->+        []+      XSplice _ -> []++instance ToHie (LRoleAnnotDecl GhcRn) where+  toHie (L span annot) = concatM $ makeNode annot span : case annot of+      RoleAnnotDecl _ var roles ->+        [ toHie $ C Use var+        , concatMapM (pure . locOnly . getLoc) roles+        ]+      XRoleAnnotDecl _ -> []++instance ToHie (LInstDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      ClsInstD _ d ->+        [ toHie $ L span d+        ]+      DataFamInstD _ d ->+        [ toHie $ L span d+        ]+      TyFamInstD _ d ->+        [ toHie $ L span d+        ]+      XInstDecl _ -> []++instance ToHie (LClsInstDecl GhcRn) where+  toHie (L span decl) = concatM+    [ toHie $ TS (ResolvedScopes [mkScope span]) $ cid_poly_ty decl+    , toHie $ fmap (BC InstanceBind ModuleScope) $ cid_binds decl+    , toHie $ map (SC $ SI InstSig $ getRealSpan span) $ cid_sigs decl+    , pure $ concatMap (locOnly . getLoc) $ cid_tyfam_insts decl+    , toHie $ cid_tyfam_insts decl+    , pure $ concatMap (locOnly . getLoc) $ cid_datafam_insts decl+    , toHie $ cid_datafam_insts decl+    , toHie $ cid_overlap_mode decl+    ]++instance ToHie (LDataFamInstDecl GhcRn) where+  toHie (L sp (DataFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d++instance ToHie (LTyFamInstDecl GhcRn) where+  toHie (L sp (TyFamInstDecl d)) = toHie $ TS (ResolvedScopes [mkScope sp]) d++instance ToHie (Context a)+         => ToHie (PatSynFieldContext (RecordPatSynField a)) where+  toHie (PSC sp (RecordPatSynField a b)) = concatM $+    [ toHie $ C (RecField RecFieldDecl sp) a+    , toHie $ C Use b+    ]++instance ToHie (LDerivDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      DerivDecl _ typ strat overlap ->+        [ toHie $ TS (ResolvedScopes []) typ+        , toHie strat+        , toHie overlap+        ]+      XDerivDecl _ -> []++instance ToHie (LFixitySig GhcRn) where+  toHie (L span sig) = concatM $ makeNode sig span : case sig of+      FixitySig _ vars _ ->+        [ toHie $ map (C Use) vars+        ]+      XFixitySig _ -> []++instance ToHie (LDefaultDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      DefaultDecl _ typs ->+        [ toHie typs+        ]+      XDefaultDecl _ -> []++instance ToHie (LForeignDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      ForeignImport {fd_name = name, fd_sig_ty = sig, fd_fi = fi} ->+        [ toHie $ C (ValBind RegularBind ModuleScope $ getRealSpan span) name+        , toHie $ TS (ResolvedScopes []) sig+        , toHie fi+        ]+      ForeignExport {fd_name = name, fd_sig_ty = sig, fd_fe = fe} ->+        [ toHie $ C Use name+        , toHie $ TS (ResolvedScopes []) sig+        , toHie fe+        ]+      XForeignDecl _ -> []++instance ToHie ForeignImport where+  toHie (CImport (L a _) (L b _) _ _ (L c _)) = pure $ concat $+    [ locOnly a+    , locOnly b+    , locOnly c+    ]++instance ToHie ForeignExport where+  toHie (CExport (L a _) (L b _)) = pure $ concat $+    [ locOnly a+    , locOnly b+    ]++instance ToHie (LWarnDecls GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      Warnings _ _ warnings ->+        [ toHie warnings+        ]+      XWarnDecls _ -> []++instance ToHie (LWarnDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      Warning _ vars _ ->+        [ toHie $ map (C Use) vars+        ]+      XWarnDecl _ -> []++instance ToHie (LAnnDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      HsAnnotation _ _ prov expr ->+        [ toHie prov+        , toHie expr+        ]+      XAnnDecl _ -> []++instance ToHie (Context (Located a)) => ToHie (AnnProvenance a) where+  toHie (ValueAnnProvenance a) = toHie $ C Use a+  toHie (TypeAnnProvenance a) = toHie $ C Use a+  toHie ModuleAnnProvenance = pure []++instance ToHie (LRuleDecls GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      HsRules _ _ rules ->+        [ toHie rules+        ]+      XRuleDecls _ -> []++instance ToHie (LRuleDecl GhcRn) where+  toHie (L _ (XRuleDecl _)) = pure []+  toHie (L span r@(HsRule _ rname _ tybndrs bndrs exprA exprB)) = concatM+        [ makeNode r span+        , pure $ locOnly $ getLoc rname+        , toHie $ fmap (tvScopes (ResolvedScopes []) scope) tybndrs+        , toHie $ map (RS $ mkScope span) bndrs+        , toHie exprA+        , toHie exprB+        ]+    where scope = bndrs_sc `combineScopes` exprA_sc `combineScopes` exprB_sc+          bndrs_sc = maybe NoScope mkLScope (listToMaybe bndrs)+          exprA_sc = mkLScope exprA+          exprB_sc = mkLScope exprB++instance ToHie (RScoped (LRuleBndr GhcRn)) where+  toHie (RS sc (L span bndr)) = concatM $ makeNode bndr span : case bndr of+      RuleBndr _ var ->+        [ toHie $ C (ValBind RegularBind sc Nothing) var+        ]+      RuleBndrSig _ var typ ->+        [ toHie $ C (ValBind RegularBind sc Nothing) var+        , toHie $ TS (ResolvedScopes [sc]) typ+        ]+      XRuleBndr _ -> []++instance ToHie (LImportDecl GhcRn) where+  toHie (L span decl) = concatM $ makeNode decl span : case decl of+      ImportDecl { ideclName = name, ideclAs = as, ideclHiding = hidden } ->+        [ toHie $ IEC Import name+        , toHie $ fmap (IEC ImportAs) as+        , maybe (pure []) goIE hidden+        ]+      XImportDecl _ -> []+    where+      goIE (hiding, (L sp liens)) = concatM $+        [ pure $ locOnly sp+        , toHie $ map (IEC c) liens+        ]+        where+         c = if hiding then ImportHiding else Import++instance ToHie (IEContext (LIE GhcRn)) where+  toHie (IEC c (L span ie)) = concatM $ makeNode ie span : case ie of+      IEVar _ n ->+        [ toHie $ IEC c n+        ]+      IEThingAbs _ n ->+        [ toHie $ IEC c n+        ]+      IEThingAll _ n ->+        [ toHie $ IEC c n+        ]+      IEThingWith _ n _ ns flds ->+        [ toHie $ IEC c n+        , toHie $ map (IEC c) ns+        , toHie $ map (IEC c) flds+        ]+      IEModuleContents _ n ->+        [ toHie $ IEC c n+        ]+      IEGroup _ _ _ -> []+      IEDoc _ _ -> []+      IEDocNamed _ _ -> []+      XIE _ -> []++instance ToHie (IEContext (LIEWrappedName Name)) where+  toHie (IEC c (L span iewn)) = concatM $ makeNode iewn span : case iewn of+      IEName n ->+        [ toHie $ C (IEThing c) n+        ]+      IEPattern p ->+        [ toHie $ C (IEThing c) p+        ]+      IEType n ->+        [ toHie $ C (IEThing c) n+        ]++instance ToHie (IEContext (Located (FieldLbl Name))) where+  toHie (IEC c (L span lbl)) = concatM $ makeNode lbl span : case lbl of+      FieldLabel _ _ n ->+        [ toHie $ C (IEThing c) $ L span n+        ]
+ compiler/hieFile/HieBin.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE ScopedTypeVariables #-}+module HieBin ( readHieFile, writeHieFile, HieName(..), toHieName ) where++import GhcPrelude++import Binary+import BinIface                   ( getDictFastString )+import FastMutInt+import FastString                 ( FastString )+import Module                     ( Module )+import Name+import NameCache+import Outputable+import PrelInfo+import SrcLoc+import UniqSupply                 ( takeUniqFromSupply )+import Unique+import UniqFM++import qualified Data.Array as A+import Data.IORef+import Data.List                  ( mapAccumR )+import Data.Word                  ( Word32 )+import Control.Monad              ( replicateM )+import System.Directory           ( createDirectoryIfMissing )+import System.FilePath            ( takeDirectory )++-- | `Name`'s get converted into `HieName`'s before being written into @.hie@+-- files. See 'toHieName' and 'fromHieName' for logic on how to convert between+-- these two types.+data HieName+  = ExternalName !Module !OccName !SrcSpan+  | LocalName !OccName !SrcSpan+  | KnownKeyName !Unique+  deriving (Eq)++instance Ord HieName where+  compare (ExternalName a b c) (ExternalName d e f) = compare (a,b,c) (d,e,f)+  compare (LocalName a b) (LocalName c d) = compare (a,b) (c,d)+  compare (KnownKeyName a) (KnownKeyName b) = nonDetCmpUnique a b+    -- Not actually non determinstic as it is a KnownKey+  compare ExternalName{} _ = LT+  compare LocalName{} ExternalName{} = GT+  compare LocalName{} _ = LT+  compare KnownKeyName{} _ = GT++instance Outputable HieName where+  ppr (ExternalName m n sp) = text "ExternalName" <+> ppr m <+> ppr n <+> ppr sp+  ppr (LocalName n sp) = text "LocalName" <+> ppr n <+> ppr sp+  ppr (KnownKeyName u) = text "KnownKeyName" <+> ppr u+++data HieSymbolTable = HieSymbolTable+  { hie_symtab_next :: !FastMutInt+  , hie_symtab_map  :: !(IORef (UniqFM (Int, HieName)))+  }++data HieDictionary = HieDictionary+  { hie_dict_next :: !FastMutInt -- The next index to use+  , hie_dict_map  :: !(IORef (UniqFM (Int,FastString))) -- indexed by FastString+  }++initBinMemSize :: Int+initBinMemSize = 1024*1024++writeHieFile :: Binary a => FilePath -> a -> IO ()+writeHieFile hie_file_path hiefile = do+  bh0 <- openBinMem initBinMemSize++  -- remember where the dictionary pointer will go+  dict_p_p <- tellBin bh0+  put_ bh0 dict_p_p++  -- remember where the symbol table pointer will go+  symtab_p_p <- tellBin bh0+  put_ bh0 symtab_p_p++  -- Make some intial state+  symtab_next <- newFastMutInt+  writeFastMutInt symtab_next 0+  symtab_map <- newIORef emptyUFM+  let hie_symtab = HieSymbolTable {+                      hie_symtab_next = symtab_next,+                      hie_symtab_map  = symtab_map }+  dict_next_ref <- newFastMutInt+  writeFastMutInt dict_next_ref 0+  dict_map_ref <- newIORef emptyUFM+  let hie_dict = HieDictionary {+                      hie_dict_next = dict_next_ref,+                      hie_dict_map  = dict_map_ref }++  -- put the main thing+  let bh = setUserData bh0 $ newWriteState (putName hie_symtab)+                                           (putName hie_symtab)+                                           (putFastString hie_dict)+  put_ bh hiefile++  -- write the symtab pointer at the front of the file+  symtab_p <- tellBin bh+  putAt bh symtab_p_p symtab_p+  seekBin bh symtab_p++  -- write the symbol table itself+  symtab_next' <- readFastMutInt symtab_next+  symtab_map'  <- readIORef symtab_map+  putSymbolTable bh symtab_next' symtab_map'++  -- write the dictionary pointer at the fornt of the file+  dict_p <- tellBin bh+  putAt bh dict_p_p dict_p+  seekBin bh dict_p++  -- write the dictionary itself+  dict_next <- readFastMutInt dict_next_ref+  dict_map  <- readIORef dict_map_ref+  putDictionary bh dict_next dict_map++  -- and send the result to the file+  createDirectoryIfMissing True (takeDirectory hie_file_path)+  writeBinMem bh hie_file_path+  return ()++readHieFile :: Binary a => NameCache -> FilePath -> IO (a, NameCache)+readHieFile nc file = do+  bh0 <- readBinMem file++  dict  <- get_dictionary bh0++  -- read the symbol table so we are capable of reading the actual data+  (bh1, nc') <- do+      let bh1 = setUserData bh0 $ newReadState (error "getSymtabName")+                                               (getDictFastString dict)+      (nc', symtab) <- get_symbol_table bh1+      let bh1' = setUserData bh1+               $ newReadState (getSymTabName symtab)+                              (getDictFastString dict)+      return (bh1', nc')++  -- load the actual data+  hiefile <- get bh1+  return (hiefile, nc')+  where+    get_dictionary bin_handle = do+      dict_p <- get bin_handle+      data_p <- tellBin bin_handle+      seekBin bin_handle dict_p+      dict <- getDictionary bin_handle+      seekBin bin_handle data_p+      return dict++    get_symbol_table bh1 = do+      symtab_p <- get bh1+      data_p'  <- tellBin bh1+      seekBin bh1 symtab_p+      (nc', symtab) <- getSymbolTable bh1 nc+      seekBin bh1 data_p'+      return (nc', symtab)++putFastString :: HieDictionary -> BinHandle -> FastString -> IO ()+putFastString HieDictionary { hie_dict_next = j_r,+                              hie_dict_map  = out_r}  bh f+  = do+    out <- readIORef out_r+    let unique = getUnique f+    case lookupUFM out unique of+        Just (j, _)  -> put_ bh (fromIntegral j :: Word32)+        Nothing -> do+           j <- readFastMutInt j_r+           put_ bh (fromIntegral j :: Word32)+           writeFastMutInt j_r (j + 1)+           writeIORef out_r $! addToUFM out unique (j, f)++putSymbolTable :: BinHandle -> Int -> UniqFM (Int,HieName) -> IO ()+putSymbolTable bh next_off symtab = do+  put_ bh next_off+  let names = A.elems (A.array (0,next_off-1) (nonDetEltsUFM symtab))+  mapM_ (putHieName bh) names++getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, SymbolTable)+getSymbolTable bh namecache = do+  sz <- get bh+  od_names <- replicateM sz (getHieName bh)+  let arr = A.listArray (0,sz-1) names+      (namecache', names) = mapAccumR fromHieName namecache od_names+  return (namecache', arr)++getSymTabName :: SymbolTable -> BinHandle -> IO Name+getSymTabName st bh = do+  i :: Word32 <- get bh+  return $ st A.! (fromIntegral i)++putName :: HieSymbolTable -> BinHandle -> Name -> IO ()+putName (HieSymbolTable next ref) bh name = do+  symmap <- readIORef ref+  case lookupUFM symmap name of+    Just (off, ExternalName mod occ (UnhelpfulSpan _))+      | isGoodSrcSpan (nameSrcSpan name) -> do+      let hieName = ExternalName mod occ (nameSrcSpan name)+      writeIORef ref $! addToUFM symmap name (off, hieName)+      put_ bh (fromIntegral off :: Word32)+    Just (off, LocalName _occ span)+      | notLocal (toHieName name) || nameSrcSpan name /= span -> do+      writeIORef ref $! addToUFM symmap name (off, toHieName name)+      put_ bh (fromIntegral off :: Word32)+    Just (off, _) -> put_ bh (fromIntegral off :: Word32)+    Nothing -> do+        off <- readFastMutInt next+        writeFastMutInt next (off+1)+        writeIORef ref $! addToUFM symmap name (off, toHieName name)+        put_ bh (fromIntegral off :: Word32)++  where+    notLocal :: HieName -> Bool+    notLocal LocalName{} = False+    notLocal _ = True+++-- ** Converting to and from `HieName`'s++toHieName :: Name -> HieName+toHieName name+  | isKnownKeyName name = KnownKeyName (nameUnique name)+  | isExternalName name = ExternalName (nameModule name)+                                       (nameOccName name)+                                       (nameSrcSpan name)+  | otherwise = LocalName (nameOccName name) (nameSrcSpan name)++fromHieName :: NameCache -> HieName -> (NameCache, Name)+fromHieName nc (ExternalName mod occ span) =+    let cache = nsNames nc+    in case lookupOrigNameCache cache mod occ of+         Just name -> (nc, name)+         Nothing ->+           let (uniq, us) = takeUniqFromSupply (nsUniqs nc)+               name       = mkExternalName uniq mod occ span+               new_cache  = extendNameCache cache mod occ name+           in ( nc{ nsUniqs = us, nsNames = new_cache }, name )+fromHieName nc (LocalName occ span) =+    let (uniq, us) = takeUniqFromSupply (nsUniqs nc)+        name       = mkInternalName uniq occ span+    in ( nc{ nsUniqs = us }, name )+fromHieName nc (KnownKeyName u) = case lookupKnownKeyName u of+    Nothing -> pprPanic "fromHieName:unknown known-key unique"+                        (ppr (unpkUnique u))+    Just n -> (nc, n)++-- ** Reading and writing `HieName`'s++putHieName :: BinHandle -> HieName -> IO ()+putHieName bh (ExternalName mod occ span) = do+  putByte bh 0+  put_ bh (mod, occ, span)+putHieName bh (LocalName occName span) = do+  putByte bh 1+  put_ bh (occName, span)+putHieName bh (KnownKeyName uniq) = do+  putByte bh 2+  put_ bh $ unpkUnique uniq++getHieName :: BinHandle -> IO HieName+getHieName bh = do+  t <- getByte bh+  case t of+    0 -> do+      (modu, occ, span) <- get bh+      return $ ExternalName modu occ span+    1 -> do+      (occ, span) <- get bh+      return $ LocalName occ span+    2 -> do+      (c,i) <- get bh+      return $ KnownKeyName $ mkUnique c i+    _ -> panic "HieBin.getHieName: invalid tag"
+ compiler/hieFile/HieDebug.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+module HieDebug where++import GhcPrelude++import SrcLoc+import Module+import FastString+import Outputable++import HieTypes+import HieBin+import HieUtils++import qualified Data.Map as M+import qualified Data.Set as S+import Data.Function    ( on )+import Data.List        ( sortOn )+import Data.Foldable    ( toList )++ppHies :: Outputable a => (HieASTs a) -> SDoc+ppHies (HieASTs asts) = M.foldrWithKey go "" asts+  where+    go k a rest = vcat $+      [ "File: " <> ppr k+      , ppHie a+      , rest+      ]++ppHie :: Outputable a => HieAST a -> SDoc+ppHie = go 0+  where+    go n (Node inf sp children) = hang header n rest+      where+        rest = vcat $ map (go (n+2)) children+        header = hsep+          [ "Node"+          , ppr sp+          , ppInfo inf+          ]++ppInfo :: Outputable a => NodeInfo a -> SDoc+ppInfo ni = hsep+  [ ppr $ toList $ nodeAnnotations ni+  , ppr $ nodeType ni+  , ppr $ M.toList $ nodeIdentifiers ni+  ]++type Diff a = a -> a -> [SDoc]++diffFile :: Diff HieFile+diffFile = diffAsts eqDiff `on` (getAsts . hie_asts)++diffAsts :: (Outputable a, Eq a) => Diff a -> Diff (M.Map FastString (HieAST a))+diffAsts f = diffList (diffAst f) `on` M.elems++diffAst :: (Outputable a, Eq a) => Diff a -> Diff (HieAST a)+diffAst diffType (Node info1 span1 xs1) (Node info2 span2 xs2) =+    infoDiff ++ spanDiff ++ diffList (diffAst diffType) xs1 xs2+  where+    spanDiff+      | span1 /= span2 = [hsep ["Spans", ppr span1, "and", ppr span2, "differ"]]+      | otherwise = []+    infoDiff+      = (diffList eqDiff `on` (S.toAscList . nodeAnnotations)) info1 info2+     ++ (diffList diffType `on` nodeType) info1 info2+     ++ (diffIdents `on` nodeIdentifiers) info1 info2+    diffIdents a b = (diffList diffIdent `on` normalizeIdents) a b+    diffIdent (a,b) (c,d) = diffName a c+                         ++ eqDiff b d+    diffName (Right a) (Right b) = case (a,b) of+      (ExternalName m o _, ExternalName m' o' _) -> eqDiff (m,o) (m',o')+      (LocalName o _, ExternalName _ o' _) -> eqDiff o o'+      _ -> eqDiff a b+    diffName a b = eqDiff a b++type DiffIdent = Either ModuleName HieName++normalizeIdents :: NodeIdentifiers a -> [(DiffIdent,IdentifierDetails a)]+normalizeIdents = sortOn fst . map (first toHieName) . M.toList+  where+    first f (a,b) = (fmap f a, b)++diffList :: Diff a -> Diff [a]+diffList f xs ys+  | length xs == length ys = concat $ zipWith f xs ys+  | otherwise = ["length of lists doesn't match"]++eqDiff :: (Outputable a, Eq a) => Diff a+eqDiff a b+  | a == b = []+  | otherwise = [hsep [ppr a, "and", ppr b, "do not match"]]++validAst :: HieAST a -> Either SDoc ()+validAst (Node _ span children) = do+  checkContainment children+  checkSorted children+  mapM_ validAst children+  where+    checkSorted [] = return ()+    checkSorted [_] = return ()+    checkSorted (x:y:xs)+      | nodeSpan x `leftOf` nodeSpan y = checkSorted (y:xs)+      | otherwise = Left $ hsep+          [ ppr $ nodeSpan x+          , "is not to the left of"+          , ppr $ nodeSpan y+          ]+    checkContainment [] = return ()+    checkContainment (x:xs)+      | span `containsSpan` (nodeSpan x) = checkContainment xs+      | otherwise = Left $ hsep+          [ ppr $ span+          , "does not contain"+          , ppr $ nodeSpan x+          ]++-- | Look for any identifiers which occur outside of their supposed scopes.+-- Returns a list of error messages.+validateScopes :: M.Map FastString (HieAST a) -> [SDoc]+validateScopes asts = M.foldrWithKey (\k a b -> valid k a ++ b) [] refMap+  where+    refMap = generateReferencesMap asts+    valid (Left _) _ = []+    valid (Right n) refs = concatMap inScope refs+      where+        mapRef = foldMap getScopeFromContext . identInfo . snd+        scopes = case foldMap mapRef refs of+          Just xs -> xs+          Nothing -> []+        inScope (sp, dets)+          |  definedInAsts asts n+          && any isOccurrence (identInfo dets)+            = case scopes of+              [] -> []+              _ -> if any (`scopeContainsSpan` sp) scopes+                   then []+                   else return $ hsep $+                     [ "Name", ppr n, "at position", ppr sp+                     , "doesn't occur in calculated scope", ppr scopes]+          | otherwise = []
+ compiler/hieFile/HieTypes.hs view
@@ -0,0 +1,514 @@+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+module HieTypes where++import GhcPrelude++import Binary+import FastString                 ( FastString )+import IfaceType+import Module                     ( ModuleName, Module )+import Name                       ( Name )+import Outputable hiding ( (<>) )+import SrcLoc                     ( RealSrcSpan )+import Avail++import qualified Data.Array as A+import qualified Data.Map as M+import qualified Data.Set as S+import Data.ByteString            ( ByteString )+import Data.Data                  ( Typeable, Data )+import Data.Semigroup             ( Semigroup(..) )+import Data.Word                  ( Word8 )+import Control.Applicative        ( (<|>) )++type Span = RealSrcSpan++-- | Current version of @.hie@ files+curHieVersion :: Word8+curHieVersion = 0++{- |+GHC builds up a wealth of information about Haskell source as it compiles it.+@.hie@ files are a way of persisting some of this information to disk so that+external tools that need to work with haskell source don't need to parse,+typecheck, and rename all over again. These files contain:++  * a simplified AST++       * nodes are annotated with source positions and types+       * identifiers are annotated with scope information++  * the raw bytes of the initial Haskell source++Besides saving compilation cycles, @.hie@ files also offer a more stable+interface than the GHC API.+-}+data HieFile = HieFile+    { hie_version :: Word8+    -- ^ version of the HIE format++    , hie_ghc_version :: ByteString+    -- ^ Version of GHC that produced this file++    , hie_hs_file :: FilePath+    -- ^ Initial Haskell source file path++    , hie_module :: Module+    -- ^ The module this HIE file is for++    , hie_types :: A.Array TypeIndex HieTypeFlat+    -- ^ Types referenced in the 'hie_asts'.+    --+    -- See Note [Efficient serialization of redundant type info]++    , hie_asts :: HieASTs TypeIndex+    -- ^ Type-annotated abstract syntax trees++    , hie_exports :: [AvailInfo]+    -- ^ The names that this module exports++    , hie_hs_src :: ByteString+    -- ^ Raw bytes of the initial Haskell source+    }++instance Binary HieFile where+  put_ bh hf = do+    put_ bh $ hie_version hf+    put_ bh $ hie_ghc_version hf+    put_ bh $ hie_hs_file hf+    put_ bh $ hie_module hf+    put_ bh $ hie_types hf+    put_ bh $ hie_asts hf+    put_ bh $ hie_exports hf+    put_ bh $ hie_hs_src hf++  get bh = HieFile+    <$> get bh+    <*> get bh+    <*> get bh+    <*> get bh+    <*> get bh+    <*> get bh+    <*> get bh+    <*> get bh+++{-+Note [Efficient serialization of redundant type info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The type information in .hie files is highly repetitive and redundant. For+example, consider the expression++    const True 'a'++There is a lot of shared structure between the types of subterms:++  * const True 'a' ::                 Bool+  * const True     ::         Char -> Bool+  * const          :: Bool -> Char -> Bool++Since all 3 of these types need to be stored in the .hie file, it is worth+making an effort to deduplicate this shared structure. The trick is to define+a new data type that is a flattened version of 'Type':++    data HieType a = HAppTy a a  -- data Type = AppTy Type Type+                   | HFunTy a a  --           | FunTy Type Type+                   | ...++    type TypeIndex = Int++Types in the final AST are stored in an 'A.Array TypeIndex (HieType TypeIndex)',+where the 'TypeIndex's in the 'HieType' are references to other elements of the+array. Types recovered from GHC are deduplicated and stored in this compressed+form with sharing of subtrees.+-}++type TypeIndex = Int++-- | A flattened version of 'Type'.+--+-- See Note [Efficient serialization of redundant type info]+data HieType a+  = HTyVarTy Name+  | HAppTy a (HieArgs a)+  | HTyConApp IfaceTyCon (HieArgs a)+  | HForAllTy ((Name, a),ArgFlag) a+  | HFunTy  a a+  | HQualTy a a           -- ^ type with constraint: @t1 => t2@ (see 'IfaceDFunTy')+  | HLitTy IfaceTyLit+  | HCastTy a+  | HCoercionTy+    deriving (Functor, Foldable, Traversable, Eq)++type HieTypeFlat = HieType TypeIndex++-- | Roughly isomorphic to the original core 'Type'.+newtype HieTypeFix = Roll (HieType (HieTypeFix))++instance Binary (HieType TypeIndex) where+  put_ bh (HTyVarTy n) = do+    putByte bh 0+    put_ bh n+  put_ bh (HAppTy a b) = do+    putByte bh 1+    put_ bh a+    put_ bh b+  put_ bh (HTyConApp n xs) = do+    putByte bh 2+    put_ bh n+    put_ bh xs+  put_ bh (HForAllTy bndr a) = do+    putByte bh 3+    put_ bh bndr+    put_ bh a+  put_ bh (HFunTy a b) = do+    putByte bh 4+    put_ bh a+    put_ bh b+  put_ bh (HQualTy a b) = do+    putByte bh 5+    put_ bh a+    put_ bh b+  put_ bh (HLitTy l) = do+    putByte bh 6+    put_ bh l+  put_ bh (HCastTy a) = do+    putByte bh 7+    put_ bh a+  put_ bh (HCoercionTy) = putByte bh 8++  get bh = do+    (t :: Word8) <- get bh+    case t of+      0 -> HTyVarTy <$> get bh+      1 -> HAppTy <$> get bh <*> get bh+      2 -> HTyConApp <$> get bh <*> get bh+      3 -> HForAllTy <$> get bh <*> get bh+      4 -> HFunTy <$> get bh <*> get bh+      5 -> HQualTy <$> get bh <*> get bh+      6 -> HLitTy <$> get bh+      7 -> HCastTy <$> get bh+      8 -> return HCoercionTy+      _ -> panic "Binary (HieArgs Int): invalid tag"+++-- | A list of type arguments along with their respective visibilities (ie. is+-- this an argument that would return 'True' for 'isVisibleArgFlag'?).+newtype HieArgs a = HieArgs [(Bool,a)]+  deriving (Functor, Foldable, Traversable, Eq)++instance Binary (HieArgs TypeIndex) where+  put_ bh (HieArgs xs) = put_ bh xs+  get bh = HieArgs <$> get bh++-- | Mapping from filepaths (represented using 'FastString') to the+-- corresponding AST+newtype HieASTs a = HieASTs { getAsts :: (M.Map FastString (HieAST a)) }+  deriving (Functor, Foldable, Traversable)++instance Binary (HieASTs TypeIndex) where+  put_ bh asts = put_ bh $ M.toAscList $ getAsts asts+  get bh = HieASTs <$> fmap M.fromDistinctAscList (get bh)+++data HieAST a =+  Node+    { nodeInfo :: NodeInfo a+    , nodeSpan :: Span+    , nodeChildren :: [HieAST a]+    } deriving (Functor, Foldable, Traversable)++instance Binary (HieAST TypeIndex) where+  put_ bh ast = do+    put_ bh $ nodeInfo ast+    put_ bh $ nodeSpan ast+    put_ bh $ nodeChildren ast++  get bh = Node+    <$> get bh+    <*> get bh+    <*> get bh+++-- | The information stored in one AST node.+--+-- The type parameter exists to provide flexibility in representation of types+-- (see Note [Efficient serialization of redundant type info]).+data NodeInfo a = NodeInfo+    { nodeAnnotations :: S.Set (FastString,FastString)+    -- ^ (name of the AST node constructor, name of the AST node Type)++    , nodeType :: [a]+    -- ^ The Haskell types of this node, if any.++    , nodeIdentifiers :: NodeIdentifiers a+    -- ^ All the identifiers and their details+    } deriving (Functor, Foldable, Traversable)++instance Binary (NodeInfo TypeIndex) where+  put_ bh ni = do+    put_ bh $ S.toAscList $ nodeAnnotations ni+    put_ bh $ nodeType ni+    put_ bh $ M.toList $ nodeIdentifiers ni+  get bh = NodeInfo+    <$> fmap (S.fromDistinctAscList) (get bh)+    <*> get bh+    <*> fmap (M.fromList) (get bh)++type Identifier = Either ModuleName Name++type NodeIdentifiers a = M.Map Identifier (IdentifierDetails a)++-- | Information associated with every identifier+--+-- We need to include types with identifiers because sometimes multiple+-- identifiers occur in the same span(Overloaded Record Fields and so on)+data IdentifierDetails a = IdentifierDetails+  { identType :: Maybe a+  , identInfo :: S.Set ContextInfo+  } deriving (Eq, Functor, Foldable, Traversable)++instance Outputable a => Outputable (IdentifierDetails a) where+  ppr x = text "IdentifierDetails" <+> ppr (identType x) <+> ppr (identInfo x)++instance Semigroup (IdentifierDetails a) where+  d1 <> d2 = IdentifierDetails (identType d1 <|> identType d2)+                               (S.union (identInfo d1) (identInfo d2))++instance Monoid (IdentifierDetails a) where+  mempty = IdentifierDetails Nothing S.empty++instance Binary (IdentifierDetails TypeIndex) where+  put_ bh dets = do+    put_ bh $ identType dets+    put_ bh $ S.toAscList $ identInfo dets+  get bh =  IdentifierDetails+    <$> get bh+    <*> fmap (S.fromDistinctAscList) (get bh)+++-- | Different contexts under which identifiers exist+data ContextInfo+  = Use                -- ^ regular variable+  | MatchBind+  | IEThing IEType     -- ^ import/export+  | TyDecl++  -- | Value binding+  | ValBind+      BindType     -- ^ whether or not the binding is in an instance+      Scope        -- ^ scope over which the value is bound+      (Maybe Span) -- ^ span of entire binding++  -- | Pattern binding+  --+  -- This case is tricky because the bound identifier can be used in two+  -- distinct scopes. Consider the following example (with @-XViewPatterns@)+  --+  -- @+  -- do (b, a, (a -> True)) <- bar+  --    foo a+  -- @+  --+  -- The identifier @a@ has two scopes: in the view pattern @(a -> True)@ and+  -- in the rest of the @do@-block in @foo a@.+  | PatternBind+      Scope        -- ^ scope /in the pattern/ (the variable bound can be used+                   -- further in the pattern)+      Scope        -- ^ rest of the scope outside the pattern+      (Maybe Span) -- ^ span of entire binding++  | ClassTyDecl (Maybe Span)++  -- | Declaration+  | Decl+      DeclType     -- ^ type of declaration+      (Maybe Span) -- ^ span of entire binding++  -- | Type variable+  | TyVarBind Scope TyVarScope++  -- | Record field+  | RecField RecFieldContext (Maybe Span)+    deriving (Eq, Ord, Show)++instance Outputable ContextInfo where+  ppr = text . show++instance Binary ContextInfo where+  put_ bh Use = putByte bh 0+  put_ bh (IEThing t) = do+    putByte bh 1+    put_ bh t+  put_ bh TyDecl = putByte bh 2+  put_ bh (ValBind bt sc msp) = do+    putByte bh 3+    put_ bh bt+    put_ bh sc+    put_ bh msp+  put_ bh (PatternBind a b c) = do+    putByte bh 4+    put_ bh a+    put_ bh b+    put_ bh c+  put_ bh (ClassTyDecl sp) = do+    putByte bh 5+    put_ bh sp+  put_ bh (Decl a b) = do+    putByte bh 6+    put_ bh a+    put_ bh b+  put_ bh (TyVarBind a b) = do+    putByte bh 7+    put_ bh a+    put_ bh b+  put_ bh (RecField a b) = do+    putByte bh 8+    put_ bh a+    put_ bh b+  put_ bh MatchBind = putByte bh 9++  get bh = do+    (t :: Word8) <- get bh+    case t of+      0 -> return Use+      1 -> IEThing <$> get bh+      2 -> return TyDecl+      3 -> ValBind <$> get bh <*> get bh <*> get bh+      4 -> PatternBind <$> get bh <*> get bh <*> get bh+      5 -> ClassTyDecl <$> get bh+      6 -> Decl <$> get bh <*> get bh+      7 -> TyVarBind <$> get bh <*> get bh+      8 -> RecField <$> get bh <*> get bh+      9 -> return MatchBind+      _ -> panic "Binary ContextInfo: invalid tag"+++-- | Types of imports and exports+data IEType+  = Import+  | ImportAs+  | ImportHiding+  | Export+    deriving (Eq, Enum, Ord, Show)++instance Binary IEType where+  put_ bh b = putByte bh (fromIntegral (fromEnum b))+  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))+++data RecFieldContext+  = RecFieldDecl+  | RecFieldAssign+  | RecFieldMatch+  | RecFieldOcc+    deriving (Eq, Enum, Ord, Show)++instance Binary RecFieldContext where+  put_ bh b = putByte bh (fromIntegral (fromEnum b))+  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))+++data BindType+  = RegularBind+  | InstanceBind+    deriving (Eq, Ord, Show, Enum)++instance Binary BindType where+  put_ bh b = putByte bh (fromIntegral (fromEnum b))+  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))+++data DeclType+  = FamDec     -- ^ type or data family+  | SynDec     -- ^ type synonym+  | DataDec    -- ^ data declaration+  | ConDec     -- ^ constructor declaration+  | PatSynDec  -- ^ pattern synonym+  | ClassDec   -- ^ class declaration+  | InstDec    -- ^ instance declaration+    deriving (Eq, Ord, Show, Enum)++instance Binary DeclType where+  put_ bh b = putByte bh (fromIntegral (fromEnum b))+  get bh = do x <- getByte bh; pure $! (toEnum (fromIntegral x))+++data Scope+  = NoScope+  | LocalScope Span+  | ModuleScope+    deriving (Eq, Ord, Show, Typeable, Data)++instance Outputable Scope where+  ppr NoScope = text "NoScope"+  ppr (LocalScope sp) = text "LocalScope" <+> ppr sp+  ppr ModuleScope = text "ModuleScope"++instance Binary Scope where+  put_ bh NoScope = putByte bh 0+  put_ bh (LocalScope span) = do+    putByte bh 1+    put_ bh span+  put_ bh ModuleScope = putByte bh 2++  get bh = do+    (t :: Word8) <- get bh+    case t of+      0 -> return NoScope+      1 -> LocalScope <$> get bh+      2 -> return ModuleScope+      _ -> panic "Binary Scope: invalid tag"+++-- | Scope of a type variable.+--+-- This warrants a data type apart from 'Scope' because of complexities+-- introduced by features like @-XScopedTypeVariables@ and @-XInstanceSigs@. For+-- example, consider:+--+-- @+-- foo, bar, baz :: forall a. a -> a+-- @+--+-- Here @a@ is in scope in all the definitions of @foo@, @bar@, and @baz@, so we+-- need a list of scopes to keep track of this. Furthermore, this list cannot be+-- computed until we resolve the binding sites of @foo@, @bar@, and @baz@.+--+-- Consequently, @a@ starts with an @'UnresolvedScope' [foo, bar, baz] Nothing@+-- which later gets resolved into a 'ResolvedScopes'.+data TyVarScope+  = ResolvedScopes [Scope]++  -- | Unresolved scopes should never show up in the final @.hie@ file+  | UnresolvedScope+        [Name]        -- ^ names of the definitions over which the scope spans+        (Maybe Span)  -- ^ the location of the instance/class declaration for+                      -- the case where the type variable is declared in a+                      -- method type signature+    deriving (Eq, Ord)++instance Show TyVarScope where+  show (ResolvedScopes sc) = show sc+  show _ = error "UnresolvedScope"++instance Binary TyVarScope where+  put_ bh (ResolvedScopes xs) = do+    putByte bh 0+    put_ bh xs+  put_ bh (UnresolvedScope ns span) = do+    putByte bh 1+    put_ bh ns+    put_ bh span++  get bh = do+    (t :: Word8) <- get bh+    case t of+      0 -> ResolvedScopes <$> get bh+      1 -> UnresolvedScope <$> get bh <*> get bh+      _ -> panic "Binary TyVarScope: invalid tag"
+ compiler/hieFile/HieUtils.hs view
@@ -0,0 +1,455 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+module HieUtils where++import GhcPrelude++import CoreMap+import DynFlags                   ( DynFlags )+import FastString                 ( FastString, mkFastString )+import IfaceType+import Name hiding (varName)+import Outputable                 ( renderWithStyle, ppr, defaultUserStyle )+import SrcLoc+import ToIface+import TyCon+import TyCoRep+import Type+import Var+import VarEnv++import HieTypes++import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.IntMap.Strict as IM+import qualified Data.Array as A+import Data.Data                  ( typeOf, typeRepTyCon, Data(toConstr) )+import Data.Maybe                 ( maybeToList )+import Data.Monoid+import Data.Traversable           ( for )+import Control.Monad.Trans.State.Strict hiding (get)+++generateReferencesMap+  :: Foldable f+  => f (HieAST a)+  -> M.Map Identifier [(Span, IdentifierDetails a)]+generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty+  where+    go ast = M.unionsWith (++) (this : map go (nodeChildren ast))+      where+        this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast++renderHieType :: DynFlags -> HieTypeFix -> String+renderHieType df ht = renderWithStyle df (ppr $ hieTypeToIface ht) sty+  where sty = defaultUserStyle df++resolveVisibility :: Type -> [Type] -> [(Bool,Type)]+resolveVisibility kind ty_args+  = go (mkEmptyTCvSubst in_scope) kind ty_args+  where+    in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args)++    go _   _                   []     = []+    go env ty                  ts+      | Just ty' <- coreView ty+      = go env ty' ts+    go env (ForAllTy (Bndr tv vis) res) (t:ts)+      | isVisibleArgFlag vis = (True , t) : ts'+      | otherwise            = (False, t) : ts'+      where+        ts' = go (extendTvSubst env tv t) res ts++    go env (FunTy { ft_res = res }) (t:ts) -- No type-class args in tycon apps+      = (True,t) : (go env res ts)++    go env (TyVarTy tv) ts+      | Just ki <- lookupTyVar env tv = go env ki ts+    go env kind (t:ts) = (True, t) : (go env kind ts) -- Ill-kinded++foldType :: (HieType a -> a) -> HieTypeFix -> a+foldType f (Roll t) = f $ fmap (foldType f) t++hieTypeToIface :: HieTypeFix -> IfaceType+hieTypeToIface = foldType go+  where+    go (HTyVarTy n) = IfaceTyVar $ occNameFS $ getOccName n+    go (HAppTy a b) = IfaceAppTy a (hieToIfaceArgs b)+    go (HLitTy l) = IfaceLitTy l+    go (HForAllTy ((n,k),af) t) = let b = (occNameFS $ getOccName n, k)+                                  in IfaceForAllTy (Bndr (IfaceTvBndr b) af) t+    go (HFunTy a b)     = IfaceFunTy VisArg   a    b+    go (HQualTy pred b) = IfaceFunTy InvisArg pred b+    go (HCastTy a) = a+    go HCoercionTy = IfaceTyVar "<coercion type>"+    go (HTyConApp a xs) = IfaceTyConApp a (hieToIfaceArgs xs)++    -- This isn't fully faithful - we can't produce the 'Inferred' case+    hieToIfaceArgs :: HieArgs IfaceType -> IfaceAppArgs+    hieToIfaceArgs (HieArgs xs) = go' xs+      where+        go' [] = IA_Nil+        go' ((True ,x):xs) = IA_Arg x Required $ go' xs+        go' ((False,x):xs) = IA_Arg x Specified $ go' xs++data HieTypeState+  = HTS+    { tyMap      :: !(TypeMap TypeIndex)+    , htyTable   :: !(IM.IntMap HieTypeFlat)+    , freshIndex :: !TypeIndex+    }++initialHTS :: HieTypeState+initialHTS = HTS emptyTypeMap IM.empty 0++freshTypeIndex :: State HieTypeState TypeIndex+freshTypeIndex = do+  index <- gets freshIndex+  modify' $ \hts -> hts { freshIndex = index+1 }+  return index++compressTypes+  :: HieASTs Type+  -> (HieASTs TypeIndex, A.Array TypeIndex HieTypeFlat)+compressTypes asts = (a, arr)+  where+    (a, (HTS _ m i)) = flip runState initialHTS $+      for asts $ \typ -> do+        i <- getTypeIndex typ+        return i+    arr = A.array (0,i-1) (IM.toList m)++recoverFullType :: TypeIndex -> A.Array TypeIndex HieTypeFlat -> HieTypeFix+recoverFullType i m = go i+  where+    go i = Roll $ fmap go (m A.! i)++getTypeIndex :: Type -> State HieTypeState TypeIndex+getTypeIndex t+  | otherwise = do+      tm <- gets tyMap+      case lookupTypeMap tm t of+        Just i -> return i+        Nothing -> do+          ht <- go t+          extendHTS t ht+  where+    extendHTS t ht = do+      i <- freshTypeIndex+      modify' $ \(HTS tm tt fi) ->+        HTS (extendTypeMap tm t i) (IM.insert i ht tt) fi+      return i++    go (TyVarTy v) = return $ HTyVarTy $ varName v+    go ty@(AppTy _ _) = do+      let (head,args) = splitAppTys ty+          visArgs = HieArgs $ resolveVisibility (typeKind head) args+      ai <- getTypeIndex head+      argsi <- mapM getTypeIndex visArgs+      return $ HAppTy ai argsi+    go (TyConApp f xs) = do+      let visArgs = HieArgs $ resolveVisibility (tyConKind f) xs+      is <- mapM getTypeIndex visArgs+      return $ HTyConApp (toIfaceTyCon f) is+    go (ForAllTy (Bndr v a) t) = do+      k <- getTypeIndex (varType v)+      i <- getTypeIndex t+      return $ HForAllTy ((varName v,k),a) i+    go (FunTy { ft_af = af, ft_arg = a, ft_res = b }) = do+      ai <- getTypeIndex a+      bi <- getTypeIndex b+      return $ case af of+                 InvisArg -> HQualTy ai bi+                 VisArg   -> HFunTy ai bi+    go (LitTy a) = return $ HLitTy $ toIfaceTyLit a+    go (CastTy t _) = do+      i <- getTypeIndex t+      return $ HCastTy i+    go (CoercionTy _) = return HCoercionTy++resolveTyVarScopes :: M.Map FastString (HieAST a) -> M.Map FastString (HieAST a)+resolveTyVarScopes asts = M.map go asts+  where+    go ast = resolveTyVarScopeLocal ast asts++resolveTyVarScopeLocal :: HieAST a -> M.Map FastString (HieAST a) -> HieAST a+resolveTyVarScopeLocal ast asts = go ast+  where+    resolveNameScope dets = dets{identInfo =+      S.map resolveScope (identInfo dets)}+    resolveScope (TyVarBind sc (UnresolvedScope names Nothing)) =+      TyVarBind sc $ ResolvedScopes+        [ LocalScope binding+        | name <- names+        , Just binding <- [getNameBinding name asts]+        ]+    resolveScope (TyVarBind sc (UnresolvedScope names (Just sp))) =+      TyVarBind sc $ ResolvedScopes+        [ LocalScope binding+        | name <- names+        , Just binding <- [getNameBindingInClass name sp asts]+        ]+    resolveScope scope = scope+    go (Node info span children) = Node info' span $ map go children+      where+        info' = info { nodeIdentifiers = idents }+        idents = M.map resolveNameScope $ nodeIdentifiers info++getNameBinding :: Name -> M.Map FastString (HieAST a) -> Maybe Span+getNameBinding n asts = do+  (_,msp) <- getNameScopeAndBinding n asts+  msp++getNameScope :: Name -> M.Map FastString (HieAST a) -> Maybe [Scope]+getNameScope n asts = do+  (scopes,_) <- getNameScopeAndBinding n asts+  return scopes++getNameBindingInClass+  :: Name+  -> Span+  -> M.Map FastString (HieAST a)+  -> Maybe Span+getNameBindingInClass n sp asts = do+  ast <- M.lookup (srcSpanFile sp) asts+  getFirst $ foldMap First $ do+    child <- flattenAst ast+    dets <- maybeToList+      $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo child+    let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)+    return (getFirst binding)++getNameScopeAndBinding+  :: Name+  -> M.Map FastString (HieAST a)+  -> Maybe ([Scope], Maybe Span)+getNameScopeAndBinding n asts = case nameSrcSpan n of+  RealSrcSpan sp -> do -- @Maybe+    ast <- M.lookup (srcSpanFile sp) asts+    defNode <- selectLargestContainedBy sp ast+    getFirst $ foldMap First $ do -- @[]+      node <- flattenAst defNode+      dets <- maybeToList+        $ M.lookup (Right n) $ nodeIdentifiers $ nodeInfo node+      scopes <- maybeToList $ foldMap getScopeFromContext (identInfo dets)+      let binding = foldMap (First . getBindSiteFromContext) (identInfo dets)+      return $ Just (scopes, getFirst binding)+  _ -> Nothing++getScopeFromContext :: ContextInfo -> Maybe [Scope]+getScopeFromContext (ValBind _ sc _) = Just [sc]+getScopeFromContext (PatternBind a b _) = Just [a, b]+getScopeFromContext (ClassTyDecl _) = Just [ModuleScope]+getScopeFromContext (Decl _ _) = Just [ModuleScope]+getScopeFromContext (TyVarBind a (ResolvedScopes xs)) = Just $ a:xs+getScopeFromContext (TyVarBind a _) = Just [a]+getScopeFromContext _ = Nothing++getBindSiteFromContext :: ContextInfo -> Maybe Span+getBindSiteFromContext (ValBind _ _ sp) = sp+getBindSiteFromContext (PatternBind _ _ sp) = sp+getBindSiteFromContext _ = Nothing++flattenAst :: HieAST a -> [HieAST a]+flattenAst n =+  n : concatMap flattenAst (nodeChildren n)++smallestContainingSatisfying+  :: Span+  -> (HieAST a -> Bool)+  -> HieAST a+  -> Maybe (HieAST a)+smallestContainingSatisfying sp cond node+  | nodeSpan node `containsSpan` sp = getFirst $ mconcat+      [ foldMap (First . smallestContainingSatisfying sp cond) $+          nodeChildren node+      , First $ if cond node then Just node else Nothing+      ]+  | sp `containsSpan` nodeSpan node = Nothing+  | otherwise = Nothing++selectLargestContainedBy :: Span -> HieAST a -> Maybe (HieAST a)+selectLargestContainedBy sp node+  | sp `containsSpan` nodeSpan node = Just node+  | nodeSpan node `containsSpan` sp =+      getFirst $ foldMap (First . selectLargestContainedBy sp) $+        nodeChildren node+  | otherwise = Nothing++selectSmallestContaining :: Span -> HieAST a -> Maybe (HieAST a)+selectSmallestContaining sp node+  | nodeSpan node `containsSpan` sp = getFirst $ mconcat+      [ foldMap (First . selectSmallestContaining sp) $ nodeChildren node+      , First (Just node)+      ]+  | sp `containsSpan` nodeSpan node = Nothing+  | otherwise = Nothing++definedInAsts :: M.Map FastString (HieAST a) -> Name -> Bool+definedInAsts asts n = case nameSrcSpan n of+  RealSrcSpan sp -> srcSpanFile sp `elem` M.keys asts+  _ -> False++isOccurrence :: ContextInfo -> Bool+isOccurrence Use = True+isOccurrence _ = False++scopeContainsSpan :: Scope -> Span -> Bool+scopeContainsSpan NoScope _ = False+scopeContainsSpan ModuleScope _ = True+scopeContainsSpan (LocalScope a) b = a `containsSpan` b++-- | One must contain the other. Leaf nodes cannot contain anything+combineAst :: HieAST Type -> HieAST Type -> HieAST Type+combineAst a@(Node aInf aSpn xs) b@(Node bInf bSpn ys)+  | aSpn == bSpn = Node (aInf `combineNodeInfo` bInf) aSpn (mergeAsts xs ys)+  | aSpn `containsSpan` bSpn = combineAst b a+combineAst a (Node xs span children) = Node xs span (insertAst a children)++-- | Insert an AST in a sorted list of disjoint Asts+insertAst :: HieAST Type -> [HieAST Type] -> [HieAST Type]+insertAst x = mergeAsts [x]++-- | Merge two nodes together.+--+-- Precondition and postcondition: elements in 'nodeType' are ordered.+combineNodeInfo :: NodeInfo Type -> NodeInfo Type -> NodeInfo Type+(NodeInfo as ai ad) `combineNodeInfo` (NodeInfo bs bi bd) =+  NodeInfo (S.union as bs) (mergeSorted ai bi) (M.unionWith (<>) ad bd)+  where+    mergeSorted :: [Type] -> [Type] -> [Type]+    mergeSorted la@(a:as) lb@(b:bs) = case nonDetCmpType a b of+                                        LT -> a : mergeSorted as lb+                                        EQ -> a : mergeSorted as bs+                                        GT -> b : mergeSorted la bs+    mergeSorted as [] = as+    mergeSorted [] bs = bs+++{- | Merge two sorted, disjoint lists of ASTs, combining when necessary.++In the absence of position-altering pragmas (ex: @# line "file.hs" 3@),+different nodes in an AST tree should either have disjoint spans (in+which case you can say for sure which one comes first) or one span+should be completely contained in the other (in which case the contained+span corresponds to some child node).++However, since Haskell does have position-altering pragmas it /is/+possible for spans to be overlapping. Here is an example of a source file+in which @foozball@ and @quuuuuux@ have overlapping spans:++@+module Baz where++# line 3 "Baz.hs"+foozball :: Int+foozball = 0++# line 3 "Baz.hs"+bar, quuuuuux :: Int+bar = 1+quuuuuux = 2+@++In these cases, we just do our best to produce sensible `HieAST`'s. The blame+should be laid at the feet of whoever wrote the line pragmas in the first place+(usually the C preprocessor...).+-}+mergeAsts :: [HieAST Type] -> [HieAST Type] -> [HieAST Type]+mergeAsts xs [] = xs+mergeAsts [] ys = ys+mergeAsts xs@(a:as) ys@(b:bs)+  | span_a `containsSpan`   span_b = mergeAsts (combineAst a b : as) bs+  | span_b `containsSpan`   span_a = mergeAsts as (combineAst a b : bs)+  | span_a `rightOf`        span_b = b : mergeAsts xs bs+  | span_a `leftOf`         span_b = a : mergeAsts as ys++  -- These cases are to work around ASTs that are not fully disjoint+  | span_a `startsRightOf`  span_b = b : mergeAsts as ys+  | otherwise                      = a : mergeAsts as ys+  where+    span_a = nodeSpan a+    span_b = nodeSpan b++rightOf :: Span -> Span -> Bool+rightOf s1 s2+  = (srcSpanStartLine s1, srcSpanStartCol s1)+       >= (srcSpanEndLine s2, srcSpanEndCol s2)+    && (srcSpanFile s1 == srcSpanFile s2)++leftOf :: Span -> Span -> Bool+leftOf s1 s2+  = (srcSpanEndLine s1, srcSpanEndCol s1)+       <= (srcSpanStartLine s2, srcSpanStartCol s2)+    && (srcSpanFile s1 == srcSpanFile s2)++startsRightOf :: Span -> Span -> Bool+startsRightOf s1 s2+  = (srcSpanStartLine s1, srcSpanStartCol s1)+       >= (srcSpanStartLine s2, srcSpanStartCol s2)++-- | combines and sorts ASTs using a merge sort+mergeSortAsts :: [HieAST Type] -> [HieAST Type]+mergeSortAsts = go . map pure+  where+    go [] = []+    go [xs] = xs+    go xss = go (mergePairs xss)+    mergePairs [] = []+    mergePairs [xs] = [xs]+    mergePairs (xs:ys:xss) = mergeAsts xs ys : mergePairs xss++simpleNodeInfo :: FastString -> FastString -> NodeInfo a+simpleNodeInfo cons typ = NodeInfo (S.singleton (cons, typ)) [] M.empty++locOnly :: SrcSpan -> [HieAST a]+locOnly (RealSrcSpan span) =+  [Node e span []]+    where e = NodeInfo S.empty [] M.empty+locOnly _ = []++mkScope :: SrcSpan -> Scope+mkScope (RealSrcSpan sp) = LocalScope sp+mkScope _ = NoScope++mkLScope :: Located a -> Scope+mkLScope = mkScope . getLoc++combineScopes :: Scope -> Scope -> Scope+combineScopes ModuleScope _ = ModuleScope+combineScopes _ ModuleScope = ModuleScope+combineScopes NoScope x = x+combineScopes x NoScope = x+combineScopes (LocalScope a) (LocalScope b) =+  mkScope $ combineSrcSpans (RealSrcSpan a) (RealSrcSpan b)++{-# INLINEABLE makeNode #-}+makeNode+  :: (Applicative m, Data a)+  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')+  -> SrcSpan                 -- ^ return an empty list if this is unhelpful+  -> m [HieAST b]+makeNode x spn = pure $ case spn of+  RealSrcSpan span -> [Node (simpleNodeInfo cons typ) span []]+  _ -> []+  where+    cons = mkFastString . show . toConstr $ x+    typ = mkFastString . show . typeRepTyCon . typeOf $ x++{-# INLINEABLE makeTypeNode #-}+makeTypeNode+  :: (Applicative m, Data a)+  => a                       -- ^ helps fill in 'nodeAnnotations' (with 'Data')+  -> SrcSpan                 -- ^ return an empty list if this is unhelpful+  -> Type                    -- ^ type to associate with the node+  -> m [HieAST Type]+makeTypeNode x spn etyp = pure $ case spn of+  RealSrcSpan span ->+    [Node (NodeInfo (S.singleton (cons,typ)) [etyp] M.empty) span []]+  _ -> []+  where+    cons = mkFastString . show . toConstr $ x+    typ = mkFastString . show . typeRepTyCon . typeOf $ x
+ compiler/hsSyn/Convert.hs view
@@ -0,0 +1,1986 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++This module converts Template Haskell syntax into HsSyn+-}++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module Convert( convertToHsExpr, convertToPat, convertToHsDecls,+                convertToHsType,+                thRdrNameGuesses ) where++import GhcPrelude++import HsSyn as Hs+import PrelNames+import RdrName+import qualified Name+import Module+import RdrHsSyn+import OccName+import SrcLoc+import Type+import qualified Coercion ( Role(..) )+import TysWiredIn+import BasicTypes as Hs+import ForeignCall+import Unique+import ErrUtils+import Bag+import Lexeme+import Util+import FastString+import Outputable+import MonadUtils ( foldrM )++import qualified Data.ByteString as BS+import Control.Monad( unless, liftM, ap )++import Data.Maybe( catMaybes, isNothing )+import Language.Haskell.TH as TH hiding (sigP)+import Language.Haskell.TH.Syntax as TH+import Foreign.ForeignPtr+import Foreign.Ptr+import System.IO.Unsafe++-------------------------------------------------------------------+--              The external interface++convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either MsgDoc [LHsDecl GhcPs]+convertToHsDecls loc ds = initCvt loc (fmap catMaybes (mapM cvt_dec ds))+  where+    cvt_dec d = wrapMsg "declaration" d (cvtDec d)++convertToHsExpr :: SrcSpan -> TH.Exp -> Either MsgDoc (LHsExpr GhcPs)+convertToHsExpr loc e+  = initCvt loc $ wrapMsg "expression" e $ cvtl e++convertToPat :: SrcSpan -> TH.Pat -> Either MsgDoc (LPat GhcPs)+convertToPat loc p+  = initCvt loc $ wrapMsg "pattern" p $ cvtPat p++convertToHsType :: SrcSpan -> TH.Type -> Either MsgDoc (LHsType GhcPs)+convertToHsType loc t+  = initCvt loc $ wrapMsg "type" t $ cvtType t++-------------------------------------------------------------------+newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either MsgDoc (SrcSpan, a) }+        -- Push down the source location;+        -- Can fail, with a single error message++-- NB: If the conversion succeeds with (Right x), there should+--     be no exception values hiding in x+-- Reason: so a (head []) in TH code doesn't subsequently+--         make GHC crash when it tries to walk the generated tree++-- Use the loc everywhere, for lack of anything better+-- In particular, we want it on binding locations, so that variables bound in+-- the spliced-in declarations get a location that at least relates to the splice point++instance Functor CvtM where+    fmap = liftM++instance Applicative CvtM where+    pure x = CvtM $ \loc -> Right (loc,x)+    (<*>) = ap++instance Monad CvtM where+  (CvtM m) >>= k = CvtM $ \loc -> case m loc of+                                  Left err -> Left err+                                  Right (loc',v) -> unCvtM (k v) loc'++initCvt :: SrcSpan -> CvtM a -> Either MsgDoc a+initCvt loc (CvtM m) = fmap snd (m loc)++force :: a -> CvtM ()+force a = a `seq` return ()++failWith :: MsgDoc -> CvtM a+failWith m = CvtM (\_ -> Left m)++getL :: CvtM SrcSpan+getL = CvtM (\loc -> Right (loc,loc))++setL :: SrcSpan -> CvtM ()+setL loc = CvtM (\_ -> Right (loc, ()))++returnL :: HasSrcSpan a => SrcSpanLess a -> CvtM a+returnL x = CvtM (\loc -> Right (loc, cL loc x))++returnJustL :: HasSrcSpan a => SrcSpanLess a -> CvtM (Maybe a)+returnJustL = fmap Just . returnL++wrapParL :: HasSrcSpan a =>+            (a -> SrcSpanLess a) -> SrcSpanLess a -> CvtM (SrcSpanLess  a)+wrapParL add_par x = CvtM (\loc -> Right (loc, add_par (cL loc x)))++wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b+-- E.g  wrapMsg "declaration" dec thing+wrapMsg what item (CvtM m)+  = CvtM (\loc -> case m loc of+                     Left err -> Left (err $$ getPprStyle msg)+                     Right v  -> Right v)+  where+        -- Show the item in pretty syntax normally,+        -- but with all its constructors if you say -dppr-debug+    msg sty = hang (text "When splicing a TH" <+> text what <> colon)+                 2 (if debugStyle sty+                    then text (show item)+                    else text (pprint item))++wrapL :: HasSrcSpan a => CvtM (SrcSpanLess a) -> CvtM a+wrapL (CvtM m) = CvtM (\loc -> case m loc of+                               Left err -> Left err+                               Right (loc',v) -> Right (loc',cL loc v))++-------------------------------------------------------------------+cvtDecs :: [TH.Dec] -> CvtM [LHsDecl GhcPs]+cvtDecs = fmap catMaybes . mapM cvtDec++cvtDec :: TH.Dec -> CvtM (Maybe (LHsDecl GhcPs))+cvtDec (TH.ValD pat body ds)+  | TH.VarP s <- pat+  = do  { s' <- vNameL s+        ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)+        ; returnJustL $ Hs.ValD noExt $ mkFunBind s' [cl'] }++  | otherwise+  = do  { pat' <- cvtPat pat+        ; body' <- cvtGuard body+        ; ds' <- cvtLocalDecs (text "a where clause") ds+        ; returnJustL $ Hs.ValD noExt $+          PatBind { pat_lhs = pat'+                  , pat_rhs = GRHSs noExt body' (noLoc ds')+                  , pat_ext = noExt+                  , pat_ticks = ([],[]) } }++cvtDec (TH.FunD nm cls)+  | null cls+  = failWith (text "Function binding for"+                 <+> quotes (text (TH.pprint nm))+                 <+> text "has no equations")+  | otherwise+  = do  { nm' <- vNameL nm+        ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls+        ; returnJustL $ Hs.ValD noExt $ mkFunBind nm' cls' }++cvtDec (TH.SigD nm typ)+  = do  { nm' <- vNameL nm+        ; ty' <- cvtType typ+        ; returnJustL $ Hs.SigD noExt+                                    (TypeSig noExt [nm'] (mkLHsSigWcType ty')) }++cvtDec (TH.InfixD fx nm)+  -- Fixity signatures are allowed for variables, constructors, and types+  -- the renamer automatically looks for types during renaming, even when+  -- the RdrName says it's a variable or a constructor. So, just assume+  -- it's a variable or constructor and proceed.+  = do { nm' <- vcNameL nm+       ; returnJustL (Hs.SigD noExt (FixSig noExt+                                      (FixitySig noExt [nm'] (cvtFixity fx)))) }++cvtDec (PragmaD prag)+  = cvtPragmaD prag++cvtDec (TySynD tc tvs rhs)+  = do  { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs+        ; rhs' <- cvtType rhs+        ; returnJustL $ TyClD noExt $+          SynDecl { tcdSExt = noExt, tcdLName = tc', tcdTyVars = tvs'+                  , tcdFixity = Prefix+                  , tcdRhs = rhs' } }++cvtDec (DataD ctxt tc tvs ksig constrs derivs)+  = do  { let isGadtCon (GadtC    _ _ _) = True+              isGadtCon (RecGadtC _ _ _) = True+              isGadtCon (ForallC  _ _ c) = isGadtCon c+              isGadtCon _                = False+              isGadtDecl  = all isGadtCon constrs+              isH98Decl   = all (not . isGadtCon) constrs+        ; unless (isGadtDecl || isH98Decl)+                 (failWith (text "Cannot mix GADT constructors with Haskell 98"+                        <+> text "constructors"))+        ; unless (isNothing ksig || isGadtDecl)+                 (failWith (text "Kind signatures are only allowed on GADTs"))+        ; (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs+        ; ksig' <- cvtKind `traverse` ksig+        ; cons' <- mapM cvtConstr constrs+        ; derivs' <- cvtDerivs derivs+        ; let defn = HsDataDefn { dd_ext = noExt+                                , dd_ND = DataType, dd_cType = Nothing+                                , dd_ctxt = ctxt'+                                , dd_kindSig = ksig'+                                , dd_cons = cons', dd_derivs = derivs' }+        ; returnJustL $ TyClD noExt (DataDecl+                                        { tcdDExt = noExt+                                        , tcdLName = tc', tcdTyVars = tvs'+                                        , tcdFixity = Prefix+                                        , tcdDataDefn = defn }) }++cvtDec (NewtypeD ctxt tc tvs ksig constr derivs)+  = do  { (ctxt', tc', tvs') <- cvt_tycl_hdr ctxt tc tvs+        ; ksig' <- cvtKind `traverse` ksig+        ; con' <- cvtConstr constr+        ; derivs' <- cvtDerivs derivs+        ; let defn = HsDataDefn { dd_ext = noExt+                                , dd_ND = NewType, dd_cType = Nothing+                                , dd_ctxt = ctxt'+                                , dd_kindSig = ksig'+                                , dd_cons = [con']+                                , dd_derivs = derivs' }+        ; returnJustL $ TyClD noExt (DataDecl+                                    { tcdDExt = noExt+                                    , tcdLName = tc', tcdTyVars = tvs'+                                    , tcdFixity = Prefix+                                    , tcdDataDefn = defn }) }++cvtDec (ClassD ctxt cl tvs fds decs)+  = do  { (cxt', tc', tvs') <- cvt_tycl_hdr ctxt cl tvs+        ; fds'  <- mapM cvt_fundep fds+        ; (binds', sigs', fams', at_defs', adts') <- cvt_ci_decs (text "a class declaration") decs+        ; unless (null adts')+            (failWith $ (text "Default data instance declarations"+                     <+> text "are not allowed:")+                   $$ (Outputable.ppr adts'))+        ; returnJustL $ TyClD noExt $+          ClassDecl { tcdCExt = noExt+                    , tcdCtxt = cxt', tcdLName = tc', tcdTyVars = tvs'+                    , tcdFixity = Prefix+                    , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs'+                    , tcdMeths = binds'+                    , tcdATs = fams', tcdATDefs = at_defs', tcdDocs = [] }+                              -- no docs in TH ^^+        }++cvtDec (InstanceD o ctxt ty decs)+  = do  { let doc = text "an instance declaration"+        ; (binds', sigs', fams', ats', adts') <- cvt_ci_decs doc decs+        ; unless (null fams') (failWith (mkBadDecMsg doc fams'))+        ; ctxt' <- cvtContext funPrec ctxt+        ; (dL->L loc ty') <- cvtType ty+        ; let inst_ty' = mkHsQualTy ctxt loc ctxt' $ cL loc ty'+        ; returnJustL $ InstD noExt $ ClsInstD noExt $+          ClsInstDecl { cid_ext = noExt, cid_poly_ty = mkLHsSigType inst_ty'+                      , cid_binds = binds'+                      , cid_sigs = Hs.mkClassOpSigs sigs'+                      , cid_tyfam_insts = ats', cid_datafam_insts = adts'+                      , cid_overlap_mode = fmap (cL loc . overlap) o } }+  where+  overlap pragma =+    case pragma of+      TH.Overlaps      -> Hs.Overlaps     (SourceText "OVERLAPS")+      TH.Overlappable  -> Hs.Overlappable (SourceText "OVERLAPPABLE")+      TH.Overlapping   -> Hs.Overlapping  (SourceText "OVERLAPPING")+      TH.Incoherent    -> Hs.Incoherent   (SourceText "INCOHERENT")+++++cvtDec (ForeignD ford)+  = do { ford' <- cvtForD ford+       ; returnJustL $ ForD noExt ford' }++cvtDec (DataFamilyD tc tvs kind)+  = do { (_, tc', tvs') <- cvt_tycl_hdr [] tc tvs+       ; result <- cvtMaybeKindToFamilyResultSig kind+       ; returnJustL $ TyClD noExt $ FamDecl noExt $+         FamilyDecl noExt DataFamily tc' tvs' Prefix result Nothing }++cvtDec (DataInstD ctxt bndrs tys ksig constrs derivs)+  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys+       ; ksig' <- cvtKind `traverse` ksig+       ; cons' <- mapM cvtConstr constrs+       ; derivs' <- cvtDerivs derivs+       ; let defn = HsDataDefn { dd_ext = noExt+                               , dd_ND = DataType, dd_cType = Nothing+                               , dd_ctxt = ctxt'+                               , dd_kindSig = ksig'+                               , dd_cons = cons', dd_derivs = derivs' }++       ; returnJustL $ InstD noExt $ DataFamInstD+           { dfid_ext = noExt+           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $+                           FamEqn { feqn_ext = noExt+                                  , feqn_tycon = tc'+                                  , feqn_bndrs = bndrs'+                                  , feqn_pats = typats'+                                  , feqn_rhs = defn+                                  , feqn_fixity = Prefix } }}}++cvtDec (NewtypeInstD ctxt bndrs tys ksig constr derivs)+  = do { (ctxt', tc', bndrs', typats') <- cvt_datainst_hdr ctxt bndrs tys+       ; ksig' <- cvtKind `traverse` ksig+       ; con' <- cvtConstr constr+       ; derivs' <- cvtDerivs derivs+       ; let defn = HsDataDefn { dd_ext = noExt+                               , dd_ND = NewType, dd_cType = Nothing+                               , dd_ctxt = ctxt'+                               , dd_kindSig = ksig'+                               , dd_cons = [con'], dd_derivs = derivs' }+       ; returnJustL $ InstD noExt $ DataFamInstD+           { dfid_ext = noExt+           , dfid_inst = DataFamInstDecl { dfid_eqn = mkHsImplicitBndrs $+                           FamEqn { feqn_ext = noExt+                                  , feqn_tycon = tc'+                                  , feqn_bndrs = bndrs'+                                  , feqn_pats = typats'+                                  , feqn_rhs = defn+                                  , feqn_fixity = Prefix } }}}++cvtDec (TySynInstD eqn)+  = do  { (dL->L _ eqn') <- cvtTySynEqn eqn+        ; returnJustL $ InstD noExt $ TyFamInstD+            { tfid_ext = noExt+            , tfid_inst = TyFamInstDecl { tfid_eqn = eqn' } } }++cvtDec (OpenTypeFamilyD head)+  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head+       ; returnJustL $ TyClD noExt $ FamDecl noExt $+         FamilyDecl noExt OpenTypeFamily tc' tyvars' Prefix result' injectivity'+       }++cvtDec (ClosedTypeFamilyD head eqns)+  = do { (tc', tyvars', result', injectivity') <- cvt_tyfam_head head+       ; eqns' <- mapM cvtTySynEqn eqns+       ; returnJustL $ TyClD noExt $ FamDecl noExt $+         FamilyDecl noExt (ClosedTypeFamily (Just eqns')) tc' tyvars' Prefix+                           result' injectivity' }++cvtDec (TH.RoleAnnotD tc roles)+  = do { tc' <- tconNameL tc+       ; let roles' = map (noLoc . cvtRole) roles+       ; returnJustL $ Hs.RoleAnnotD noExt (RoleAnnotDecl noExt tc' roles') }++cvtDec (TH.StandaloneDerivD ds cxt ty)+  = do { cxt' <- cvtContext funPrec cxt+       ; ds'  <- traverse cvtDerivStrategy ds+       ; (dL->L loc ty') <- cvtType ty+       ; let inst_ty' = mkHsQualTy cxt loc cxt' $ cL loc ty'+       ; returnJustL $ DerivD noExt $+         DerivDecl { deriv_ext =noExt+                   , deriv_strategy = ds'+                   , deriv_type = mkLHsSigWcType inst_ty'+                   , deriv_overlap_mode = Nothing } }++cvtDec (TH.DefaultSigD nm typ)+  = do { nm' <- vNameL nm+       ; ty' <- cvtType typ+       ; returnJustL $ Hs.SigD noExt+                     $ ClassOpSig noExt True [nm'] (mkLHsSigType ty')}++cvtDec (TH.PatSynD nm args dir pat)+  = do { nm'   <- cNameL nm+       ; args' <- cvtArgs args+       ; dir'  <- cvtDir nm' dir+       ; pat'  <- cvtPat pat+       ; returnJustL $ Hs.ValD noExt $ PatSynBind noExt $+           PSB noExt nm' args' pat' dir' }+  where+    cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixCon <$> mapM vNameL args+    cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixCon <$> vNameL a1 <*> vNameL a2+    cvtArgs (TH.RecordPatSyn sels)+      = do { sels' <- mapM vNameL sels+           ; vars' <- mapM (vNameL . mkNameS . nameBase) sels+           ; return $ Hs.RecCon $ zipWith RecordPatSynField sels' vars' }++    cvtDir _ Unidir          = return Unidirectional+    cvtDir _ ImplBidir       = return ImplicitBidirectional+    cvtDir n (ExplBidir cls) =+      do { ms <- mapM (cvtClause (mkPrefixFunRhs n)) cls+         ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms }++cvtDec (TH.PatSynSigD nm ty)+  = do { nm' <- cNameL nm+       ; ty' <- cvtPatSynSigTy ty+       ; returnJustL $ Hs.SigD noExt $ PatSynSig noExt [nm'] (mkLHsSigType ty')}++-- Implicit parameter bindings are handled in cvtLocalDecs and+-- cvtImplicitParamBind. They are not allowed in any other scope, so+-- reaching this case indicates an error.+cvtDec (TH.ImplicitParamBindD _ _)+  = failWith (text "Implicit parameter binding only allowed in let or where")++----------------+cvtTySynEqn :: TySynEqn -> CvtM (LTyFamInstEqn GhcPs)+cvtTySynEqn (TySynEqn mb_bndrs lhs rhs)+  = do { mb_bndrs' <- traverse (mapM cvt_tv) mb_bndrs+       ; (head_ty, args) <- split_ty_app lhs+       ; case head_ty of+           ConT nm -> do { nm' <- tconNameL nm+                         ; rhs' <- cvtType rhs+                         ; let args' = map wrap_tyarg args+                         ; returnL $ mkHsImplicitBndrs+                            $ FamEqn { feqn_ext    = noExt+                                     , feqn_tycon  = nm'+                                     , feqn_bndrs  = mb_bndrs'+                                     , feqn_pats   = args'+                                     , feqn_fixity = Prefix+                                     , feqn_rhs    = rhs' } }+           InfixT t1 nm t2 -> do { nm' <- tconNameL nm+                                 ; args' <- mapM cvtType [t1,t2]+                                 ; rhs' <- cvtType rhs+                                 ; returnL $ mkHsImplicitBndrs+                                      $ FamEqn { feqn_ext    = noExt+                                               , feqn_tycon  = nm'+                                               , feqn_bndrs  = mb_bndrs'+                                               , feqn_pats   =+                                                (map HsValArg args') ++ args+                                               , feqn_fixity = Hs.Infix+                                               , feqn_rhs    = rhs' } }+           _ -> failWith $ text "Invalid type family instance LHS:"+                          <+> text (show lhs)+        }++----------------+cvt_ci_decs :: MsgDoc -> [TH.Dec]+            -> CvtM (LHsBinds GhcPs,+                     [LSig GhcPs],+                     [LFamilyDecl GhcPs],+                     [LTyFamInstDecl GhcPs],+                     [LDataFamInstDecl GhcPs])+-- Convert the declarations inside a class or instance decl+-- ie signatures, bindings, and associated types+cvt_ci_decs doc decs+  = do  { decs' <- cvtDecs decs+        ; let (ats', bind_sig_decs') = partitionWith is_tyfam_inst decs'+        ; let (adts', no_ats')       = partitionWith is_datafam_inst bind_sig_decs'+        ; let (sigs', prob_binds')   = partitionWith is_sig no_ats'+        ; let (binds', prob_fams')   = partitionWith is_bind prob_binds'+        ; let (fams', bads)          = partitionWith is_fam_decl prob_fams'+        ; unless (null bads) (failWith (mkBadDecMsg doc bads))+          --We use FromSource as the origin of the bind+          -- because the TH declaration is user-written+        ; return (listToBag binds', sigs', fams', ats', adts') }++----------------+cvt_tycl_hdr :: TH.Cxt -> TH.Name -> [TH.TyVarBndr]+             -> CvtM ( LHsContext GhcPs+                     , Located RdrName+                     , LHsQTyVars GhcPs)+cvt_tycl_hdr cxt tc tvs+  = do { cxt' <- cvtContext funPrec cxt+       ; tc'  <- tconNameL tc+       ; tvs' <- cvtTvs tvs+       ; return (cxt', tc', tvs')+       }++cvt_datainst_hdr :: TH.Cxt -> Maybe [TH.TyVarBndr] -> TH.Type+               -> CvtM ( LHsContext GhcPs+                       , Located RdrName+                       , Maybe [LHsTyVarBndr GhcPs]+                       , HsTyPats GhcPs)+cvt_datainst_hdr cxt bndrs tys+  = do { cxt' <- cvtContext funPrec cxt+       ; bndrs' <- traverse (mapM cvt_tv) bndrs+       ; (head_ty, args) <- split_ty_app tys+       ; case head_ty of+          ConT nm -> do { nm' <- tconNameL nm+                        ; let args' = map wrap_tyarg args+                        ; return (cxt', nm', bndrs', args') }+          InfixT t1 nm t2 -> do { nm' <- tconNameL nm+                                ; args' <- mapM cvtType [t1,t2]+                                ; return (cxt', nm', bndrs',+                                         ((map HsValArg args') ++ args)) }+          _ -> failWith $ text "Invalid type instance header:"+                          <+> text (show tys) }++----------------+cvt_tyfam_head :: TypeFamilyHead+               -> CvtM ( Located RdrName+                       , LHsQTyVars GhcPs+                       , Hs.LFamilyResultSig GhcPs+                       , Maybe (Hs.LInjectivityAnn GhcPs))++cvt_tyfam_head (TypeFamilyHead tc tyvars result injectivity)+  = do {(_, tc', tyvars') <- cvt_tycl_hdr [] tc tyvars+       ; result' <- cvtFamilyResultSig result+       ; injectivity' <- traverse cvtInjectivityAnnotation injectivity+       ; return (tc', tyvars', result', injectivity') }++-------------------------------------------------------------------+--              Partitioning declarations+-------------------------------------------------------------------++is_fam_decl :: LHsDecl GhcPs -> Either (LFamilyDecl GhcPs) (LHsDecl GhcPs)+is_fam_decl (dL->L loc (TyClD _ (FamDecl { tcdFam = d }))) = Left (cL loc d)+is_fam_decl decl = Right decl++is_tyfam_inst :: LHsDecl GhcPs -> Either (LTyFamInstDecl GhcPs) (LHsDecl GhcPs)+is_tyfam_inst (dL->L loc (Hs.InstD _ (TyFamInstD { tfid_inst = d })))+  = Left (cL loc d)+is_tyfam_inst decl+  = Right decl++is_datafam_inst :: LHsDecl GhcPs+                -> Either (LDataFamInstDecl GhcPs) (LHsDecl GhcPs)+is_datafam_inst (dL->L loc (Hs.InstD  _ (DataFamInstD { dfid_inst = d })))+  = Left (cL loc d)+is_datafam_inst decl+  = Right decl++is_sig :: LHsDecl GhcPs -> Either (LSig GhcPs) (LHsDecl GhcPs)+is_sig (dL->L loc (Hs.SigD _ sig)) = Left (cL loc sig)+is_sig decl                        = Right decl++is_bind :: LHsDecl GhcPs -> Either (LHsBind GhcPs) (LHsDecl GhcPs)+is_bind (dL->L loc (Hs.ValD _ bind)) = Left (cL loc bind)+is_bind decl                         = Right decl++is_ip_bind :: TH.Dec -> Either (String, TH.Exp) TH.Dec+is_ip_bind (TH.ImplicitParamBindD n e) = Left (n, e)+is_ip_bind decl             = Right decl++mkBadDecMsg :: Outputable a => MsgDoc -> [a] -> MsgDoc+mkBadDecMsg doc bads+  = sep [ text "Illegal declaration(s) in" <+> doc <> colon+        , nest 2 (vcat (map Outputable.ppr bads)) ]++---------------------------------------------------+--      Data types+---------------------------------------------------++cvtConstr :: TH.Con -> CvtM (LConDecl GhcPs)++cvtConstr (NormalC c strtys)+  = do  { c'   <- cNameL c+        ; tys' <- mapM cvt_arg strtys+        ; returnL $ mkConDeclH98 c' Nothing Nothing (PrefixCon tys') }++cvtConstr (RecC c varstrtys)+  = do  { c'    <- cNameL c+        ; args' <- mapM cvt_id_arg varstrtys+        ; returnL $ mkConDeclH98 c' Nothing Nothing+                                   (RecCon (noLoc args')) }++cvtConstr (InfixC st1 c st2)+  = do  { c'   <- cNameL c+        ; st1' <- cvt_arg st1+        ; st2' <- cvt_arg st2+        ; returnL $ mkConDeclH98 c' Nothing Nothing (InfixCon st1' st2') }++cvtConstr (ForallC tvs ctxt con)+  = do  { tvs'      <- cvtTvs tvs+        ; ctxt'     <- cvtContext funPrec ctxt+        ; (dL->L _ con')  <- cvtConstr con+        ; returnL $ add_forall tvs' ctxt' con' }+  where+    add_cxt lcxt         Nothing           = Just lcxt+    add_cxt (dL->L loc cxt1) (Just (dL->L _ cxt2))+      = Just (cL loc (cxt1 ++ cxt2))++    add_forall tvs' cxt' con@(ConDeclGADT { con_qvars = qvars, con_mb_cxt = cxt })+      = con { con_forall = noLoc $ not (null all_tvs)+            , con_qvars  = mkHsQTvs all_tvs+            , con_mb_cxt = add_cxt cxt' cxt }+      where+        all_tvs = hsQTvExplicit tvs' ++ hsQTvExplicit qvars++    add_forall tvs' cxt' con@(ConDeclH98 { con_ex_tvs = ex_tvs, con_mb_cxt = cxt })+      = con { con_forall = noLoc $ not (null all_tvs)+            , con_ex_tvs = all_tvs+            , con_mb_cxt = add_cxt cxt' cxt }+      where+        all_tvs = hsQTvExplicit tvs' ++ ex_tvs++    add_forall _ _ (XConDecl _) = panic "cvtConstr"++cvtConstr (GadtC c strtys ty)+  = do  { c'      <- mapM cNameL c+        ; args    <- mapM cvt_arg strtys+        ; (dL->L _ ty') <- cvtType ty+        ; c_ty    <- mk_arr_apps args ty'+        ; returnL $ fst $ mkGadtDecl c' c_ty}++cvtConstr (RecGadtC c varstrtys ty)+  = do  { c'       <- mapM cNameL c+        ; ty'      <- cvtType ty+        ; rec_flds <- mapM cvt_id_arg varstrtys+        ; let rec_ty = noLoc (HsFunTy noExt+                                           (noLoc $ HsRecTy noExt rec_flds) ty')+        ; returnL $ fst $ mkGadtDecl c' rec_ty }++cvtSrcUnpackedness :: TH.SourceUnpackedness -> SrcUnpackedness+cvtSrcUnpackedness NoSourceUnpackedness = NoSrcUnpack+cvtSrcUnpackedness SourceNoUnpack       = SrcNoUnpack+cvtSrcUnpackedness SourceUnpack         = SrcUnpack++cvtSrcStrictness :: TH.SourceStrictness -> SrcStrictness+cvtSrcStrictness NoSourceStrictness = NoSrcStrict+cvtSrcStrictness SourceLazy         = SrcLazy+cvtSrcStrictness SourceStrict       = SrcStrict++cvt_arg :: (TH.Bang, TH.Type) -> CvtM (LHsType GhcPs)+cvt_arg (Bang su ss, ty)+  = do { ty'' <- cvtType ty+       ; let ty' = parenthesizeHsType appPrec ty''+             su' = cvtSrcUnpackedness su+             ss' = cvtSrcStrictness ss+       ; returnL $ HsBangTy noExt (HsSrcBang NoSourceText su' ss') ty' }++cvt_id_arg :: (TH.Name, TH.Bang, TH.Type) -> CvtM (LConDeclField GhcPs)+cvt_id_arg (i, str, ty)+  = do  { (dL->L li i') <- vNameL i+        ; ty' <- cvt_arg (str,ty)+        ; return $ noLoc (ConDeclField+                          { cd_fld_ext = noExt+                          , cd_fld_names+                              = [cL li $ FieldOcc noExt (cL li i')]+                          , cd_fld_type =  ty'+                          , cd_fld_doc = Nothing}) }++cvtDerivs :: [TH.DerivClause] -> CvtM (HsDeriving GhcPs)+cvtDerivs cs = do { cs' <- mapM cvtDerivClause cs+                  ; returnL cs' }++cvt_fundep :: FunDep -> CvtM (LHsFunDep GhcPs)+cvt_fundep (FunDep xs ys) = do { xs' <- mapM tNameL xs+                               ; ys' <- mapM tNameL ys+                               ; returnL (xs', ys') }+++------------------------------------------+--      Foreign declarations+------------------------------------------++cvtForD :: Foreign -> CvtM (ForeignDecl GhcPs)+cvtForD (ImportF callconv safety from nm ty)+  -- the prim and javascript calling conventions do not support headers+  -- and are inserted verbatim, analogous to mkImport in RdrHsSyn+  | callconv == TH.Prim || callconv == TH.JavaScript+  = mk_imp (CImport (noLoc (cvt_conv callconv)) (noLoc safety') Nothing+                    (CFunction (StaticTarget (SourceText from)+                                             (mkFastString from) Nothing+                                             True))+                    (noLoc $ quotedSourceText from))+  | Just impspec <- parseCImport (noLoc (cvt_conv callconv)) (noLoc safety')+                                 (mkFastString (TH.nameBase nm))+                                 from (noLoc $ quotedSourceText from)+  = mk_imp impspec+  | otherwise+  = failWith $ text (show from) <+> text "is not a valid ccall impent"+  where+    mk_imp impspec+      = do { nm' <- vNameL nm+           ; ty' <- cvtType ty+           ; return (ForeignImport { fd_i_ext = noExt+                                   , fd_name = nm'+                                   , fd_sig_ty = mkLHsSigType ty'+                                   , fd_fi = impspec })+           }+    safety' = case safety of+                     Unsafe     -> PlayRisky+                     Safe       -> PlaySafe+                     Interruptible -> PlayInterruptible++cvtForD (ExportF callconv as nm ty)+  = do  { nm' <- vNameL nm+        ; ty' <- cvtType ty+        ; let e = CExport (noLoc (CExportStatic (SourceText as)+                                                (mkFastString as)+                                                (cvt_conv callconv)))+                                                (noLoc (SourceText as))+        ; return $ ForeignExport { fd_e_ext = noExt+                                 , fd_name = nm'+                                 , fd_sig_ty = mkLHsSigType ty'+                                 , fd_fe = e } }++cvt_conv :: TH.Callconv -> CCallConv+cvt_conv TH.CCall      = CCallConv+cvt_conv TH.StdCall    = StdCallConv+cvt_conv TH.CApi       = CApiConv+cvt_conv TH.Prim       = PrimCallConv+cvt_conv TH.JavaScript = JavaScriptCallConv++------------------------------------------+--              Pragmas+------------------------------------------++cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))+cvtPragmaD (InlineP nm inline rm phases)+  = do { nm' <- vNameL nm+       ; let dflt = dfltActivation inline+       ; let src TH.NoInline  = "{-# NOINLINE"+             src TH.Inline    = "{-# INLINE"+             src TH.Inlinable = "{-# INLINABLE"+       ; let ip   = InlinePragma { inl_src    = SourceText $ src inline+                                 , inl_inline = cvtInline inline+                                 , inl_rule   = cvtRuleMatch rm+                                 , inl_act    = cvtPhases phases dflt+                                 , inl_sat    = Nothing }+       ; returnJustL $ Hs.SigD noExt $ InlineSig noExt nm' ip }++cvtPragmaD (SpecialiseP nm ty inline phases)+  = do { nm' <- vNameL nm+       ; ty' <- cvtType ty+       ; let src TH.NoInline  = "{-# SPECIALISE NOINLINE"+             src TH.Inline    = "{-# SPECIALISE INLINE"+             src TH.Inlinable = "{-# SPECIALISE INLINE"+       ; let (inline', dflt,srcText) = case inline of+               Just inline1 -> (cvtInline inline1, dfltActivation inline1,+                                src inline1)+               Nothing      -> (NoUserInline,   AlwaysActive,+                                "{-# SPECIALISE")+       ; let ip = InlinePragma { inl_src    = SourceText srcText+                               , inl_inline = inline'+                               , inl_rule   = Hs.FunLike+                               , inl_act    = cvtPhases phases dflt+                               , inl_sat    = Nothing }+       ; returnJustL $ Hs.SigD noExt $ SpecSig noExt nm' [mkLHsSigType ty'] ip }++cvtPragmaD (SpecialiseInstP ty)+  = do { ty' <- cvtType ty+       ; returnJustL $ Hs.SigD noExt $+         SpecInstSig noExt (SourceText "{-# SPECIALISE") (mkLHsSigType ty') }++cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases)+  = do { let nm' = mkFastString nm+       ; let act = cvtPhases phases AlwaysActive+       ; ty_bndrs' <- traverse (mapM cvt_tv) ty_bndrs+       ; tm_bndrs' <- mapM cvtRuleBndr tm_bndrs+       ; lhs'   <- cvtl lhs+       ; rhs'   <- cvtl rhs+       ; returnJustL $ Hs.RuleD noExt+            $ HsRules { rds_ext = noExt+                      , rds_src = SourceText "{-# RULES"+                      , rds_rules = [noLoc $+                          HsRule { rd_ext  = noExt+                                 , rd_name = (noLoc (quotedSourceText nm,nm'))+                                 , rd_act  = act+                                 , rd_tyvs = ty_bndrs'+                                 , rd_tmvs = tm_bndrs'+                                 , rd_lhs  = lhs'+                                 , rd_rhs  = rhs' }] }++          }++cvtPragmaD (AnnP target exp)+  = do { exp' <- cvtl exp+       ; target' <- case target of+         ModuleAnnotation  -> return ModuleAnnProvenance+         TypeAnnotation n  -> do+           n' <- tconName n+           return (TypeAnnProvenance  (noLoc n'))+         ValueAnnotation n -> do+           n' <- vcName n+           return (ValueAnnProvenance (noLoc n'))+       ; returnJustL $ Hs.AnnD noExt+                     $ HsAnnotation noExt (SourceText "{-# ANN") target' exp'+       }++cvtPragmaD (LineP line file)+  = do { setL (srcLocSpan (mkSrcLoc (fsLit file) line 1))+       ; return Nothing+       }+cvtPragmaD (CompleteP cls mty)+  = do { cls' <- noLoc <$> mapM cNameL cls+       ; mty'  <- traverse tconNameL mty+       ; returnJustL $ Hs.SigD noExt+                   $ CompleteMatchSig noExt NoSourceText cls' mty' }++dfltActivation :: TH.Inline -> Activation+dfltActivation TH.NoInline = NeverActive+dfltActivation _           = AlwaysActive++cvtInline :: TH.Inline -> Hs.InlineSpec+cvtInline TH.NoInline  = Hs.NoInline+cvtInline TH.Inline    = Hs.Inline+cvtInline TH.Inlinable = Hs.Inlinable++cvtRuleMatch :: TH.RuleMatch -> RuleMatchInfo+cvtRuleMatch TH.ConLike = Hs.ConLike+cvtRuleMatch TH.FunLike = Hs.FunLike++cvtPhases :: TH.Phases -> Activation -> Activation+cvtPhases AllPhases       dflt = dflt+cvtPhases (FromPhase i)   _    = ActiveAfter NoSourceText i+cvtPhases (BeforePhase i) _    = ActiveBefore NoSourceText i++cvtRuleBndr :: TH.RuleBndr -> CvtM (Hs.LRuleBndr GhcPs)+cvtRuleBndr (RuleVar n)+  = do { n' <- vNameL n+       ; return $ noLoc $ Hs.RuleBndr noExt n' }+cvtRuleBndr (TypedRuleVar n ty)+  = do { n'  <- vNameL n+       ; ty' <- cvtType ty+       ; return $ noLoc $ Hs.RuleBndrSig noExt n' $ mkLHsSigWcType ty' }++---------------------------------------------------+--              Declarations+---------------------------------------------------++cvtLocalDecs :: MsgDoc -> [TH.Dec] -> CvtM (HsLocalBinds GhcPs)+cvtLocalDecs doc ds+  = case partitionWith is_ip_bind ds of+      ([], []) -> return (EmptyLocalBinds noExt)+      ([], _) -> do+        ds' <- cvtDecs ds+        let (binds, prob_sigs) = partitionWith is_bind ds'+        let (sigs, bads) = partitionWith is_sig prob_sigs+        unless (null bads) (failWith (mkBadDecMsg doc bads))+        return (HsValBinds noExt (ValBinds noExt (listToBag binds) sigs))+      (ip_binds, []) -> do+        binds <- mapM (uncurry cvtImplicitParamBind) ip_binds+        return (HsIPBinds noExt (IPBinds noExt binds))+      ((_:_), (_:_)) ->+        failWith (text "Implicit parameters mixed with other bindings")++cvtClause :: HsMatchContext RdrName+          -> TH.Clause -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))+cvtClause ctxt (Clause ps body wheres)+  = do  { ps' <- cvtPats ps+        ; let pps = map (parenthesizePat appPrec) ps'+        ; g'  <- cvtGuard body+        ; ds' <- cvtLocalDecs (text "a where clause") wheres+        ; returnL $ Hs.Match noExt ctxt pps (GRHSs noExt g' (noLoc ds')) }++cvtImplicitParamBind :: String -> TH.Exp -> CvtM (LIPBind GhcPs)+cvtImplicitParamBind n e = do+    n' <- wrapL (ipName n)+    e' <- cvtl e+    returnL (IPBind noExt (Left n') e')++-------------------------------------------------------------------+--              Expressions+-------------------------------------------------------------------++cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)+cvtl e = wrapL (cvt e)+  where+    cvt (VarE s)        = do { s' <- vName s; return $ HsVar noExt (noLoc s') }+    cvt (ConE s)        = do { s' <- cName s; return $ HsVar noExt (noLoc s') }+    cvt (LitE l)+      | overloadedLit l = go cvtOverLit (HsOverLit noExt)+                             (hsOverLitNeedsParens appPrec)+      | otherwise       = go cvtLit (HsLit noExt)+                             (hsLitNeedsParens appPrec)+      where+        go :: (Lit -> CvtM (l GhcPs))+           -> (l GhcPs -> HsExpr GhcPs)+           -> (l GhcPs -> Bool)+           -> CvtM (HsExpr GhcPs)+        go cvt_lit mk_expr is_compound_lit = do+          l' <- cvt_lit l+          let e' = mk_expr l'+          return $ if is_compound_lit l' then HsPar noExt (noLoc e') else e'+    cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y+                                   ; return $ HsApp noExt (mkLHsPar x')+                                                          (mkLHsPar y')}+    cvt (AppE x y)            = do { x' <- cvtl x; y' <- cvtl y+                                   ; return $ HsApp noExt (mkLHsPar x')+                                                          (mkLHsPar y')}+    cvt (AppTypeE e t) = do { e' <- cvtl e+                            ; t' <- cvtType t+                            ; let tp = parenthesizeHsType appPrec t'+                            ; return $ HsAppType noExt e'+                                     $ mkHsWildCardBndrs tp }+    cvt (LamE [] e)    = cvt e -- Degenerate case. We convert the body as its+                               -- own expression to avoid pretty-printing+                               -- oddities that can result from zero-argument+                               -- lambda expressions. See #13856.+    cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e+                            ; let pats = map (parenthesizePat appPrec) ps'+                            ; return $ HsLam noExt (mkMatchGroup FromSource+                                             [mkSimpleMatch LambdaExpr+                                             pats e'])}+    cvt (LamCaseE ms)  = do { ms' <- mapM (cvtMatch CaseAlt) ms+                            ; return $ HsLamCase noExt+                                                   (mkMatchGroup FromSource ms')+                            }+    cvt (TupE [e])     = do { e' <- cvtl e; return $ HsPar noExt e' }+                                 -- Note [Dropping constructors]+                                 -- Singleton tuples treated like nothing (just parens)+    cvt (TupE es)      = do { es' <- mapM cvtl es+                            ; return $ ExplicitTuple noExt+                                             (map (noLoc . (Present noExt)) es')+                                                                         Boxed }+    cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es+                                   ; return $ ExplicitTuple noExt+                                           (map (noLoc . (Present noExt)) es')+                                                                       Unboxed }+    cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e+                                       ; unboxedSumChecks alt arity+                                       ; return $ ExplicitSum noExt+                                                                   alt arity e'}+    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;+                            ; return $ HsIf noExt (Just noSyntaxExpr) x' y' z' }+    cvt (MultiIfE alts)+      | null alts      = failWith (text "Multi-way if-expression with no alternatives")+      | otherwise      = do { alts' <- mapM cvtpair alts+                            ; return $ HsMultiIf noExt alts' }+    cvt (LetE ds e)    = do { ds' <- cvtLocalDecs (text "a let expression") ds+                            ; e' <- cvtl e; return $ HsLet noExt (noLoc ds') e'}+    cvt (CaseE e ms)   = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms+                            ; return $ HsCase noExt e'+                                                 (mkMatchGroup FromSource ms') }+    cvt (DoE ss)       = cvtHsDo DoExpr ss+    cvt (MDoE ss)      = cvtHsDo MDoExpr ss+    cvt (CompE ss)     = cvtHsDo ListComp ss+    cvt (ArithSeqE dd) = do { dd' <- cvtDD dd+                            ; return $ ArithSeq noExt Nothing dd' }+    cvt (ListE xs)+      | Just s <- allCharLs xs       = do { l' <- cvtLit (StringL s)+                                          ; return (HsLit noExt l') }+             -- Note [Converting strings]+      | otherwise       = do { xs' <- mapM cvtl xs+                             ; return $ ExplicitList noExt Nothing xs'+                             }++    -- Infix expressions+    cvt (InfixE (Just x) s (Just y)) =+      do { x' <- cvtl x+         ; s' <- cvtl s+         ; y' <- cvtl y+         ; let px = parenthesizeHsExpr opPrec x'+               py = parenthesizeHsExpr opPrec y'+         ; wrapParL (HsPar noExt)+           $ OpApp noExt px s' py }+           -- Parenthesise both arguments and result,+           -- to ensure this operator application does+           -- does not get re-associated+           -- See Note [Operator association]+    cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y+                                          ; wrapParL (HsPar noExt) $+                                                          SectionR noExt s' y' }+                                            -- See Note [Sections in HsSyn] in HsExpr+    cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s+                                          ; wrapParL (HsPar noExt) $+                                                          SectionL noExt x' s' }++    cvt (InfixE Nothing  s Nothing ) = do { s' <- cvtl s+                                          ; return $ HsPar noExt s' }+                                       -- Can I indicate this is an infix thing?+                                       -- Note [Dropping constructors]++    cvt (UInfixE x s y)  = do { x' <- cvtl x+                              ; let x'' = case unLoc x' of+                                            OpApp {} -> x'+                                            _ -> mkLHsPar x'+                              ; cvtOpApp x'' s y } --  Note [Converting UInfix]++    cvt (ParensE e)      = do { e' <- cvtl e; return $ HsPar noExt e' }+    cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t+                              ; let pe = parenthesizeHsExpr sigPrec e'+                              ; return $ ExprWithTySig noExt pe (mkLHsSigWcType t') }+    cvt (RecConE c flds) = do { c' <- cNameL c+                              ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds+                              ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }+    cvt (RecUpdE e flds) = do { e' <- cvtl e+                              ; flds'+                                  <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))+                                           flds+                              ; return $ mkRdrRecordUpd e' flds' }+    cvt (StaticE e)      = fmap (HsStatic noExt) $ cvtl e+    cvt (UnboundVarE s)  = do -- Use of 'vcName' here instead of 'vName' is+                              -- important, because UnboundVarE may contain+                              -- constructor names - see #14627.+                              { s' <- vcName s+                              ; return $ HsVar noExt (noLoc s') }+    cvt (LabelE s)       = do { return $ HsOverLabel noExt Nothing (fsLit s) }+    cvt (ImplicitParamVarE n) = do { n' <- ipName n; return $ HsIPVar noExt n' }++{- Note [Dropping constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we drop constructors from the input (for instance, when we encounter @TupE [e]@)+we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@+could meet @UInfix@ constructors containing the @TupE [e]@. For example:++  UInfixE x * (TupE [UInfixE y + z])++If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet+and the above expression would be reassociated to++  OpApp (OpApp x * y) + z++which we don't want.+-}++cvtFld :: (RdrName -> t) -> (TH.Name, TH.Exp)+       -> CvtM (LHsRecField' t (LHsExpr GhcPs))+cvtFld f (v,e)+  = do  { v' <- vNameL v; e' <- cvtl e+        ; return (noLoc $ HsRecField { hsRecFieldLbl = fmap f v'+                                     , hsRecFieldArg = e'+                                     , hsRecPun      = False}) }++cvtDD :: Range -> CvtM (ArithSeqInfo GhcPs)+cvtDD (FromR x)           = do { x' <- cvtl x; return $ From x' }+cvtDD (FromThenR x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x' y' }+cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' }+cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' }++{- Note [Operator assocation]+We must be quite careful about adding parens:+  * Infix (UInfix ...) op arg      Needs parens round the first arg+  * Infix (Infix ...) op arg       Needs parens round the first arg+  * UInfix (UInfix ...) op arg     No parens for first arg+  * UInfix (Infix ...) op arg      Needs parens round first arg+++Note [Converting UInfix]+~~~~~~~~~~~~~~~~~~~~~~~~+When converting @UInfixE@, @UInfixP@, and @UInfixT@ values, we want to readjust+the trees to reflect the fixities of the underlying operators:++  UInfixE x * (UInfixE y + z) ---> (x * y) + z++This is done by the renamer (see @mkOppAppRn@, @mkConOppPatRn@, and+@mkHsOpTyRn@ in RnTypes), which expects that the input will be completely+right-biased for types and left-biased for everything else. So we left-bias the+trees of @UInfixP@ and @UInfixE@ and right-bias the trees of @UInfixT@.++Sample input:++  UInfixE+   (UInfixE x op1 y)+   op2+   (UInfixE z op3 w)++Sample output:++  OpApp+    (OpApp+      (OpApp x op1 y)+      op2+      z)+    op3+    w++The functions @cvtOpApp@, @cvtOpAppP@, and @cvtOpAppT@ are responsible for this+biasing.+-}++{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.+The produced tree of infix expressions will be left-biased, provided @x@ is.++We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis+is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that+this holds for both branches (of @cvtOpApp@), provided we assume it holds for+the recursive calls to @cvtOpApp@.++When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased+since we have already run @cvtl@ on it.+-}+cvtOpApp :: LHsExpr GhcPs -> TH.Exp -> TH.Exp -> CvtM (HsExpr GhcPs)+cvtOpApp x op1 (UInfixE y op2 z)+  = do { l <- wrapL $ cvtOpApp x op1 y+       ; cvtOpApp l op2 z }+cvtOpApp x op y+  = do { op' <- cvtl op+       ; y' <- cvtl y+       ; return (OpApp noExt x op' y') }++-------------------------------------+--      Do notation and statements+-------------------------------------++cvtHsDo :: HsStmtContext Name.Name -> [TH.Stmt] -> CvtM (HsExpr GhcPs)+cvtHsDo do_or_lc stmts+  | null stmts = failWith (text "Empty stmt list in do-block")+  | otherwise+  = do  { stmts' <- cvtStmts stmts+        ; let Just (stmts'', last') = snocView stmts'++        ; last'' <- case last' of+                    (dL->L loc (BodyStmt _ body _ _))+                      -> return (cL loc (mkLastStmt body))+                    _ -> failWith (bad_last last')++        ; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) }+  where+    bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon+                         , nest 2 $ Outputable.ppr stmt+                         , text "(It should be an expression.)" ]++cvtStmts :: [TH.Stmt] -> CvtM [Hs.LStmt GhcPs (LHsExpr GhcPs)]+cvtStmts = mapM cvtStmt++cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt GhcPs (LHsExpr GhcPs))+cvtStmt (NoBindS e)    = do { e' <- cvtl e; returnL $ mkBodyStmt e' }+cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }+cvtStmt (TH.LetS ds)   = do { ds' <- cvtLocalDecs (text "a let binding") ds+                            ; returnL $ LetStmt noExt (noLoc ds') }+cvtStmt (TH.ParS dss)  = do { dss' <- mapM cvt_one dss+                            ; returnL $ ParStmt noExt dss' noExpr noSyntaxExpr }+  where+    cvt_one ds = do { ds' <- cvtStmts ds+                    ; return (ParStmtBlock noExt ds' undefined noSyntaxExpr) }+cvtStmt (TH.RecS ss) = do { ss' <- mapM cvtStmt ss; returnL (mkRecStmt ss') }++cvtMatch :: HsMatchContext RdrName+         -> TH.Match -> CvtM (Hs.LMatch GhcPs (LHsExpr GhcPs))+cvtMatch ctxt (TH.Match p body decs)+  = do  { p' <- cvtPat p+        ; let lp = case p' of+                     (dL->L loc SigPat{}) -> cL loc (ParPat NoExt p') -- #14875+                     _                    -> p'+        ; g' <- cvtGuard body+        ; decs' <- cvtLocalDecs (text "a where clause") decs+        ; returnL $ Hs.Match noExt ctxt [lp] (GRHSs noExt g' (noLoc decs')) }++cvtGuard :: TH.Body -> CvtM [LGRHS GhcPs (LHsExpr GhcPs)]+cvtGuard (GuardedB pairs) = mapM cvtpair pairs+cvtGuard (NormalB e)      = do { e' <- cvtl e+                               ; g' <- returnL $ GRHS noExt [] e'; return [g'] }++cvtpair :: (TH.Guard, TH.Exp) -> CvtM (LGRHS GhcPs (LHsExpr GhcPs))+cvtpair (NormalG ge,rhs) = do { ge' <- cvtl ge; rhs' <- cvtl rhs+                              ; g' <- returnL $ mkBodyStmt ge'+                              ; returnL $ GRHS noExt [g'] rhs' }+cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs+                              ; returnL $ GRHS noExt gs' rhs' }++cvtOverLit :: Lit -> CvtM (HsOverLit GhcPs)+cvtOverLit (IntegerL i)+  = do { force i; return $ mkHsIntegral   (mkIntegralLit i) }+cvtOverLit (RationalL r)+  = do { force r; return $ mkHsFractional (mkFractionalLit r) }+cvtOverLit (StringL s)+  = do { let { s' = mkFastString s }+       ; force s'+       ; return $ mkHsIsString (quotedSourceText s) s'+       }+cvtOverLit _ = panic "Convert.cvtOverLit: Unexpected overloaded literal"+-- An Integer is like an (overloaded) '3' in a Haskell source program+-- Similarly 3.5 for fractionals++{- Note [Converting strings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we get (ListE [CharL 'x', CharL 'y']) we'd like to convert to+a string literal for "xy".  Of course, we might hope to get+(LitE (StringL "xy")), but not always, and allCharLs fails quickly+if it isn't a literal string+-}++allCharLs :: [TH.Exp] -> Maybe String+-- Note [Converting strings]+-- NB: only fire up this setup for a non-empty list, else+--     there's a danger of returning "" for [] :: [Int]!+allCharLs xs+  = case xs of+      LitE (CharL c) : ys -> go [c] ys+      _                   -> Nothing+  where+    go cs []                    = Just (reverse cs)+    go cs (LitE (CharL c) : ys) = go (c:cs) ys+    go _  _                     = Nothing++cvtLit :: Lit -> CvtM (HsLit GhcPs)+cvtLit (IntPrimL i)    = do { force i; return $ HsIntPrim NoSourceText i }+cvtLit (WordPrimL w)   = do { force w; return $ HsWordPrim NoSourceText w }+cvtLit (FloatPrimL f)+  = do { force f; return $ HsFloatPrim noExt (mkFractionalLit f) }+cvtLit (DoublePrimL f)+  = do { force f; return $ HsDoublePrim noExt (mkFractionalLit f) }+cvtLit (CharL c)       = do { force c; return $ HsChar NoSourceText c }+cvtLit (CharPrimL c)   = do { force c; return $ HsCharPrim NoSourceText c }+cvtLit (StringL s)     = do { let { s' = mkFastString s }+                            ; force s'+                            ; return $ HsString (quotedSourceText s) s' }+cvtLit (StringPrimL s) = do { let { s' = BS.pack s }+                            ; force s'+                            ; return $ HsStringPrim NoSourceText s' }+cvtLit (BytesPrimL (Bytes fptr off sz)) = do+  let bs = unsafePerformIO $ withForeignPtr fptr $ \ptr ->+             BS.packCStringLen (ptr `plusPtr` fromIntegral off, fromIntegral sz)+  force bs+  return $ HsStringPrim NoSourceText bs+cvtLit _ = panic "Convert.cvtLit: Unexpected literal"+        -- cvtLit should not be called on IntegerL, RationalL+        -- That precondition is established right here in+        -- Convert.hs, hence panic++quotedSourceText :: String -> SourceText+quotedSourceText s = SourceText $ "\"" ++ s ++ "\""++cvtPats :: [TH.Pat] -> CvtM [Hs.LPat GhcPs]+cvtPats pats = mapM cvtPat pats++cvtPat :: TH.Pat -> CvtM (Hs.LPat GhcPs)+cvtPat pat = wrapL (cvtp pat)++cvtp :: TH.Pat -> CvtM (Hs.Pat GhcPs)+cvtp (TH.LitP l)+  | overloadedLit l    = do { l' <- cvtOverLit l+                            ; return (mkNPat (noLoc l') Nothing) }+                                  -- Not right for negative patterns;+                                  -- need to think about that!+  | otherwise          = do { l' <- cvtLit l; return $ Hs.LitPat noExt l' }+cvtp (TH.VarP s)       = do { s' <- vName s+                            ; return $ Hs.VarPat noExt (noLoc s') }+cvtp (TupP [p])        = do { p' <- cvtPat p; return $ ParPat noExt p' }+                                         -- Note [Dropping constructors]+cvtp (TupP ps)         = do { ps' <- cvtPats ps+                            ; return $ TuplePat noExt ps' Boxed }+cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps+                            ; return $ TuplePat noExt ps' Unboxed }+cvtp (UnboxedSumP p alt arity)+                       = do { p' <- cvtPat p+                            ; unboxedSumChecks alt arity+                            ; return $ SumPat noExt p' alt arity }+cvtp (ConP s ps)       = do { s' <- cNameL s; ps' <- cvtPats ps+                            ; let pps = map (parenthesizePat appPrec) ps'+                            ; return $ ConPatIn s' (PrefixCon pps) }+cvtp (InfixP p1 s p2)  = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2+                            ; wrapParL (ParPat noExt) $+                              ConPatIn s' $+                              InfixCon (parenthesizePat opPrec p1')+                                       (parenthesizePat opPrec p2') }+                            -- See Note [Operator association]+cvtp (UInfixP p1 s p2) = do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix]+cvtp (ParensP p)       = do { p' <- cvtPat p;+                            ; case unLoc p' of  -- may be wrapped ConPatIn+                                ParPat {} -> return $ unLoc p'+                                _         -> return $ ParPat noExt p' }+cvtp (TildeP p)        = do { p' <- cvtPat p; return $ LazyPat noExt p' }+cvtp (BangP p)         = do { p' <- cvtPat p; return $ BangPat noExt p' }+cvtp (TH.AsP s p)      = do { s' <- vNameL s; p' <- cvtPat p+                            ; return $ AsPat noExt s' p' }+cvtp TH.WildP          = return $ WildPat noExt+cvtp (RecP c fs)       = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs+                            ; return $ ConPatIn c'+                                     $ Hs.RecCon (HsRecFields fs' Nothing) }+cvtp (ListP ps)        = do { ps' <- cvtPats ps+                            ; return+                                   $ ListPat noExt ps'}+cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t+                            ; return $ SigPat noExt p' (mkLHsSigWcType t') }+cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p+                            ; return $ ViewPat noExt e' p'}++cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField GhcPs (LPat GhcPs))+cvtPatFld (s,p)+  = do  { (dL->L ls s') <- vNameL s+        ; p' <- cvtPat p+        ; return (noLoc $ HsRecField { hsRecFieldLbl+                                         = cL ls $ mkFieldOcc (cL ls s')+                                     , hsRecFieldArg = p'+                                     , hsRecPun      = False}) }++{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@.+The produced tree of infix patterns will be left-biased, provided @x@ is.++See the @cvtOpApp@ documentation for how this function works.+-}+cvtOpAppP :: Hs.LPat GhcPs -> TH.Name -> TH.Pat -> CvtM (Hs.Pat GhcPs)+cvtOpAppP x op1 (UInfixP y op2 z)+  = do { l <- wrapL $ cvtOpAppP x op1 y+       ; cvtOpAppP l op2 z }+cvtOpAppP x op y+  = do { op' <- cNameL op+       ; y' <- cvtPat y+       ; return (ConPatIn op' (InfixCon x y')) }++-----------------------------------------------------------+--      Types and type variables++cvtTvs :: [TH.TyVarBndr] -> CvtM (LHsQTyVars GhcPs)+cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }++cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr GhcPs)+cvt_tv (TH.PlainTV nm)+  = do { nm' <- tNameL nm+       ; returnL $ UserTyVar noExt nm' }+cvt_tv (TH.KindedTV nm ki)+  = do { nm' <- tNameL nm+       ; ki' <- cvtKind ki+       ; returnL $ KindedTyVar noExt nm' ki' }++cvtRole :: TH.Role -> Maybe Coercion.Role+cvtRole TH.NominalR          = Just Coercion.Nominal+cvtRole TH.RepresentationalR = Just Coercion.Representational+cvtRole TH.PhantomR          = Just Coercion.Phantom+cvtRole TH.InferR            = Nothing++cvtContext :: PprPrec -> TH.Cxt -> CvtM (LHsContext GhcPs)+cvtContext p tys = do { preds' <- mapM cvtPred tys+                      ; parenthesizeHsContext p <$> returnL preds' }++cvtPred :: TH.Pred -> CvtM (LHsType GhcPs)+cvtPred = cvtType++cvtDerivClause :: TH.DerivClause+               -> CvtM (LHsDerivingClause GhcPs)+cvtDerivClause (TH.DerivClause ds ctxt)+  = do { ctxt' <- fmap (map mkLHsSigType) <$> cvtContext appPrec ctxt+       ; ds'   <- traverse cvtDerivStrategy ds+       ; returnL $ HsDerivingClause noExt ds' ctxt' }++cvtDerivStrategy :: TH.DerivStrategy -> CvtM (Hs.LDerivStrategy GhcPs)+cvtDerivStrategy TH.StockStrategy    = returnL Hs.StockStrategy+cvtDerivStrategy TH.AnyclassStrategy = returnL Hs.AnyclassStrategy+cvtDerivStrategy TH.NewtypeStrategy  = returnL Hs.NewtypeStrategy+cvtDerivStrategy (TH.ViaStrategy ty) = do+  ty' <- cvtType ty+  returnL $ Hs.ViaStrategy (mkLHsSigType ty')++cvtType :: TH.Type -> CvtM (LHsType GhcPs)+cvtType = cvtTypeKind "type"++cvtTypeKind :: String -> TH.Type -> CvtM (LHsType GhcPs)+cvtTypeKind ty_str ty+  = do { (head_ty, tys') <- split_ty_app ty+       ; let m_normals = mapM extract_normal tys'+                                where extract_normal (HsValArg ty) = Just ty+                                      extract_normal _ = Nothing++       ; case head_ty of+           TupleT n+            | Just normals <- m_normals+            , normals `lengthIs` n         -- Saturated+               -> if n==1 then return (head normals) -- Singleton tuples treated+                                                     -- like nothing (ie just parens)+                          else returnL (HsTupleTy noExt+                                        HsBoxedOrConstraintTuple normals)+            | n == 1+               -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))+            | otherwise+            -> mk_apps+               (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Boxed n))))+               tys'+           UnboxedTupleT n+             | Just normals <- m_normals+             , normals `lengthIs` n               -- Saturated+             -> returnL (HsTupleTy noExt HsUnboxedTuple normals)+             | otherwise+             -> mk_apps+                (HsTyVar noExt NotPromoted (noLoc (getRdrName (tupleTyCon Unboxed n))))+                tys'+           UnboxedSumT n+             | n < 2+            -> failWith $+                   vcat [ text "Illegal sum arity:" <+> text (show n)+                        , nest 2 $+                            text "Sums must have an arity of at least 2" ]+             | Just normals <- m_normals+             , normals `lengthIs` n -- Saturated+             -> returnL (HsSumTy noExt normals)+             | otherwise+             -> mk_apps+                (HsTyVar noExt NotPromoted (noLoc (getRdrName (sumTyCon n))))+                tys'+           ArrowT+             | Just normals <- m_normals+             , [x',y'] <- normals -> do+                 x'' <- case unLoc x' of+                          HsFunTy{}    -> returnL (HsParTy noExt x')+                          HsForAllTy{} -> returnL (HsParTy noExt x') -- #14646+                          HsQualTy{}   -> returnL (HsParTy noExt x') -- #15324+                          _            -> return $+                                          parenthesizeHsType sigPrec x'+                 let y'' = parenthesizeHsType sigPrec y'+                 returnL (HsFunTy noExt x'' y'')+             | otherwise+             -> mk_apps+                (HsTyVar noExt NotPromoted (noLoc (getRdrName funTyCon)))+                tys'+           ListT+             | Just normals <- m_normals+             , [x'] <- normals -> do+                returnL (HsListTy noExt x')+             | otherwise+             -> mk_apps+                (HsTyVar noExt NotPromoted (noLoc (getRdrName listTyCon)))+                tys'++           VarT nm -> do { nm' <- tNameL nm+                         ; mk_apps (HsTyVar noExt NotPromoted nm') tys' }+           ConT nm -> do { nm' <- tconName nm+                         ; -- ConT can contain both data constructor (i.e.,+                           -- promoted) names and other (i.e, unpromoted)+                           -- names, as opposed to PromotedT, which can only+                           -- contain data constructor names. See #15572.+                           let prom = if isRdrDataCon nm'+                                      then IsPromoted+                                      else NotPromoted+                         ; mk_apps (HsTyVar noExt prom (noLoc nm')) tys'}++           ForallT tvs cxt ty+             | null tys'+             -> do { tvs' <- cvtTvs tvs+                   ; cxt' <- cvtContext funPrec cxt+                   ; ty'  <- cvtType ty+                   ; loc <- getL+                   ; let hs_ty  = mkHsForAllTy tvs loc ForallInvis tvs' rho_ty+                         rho_ty = mkHsQualTy cxt loc cxt' ty'++                   ; return hs_ty }++           ForallVisT tvs ty+             | null tys'+             -> do { tvs' <- cvtTvs tvs+                   ; ty'  <- cvtType ty+                   ; loc  <- getL+                   ; pure $ mkHsForAllTy tvs loc ForallVis tvs' ty' }++           SigT ty ki+             -> do { ty' <- cvtType ty+                   ; ki' <- cvtKind ki+                   ; mk_apps (HsKindSig noExt ty' ki') tys'+                   }++           LitT lit+             -> mk_apps (HsTyLit noExt (cvtTyLit lit)) tys'++           WildCardT+             -> mk_apps mkAnonWildCardTy tys'++           InfixT t1 s t2+             -> do { s'  <- tconName s+                   ; t1' <- cvtType t1+                   ; t2' <- cvtType t2+                   ; mk_apps+                      (HsTyVar noExt NotPromoted (noLoc s'))+                      ([HsValArg t1', HsValArg t2'] ++ tys')+                   }++           UInfixT t1 s t2+             -> do { t2' <- cvtType t2+                   ; t <- cvtOpAppT t1 s t2'+                   ; mk_apps (unLoc t) tys'+                   } -- Note [Converting UInfix]++           ParensT t+             -> do { t' <- cvtType t+                   ; mk_apps (HsParTy noExt t') tys'+                   }++           PromotedT nm -> do { nm' <- cName nm+                              ; mk_apps (HsTyVar noExt IsPromoted (noLoc nm'))+                                        tys' }+                 -- Promoted data constructor; hence cName++           PromotedTupleT n+              | n == 1+              -> failWith (ptext (sLit ("Illegal promoted 1-tuple " ++ ty_str)))+              | Just normals <- m_normals+              , normals `lengthIs` n   -- Saturated+              -> returnL (HsExplicitTupleTy noExt normals)+              | otherwise+              -> mk_apps+                 (HsTyVar noExt IsPromoted (noLoc (getRdrName (tupleDataCon Boxed n))))+                 tys'++           PromotedNilT+             -> mk_apps (HsExplicitListTy noExt IsPromoted []) tys'++           PromotedConsT  -- See Note [Representing concrete syntax in types]+                          -- in Language.Haskell.TH.Syntax+              | Just normals <- m_normals+              , [ty1, dL->L _ (HsExplicitListTy _ ip tys2)] <- normals+              -> do+                  returnL (HsExplicitListTy noExt ip (ty1:tys2))+              | otherwise+              -> mk_apps+                 (HsTyVar noExt IsPromoted (noLoc (getRdrName consDataCon)))+                 tys'++           StarT+             -> mk_apps+                (HsTyVar noExt NotPromoted (noLoc (getRdrName liftedTypeKindTyCon)))+                tys'++           ConstraintT+             -> mk_apps+                (HsTyVar noExt NotPromoted (noLoc (getRdrName constraintKindTyCon)))+                tys'++           EqualityT+             | Just normals <- m_normals+             , [x',y'] <- normals ->+                   let px = parenthesizeHsType opPrec x'+                       py = parenthesizeHsType opPrec y'+                   in returnL (HsOpTy noExt px (noLoc eqTyCon_RDR) py)+               -- The long-term goal is to remove the above case entirely and+               -- subsume it under the case for InfixT. See #15815, comment:6,+               -- for more details.++             | otherwise ->+                   mk_apps (HsTyVar noExt NotPromoted+                            (noLoc eqTyCon_RDR)) tys'+           ImplicitParamT n t+             -> do { n' <- wrapL $ ipName n+                   ; t' <- cvtType t+                   ; returnL (HsIParamTy noExt n' t')+                   }++           _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))+    }++-- | Constructs an application of a type to arguments passed in a list.+mk_apps :: HsType GhcPs -> [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)+mk_apps head_ty type_args = do+  head_ty' <- returnL head_ty+  -- We must parenthesize the function type in case of an explicit+  -- signature. For instance, in `(Maybe :: Type -> Type) Int`, there+  -- _must_ be parentheses around `Maybe :: Type -> Type`.+  let phead_ty :: LHsType GhcPs+      phead_ty = parenthesizeHsType sigPrec head_ty'++      go :: [LHsTypeArg GhcPs] -> CvtM (LHsType GhcPs)+      go [] = pure head_ty'+      go (arg:args) =+        case arg of+          HsValArg ty  -> do p_ty <- add_parens ty+                             mk_apps (HsAppTy noExt phead_ty p_ty) args+          HsTypeArg l ki -> do p_ki <- add_parens ki+                               mk_apps (HsAppKindTy l phead_ty p_ki) args+          HsArgPar _   -> mk_apps (HsParTy noExt phead_ty) args++  go type_args+   where+    -- See Note [Adding parens for splices]+    add_parens lt@(dL->L _ t)+      | hsTypeNeedsParens appPrec t = returnL (HsParTy noExt lt)+      | otherwise                   = return lt++wrap_tyarg :: LHsTypeArg GhcPs -> LHsTypeArg GhcPs+wrap_tyarg (HsValArg ty)    = HsValArg  $ parenthesizeHsType appPrec ty+wrap_tyarg (HsTypeArg l ki) = HsTypeArg l $ parenthesizeHsType appPrec ki+wrap_tyarg ta@(HsArgPar {}) = ta -- Already parenthesized++-- ---------------------------------------------------------------------+-- Note [Adding parens for splices]+{-+The hsSyn representation of parsed source explicitly contains all the original+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.++In the process, all parens are stripped out, as they are not needed.++This Convert module then converts the TH AST back to hsSyn AST.++In order to pretty-print this hsSyn AST, parens need to be adde back at certain+points so that the code is readable with its original meaning.++So scattered through Convert.hs are various points where parens are added.++See (among other closed issued) https://gitlab.haskell.org/ghc/ghc/issues/14289+-}+-- ---------------------------------------------------------------------++-- | Constructs an arrow type with a specified return type+mk_arr_apps :: [LHsType GhcPs] -> HsType GhcPs -> CvtM (LHsType GhcPs)+mk_arr_apps tys return_ty = foldrM go return_ty tys >>= returnL+    where go :: LHsType GhcPs -> HsType GhcPs -> CvtM (HsType GhcPs)+          go arg ret_ty = do { ret_ty_l <- returnL ret_ty+                             ; return (HsFunTy noExt arg ret_ty_l) }++split_ty_app :: TH.Type -> CvtM (TH.Type, [LHsTypeArg GhcPs])+split_ty_app ty = go ty []+  where+    go (AppT f a) as' = do { a' <- cvtType a; go f (HsValArg a':as') }+    go (AppKindT ty ki) as' = do { ki' <- cvtKind ki+                                 ; go ty (HsTypeArg noSrcSpan ki':as') }+    go (ParensT t) as' = do { loc <- getL; go t (HsArgPar loc: as') }+    go f as           = return (f,as)++cvtTyLit :: TH.TyLit -> HsTyLit+cvtTyLit (TH.NumTyLit i) = HsNumTy NoSourceText i+cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s)++{- | @cvtOpAppT x op y@ converts @op@ and @y@ and produces the operator+application @x `op` y@. The produced tree of infix types will be right-biased,+provided @y@ is.++See the @cvtOpApp@ documentation for how this function works.+-}+cvtOpAppT :: TH.Type -> TH.Name -> LHsType GhcPs -> CvtM (LHsType GhcPs)+cvtOpAppT (UInfixT x op2 y) op1 z+  = do { l <- cvtOpAppT y op1 z+       ; cvtOpAppT x op2 l }+cvtOpAppT x op y+  = do { op' <- tconNameL op+       ; x' <- cvtType x+       ; returnL (mkHsOpTy x' op' y) }++cvtKind :: TH.Kind -> CvtM (LHsKind GhcPs)+cvtKind = cvtTypeKind "kind"++-- | Convert Maybe Kind to a type family result signature. Used with data+-- families where naming of the result is not possible (thus only kind or no+-- signature is possible).+cvtMaybeKindToFamilyResultSig :: Maybe TH.Kind+                              -> CvtM (LFamilyResultSig GhcPs)+cvtMaybeKindToFamilyResultSig Nothing   = returnL (Hs.NoSig noExt)+cvtMaybeKindToFamilyResultSig (Just ki) = do { ki' <- cvtKind ki+                                             ; returnL (Hs.KindSig noExt ki') }++-- | Convert type family result signature. Used with both open and closed type+-- families.+cvtFamilyResultSig :: TH.FamilyResultSig -> CvtM (Hs.LFamilyResultSig GhcPs)+cvtFamilyResultSig TH.NoSig           = returnL (Hs.NoSig noExt)+cvtFamilyResultSig (TH.KindSig ki)    = do { ki' <- cvtKind ki+                                           ; returnL (Hs.KindSig noExt  ki') }+cvtFamilyResultSig (TH.TyVarSig bndr) = do { tv <- cvt_tv bndr+                                           ; returnL (Hs.TyVarSig noExt tv) }++-- | Convert injectivity annotation of a type family.+cvtInjectivityAnnotation :: TH.InjectivityAnn+                         -> CvtM (Hs.LInjectivityAnn GhcPs)+cvtInjectivityAnnotation (TH.InjectivityAnn annLHS annRHS)+  = do { annLHS' <- tNameL annLHS+       ; annRHS' <- mapM tNameL annRHS+       ; returnL (Hs.InjectivityAnn annLHS' annRHS') }++cvtPatSynSigTy :: TH.Type -> CvtM (LHsType GhcPs)+-- pattern synonym types are of peculiar shapes, which is why we treat+-- them separately from regular types;+-- see Note [Pattern synonym type signatures and Template Haskell]+cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))+  | null exis, null provs = cvtType (ForallT univs reqs ty)+  | null univs, null reqs = do { l   <- getL+                               ; ty' <- cvtType (ForallT exis provs ty)+                               ; return $ cL l (HsQualTy { hst_ctxt = cL l []+                                                         , hst_xqual = noExt+                                                         , hst_body = ty' }) }+  | null reqs             = do { l      <- getL+                               ; univs' <- hsQTvExplicit <$> cvtTvs univs+                               ; ty'    <- cvtType (ForallT exis provs ty)+                               ; let forTy = HsForAllTy+                                              { hst_fvf = ForallInvis+                                              , hst_bndrs = univs'+                                              , hst_xforall = noExt+                                              , hst_body = cL l cxtTy }+                                     cxtTy = HsQualTy { hst_ctxt = cL l []+                                                      , hst_xqual = noExt+                                                      , hst_body = ty' }+                               ; return $ cL l forTy }+  | otherwise             = cvtType (ForallT univs reqs (ForallT exis provs ty))+cvtPatSynSigTy ty         = cvtType ty++-----------------------------------------------------------+cvtFixity :: TH.Fixity -> Hs.Fixity+cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir)+   where+     cvt_dir TH.InfixL = Hs.InfixL+     cvt_dir TH.InfixR = Hs.InfixR+     cvt_dir TH.InfixN = Hs.InfixN++-----------------------------------------------------------+++-----------------------------------------------------------+-- some useful things++overloadedLit :: Lit -> Bool+-- True for literals that Haskell treats as overloaded+overloadedLit (IntegerL  _) = True+overloadedLit (RationalL _) = True+overloadedLit _             = False++-- Checks that are performed when converting unboxed sum expressions and+-- patterns alike.+unboxedSumChecks :: TH.SumAlt -> TH.SumArity -> CvtM ()+unboxedSumChecks alt arity+    | alt > arity+    = failWith $ text "Sum alternative"    <+> text (show alt)+             <+> text "exceeds its arity," <+> text (show arity)+    | alt <= 0+    = failWith $ vcat [ text "Illegal sum alternative:" <+> text (show alt)+                      , nest 2 $ text "Sum alternatives must start from 1" ]+    | arity < 2+    = failWith $ vcat [ text "Illegal sum arity:" <+> text (show arity)+                      , nest 2 $ text "Sums must have an arity of at least 2" ]+    | otherwise+    = return ()++-- | If passed an empty list of 'TH.TyVarBndr's, this simply returns the+-- third argument (an 'LHsType'). Otherwise, return an 'HsForAllTy'+-- using the provided 'LHsQTyVars' and 'LHsType'.+mkHsForAllTy :: [TH.TyVarBndr]+             -- ^ The original Template Haskell type variable binders+             -> SrcSpan+             -- ^ The location of the returned 'LHsType' if it needs an+             --   explicit forall+             -> ForallVisFlag+             -- ^ Whether this is @forall@ is visible (e.g., @forall a ->@)+             --   or invisible (e.g., @forall a.@)+             -> LHsQTyVars GhcPs+             -- ^ The converted type variable binders+             -> LHsType GhcPs+             -- ^ The converted rho type+             -> LHsType GhcPs+             -- ^ The complete type, quantified with a forall if necessary+mkHsForAllTy tvs loc fvf tvs' rho_ty+  | null tvs  = rho_ty+  | otherwise = cL loc $ HsForAllTy { hst_fvf = fvf+                                    , hst_bndrs = hsQTvExplicit tvs'+                                    , hst_xforall = noExt+                                    , hst_body = rho_ty }++-- | If passed an empty 'TH.Cxt', this simply returns the third argument+-- (an 'LHsType'). Otherwise, return an 'HsQualTy' using the provided+-- 'LHsContext' and 'LHsType'.++-- It's important that we don't build an HsQualTy if the context is empty,+-- as the pretty-printer for HsType _always_ prints contexts, even if+-- they're empty. See #13183.+mkHsQualTy :: TH.Cxt+           -- ^ The original Template Haskell context+           -> SrcSpan+           -- ^ The location of the returned 'LHsType' if it needs an+           --   explicit context+           -> LHsContext GhcPs+           -- ^ The converted context+           -> LHsType GhcPs+           -- ^ The converted tau type+           -> LHsType GhcPs+           -- ^ The complete type, qualified with a context if necessary+mkHsQualTy ctxt loc ctxt' ty+  | null ctxt = ty+  | otherwise = cL loc $ HsQualTy { hst_xqual = noExt+                                  , hst_ctxt  = ctxt'+                                  , hst_body  = ty }++--------------------------------------------------------------------+--      Turning Name back into RdrName+--------------------------------------------------------------------++-- variable names+vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)+vName,  cName,  vcName,  tName,  tconName  :: TH.Name -> CvtM RdrName++-- Variable names+vNameL n = wrapL (vName n)+vName n = cvtName OccName.varName n++-- Constructor function names; this is Haskell source, hence srcDataName+cNameL n = wrapL (cName n)+cName n = cvtName OccName.dataName n++-- Variable *or* constructor names; check by looking at the first char+vcNameL n = wrapL (vcName n)+vcName n = if isVarName n then vName n else cName n++-- Type variable names+tNameL n = wrapL (tName n)+tName n = cvtName OccName.tvName n++-- Type Constructor names+tconNameL n = wrapL (tconName n)+tconName n = cvtName OccName.tcClsName n++ipName :: String -> CvtM HsIPName+ipName n+  = do { unless (okVarOcc n) (failWith (badOcc OccName.varName n))+       ; return (HsIPName (fsLit n)) }++cvtName :: OccName.NameSpace -> TH.Name -> CvtM RdrName+cvtName ctxt_ns (TH.Name occ flavour)+  | not (okOcc ctxt_ns occ_str) = failWith (badOcc ctxt_ns occ_str)+  | otherwise+  = do { loc <- getL+       ; let rdr_name = thRdrName loc ctxt_ns occ_str flavour+       ; force rdr_name+       ; return rdr_name }+  where+    occ_str = TH.occString occ++okOcc :: OccName.NameSpace -> String -> Bool+okOcc ns str+  | OccName.isVarNameSpace ns     = okVarOcc str+  | OccName.isDataConNameSpace ns = okConOcc str+  | otherwise                     = okTcOcc  str++-- Determine the name space of a name in a type+--+isVarName :: TH.Name -> Bool+isVarName (TH.Name occ _)+  = case TH.occString occ of+      ""    -> False+      (c:_) -> startsVarId c || startsVarSym c++badOcc :: OccName.NameSpace -> String -> SDoc+badOcc ctxt_ns occ+  = text "Illegal" <+> pprNameSpace ctxt_ns+        <+> text "name:" <+> quotes (text occ)++thRdrName :: SrcSpan -> OccName.NameSpace -> String -> TH.NameFlavour -> RdrName+-- This turns a TH Name into a RdrName; used for both binders and occurrences+-- See Note [Binders in Template Haskell]+-- The passed-in name space tells what the context is expecting;+--      use it unless the TH name knows what name-space it comes+--      from, in which case use the latter+--+-- We pass in a SrcSpan (gotten from the monad) because this function+-- is used for *binders* and if we make an Exact Name we want it+-- to have a binding site inside it.  (cf #5434)+--+-- ToDo: we may generate silly RdrNames, by passing a name space+--       that doesn't match the string, like VarName ":+",+--       which will give confusing error messages later+--+-- The strict applications ensure that any buried exceptions get forced+thRdrName loc ctxt_ns th_occ th_name+  = case th_name of+     TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod+     TH.NameQ mod  -> (mkRdrQual  $! mk_mod mod) $! occ+     TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq (fromInteger uniq)) $! occ) loc)+     TH.NameU uniq -> nameRdrName $! (((Name.mkSystemNameAt $! mk_uniq (fromInteger uniq)) $! occ) loc)+     TH.NameS | Just name <- isBuiltInOcc_maybe occ -> nameRdrName $! name+              | otherwise                           -> mkRdrUnqual $! occ+              -- We check for built-in syntax here, because the TH+              -- user might have written a (NameS "(,,)"), for example+  where+    occ :: OccName.OccName+    occ = mk_occ ctxt_ns th_occ++-- Return an unqualified exact RdrName if we're dealing with built-in syntax.+-- See #13776.+thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName+thOrigRdrName occ th_ns pkg mod =+  let occ' = mk_occ (mk_ghc_ns th_ns) occ+  in case isBuiltInOcc_maybe occ' of+       Just name -> nameRdrName name+       Nothing   -> (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! occ'++thRdrNameGuesses :: TH.Name -> [RdrName]+thRdrNameGuesses (TH.Name occ flavour)+  -- This special case for NameG ensures that we don't generate duplicates in the output list+  | TH.NameG th_ns pkg mod <- flavour = [ thOrigRdrName occ_str th_ns pkg mod]+  | otherwise                         = [ thRdrName noSrcSpan gns occ_str flavour+                                        | gns <- guessed_nss]+  where+    -- guessed_ns are the name spaces guessed from looking at the TH name+    guessed_nss+      | isLexCon (mkFastString occ_str) = [OccName.tcName,  OccName.dataName]+      | otherwise                       = [OccName.varName, OccName.tvName]+    occ_str = TH.occString occ++-- The packing and unpacking is rather turgid :-(+mk_occ :: OccName.NameSpace -> String -> OccName.OccName+mk_occ ns occ = OccName.mkOccName ns occ++mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace+mk_ghc_ns TH.DataName  = OccName.dataName+mk_ghc_ns TH.TcClsName = OccName.tcClsName+mk_ghc_ns TH.VarName   = OccName.varName++mk_mod :: TH.ModName -> ModuleName+mk_mod mod = mkModuleName (TH.modString mod)++mk_pkg :: TH.PkgName -> UnitId+mk_pkg pkg = stringToUnitId (TH.pkgString pkg)++mk_uniq :: Int -> Unique+mk_uniq u = mkUniqueGrimily u++{-+Note [Binders in Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this TH term construction:+  do { x1 <- TH.newName "x"   -- newName :: String -> Q TH.Name+     ; x2 <- TH.newName "x"   -- Builds a NameU+     ; x3 <- TH.newName "x"++     ; let x = mkName "x"     -- mkName :: String -> TH.Name+                              -- Builds a NameS++     ; return (LamE (..pattern [x1,x2]..) $+               LamE (VarPat x3) $+               ..tuple (x1,x2,x3,x)) }++It represents the term   \[x1,x2]. \x3. (x1,x2,x3,x)++a) We don't want to complain about "x" being bound twice in+   the pattern [x1,x2]+b) We don't want x3 to shadow the x1,x2+c) We *do* want 'x' (dynamically bound with mkName) to bind+   to the innermost binding of "x", namely x3.+d) When pretty printing, we want to print a unique with x1,x2+   etc, else they'll all print as "x" which isn't very helpful++When we convert all this to HsSyn, the TH.Names are converted with+thRdrName.  To achieve (b) we want the binders to be Exact RdrNames.+Achieving (a) is a bit awkward, because+   - We must check for duplicate and shadowed names on Names,+     not RdrNames, *after* renaming.+     See Note [Collect binders only after renaming] in HsUtils++   - But to achieve (a) we must distinguish between the Exact+     RdrNames arising from TH and the Unqual RdrNames that would+     come from a user writing \[x,x] -> blah++So in Convert.thRdrName we translate+   TH Name                          RdrName+   --------------------------------------------------------+   NameU (arising from newName) --> Exact (Name{ System })+   NameS (arising from mkName)  --> Unqual++Notice that the NameUs generate *System* Names.  Then, when+figuring out shadowing and duplicates, we can filter out+System Names.++This use of System Names fits with other uses of System Names, eg for+temporary variables "a". Since there are lots of things called "a" we+usually want to print the name with the unique, and that is indeed+the way System Names are printed.++There's a small complication of course; see Note [Looking up Exact+RdrNames] in RnEnv.+-}++{-+Note [Pattern synonym type signatures and Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In general, the type signature of a pattern synonym++  pattern P x1 x2 .. xn = <some-pattern>++is of the form++   forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t++with the following parts:++   1) the (possibly empty lists of) universally quantified type+      variables `univs` and required constraints `reqs` on them.+   2) the (possibly empty lists of) existentially quantified type+      variables `exis` and the provided constraints `provs` on them.+   3) the types `t1`, `t2`, .., `tn` of the pattern synonym's arguments x1,+      x2, .., xn, respectively+   4) the type `t` of <some-pattern>, mentioning only universals from `univs`.++Due to the two forall quantifiers and constraint contexts (either of+which might be empty), pattern synonym type signatures are treated+specially in `deSugar/DsMeta.hs`, `hsSyn/Convert.hs`, and+`typecheck/TcSplice.hs`:++   (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.:++           ForallT univs reqs (ForallT exis provs ty)+              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)++   (b) When converting pattern synonyms from TH.Dec to HsSyn in+       `hsSyn/Convert.hs`, we convert their TH type signatures back to an+       appropriate Haskell pattern synonym type of the form++         forall univs. reqs => forall exis. provs => t1 -> t2 -> ... -> tn -> t++       where initial empty `univs` type variables or an empty `reqs`+       constraint context are represented *explicitly* as `() =>`.++   (c) When reifying a pattern synonym in `typecheck/TcSplice.hs`, we always+       return its *full* type, i.e.:++           ForallT univs reqs (ForallT exis provs ty)+              (where ty is the AST representation of t1 -> t2 -> ... -> tn -> t)++The key point is to always represent a pattern synonym's *full* type+in cases (a) and (c) to make it clear which of the two forall+quantifiers and/or constraint contexts are specified, and which are+not. See GHC's user's guide on pattern synonyms for more information+about pattern synonym type signatures.++-}
+ compiler/hsSyn/HsDumpAst.hs view
@@ -0,0 +1,220 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Contains a debug function to dump parts of the hsSyn AST. It uses a syb+-- traversal which falls back to displaying based on the constructor name, so+-- can be used to dump anything having a @Data.Data@ instance.++module HsDumpAst (+        -- * Dumping ASTs+        showAstData,+        BlankSrcSpan(..),+    ) where++import GhcPrelude++import Data.Data hiding (Fixity)+import Bag+import BasicTypes+import FastString+import NameSet+import Name+import DataCon+import SrcLoc+import HsSyn+import OccName hiding (occName)+import Var+import Module+import Outputable++import qualified Data.ByteString as B++data BlankSrcSpan = BlankSrcSpan | NoBlankSrcSpan+                  deriving (Eq,Show)++-- | Show a GHC syntax tree. This parameterised because it is also used for+-- comparing ASTs in ppr roundtripping tests, where the SrcSpan's are blanked+-- out, to avoid comparing locations, only structure+showAstData :: Data a => BlankSrcSpan -> a -> SDoc+showAstData b a0 = blankLine $$ showAstData' a0+  where+    showAstData' :: Data a => a -> SDoc+    showAstData' =+      generic+              `ext1Q` list+              `extQ` string `extQ` fastString `extQ` srcSpan+              `extQ` lit `extQ` litr `extQ` litt+              `extQ` bytestring+              `extQ` name `extQ` occName `extQ` moduleName `extQ` var+              `extQ` dataCon+              `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet+              `extQ` fixity+              `ext2Q` located++      where generic :: Data a => a -> SDoc+            generic t = parens $ text (showConstr (toConstr t))+                                  $$ vcat (gmapQ showAstData' t)++            string :: String -> SDoc+            string     = text . normalize_newlines . show++            fastString :: FastString -> SDoc+            fastString s = braces $+                            text "FastString: "+                         <> text (normalize_newlines . show $ s)++            bytestring :: B.ByteString -> SDoc+            bytestring = text . normalize_newlines . show++            list []    = brackets empty+            list [x]   = brackets (showAstData' x)+            list (x1 : x2 : xs) =  (text "[" <> showAstData' x1)+                                $$ go x2 xs+              where+                go y [] = text "," <> showAstData' y <> text "]"+                go y1 (y2 : ys) = (text "," <> showAstData' y1) $$ go y2 ys++            -- Eliminate word-size dependence+            lit :: HsLit GhcPs -> SDoc+            lit (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s+            lit (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s+            lit (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s+            lit (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s+            lit l                  = generic l++            litr :: HsLit GhcRn -> SDoc+            litr (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s+            litr (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s+            litr (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s+            litr (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s+            litr l                  = generic l++            litt :: HsLit GhcTc -> SDoc+            litt (HsWordPrim   s x) = numericLit "HsWord{64}Prim" x s+            litt (HsWord64Prim s x) = numericLit "HsWord{64}Prim" x s+            litt (HsIntPrim    s x) = numericLit "HsInt{64}Prim"  x s+            litt (HsInt64Prim  s x) = numericLit "HsInt{64}Prim"  x s+            litt l                  = generic l++            numericLit :: String -> Integer -> SourceText -> SDoc+            numericLit tag x s = braces $ hsep [ text tag+                                               , generic x+                                               , generic s ]++            name :: Name -> SDoc+            name nm    = braces $ text "Name: " <> ppr nm++            occName n  =  braces $+                          text "OccName: "+                       <> text (OccName.occNameString n)++            moduleName :: ModuleName -> SDoc+            moduleName m = braces $ text "ModuleName: " <> ppr m++            srcSpan :: SrcSpan -> SDoc+            srcSpan ss = case b of+             BlankSrcSpan -> text "{ ss }"+             NoBlankSrcSpan -> braces $ char ' ' <>+                             (hang (ppr ss) 1+                                   -- TODO: show annotations here+                                   (text ""))++            var  :: Var -> SDoc+            var v      = braces $ text "Var: " <> ppr v++            dataCon :: DataCon -> SDoc+            dataCon c  = braces $ text "DataCon: " <> ppr c++            bagRdrName:: Bag (Located (HsBind GhcPs)) -> SDoc+            bagRdrName bg =  braces $+                             text "Bag(Located (HsBind GhcPs)):"+                          $$ (list . bagToList $ bg)++            bagName   :: Bag (Located (HsBind GhcRn)) -> SDoc+            bagName bg  =  braces $+                           text "Bag(Located (HsBind Name)):"+                        $$ (list . bagToList $ bg)++            bagVar    :: Bag (Located (HsBind GhcTc)) -> SDoc+            bagVar bg  =  braces $+                          text "Bag(Located (HsBind Var)):"+                       $$ (list . bagToList $ bg)++            nameSet ns =  braces $+                          text "NameSet:"+                       $$ (list . nameSetElemsStable $ ns)++            fixity :: Fixity -> SDoc+            fixity fx =  braces $+                         text "Fixity: "+                      <> ppr fx++            located :: (Data b,Data loc) => GenLocated loc b -> SDoc+            located (L ss a) = parens $+                   case cast ss of+                        Just (s :: SrcSpan) ->+                          srcSpan s+                        Nothing -> text "nnnnnnnn"+                      $$ showAstData' a++normalize_newlines :: String -> String+normalize_newlines ('\\':'r':'\\':'n':xs) = '\\':'n':normalize_newlines xs+normalize_newlines (x:xs)                 = x:normalize_newlines xs+normalize_newlines []                     = []++{-+************************************************************************+*                                                                      *+* Copied from syb+*                                                                      *+************************************************************************+-}+++-- | The type constructor for queries+newtype Q q x = Q { unQ :: x -> q }++-- | Extend a generic query by a type-specific case+extQ :: ( Typeable a+        , Typeable b+        )+     => (a -> q)+     -> (b -> q)+     -> a+     -> q+extQ f g a = maybe (f a) g (cast a)++-- | Type extension of queries for type constructors+ext1Q :: (Data d, Typeable t)+      => (d -> q)+      -> (forall e. Data e => t e -> q)+      -> d -> q+ext1Q def ext = unQ ((Q def) `ext1` (Q ext))+++-- | Type extension of queries for type constructors+ext2Q :: (Data d, Typeable t)+      => (d -> q)+      -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)+      -> d -> q+ext2Q def ext = unQ ((Q def) `ext2` (Q ext))++-- | Flexible type extension+ext1 :: (Data a, Typeable t)+     => c a+     -> (forall d. Data d => c (t d))+     -> c a+ext1 def ext = maybe def id (dataCast1 ext)++++-- | Flexible type extension+ext2 :: (Data a, Typeable t)+     => c a+     -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))+     -> c a+ext2 def ext = maybe def id (dataCast2 ext)
+ compiler/iface/BinIface.hs view
@@ -0,0 +1,425 @@+{-# LANGUAGE BinaryLiterals, CPP, ScopedTypeVariables, BangPatterns #-}++--+--  (c) The University of Glasgow 2002-2006+--++{-# OPTIONS_GHC -O2 #-}+-- We always optimise this, otherwise performance of a non-optimised+-- compiler is severely affected++-- | Binary interface file support.+module BinIface (+        writeBinIface,+        readBinIface,+        getSymtabName,+        getDictFastString,+        CheckHiWay(..),+        TraceBinIFaceReading(..),+        getWithUserData,+        putWithUserData++    ) where++#include "HsVersions.h"++import GhcPrelude++import TcRnMonad+import PrelInfo   ( isKnownKeyName, lookupKnownKeyName )+import IfaceEnv+import HscTypes+import Module+import Name+import DynFlags+import UniqFM+import UniqSupply+import Panic+import Binary+import SrcLoc+import ErrUtils+import FastMutInt+import Unique+import Outputable+import NameCache+import Platform+import FastString+import Constants+import Util++import Data.Array+import Data.Array.ST+import Data.Array.Unsafe+import Data.Bits+import Data.Char+import Data.Word+import Data.IORef+import Data.Foldable+import Control.Monad+import Control.Monad.ST+import Control.Monad.Trans.Class+import qualified Control.Monad.Trans.State.Strict as State++-- ---------------------------------------------------------------------------+-- Reading and writing binary interface files+--++data CheckHiWay = CheckHiWay | IgnoreHiWay+    deriving Eq++data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading+    deriving Eq++-- | Read an interface file+readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath+             -> TcRnIf a b ModIface+readBinIface checkHiWay traceBinIFaceReading hi_path = do+    ncu <- mkNameCacheUpdater+    dflags <- getDynFlags+    liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu++readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath+              -> NameCacheUpdater+              -> IO ModIface+readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do+    let printer :: SDoc -> IO ()+        printer = case traceBinIFaceReading of+                      TraceBinIFaceReading -> \sd ->+                          putLogMsg dflags+                                    NoReason+                                    SevOutput+                                    noSrcSpan+                                    (defaultDumpStyle dflags)+                                    sd+                      QuietBinIFaceReading -> \_ -> return ()++        wantedGot :: String -> a -> a -> (a -> SDoc) -> IO ()+        wantedGot what wanted got ppr' =+            printer (text what <> text ": " <>+                     vcat [text "Wanted " <> ppr' wanted <> text ",",+                           text "got    " <> ppr' got])++        errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()+        errorOnMismatch what wanted got =+            -- This will be caught by readIface which will emit an error+            -- msg containing the iface module name.+            when (wanted /= got) $ throwGhcExceptionIO $ ProgramError+                         (what ++ " (wanted " ++ show wanted+                               ++ ", got "    ++ show got ++ ")")+    bh <- Binary.readBinMem hi_path++    -- Read the magic number to check that this really is a GHC .hi file+    -- (This magic number does not change when we change+    --  GHC interface file format)+    magic <- get bh+    wantedGot "Magic" (binaryInterfaceMagic dflags) magic ppr+    errorOnMismatch "magic number mismatch: old/corrupt interface file?"+        (binaryInterfaceMagic dflags) magic++    -- Note [dummy iface field]+    -- read a dummy 32/64 bit value.  This field used to hold the+    -- dictionary pointer in old interface file formats, but now+    -- the dictionary pointer is after the version (where it+    -- should be).  Also, the serialisation of value of type "Bin+    -- a" used to depend on the word size of the machine, now they+    -- are always 32 bits.+    if wORD_SIZE dflags == 4+        then do _ <- Binary.get bh :: IO Word32; return ()+        else do _ <- Binary.get bh :: IO Word64; return ()++    -- Check the interface file version and ways.+    check_ver  <- get bh+    let our_ver = show hiVersion+    wantedGot "Version" our_ver check_ver text+    errorOnMismatch "mismatched interface file versions" our_ver check_ver++    check_way <- get bh+    let way_descr = getWayDescr dflags+    wantedGot "Way" way_descr check_way ppr+    when (checkHiWay == CheckHiWay) $+        errorOnMismatch "mismatched interface file ways" way_descr check_way+    getWithUserData ncu bh+++-- | This performs a get action after reading the dictionary and symbol+-- table. It is necessary to run this before trying to deserialise any+-- Names or FastStrings.+getWithUserData :: Binary a => NameCacheUpdater -> BinHandle -> IO a+getWithUserData ncu bh = do+    -- Read the dictionary+    -- The next word in the file is a pointer to where the dictionary is+    -- (probably at the end of the file)+    dict_p <- Binary.get bh+    data_p <- tellBin bh          -- Remember where we are now+    seekBin bh dict_p+    dict   <- getDictionary bh+    seekBin bh data_p             -- Back to where we were before++    -- Initialise the user-data field of bh+    bh <- do+        bh <- return $ setUserData bh $ newReadState (error "getSymtabName")+                                                     (getDictFastString dict)+        symtab_p <- Binary.get bh     -- Get the symtab ptr+        data_p <- tellBin bh          -- Remember where we are now+        seekBin bh symtab_p+        symtab <- getSymbolTable bh ncu+        seekBin bh data_p             -- Back to where we were before++        -- It is only now that we know how to get a Name+        return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)+                                               (getDictFastString dict)++    -- Read the interface file+    get bh++-- | Write an interface file+writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()+writeBinIface dflags hi_path mod_iface = do+    bh <- openBinMem initBinMemSize+    put_ bh (binaryInterfaceMagic dflags)++   -- dummy 32/64-bit field before the version/way for+   -- compatibility with older interface file formats.+   -- See Note [dummy iface field] above.+    if wORD_SIZE dflags == 4+        then Binary.put_ bh (0 :: Word32)+        else Binary.put_ bh (0 :: Word64)++    -- The version and way descriptor go next+    put_ bh (show hiVersion)+    let way_descr = getWayDescr dflags+    put_  bh way_descr+++    putWithUserData (debugTraceMsg dflags 3) bh mod_iface+    -- And send the result to the file+    writeBinMem bh hi_path++-- | Put a piece of data with an initialised `UserData` field. This+-- is necessary if you want to serialise Names or FastStrings.+-- It also writes a symbol table and the dictionary.+-- This segment should be read using `getWithUserData`.+putWithUserData :: Binary a => (SDoc -> IO ()) -> BinHandle -> a -> IO ()+putWithUserData log_action bh payload = do+    -- Remember where the dictionary pointer will go+    dict_p_p <- tellBin bh+    -- Placeholder for ptr to dictionary+    put_ bh dict_p_p++    -- Remember where the symbol table pointer will go+    symtab_p_p <- tellBin bh+    put_ bh symtab_p_p+    -- Make some initial state+    symtab_next <- newFastMutInt+    writeFastMutInt symtab_next 0+    symtab_map <- newIORef emptyUFM+    let bin_symtab = BinSymbolTable {+                         bin_symtab_next = symtab_next,+                         bin_symtab_map  = symtab_map }+    dict_next_ref <- newFastMutInt+    writeFastMutInt dict_next_ref 0+    dict_map_ref <- newIORef emptyUFM+    let bin_dict = BinDictionary {+                       bin_dict_next = dict_next_ref,+                       bin_dict_map  = dict_map_ref }++    -- Put the main thing,+    bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)+                                                  (putName bin_dict bin_symtab)+                                                  (putFastString bin_dict)+    put_ bh payload++    -- Write the symtab pointer at the front of the file+    symtab_p <- tellBin bh        -- This is where the symtab will start+    putAt bh symtab_p_p symtab_p  -- Fill in the placeholder+    seekBin bh symtab_p           -- Seek back to the end of the file++    -- Write the symbol table itself+    symtab_next <- readFastMutInt symtab_next+    symtab_map  <- readIORef symtab_map+    putSymbolTable bh symtab_next symtab_map+    log_action (text "writeBinIface:" <+> int symtab_next+                                <+> text "Names")++    -- NB. write the dictionary after the symbol table, because+    -- writing the symbol table may create more dictionary entries.++    -- Write the dictionary pointer at the front of the file+    dict_p <- tellBin bh          -- This is where the dictionary will start+    putAt bh dict_p_p dict_p      -- Fill in the placeholder+    seekBin bh dict_p             -- Seek back to the end of the file++    -- Write the dictionary itself+    dict_next <- readFastMutInt dict_next_ref+    dict_map  <- readIORef dict_map_ref+    putDictionary bh dict_next dict_map+    log_action (text "writeBinIface:" <+> int dict_next+                                <+> text "dict entries")++++-- | Initial ram buffer to allocate for writing interface files+initBinMemSize :: Int+initBinMemSize = 1024 * 1024++binaryInterfaceMagic :: DynFlags -> Word32+binaryInterfaceMagic dflags+ | target32Bit (targetPlatform dflags) = 0x1face+ | otherwise                           = 0x1face64+++-- -----------------------------------------------------------------------------+-- The symbol table+--++putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()+putSymbolTable bh next_off symtab = do+    put_ bh next_off+    let names = elems (array (0,next_off-1) (nonDetEltsUFM symtab))+      -- It's OK to use nonDetEltsUFM here because the elements have+      -- indices that array uses to create order+    mapM_ (\n -> serialiseName bh n symtab) names++getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable+getSymbolTable bh ncu = do+    sz <- get bh+    od_names <- sequence (replicate sz (get bh))+    updateNameCache ncu $ \namecache ->+        runST $ flip State.evalStateT namecache $ do+            mut_arr <- lift $ newSTArray_ (0, sz-1)+            for_ (zip [0..] od_names) $ \(i, odn) -> do+                (nc, !n) <- State.gets $ \nc -> fromOnDiskName nc odn+                lift $ writeArray mut_arr i n+                State.put nc+            arr <- lift $ unsafeFreeze mut_arr+            namecache' <- State.get+            return (namecache', arr)+  where+    -- This binding is required because the type of newArray_ cannot be inferred+    newSTArray_ :: forall s. (Int, Int) -> ST s (STArray s Int Name)+    newSTArray_ = newArray_++type OnDiskName = (UnitId, ModuleName, OccName)++fromOnDiskName :: NameCache -> OnDiskName -> (NameCache, Name)+fromOnDiskName nc (pid, mod_name, occ) =+    let mod   = mkModule pid mod_name+        cache = nsNames nc+    in case lookupOrigNameCache cache  mod occ of+           Just name -> (nc, name)+           Nothing   ->+               let (uniq, us) = takeUniqFromSupply (nsUniqs nc)+                   name       = mkExternalName uniq mod occ noSrcSpan+                   new_cache  = extendNameCache cache mod occ name+               in ( nc{ nsUniqs = us, nsNames = new_cache }, name )++serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()+serialiseName bh name _ = do+    let mod = ASSERT2( isExternalName name, ppr name ) nameModule name+    put_ bh (moduleUnitId mod, moduleName mod, nameOccName name)+++-- Note [Symbol table representation of names]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- An occurrence of a name in an interface file is serialized as a single 32-bit+-- word. The format of this word is:+--  00xxxxxx xxxxxxxx xxxxxxxx xxxxxxxx+--   A normal name. x is an index into the symbol table+--  10xxxxxx xxyyyyyy yyyyyyyy yyyyyyyy+--   A known-key name. x is the Unique's Char, y is the int part. We assume that+--   all known-key uniques fit in this space. This is asserted by+--   PrelInfo.knownKeyNamesOkay.+--+-- During serialization we check for known-key things using isKnownKeyName.+-- During deserialization we use lookupKnownKeyName to get from the unique back+-- to its corresponding Name.+++-- See Note [Symbol table representation of names]+putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()+putName _dict BinSymbolTable{+               bin_symtab_map = symtab_map_ref,+               bin_symtab_next = symtab_next }+        bh name+  | isKnownKeyName name+  , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits+  = -- ASSERT(u < 2^(22 :: Int))+    put_ bh (0x80000000+             .|. (fromIntegral (ord c) `shiftL` 22)+             .|. (fromIntegral u :: Word32))++  | otherwise+  = do symtab_map <- readIORef symtab_map_ref+       case lookupUFM symtab_map name of+         Just (off,_) -> put_ bh (fromIntegral off :: Word32)+         Nothing -> do+            off <- readFastMutInt symtab_next+            -- MASSERT(off < 2^(30 :: Int))+            writeFastMutInt symtab_next (off+1)+            writeIORef symtab_map_ref+                $! addToUFM symtab_map name (off,name)+            put_ bh (fromIntegral off :: Word32)++-- See Note [Symbol table representation of names]+getSymtabName :: NameCacheUpdater+              -> Dictionary -> SymbolTable+              -> BinHandle -> IO Name+getSymtabName _ncu _dict symtab bh = do+    i :: Word32 <- get bh+    case i .&. 0xC0000000 of+      0x00000000 -> return $! symtab ! fromIntegral i++      0x80000000 ->+        let+          tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))+          ix  = fromIntegral i .&. 0x003FFFFF+          u   = mkUnique tag ix+        in+          return $! case lookupKnownKeyName u of+                      Nothing -> pprPanic "getSymtabName:unknown known-key unique"+                                          (ppr i $$ ppr (unpkUnique u))+                      Just n  -> n++      _ -> pprPanic "getSymtabName:unknown name tag" (ppr i)++data BinSymbolTable = BinSymbolTable {+        bin_symtab_next :: !FastMutInt, -- The next index to use+        bin_symtab_map  :: !(IORef (UniqFM (Int,Name)))+                                -- indexed by Name+  }++putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()+putFastString dict bh fs = allocateFastString dict fs >>= put_ bh++allocateFastString :: BinDictionary -> FastString -> IO Word32+allocateFastString BinDictionary { bin_dict_next = j_r,+                                   bin_dict_map  = out_r} f = do+    out <- readIORef out_r+    let uniq = getUnique f+    case lookupUFM out uniq of+        Just (j, _)  -> return (fromIntegral j :: Word32)+        Nothing -> do+           j <- readFastMutInt j_r+           writeFastMutInt j_r (j + 1)+           writeIORef out_r $! addToUFM out uniq (j, f)+           return (fromIntegral j :: Word32)++getDictFastString :: Dictionary -> BinHandle -> IO FastString+getDictFastString dict bh = do+    j <- get bh+    return $! (dict ! fromIntegral (j :: Word32))++data BinDictionary = BinDictionary {+        bin_dict_next :: !FastMutInt, -- The next index to use+        bin_dict_map  :: !(IORef (UniqFM (Int,FastString)))+                                -- indexed by FastString+  }++getWayDescr :: DynFlags -> String+getWayDescr dflags+  | platformUnregisterised (targetPlatform dflags) = 'u':tag+  | otherwise                                      =     tag+  where tag = buildTag dflags+        -- if this is an unregisterised build, make sure our interfaces+        -- can't be used by a registerised build.
+ compiler/iface/BuildTyCl.hs view
@@ -0,0 +1,414 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE CPP #-}++module BuildTyCl (+        buildDataCon,+        buildPatSyn,+        TcMethInfo, MethInfo, buildClass,+        mkNewTyConRhs,+        newImplicitBinder, newTyConRepName+    ) where++#include "HsVersions.h"++import GhcPrelude++import IfaceEnv+import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )+import TysWiredIn( isCTupleTyConName )+import TysPrim ( voidPrimTy )+import DataCon+import PatSyn+import Var+import VarSet+import BasicTypes+import Name+import NameEnv+import MkId+import Class+import TyCon+import Type+import Id+import TcType++import SrcLoc( SrcSpan, noSrcSpan )+import DynFlags+import TcRnMonad+import UniqSupply+import Util+import Outputable+++mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs+-- ^ Monadic because it makes a Name for the coercion TyCon+--   We pass the Name of the parent TyCon, as well as the TyCon itself,+--   because the latter is part of a knot, whereas the former is not.+mkNewTyConRhs tycon_name tycon con+  = do  { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc+        ; let nt_ax = mkNewTypeCoAxiom co_tycon_name tycon etad_tvs etad_roles etad_rhs+        ; traceIf (text "mkNewTyConRhs" <+> ppr nt_ax)+        ; return (NewTyCon { data_con    = con,+                             nt_rhs      = rhs_ty,+                             nt_etad_rhs = (etad_tvs, etad_rhs),+                             nt_co       = nt_ax } ) }+                             -- Coreview looks through newtypes with a Nothing+                             -- for nt_co, or uses explicit coercions otherwise+  where+    tvs    = tyConTyVars tycon+    roles  = tyConRoles tycon+    con_arg_ty = case dataConRepArgTys con of+                   [arg_ty] -> arg_ty+                   tys -> pprPanic "mkNewTyConRhs" (ppr con <+> ppr tys)+    rhs_ty = substTyWith (dataConUnivTyVars con)+                         (mkTyVarTys tvs) con_arg_ty+        -- Instantiate the newtype's RHS with the+        -- type variables from the tycon+        -- NB: a newtype DataCon has a type that must look like+        --        forall tvs.  <arg-ty> -> T tvs+        -- Note that we *can't* use dataConInstOrigArgTys here because+        -- the newtype arising from   class Foo a => Bar a where {}+        -- has a single argument (Foo a) that is a *type class*, so+        -- dataConInstOrigArgTys returns [].++    etad_tvs   :: [TyVar]  -- Matched lazily, so that mkNewTypeCo can+    etad_roles :: [Role]   -- return a TyCon without pulling on rhs_ty+    etad_rhs   :: Type     -- See Note [Tricky iface loop] in LoadIface+    (etad_tvs, etad_roles, etad_rhs) = eta_reduce (reverse tvs) (reverse roles) rhs_ty++    eta_reduce :: [TyVar]       -- Reversed+               -> [Role]        -- also reversed+               -> Type          -- Rhs type+               -> ([TyVar], [Role], Type)  -- Eta-reduced version+                                           -- (tyvars in normal order)+    eta_reduce (a:as) (_:rs) ty | Just (fun, arg) <- splitAppTy_maybe ty,+                                  Just tv <- getTyVar_maybe arg,+                                  tv == a,+                                  not (a `elemVarSet` tyCoVarsOfType fun)+                                = eta_reduce as rs fun+    eta_reduce tvs rs ty = (reverse tvs, reverse rs, ty)++------------------------------------------------------+buildDataCon :: FamInstEnvs+            -> Name+            -> Bool                     -- Declared infix+            -> TyConRepName+            -> [HsSrcBang]+            -> Maybe [HsImplBang]+                -- See Note [Bangs on imported data constructors] in MkId+           -> [FieldLabel]             -- Field labels+           -> [TyVar]                  -- Universals+           -> [TyCoVar]                -- Existentials+           -> [TyVarBinder]            -- User-written 'TyVarBinder's+           -> [EqSpec]                 -- Equality spec+           -> KnotTied ThetaType       -- Does not include the "stupid theta"+                                       -- or the GADT equalities+           -> [KnotTied Type]          -- Arguments+           -> KnotTied Type            -- Result types+           -> KnotTied TyCon           -- Rep tycon+           -> NameEnv ConTag           -- Maps the Name of each DataCon to its+                                       -- ConTag+           -> TcRnIf m n DataCon+-- A wrapper for DataCon.mkDataCon that+--   a) makes the worker Id+--   b) makes the wrapper Id if necessary, including+--      allocating its unique (hence monadic)+buildDataCon fam_envs src_name declared_infix prom_info src_bangs impl_bangs+             field_lbls univ_tvs ex_tvs user_tvbs eq_spec ctxt arg_tys res_ty+             rep_tycon tag_map+  = do  { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc+        ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc+        -- This last one takes the name of the data constructor in the source+        -- code, which (for Haskell source anyway) will be in the DataName name+        -- space, and puts it into the VarName name space++        ; traceIf (text "buildDataCon 1" <+> ppr src_name)+        ; us <- newUniqueSupply+        ; dflags <- getDynFlags+        ; let stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs+              tag = lookupNameEnv_NF tag_map src_name+              -- See Note [Constructor tag allocation], fixes #14657+              data_con = mkDataCon src_name declared_infix prom_info+                                   src_bangs field_lbls+                                   univ_tvs ex_tvs user_tvbs eq_spec ctxt+                                   arg_tys res_ty NoRRI rep_tycon tag+                                   stupid_ctxt dc_wrk dc_rep+              dc_wrk = mkDataConWorkId work_name data_con+              dc_rep = initUs_ us (mkDataConRep dflags fam_envs wrap_name+                                                impl_bangs data_con)++        ; traceIf (text "buildDataCon 2" <+> ppr src_name)+        ; return data_con }+++-- The stupid context for a data constructor should be limited to+-- the type variables mentioned in the arg_tys+-- ToDo: Or functionally dependent on?+--       This whole stupid theta thing is, well, stupid.+mkDataConStupidTheta :: TyCon -> [Type] -> [TyVar] -> [PredType]+mkDataConStupidTheta tycon arg_tys univ_tvs+  | null stupid_theta = []      -- The common case+  | otherwise         = filter in_arg_tys stupid_theta+  where+    tc_subst     = zipTvSubst (tyConTyVars tycon)+                              (mkTyVarTys univ_tvs)+    stupid_theta = substTheta tc_subst (tyConStupidTheta tycon)+        -- Start by instantiating the master copy of the+        -- stupid theta, taken from the TyCon++    arg_tyvars      = tyCoVarsOfTypes arg_tys+    in_arg_tys pred = not $ isEmptyVarSet $+                      tyCoVarsOfType pred `intersectVarSet` arg_tyvars+++------------------------------------------------------+buildPatSyn :: Name -> Bool+            -> (Id,Bool) -> Maybe (Id, Bool)+            -> ([TyVarBinder], ThetaType) -- ^ Univ and req+            -> ([TyVarBinder], ThetaType) -- ^ Ex and prov+            -> [Type]               -- ^ Argument types+            -> Type                 -- ^ Result type+            -> [FieldLabel]         -- ^ Field labels for+                                    --   a record pattern synonym+            -> PatSyn+buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder+            (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys+            pat_ty field_labels+  = -- The assertion checks that the matcher is+    -- compatible with the pattern synonym+    ASSERT2((and [ univ_tvs `equalLength` univ_tvs1+                 , ex_tvs `equalLength` ex_tvs1+                 , pat_ty `eqType` substTy subst pat_ty1+                 , prov_theta `eqTypes` substTys subst prov_theta1+                 , req_theta `eqTypes` substTys subst req_theta1+                 , compareArgTys arg_tys (substTys subst arg_tys1)+                 ])+            , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1+                    , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1+                    , ppr pat_ty <+> twiddle <+> ppr pat_ty1+                    , ppr prov_theta <+> twiddle <+> ppr prov_theta1+                    , ppr req_theta <+> twiddle <+> ppr req_theta1+                    , ppr arg_tys <+> twiddle <+> ppr arg_tys1]))+    mkPatSyn src_name declared_infix+             (univ_tvs, req_theta) (ex_tvs, prov_theta)+             arg_tys pat_ty+             matcher builder field_labels+  where+    ((_:_:univ_tvs1), req_theta1, tau) = tcSplitSigmaTy $ idType matcher_id+    ([pat_ty1, cont_sigma, _], _)      = tcSplitFunTys tau+    (ex_tvs1, prov_theta1, cont_tau)   = tcSplitSigmaTy cont_sigma+    (arg_tys1, _) = (tcSplitFunTys cont_tau)+    twiddle = char '~'+    subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)+                       (mkTyVarTys (binderVars (univ_tvs ++ ex_tvs)))++    -- For a nullary pattern synonym we add a single void argument to the+    -- matcher to preserve laziness in the case of unlifted types.+    -- See #12746+    compareArgTys :: [Type] -> [Type] -> Bool+    compareArgTys [] [x] = x `eqType` voidPrimTy+    compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys+++------------------------------------------------------+type TcMethInfo = MethInfo  -- this variant needs zonking+type MethInfo       -- A temporary intermediate, to communicate+                    -- between tcClassSigs and buildClass.+  = ( Name   -- Name of the class op+    , Type   -- Type of the class op+    , Maybe (DefMethSpec (SrcSpan, Type)))+         -- Nothing                    => no default method+         --+         -- Just VanillaDM             => There is an ordinary+         --                               polymorphic default method+         --+         -- Just (GenericDM (loc, ty)) => There is a generic default metho+         --                               Here is its type, and the location+         --                               of the type signature+         --    We need that location /only/ to attach it to the+         --    generic default method's Name; and we need /that/+         --    only to give the right location of an ambiguity error+         --    for the generic default method, spat out by checkValidClass++buildClass :: Name  -- Name of the class/tycon (they have the same Name)+           -> [TyConBinder]                -- Of the tycon+           -> [Role]+           -> [FunDep TyVar]               -- Functional dependencies+           -- Super classes, associated types, method info, minimal complete def.+           -- This is Nothing if the class is abstract.+           -> Maybe (KnotTied ThetaType, [ClassATItem], [KnotTied MethInfo], ClassMinimalDef)+           -> TcRnIf m n Class++buildClass tycon_name binders roles fds Nothing+  = fixM  $ \ rec_clas ->       -- Only name generation inside loop+    do  { traceIf (text "buildClass")++        ; tc_rep_name  <- newTyConRepName tycon_name+        ; let univ_tvs = binderVars binders+              tycon = mkClassTyCon tycon_name binders roles+                                   AbstractTyCon rec_clas tc_rep_name+              result = mkAbstractClass tycon_name univ_tvs fds tycon+        ; traceIf (text "buildClass" <+> ppr tycon)+        ; return result }++buildClass tycon_name binders roles fds+           (Just (sc_theta, at_items, sig_stuff, mindef))+  = fixM  $ \ rec_clas ->       -- Only name generation inside loop+    do  { traceIf (text "buildClass")++        ; datacon_name <- newImplicitBinder tycon_name mkClassDataConOcc+        ; tc_rep_name  <- newTyConRepName tycon_name++        ; op_items <- mapM (mk_op_item rec_clas) sig_stuff+                        -- Build the selector id and default method id++              -- Make selectors for the superclasses+        ; sc_sel_names <- mapM  (newImplicitBinder tycon_name . mkSuperDictSelOcc)+                                (takeList sc_theta [fIRST_TAG..])+        ; let sc_sel_ids = [ mkDictSelId sc_name rec_clas+                           | sc_name <- sc_sel_names]+              -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we+              -- can construct names for the selectors. Thus+              --      class (C a, C b) => D a b where ...+              -- gives superclass selectors+              --      D_sc1, D_sc2+              -- (We used to call them D_C, but now we can have two different+              --  superclasses both called C!)++        ; let use_newtype = isSingleton arg_tys+                -- Use a newtype if the data constructor+                --   (a) has exactly one value field+                --       i.e. exactly one operation or superclass taken together+                --   (b) that value is of lifted type (which they always are, because+                --       we box equality superclasses)+                -- See note [Class newtypes and equality predicates]++                -- We treat the dictionary superclasses as ordinary arguments.+                -- That means that in the case of+                --     class C a => D a+                -- we don't get a newtype with no arguments!+              args       = sc_sel_names ++ op_names+              op_tys     = [ty | (_,ty,_) <- sig_stuff]+              op_names   = [op | (op,_,_) <- sig_stuff]+              arg_tys    = sc_theta ++ op_tys+              rec_tycon  = classTyCon rec_clas+              univ_bndrs = tyConTyVarBinders binders+              univ_tvs   = binderVars univ_bndrs++        ; rep_nm   <- newTyConRepName datacon_name+        ; dict_con <- buildDataCon (panic "buildClass: FamInstEnvs")+                                   datacon_name+                                   False        -- Not declared infix+                                   rep_nm+                                   (map (const no_bang) args)+                                   (Just (map (const HsLazy) args))+                                   [{- No fields -}]+                                   univ_tvs+                                   [{- no existentials -}]+                                   univ_bndrs+                                   [{- No GADT equalities -}]+                                   [{- No theta -}]+                                   arg_tys+                                   (mkTyConApp rec_tycon (mkTyVarTys univ_tvs))+                                   rec_tycon+                                   (mkTyConTagMap rec_tycon)++        ; rhs <- case () of+                  _ | use_newtype+                    -> mkNewTyConRhs tycon_name rec_tycon dict_con+                    | isCTupleTyConName tycon_name+                    -> return (TupleTyCon { data_con = dict_con+                                          , tup_sort = ConstraintTuple })+                    | otherwise+                    -> return (mkDataTyConRhs [dict_con])++        ; let { tycon = mkClassTyCon tycon_name binders roles+                                     rhs rec_clas tc_rep_name+                -- A class can be recursive, and in the case of newtypes+                -- this matters.  For example+                --      class C a where { op :: C b => a -> b -> Int }+                -- Because C has only one operation, it is represented by+                -- a newtype, and it should be a *recursive* newtype.+                -- [If we don't make it a recursive newtype, we'll expand the+                -- newtype like a synonym, but that will lead to an infinite+                -- type]++              ; result = mkClass tycon_name univ_tvs fds+                                 sc_theta sc_sel_ids at_items+                                 op_items mindef tycon+              }+        ; traceIf (text "buildClass" <+> ppr tycon)+        ; return result }+  where+    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict++    mk_op_item :: Class -> TcMethInfo -> TcRnIf n m ClassOpItem+    mk_op_item rec_clas (op_name, _, dm_spec)+      = do { dm_info <- mk_dm_info op_name dm_spec+           ; return (mkDictSelId op_name rec_clas, dm_info) }++    mk_dm_info :: Name -> Maybe (DefMethSpec (SrcSpan, Type))+               -> TcRnIf n m (Maybe (Name, DefMethSpec Type))+    mk_dm_info _ Nothing+      = return Nothing+    mk_dm_info op_name (Just VanillaDM)+      = do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc+           ; return (Just (dm_name, VanillaDM)) }+    mk_dm_info op_name (Just (GenericDM (loc, dm_ty)))+      = do { dm_name <- newImplicitBinderLoc op_name mkDefaultMethodOcc loc+           ; return (Just (dm_name, GenericDM dm_ty)) }++{-+Note [Class newtypes and equality predicates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        class (a ~ F b) => C a b where+          op :: a -> b++We cannot represent this by a newtype, even though it's not+existential, because there are two value fields (the equality+predicate and op. See #2238++Moreover,+          class (a ~ F b) => C a b where {}+Here we can't use a newtype either, even though there is only+one field, because equality predicates are unboxed, and classes+are boxed.+-}++newImplicitBinder :: Name                       -- Base name+                  -> (OccName -> OccName)       -- Occurrence name modifier+                  -> TcRnIf m n Name            -- Implicit name+-- Called in BuildTyCl to allocate the implicit binders of type/class decls+-- For source type/class decls, this is the first occurrence+-- For iface ones, the LoadIface has already allocated a suitable name in the cache+newImplicitBinder base_name mk_sys_occ+  = newImplicitBinderLoc base_name mk_sys_occ (nameSrcSpan base_name)++newImplicitBinderLoc :: Name                       -- Base name+                     -> (OccName -> OccName)       -- Occurrence name modifier+                     -> SrcSpan+                     -> TcRnIf m n Name            -- Implicit name+-- Just the same, but lets you specify the SrcSpan+newImplicitBinderLoc base_name mk_sys_occ loc+  | Just mod <- nameModule_maybe base_name+  = newGlobalBinder mod occ loc+  | otherwise           -- When typechecking a [d| decl bracket |],+                        -- TH generates types, classes etc with Internal names,+                        -- so we follow suit for the implicit binders+  = do  { uniq <- newUnique+        ; return (mkInternalName uniq occ loc) }+  where+    occ = mk_sys_occ (nameOccName base_name)++-- | Make the 'TyConRepName' for this 'TyCon'+newTyConRepName :: Name -> TcRnIf gbl lcl TyConRepName+newTyConRepName tc_name+  | Just mod <- nameModule_maybe tc_name+  , (mod, occ) <- tyConRepModOcc mod (nameOccName tc_name)+  = newGlobalBinder mod occ noSrcSpan+  | otherwise+  = newImplicitBinder tc_name mkTyConRepOcc
+ compiler/iface/FlagChecker.hs view
@@ -0,0 +1,181 @@+{-# LANGUAGE RecordWildCards #-}++-- | This module manages storing the various GHC option flags in a modules+-- interface file as part of the recompilation checking infrastructure.+module FlagChecker (+        fingerprintDynFlags+      , fingerprintOptFlags+      , fingerprintHpcFlags+    ) where++import GhcPrelude++import Binary+import BinIface ()+import DynFlags+import HscTypes+import Module+import Name+import Fingerprint+import BinFingerprint+-- import Outputable++import qualified EnumSet+import System.FilePath (normalise)++-- | Produce a fingerprint of a @DynFlags@ value. We only base+-- the finger print on important fields in @DynFlags@ so that+-- the recompilation checker can use this fingerprint.+--+-- NB: The 'Module' parameter is the 'Module' recorded by the+-- *interface* file, not the actual 'Module' according to our+-- 'DynFlags'.+fingerprintDynFlags :: DynFlags -> Module+                    -> (BinHandle -> Name -> IO ())+                    -> IO Fingerprint++fingerprintDynFlags dflags@DynFlags{..} this_mod nameio =+    let mainis   = if mainModIs == this_mod then Just mainFunIs else Nothing+                      -- see #5878+        -- pkgopts  = (thisPackage dflags, sort $ packageFlags dflags)+        safeHs   = setSafeMode safeHaskell+        -- oflags   = sort $ filter filterOFlags $ flags dflags++        -- *all* the extension flags and the language+        lang = (fmap fromEnum language,+                map fromEnum $ EnumSet.toList extensionFlags)++        -- -I, -D and -U flags affect CPP+        cpp = ( map normalise $ flattenIncludes includePaths+            -- normalise: eliminate spurious differences due to "./foo" vs "foo"+              , picPOpts dflags+              , opt_P_signature dflags)+            -- See Note [Repeated -optP hashing]++        -- Note [path flags and recompilation]+        paths = [ hcSuf ]++        -- -fprof-auto etc.+        prof = if gopt Opt_SccProfilingOn dflags then fromEnum profAuto else 0++        flags = (mainis, safeHs, lang, cpp, paths, prof)++    in -- pprTrace "flags" (ppr flags) $+       computeFingerprint nameio flags++-- Fingerprint the optimisation info. We keep this separate from the rest of+-- the flags because GHCi users (especially) may wish to ignore changes in+-- optimisation level or optimisation flags so as to use as many pre-existing+-- object files as they can.+-- See Note [Ignoring some flag changes]+fingerprintOptFlags :: DynFlags+                      -> (BinHandle -> Name -> IO ())+                      -> IO Fingerprint+fingerprintOptFlags DynFlags{..} nameio =+      let+        -- See https://gitlab.haskell.org/ghc/ghc/issues/10923+        -- We used to fingerprint the optimisation level, but as Joachim+        -- Breitner pointed out in comment 9 on that ticket, it's better+        -- to ignore that and just look at the individual optimisation flags.+        opt_flags = map fromEnum $ filter (`EnumSet.member` optimisationFlags)+                                          (EnumSet.toList generalFlags)++      in computeFingerprint nameio opt_flags++-- Fingerprint the HPC info. We keep this separate from the rest of+-- the flags because GHCi users (especially) may wish to use an object+-- file compiled for HPC when not actually using HPC.+-- See Note [Ignoring some flag changes]+fingerprintHpcFlags :: DynFlags+                      -> (BinHandle -> Name -> IO ())+                      -> IO Fingerprint+fingerprintHpcFlags dflags@DynFlags{..} nameio =+      let+        -- -fhpc, see https://gitlab.haskell.org/ghc/ghc/issues/11798+        -- hpcDir is output-only, so we should recompile if it changes+        hpc = if gopt Opt_Hpc dflags then Just hpcDir else Nothing++      in computeFingerprint nameio hpc+++{- Note [path flags and recompilation]++There are several flags that we deliberately omit from the+recompilation check; here we explain why.++-osuf, -odir, -hisuf, -hidir+  If GHC decides that it does not need to recompile, then+  it must have found an up-to-date .hi file and .o file.+  There is no point recording these flags - the user must+  have passed the correct ones.  Indeed, the user may+  have compiled the source file in one-shot mode using+  -o to specify the .o file, and then loaded it in GHCi+  using -odir.++-stubdir+  We omit this one because it is automatically set by -outputdir, and+  we don't want changes in -outputdir to automatically trigger+  recompilation.  This could be wrong, but only in very rare cases.++-i (importPaths)+  For the same reason as -osuf etc. above: if GHC decides not to+  recompile, then it must have already checked all the .hi files on+  which the current module depends, so it must have found them+  successfully.  It is occasionally useful to be able to cd to a+  different directory and use -i flags to enable GHC to find the .hi+  files; we don't want this to force recompilation.++The only path-related flag left is -hcsuf.+-}++{- Note [Ignoring some flag changes]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Normally, --make tries to reuse only compilation products that are+the same as those that would have been produced compiling from+scratch. Sometimes, however, users would like to be more aggressive+about recompilation avoidance. This is particularly likely when+developing using GHCi (see #13604). Currently, we allow users to+ignore optimisation changes using -fignore-optim-changes, and to+ignore HPC option changes using -fignore-hpc-changes. If there's a+demand for it, we could also allow changes to -fprof-auto-* flags+(although we can't allow -prof flags to differ). The key thing about+these options is that we can still successfully link a library or+executable when some of its components differ in these ways.++The way we accomplish this is to leave the optimization and HPC+options out of the flag hash, hashing them separately.+-}++{- Note [Repeated -optP hashing]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We invoke fingerprintDynFlags for each compiled module to include+the hash of relevant DynFlags in the resulting interface file.+-optP (preprocessor) flags are part of that hash.+-optP flags can come from multiple places:++  1. -optP flags directly passed on command line.+  2. -optP flags implied by other flags. Eg. -DPROFILING implied by -prof.+  3. -optP flags added with {-# OPTIONS -optP-D__F__ #-} in a file.++When compiling many modules at once with many -optP command line arguments+the work of hashing -optP flags would be repeated. This can get expensive+and as noted on #14697 it can take 7% of time and 14% of allocations on+a real codebase.++The obvious solution is to cache the hash of -optP flags per GHC invocation.+However, one has to be careful there, as the flags that were added in 3. way+have to be accounted for.++The current strategy is as follows:++  1. Lazily compute the hash of sOpt_p in sOpt_P_fingerprint whenever sOpt_p+     is modified. This serves dual purpose. It ensures correctness for when+     we add per file -optP flags and lets us save work for when we don't.+  2. When computing the fingerprint in fingerprintDynFlags use the cached+     value *and* fingerprint the additional implied (see 2. above) -optP flags.+     This is relatively cheap and saves the headache of fingerprinting all+     the -optP flags and tracking all the places that could invalidate the+     cache.+-}
+ compiler/iface/IfaceEnv.hs view
@@ -0,0 +1,298 @@+-- (c) The University of Glasgow 2002-2006++{-# LANGUAGE CPP, RankNTypes, BangPatterns #-}++module IfaceEnv (+        newGlobalBinder, newInteractiveBinder,+        externaliseName,+        lookupIfaceTop,+        lookupOrig, lookupOrigIO, lookupOrigNameCache, extendNameCache,+        newIfaceName, newIfaceNames,+        extendIfaceIdEnv, extendIfaceTyVarEnv,+        tcIfaceLclId, tcIfaceTyVar, lookupIfaceVar,+        lookupIfaceTyVar, extendIfaceEnvs,+        setNameModule,++        ifaceExportNames,++        -- Name-cache stuff+        allocateGlobalBinder, updNameCacheTc,+        mkNameCacheUpdater, NameCacheUpdater(..),+   ) where++#include "HsVersions.h"++import GhcPrelude++import TcRnMonad+import HscTypes+import Type+import Var+import Name+import Avail+import Module+import FastString+import FastStringEnv+import IfaceType+import NameCache+import UniqSupply+import SrcLoc++import Outputable+import Data.List     ( partition )++{-+*********************************************************+*                                                      *+        Allocating new Names in the Name Cache+*                                                      *+*********************************************************++See Also: Note [The Name Cache] in NameCache+-}++newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name+-- Used for source code and interface files, to make the+-- Name for a thing, given its Module and OccName+-- See Note [The Name Cache]+--+-- The cache may already already have a binding for this thing,+-- because we may have seen an occurrence before, but now is the+-- moment when we know its Module and SrcLoc in their full glory++newGlobalBinder mod occ loc+  = do { name <- updNameCacheTc mod occ $ \name_cache ->+                 allocateGlobalBinder name_cache mod occ loc+       ; traceIf (text "newGlobalBinder" <+>+                  (vcat [ ppr mod <+> ppr occ <+> ppr loc, ppr name]))+       ; return name }++newInteractiveBinder :: HscEnv -> OccName -> SrcSpan -> IO Name+-- Works in the IO monad, and gets the Module+-- from the interactive context+newInteractiveBinder hsc_env occ loc+ = do { let mod = icInteractiveModule (hsc_IC hsc_env)+       ; updNameCacheIO hsc_env mod occ $ \name_cache ->+         allocateGlobalBinder name_cache mod occ loc }++allocateGlobalBinder+  :: NameCache+  -> Module -> OccName -> SrcSpan+  -> (NameCache, Name)+-- See Note [The Name Cache]+allocateGlobalBinder name_supply mod occ loc+  = case lookupOrigNameCache (nsNames name_supply) mod occ of+        -- A hit in the cache!  We are at the binding site of the name.+        -- This is the moment when we know the SrcLoc+        -- of the Name, so we set this field in the Name we return.+        --+        -- Then (bogus) multiple bindings of the same Name+        -- get different SrcLocs can can be reported as such.+        --+        -- Possible other reason: it might be in the cache because we+        --      encountered an occurrence before the binding site for an+        --      implicitly-imported Name.  Perhaps the current SrcLoc is+        --      better... but not really: it'll still just say 'imported'+        --+        -- IMPORTANT: Don't mess with wired-in names.+        --            Their wired-in-ness is in their NameSort+        --            and their Module is correct.++        Just name | isWiredInName name+                  -> (name_supply, name)+                  | otherwise+                  -> (new_name_supply, name')+                  where+                    uniq            = nameUnique name+                    name'           = mkExternalName uniq mod occ loc+                                      -- name' is like name, but with the right SrcSpan+                    new_cache       = extendNameCache (nsNames name_supply) mod occ name'+                    new_name_supply = name_supply {nsNames = new_cache}++        -- Miss in the cache!+        -- Build a completely new Name, and put it in the cache+        _ -> (new_name_supply, name)+                  where+                    (uniq, us')     = takeUniqFromSupply (nsUniqs name_supply)+                    name            = mkExternalName uniq mod occ loc+                    new_cache       = extendNameCache (nsNames name_supply) mod occ name+                    new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache}++ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo]+ifaceExportNames exports = return exports++-- | A function that atomically updates the name cache given a modifier+-- function.  The second result of the modifier function will be the result+-- of the IO action.+newtype NameCacheUpdater+      = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c }++mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater+mkNameCacheUpdater = do { hsc_env <- getTopEnv+                        ; let !ncRef = hsc_NC hsc_env+                        ; return (NCU (updNameCache ncRef)) }++updNameCacheTc :: Module -> OccName -> (NameCache -> (NameCache, c))+               -> TcRnIf a b c+updNameCacheTc mod occ upd_fn = do {+    hsc_env <- getTopEnv+  ; liftIO $ updNameCacheIO hsc_env mod occ upd_fn }+++updNameCacheIO ::  HscEnv -> Module -> OccName+               -> (NameCache -> (NameCache, c))+               -> IO c+updNameCacheIO hsc_env mod occ upd_fn = do {++    -- First ensure that mod and occ are evaluated+    -- If not, chaos can ensue:+    --      we read the name-cache+    --      then pull on mod (say)+    --      which does some stuff that modifies the name cache+    -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..)++    mod `seq` occ `seq` return ()+  ; updNameCache (hsc_NC hsc_env) upd_fn }+++{-+************************************************************************+*                                                                      *+                Name cache access+*                                                                      *+************************************************************************+-}++-- | Look up the 'Name' for a given 'Module' and 'OccName'.+-- Consider alternatively using 'lookupIfaceTop' if you're in the 'IfL' monad+-- and 'Module' is simply that of the 'ModIface' you are typechecking.+lookupOrig :: Module -> OccName -> TcRnIf a b Name+lookupOrig mod occ+  = do  { traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ)++        ; updNameCacheTc mod occ $ lookupNameCache mod occ }++lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name+lookupOrigIO hsc_env mod occ+  = updNameCacheIO hsc_env mod occ $ lookupNameCache mod occ++lookupNameCache :: Module -> OccName -> NameCache -> (NameCache, Name)+-- Lookup up the (Module,OccName) in the NameCache+-- If you find it, return it; if not, allocate a fresh original name and extend+-- the NameCache.+-- Reason: this may the first occurrence of (say) Foo.bar we have encountered.+-- If we need to explore its value we will load Foo.hi; but meanwhile all we+-- need is a Name for it.+lookupNameCache mod occ name_cache =+  case lookupOrigNameCache (nsNames name_cache) mod occ of {+    Just name -> (name_cache, name);+    Nothing   ->+        case takeUniqFromSupply (nsUniqs name_cache) of {+          (uniq, us) ->+              let+                name      = mkExternalName uniq mod occ noSrcSpan+                new_cache = extendNameCache (nsNames name_cache) mod occ name+              in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}++externaliseName :: Module -> Name -> TcRnIf m n Name+-- Take an Internal Name and make it an External one,+-- with the same unique+externaliseName mod name+  = do { let occ = nameOccName name+             loc = nameSrcSpan name+             uniq = nameUnique name+       ; occ `seq` return ()  -- c.f. seq in newGlobalBinder+       ; updNameCacheTc mod occ $ \ ns ->+         let name' = mkExternalName uniq mod occ loc+             ns'   = ns { nsNames = extendNameCache (nsNames ns) mod occ name' }+         in (ns', name') }++-- | Set the 'Module' of a 'Name'.+setNameModule :: Maybe Module -> Name -> TcRnIf m n Name+setNameModule Nothing n = return n+setNameModule (Just m) n =+    newGlobalBinder m (nameOccName n) (nameSrcSpan n)++{-+************************************************************************+*                                                                      *+                Type variables and local Ids+*                                                                      *+************************************************************************+-}++tcIfaceLclId :: FastString -> IfL Id+tcIfaceLclId occ+  = do  { lcl <- getLclEnv+        ; case (lookupFsEnv (if_id_env lcl) occ) of+            Just ty_var -> return ty_var+            Nothing     -> failIfM (text "Iface id out of scope: " <+> ppr occ)+        }++extendIfaceIdEnv :: [Id] -> IfL a -> IfL a+extendIfaceIdEnv ids thing_inside+  = do  { env <- getLclEnv+        ; let { id_env' = extendFsEnvList (if_id_env env) pairs+              ; pairs   = [(occNameFS (getOccName id), id) | id <- ids] }+        ; setLclEnv (env { if_id_env = id_env' }) thing_inside }+++tcIfaceTyVar :: FastString -> IfL TyVar+tcIfaceTyVar occ+  = do  { lcl <- getLclEnv+        ; case (lookupFsEnv (if_tv_env lcl) occ) of+            Just ty_var -> return ty_var+            Nothing     -> failIfM (text "Iface type variable out of scope: " <+> ppr occ)+        }++lookupIfaceTyVar :: IfaceTvBndr -> IfL (Maybe TyVar)+lookupIfaceTyVar (occ, _)+  = do  { lcl <- getLclEnv+        ; return (lookupFsEnv (if_tv_env lcl) occ) }++lookupIfaceVar :: IfaceBndr -> IfL (Maybe TyCoVar)+lookupIfaceVar (IfaceIdBndr (occ, _))+  = do  { lcl <- getLclEnv+        ; return (lookupFsEnv (if_id_env lcl) occ) }+lookupIfaceVar (IfaceTvBndr (occ, _))+  = do  { lcl <- getLclEnv+        ; return (lookupFsEnv (if_tv_env lcl) occ) }++extendIfaceTyVarEnv :: [TyVar] -> IfL a -> IfL a+extendIfaceTyVarEnv tyvars thing_inside+  = do  { env <- getLclEnv+        ; let { tv_env' = extendFsEnvList (if_tv_env env) pairs+              ; pairs   = [(occNameFS (getOccName tv), tv) | tv <- tyvars] }+        ; setLclEnv (env { if_tv_env = tv_env' }) thing_inside }++extendIfaceEnvs :: [TyCoVar] -> IfL a -> IfL a+extendIfaceEnvs tcvs thing_inside+  = extendIfaceTyVarEnv tvs $+    extendIfaceIdEnv    cvs $+    thing_inside+  where+    (tvs, cvs) = partition isTyVar tcvs++{-+************************************************************************+*                                                                      *+                Getting from RdrNames to Names+*                                                                      *+************************************************************************+-}++-- | Look up a top-level name from the current Iface module+lookupIfaceTop :: OccName -> IfL Name+lookupIfaceTop occ+  = do  { env <- getLclEnv; lookupOrig (if_mod env) occ }++newIfaceName :: OccName -> IfL Name+newIfaceName occ+  = do  { uniq <- newUnique+        ; return $! mkInternalName uniq occ noSrcSpan }++newIfaceNames :: [OccName] -> IfL [Name]+newIfaceNames occs+  = do  { uniqs <- newUniqueSupply+        ; return [ mkInternalName uniq occ noSrcSpan+                 | (occ,uniq) <- occs `zip` uniqsFromSupply uniqs] }
+ compiler/iface/IfaceEnv.hs-boot view
@@ -0,0 +1,9 @@+module IfaceEnv where++import Module+import OccName+import TcRnMonad+import Name+import SrcLoc++newGlobalBinder :: Module -> OccName -> SrcSpan -> TcRnIf a b Name
+ compiler/iface/LoadIface.hs view
@@ -0,0 +1,1286 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Loading interface files+-}++{-# LANGUAGE CPP, BangPatterns, RecordWildCards, NondecreasingIndentation #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module LoadIface (+        -- Importing one thing+        tcLookupImported_maybe, importDecl,+        checkWiredInTyCon, ifCheckWiredInThing,++        -- RnM/TcM functions+        loadModuleInterface, loadModuleInterfaces,+        loadSrcInterface, loadSrcInterface_maybe,+        loadInterfaceForName, loadInterfaceForNameMaybe, loadInterfaceForModule,++        -- IfM functions+        loadInterface,+        loadSysInterface, loadUserInterface, loadPluginInterface,+        findAndReadIface, readIface,    -- Used when reading the module's old interface+        loadDecls,      -- Should move to TcIface and be renamed+        initExternalPackageState,+        moduleFreeHolesPrecise,+        needWiredInHomeIface, loadWiredInHomeIface,++        pprModIfaceSimple,+        ifaceStats, pprModIface, showIface+   ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-}   TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst,+                                 tcIfaceFamInst,+                                 tcIfaceAnnotations, tcIfaceCompleteSigs )++import DynFlags+import IfaceSyn+import IfaceEnv+import HscTypes++import BasicTypes hiding (SuccessFlag(..))+import TcRnMonad++import Constants+import PrelNames+import PrelInfo+import PrimOp   ( allThePrimOps, primOpFixity, primOpOcc )+import MkId     ( seqId )+import TysPrim  ( funTyConName )+import Rules+import TyCon+import Annotations+import InstEnv+import FamInstEnv+import Name+import NameEnv+import Avail+import Module+import Maybes+import ErrUtils+import Finder+import UniqFM+import SrcLoc+import Outputable+import BinIface+import Panic+import Util+import FastString+import Fingerprint+import Hooks+import FieldLabel+import RnModIface+import UniqDSet+import Plugins++import Control.Monad+import Control.Exception+import Data.IORef+import System.FilePath++{-+************************************************************************+*                                                                      *+*      tcImportDecl is the key function for "faulting in"              *+*      imported things+*                                                                      *+************************************************************************++The main idea is this.  We are chugging along type-checking source code, and+find a reference to GHC.Base.map.  We call tcLookupGlobal, which doesn't find+it in the EPS type envt.  So it+        1 loads GHC.Base.hi+        2 gets the decl for GHC.Base.map+        3 typechecks it via tcIfaceDecl+        4 and adds it to the type env in the EPS++Note that DURING STEP 4, we may find that map's type mentions a type+constructor that also++Notice that for imported things we read the current version from the EPS+mutable variable.  This is important in situations like+        ...$(e1)...$(e2)...+where the code that e1 expands to might import some defns that+also turn out to be needed by the code that e2 expands to.+-}++tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)+-- Returns (Failed err) if we can't find the interface file for the thing+tcLookupImported_maybe name+  = do  { hsc_env <- getTopEnv+        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)+        ; case mb_thing of+            Just thing -> return (Succeeded thing)+            Nothing    -> tcImportDecl_maybe name }++tcImportDecl_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)+-- Entry point for *source-code* uses of importDecl+tcImportDecl_maybe name+  | Just thing <- wiredInNameTyThing_maybe name+  = do  { when (needWiredInHomeIface thing)+               (initIfaceTcRn (loadWiredInHomeIface name))+                -- See Note [Loading instances for wired-in things]+        ; return (Succeeded thing) }+  | otherwise+  = initIfaceTcRn (importDecl name)++importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing)+-- Get the TyThing for this Name from an interface file+-- It's not a wired-in thing -- the caller caught that+importDecl name+  = ASSERT( not (isWiredInName name) )+    do  { traceIf nd_doc++        -- Load the interface, which should populate the PTE+        ; mb_iface <- ASSERT2( isExternalName name, ppr name )+                      loadInterface nd_doc (nameModule name) ImportBySystem+        ; case mb_iface of {+                Failed err_msg  -> return (Failed err_msg) ;+                Succeeded _ -> do++        -- Now look it up again; this time we should find it+        { eps <- getEps+        ; case lookupTypeEnv (eps_PTE eps) name of+            Just thing -> return $ Succeeded thing+            Nothing    -> let doc = whenPprDebug (found_things_msg eps $$ empty)+                                    $$ not_found_msg+                          in return $ Failed doc+    }}}+  where+    nd_doc = text "Need decl for" <+> ppr name+    not_found_msg = hang (text "Can't find interface-file declaration for" <+>+                                pprNameSpace (occNameSpace (nameOccName name)) <+> ppr name)+                       2 (vcat [text "Probable cause: bug in .hi-boot file, or inconsistent .hi file",+                                text "Use -ddump-if-trace to get an idea of which file caused the error"])+    found_things_msg eps =+        hang (text "Found the following declarations in" <+> ppr (nameModule name) <> colon)+           2 (vcat (map ppr $ filter is_interesting $ nameEnvElts $ eps_PTE eps))+      where+        is_interesting thing = nameModule name == nameModule (getName thing)+++{-+************************************************************************+*                                                                      *+           Checks for wired-in things+*                                                                      *+************************************************************************++Note [Loading instances for wired-in things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to make sure that we have at least *read* the interface files+for any module with an instance decl or RULE that we might want.++* If the instance decl is an orphan, we have a whole separate mechanism+  (loadOrphanModules)++* If the instance decl is not an orphan, then the act of looking at the+  TyCon or Class will force in the defining module for the+  TyCon/Class, and hence the instance decl++* BUT, if the TyCon is a wired-in TyCon, we don't really need its interface;+  but we must make sure we read its interface in case it has instances or+  rules.  That is what LoadIface.loadWiredInHomeIface does.  It's called+  from TcIface.{tcImportDecl, checkWiredInTyCon, ifCheckWiredInThing}++* HOWEVER, only do this for TyCons.  There are no wired-in Classes.  There+  are some wired-in Ids, but we don't want to load their interfaces. For+  example, Control.Exception.Base.recSelError is wired in, but that module+  is compiled late in the base library, and we don't want to force it to+  load before it's been compiled!++All of this is done by the type checker. The renamer plays no role.+(It used to, but no longer.)+-}++checkWiredInTyCon :: TyCon -> TcM ()+-- Ensure that the home module of the TyCon (and hence its instances)+-- are loaded. See Note [Loading instances for wired-in things]+-- It might not be a wired-in tycon (see the calls in TcUnify),+-- in which case this is a no-op.+checkWiredInTyCon tc+  | not (isWiredInName tc_name)+  = return ()+  | otherwise+  = do  { mod <- getModule+        ; traceIf (text "checkWiredInTyCon" <+> ppr tc_name $$ ppr mod)+        ; ASSERT( isExternalName tc_name )+          when (mod /= nameModule tc_name)+               (initIfaceTcRn (loadWiredInHomeIface tc_name))+                -- Don't look for (non-existent) Float.hi when+                -- compiling Float.hs, which mentions Float of course+                -- A bit yukky to call initIfaceTcRn here+        }+  where+    tc_name = tyConName tc++ifCheckWiredInThing :: TyThing -> IfL ()+-- Even though we are in an interface file, we want to make+-- sure the instances of a wired-in thing are loaded (imagine f :: Double -> Double)+-- Ditto want to ensure that RULES are loaded too+-- See Note [Loading instances for wired-in things]+ifCheckWiredInThing thing+  = do  { mod <- getIfModule+                -- Check whether we are typechecking the interface for this+                -- very module.  E.g when compiling the base library in --make mode+                -- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in+                -- the HPT, so without the test we'll demand-load it into the PIT!+                -- C.f. the same test in checkWiredInTyCon above+        ; let name = getName thing+        ; ASSERT2( isExternalName name, ppr name )+          when (needWiredInHomeIface thing && mod /= nameModule name)+               (loadWiredInHomeIface name) }++needWiredInHomeIface :: TyThing -> Bool+-- Only for TyCons; see Note [Loading instances for wired-in things]+needWiredInHomeIface (ATyCon {}) = True+needWiredInHomeIface _           = False+++{-+************************************************************************+*                                                                      *+        loadSrcInterface, loadOrphanModules, loadInterfaceForName++                These three are called from TcM-land+*                                                                      *+************************************************************************+-}++-- | Load the interface corresponding to an @import@ directive in+-- source code.  On a failure, fail in the monad with an error message.+loadSrcInterface :: SDoc+                 -> ModuleName+                 -> IsBootInterface     -- {-# SOURCE #-} ?+                 -> Maybe FastString    -- "package", if any+                 -> RnM ModIface++loadSrcInterface doc mod want_boot maybe_pkg+  = do { res <- loadSrcInterface_maybe doc mod want_boot maybe_pkg+       ; case res of+           Failed err      -> failWithTc err+           Succeeded iface -> return iface }++-- | Like 'loadSrcInterface', but returns a 'MaybeErr'.+loadSrcInterface_maybe :: SDoc+                       -> ModuleName+                       -> IsBootInterface     -- {-# SOURCE #-} ?+                       -> Maybe FastString    -- "package", if any+                       -> RnM (MaybeErr MsgDoc ModIface)++loadSrcInterface_maybe doc mod want_boot maybe_pkg+  -- We must first find which Module this import refers to.  This involves+  -- calling the Finder, which as a side effect will search the filesystem+  -- and create a ModLocation.  If successful, loadIface will read the+  -- interface; it will call the Finder again, but the ModLocation will be+  -- cached from the first search.+  = do { hsc_env <- getTopEnv+       ; res <- liftIO $ findImportedModule hsc_env mod maybe_pkg+       ; case res of+           Found _ mod -> initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot)+           -- TODO: Make sure this error message is good+           err         -> return (Failed (cannotFindModule (hsc_dflags hsc_env) mod err)) }++-- | Load interface directly for a fully qualified 'Module'.  (This is a fairly+-- rare operation, but in particular it is used to load orphan modules+-- in order to pull their instances into the global package table and to+-- handle some operations in GHCi).+loadModuleInterface :: SDoc -> Module -> TcM ModIface+loadModuleInterface doc mod = initIfaceTcRn (loadSysInterface doc mod)++-- | Load interfaces for a collection of modules.+loadModuleInterfaces :: SDoc -> [Module] -> TcM ()+loadModuleInterfaces doc mods+  | null mods = return ()+  | otherwise = initIfaceTcRn (mapM_ load mods)+  where+    load mod = loadSysInterface (doc <+> parens (ppr mod)) mod++-- | Loads the interface for a given Name.+-- Should only be called for an imported name;+-- otherwise loadSysInterface may not find the interface+loadInterfaceForName :: SDoc -> Name -> TcRn ModIface+loadInterfaceForName doc name+  = do { when debugIsOn $  -- Check pre-condition+         do { this_mod <- getModule+            ; MASSERT2( not (nameIsLocalOrFrom this_mod name), ppr name <+> parens doc ) }+      ; ASSERT2( isExternalName name, ppr name )+        initIfaceTcRn $ loadSysInterface doc (nameModule name) }++-- | Only loads the interface for external non-local names.+loadInterfaceForNameMaybe :: SDoc -> Name -> TcRn (Maybe ModIface)+loadInterfaceForNameMaybe doc name+  = do { this_mod <- getModule+       ; if nameIsLocalOrFrom this_mod name || not (isExternalName name)+         then return Nothing+         else Just <$> (initIfaceTcRn $ loadSysInterface doc (nameModule name))+       }++-- | Loads the interface for a given Module.+loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface+loadInterfaceForModule doc m+  = do+    -- Should not be called with this module+    when debugIsOn $ do+      this_mod <- getModule+      MASSERT2( this_mod /= m, ppr m <+> parens doc )+    initIfaceTcRn $ loadSysInterface doc m++{-+*********************************************************+*                                                      *+                loadInterface++        The main function to load an interface+        for an imported module, and put it in+        the External Package State+*                                                      *+*********************************************************+-}++-- | An 'IfM' function to load the home interface for a wired-in thing,+-- so that we're sure that we see its instance declarations and rules+-- See Note [Loading instances for wired-in things]+loadWiredInHomeIface :: Name -> IfM lcl ()+loadWiredInHomeIface name+  = ASSERT( isWiredInName name )+    do _ <- loadSysInterface doc (nameModule name); return ()+  where+    doc = text "Need home interface for wired-in thing" <+> ppr name++------------------+-- | Loads a system interface and throws an exception if it fails+loadSysInterface :: SDoc -> Module -> IfM lcl ModIface+loadSysInterface doc mod_name = loadInterfaceWithException doc mod_name ImportBySystem++------------------+-- | Loads a user interface and throws an exception if it fails. The first parameter indicates+-- whether we should import the boot variant of the module+loadUserInterface :: Bool -> SDoc -> Module -> IfM lcl ModIface+loadUserInterface is_boot doc mod_name+  = loadInterfaceWithException doc mod_name (ImportByUser is_boot)++loadPluginInterface :: SDoc -> Module -> IfM lcl ModIface+loadPluginInterface doc mod_name+  = loadInterfaceWithException doc mod_name ImportByPlugin++------------------+-- | A wrapper for 'loadInterface' that throws an exception if it fails+loadInterfaceWithException :: SDoc -> Module -> WhereFrom -> IfM lcl ModIface+loadInterfaceWithException doc mod_name where_from+  = withException (loadInterface doc mod_name where_from)++------------------+loadInterface :: SDoc -> Module -> WhereFrom+              -> IfM lcl (MaybeErr MsgDoc ModIface)++-- loadInterface looks in both the HPT and PIT for the required interface+-- If not found, it loads it, and puts it in the PIT (always).++-- If it can't find a suitable interface file, we+--      a) modify the PackageIfaceTable to have an empty entry+--              (to avoid repeated complaints)+--      b) return (Left message)+--+-- It's not necessarily an error for there not to be an interface+-- file -- perhaps the module has changed, and that interface+-- is no longer used++loadInterface doc_str mod from+  | isHoleModule mod+  -- Hole modules get special treatment+  = do dflags <- getDynFlags+       -- Redo search for our local hole module+       loadInterface doc_str (mkModule (thisPackage dflags) (moduleName mod)) from+  | otherwise+  = do  {       -- Read the state+          (eps,hpt) <- getEpsAndHpt+        ; gbl_env <- getGblEnv++        ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from)++                -- Check whether we have the interface already+        ; dflags <- getDynFlags+        ; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of {+            Just iface+                -> return (Succeeded iface) ;   -- Already loaded+                        -- The (src_imp == mi_boot iface) test checks that the already-loaded+                        -- interface isn't a boot iface.  This can conceivably happen,+                        -- if an earlier import had a before we got to real imports.   I think.+            _ -> do {++        -- READ THE MODULE IN+        ; read_result <- case (wantHiBootFile dflags eps mod from) of+                           Failed err             -> return (Failed err)+                           Succeeded hi_boot_file -> computeInterface doc_str hi_boot_file mod+        ; case read_result of {+            Failed err -> do+                { let fake_iface = emptyModIface mod++                ; updateEps_ $ \eps ->+                        eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface }+                        -- Not found, so add an empty iface to+                        -- the EPS map so that we don't look again++                ; return (Failed err) } ;++        -- Found and parsed!+        -- We used to have a sanity check here that looked for:+        --  * System importing ..+        --  * a home package module ..+        --  * that we know nothing about (mb_dep == Nothing)!+        --+        -- But this is no longer valid because thNameToGhcName allows users to+        -- cause the system to load arbitrary interfaces (by supplying an appropriate+        -- Template Haskell original-name).+            Succeeded (iface, loc) ->+        let+            loc_doc = text loc+        in+        initIfaceLcl (mi_semantic_module iface) loc_doc (mi_boot iface) $ do++        dontLeakTheHPT $ do++        --      Load the new ModIface into the External Package State+        -- Even home-package interfaces loaded by loadInterface+        --      (which only happens in OneShot mode; in Batch/Interactive+        --      mode, home-package modules are loaded one by one into the HPT)+        -- are put in the EPS.+        --+        -- The main thing is to add the ModIface to the PIT, but+        -- we also take the+        --      IfaceDecls, IfaceClsInst, IfaceFamInst, IfaceRules,+        -- out of the ModIface and put them into the big EPS pools++        -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined+        ---    names is done correctly (notably, whether this is an .hi file or .hi-boot file).+        --     If we do loadExport first the wrong info gets into the cache (unless we+        --      explicitly tag each export which seems a bit of a bore)++        ; ignore_prags      <- goptM Opt_IgnoreInterfacePragmas+        ; new_eps_decls     <- loadDecls ignore_prags (mi_decls iface)+        ; new_eps_insts     <- mapM tcIfaceInst (mi_insts iface)+        ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)+        ; new_eps_rules     <- tcIfaceRules ignore_prags (mi_rules iface)+        ; new_eps_anns      <- tcIfaceAnnotations (mi_anns iface)+        ; new_eps_complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)++        ; let { final_iface = iface {+                                mi_decls     = panic "No mi_decls in PIT",+                                mi_insts     = panic "No mi_insts in PIT",+                                mi_fam_insts = panic "No mi_fam_insts in PIT",+                                mi_rules     = panic "No mi_rules in PIT",+                                mi_anns      = panic "No mi_anns in PIT"+                              }+               }++        ; let bad_boot = mi_boot iface && fmap fst (if_rec_types gbl_env) == Just mod+                            -- Warn warn against an EPS-updating import+                            -- of one's own boot file! (one-shot only)+                            -- See Note [Loading your own hi-boot file]+                            -- in MkIface.++        ; WARN( bad_boot, ppr mod )+          updateEps_  $ \ eps ->+           if elemModuleEnv mod (eps_PIT eps) || is_external_sig dflags iface+                then eps+           else if bad_boot+                -- See Note [Loading your own hi-boot file]+                then eps { eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls }+           else+                eps {+                  eps_PIT          = extendModuleEnv (eps_PIT eps) mod final_iface,+                  eps_PTE          = addDeclsToPTE   (eps_PTE eps) new_eps_decls,+                  eps_rule_base    = extendRuleBaseList (eps_rule_base eps)+                                                        new_eps_rules,+                  eps_complete_matches+                                   = extendCompleteMatchMap+                                         (eps_complete_matches eps)+                                         new_eps_complete_sigs,+                  eps_inst_env     = extendInstEnvList (eps_inst_env eps)+                                                       new_eps_insts,+                  eps_fam_inst_env = extendFamInstEnvList (eps_fam_inst_env eps)+                                                          new_eps_fam_insts,+                  eps_ann_env      = extendAnnEnvList (eps_ann_env eps)+                                                      new_eps_anns,+                  eps_mod_fam_inst_env+                                   = let+                                       fam_inst_env =+                                         extendFamInstEnvList emptyFamInstEnv+                                                              new_eps_fam_insts+                                     in+                                     extendModuleEnv (eps_mod_fam_inst_env eps)+                                                     mod+                                                     fam_inst_env,+                  eps_stats        = addEpsInStats (eps_stats eps)+                                                   (length new_eps_decls)+                                                   (length new_eps_insts)+                                                   (length new_eps_rules) }++        ; -- invoke plugins+          res <- withPlugins dflags interfaceLoadAction final_iface+        ; return (Succeeded res)+    }}}}++{- Note [Loading your own hi-boot file]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking, when compiling module M, we should not+load M.hi boot into the EPS.  After all, we are very shortly+going to have full information about M.  Moreover, see+Note [Do not update EPS with your own hi-boot] in MkIface.++But there is a HORRIBLE HACK here.++* At the end of tcRnImports, we call checkFamInstConsistency to+  check consistency of imported type-family instances+  See Note [The type family instance consistency story] in FamInst++* Alas, those instances may refer to data types defined in M,+  if there is a M.hs-boot.++* And that means we end up loading M.hi-boot, because those+  data types are not yet in the type environment.++But in this wierd case, /all/ we need is the types. We don't need+instances, rules etc.  And if we put the instances in the EPS+we get "duplicate instance" warnings when we compile the "real"+instance in M itself.  Hence the strange business of just updateing+the eps_PTE.++This really happens in practice.  The module HsExpr.hs gets+"duplicate instance" errors if this hack is not present.++This is a mess.+++Note [HPT space leak] (#15111)+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In IfL, we defer some work until it is demanded using forkM, such+as building TyThings from IfaceDecls. These thunks are stored in+the ExternalPackageState, and they might never be poked.  If we're+not careful, these thunks will capture the state of the loaded+program when we read an interface file, and retain all that data+for ever.++Therefore, when loading a package interface file , we use a "clean"+version of the HscEnv with all the data about the currently loaded+program stripped out. Most of the fields can be panics because+we'll never read them, but hsc_HPT needs to be empty because this+interface will cause other interfaces to be loaded recursively, and+when looking up those interfaces we use the HPT in loadInterface.+We know that none of the interfaces below here can refer to+home-package modules however, so it's safe for the HPT to be empty.+-}++dontLeakTheHPT :: IfL a -> IfL a+dontLeakTheHPT thing_inside = do+  let+    cleanTopEnv HscEnv{..} =+       let+         -- wrinkle: when we're typechecking in --backpack mode, the+         -- instantiation of a signature might reside in the HPT, so+         -- this case breaks the assumption that EPS interfaces only+         -- refer to other EPS interfaces. We can detect when we're in+         -- typechecking-only mode by using hscTarget==HscNothing, and+         -- in that case we don't empty the HPT.  (admittedly this is+         -- a bit of a hack, better suggestions welcome). A number of+         -- tests in testsuite/tests/backpack break without this+         -- tweak.+         !hpt | hscTarget hsc_dflags == HscNothing = hsc_HPT+              | otherwise = emptyHomePackageTable+       in+       HscEnv {  hsc_targets      = panic "cleanTopEnv: hsc_targets"+              ,  hsc_mod_graph    = panic "cleanTopEnv: hsc_mod_graph"+              ,  hsc_IC           = panic "cleanTopEnv: hsc_IC"+              ,  hsc_HPT          = hpt+              , .. }++  updTopEnv cleanTopEnv $ do+  !_ <- getTopEnv        -- force the updTopEnv+  thing_inside+++-- | Returns @True@ if a 'ModIface' comes from an external package.+-- In this case, we should NOT load it into the EPS; the entities+-- should instead come from the local merged signature interface.+is_external_sig :: DynFlags -> ModIface -> Bool+is_external_sig dflags iface =+    -- It's a signature iface...+    mi_semantic_module iface /= mi_module iface &&+    -- and it's not from the local package+    moduleUnitId (mi_module iface) /= thisPackage dflags++-- | This is an improved version of 'findAndReadIface' which can also+-- handle the case when a user requests @p[A=<B>]:M@ but we only+-- have an interface for @p[A=<A>]:M@ (the indefinite interface.+-- If we are not trying to build code, we load the interface we have,+-- *instantiating it* according to how the holes are specified.+-- (Of course, if we're actually building code, this is a hard error.)+--+-- In the presence of holes, 'computeInterface' has an important invariant:+-- to load module M, its set of transitively reachable requirements must+-- have an up-to-date local hi file for that requirement.  Note that if+-- we are loading the interface of a requirement, this does not+-- apply to the requirement itself; e.g., @p[A=<A>]:A@ does not require+-- A.hi to be up-to-date (and indeed, we MUST NOT attempt to read A.hi, unless+-- we are actually typechecking p.)+computeInterface ::+       SDoc -> IsBootInterface -> Module+    -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))+computeInterface doc_str hi_boot_file mod0 = do+    MASSERT( not (isHoleModule mod0) )+    dflags <- getDynFlags+    case splitModuleInsts mod0 of+        (imod, Just indef) | not (unitIdIsDefinite (thisPackage dflags)) -> do+            r <- findAndReadIface doc_str imod mod0 hi_boot_file+            case r of+                Succeeded (iface0, path) -> do+                    hsc_env <- getTopEnv+                    r <- liftIO $+                        rnModIface hsc_env (indefUnitIdInsts (indefModuleUnitId indef))+                                   Nothing iface0+                    case r of+                        Right x -> return (Succeeded (x, path))+                        Left errs -> liftIO . throwIO . mkSrcErr $ errs+                Failed err -> return (Failed err)+        (mod, _) ->+            findAndReadIface doc_str mod mod0 hi_boot_file++-- | Compute the signatures which must be compiled in order to+-- load the interface for a 'Module'.  The output of this function+-- is always a subset of 'moduleFreeHoles'; it is more precise+-- because in signature @p[A=<A>,B=<B>]:B@, although the free holes+-- are A and B, B might not depend on A at all!+--+-- If this is invoked on a signature, this does NOT include the+-- signature itself; e.g. precise free module holes of+-- @p[A=<A>,B=<B>]:B@ never includes B.+moduleFreeHolesPrecise+    :: SDoc -> Module+    -> TcRnIf gbl lcl (MaybeErr MsgDoc (UniqDSet ModuleName))+moduleFreeHolesPrecise doc_str mod+ | moduleIsDefinite mod = return (Succeeded emptyUniqDSet)+ | otherwise =+   case splitModuleInsts mod of+    (imod, Just indef) -> do+        let insts = indefUnitIdInsts (indefModuleUnitId indef)+        traceIf (text "Considering whether to load" <+> ppr mod <+>+                 text "to compute precise free module holes")+        (eps, hpt) <- getEpsAndHpt+        dflags <- getDynFlags+        case tryEpsAndHpt dflags eps hpt `firstJust` tryDepsCache eps imod insts of+            Just r -> return (Succeeded r)+            Nothing -> readAndCache imod insts+    (_, Nothing) -> return (Succeeded emptyUniqDSet)+  where+    tryEpsAndHpt dflags eps hpt =+        fmap mi_free_holes (lookupIfaceByModule dflags hpt (eps_PIT eps) mod)+    tryDepsCache eps imod insts =+        case lookupInstalledModuleEnv (eps_free_holes eps) imod of+            Just ifhs  -> Just (renameFreeHoles ifhs insts)+            _otherwise -> Nothing+    readAndCache imod insts = do+        mb_iface <- findAndReadIface (text "moduleFreeHolesPrecise" <+> doc_str) imod mod False+        case mb_iface of+            Succeeded (iface, _) -> do+                let ifhs = mi_free_holes iface+                -- Cache it+                updateEps_ (\eps ->+                    eps { eps_free_holes = extendInstalledModuleEnv (eps_free_holes eps) imod ifhs })+                return (Succeeded (renameFreeHoles ifhs insts))+            Failed err -> return (Failed err)++wantHiBootFile :: DynFlags -> ExternalPackageState -> Module -> WhereFrom+               -> MaybeErr MsgDoc IsBootInterface+-- Figure out whether we want Foo.hi or Foo.hi-boot+wantHiBootFile dflags eps mod from+  = case from of+       ImportByUser usr_boot+          | usr_boot && not this_package+          -> Failed (badSourceImport mod)+          | otherwise -> Succeeded usr_boot++       ImportByPlugin+          -> Succeeded False++       ImportBySystem+          | not this_package   -- If the module to be imported is not from this package+          -> Succeeded False   -- don't look it up in eps_is_boot, because that is keyed+                               -- on the ModuleName of *home-package* modules only.+                               -- We never import boot modules from other packages!++          | otherwise+          -> case lookupUFM (eps_is_boot eps) (moduleName mod) of+                Just (_, is_boot) -> Succeeded is_boot+                Nothing           -> Succeeded False+                     -- The boot-ness of the requested interface,+                     -- based on the dependencies in directly-imported modules+  where+    this_package = thisPackage dflags == moduleUnitId mod++badSourceImport :: Module -> SDoc+badSourceImport mod+  = hang (text "You cannot {-# SOURCE #-} import a module from another package")+       2 (text "but" <+> quotes (ppr mod) <+> ptext (sLit "is from package")+          <+> quotes (ppr (moduleUnitId mod)))++-----------------------------------------------------+--      Loading type/class/value decls+-- We pass the full Module name here, replete with+-- its package info, so that we can build a Name for+-- each binder with the right package info in it+-- All subsequent lookups, including crucially lookups during typechecking+-- the declaration itself, will find the fully-glorious Name+--+-- We handle ATs specially.  They are not main declarations, but also not+-- implicit things (in particular, adding them to `implicitTyThings' would mess+-- things up in the renaming/type checking of source programs).+-----------------------------------------------------++addDeclsToPTE :: PackageTypeEnv -> [(Name,TyThing)] -> PackageTypeEnv+addDeclsToPTE pte things = extendNameEnvList pte things++loadDecls :: Bool+          -> [(Fingerprint, IfaceDecl)]+          -> IfL [(Name,TyThing)]+loadDecls ignore_prags ver_decls+   = do { thingss <- mapM (loadDecl ignore_prags) ver_decls+        ; return (concat thingss)+        }++loadDecl :: Bool                    -- Don't load pragmas into the decl pool+          -> (Fingerprint, IfaceDecl)+          -> IfL [(Name,TyThing)]   -- The list can be poked eagerly, but the+                                    -- TyThings are forkM'd thunks+loadDecl ignore_prags (_version, decl)+  = do  {       -- Populate the name cache with final versions of all+                -- the names associated with the decl+          let main_name = ifName decl++        -- Typecheck the thing, lazily+        -- NB. Firstly, the laziness is there in case we never need the+        -- declaration (in one-shot mode), and secondly it is there so that+        -- we don't look up the occurrence of a name before calling mk_new_bndr+        -- on the binder.  This is important because we must get the right name+        -- which includes its nameParent.++        ; thing <- forkM doc $ do { bumpDeclStats main_name+                                  ; tcIfaceDecl ignore_prags decl }++        -- Populate the type environment with the implicitTyThings too.+        --+        -- Note [Tricky iface loop]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~+        -- Summary: The delicate point here is that 'mini-env' must be+        -- buildable from 'thing' without demanding any of the things+        -- 'forkM'd by tcIfaceDecl.+        --+        -- In more detail: Consider the example+        --      data T a = MkT { x :: T a }+        -- The implicitTyThings of T are:  [ <datacon MkT>, <selector x>]+        -- (plus their workers, wrappers, coercions etc etc)+        --+        -- We want to return an environment+        --      [ "MkT" -> <datacon MkT>, "x" -> <selector x>, ... ]+        -- (where the "MkT" is the *Name* associated with MkT, etc.)+        --+        -- We do this by mapping the implicit_names to the associated+        -- TyThings.  By the invariant on ifaceDeclImplicitBndrs and+        -- implicitTyThings, we can use getOccName on the implicit+        -- TyThings to make this association: each Name's OccName should+        -- be the OccName of exactly one implicitTyThing.  So the key is+        -- to define a "mini-env"+        --+        -- [ 'MkT' -> <datacon MkT>, 'x' -> <selector x>, ... ]+        -- where the 'MkT' here is the *OccName* associated with MkT.+        --+        -- However, there is a subtlety: due to how type checking needs+        -- to be staged, we can't poke on the forkM'd thunks inside the+        -- implicitTyThings while building this mini-env.+        -- If we poke these thunks too early, two problems could happen:+        --    (1) When processing mutually recursive modules across+        --        hs-boot boundaries, poking too early will do the+        --        type-checking before the recursive knot has been tied,+        --        so things will be type-checked in the wrong+        --        environment, and necessary variables won't be in+        --        scope.+        --+        --    (2) Looking up one OccName in the mini_env will cause+        --        others to be looked up, which might cause that+        --        original one to be looked up again, and hence loop.+        --+        -- The code below works because of the following invariant:+        -- getOccName on a TyThing does not force the suspended type+        -- checks in order to extract the name. For example, we don't+        -- poke on the "T a" type of <selector x> on the way to+        -- extracting <selector x>'s OccName. Of course, there is no+        -- reason in principle why getting the OccName should force the+        -- thunks, but this means we need to be careful in+        -- implicitTyThings and its helper functions.+        --+        -- All a bit too finely-balanced for my liking.++        -- This mini-env and lookup function mediates between the+        --'Name's n and the map from 'OccName's to the implicit TyThings+        ; let mini_env = mkOccEnv [(getOccName t, t) | t <- implicitTyThings thing]+              lookup n = case lookupOccEnv mini_env (getOccName n) of+                           Just thing -> thing+                           Nothing    ->+                             pprPanic "loadDecl" (ppr main_name <+> ppr n $$ ppr (decl))++        ; implicit_names <- mapM lookupIfaceTop (ifaceDeclImplicitBndrs decl)++--         ; traceIf (text "Loading decl for " <> ppr main_name $$ ppr implicit_names)+        ; return $ (main_name, thing) :+                      -- uses the invariant that implicit_names and+                      -- implicitTyThings are bijective+                      [(n, lookup n) | n <- implicit_names]+        }+  where+    doc = text "Declaration for" <+> ppr (ifName decl)++bumpDeclStats :: Name -> IfL ()         -- Record that one more declaration has actually been used+bumpDeclStats name+  = do  { traceIf (text "Loading decl for" <+> ppr name)+        ; updateEps_ (\eps -> let stats = eps_stats eps+                              in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } })+        }++{-+*********************************************************+*                                                      *+\subsection{Reading an interface file}+*                                                      *+*********************************************************++Note [Home module load error]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the sought-for interface is in the current package (as determined+by -package-name flag) then it jolly well should already be in the HPT+because we process home-package modules in dependency order.  (Except+in one-shot mode; see notes with hsc_HPT decl in HscTypes).++It is possible (though hard) to get this error through user behaviour.+  * Suppose package P (modules P1, P2) depends on package Q (modules Q1,+    Q2, with Q2 importing Q1)+  * We compile both packages.+  * Now we edit package Q so that it somehow depends on P+  * Now recompile Q with --make (without recompiling P).+  * Then Q1 imports, say, P1, which in turn depends on Q2. So Q2+    is a home-package module which is not yet in the HPT!  Disaster.++This actually happened with P=base, Q=ghc-prim, via the AMP warnings.+See #8320.+-}++findAndReadIface :: SDoc+                 -- The unique identifier of the on-disk module we're+                 -- looking for+                 -> InstalledModule+                 -- The *actual* module we're looking for.  We use+                 -- this to check the consistency of the requirements+                 -- of the module we read out.+                 -> Module+                 -> IsBootInterface     -- True  <=> Look for a .hi-boot file+                                        -- False <=> Look for .hi file+                 -> TcRnIf gbl lcl (MaybeErr MsgDoc (ModIface, FilePath))+        -- Nothing <=> file not found, or unreadable, or illegible+        -- Just x  <=> successfully found and parsed++        -- It *doesn't* add an error to the monad, because+        -- sometimes it's ok to fail... see notes with loadInterface+findAndReadIface doc_str mod wanted_mod_with_insts hi_boot_file+  = do traceIf (sep [hsep [text "Reading",+                           if hi_boot_file+                             then text "[boot]"+                             else Outputable.empty,+                           text "interface for",+                           ppr mod <> semi],+                     nest 4 (text "reason:" <+> doc_str)])++       -- Check for GHC.Prim, and return its static interface+       -- TODO: make this check a function+       if mod `installedModuleEq` gHC_PRIM+           then do+               iface <- getHooked ghcPrimIfaceHook ghcPrimIface+               return (Succeeded (iface,+                                   "<built in interface for GHC.Prim>"))+           else do+               dflags <- getDynFlags+               -- Look for the file+               hsc_env <- getTopEnv+               mb_found <- liftIO (findExactModule hsc_env mod)+               case mb_found of+                   InstalledFound loc mod -> do+                       -- Found file, so read it+                       let file_path = addBootSuffix_maybe hi_boot_file+                                                           (ml_hi_file loc)++                       -- See Note [Home module load error]+                       if installedModuleUnitId mod `installedUnitIdEq` thisPackage dflags &&+                          not (isOneShot (ghcMode dflags))+                           then return (Failed (homeModError mod loc))+                           else do r <- read_file file_path+                                   checkBuildDynamicToo r+                                   return r+                   err -> do+                       traceIf (text "...not found")+                       dflags <- getDynFlags+                       return (Failed (cannotFindInterface dflags+                                           (installedModuleName mod) err))+    where read_file file_path = do+              traceIf (text "readIFace" <+> text file_path)+              -- Figure out what is recorded in mi_module.  If this is+              -- a fully definite interface, it'll match exactly, but+              -- if it's indefinite, the inside will be uninstantiated!+              dflags <- getDynFlags+              let wanted_mod =+                    case splitModuleInsts wanted_mod_with_insts of+                        (_, Nothing) -> wanted_mod_with_insts+                        (_, Just indef_mod) ->+                          indefModuleToModule dflags+                            (generalizeIndefModule indef_mod)+              read_result <- readIface wanted_mod file_path+              case read_result of+                Failed err -> return (Failed (badIfaceFile file_path err))+                Succeeded iface -> return (Succeeded (iface, file_path))+                            -- Don't forget to fill in the package name...+          checkBuildDynamicToo (Succeeded (iface, filePath)) = do+              dflags <- getDynFlags+              -- Indefinite interfaces are ALWAYS non-dynamic, and+              -- that's OK.+              let is_definite_iface = moduleIsDefinite (mi_module iface)+              when is_definite_iface $+                whenGeneratingDynamicToo dflags $ withDoDynamicToo $ do+                  let ref = canGenerateDynamicToo dflags+                      dynFilePath = addBootSuffix_maybe hi_boot_file+                                  $ replaceExtension filePath (dynHiSuf dflags)+                  r <- read_file dynFilePath+                  case r of+                      Succeeded (dynIface, _)+                       | mi_mod_hash iface == mi_mod_hash dynIface ->+                          return ()+                       | otherwise ->+                          do traceIf (text "Dynamic hash doesn't match")+                             liftIO $ writeIORef ref False+                      Failed err ->+                          do traceIf (text "Failed to load dynamic interface file:" $$ err)+                             liftIO $ writeIORef ref False+          checkBuildDynamicToo _ = return ()++-- @readIface@ tries just the one file.++readIface :: Module -> FilePath+          -> TcRnIf gbl lcl (MaybeErr MsgDoc ModIface)+        -- Failed err    <=> file not found, or unreadable, or illegible+        -- Succeeded iface <=> successfully found and parsed++readIface wanted_mod file_path+  = do  { res <- tryMostM $+                 readBinIface CheckHiWay QuietBinIFaceReading file_path+        ; dflags <- getDynFlags+        ; case res of+            Right iface+                -- NB: This check is NOT just a sanity check, it is+                -- critical for correctness of recompilation checking+                -- (it lets us tell when -this-unit-id has changed.)+                | wanted_mod == actual_mod+                                -> return (Succeeded iface)+                | otherwise     -> return (Failed err)+                where+                  actual_mod = mi_module iface+                  err = hiModuleNameMismatchWarn dflags wanted_mod actual_mod++            Left exn    -> return (Failed (text (showException exn)))+    }++{-+*********************************************************+*                                                       *+        Wired-in interface for GHC.Prim+*                                                       *+*********************************************************+-}++initExternalPackageState :: ExternalPackageState+initExternalPackageState+  = EPS {+      eps_is_boot          = emptyUFM,+      eps_PIT              = emptyPackageIfaceTable,+      eps_free_holes       = emptyInstalledModuleEnv,+      eps_PTE              = emptyTypeEnv,+      eps_inst_env         = emptyInstEnv,+      eps_fam_inst_env     = emptyFamInstEnv,+      eps_rule_base        = mkRuleBase builtinRules,+        -- Initialise the EPS rule pool with the built-in rules+      eps_mod_fam_inst_env+                           = emptyModuleEnv,+      eps_complete_matches = emptyUFM,+      eps_ann_env          = emptyAnnEnv,+      eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0+                           , n_insts_in = 0, n_insts_out = 0+                           , n_rules_in = length builtinRules, n_rules_out = 0 }+    }++{-+*********************************************************+*                                                       *+        Wired-in interface for GHC.Prim+*                                                       *+*********************************************************+-}++ghcPrimIface :: ModIface+ghcPrimIface+  = (emptyModIface gHC_PRIM) {+        mi_exports  = ghcPrimExports,+        mi_decls    = [],+        mi_fixities = fixities,+        mi_fix_fn  = mkIfaceFixCache fixities+    }+  where+    -- The fixities listed here for @`seq`@ or @->@ should match+    -- those in primops.txt.pp (from which Haddock docs are generated).+    fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR)+             : (occName funTyConName, funTyFixity)  -- trac #10145+             : mapMaybe mkFixity allThePrimOps+    mkFixity op = (,) (primOpOcc op) <$> primOpFixity op++{-+*********************************************************+*                                                      *+\subsection{Statistics}+*                                                      *+*********************************************************+-}++ifaceStats :: ExternalPackageState -> SDoc+ifaceStats eps+  = hcat [text "Renamer stats: ", msg]+  where+    stats = eps_stats eps+    msg = vcat+        [int (n_ifaces_in stats) <+> text "interfaces read",+         hsep [ int (n_decls_out stats), text "type/class/variable imported, out of",+                int (n_decls_in stats), text "read"],+         hsep [ int (n_insts_out stats), text "instance decls imported, out of",+                int (n_insts_in stats), text "read"],+         hsep [ int (n_rules_out stats), text "rule decls imported, out of",+                int (n_rules_in stats), text "read"]+        ]++{-+************************************************************************+*                                                                      *+                Printing interfaces+*                                                                      *+************************************************************************++Note [Name qualification with --show-iface]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In order to disambiguate between identifiers from different modules, we qualify+all names that don't originate in the current module. In order to keep visual+noise as low as possible, we keep local names unqualified.++For some background on this choice see trac #15269.+-}++-- | Read binary interface, and print it out+showIface :: HscEnv -> FilePath -> IO ()+showIface hsc_env filename = do+   -- skip the hi way check; we don't want to worry about profiled vs.+   -- non-profiled interfaces, for example.+   iface <- initTcRnIf 's' hsc_env () () $+       readBinIface IgnoreHiWay TraceBinIFaceReading filename+   let dflags = hsc_dflags hsc_env+       -- See Note [Name qualification with --show-iface]+       qualifyImportedNames mod _+           | mod == mi_module iface = NameUnqual+           | otherwise              = NameNotInScope1+       print_unqual = QueryQualify qualifyImportedNames+                                   neverQualifyModules+                                   neverQualifyPackages+   putLogMsg dflags NoReason SevDump noSrcSpan+      (mkDumpStyle dflags print_unqual) (pprModIface iface)++-- Show a ModIface but don't display details; suitable for ModIfaces stored in+-- the EPT.+pprModIfaceSimple :: ModIface -> SDoc+pprModIfaceSimple iface = ppr (mi_module iface) $$ pprDeps (mi_deps iface) $$ nest 2 (vcat (map pprExport (mi_exports iface)))++pprModIface :: ModIface -> SDoc+-- Show a ModIface+pprModIface iface+ = vcat [ text "interface"+                <+> ppr (mi_module iface) <+> pp_hsc_src (mi_hsc_src iface)+                <+> (if mi_orphan iface then text "[orphan module]" else Outputable.empty)+                <+> (if mi_finsts iface then text "[family instance module]" else Outputable.empty)+                <+> (if mi_hpc    iface then text "[hpc]" else Outputable.empty)+                <+> integer hiVersion+        , nest 2 (text "interface hash:" <+> ppr (mi_iface_hash iface))+        , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface))+        , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface))+        , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface))+        , nest 2 (text "flag hash:" <+> ppr (mi_flag_hash iface))+        , nest 2 (text "opt_hash:" <+> ppr (mi_opt_hash iface))+        , nest 2 (text "hpc_hash:" <+> ppr (mi_hpc_hash iface))+        , nest 2 (text "plugin_hash:" <+> ppr (mi_plugin_hash iface))+        , nest 2 (text "sig of:" <+> ppr (mi_sig_of iface))+        , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface))+        , nest 2 (text "where")+        , text "exports:"+        , nest 2 (vcat (map pprExport (mi_exports iface)))+        , pprDeps (mi_deps iface)+        , vcat (map pprUsage (mi_usages iface))+        , vcat (map pprIfaceAnnotation (mi_anns iface))+        , pprFixities (mi_fixities iface)+        , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface]+        , vcat (map ppr (mi_insts iface))+        , vcat (map ppr (mi_fam_insts iface))+        , vcat (map ppr (mi_rules iface))+        , ppr (mi_warns iface)+        , pprTrustInfo (mi_trust iface)+        , pprTrustPkg (mi_trust_pkg iface)+        , vcat (map ppr (mi_complete_sigs iface))+        , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface))+        , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface))+        , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface))+        ]+  where+    pp_hsc_src HsBootFile = text "[boot]"+    pp_hsc_src HsigFile = text "[hsig]"+    pp_hsc_src HsSrcFile = Outputable.empty++{-+When printing export lists, we print like this:+        Avail   f               f+        AvailTC C [C, x, y]     C(x,y)+        AvailTC C [x, y]        C!(x,y)         -- Exporting x, y but not C+-}++pprExport :: IfaceExport -> SDoc+pprExport (Avail n)         = ppr n+pprExport (AvailTC _ [] []) = Outputable.empty+pprExport (AvailTC n ns0 fs)+  = case ns0 of+      (n':ns) | n==n' -> ppr n <> pp_export ns fs+      _               -> ppr n <> vbar <> pp_export ns0 fs+  where+    pp_export []    [] = Outputable.empty+    pp_export names fs = braces (hsep (map ppr names ++ map (ppr . flLabel) fs))++pprUsage :: Usage -> SDoc+pprUsage usage@UsagePackageModule{}+  = pprUsageImport usage usg_mod+pprUsage usage@UsageHomeModule{}+  = pprUsageImport usage usg_mod_name $$+    nest 2 (+        maybe Outputable.empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$+        vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]+        )+pprUsage usage@UsageFile{}+  = hsep [text "addDependentFile",+          doubleQuotes (text (usg_file_path usage)),+          ppr (usg_file_hash usage)]+pprUsage usage@UsageMergedRequirement{}+  = hsep [text "merged", ppr (usg_mod usage), ppr (usg_mod_hash usage)]++pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc+pprUsageImport usage usg_mod'+  = hsep [text "import", safe, ppr (usg_mod' usage),+                       ppr (usg_mod_hash usage)]+    where+        safe | usg_safe usage = text "safe"+             | otherwise      = text " -/ "++pprDeps :: Dependencies -> SDoc+pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,+                dep_finsts = finsts })+  = vcat [text "module dependencies:" <+> fsep (map ppr_mod mods),+          text "package dependencies:" <+> fsep (map ppr_pkg pkgs),+          text "orphans:" <+> fsep (map ppr orphs),+          text "family instance modules:" <+> fsep (map ppr finsts)+        ]+  where+    ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot+    ppr_pkg (pkg,trust_req)  = ppr pkg <>+                               (if trust_req then text "*" else Outputable.empty)+    ppr_boot True  = text "[boot]"+    ppr_boot False = Outputable.empty++pprFixities :: [(OccName, Fixity)] -> SDoc+pprFixities []    = Outputable.empty+pprFixities fixes = text "fixities" <+> pprWithCommas pprFix fixes+                  where+                    pprFix (occ,fix) = ppr fix <+> ppr occ++pprTrustInfo :: IfaceTrustInfo -> SDoc+pprTrustInfo trust = text "trusted:" <+> ppr trust++pprTrustPkg :: Bool -> SDoc+pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg++instance Outputable Warnings where+    ppr = pprWarns++pprWarns :: Warnings -> SDoc+pprWarns NoWarnings         = Outputable.empty+pprWarns (WarnAll txt)  = text "Warn all" <+> ppr txt+pprWarns (WarnSome prs) = text "Warnings"+                        <+> vcat (map pprWarning prs)+    where pprWarning (name, txt) = ppr name <+> ppr txt++pprIfaceAnnotation :: IfaceAnnotation -> SDoc+pprIfaceAnnotation (IfaceAnnotation { ifAnnotatedTarget = target, ifAnnotatedValue = serialized })+  = ppr target <+> text "annotated by" <+> ppr serialized++{-+*********************************************************+*                                                       *+\subsection{Errors}+*                                                       *+*********************************************************+-}++badIfaceFile :: String -> SDoc -> SDoc+badIfaceFile file err+  = vcat [text "Bad interface file:" <+> text file,+          nest 4 err]++hiModuleNameMismatchWarn :: DynFlags -> Module -> Module -> MsgDoc+hiModuleNameMismatchWarn dflags requested_mod read_mod+ | moduleUnitId requested_mod == moduleUnitId read_mod =+    sep [text "Interface file contains module" <+> quotes (ppr read_mod) <> comma,+         text "but we were expecting module" <+> quotes (ppr requested_mod),+         sep [text "Probable cause: the source code which generated interface file",+             text "has an incompatible module name"+            ]+        ]+ | otherwise =+  -- ToDo: This will fail to have enough qualification when the package IDs+  -- are the same+  withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $+    -- we want the Modules below to be qualified with package names,+    -- so reset the PrintUnqualified setting.+    hsep [ text "Something is amiss; requested module "+         , ppr requested_mod+         , text "differs from name found in the interface file"+         , ppr read_mod+         , parens (text "if these names look the same, try again with -dppr-debug")+         ]++homeModError :: InstalledModule -> ModLocation -> SDoc+-- See Note [Home module load error]+homeModError mod location+  = text "attempting to use module " <> quotes (ppr mod)+    <> (case ml_hs_file location of+           Just file -> space <> parens (text file)+           Nothing   -> Outputable.empty)+    <+> text "which is not loaded"
+ compiler/iface/LoadIface.hs-boot view
@@ -0,0 +1,7 @@+module LoadIface where+import Module (Module)+import TcRnMonad (IfM)+import HscTypes (ModIface)+import Outputable (SDoc)++loadSysInterface :: SDoc -> Module -> IfM lcl ModIface
+ compiler/iface/MkIface.hs view
@@ -0,0 +1,2034 @@+{-+(c) The University of Glasgow 2006-2008+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998+-}++{-# LANGUAGE CPP, NondecreasingIndentation #-}+{-# LANGUAGE MultiWayIf #-}++-- | Module for constructing @ModIface@ values (interface files),+-- writing them to disk and comparing two versions to see if+-- recompilation is required.+module MkIface (+        mkIface,        -- Build a ModIface from a ModGuts,+                        -- including computing version information++        mkIfaceTc,++        writeIfaceFile, -- Write the interface file++        checkOldIface,  -- See if recompilation is required, by+                        -- comparing version information+        RecompileRequired(..), recompileRequired,+        mkIfaceExports,++        coAxiomToIfaceDecl,+        tyThingToIfaceDecl -- Converting things to their Iface equivalents+ ) where++{-+  -----------------------------------------------+          Recompilation checking+  -----------------------------------------------++A complete description of how recompilation checking works can be+found in the wiki commentary:++ https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance++Please read the above page for a top-down description of how this all+works.  Notes below cover specific issues related to the implementation.++Basic idea:++  * In the mi_usages information in an interface, we record the+    fingerprint of each free variable of the module++  * In mkIface, we compute the fingerprint of each exported thing A.f.+    For each external thing that A.f refers to, we include the fingerprint+    of the external reference when computing the fingerprint of A.f.  So+    if anything that A.f depends on changes, then A.f's fingerprint will+    change.+    Also record any dependent files added with+      * addDependentFile+      * #include+      * -optP-include++  * In checkOldIface we compare the mi_usages for the module with+    the actual fingerprint for all each thing recorded in mi_usages+-}++#include "HsVersions.h"++import GhcPrelude++import IfaceSyn+import BinFingerprint+import LoadIface+import ToIface+import FlagChecker++import DsUsage ( mkUsageInfo, mkUsedNames, mkDependencies )+import Id+import Annotations+import CoreSyn+import Class+import TyCon+import CoAxiom+import ConLike+import DataCon+import Type+import TcType+import InstEnv+import FamInstEnv+import TcRnMonad+import HsSyn+import HscTypes+import Finder+import DynFlags+import VarEnv+import Var+import Name+import Avail+import RdrName+import NameEnv+import NameSet+import Module+import BinIface+import ErrUtils+import Digraph+import SrcLoc+import Outputable+import BasicTypes       hiding ( SuccessFlag(..) )+import Unique+import Util             hiding ( eqListBy )+import FastString+import Maybes+import Binary+import Fingerprint+import Exception+import UniqSet+import Packages+import ExtractDocs++import Control.Monad+import Data.Function+import Data.List+import qualified Data.Map as Map+import Data.Ord+import Data.IORef+import System.Directory+import System.FilePath+import Plugins ( PluginRecompile(..), PluginWithArgs(..), LoadedPlugin(..),+                 pluginRecompile', plugins )++--Qualified import so we can define a Semigroup instance+-- but it doesn't clash with Outputable.<>+import qualified Data.Semigroup++{-+************************************************************************+*                                                                      *+\subsection{Completing an interface}+*                                                                      *+************************************************************************+-}++mkIface :: HscEnv+        -> Maybe Fingerprint    -- The old fingerprint, if we have it+        -> ModDetails           -- The trimmed, tidied interface+        -> ModGuts              -- Usages, deprecations, etc+        -> IO (ModIface, -- The new one+               Bool)     -- True <=> there was an old Iface, and the+                         --          new one is identical, so no need+                         --          to write it++mkIface hsc_env maybe_old_fingerprint mod_details+         ModGuts{     mg_module       = this_mod,+                      mg_hsc_src      = hsc_src,+                      mg_usages       = usages,+                      mg_used_th      = used_th,+                      mg_deps         = deps,+                      mg_rdr_env      = rdr_env,+                      mg_fix_env      = fix_env,+                      mg_warns        = warns,+                      mg_hpc_info     = hpc_info,+                      mg_safe_haskell = safe_mode,+                      mg_trust_pkg    = self_trust,+                      mg_doc_hdr      = doc_hdr,+                      mg_decl_docs    = decl_docs,+                      mg_arg_docs     = arg_docs+                    }+        = mkIface_ hsc_env maybe_old_fingerprint+                   this_mod hsc_src used_th deps rdr_env fix_env+                   warns hpc_info self_trust+                   safe_mode usages+                   doc_hdr decl_docs arg_docs+                   mod_details++-- | make an interface from the results of typechecking only.  Useful+-- for non-optimising compilation, or where we aren't generating any+-- object code at all ('HscNothing').+mkIfaceTc :: HscEnv+          -> Maybe Fingerprint  -- The old fingerprint, if we have it+          -> SafeHaskellMode    -- The safe haskell mode+          -> ModDetails         -- gotten from mkBootModDetails, probably+          -> TcGblEnv           -- Usages, deprecations, etc+          -> IO (ModIface, Bool)+mkIfaceTc hsc_env maybe_old_fingerprint safe_mode mod_details+  tc_result@TcGblEnv{ tcg_mod = this_mod,+                      tcg_src = hsc_src,+                      tcg_imports = imports,+                      tcg_rdr_env = rdr_env,+                      tcg_fix_env = fix_env,+                      tcg_merged = merged,+                      tcg_warns = warns,+                      tcg_hpc = other_hpc_info,+                      tcg_th_splice_used = tc_splice_used,+                      tcg_dependent_files = dependent_files+                    }+  = do+          let used_names = mkUsedNames tc_result+          let pluginModules =+                map lpModule (cachedPlugins (hsc_dflags hsc_env))+          deps <- mkDependencies+                    (thisInstalledUnitId (hsc_dflags hsc_env))+                    (map mi_module pluginModules) tc_result+          let hpc_info = emptyHpcInfo other_hpc_info+          used_th <- readIORef tc_splice_used+          dep_files <- (readIORef dependent_files)+          -- Do NOT use semantic module here; this_mod in mkUsageInfo+          -- is used solely to decide if we should record a dependency+          -- or not.  When we instantiate a signature, the semantic+          -- module is something we want to record dependencies for,+          -- but if you pass that in here, we'll decide it's the local+          -- module and does not need to be recorded as a dependency.+          -- See Note [Identity versus semantic module]+          usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names+                      dep_files merged pluginModules++          let (doc_hdr', doc_map, arg_map) = extractDocs tc_result++          mkIface_ hsc_env maybe_old_fingerprint+                   this_mod hsc_src+                   used_th deps rdr_env+                   fix_env warns hpc_info+                   (imp_trust_own_pkg imports) safe_mode usages+                   doc_hdr' doc_map arg_map+                   mod_details++++mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> HscSource+         -> Bool -> Dependencies -> GlobalRdrEnv+         -> NameEnv FixItem -> Warnings -> HpcInfo+         -> Bool+         -> SafeHaskellMode+         -> [Usage]+         -> Maybe HsDocString+         -> DeclDocMap+         -> ArgDocMap+         -> ModDetails+         -> IO (ModIface, Bool)+mkIface_ hsc_env maybe_old_fingerprint+         this_mod hsc_src used_th deps rdr_env fix_env src_warns+         hpc_info pkg_trust_req safe_mode usages+         doc_hdr decl_docs arg_docs+         ModDetails{  md_insts     = insts,+                      md_fam_insts = fam_insts,+                      md_rules     = rules,+                      md_anns      = anns,+                      md_types     = type_env,+                      md_exports   = exports,+                      md_complete_sigs = complete_sigs }+-- NB:  notice that mkIface does not look at the bindings+--      only at the TypeEnv.  The previous Tidy phase has+--      put exactly the info into the TypeEnv that we want+--      to expose in the interface++  = do+    let semantic_mod = canonicalizeHomeModule (hsc_dflags hsc_env) (moduleName this_mod)+        entities = typeEnvElts type_env+        decls  = [ tyThingToIfaceDecl entity+                 | entity <- entities,+                   let name = getName entity,+                   not (isImplicitTyThing entity),+                      -- No implicit Ids and class tycons in the interface file+                   not (isWiredInName name),+                      -- Nor wired-in things; the compiler knows about them anyhow+                   nameIsLocalOrFrom semantic_mod name  ]+                      -- Sigh: see Note [Root-main Id] in TcRnDriver+                      -- NB: ABSOLUTELY need to check against semantic_mod,+                      -- because all of the names in an hsig p[H=<H>]:H+                      -- are going to be for <H>, not the former id!+                      -- See Note [Identity versus semantic module]++        fixities    = sortBy (comparing fst)+          [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]+          -- The order of fixities returned from nameEnvElts is not+          -- deterministic, so we sort by OccName to canonicalize it.+          -- See Note [Deterministic UniqFM] in UniqDFM for more details.+        warns       = src_warns+        iface_rules = map coreRuleToIfaceRule rules+        iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts+        iface_fam_insts = map famInstToIfaceFamInst fam_insts+        trust_info  = setSafeMode safe_mode+        annotations = map mkIfaceAnnotation anns+        icomplete_sigs = map mkIfaceCompleteSig complete_sigs++        intermediate_iface = ModIface {+              mi_module      = this_mod,+              -- Need to record this because it depends on the -instantiated-with flag+              -- which could change+              mi_sig_of      = if semantic_mod == this_mod+                                then Nothing+                                else Just semantic_mod,+              mi_hsc_src     = hsc_src,+              mi_deps        = deps,+              mi_usages      = usages,+              mi_exports     = mkIfaceExports exports,++              -- Sort these lexicographically, so that+              -- the result is stable across compilations+              mi_insts       = sortBy cmp_inst     iface_insts,+              mi_fam_insts   = sortBy cmp_fam_inst iface_fam_insts,+              mi_rules       = sortBy cmp_rule     iface_rules,++              mi_fixities    = fixities,+              mi_warns       = warns,+              mi_anns        = annotations,+              mi_globals     = maybeGlobalRdrEnv rdr_env,++              -- Left out deliberately: filled in by addFingerprints+              mi_iface_hash  = fingerprint0,+              mi_mod_hash    = fingerprint0,+              mi_flag_hash   = fingerprint0,+              mi_opt_hash    = fingerprint0,+              mi_hpc_hash    = fingerprint0,+              mi_exp_hash    = fingerprint0,+              mi_plugin_hash = fingerprint0,+              mi_used_th     = used_th,+              mi_orphan_hash = fingerprint0,+              mi_orphan      = False, -- Always set by addFingerprints, but+                                      -- it's a strict field, so we can't omit it.+              mi_finsts      = False, -- Ditto+              mi_decls       = deliberatelyOmitted "decls",+              mi_hash_fn     = deliberatelyOmitted "hash_fn",+              mi_hpc         = isHpcUsed hpc_info,+              mi_trust       = trust_info,+              mi_trust_pkg   = pkg_trust_req,++              -- And build the cached values+              mi_warn_fn     = mkIfaceWarnCache warns,+              mi_fix_fn      = mkIfaceFixCache fixities,+              mi_complete_sigs = icomplete_sigs,+              mi_doc_hdr     = doc_hdr,+              mi_decl_docs   = decl_docs,+              mi_arg_docs    = arg_docs }++    (new_iface, no_change_at_all)+          <- {-# SCC "versioninfo" #-}+                   addFingerprints hsc_env maybe_old_fingerprint+                                   intermediate_iface decls++    -- Debug printing+    dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE"+                  (pprModIface new_iface)++    -- bug #1617: on reload we weren't updating the PrintUnqualified+    -- correctly.  This stems from the fact that the interface had+    -- not changed, so addFingerprints returns the old ModIface+    -- with the old GlobalRdrEnv (mi_globals).+    let final_iface = new_iface{ mi_globals = maybeGlobalRdrEnv rdr_env }++    return (final_iface, no_change_at_all)+  where+     cmp_rule     = comparing ifRuleName+     -- Compare these lexicographically by OccName, *not* by unique,+     -- because the latter is not stable across compilations:+     cmp_inst     = comparing (nameOccName . ifDFun)+     cmp_fam_inst = comparing (nameOccName . ifFamInstTcName)++     dflags = hsc_dflags hsc_env++     -- We only fill in mi_globals if the module was compiled to byte+     -- code.  Otherwise, the compiler may not have retained all the+     -- top-level bindings and they won't be in the TypeEnv (see+     -- Desugar.addExportFlagsAndRules).  The mi_globals field is used+     -- by GHCi to decide whether the module has its full top-level+     -- scope available. (#5534)+     maybeGlobalRdrEnv :: GlobalRdrEnv -> Maybe GlobalRdrEnv+     maybeGlobalRdrEnv rdr_env+         | targetRetainsAllBindings (hscTarget dflags) = Just rdr_env+         | otherwise                                   = Nothing++     deliberatelyOmitted :: String -> a+     deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x)++     ifFamInstTcName = ifFamInstFam++-----------------------------+writeIfaceFile :: DynFlags -> FilePath -> ModIface -> IO ()+writeIfaceFile dflags hi_file_path new_iface+    = do createDirectoryIfMissing True (takeDirectory hi_file_path)+         writeBinIface dflags hi_file_path new_iface+++-- -----------------------------------------------------------------------------+-- Look up parents and versions of Names++-- This is like a global version of the mi_hash_fn field in each ModIface.+-- Given a Name, it finds the ModIface, and then uses mi_hash_fn to get+-- the parent and version info.++mkHashFun+        :: HscEnv                       -- needed to look up versions+        -> ExternalPackageState         -- ditto+        -> (Name -> IO Fingerprint)+mkHashFun hsc_env eps name+  | isHoleModule orig_mod+  = lookup (mkModule (thisPackage dflags) (moduleName orig_mod))+  | otherwise+  = lookup orig_mod+  where+      dflags = hsc_dflags hsc_env+      hpt = hsc_HPT hsc_env+      pit = eps_PIT eps+      occ = nameOccName name+      orig_mod = nameModule name+      lookup mod = do+        MASSERT2( isExternalName name, ppr name )+        iface <- case lookupIfaceByModule dflags hpt pit mod of+                  Just iface -> return iface+                  Nothing -> do+                      -- This can occur when we're writing out ifaces for+                      -- requirements; we didn't do any /real/ typechecking+                      -- so there's no guarantee everything is loaded.+                      -- Kind of a heinous hack.+                      iface <- initIfaceLoad hsc_env . withException+                            $ loadInterface (text "lookupVers2") mod ImportBySystem+                      return iface+        return $ snd (mi_hash_fn iface occ `orElse`+                  pprPanic "lookupVers1" (ppr mod <+> ppr occ))++-- ---------------------------------------------------------------------------+-- Compute fingerprints for the interface++{-+Note [Fingerprinting IfaceDecls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The general idea here is that we first examine the 'IfaceDecl's and determine+the recursive groups of them. We then walk these groups in dependency order,+serializing each contained 'IfaceDecl' to a "Binary" buffer which we then+hash using MD5 to produce a fingerprint for the group.++However, the serialization that we use is a bit funny: we override the @putName@+operation with our own which serializes the hash of a 'Name' instead of the+'Name' itself. This ensures that the fingerprint of a decl changes if anything+in its transitive closure changes. This trick is why we must be careful about+traversing in dependency order: we need to ensure that we have hashes for+everything referenced by the decl which we are fingerprinting.++Moreover, we need to be careful to distinguish between serialization of binding+Names (e.g. the ifName field of a IfaceDecl) and non-binding (e.g. the ifInstCls+field of a IfaceClsInst): only in the non-binding case should we include the+fingerprint; in the binding case we shouldn't since it is merely the name of the+thing that we are currently fingerprinting.+-}++-- | Add fingerprints for top-level declarations to a 'ModIface'.+--+-- See Note [Fingerprinting IfaceDecls]+addFingerprints+        :: HscEnv+        -> Maybe Fingerprint -- the old fingerprint, if any+        -> ModIface          -- The new interface (lacking decls)+        -> [IfaceDecl]       -- The new decls+        -> IO (ModIface,     -- Updated interface+               Bool)         -- True <=> no changes at all;+                             -- no need to write Iface++addFingerprints hsc_env mb_old_fingerprint iface0 new_decls+ = do+   eps <- hscEPS hsc_env+   let+        -- The ABI of a declaration represents everything that is made+        -- visible about the declaration that a client can depend on.+        -- see IfaceDeclABI below.+       declABI :: IfaceDecl -> IfaceDeclABI+       -- TODO: I'm not sure if this should be semantic_mod or this_mod.+       -- See also Note [Identity versus semantic module]+       declABI decl = (this_mod, decl, extras)+        where extras = declExtras fix_fn ann_fn non_orph_rules non_orph_insts+                                  non_orph_fis top_lvl_name_env decl++       -- This is used for looking up the Name of a default method+       -- from its OccName. See Note [default method Name]+       top_lvl_name_env =+         mkOccEnv [ (nameOccName nm, nm)+                  | IfaceId { ifName = nm } <- new_decls ]++       -- Dependency edges between declarations in the current module.+       -- This is computed by finding the free external names of each+       -- declaration, including IfaceDeclExtras (things that a+       -- declaration implicitly depends on).+       edges :: [ Node Unique IfaceDeclABI ]+       edges = [ DigraphNode abi (getUnique (getOccName decl)) out+               | decl <- new_decls+               , let abi = declABI decl+               , let out = localOccs $ freeNamesDeclABI abi+               ]++       name_module n = ASSERT2( isExternalName n, ppr n ) nameModule n+       localOccs =+         map (getUnique . getParent . getOccName)+                        -- NB: names always use semantic module, so+                        -- filtering must be on the semantic module!+                        -- See Note [Identity versus semantic module]+                        . filter ((== semantic_mod) . name_module)+                        . nonDetEltsUniqSet+                   -- It's OK to use nonDetEltsUFM as localOccs is only+                   -- used to construct the edges and+                   -- stronglyConnCompFromEdgedVertices is deterministic+                   -- even with non-deterministic order of edges as+                   -- explained in Note [Deterministic SCC] in Digraph.+          where getParent :: OccName -> OccName+                getParent occ = lookupOccEnv parent_map occ `orElse` occ++        -- maps OccNames to their parents in the current module.+        -- e.g. a reference to a constructor must be turned into a reference+        -- to the TyCon for the purposes of calculating dependencies.+       parent_map :: OccEnv OccName+       parent_map = foldl' extend emptyOccEnv new_decls+          where extend env d =+                  extendOccEnvList env [ (b,n) | b <- ifaceDeclImplicitBndrs d ]+                  where n = getOccName d++        -- Strongly-connected groups of declarations, in dependency order+       groups :: [SCC IfaceDeclABI]+       groups = stronglyConnCompFromEdgedVerticesUniq edges++       global_hash_fn = mkHashFun hsc_env eps++        -- How to output Names when generating the data to fingerprint.+        -- Here we want to output the fingerprint for each top-level+        -- Name, whether it comes from the current module or another+        -- module.  In this way, the fingerprint for a declaration will+        -- change if the fingerprint for anything it refers to (transitively)+        -- changes.+       mk_put_name :: OccEnv (OccName,Fingerprint)+                   -> BinHandle -> Name -> IO  ()+       mk_put_name local_env bh name+          | isWiredInName name  =  putNameLiterally bh name+           -- wired-in names don't have fingerprints+          | otherwise+          = ASSERT2( isExternalName name, ppr name )+            let hash | nameModule name /= semantic_mod =  global_hash_fn name+                     -- Get it from the REAL interface!!+                     -- This will trigger when we compile an hsig file+                     -- and we know a backing impl for it.+                     -- See Note [Identity versus semantic module]+                     | semantic_mod /= this_mod+                     , not (isHoleModule semantic_mod) = global_hash_fn name+                     | otherwise = return (snd (lookupOccEnv local_env (getOccName name)+                           `orElse` pprPanic "urk! lookup local fingerprint"+                                       (ppr name $$ ppr local_env)))+                -- This panic indicates that we got the dependency+                -- analysis wrong, because we needed a fingerprint for+                -- an entity that wasn't in the environment.  To debug+                -- it, turn the panic into a trace, uncomment the+                -- pprTraces below, run the compile again, and inspect+                -- the output and the generated .hi file with+                -- --show-iface.+            in hash >>= put_ bh++        -- take a strongly-connected group of declarations and compute+        -- its fingerprint.++       fingerprint_group :: (OccEnv (OccName,Fingerprint),+                             [(Fingerprint,IfaceDecl)])+                         -> SCC IfaceDeclABI+                         -> IO (OccEnv (OccName,Fingerprint),+                                [(Fingerprint,IfaceDecl)])++       fingerprint_group (local_env, decls_w_hashes) (AcyclicSCC abi)+          = do let hash_fn = mk_put_name local_env+                   decl = abiDecl abi+               --pprTrace "fingerprinting" (ppr (ifName decl) ) $ do+               hash <- computeFingerprint hash_fn abi+               env' <- extend_hash_env local_env (hash,decl)+               return (env', (hash,decl) : decls_w_hashes)++       fingerprint_group (local_env, decls_w_hashes) (CyclicSCC abis)+          = do let decls = map abiDecl abis+               local_env1 <- foldM extend_hash_env local_env+                                   (zip (repeat fingerprint0) decls)+               let hash_fn = mk_put_name local_env1+               -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do+               let stable_abis = sortBy cmp_abiNames abis+                -- put the cycle in a canonical order+               hash <- computeFingerprint hash_fn stable_abis+               let pairs = zip (repeat hash) decls+               local_env2 <- foldM extend_hash_env local_env pairs+               return (local_env2, pairs ++ decls_w_hashes)++       -- we have fingerprinted the whole declaration, but we now need+       -- to assign fingerprints to all the OccNames that it binds, to+       -- use when referencing those OccNames in later declarations.+       --+       extend_hash_env :: OccEnv (OccName,Fingerprint)+                       -> (Fingerprint,IfaceDecl)+                       -> IO (OccEnv (OccName,Fingerprint))+       extend_hash_env env0 (hash,d) = do+          return (foldr (\(b,fp) env -> extendOccEnv env b (b,fp)) env0+                 (ifaceDeclFingerprints hash d))++   --+   (local_env, decls_w_hashes) <-+       foldM fingerprint_group (emptyOccEnv, []) groups++   -- when calculating fingerprints, we always need to use canonical+   -- ordering for lists of things.  In particular, the mi_deps has various+   -- lists of modules and suchlike, so put these all in canonical order:+   let sorted_deps = sortDependencies (mi_deps iface0)++   -- The export hash of a module depends on the orphan hashes of the+   -- orphan modules below us in the dependency tree.  This is the way+   -- that changes in orphans get propagated all the way up the+   -- dependency tree.+   --+   -- Note [A bad dep_orphs optimization]+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   -- In a previous version of this code, we filtered out orphan modules which+   -- were not from the home package, justifying it by saying that "we'd+   -- pick up the ABI hashes of the external module instead".  This is wrong.+   -- Suppose that we have:+   --+   --       module External where+   --           instance Show (a -> b)+   --+   --       module Home1 where+   --           import External+   --+   --       module Home2 where+   --           import Home1+   --+   -- The export hash of Home1 needs to reflect the orphan instances of+   -- External. It's true that Home1 will get rebuilt if the orphans+   -- of External, but we also need to make sure Home2 gets rebuilt+   -- as well.  See #12733 for more details.+   let orph_mods+        = filter (/= this_mod) -- Note [Do not update EPS with your own hi-boot]+        $ dep_orphs sorted_deps+   dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods++   -- Note [Do not update EPS with your own hi-boot]+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   -- (See also #10182).  When your hs-boot file includes an orphan+   -- instance declaration, you may find that the dep_orphs of a module you+   -- import contains reference to yourself.  DO NOT actually load this module+   -- or add it to the orphan hashes: you're going to provide the orphan+   -- instances yourself, no need to consult hs-boot; if you do load the+   -- interface into EPS, you will see a duplicate orphan instance.++   orphan_hash <- computeFingerprint (mk_put_name local_env)+                                     (map ifDFun orph_insts, orph_rules, orph_fis)++   -- the export list hash doesn't depend on the fingerprints of+   -- the Names it mentions, only the Names themselves, hence putNameLiterally.+   export_hash <- computeFingerprint putNameLiterally+                      (mi_exports iface0,+                       orphan_hash,+                       dep_orphan_hashes,+                       dep_pkgs (mi_deps iface0),+                       -- See Note [Export hash depends on non-orphan family instances]+                       dep_finsts (mi_deps iface0),+                        -- dep_pkgs: see "Package Version Changes" on+                        -- wiki/commentary/compiler/recompilation-avoidance+                       mi_trust iface0)+                        -- Make sure change of Safe Haskell mode causes recomp.++   -- Note [Export hash depends on non-orphan family instances]+   -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   --+   -- Suppose we have:+   --+   --   module A where+   --       type instance F Int = Bool+   --+   --   module B where+   --       import A+   --+   --   module C where+   --       import B+   --+   -- The family instance consistency check for C depends on the dep_finsts of+   -- B.  If we rename module A to A2, when the dep_finsts of B changes, we need+   -- to make sure that C gets rebuilt. Effectively, the dep_finsts are part of+   -- the exports of B, because C always considers them when checking+   -- consistency.+   --+   -- A full discussion is in #12723.+   --+   -- We do NOT need to hash dep_orphs, because this is implied by+   -- dep_orphan_hashes, and we do not need to hash ordinary class instances,+   -- because there is no eager consistency check as there is with type families+   -- (also we didn't store it anywhere!)+   --++   -- put the declarations in a canonical order, sorted by OccName+   let sorted_decls = Map.elems $ Map.fromList $+                          [(getOccName d, e) | e@(_, d) <- decls_w_hashes]++   -- the flag hash depends on:+   --   - (some of) dflags+   -- it returns two hashes, one that shouldn't change+   -- the abi hash and one that should+   flag_hash <- fingerprintDynFlags dflags this_mod putNameLiterally++   opt_hash <- fingerprintOptFlags dflags putNameLiterally++   hpc_hash <- fingerprintHpcFlags dflags putNameLiterally++   plugin_hash <- fingerprintPlugins hsc_env++   -- the ABI hash depends on:+   --   - decls+   --   - export list+   --   - orphans+   --   - deprecations+   --   - flag abi hash+   mod_hash <- computeFingerprint putNameLiterally+                      (map fst sorted_decls,+                       export_hash,  -- includes orphan_hash+                       mi_warns iface0)++   -- The interface hash depends on:+   --   - the ABI hash, plus+   --   - the module level annotations,+   --   - usages+   --   - deps (home and external packages, dependent files)+   --   - hpc+   iface_hash <- computeFingerprint putNameLiterally+                      (mod_hash,+                       ann_fn (mkVarOcc "module"),  -- See mkIfaceAnnCache+                       mi_usages iface0,+                       sorted_deps,+                       mi_hpc iface0)++   let+    no_change_at_all = Just iface_hash == mb_old_fingerprint++    final_iface = iface0 {+                mi_mod_hash    = mod_hash,+                mi_iface_hash  = iface_hash,+                mi_exp_hash    = export_hash,+                mi_orphan_hash = orphan_hash,+                mi_flag_hash   = flag_hash,+                mi_opt_hash    = opt_hash,+                mi_hpc_hash    = hpc_hash,+                mi_plugin_hash = plugin_hash,+                mi_orphan      = not (   all ifRuleAuto orph_rules+                                           -- See Note [Orphans and auto-generated rules]+                                      && null orph_insts+                                      && null orph_fis),+                mi_finsts      = not . null $ mi_fam_insts iface0,+                mi_decls       = sorted_decls,+                mi_hash_fn     = lookupOccEnv local_env }+   --+   return (final_iface, no_change_at_all)++  where+    this_mod = mi_module iface0+    semantic_mod = mi_semantic_module iface0+    dflags = hsc_dflags hsc_env+    (non_orph_insts, orph_insts) = mkOrphMap ifInstOrph    (mi_insts iface0)+    (non_orph_rules, orph_rules) = mkOrphMap ifRuleOrph    (mi_rules iface0)+    (non_orph_fis,   orph_fis)   = mkOrphMap ifFamInstOrph (mi_fam_insts iface0)+    fix_fn = mi_fix_fn iface0+    ann_fn = mkIfaceAnnCache (mi_anns iface0)++-- | Retrieve the orphan hashes 'mi_orphan_hash' for a list of modules+-- (in particular, the orphan modules which are transitively imported by the+-- current module).+--+-- Q: Why do we need the hash at all, doesn't the list of transitively+-- imported orphan modules suffice?+--+-- A: If one of our transitive imports adds a new orphan instance, our+-- export hash must change so that modules which import us rebuild.  If we just+-- hashed the [Module], the hash would not change even when a new instance was+-- added to a module that already had an orphan instance.+--+-- Q: Why don't we just hash the orphan hashes of our direct dependencies?+-- Why the full transitive closure?+--+-- A: Suppose we have these modules:+--+--      module A where+--          instance Show (a -> b) where+--      module B where+--          import A -- **+--      module C where+--          import A+--          import B+--+-- Whether or not we add or remove the import to A in B affects the+-- orphan hash of B.  But it shouldn't really affect the orphan hash+-- of C.  If we hashed only direct dependencies, there would be no+-- way to tell that the net effect was a wash, and we'd be forced+-- to recompile C and everything else.+getOrphanHashes :: HscEnv -> [Module] -> IO [Fingerprint]+getOrphanHashes hsc_env mods = do+  eps <- hscEPS hsc_env+  let+    hpt        = hsc_HPT hsc_env+    pit        = eps_PIT eps+    dflags     = hsc_dflags hsc_env+    get_orph_hash mod =+          case lookupIfaceByModule dflags hpt pit mod of+            Just iface -> return (mi_orphan_hash iface)+            Nothing    -> do -- similar to 'mkHashFun'+                iface <- initIfaceLoad hsc_env . withException+                            $ loadInterface (text "getOrphanHashes") mod ImportBySystem+                return (mi_orphan_hash iface)++  --+  mapM get_orph_hash mods+++sortDependencies :: Dependencies -> Dependencies+sortDependencies d+ = Deps { dep_mods   = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d),+          dep_pkgs   = sortBy (compare `on` fst) (dep_pkgs d),+          dep_orphs  = sortBy stableModuleCmp (dep_orphs d),+          dep_finsts = sortBy stableModuleCmp (dep_finsts d),+          dep_plgins = sortBy (compare `on` moduleNameFS) (dep_plgins d) }++-- | Creates cached lookup for the 'mi_anns' field of ModIface+-- Hackily, we use "module" as the OccName for any module-level annotations+mkIfaceAnnCache :: [IfaceAnnotation] -> OccName -> [AnnPayload]+mkIfaceAnnCache anns+  = \n -> lookupOccEnv env n `orElse` []+  where+    pair (IfaceAnnotation target value) =+      (case target of+          NamedTarget occn -> occn+          ModuleTarget _   -> mkVarOcc "module"+      , [value])+    -- flipping (++), so the first argument is always short+    env = mkOccEnv_C (flip (++)) (map pair anns)++{-+************************************************************************+*                                                                      *+          The ABI of an IfaceDecl+*                                                                      *+************************************************************************++Note [The ABI of an IfaceDecl]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The ABI of a declaration consists of:++   (a) the full name of the identifier (inc. module and package,+       because these are used to construct the symbol name by which+       the identifier is known externally).++   (b) the declaration itself, as exposed to clients.  That is, the+       definition of an Id is included in the fingerprint only if+       it is made available as an unfolding in the interface.++   (c) the fixity of the identifier (if it exists)+   (d) for Ids: rules+   (e) for classes: instances, fixity & rules for methods+   (f) for datatypes: instances, fixity & rules for constrs++Items (c)-(f) are not stored in the IfaceDecl, but instead appear+elsewhere in the interface file.  But they are *fingerprinted* with+the declaration itself. This is done by grouping (c)-(f) in IfaceDeclExtras,+and fingerprinting that as part of the declaration.+-}++type IfaceDeclABI = (Module, IfaceDecl, IfaceDeclExtras)++data IfaceDeclExtras+  = IfaceIdExtras IfaceIdExtras++  | IfaceDataExtras+       (Maybe Fixity)           -- Fixity of the tycon itself (if it exists)+       [IfaceInstABI]           -- Local class and family instances of this tycon+                                -- See Note [Orphans] in InstEnv+       [AnnPayload]             -- Annotations of the type itself+       [IfaceIdExtras]          -- For each constructor: fixity, RULES and annotations++  | IfaceClassExtras+       (Maybe Fixity)           -- Fixity of the class itself (if it exists)+       [IfaceInstABI]           -- Local instances of this class *or*+                                --   of its associated data types+                                -- See Note [Orphans] in InstEnv+       [AnnPayload]             -- Annotations of the type itself+       [IfaceIdExtras]          -- For each class method: fixity, RULES and annotations+       [IfExtName]              -- Default methods. If a module+                                -- mentions a class, then it can+                                -- instantiate the class and thereby+                                -- use the default methods, so we must+                                -- include these in the fingerprint of+                                -- a class.++  | IfaceSynonymExtras (Maybe Fixity) [AnnPayload]++  | IfaceFamilyExtras   (Maybe Fixity) [IfaceInstABI] [AnnPayload]++  | IfaceOtherDeclExtras++data IfaceIdExtras+  = IdExtras+       (Maybe Fixity)           -- Fixity of the Id (if it exists)+       [IfaceRule]              -- Rules for the Id+       [AnnPayload]             -- Annotations for the Id++-- When hashing a class or family instance, we hash only the+-- DFunId or CoAxiom, because that depends on all the+-- information about the instance.+--+type IfaceInstABI = IfExtName   -- Name of DFunId or CoAxiom that is evidence for the instance++abiDecl :: IfaceDeclABI -> IfaceDecl+abiDecl (_, decl, _) = decl++cmp_abiNames :: IfaceDeclABI -> IfaceDeclABI -> Ordering+cmp_abiNames abi1 abi2 = getOccName (abiDecl abi1) `compare`+                         getOccName (abiDecl abi2)++freeNamesDeclABI :: IfaceDeclABI -> NameSet+freeNamesDeclABI (_mod, decl, extras) =+  freeNamesIfDecl decl `unionNameSet` freeNamesDeclExtras extras++freeNamesDeclExtras :: IfaceDeclExtras -> NameSet+freeNamesDeclExtras (IfaceIdExtras id_extras)+  = freeNamesIdExtras id_extras+freeNamesDeclExtras (IfaceDataExtras  _ insts _ subs)+  = unionNameSets (mkNameSet insts : map freeNamesIdExtras subs)+freeNamesDeclExtras (IfaceClassExtras _ insts _ subs defms)+  = unionNameSets $+      mkNameSet insts : mkNameSet defms : map freeNamesIdExtras subs+freeNamesDeclExtras (IfaceSynonymExtras _ _)+  = emptyNameSet+freeNamesDeclExtras (IfaceFamilyExtras _ insts _)+  = mkNameSet insts+freeNamesDeclExtras IfaceOtherDeclExtras+  = emptyNameSet++freeNamesIdExtras :: IfaceIdExtras -> NameSet+freeNamesIdExtras (IdExtras _ rules _) = unionNameSets (map freeNamesIfRule rules)++instance Outputable IfaceDeclExtras where+  ppr IfaceOtherDeclExtras       = Outputable.empty+  ppr (IfaceIdExtras  extras)    = ppr_id_extras extras+  ppr (IfaceSynonymExtras fix anns) = vcat [ppr fix, ppr anns]+  ppr (IfaceFamilyExtras fix finsts anns) = vcat [ppr fix, ppr finsts, ppr anns]+  ppr (IfaceDataExtras fix insts anns stuff) = vcat [ppr fix, ppr_insts insts, ppr anns,+                                                ppr_id_extras_s stuff]+  ppr (IfaceClassExtras fix insts anns stuff defms) =+    vcat [ppr fix, ppr_insts insts, ppr anns,+          ppr_id_extras_s stuff, ppr defms]++ppr_insts :: [IfaceInstABI] -> SDoc+ppr_insts _ = text "<insts>"++ppr_id_extras_s :: [IfaceIdExtras] -> SDoc+ppr_id_extras_s stuff = vcat (map ppr_id_extras stuff)++ppr_id_extras :: IfaceIdExtras -> SDoc+ppr_id_extras (IdExtras fix rules anns) = ppr fix $$ vcat (map ppr rules) $$ vcat (map ppr anns)++-- This instance is used only to compute fingerprints+instance Binary IfaceDeclExtras where+  get _bh = panic "no get for IfaceDeclExtras"+  put_ bh (IfaceIdExtras extras) = do+   putByte bh 1; put_ bh extras+  put_ bh (IfaceDataExtras fix insts anns cons) = do+   putByte bh 2; put_ bh fix; put_ bh insts; put_ bh anns; put_ bh cons+  put_ bh (IfaceClassExtras fix insts anns methods defms) = do+   putByte bh 3+   put_ bh fix+   put_ bh insts+   put_ bh anns+   put_ bh methods+   put_ bh defms+  put_ bh (IfaceSynonymExtras fix anns) = do+   putByte bh 4; put_ bh fix; put_ bh anns+  put_ bh (IfaceFamilyExtras fix finsts anns) = do+   putByte bh 5; put_ bh fix; put_ bh finsts; put_ bh anns+  put_ bh IfaceOtherDeclExtras = putByte bh 6++instance Binary IfaceIdExtras where+  get _bh = panic "no get for IfaceIdExtras"+  put_ bh (IdExtras fix rules anns)= do { put_ bh fix; put_ bh rules; put_ bh anns }++declExtras :: (OccName -> Maybe Fixity)+           -> (OccName -> [AnnPayload])+           -> OccEnv [IfaceRule]+           -> OccEnv [IfaceClsInst]+           -> OccEnv [IfaceFamInst]+           -> OccEnv IfExtName          -- lookup default method names+           -> IfaceDecl+           -> IfaceDeclExtras++declExtras fix_fn ann_fn rule_env inst_env fi_env dm_env decl+  = case decl of+      IfaceId{} -> IfaceIdExtras (id_extras n)+      IfaceData{ifCons=cons} ->+                     IfaceDataExtras (fix_fn n)+                        (map ifFamInstAxiom (lookupOccEnvL fi_env n) +++                         map ifDFun         (lookupOccEnvL inst_env n))+                        (ann_fn n)+                        (map (id_extras . occName . ifConName) (visibleIfConDecls cons))+      IfaceClass{ifBody = IfConcreteClass { ifSigs=sigs, ifATs=ats }} ->+                     IfaceClassExtras (fix_fn n) insts (ann_fn n) meths defms+          where+            insts = (map ifDFun $ (concatMap at_extras ats)+                                    ++ lookupOccEnvL inst_env n)+                           -- Include instances of the associated types+                           -- as well as instances of the class (#5147)+            meths = [id_extras (getOccName op) | IfaceClassOp op _ _ <- sigs]+            -- Names of all the default methods (see Note [default method Name])+            defms = [ dmName+                    | IfaceClassOp bndr _ (Just _) <- sigs+                    , let dmOcc = mkDefaultMethodOcc (nameOccName bndr)+                    , Just dmName <- [lookupOccEnv dm_env dmOcc] ]+      IfaceSynonym{} -> IfaceSynonymExtras (fix_fn n)+                                           (ann_fn n)+      IfaceFamily{} -> IfaceFamilyExtras (fix_fn n)+                        (map ifFamInstAxiom (lookupOccEnvL fi_env n))+                        (ann_fn n)+      _other -> IfaceOtherDeclExtras+  where+        n = getOccName decl+        id_extras occ = IdExtras (fix_fn occ) (lookupOccEnvL rule_env occ) (ann_fn occ)+        at_extras (IfaceAT decl _) = lookupOccEnvL inst_env (getOccName decl)+++{- Note [default method Name] (see also #15970)++The Names for the default methods aren't available in the IfaceSyn.++* We originally start with a DefMethInfo from the class, contain a+  Name for the default method++* We turn that into IfaceSyn as a DefMethSpec which lacks a Name+  entirely. Why? Because the Name can be derived from the method name+  (in TcIface), so doesn't need to be serialised into the interface+  file.++But now we have to get the Name back, because the class declaration's+fingerprint needs to depend on it (this was the bug in #15970).  This+is done in a slightly convoluted way:++* Then, in addFingerprints we build a map that maps OccNames to Names++* We pass that map to declExtras which laboriously looks up in the map+  (using the derived occurrence name) to recover the Name we have just+  thrown away.+-}++lookupOccEnvL :: OccEnv [v] -> OccName -> [v]+lookupOccEnvL env k = lookupOccEnv env k `orElse` []++{-+-- for testing: use the md5sum command to generate fingerprints and+-- compare the results against our built-in version.+  fp' <- oldMD5 dflags bh+  if fp /= fp' then pprPanic "computeFingerprint" (ppr fp <+> ppr fp')+               else return fp++oldMD5 dflags bh = do+  tmp <- newTempName dflags CurrentModule "bin"+  writeBinMem bh tmp+  tmp2 <- newTempName dflags CurrentModule "md5"+  let cmd = "md5sum " ++ tmp ++ " >" ++ tmp2+  r <- system cmd+  case r of+    ExitFailure _ -> throwGhcExceptionIO (PhaseFailed cmd r)+    ExitSuccess -> do+        hash_str <- readFile tmp2+        return $! readHexFingerprint hash_str+-}++----------------------+-- mkOrphMap partitions instance decls or rules into+--      (a) an OccEnv for ones that are not orphans,+--          mapping the local OccName to a list of its decls+--      (b) a list of orphan decls+mkOrphMap :: (decl -> IsOrphan) -- Extract orphan status from decl+          -> [decl]             -- Sorted into canonical order+          -> (OccEnv [decl],    -- Non-orphan decls associated with their key;+                                --      each sublist in canonical order+              [decl])           -- Orphan decls; in canonical order+mkOrphMap get_key decls+  = foldl' go (emptyOccEnv, []) decls+  where+    go (non_orphs, orphs) d+        | NotOrphan occ <- get_key d+        = (extendOccEnv_Acc (:) singleton non_orphs occ d, orphs)+        | otherwise = (non_orphs, d:orphs)++{-+************************************************************************+*                                                                      *+       COMPLETE Pragmas+*                                                                      *+************************************************************************+-}++mkIfaceCompleteSig :: CompleteMatch -> IfaceCompleteMatch+mkIfaceCompleteSig (CompleteMatch cls tc) = IfaceCompleteMatch cls tc+++{-+************************************************************************+*                                                                      *+       Keeping track of what we've slurped, and fingerprints+*                                                                      *+************************************************************************+-}+++mkIfaceAnnotation :: Annotation -> IfaceAnnotation+mkIfaceAnnotation (Annotation { ann_target = target, ann_value = payload })+  = IfaceAnnotation {+        ifAnnotatedTarget = fmap nameOccName target,+        ifAnnotatedValue = payload+    }++mkIfaceExports :: [AvailInfo] -> [IfaceExport]  -- Sort to make canonical+mkIfaceExports exports+  = sortBy stableAvailCmp (map sort_subs exports)+  where+    sort_subs :: AvailInfo -> AvailInfo+    sort_subs (Avail n) = Avail n+    sort_subs (AvailTC n [] fs) = AvailTC n [] (sort_flds fs)+    sort_subs (AvailTC n (m:ms) fs)+       | n==m      = AvailTC n (m:sortBy stableNameCmp ms) (sort_flds fs)+       | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) (sort_flds fs)+       -- Maintain the AvailTC Invariant++    sort_flds = sortBy (stableNameCmp `on` flSelector)++{-+Note [Original module]+~~~~~~~~~~~~~~~~~~~~~+Consider this:+        module X where { data family T }+        module Y( T(..) ) where { import X; data instance T Int = MkT Int }+The exported Avail from Y will look like+        X.T{X.T, Y.MkT}+That is, in Y,+  - only MkT is brought into scope by the data instance;+  - but the parent (used for grouping and naming in T(..) exports) is X.T+  - and in this case we export X.T too++In the result of MkIfaceExports, the names are grouped by defining module,+so we may need to split up a single Avail into multiple ones.++Note [Internal used_names]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Most of the used_names are External Names, but we can have Internal+Names too: see Note [Binders in Template Haskell] in Convert, and+#5362 for an example.  Such Names are always+  - Such Names are always for locally-defined things, for which we+    don't gather usage info, so we can just ignore them in ent_map+  - They are always System Names, hence the assert, just as a double check.+++************************************************************************+*                                                                      *+        Load the old interface file for this module (unless+        we have it already), and check whether it is up to date+*                                                                      *+************************************************************************+-}++data RecompileRequired+  = UpToDate+       -- ^ everything is up to date, recompilation is not required+  | MustCompile+       -- ^ The .hs file has been touched, or the .o/.hi file does not exist+  | RecompBecause String+       -- ^ The .o/.hi files are up to date, but something else has changed+       -- to force recompilation; the String says what (one-line summary)+   deriving Eq++instance Semigroup RecompileRequired where+  UpToDate <> r = r+  mc <> _       = mc++instance Monoid RecompileRequired where+  mempty = UpToDate++recompileRequired :: RecompileRequired -> Bool+recompileRequired UpToDate = False+recompileRequired _ = True++++-- | Top level function to check if the version of an old interface file+-- is equivalent to the current source file the user asked us to compile.+-- If the same, we can avoid recompilation. We return a tuple where the+-- first element is a bool saying if we should recompile the object file+-- and the second is maybe the interface file, where Nothng means to+-- rebuild the interface file not use the exisitng one.+checkOldIface+  :: HscEnv+  -> ModSummary+  -> SourceModified+  -> Maybe ModIface         -- Old interface from compilation manager, if any+  -> IO (RecompileRequired, Maybe ModIface)++checkOldIface hsc_env mod_summary source_modified maybe_iface+  = do  let dflags = hsc_dflags hsc_env+        showPass dflags $+            "Checking old interface for " +++              (showPpr dflags $ ms_mod mod_summary) +++              " (use -ddump-hi-diffs for more details)"+        initIfaceCheck (text "checkOldIface") hsc_env $+            check_old_iface hsc_env mod_summary source_modified maybe_iface++check_old_iface+  :: HscEnv+  -> ModSummary+  -> SourceModified+  -> Maybe ModIface+  -> IfG (RecompileRequired, Maybe ModIface)++check_old_iface hsc_env mod_summary src_modified maybe_iface+  = let dflags = hsc_dflags hsc_env+        getIface =+            case maybe_iface of+                Just _  -> do+                    traceIf (text "We already have the old interface for" <+>+                      ppr (ms_mod mod_summary))+                    return maybe_iface+                Nothing -> loadIface++        loadIface = do+             let iface_path = msHiFilePath mod_summary+             read_result <- readIface (ms_mod mod_summary) iface_path+             case read_result of+                 Failed err -> do+                     traceIf (text "FYI: cannot read old interface file:" $$ nest 4 err)+                     traceHiDiffs (text "Old interface file was invalid:" $$ nest 4 err)+                     return Nothing+                 Succeeded iface -> do+                     traceIf (text "Read the interface file" <+> text iface_path)+                     return $ Just iface++        src_changed+            | gopt Opt_ForceRecomp (hsc_dflags hsc_env) = True+            | SourceModified <- src_modified = True+            | otherwise = False+    in do+        when src_changed $+            traceHiDiffs (nest 4 $ text "Source file changed or recompilation check turned off")++        case src_changed of+            -- If the source has changed and we're in interactive mode,+            -- avoid reading an interface; just return the one we might+            -- have been supplied with.+            True | not (isObjectTarget $ hscTarget dflags) ->+                return (MustCompile, maybe_iface)++            -- Try and read the old interface for the current module+            -- from the .hi file left from the last time we compiled it+            True -> do+                maybe_iface' <- getIface+                return (MustCompile, maybe_iface')++            False -> do+                maybe_iface' <- getIface+                case maybe_iface' of+                    -- We can't retrieve the iface+                    Nothing    -> return (MustCompile, Nothing)++                    -- We have got the old iface; check its versions+                    -- even in the SourceUnmodifiedAndStable case we+                    -- should check versions because some packages+                    -- might have changed or gone away.+                    Just iface -> checkVersions hsc_env mod_summary iface++-- | Check if a module is still the same 'version'.+--+-- This function is called in the recompilation checker after we have+-- determined that the module M being checked hasn't had any changes+-- to its source file since we last compiled M. So at this point in general+-- two things may have changed that mean we should recompile M:+--   * The interface export by a dependency of M has changed.+--   * The compiler flags specified this time for M have changed+--     in a manner that is significant for recompilation.+-- We return not just if we should recompile the object file but also+-- if we should rebuild the interface file.+checkVersions :: HscEnv+              -> ModSummary+              -> ModIface       -- Old interface+              -> IfG (RecompileRequired, Maybe ModIface)+checkVersions hsc_env mod_summary iface+  = do { traceHiDiffs (text "Considering whether compilation is required for" <+>+                        ppr (mi_module iface) <> colon)++       -- readIface will have verified that the InstalledUnitId matches,+       -- but we ALSO must make sure the instantiation matches up.  See+       -- test case bkpcabal04!+       ; if moduleUnitId (mi_module iface) /= thisPackage (hsc_dflags hsc_env)+            then return (RecompBecause "-this-unit-id changed", Nothing) else do {+       ; recomp <- checkFlagHash hsc_env iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkOptimHash hsc_env iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkHpcHash hsc_env iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkMergedSignatures mod_summary iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkHsig mod_summary iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkHie mod_summary+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+       ; recomp <- checkDependencies hsc_env mod_summary iface+       ; if recompileRequired recomp then return (recomp, Just iface) else do {+       ; recomp <- checkPlugins hsc_env iface+       ; if recompileRequired recomp then return (recomp, Nothing) else do {+++       -- Source code unchanged and no errors yet... carry on+       --+       -- First put the dependent-module info, read from the old+       -- interface, into the envt, so that when we look for+       -- interfaces we look for the right one (.hi or .hi-boot)+       --+       -- It's just temporary because either the usage check will succeed+       -- (in which case we are done with this module) or it'll fail (in which+       -- case we'll compile the module from scratch anyhow).+       --+       -- We do this regardless of compilation mode, although in --make mode+       -- all the dependent modules should be in the HPT already, so it's+       -- quite redundant+       ; updateEps_ $ \eps  -> eps { eps_is_boot = mod_deps }+       ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface]+       ; return (recomp, Just iface)+    }}}}}}}}}}+  where+    this_pkg = thisPackage (hsc_dflags hsc_env)+    -- This is a bit of a hack really+    mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface)+    mod_deps = mkModDeps (dep_mods (mi_deps iface))++-- | Check if any plugins are requesting recompilation+checkPlugins :: HscEnv -> ModIface -> IfG RecompileRequired+checkPlugins hsc iface = liftIO $ do+  new_fingerprint <- fingerprintPlugins hsc+  let old_fingerprint = mi_plugin_hash iface+  pr <- mconcat <$> mapM pluginRecompile' (plugins (hsc_dflags hsc))+  return $+    pluginRecompileToRecompileRequired old_fingerprint new_fingerprint pr++fingerprintPlugins :: HscEnv -> IO Fingerprint+fingerprintPlugins hsc_env = do+  fingerprintPlugins' $ plugins (hsc_dflags hsc_env)++fingerprintPlugins' :: [PluginWithArgs] -> IO Fingerprint+fingerprintPlugins' plugins = do+  res <- mconcat <$> mapM pluginRecompile' plugins+  return $ case res of+      NoForceRecompile ->  fingerprintString "NoForceRecompile"+      ForceRecompile   -> fingerprintString "ForceRecompile"+      -- is the chance of collision worth worrying about?+      -- An alternative is to fingerprintFingerprints [fingerprintString+      -- "maybeRecompile", fp]+      (MaybeRecompile fp) -> fp+++pluginRecompileToRecompileRequired+    :: Fingerprint -> Fingerprint -> PluginRecompile -> RecompileRequired+pluginRecompileToRecompileRequired old_fp new_fp pr+  | old_fp == new_fp =+    case pr of+      NoForceRecompile  -> UpToDate++      -- we already checked the fingerprint above so a mismatch is not possible+      -- here, remember that: `fingerprint (MaybeRecomp x) == x`.+      MaybeRecompile _  -> UpToDate++      -- when we have an impure plugin in the stack we have to unconditionally+      -- recompile since it might integrate all sorts of crazy IO results into+      -- its compilation output.+      ForceRecompile    -> RecompBecause "Impure plugin forced recompilation"++  | old_fp `elem` magic_fingerprints ||+    new_fp `elem` magic_fingerprints+    -- The fingerprints do not match either the old or new one is a magic+    -- fingerprint. This happens when non-pure plugins are added for the first+    -- time or when we go from one recompilation strategy to another: (force ->+    -- no-force, maybe-recomp -> no-force, no-force -> maybe-recomp etc.)+    --+    -- For example when we go from from ForceRecomp to NoForceRecomp+    -- recompilation is triggered since the old impure plugins could have+    -- changed the build output which is now back to normal.+    = RecompBecause "Plugins changed"++  | otherwise =+    let reason = "Plugin fingerprint changed" in+    case pr of+      -- even though a plugin is forcing recompilation the fingerprint changed+      -- which would cause recompilation anyways so we report the fingerprint+      -- change instead.+      ForceRecompile   -> RecompBecause reason++      _                -> RecompBecause reason++ where+   magic_fingerprints =+       [ fingerprintString "NoForceRecompile"+       , fingerprintString "ForceRecompile"+       ]+++-- | Check if an hsig file needs recompilation because its+-- implementing module has changed.+checkHsig :: ModSummary -> ModIface -> IfG RecompileRequired+checkHsig mod_summary iface = do+    dflags <- getDynFlags+    let outer_mod = ms_mod mod_summary+        inner_mod = canonicalizeHomeModule dflags (moduleName outer_mod)+    MASSERT( moduleUnitId outer_mod == thisPackage dflags )+    case inner_mod == mi_semantic_module iface of+        True -> up_to_date (text "implementing module unchanged")+        False -> return (RecompBecause "implementing module changed")++-- | Check if @.hie@ file is out of date or missing.+checkHie :: ModSummary -> IfG RecompileRequired+checkHie mod_summary = do+    dflags <- getDynFlags+    let hie_date_opt = ms_hie_date mod_summary+        hs_date = ms_hs_date mod_summary+    pure $ case gopt Opt_WriteHie dflags of+               False -> UpToDate+               True -> case hie_date_opt of+                           Nothing -> RecompBecause "HIE file is missing"+                           Just hie_date+                               | hie_date < hs_date+                               -> RecompBecause "HIE file is out of date"+                               | otherwise+                               -> UpToDate++-- | Check the flags haven't changed+checkFlagHash :: HscEnv -> ModIface -> IfG RecompileRequired+checkFlagHash hsc_env iface = do+    let old_hash = mi_flag_hash iface+    new_hash <- liftIO $ fingerprintDynFlags (hsc_dflags hsc_env)+                                             (mi_module iface)+                                             putNameLiterally+    case old_hash == new_hash of+        True  -> up_to_date (text "Module flags unchanged")+        False -> out_of_date_hash "flags changed"+                     (text "  Module flags have changed")+                     old_hash new_hash++-- | Check the optimisation flags haven't changed+checkOptimHash :: HscEnv -> ModIface -> IfG RecompileRequired+checkOptimHash hsc_env iface = do+    let old_hash = mi_opt_hash iface+    new_hash <- liftIO $ fingerprintOptFlags (hsc_dflags hsc_env)+                                               putNameLiterally+    if | old_hash == new_hash+         -> up_to_date (text "Optimisation flags unchanged")+       | gopt Opt_IgnoreOptimChanges (hsc_dflags hsc_env)+         -> up_to_date (text "Optimisation flags changed; ignoring")+       | otherwise+         -> out_of_date_hash "Optimisation flags changed"+                     (text "  Optimisation flags have changed")+                     old_hash new_hash++-- | Check the HPC flags haven't changed+checkHpcHash :: HscEnv -> ModIface -> IfG RecompileRequired+checkHpcHash hsc_env iface = do+    let old_hash = mi_hpc_hash iface+    new_hash <- liftIO $ fingerprintHpcFlags (hsc_dflags hsc_env)+                                               putNameLiterally+    if | old_hash == new_hash+         -> up_to_date (text "HPC flags unchanged")+       | gopt Opt_IgnoreHpcChanges (hsc_dflags hsc_env)+         -> up_to_date (text "HPC flags changed; ignoring")+       | otherwise+         -> out_of_date_hash "HPC flags changed"+                     (text "  HPC flags have changed")+                     old_hash new_hash++-- Check that the set of signatures we are merging in match.+-- If the -unit-id flags change, this can change too.+checkMergedSignatures :: ModSummary -> ModIface -> IfG RecompileRequired+checkMergedSignatures mod_summary iface = do+    dflags <- getDynFlags+    let old_merged = sort [ mod | UsageMergedRequirement{ usg_mod = mod } <- mi_usages iface ]+        new_merged = case Map.lookup (ms_mod_name mod_summary)+                                     (requirementContext (pkgState dflags)) of+                        Nothing -> []+                        Just r -> sort $ map (indefModuleToModule dflags) r+    if old_merged == new_merged+        then up_to_date (text "signatures to merge in unchanged" $$ ppr new_merged)+        else return (RecompBecause "signatures to merge in changed")++-- If the direct imports of this module are resolved to targets that+-- are not among the dependencies of the previous interface file,+-- then we definitely need to recompile.  This catches cases like+--   - an exposed package has been upgraded+--   - we are compiling with different package flags+--   - a home module that was shadowing a package module has been removed+--   - a new home module has been added that shadows a package module+-- See bug #1372.+--+-- Returns (RecompBecause <textual reason>) if recompilation is required.+checkDependencies :: HscEnv -> ModSummary -> ModIface -> IfG RecompileRequired+checkDependencies hsc_env summary iface+ = checkList (map dep_missing (ms_imps summary ++ ms_srcimps summary))+  where+   prev_dep_mods = dep_mods (mi_deps iface)+   prev_dep_plgn = dep_plgins (mi_deps iface)+   prev_dep_pkgs = dep_pkgs (mi_deps iface)++   this_pkg = thisPackage (hsc_dflags hsc_env)++   dep_missing (mb_pkg, L _ mod) = do+     find_res <- liftIO $ findImportedModule hsc_env mod (mb_pkg)+     let reason = moduleNameString mod ++ " changed"+     case find_res of+        Found _ mod+          | pkg == this_pkg+           -> if moduleName mod `notElem` map fst prev_dep_mods ++ prev_dep_plgn+                 then do traceHiDiffs $+                           text "imported module " <> quotes (ppr mod) <>+                           text " not among previous dependencies"+                         return (RecompBecause reason)+                 else+                         return UpToDate+          | otherwise+           -> if toInstalledUnitId pkg `notElem` (map fst prev_dep_pkgs)+                 then do traceHiDiffs $+                           text "imported module " <> quotes (ppr mod) <>+                           text " is from package " <> quotes (ppr pkg) <>+                           text ", which is not among previous dependencies"+                         return (RecompBecause reason)+                 else+                         return UpToDate+           where pkg = moduleUnitId mod+        _otherwise  -> return (RecompBecause reason)++needInterface :: Module -> (ModIface -> IfG RecompileRequired)+              -> IfG RecompileRequired+needInterface mod continue+  = do  -- Load the imported interface if possible+    let doc_str = sep [text "need version info for", ppr mod]+    traceHiDiffs (text "Checking usages for module" <+> ppr mod)++    mb_iface <- loadInterface doc_str mod ImportBySystem+        -- Load the interface, but don't complain on failure;+        -- Instead, get an Either back which we can test++    case mb_iface of+      Failed _ -> do+        traceHiDiffs (sep [text "Couldn't load interface for module",+                           ppr mod])+        return MustCompile+                  -- Couldn't find or parse a module mentioned in the+                  -- old interface file.  Don't complain: it might+                  -- just be that the current module doesn't need that+                  -- import and it's been deleted+      Succeeded iface -> continue iface++-- | Given the usage information extracted from the old+-- M.hi file for the module being compiled, figure out+-- whether M needs to be recompiled.+checkModUsage :: UnitId -> Usage -> IfG RecompileRequired+checkModUsage _this_pkg UsagePackageModule{+                                usg_mod = mod,+                                usg_mod_hash = old_mod_hash }+  = needInterface mod $ \iface -> do+    let reason = moduleNameString (moduleName mod) ++ " changed"+    checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)+        -- We only track the ABI hash of package modules, rather than+        -- individual entity usages, so if the ABI hash changes we must+        -- recompile.  This is safe but may entail more recompilation when+        -- a dependent package has changed.++checkModUsage _ UsageMergedRequirement{ usg_mod = mod, usg_mod_hash = old_mod_hash }+  = needInterface mod $ \iface -> do+    let reason = moduleNameString (moduleName mod) ++ " changed (raw)"+    checkModuleFingerprint reason old_mod_hash (mi_mod_hash iface)++checkModUsage this_pkg UsageHomeModule{+                                usg_mod_name = mod_name,+                                usg_mod_hash = old_mod_hash,+                                usg_exports = maybe_old_export_hash,+                                usg_entities = old_decl_hash }+  = do+    let mod = mkModule this_pkg mod_name+    needInterface mod $ \iface -> do++    let+        new_mod_hash    = mi_mod_hash    iface+        new_decl_hash   = mi_hash_fn     iface+        new_export_hash = mi_exp_hash    iface++        reason = moduleNameString mod_name ++ " changed"++        -- CHECK MODULE+    recompile <- checkModuleFingerprint reason old_mod_hash new_mod_hash+    if not (recompileRequired recompile)+      then return UpToDate+      else do++        -- CHECK EXPORT LIST+        checkMaybeHash reason maybe_old_export_hash new_export_hash+            (text "  Export list changed") $ do++        -- CHECK ITEMS ONE BY ONE+        recompile <- checkList [ checkEntityUsage reason new_decl_hash u+                               | u <- old_decl_hash]+        if recompileRequired recompile+          then return recompile     -- This one failed, so just bail out now+          else up_to_date (text "  Great!  The bits I use are up to date")+++checkModUsage _this_pkg UsageFile{ usg_file_path = file,+                                   usg_file_hash = old_hash } =+  liftIO $+    handleIO handle $ do+      new_hash <- getFileHash file+      if (old_hash /= new_hash)+         then return recomp+         else return UpToDate+ where+   recomp = RecompBecause (file ++ " changed")+   handle =+#if defined(DEBUG)+       \e -> pprTrace "UsageFile" (text (show e)) $ return recomp+#else+       \_ -> return recomp -- if we can't find the file, just recompile, don't fail+#endif++------------------------+checkModuleFingerprint :: String -> Fingerprint -> Fingerprint+                       -> IfG RecompileRequired+checkModuleFingerprint reason old_mod_hash new_mod_hash+  | new_mod_hash == old_mod_hash+  = up_to_date (text "Module fingerprint unchanged")++  | otherwise+  = out_of_date_hash reason (text "  Module fingerprint has changed")+                     old_mod_hash new_mod_hash++------------------------+checkMaybeHash :: String -> Maybe Fingerprint -> Fingerprint -> SDoc+               -> IfG RecompileRequired -> IfG RecompileRequired+checkMaybeHash reason maybe_old_hash new_hash doc continue+  | Just hash <- maybe_old_hash, hash /= new_hash+  = out_of_date_hash reason doc hash new_hash+  | otherwise+  = continue++------------------------+checkEntityUsage :: String+                 -> (OccName -> Maybe (OccName, Fingerprint))+                 -> (OccName, Fingerprint)+                 -> IfG RecompileRequired+checkEntityUsage reason new_hash (name,old_hash)+  = case new_hash name of++        Nothing       ->        -- We used it before, but it ain't there now+                          out_of_date reason (sep [text "No longer exported:", ppr name])++        Just (_, new_hash)      -- It's there, but is it up to date?+          | new_hash == old_hash -> do traceHiDiffs (text "  Up to date" <+> ppr name <+> parens (ppr new_hash))+                                       return UpToDate+          | otherwise            -> out_of_date_hash reason (text "  Out of date:" <+> ppr name)+                                                     old_hash new_hash++up_to_date :: SDoc -> IfG RecompileRequired+up_to_date  msg = traceHiDiffs msg >> return UpToDate++out_of_date :: String -> SDoc -> IfG RecompileRequired+out_of_date reason msg = traceHiDiffs msg >> return (RecompBecause reason)++out_of_date_hash :: String -> SDoc -> Fingerprint -> Fingerprint -> IfG RecompileRequired+out_of_date_hash reason msg old_hash new_hash+  = out_of_date reason (hsep [msg, ppr old_hash, text "->", ppr new_hash])++----------------------+checkList :: [IfG RecompileRequired] -> IfG RecompileRequired+-- This helper is used in two places+checkList []             = return UpToDate+checkList (check:checks) = do recompile <- check+                              if recompileRequired recompile+                                then return recompile+                                else checkList checks++{-+************************************************************************+*                                                                      *+                Converting things to their Iface equivalents+*                                                                      *+************************************************************************+-}++tyThingToIfaceDecl :: TyThing -> IfaceDecl+tyThingToIfaceDecl (AnId id)      = idToIfaceDecl id+tyThingToIfaceDecl (ATyCon tycon) = snd (tyConToIfaceDecl emptyTidyEnv tycon)+tyThingToIfaceDecl (ACoAxiom ax)  = coAxiomToIfaceDecl ax+tyThingToIfaceDecl (AConLike cl)  = case cl of+    RealDataCon dc -> dataConToIfaceDecl dc -- for ppr purposes only+    PatSynCon ps   -> patSynToIfaceDecl ps++--------------------------+idToIfaceDecl :: Id -> IfaceDecl+-- The Id is already tidied, so that locally-bound names+-- (lambdas, for-alls) already have non-clashing OccNames+-- We can't tidy it here, locally, because it may have+-- free variables in its type or IdInfo+idToIfaceDecl id+  = IfaceId { ifName      = getName id,+              ifType      = toIfaceType (idType id),+              ifIdDetails = toIfaceIdDetails (idDetails id),+              ifIdInfo    = toIfaceIdInfo (idInfo id) }++--------------------------+dataConToIfaceDecl :: DataCon -> IfaceDecl+dataConToIfaceDecl dataCon+  = IfaceId { ifName      = getName dataCon,+              ifType      = toIfaceType (dataConUserType dataCon),+              ifIdDetails = IfVanillaId,+              ifIdInfo    = NoInfo }++--------------------------+coAxiomToIfaceDecl :: CoAxiom br -> IfaceDecl+-- We *do* tidy Axioms, because they are not (and cannot+-- conveniently be) built in tidy form+coAxiomToIfaceDecl ax@(CoAxiom { co_ax_tc = tycon, co_ax_branches = branches+                               , co_ax_role = role })+ = IfaceAxiom { ifName       = getName ax+              , ifTyCon      = toIfaceTyCon tycon+              , ifRole       = role+              , ifAxBranches = map (coAxBranchToIfaceBranch tycon+                                     (map coAxBranchLHS branch_list))+                                   branch_list }+ where+   branch_list = fromBranches branches++-- 2nd parameter is the list of branch LHSs, for conversion from incompatible branches+-- to incompatible indices+-- See Note [Storing compatibility] in CoAxiom+coAxBranchToIfaceBranch :: TyCon -> [[Type]] -> CoAxBranch -> IfaceAxBranch+coAxBranchToIfaceBranch tc lhs_s+                        branch@(CoAxBranch { cab_incomps = incomps })+  = (coAxBranchToIfaceBranch' tc branch) { ifaxbIncomps = iface_incomps }+  where+    iface_incomps = map (expectJust "iface_incomps"+                        . (flip findIndex lhs_s+                          . eqTypes)+                        . coAxBranchLHS) incomps++-- use this one for standalone branches without incompatibles+coAxBranchToIfaceBranch' :: TyCon -> CoAxBranch -> IfaceAxBranch+coAxBranchToIfaceBranch' tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                                        , cab_eta_tvs = eta_tvs+                                        , cab_lhs = lhs+                                        , cab_roles = roles, cab_rhs = rhs })+  = IfaceAxBranch { ifaxbTyVars    = toIfaceTvBndrs tvs+                  , ifaxbCoVars    = map toIfaceIdBndr cvs+                  , ifaxbEtaTyVars = toIfaceTvBndrs eta_tvs+                  , ifaxbLHS       = toIfaceTcArgs tc lhs+                  , ifaxbRoles     = roles+                  , ifaxbRHS       = toIfaceType rhs+                  , ifaxbIncomps   = [] }++-----------------+tyConToIfaceDecl :: TidyEnv -> TyCon -> (TidyEnv, IfaceDecl)+-- We *do* tidy TyCons, because they are not (and cannot+-- conveniently be) built in tidy form+-- The returned TidyEnv is the one after tidying the tyConTyVars+tyConToIfaceDecl env tycon+  | Just clas <- tyConClass_maybe tycon+  = classToIfaceDecl env clas++  | Just syn_rhs <- synTyConRhs_maybe tycon+  = ( tc_env1+    , IfaceSynonym { ifName    = getName tycon,+                     ifRoles   = tyConRoles tycon,+                     ifSynRhs  = if_syn_type syn_rhs,+                     ifBinders = if_binders,+                     ifResKind = if_res_kind+                   })++  | Just fam_flav <- famTyConFlav_maybe tycon+  = ( tc_env1+    , IfaceFamily { ifName    = getName tycon,+                    ifResVar  = if_res_var,+                    ifFamFlav = to_if_fam_flav fam_flav,+                    ifBinders = if_binders,+                    ifResKind = if_res_kind,+                    ifFamInj  = tyConInjectivityInfo tycon+                  })++  | isAlgTyCon tycon+  = ( tc_env1+    , IfaceData { ifName    = getName tycon,+                  ifBinders = if_binders,+                  ifResKind = if_res_kind,+                  ifCType   = tyConCType tycon,+                  ifRoles   = tyConRoles tycon,+                  ifCtxt    = tidyToIfaceContext tc_env1 (tyConStupidTheta tycon),+                  ifCons    = ifaceConDecls (algTyConRhs tycon),+                  ifGadtSyntax = isGadtSyntaxTyCon tycon,+                  ifParent  = parent })++  | otherwise  -- FunTyCon, PrimTyCon, promoted TyCon/DataCon+  -- We only convert these TyCons to IfaceTyCons when we are+  -- just about to pretty-print them, not because we are going+  -- to put them into interface files+  = ( env+    , IfaceData { ifName       = getName tycon,+                  ifBinders    = if_binders,+                  ifResKind    = if_res_kind,+                  ifCType      = Nothing,+                  ifRoles      = tyConRoles tycon,+                  ifCtxt       = [],+                  ifCons       = IfDataTyCon [],+                  ifGadtSyntax = False,+                  ifParent     = IfNoParent })+  where+    -- NOTE: Not all TyCons have `tyConTyVars` field. Forcing this when `tycon`+    -- is one of these TyCons (FunTyCon, PrimTyCon, PromotedDataCon) will cause+    -- an error.+    (tc_env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)+    tc_tyvars      = binderVars tc_binders+    if_binders     = toIfaceTyCoVarBinders tc_binders+                     -- No tidying of the binders; they are already tidy+    if_res_kind    = tidyToIfaceType tc_env1 (tyConResKind tycon)+    if_syn_type ty = tidyToIfaceType tc_env1 ty+    if_res_var     = getOccFS `fmap` tyConFamilyResVar_maybe tycon++    parent = case tyConFamInstSig_maybe tycon of+               Just (tc, ty, ax) -> IfDataInstance (coAxiomName ax)+                                                   (toIfaceTyCon tc)+                                                   (tidyToIfaceTcArgs tc_env1 tc ty)+               Nothing           -> IfNoParent++    to_if_fam_flav OpenSynFamilyTyCon             = IfaceOpenSynFamilyTyCon+    to_if_fam_flav AbstractClosedSynFamilyTyCon   = IfaceAbstractClosedSynFamilyTyCon+    to_if_fam_flav (DataFamilyTyCon {})           = IfaceDataFamilyTyCon+    to_if_fam_flav (BuiltInSynFamTyCon {})        = IfaceBuiltInSynFamTyCon+    to_if_fam_flav (ClosedSynFamilyTyCon Nothing) = IfaceClosedSynFamilyTyCon Nothing+    to_if_fam_flav (ClosedSynFamilyTyCon (Just ax))+      = IfaceClosedSynFamilyTyCon (Just (axn, ibr))+      where defs = fromBranches $ coAxiomBranches ax+            ibr  = map (coAxBranchToIfaceBranch' tycon) defs+            axn  = coAxiomName ax++    ifaceConDecls (NewTyCon { data_con = con })    = IfNewTyCon  (ifaceConDecl con)+    ifaceConDecls (DataTyCon { data_cons = cons }) = IfDataTyCon (map ifaceConDecl cons)+    ifaceConDecls (TupleTyCon { data_con = con })  = IfDataTyCon [ifaceConDecl con]+    ifaceConDecls (SumTyCon { data_cons = cons })  = IfDataTyCon (map ifaceConDecl cons)+    ifaceConDecls AbstractTyCon                    = IfAbstractTyCon+        -- The AbstractTyCon case happens when a TyCon has been trimmed+        -- during tidying.+        -- Furthermore, tyThingToIfaceDecl is also used in TcRnDriver+        -- for GHCi, when browsing a module, in which case the+        -- AbstractTyCon and TupleTyCon cases are perfectly sensible.+        -- (Tuple declarations are not serialised into interface files.)++    ifaceConDecl data_con+        = IfCon   { ifConName    = dataConName data_con,+                    ifConInfix   = dataConIsInfix data_con,+                    ifConWrapper = isJust (dataConWrapId_maybe data_con),+                    ifConExTCvs  = map toIfaceBndr ex_tvs',+                    ifConUserTvBinders = map toIfaceForAllBndr user_bndrs',+                    ifConEqSpec  = map (to_eq_spec . eqSpecPair) eq_spec,+                    ifConCtxt    = tidyToIfaceContext con_env2 theta,+                    ifConArgTys  = map (tidyToIfaceType con_env2) arg_tys,+                    ifConFields  = dataConFieldLabels data_con,+                    ifConStricts = map (toIfaceBang con_env2)+                                       (dataConImplBangs data_con),+                    ifConSrcStricts = map toIfaceSrcBang+                                          (dataConSrcBangs data_con)}+        where+          (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)+            = dataConFullSig data_con+          user_bndrs = dataConUserTyVarBinders data_con++          -- Tidy the univ_tvs of the data constructor to be identical+          -- to the tyConTyVars of the type constructor.  This means+          -- (a) we don't need to redundantly put them into the interface file+          -- (b) when pretty-printing an Iface data declaration in H98-style syntax,+          --     we know that the type variables will line up+          -- The latter (b) is important because we pretty-print type constructors+          -- by converting to IfaceSyn and pretty-printing that+          con_env1 = (fst tc_env1, mkVarEnv (zipEqual "ifaceConDecl" univ_tvs tc_tyvars))+                     -- A bit grimy, perhaps, but it's simple!++          (con_env2, ex_tvs') = tidyVarBndrs con_env1 ex_tvs+          user_bndrs' = map (tidyUserTyCoVarBinder con_env2) user_bndrs+          to_eq_spec (tv,ty) = (tidyTyVar con_env2 tv, tidyToIfaceType con_env2 ty)++          -- By this point, we have tidied every universal and existential+          -- tyvar. Because of the dcUserTyCoVarBinders invariant+          -- (see Note [DataCon user type variable binders]), *every*+          -- user-written tyvar must be contained in the substitution that+          -- tidying produced. Therefore, tidying the user-written tyvars is a+          -- simple matter of looking up each variable in the substitution,+          -- which tidyTyCoVarOcc accomplishes.+          tidyUserTyCoVarBinder :: TidyEnv -> TyCoVarBinder -> TyCoVarBinder+          tidyUserTyCoVarBinder env (Bndr tv vis) =+            Bndr (tidyTyCoVarOcc env tv) vis++classToIfaceDecl :: TidyEnv -> Class -> (TidyEnv, IfaceDecl)+classToIfaceDecl env clas+  = ( env1+    , IfaceClass { ifName   = getName tycon,+                   ifRoles  = tyConRoles (classTyCon clas),+                   ifBinders = toIfaceTyCoVarBinders tc_binders,+                   ifBody   = body,+                   ifFDs    = map toIfaceFD clas_fds })+  where+    (_, clas_fds, sc_theta, _, clas_ats, op_stuff)+      = classExtraBigSig clas+    tycon = classTyCon clas++    body | isAbstractTyCon tycon = IfAbstractClass+         | otherwise+         = IfConcreteClass {+                ifClassCtxt   = tidyToIfaceContext env1 sc_theta,+                ifATs    = map toIfaceAT clas_ats,+                ifSigs   = map toIfaceClassOp op_stuff,+                ifMinDef = fmap getOccFS (classMinimalDef clas)+            }++    (env1, tc_binders) = tidyTyConBinders env (tyConBinders tycon)++    toIfaceAT :: ClassATItem -> IfaceAT+    toIfaceAT (ATI tc def)+      = IfaceAT if_decl (fmap (tidyToIfaceType env2 . fst) def)+      where+        (env2, if_decl) = tyConToIfaceDecl env1 tc++    toIfaceClassOp (sel_id, def_meth)+        = ASSERT( sel_tyvars == binderVars tc_binders )+          IfaceClassOp (getName sel_id)+                       (tidyToIfaceType env1 op_ty)+                       (fmap toDmSpec def_meth)+        where+                -- Be careful when splitting the type, because of things+                -- like         class Foo a where+                --                op :: (?x :: String) => a -> a+                -- and          class Baz a where+                --                op :: (Ord a) => a -> a+          (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id)+          op_ty                = funResultTy rho_ty++    toDmSpec :: (Name, DefMethSpec Type) -> DefMethSpec IfaceType+    toDmSpec (_, VanillaDM)       = VanillaDM+    toDmSpec (_, GenericDM dm_ty) = GenericDM (tidyToIfaceType env1 dm_ty)++    toIfaceFD (tvs1, tvs2) = (map (tidyTyVar env1) tvs1+                             ,map (tidyTyVar env1) tvs2)++--------------------------++tidyTyConBinder :: TidyEnv -> TyConBinder -> (TidyEnv, TyConBinder)+-- If the type variable "binder" is in scope, don't re-bind it+-- In a class decl, for example, the ATD binders mention+-- (amd must mention) the class tyvars+tidyTyConBinder env@(_, subst) tvb@(Bndr tv vis)+ = case lookupVarEnv subst tv of+     Just tv' -> (env,  Bndr tv' vis)+     Nothing  -> tidyTyCoVarBinder env tvb++tidyTyConBinders :: TidyEnv -> [TyConBinder] -> (TidyEnv, [TyConBinder])+tidyTyConBinders = mapAccumL tidyTyConBinder++tidyTyVar :: TidyEnv -> TyVar -> FastString+tidyTyVar (_, subst) tv = toIfaceTyVar (lookupVarEnv subst tv `orElse` tv)++--------------------------+instanceToIfaceInst :: ClsInst -> IfaceClsInst+instanceToIfaceInst (ClsInst { is_dfun = dfun_id, is_flag = oflag+                             , is_cls_nm = cls_name, is_cls = cls+                             , is_tcs = mb_tcs+                             , is_orphan = orph })+  = ASSERT( cls_name == className cls )+    IfaceClsInst { ifDFun    = dfun_name,+                ifOFlag   = oflag,+                ifInstCls = cls_name,+                ifInstTys = map do_rough mb_tcs,+                ifInstOrph = orph }+  where+    do_rough Nothing  = Nothing+    do_rough (Just n) = Just (toIfaceTyCon_name n)++    dfun_name = idName dfun_id+++--------------------------+famInstToIfaceFamInst :: FamInst -> IfaceFamInst+famInstToIfaceFamInst (FamInst { fi_axiom    = axiom,+                                 fi_fam      = fam,+                                 fi_tcs      = roughs })+  = IfaceFamInst { ifFamInstAxiom    = coAxiomName axiom+                 , ifFamInstFam      = fam+                 , ifFamInstTys      = map do_rough roughs+                 , ifFamInstOrph     = orph }+  where+    do_rough Nothing  = Nothing+    do_rough (Just n) = Just (toIfaceTyCon_name n)++    fam_decl = tyConName $ coAxiomTyCon axiom+    mod = ASSERT( isExternalName (coAxiomName axiom) )+          nameModule (coAxiomName axiom)+    is_local name = nameIsLocalOrFrom mod name++    lhs_names = filterNameSet is_local (orphNamesOfCoCon axiom)++    orph | is_local fam_decl+         = NotOrphan (nameOccName fam_decl)+         | otherwise+         = chooseOrphanAnchor lhs_names++--------------------------+coreRuleToIfaceRule :: CoreRule -> IfaceRule+coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})+  = pprTrace "toHsRule: builtin" (ppr fn) $+    bogusIfaceRule fn++coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,+                            ru_act = act, ru_bndrs = bndrs,+                            ru_args = args, ru_rhs = rhs,+                            ru_orphan = orph, ru_auto = auto })+  = IfaceRule { ifRuleName  = name, ifActivation = act,+                ifRuleBndrs = map toIfaceBndr bndrs,+                ifRuleHead  = fn,+                ifRuleArgs  = map do_arg args,+                ifRuleRhs   = toIfaceExpr rhs,+                ifRuleAuto  = auto,+                ifRuleOrph  = orph }+  where+        -- For type args we must remove synonyms from the outermost+        -- level.  Reason: so that when we read it back in we'll+        -- construct the same ru_rough field as we have right now;+        -- see tcIfaceRule+    do_arg (Type ty)     = IfaceType (toIfaceType (deNoteType ty))+    do_arg (Coercion co) = IfaceCo   (toIfaceCoercion co)+    do_arg arg           = toIfaceExpr arg++bogusIfaceRule :: Name -> IfaceRule+bogusIfaceRule id_name+  = IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,+        ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [],+        ifRuleRhs = IfaceExt id_name, ifRuleOrph = IsOrphan,+        ifRuleAuto = True }
+ compiler/iface/TcIface.hs view
@@ -0,0 +1,1821 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Type checking of type signatures in interface files+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE NondecreasingIndentation #-}++module TcIface (+        tcLookupImported_maybe,+        importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,+        typecheckIfacesForMerging,+        typecheckIfaceForInstantiate,+        tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,+        tcIfaceAnnotations, tcIfaceCompleteSigs,+        tcIfaceExpr,    -- Desired by HERMIT (#7683)+        tcIfaceGlobal+ ) where++#include "HsVersions.h"++import GhcPrelude++import TcTypeNats(typeNatCoAxiomRules)+import IfaceSyn+import LoadIface+import IfaceEnv+import BuildTyCl+import TcRnMonad+import TcType+import Type+import Coercion+import CoAxiom+import TyCoRep    -- needs to build types & coercions in a knot+import HscTypes+import Annotations+import InstEnv+import FamInstEnv+import CoreSyn+import CoreUtils+import CoreUnfold+import CoreLint+import MkCore+import Id+import MkId+import IdInfo+import Class+import TyCon+import ConLike+import DataCon+import PrelNames+import TysWiredIn+import Literal+import Var+import VarSet+import Name+import NameEnv+import NameSet+import OccurAnal        ( occurAnalyseExpr )+import Demand+import Module+import UniqFM+import UniqSupply+import Outputable+import Maybes+import SrcLoc+import DynFlags+import Util+import FastString+import BasicTypes hiding ( SuccessFlag(..) )+import ListSetOps+import GHC.Fingerprint+import qualified BooleanFormula as BF++import Control.Monad+import qualified Data.Map as Map++{-+This module takes++        IfaceDecl -> TyThing+        IfaceType -> Type+        etc++An IfaceDecl is populated with RdrNames, and these are not renamed to+Names before typechecking, because there should be no scope errors etc.++        -- For (b) consider: f = \$(...h....)+        -- where h is imported, and calls f via an hi-boot file.+        -- This is bad!  But it is not seen as a staging error, because h+        -- is indeed imported.  We don't want the type-checker to black-hole+        -- when simplifying and compiling the splice!+        --+        -- Simple solution: discard any unfolding that mentions a variable+        -- bound in this module (and hence not yet processed).+        -- The discarding happens when forkM finds a type error.+++************************************************************************+*                                                                      *+                Type-checking a complete interface+*                                                                      *+************************************************************************++Suppose we discover we don't need to recompile.  Then we must type+check the old interface file.  This is a bit different to the+incremental type checking we do as we suck in interface files.  Instead+we do things similarly as when we are typechecking source decls: we+bring into scope the type envt for the interface all at once, using a+knot.  Remember, the decls aren't necessarily in dependency order --+and even if they were, the type decls might be mutually recursive.++Note [Knot-tying typecheckIface]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are typechecking an interface A.hi, and we come across+a Name for another entity defined in A.hi.  How do we get the+'TyCon', in this case?  There are three cases:++    1) tcHiBootIface in TcIface: We're typechecking an hi-boot file in+    preparation of checking if the hs file we're building+    is compatible.  In this case, we want all of the internal+    TyCons to MATCH the ones that we just constructed during+    typechecking: the knot is thus tied through if_rec_types.++    2) retypecheckLoop in GhcMake: We are retypechecking a+    mutually recursive cluster of hi files, in order to ensure+    that all of the references refer to each other correctly.+    In this case, the knot is tied through the HPT passed in,+    which contains all of the interfaces we are in the process+    of typechecking.++    3) genModDetails in HscMain: We are typechecking an+    old interface to generate the ModDetails.  In this case,+    we do the same thing as (2) and pass in an HPT with+    the HomeModInfo being generated to tie knots.++The upshot is that the CLIENT of this function is responsible+for making sure that the knot is tied correctly.  If you don't,+then you'll get a message saying that we couldn't load the+declaration you wanted.++BTW, in one-shot mode we never call typecheckIface; instead,+loadInterface handles type-checking interface.  In that case,+knots are tied through the EPS.  No problem!+-}++-- Clients of this function be careful, see Note [Knot-tying typecheckIface]+typecheckIface :: ModIface      -- Get the decls from here+               -> IfG ModDetails+typecheckIface iface+  = initIfaceLcl (mi_semantic_module iface) (text "typecheckIface") (mi_boot iface) $ do+        {       -- Get the right set of decls and rules.  If we are compiling without -O+                -- we discard pragmas before typechecking, so that we don't "see"+                -- information that we shouldn't.  From a versioning point of view+                -- It's not actually *wrong* to do so, but in fact GHCi is unable+                -- to handle unboxed tuples, so it must not see unfoldings.+          ignore_prags <- goptM Opt_IgnoreInterfacePragmas++                -- Typecheck the decls.  This is done lazily, so that the knot-tying+                -- within this single module works out right.  It's the callers+                -- job to make sure the knot is tied.+        ; names_w_things <- loadDecls ignore_prags (mi_decls iface)+        ; let type_env = mkNameEnv names_w_things++                -- Now do those rules, instances and annotations+        ; insts     <- mapM tcIfaceInst (mi_insts iface)+        ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)+        ; rules     <- tcIfaceRules ignore_prags (mi_rules iface)+        ; anns      <- tcIfaceAnnotations (mi_anns iface)++                -- Exports+        ; exports <- ifaceExportNames (mi_exports iface)++                -- Complete Sigs+        ; complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)++                -- Finished+        ; traceIf (vcat [text "Finished typechecking interface for" <+> ppr (mi_module iface),+                         -- Careful! If we tug on the TyThing thunks too early+                         -- we'll infinite loop with hs-boot.  See #10083 for+                         -- an example where this would cause non-termination.+                         text "Type envt:" <+> ppr (map fst names_w_things)])+        ; return $ ModDetails { md_types     = type_env+                              , md_insts     = insts+                              , md_fam_insts = fam_insts+                              , md_rules     = rules+                              , md_anns      = anns+                              , md_exports   = exports+                              , md_complete_sigs = complete_sigs+                              }+    }++{-+************************************************************************+*                                                                      *+                Typechecking for merging+*                                                                      *+************************************************************************+-}++-- | Returns true if an 'IfaceDecl' is for @data T@ (an abstract data type)+isAbstractIfaceDecl :: IfaceDecl -> Bool+isAbstractIfaceDecl IfaceData{ ifCons = IfAbstractTyCon } = True+isAbstractIfaceDecl IfaceClass{ ifBody = IfAbstractClass } = True+isAbstractIfaceDecl IfaceFamily{ ifFamFlav = IfaceAbstractClosedSynFamilyTyCon } = True+isAbstractIfaceDecl _ = False++ifMaybeRoles :: IfaceDecl -> Maybe [Role]+ifMaybeRoles IfaceData    { ifRoles = rs } = Just rs+ifMaybeRoles IfaceSynonym { ifRoles = rs } = Just rs+ifMaybeRoles IfaceClass   { ifRoles = rs } = Just rs+ifMaybeRoles _ = Nothing++-- | Merge two 'IfaceDecl's together, preferring a non-abstract one.  If+-- both are non-abstract we pick one arbitrarily (and check for consistency+-- later.)+mergeIfaceDecl :: IfaceDecl -> IfaceDecl -> IfaceDecl+mergeIfaceDecl d1 d2+    | isAbstractIfaceDecl d1 = d2 `withRolesFrom` d1+    | isAbstractIfaceDecl d2 = d1 `withRolesFrom` d2+    | IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops1, ifMinDef = bf1 } } <- d1+    , IfaceClass{ ifBody = IfConcreteClass { ifSigs = ops2, ifMinDef = bf2 } } <- d2+    = let ops = nameEnvElts $+                  plusNameEnv_C mergeIfaceClassOp+                    (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops1 ])+                    (mkNameEnv [ (n, op) | op@(IfaceClassOp n _ _) <- ops2 ])+      in d1 { ifBody = (ifBody d1) {+                ifSigs  = ops,+                ifMinDef = BF.mkOr [noLoc bf1, noLoc bf2]+                }+            } `withRolesFrom` d2+    -- It doesn't matter; we'll check for consistency later when+    -- we merge, see 'mergeSignatures'+    | otherwise              = d1 `withRolesFrom` d2++-- Note [Role merging]+-- ~~~~~~~~~~~~~~~~~~~+-- First, why might it be necessary to do a non-trivial role+-- merge?  It may rescue a merge that might otherwise fail:+--+--      signature A where+--          type role T nominal representational+--          data T a b+--+--      signature A where+--          type role T representational nominal+--          data T a b+--+-- A module that defines T as representational in both arguments+-- would successfully fill both signatures, so it would be better+-- if we merged the roles of these types in some nontrivial+-- way.+--+-- However, we have to be very careful about how we go about+-- doing this, because role subtyping is *conditional* on+-- the supertype being NOT representationally injective, e.g.,+-- if we have instead:+--+--      signature A where+--          type role T nominal representational+--          data T a b = T a b+--+--      signature A where+--          type role T representational nominal+--          data T a b = T a b+--+-- Should we merge the definitions of T so that the roles are R/R (or N/N)?+-- Absolutely not: neither resulting type is a subtype of the original+-- types (see Note [Role subtyping]), because data is not representationally+-- injective.+--+-- Thus, merging only occurs when BOTH TyCons in question are+-- representationally injective.  If they're not, no merge.++withRolesFrom :: IfaceDecl -> IfaceDecl -> IfaceDecl+d1 `withRolesFrom` d2+    | Just roles1 <- ifMaybeRoles d1+    , Just roles2 <- ifMaybeRoles d2+    , not (isRepInjectiveIfaceDecl d1 || isRepInjectiveIfaceDecl d2)+    = d1 { ifRoles = mergeRoles roles1 roles2 }+    | otherwise = d1+  where+    mergeRoles roles1 roles2 = zipWith max roles1 roles2++isRepInjectiveIfaceDecl :: IfaceDecl -> Bool+isRepInjectiveIfaceDecl IfaceData{ ifCons = IfDataTyCon _ } = True+isRepInjectiveIfaceDecl IfaceFamily{ ifFamFlav = IfaceDataFamilyTyCon } = True+isRepInjectiveIfaceDecl _ = False++mergeIfaceClassOp :: IfaceClassOp -> IfaceClassOp -> IfaceClassOp+mergeIfaceClassOp op1@(IfaceClassOp _ _ (Just _)) _ = op1+mergeIfaceClassOp _ op2 = op2++-- | Merge two 'OccEnv's of 'IfaceDecl's by 'OccName'.+mergeIfaceDecls :: OccEnv IfaceDecl -> OccEnv IfaceDecl -> OccEnv IfaceDecl+mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl++-- | This is a very interesting function.  Like typecheckIface, we want+-- to type check an interface file into a ModDetails.  However, the use-case+-- for these ModDetails is different: we want to compare all of the+-- ModDetails to ensure they define compatible declarations, and then+-- merge them together.  So in particular, we have to take a different+-- strategy for knot-tying: we first speculatively merge the declarations+-- to get the "base" truth for what we believe the types will be+-- (this is "type computation.")  Then we read everything in relative+-- to this truth and check for compatibility.+--+-- During the merge process, we may need to nondeterministically+-- pick a particular declaration to use, if multiple signatures define+-- the declaration ('mergeIfaceDecl').  If, for all choices, there+-- are no type synonym cycles in the resulting merged graph, then+-- we can show that our choice cannot matter. Consider the+-- set of entities which the declarations depend on: by assumption+-- of acyclicity, we can assume that these have already been shown to be equal+-- to each other (otherwise merging will fail).  Then it must+-- be the case that all candidate declarations here are type-equal+-- (the choice doesn't matter) or there is an inequality (in which+-- case merging will fail.)+--+-- Unfortunately, the choice can matter if there is a cycle.  Consider the+-- following merge:+--+--      signature H where { type A = C;  type B = A; data C      }+--      signature H where { type A = (); data B;     type C = B  }+--+-- If we pick @type A = C@ as our representative, there will be+-- a cycle and merging will fail. But if we pick @type A = ()@ as+-- our representative, no cycle occurs, and we instead conclude+-- that all of the types are unit.  So it seems that we either+-- (a) need a stronger acyclicity check which considers *all*+-- possible choices from a merge, or (b) we must find a selection+-- of declarations which is acyclic, and show that this is always+-- the "best" choice we could have made (ezyang conjectures this+-- is the case but does not have a proof).  For now this is+-- not implemented.+--+-- It's worth noting that at the moment, a data constructor and a+-- type synonym are never compatible.  Consider:+--+--      signature H where { type Int=C;         type B = Int; data C = Int}+--      signature H where { export Prelude.Int; data B;       type C = B; }+--+-- This will be rejected, because the reexported Int in the second+-- signature (a proper data type) is never considered equal to a+-- type synonym.  Perhaps this should be relaxed, where a type synonym+-- in a signature is considered implemented by a data type declaration+-- which matches the reference of the type synonym.+typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails])+typecheckIfacesForMerging mod ifaces tc_env_var =+  -- cannot be boot (False)+  initIfaceLcl mod (text "typecheckIfacesForMerging") False $ do+    ignore_prags <- goptM Opt_IgnoreInterfacePragmas+    -- Build the initial environment+    -- NB: Don't include dfuns here, because we don't want to+    -- serialize them out.  See Note [rnIfaceNeverExported] in RnModIface+    -- NB: But coercions are OK, because they will have the right OccName.+    let mk_decl_env decls+            = mkOccEnv [ (getOccName decl, decl)+                       | decl <- decls+                       , case decl of+                            IfaceId { ifIdDetails = IfDFunId } -> False -- exclude DFuns+                            _ -> True ]+        decl_envs = map (mk_decl_env . map snd . mi_decls) ifaces+                        :: [OccEnv IfaceDecl]+        decl_env = foldl' mergeIfaceDecls emptyOccEnv decl_envs+                        ::  OccEnv IfaceDecl+    -- TODO: change loadDecls to accept w/o Fingerprint+    names_w_things <- loadDecls ignore_prags (map (\x -> (fingerprint0, x))+                                                  (occEnvElts decl_env))+    let global_type_env = mkNameEnv names_w_things+    writeMutVar tc_env_var global_type_env++    -- OK, now typecheck each ModIface using this environment+    details <- forM ifaces $ \iface -> do+        -- See Note [Resolving never-exported Names in TcIface]+        type_env <- fixM $ \type_env -> do+            setImplicitEnvM type_env $ do+                decls <- loadDecls ignore_prags (mi_decls iface)+                return (mkNameEnv decls)+        -- But note that we use this type_env to typecheck references to DFun+        -- in 'IfaceInst'+        setImplicitEnvM type_env $ do+        insts     <- mapM tcIfaceInst (mi_insts iface)+        fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)+        rules     <- tcIfaceRules ignore_prags (mi_rules iface)+        anns      <- tcIfaceAnnotations (mi_anns iface)+        exports   <- ifaceExportNames (mi_exports iface)+        complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)+        return $ ModDetails { md_types     = type_env+                            , md_insts     = insts+                            , md_fam_insts = fam_insts+                            , md_rules     = rules+                            , md_anns      = anns+                            , md_exports   = exports+                            , md_complete_sigs = complete_sigs+                            }+    return (global_type_env, details)++-- | Typecheck a signature 'ModIface' under the assumption that we have+-- instantiated it under some implementation (recorded in 'mi_semantic_module')+-- and want to check if the implementation fills the signature.+--+-- This needs to operate slightly differently than 'typecheckIface'+-- because (1) we have a 'NameShape', from the exports of the+-- implementing module, which we will use to give our top-level+-- declarations the correct 'Name's even when the implementor+-- provided them with a reexport, and (2) we have to deal with+-- DFun silliness (see Note [rnIfaceNeverExported])+typecheckIfaceForInstantiate :: NameShape -> ModIface -> IfM lcl ModDetails+typecheckIfaceForInstantiate nsubst iface =+  initIfaceLclWithSubst (mi_semantic_module iface)+                        (text "typecheckIfaceForInstantiate")+                        (mi_boot iface) nsubst $ do+    ignore_prags <- goptM Opt_IgnoreInterfacePragmas+    -- See Note [Resolving never-exported Names in TcIface]+    type_env <- fixM $ \type_env -> do+        setImplicitEnvM type_env $ do+            decls     <- loadDecls ignore_prags (mi_decls iface)+            return (mkNameEnv decls)+    -- See Note [rnIfaceNeverExported]+    setImplicitEnvM type_env $ do+    insts     <- mapM tcIfaceInst (mi_insts iface)+    fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)+    rules     <- tcIfaceRules ignore_prags (mi_rules iface)+    anns      <- tcIfaceAnnotations (mi_anns iface)+    exports   <- ifaceExportNames (mi_exports iface)+    complete_sigs <- tcIfaceCompleteSigs (mi_complete_sigs iface)+    return $ ModDetails { md_types     = type_env+                        , md_insts     = insts+                        , md_fam_insts = fam_insts+                        , md_rules     = rules+                        , md_anns      = anns+                        , md_exports   = exports+                        , md_complete_sigs = complete_sigs+                        }++-- Note [Resolving never-exported Names in TcIface]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- For the high-level overview, see+-- Note [Handling never-exported TyThings under Backpack]+--+-- As described in 'typecheckIfacesForMerging', the splendid innovation+-- of signature merging is to rewrite all Names in each of the signatures+-- we are merging together to a pre-merged structure; this is the key+-- ingredient that lets us solve some problems when merging type+-- synonyms.+--+-- However, when a 'Name' refers to a NON-exported entity, as is the+-- case with the DFun of a ClsInst, or a CoAxiom of a type family,+-- this strategy causes problems: if we pick one and rewrite all+-- references to a shared 'Name', we will accidentally fail to check+-- if the DFun or CoAxioms are compatible, as they will never be+-- checked--only exported entities are checked for compatibility,+-- and a non-exported TyThing is checked WHEN we are checking the+-- ClsInst or type family for compatibility in checkBootDeclM.+-- By virtue of the fact that everything's been pointed to the merged+-- declaration, you'll never notice there's a difference even if there+-- is one.+--+-- Fortunately, there are only a few places in the interface declarations+-- where this can occur, so we replace those calls with 'tcIfaceImplicit',+-- which will consult a local TypeEnv that records any never-exported+-- TyThings which we should wire up with.+--+-- Note that we actually knot-tie this local TypeEnv (the 'fixM'), because a+-- type family can refer to a coercion axiom, all of which are done in one go+-- when we typecheck 'mi_decls'.  An alternate strategy would be to typecheck+-- coercions first before type families, but that seemed more fragile.+--++{-+************************************************************************+*                                                                      *+                Type and class declarations+*                                                                      *+************************************************************************+-}++tcHiBootIface :: HscSource -> Module -> TcRn SelfBootInfo+-- Load the hi-boot iface for the module being compiled,+-- if it indeed exists in the transitive closure of imports+-- Return the ModDetails; Nothing if no hi-boot iface+tcHiBootIface hsc_src mod+  | HsBootFile <- hsc_src            -- Already compiling a hs-boot file+  = return NoSelfBoot+  | otherwise+  = do  { traceIf (text "loadHiBootInterface" <+> ppr mod)++        ; mode <- getGhcMode+        ; if not (isOneShot mode)+                -- In --make and interactive mode, if this module has an hs-boot file+                -- we'll have compiled it already, and it'll be in the HPT+                --+                -- We check wheher the interface is a *boot* interface.+                -- It can happen (when using GHC from Visual Studio) that we+                -- compile a module in TypecheckOnly mode, with a stable,+                -- fully-populated HPT.  In that case the boot interface isn't there+                -- (it's been replaced by the mother module) so we can't check it.+                -- And that's fine, because if M's ModInfo is in the HPT, then+                -- it's been compiled once, and we don't need to check the boot iface+          then do { hpt <- getHpt+                 ; case lookupHpt hpt (moduleName mod) of+                      Just info | mi_boot (hm_iface info)+                                -> mkSelfBootInfo (hm_iface info) (hm_details info)+                      _ -> return NoSelfBoot }+          else do++        -- OK, so we're in one-shot mode.+        -- Re #9245, we always check if there is an hi-boot interface+        -- to check consistency against, rather than just when we notice+        -- that an hi-boot is necessary due to a circular import.+        { read_result <- findAndReadIface+                                need (fst (splitModuleInsts mod)) mod+                                True    -- Hi-boot file++        ; case read_result of {+            Succeeded (iface, _path) -> do { tc_iface <- initIfaceTcRn $ typecheckIface iface+                                           ; mkSelfBootInfo iface tc_iface } ;+            Failed err               ->++        -- There was no hi-boot file. But if there is circularity in+        -- the module graph, there really should have been one.+        -- Since we've read all the direct imports by now,+        -- eps_is_boot will record if any of our imports mention the+        -- current module, which either means a module loop (not+        -- a SOURCE import) or that our hi-boot file has mysteriously+        -- disappeared.+    do  { eps <- getEps+        ; case lookupUFM (eps_is_boot eps) (moduleName mod) of+            Nothing -> return NoSelfBoot -- The typical case++            Just (_, False) -> failWithTc moduleLoop+                -- Someone below us imported us!+                -- This is a loop with no hi-boot in the way++            Just (_mod, True) -> failWithTc (elaborate err)+                -- The hi-boot file has mysteriously disappeared.+    }}}}+  where+    need = text "Need the hi-boot interface for" <+> ppr mod+                 <+> text "to compare against the Real Thing"++    moduleLoop = text "Circular imports: module" <+> quotes (ppr mod)+                     <+> text "depends on itself"++    elaborate err = hang (text "Could not find hi-boot interface for" <+>+                          quotes (ppr mod) <> colon) 4 err+++mkSelfBootInfo :: ModIface -> ModDetails -> TcRn SelfBootInfo+mkSelfBootInfo iface mds+  = do -- NB: This is computed DIRECTLY from the ModIface rather+       -- than from the ModDetails, so that we can query 'sb_tcs'+       -- WITHOUT forcing the contents of the interface.+       let tcs = map ifName+                 . filter isIfaceTyCon+                 . map snd+                 $ mi_decls iface+       return $ SelfBoot { sb_mds = mds+                         , sb_tcs = mkNameSet tcs }+  where+    -- | Retuerns @True@ if, when you call 'tcIfaceDecl' on+    -- this 'IfaceDecl', an ATyCon would be returned.+    -- NB: This code assumes that a TyCon cannot be implicit.+    isIfaceTyCon IfaceId{}      = False+    isIfaceTyCon IfaceData{}    = True+    isIfaceTyCon IfaceSynonym{} = True+    isIfaceTyCon IfaceFamily{}  = True+    isIfaceTyCon IfaceClass{}   = True+    isIfaceTyCon IfaceAxiom{}   = False+    isIfaceTyCon IfacePatSyn{}  = False++{-+************************************************************************+*                                                                      *+                Type and class declarations+*                                                                      *+************************************************************************++When typechecking a data type decl, we *lazily* (via forkM) typecheck+the constructor argument types.  This is in the hope that we may never+poke on those argument types, and hence may never need to load the+interface files for types mentioned in the arg types.++E.g.+        data Foo.S = MkS Baz.T+Maybe we can get away without even loading the interface for Baz!++This is not just a performance thing.  Suppose we have+        data Foo.S = MkS Baz.T+        data Baz.T = MkT Foo.S+(in different interface files, of course).+Now, first we load and typecheck Foo.S, and add it to the type envt.+If we do explore MkS's argument, we'll load and typecheck Baz.T.+If we explore MkT's argument we'll find Foo.S already in the envt.++If we typechecked constructor args eagerly, when loading Foo.S we'd try to+typecheck the type Baz.T.  So we'd fault in Baz.T... and then need Foo.S...+which isn't done yet.++All very cunning. However, there is a rather subtle gotcha which bit+me when developing this stuff.  When we typecheck the decl for S, we+extend the type envt with S, MkS, and all its implicit Ids.  Suppose+(a bug, but it happened) that the list of implicit Ids depended in+turn on the constructor arg types.  Then the following sequence of+events takes place:+        * we build a thunk <t> for the constructor arg tys+        * we build a thunk for the extended type environment (depends on <t>)+        * we write the extended type envt into the global EPS mutvar++Now we look something up in the type envt+        * that pulls on <t>+        * which reads the global type envt out of the global EPS mutvar+        * but that depends in turn on <t>++It's subtle, because, it'd work fine if we typechecked the constructor args+eagerly -- they don't need the extended type envt.  They just get the extended+type envt by accident, because they look at it later.++What this means is that the implicitTyThings MUST NOT DEPEND on any of+the forkM stuff.+-}++tcIfaceDecl :: Bool     -- ^ True <=> discard IdInfo on IfaceId bindings+            -> IfaceDecl+            -> IfL TyThing+tcIfaceDecl = tc_iface_decl Nothing++tc_iface_decl :: Maybe Class  -- ^ For associated type/data family declarations+              -> Bool         -- ^ True <=> discard IdInfo on IfaceId bindings+              -> IfaceDecl+              -> IfL TyThing+tc_iface_decl _ ignore_prags (IfaceId {ifName = name, ifType = iface_type,+                                       ifIdDetails = details, ifIdInfo = info})+  = do  { ty <- tcIfaceType iface_type+        ; details <- tcIdDetails ty details+        ; info <- tcIdInfo ignore_prags TopLevel name ty info+        ; return (AnId (mkGlobalId details name ty info)) }++tc_iface_decl _ _ (IfaceData {ifName = tc_name,+                          ifCType = cType,+                          ifBinders = binders,+                          ifResKind = res_kind,+                          ifRoles = roles,+                          ifCtxt = ctxt, ifGadtSyntax = gadt_syn,+                          ifCons = rdr_cons,+                          ifParent = mb_parent })+  = bindIfaceTyConBinders_AT binders $ \ binders' -> do+    { res_kind' <- tcIfaceType res_kind++    ; tycon <- fixM $ \ tycon -> do+            { stupid_theta <- tcIfaceCtxt ctxt+            ; parent' <- tc_parent tc_name mb_parent+            ; cons <- tcIfaceDataCons tc_name tycon binders' rdr_cons+            ; return (mkAlgTyCon tc_name binders' res_kind'+                                 roles cType stupid_theta+                                 cons parent' gadt_syn) }+    ; traceIf (text "tcIfaceDecl4" <+> ppr tycon)+    ; return (ATyCon tycon) }+  where+    tc_parent :: Name -> IfaceTyConParent -> IfL AlgTyConFlav+    tc_parent tc_name IfNoParent+      = do { tc_rep_name <- newTyConRepName tc_name+           ; return (VanillaAlgTyCon tc_rep_name) }+    tc_parent _ (IfDataInstance ax_name _ arg_tys)+      = do { ax <- tcIfaceCoAxiom ax_name+           ; let fam_tc  = coAxiomTyCon ax+                 ax_unbr = toUnbranchedAxiom ax+           ; lhs_tys <- tcIfaceAppArgs arg_tys+           ; return (DataFamInstTyCon ax_unbr fam_tc lhs_tys) }++tc_iface_decl _ _ (IfaceSynonym {ifName = tc_name,+                                      ifRoles = roles,+                                      ifSynRhs = rhs_ty,+                                      ifBinders = binders,+                                      ifResKind = res_kind })+   = bindIfaceTyConBinders_AT binders $ \ binders' -> do+     { res_kind' <- tcIfaceType res_kind     -- Note [Synonym kind loop]+     ; rhs      <- forkM (mk_doc tc_name) $+                   tcIfaceType rhs_ty+     ; let tycon = buildSynTyCon tc_name binders' res_kind' roles rhs+     ; return (ATyCon tycon) }+   where+     mk_doc n = text "Type synonym" <+> ppr n++tc_iface_decl parent _ (IfaceFamily {ifName = tc_name,+                                     ifFamFlav = fam_flav,+                                     ifBinders = binders,+                                     ifResKind = res_kind,+                                     ifResVar = res, ifFamInj = inj })+   = bindIfaceTyConBinders_AT binders $ \ binders' -> do+     { res_kind' <- tcIfaceType res_kind    -- Note [Synonym kind loop]+     ; rhs      <- forkM (mk_doc tc_name) $+                   tc_fam_flav tc_name fam_flav+     ; res_name <- traverse (newIfaceName . mkTyVarOccFS) res+     ; let tycon = mkFamilyTyCon tc_name binders' res_kind' res_name rhs parent inj+     ; return (ATyCon tycon) }+   where+     mk_doc n = text "Type synonym" <+> ppr n++     tc_fam_flav :: Name -> IfaceFamTyConFlav -> IfL FamTyConFlav+     tc_fam_flav tc_name IfaceDataFamilyTyCon+       = do { tc_rep_name <- newTyConRepName tc_name+            ; return (DataFamilyTyCon tc_rep_name) }+     tc_fam_flav _ IfaceOpenSynFamilyTyCon= return OpenSynFamilyTyCon+     tc_fam_flav _ (IfaceClosedSynFamilyTyCon mb_ax_name_branches)+       = do { ax <- traverse (tcIfaceCoAxiom . fst) mb_ax_name_branches+            ; return (ClosedSynFamilyTyCon ax) }+     tc_fam_flav _ IfaceAbstractClosedSynFamilyTyCon+         = return AbstractClosedSynFamilyTyCon+     tc_fam_flav _ IfaceBuiltInSynFamTyCon+         = pprPanic "tc_iface_decl"+                    (text "IfaceBuiltInSynFamTyCon in interface file")++tc_iface_decl _parent _ignore_prags+            (IfaceClass {ifName = tc_name,+                         ifRoles = roles,+                         ifBinders = binders,+                         ifFDs = rdr_fds,+                         ifBody = IfAbstractClass})+  = bindIfaceTyConBinders binders $ \ binders' -> do+    { fds  <- mapM tc_fd rdr_fds+    ; cls  <- buildClass tc_name binders' roles fds Nothing+    ; return (ATyCon (classTyCon cls)) }++tc_iface_decl _parent ignore_prags+            (IfaceClass {ifName = tc_name,+                         ifRoles = roles,+                         ifBinders = binders,+                         ifFDs = rdr_fds,+                         ifBody = IfConcreteClass {+                             ifClassCtxt = rdr_ctxt,+                             ifATs = rdr_ats, ifSigs = rdr_sigs,+                             ifMinDef = mindef_occ+                         }})+  = bindIfaceTyConBinders binders $ \ binders' -> do+    { traceIf (text "tc-iface-class1" <+> ppr tc_name)+    ; ctxt <- mapM tc_sc rdr_ctxt+    ; traceIf (text "tc-iface-class2" <+> ppr tc_name)+    ; sigs <- mapM tc_sig rdr_sigs+    ; fds  <- mapM tc_fd rdr_fds+    ; traceIf (text "tc-iface-class3" <+> ppr tc_name)+    ; mindef <- traverse (lookupIfaceTop . mkVarOccFS) mindef_occ+    ; cls  <- fixM $ \ cls -> do+              { ats  <- mapM (tc_at cls) rdr_ats+              ; traceIf (text "tc-iface-class4" <+> ppr tc_name)+              ; buildClass tc_name binders' roles fds (Just (ctxt, ats, sigs, mindef)) }+    ; return (ATyCon (classTyCon cls)) }+  where+   tc_sc pred = forkM (mk_sc_doc pred) (tcIfaceType pred)+        -- The *length* of the superclasses is used by buildClass, and hence must+        -- not be inside the thunk.  But the *content* maybe recursive and hence+        -- must be lazy (via forkM).  Example:+        --     class C (T a) => D a where+        --       data T a+        -- Here the associated type T is knot-tied with the class, and+        -- so we must not pull on T too eagerly.  See #5970++   tc_sig :: IfaceClassOp -> IfL TcMethInfo+   tc_sig (IfaceClassOp op_name rdr_ty dm)+     = do { let doc = mk_op_doc op_name rdr_ty+          ; op_ty <- forkM (doc <+> text "ty") $ tcIfaceType rdr_ty+                -- Must be done lazily for just the same reason as the+                -- type of a data con; to avoid sucking in types that+                -- it mentions unless it's necessary to do so+          ; dm'   <- tc_dm doc dm+          ; return (op_name, op_ty, dm') }++   tc_dm :: SDoc+         -> Maybe (DefMethSpec IfaceType)+         -> IfL (Maybe (DefMethSpec (SrcSpan, Type)))+   tc_dm _   Nothing               = return Nothing+   tc_dm _   (Just VanillaDM)      = return (Just VanillaDM)+   tc_dm doc (Just (GenericDM ty))+        = do { -- Must be done lazily to avoid sucking in types+             ; ty' <- forkM (doc <+> text "dm") $ tcIfaceType ty+             ; return (Just (GenericDM (noSrcSpan, ty'))) }++   tc_at cls (IfaceAT tc_decl if_def)+     = do ATyCon tc <- tc_iface_decl (Just cls) ignore_prags tc_decl+          mb_def <- case if_def of+                      Nothing  -> return Nothing+                      Just def -> forkM (mk_at_doc tc)                 $+                                  extendIfaceTyVarEnv (tyConTyVars tc) $+                                  do { tc_def <- tcIfaceType def+                                     ; return (Just (tc_def, noSrcSpan)) }+                  -- Must be done lazily in case the RHS of the defaults mention+                  -- the type constructor being defined here+                  -- e.g.   type AT a; type AT b = AT [b]   #8002+          return (ATI tc mb_def)++   mk_sc_doc pred = text "Superclass" <+> ppr pred+   mk_at_doc tc = text "Associated type" <+> ppr tc+   mk_op_doc op_name op_ty = text "Class op" <+> sep [ppr op_name, ppr op_ty]++tc_iface_decl _ _ (IfaceAxiom { ifName = tc_name, ifTyCon = tc+                              , ifAxBranches = branches, ifRole = role })+  = do { tc_tycon    <- tcIfaceTyCon tc+       -- Must be done lazily, because axioms are forced when checking+       -- for family instance consistency, and the RHS may mention+       -- a hs-boot declared type constructor that is going to be+       -- defined by this module.+       -- e.g. type instance F Int = ToBeDefined+       -- See #13803+       ; tc_branches <- forkM (text "Axiom branches" <+> ppr tc_name)+                      $ tc_ax_branches branches+       ; let axiom = CoAxiom { co_ax_unique   = nameUnique tc_name+                             , co_ax_name     = tc_name+                             , co_ax_tc       = tc_tycon+                             , co_ax_role     = role+                             , co_ax_branches = manyBranches tc_branches+                             , co_ax_implicit = False }+       ; return (ACoAxiom axiom) }++tc_iface_decl _ _ (IfacePatSyn{ ifName = name+                              , ifPatMatcher = if_matcher+                              , ifPatBuilder = if_builder+                              , ifPatIsInfix = is_infix+                              , ifPatUnivBndrs = univ_bndrs+                              , ifPatExBndrs = ex_bndrs+                              , ifPatProvCtxt = prov_ctxt+                              , ifPatReqCtxt = req_ctxt+                              , ifPatArgs = args+                              , ifPatTy = pat_ty+                              , ifFieldLabels = field_labels })+  = do { traceIf (text "tc_iface_decl" <+> ppr name)+       ; matcher <- tc_pr if_matcher+       ; builder <- fmapMaybeM tc_pr if_builder+       ; bindIfaceForAllBndrs univ_bndrs $ \univ_tvs -> do+       { bindIfaceForAllBndrs ex_bndrs $ \ex_tvs -> do+       { patsyn <- forkM (mk_doc name) $+             do { prov_theta <- tcIfaceCtxt prov_ctxt+                ; req_theta  <- tcIfaceCtxt req_ctxt+                ; pat_ty     <- tcIfaceType pat_ty+                ; arg_tys    <- mapM tcIfaceType args+                ; return $ buildPatSyn name is_infix matcher builder+                                       (univ_tvs, req_theta)+                                       (ex_tvs, prov_theta)+                                       arg_tys pat_ty field_labels }+       ; return $ AConLike . PatSynCon $ patsyn }}}+  where+     mk_doc n = text "Pattern synonym" <+> ppr n+     tc_pr :: (IfExtName, Bool) -> IfL (Id, Bool)+     tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)+                        ; return (id, b) }++tc_fd :: FunDep IfLclName -> IfL (FunDep TyVar)+tc_fd (tvs1, tvs2) = do { tvs1' <- mapM tcIfaceTyVar tvs1+                        ; tvs2' <- mapM tcIfaceTyVar tvs2+                        ; return (tvs1', tvs2') }++tc_ax_branches :: [IfaceAxBranch] -> IfL [CoAxBranch]+tc_ax_branches if_branches = foldlM tc_ax_branch [] if_branches++tc_ax_branch :: [CoAxBranch] -> IfaceAxBranch -> IfL [CoAxBranch]+tc_ax_branch prev_branches+             (IfaceAxBranch { ifaxbTyVars = tv_bndrs+                            , ifaxbEtaTyVars = eta_tv_bndrs+                            , ifaxbCoVars = cv_bndrs+                            , ifaxbLHS = lhs, ifaxbRHS = rhs+                            , ifaxbRoles = roles, ifaxbIncomps = incomps })+  = bindIfaceTyConBinders_AT+      (map (\b -> Bndr (IfaceTvBndr b) (NamedTCB Inferred)) tv_bndrs) $ \ tvs ->+         -- The _AT variant is needed here; see Note [CoAxBranch type variables] in CoAxiom+    bindIfaceIds cv_bndrs $ \ cvs -> do+    { tc_lhs   <- tcIfaceAppArgs lhs+    ; tc_rhs   <- tcIfaceType rhs+    ; eta_tvs  <- bindIfaceTyVars eta_tv_bndrs return+    ; this_mod <- getIfModule+    ; let loc = mkGeneralSrcSpan (fsLit "module " `appendFS`+                                  moduleNameFS (moduleName this_mod))+          br = CoAxBranch { cab_loc     = loc+                          , cab_tvs     = binderVars tvs+                          , cab_eta_tvs = eta_tvs+                          , cab_cvs     = cvs+                          , cab_lhs     = tc_lhs+                          , cab_roles   = roles+                          , cab_rhs     = tc_rhs+                          , cab_incomps = map (prev_branches `getNth`) incomps }+    ; return (prev_branches ++ [br]) }++tcIfaceDataCons :: Name -> TyCon -> [TyConBinder] -> IfaceConDecls -> IfL AlgTyConRhs+tcIfaceDataCons tycon_name tycon tc_tybinders if_cons+  = case if_cons of+        IfAbstractTyCon  -> return AbstractTyCon+        IfDataTyCon cons -> do  { data_cons  <- mapM tc_con_decl cons+                                ; return (mkDataTyConRhs data_cons) }+        IfNewTyCon  con  -> do  { data_con  <- tc_con_decl con+                                ; mkNewTyConRhs tycon_name tycon data_con }+  where+    univ_tvs :: [TyVar]+    univ_tvs = binderVars (tyConTyVarBinders tc_tybinders)++    tag_map :: NameEnv ConTag+    tag_map = mkTyConTagMap tycon++    tc_con_decl (IfCon { ifConInfix = is_infix,+                         ifConExTCvs = ex_bndrs,+                         ifConUserTvBinders = user_bndrs,+                         ifConName = dc_name,+                         ifConCtxt = ctxt, ifConEqSpec = spec,+                         ifConArgTys = args, ifConFields = lbl_names,+                         ifConStricts = if_stricts,+                         ifConSrcStricts = if_src_stricts})+     = -- Universally-quantified tyvars are shared with+       -- parent TyCon, and are already in scope+       bindIfaceBndrs ex_bndrs    $ \ ex_tvs -> do+        { traceIf (text "Start interface-file tc_con_decl" <+> ppr dc_name)++          -- By this point, we have bound every universal and existential+          -- tyvar. Because of the dcUserTyVarBinders invariant+          -- (see Note [DataCon user type variable binders]), *every* tyvar in+          -- ifConUserTvBinders has a matching counterpart somewhere in the+          -- bound universals/existentials. As a result, calling tcIfaceTyVar+          -- below is always guaranteed to succeed.+        ; user_tv_bndrs <- mapM (\(Bndr bd vis) ->+                                   case bd of+                                     IfaceIdBndr (name, _) ->+                                       Bndr <$> tcIfaceLclId name <*> pure vis+                                     IfaceTvBndr (name, _) ->+                                       Bndr <$> tcIfaceTyVar name <*> pure vis)+                                user_bndrs++        -- Read the context and argument types, but lazily for two reasons+        -- (a) to avoid looking tugging on a recursive use of+        --     the type itself, which is knot-tied+        -- (b) to avoid faulting in the component types unless+        --     they are really needed+        ; ~(eq_spec, theta, arg_tys, stricts) <- forkM (mk_doc dc_name) $+             do { eq_spec <- tcIfaceEqSpec spec+                ; theta   <- tcIfaceCtxt ctxt+                -- This fixes #13710.  The enclosing lazy thunk gets+                -- forced when typechecking record wildcard pattern+                -- matching (it's not completely clear why this+                -- tuple is needed), which causes trouble if one of+                -- the argument types was recursively defined.+                -- See also Note [Tying the knot]+                ; arg_tys <- forkM (mk_doc dc_name <+> text "arg_tys")+                           $ mapM tcIfaceType args+                ; stricts <- mapM tc_strict if_stricts+                        -- The IfBang field can mention+                        -- the type itself; hence inside forkM+                ; return (eq_spec, theta, arg_tys, stricts) }++        -- Remember, tycon is the representation tycon+        ; let orig_res_ty = mkFamilyTyConApp tycon+                              (substTyCoVars (mkTvSubstPrs (map eqSpecPair eq_spec))+                                             (binderVars tc_tybinders))++        ; prom_rep_name <- newTyConRepName dc_name++        ; con <- buildDataCon (pprPanic "tcIfaceDataCons: FamInstEnvs" (ppr dc_name))+                       dc_name is_infix prom_rep_name+                       (map src_strict if_src_stricts)+                       (Just stricts)+                       -- Pass the HsImplBangs (i.e. final+                       -- decisions) to buildDataCon; it'll use+                       -- these to guide the construction of a+                       -- worker.+                       -- See Note [Bangs on imported data constructors] in MkId+                       lbl_names+                       univ_tvs ex_tvs user_tv_bndrs+                       eq_spec theta+                       arg_tys orig_res_ty tycon tag_map+        ; traceIf (text "Done interface-file tc_con_decl" <+> ppr dc_name)+        ; return con }+    mk_doc con_name = text "Constructor" <+> ppr con_name++    tc_strict :: IfaceBang -> IfL HsImplBang+    tc_strict IfNoBang = return (HsLazy)+    tc_strict IfStrict = return (HsStrict)+    tc_strict IfUnpack = return (HsUnpack Nothing)+    tc_strict (IfUnpackCo if_co) = do { co <- tcIfaceCo if_co+                                      ; return (HsUnpack (Just co)) }++    src_strict :: IfaceSrcBang -> HsSrcBang+    src_strict (IfSrcBang unpk bang) = HsSrcBang NoSourceText unpk bang++tcIfaceEqSpec :: IfaceEqSpec -> IfL [EqSpec]+tcIfaceEqSpec spec+  = mapM do_item spec+  where+    do_item (occ, if_ty) = do { tv <- tcIfaceTyVar occ+                              ; ty <- tcIfaceType if_ty+                              ; return (mkEqSpec tv ty) }++{-+Note [Synonym kind loop]+~~~~~~~~~~~~~~~~~~~~~~~~+Notice that we eagerly grab the *kind* from the interface file, but+build a forkM thunk for the *rhs* (and family stuff).  To see why,+consider this (#2412)++M.hs:       module M where { import X; data T = MkT S }+X.hs:       module X where { import {-# SOURCE #-} M; type S = T }+M.hs-boot:  module M where { data T }++When kind-checking M.hs we need S's kind.  But we do not want to+find S's kind from (typeKind S-rhs), because we don't want to look at+S-rhs yet!  Since S is imported from X.hi, S gets just one chance to+be defined, and we must not do that until we've finished with M.T.++Solution: record S's kind in the interface file; now we can safely+look at it.++************************************************************************+*                                                                      *+                Instances+*                                                                      *+************************************************************************+-}++tcIfaceInst :: IfaceClsInst -> IfL ClsInst+tcIfaceInst (IfaceClsInst { ifDFun = dfun_name, ifOFlag = oflag+                          , ifInstCls = cls, ifInstTys = mb_tcs+                          , ifInstOrph = orph })+  = do { dfun <- forkM (text "Dict fun" <+> ppr dfun_name) $+                    fmap tyThingId (tcIfaceImplicit dfun_name)+       ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs+       ; return (mkImportedInstance cls mb_tcs' dfun_name dfun oflag orph) }++tcIfaceFamInst :: IfaceFamInst -> IfL FamInst+tcIfaceFamInst (IfaceFamInst { ifFamInstFam = fam, ifFamInstTys = mb_tcs+                             , ifFamInstAxiom = axiom_name } )+    = do { axiom' <- forkM (text "Axiom" <+> ppr axiom_name) $+                     tcIfaceCoAxiom axiom_name+             -- will panic if branched, but that's OK+         ; let axiom'' = toUnbranchedAxiom axiom'+               mb_tcs' = map (fmap ifaceTyConName) mb_tcs+         ; return (mkImportedFamInst fam mb_tcs' axiom'') }++{-+************************************************************************+*                                                                      *+                Rules+*                                                                      *+************************************************************************++We move a IfaceRule from eps_rules to eps_rule_base when all its LHS free vars+are in the type environment.  However, remember that typechecking a Rule may+(as a side effect) augment the type envt, and so we may need to iterate the process.+-}++tcIfaceRules :: Bool            -- True <=> ignore rules+             -> [IfaceRule]+             -> IfL [CoreRule]+tcIfaceRules ignore_prags if_rules+  | ignore_prags = return []+  | otherwise    = mapM tcIfaceRule if_rules++tcIfaceRule :: IfaceRule -> IfL CoreRule+tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,+                        ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,+                        ifRuleAuto = auto, ifRuleOrph = orph })+  = do  { ~(bndrs', args', rhs') <-+                -- Typecheck the payload lazily, in the hope it'll never be looked at+                forkM (text "Rule" <+> pprRuleName name) $+                bindIfaceBndrs bndrs                      $ \ bndrs' ->+                do { args' <- mapM tcIfaceExpr args+                   ; rhs'  <- tcIfaceExpr rhs+                   ; return (bndrs', args', rhs') }+        ; let mb_tcs = map ifTopFreeName args+        ; this_mod <- getIfModule+        ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,+                          ru_bndrs = bndrs', ru_args = args',+                          ru_rhs = occurAnalyseExpr rhs',+                          ru_rough = mb_tcs,+                          ru_origin = this_mod,+                          ru_orphan = orph,+                          ru_auto = auto,+                          ru_local = False }) } -- An imported RULE is never for a local Id+                                                -- or, even if it is (module loop, perhaps)+                                                -- we'll just leave it in the non-local set+  where+        -- This function *must* mirror exactly what Rules.roughTopNames does+        -- We could have stored the ru_rough field in the iface file+        -- but that would be redundant, I think.+        -- The only wrinkle is that we must not be deceived by+        -- type synonyms at the top of a type arg.  Since+        -- we can't tell at this point, we are careful not+        -- to write them out in coreRuleToIfaceRule+    ifTopFreeName :: IfaceExpr -> Maybe Name+    ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc)+    ifTopFreeName (IfaceType (IfaceTupleTy s _ ts)) = Just (tupleTyConName s (length (appArgsIfaceTypes ts)))+    ifTopFreeName (IfaceApp f _)                    = ifTopFreeName f+    ifTopFreeName (IfaceExt n)                      = Just n+    ifTopFreeName _                                 = Nothing++{-+************************************************************************+*                                                                      *+                Annotations+*                                                                      *+************************************************************************+-}++tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]+tcIfaceAnnotations = mapM tcIfaceAnnotation++tcIfaceAnnotation :: IfaceAnnotation -> IfL Annotation+tcIfaceAnnotation (IfaceAnnotation target serialized) = do+    target' <- tcIfaceAnnTarget target+    return $ Annotation {+        ann_target = target',+        ann_value = serialized+    }++tcIfaceAnnTarget :: IfaceAnnTarget -> IfL (AnnTarget Name)+tcIfaceAnnTarget (NamedTarget occ) = do+    name <- lookupIfaceTop occ+    return $ NamedTarget name+tcIfaceAnnTarget (ModuleTarget mod) = do+    return $ ModuleTarget mod++{-+************************************************************************+*                                                                      *+                Complete Match Pragmas+*                                                                      *+************************************************************************+-}++tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]+tcIfaceCompleteSigs = mapM tcIfaceCompleteSig++tcIfaceCompleteSig :: IfaceCompleteMatch -> IfL CompleteMatch+tcIfaceCompleteSig (IfaceCompleteMatch ms t) = return (CompleteMatch ms t)++{-+************************************************************************+*                                                                      *+                        Types+*                                                                      *+************************************************************************+-}++tcIfaceType :: IfaceType -> IfL Type+tcIfaceType = go+  where+    go (IfaceTyVar n)          = TyVarTy <$> tcIfaceTyVar n+    go (IfaceFreeTyVar n)      = pprPanic "tcIfaceType:IfaceFreeTyVar" (ppr n)+    go (IfaceLitTy l)          = LitTy <$> tcIfaceTyLit l+    go (IfaceFunTy flag t1 t2) = FunTy flag <$> go t1 <*> go t2+    go (IfaceTupleTy s i tks)  = tcIfaceTupleTy s i tks+    go (IfaceAppTy t ts)+      = do { t'  <- go t+           ; ts' <- traverse go (appArgsIfaceTypes ts)+           ; pure (foldl' AppTy t' ts') }+    go (IfaceTyConApp tc tks)+      = do { tc' <- tcIfaceTyCon tc+           ; tks' <- mapM go (appArgsIfaceTypes tks)+           ; return (mkTyConApp tc' tks') }+    go (IfaceForAllTy bndr t)+      = bindIfaceForAllBndr bndr $ \ tv' vis ->+        ForAllTy (Bndr tv' vis) <$> go t+    go (IfaceCastTy ty co)   = CastTy <$> go ty <*> tcIfaceCo co+    go (IfaceCoercionTy co)  = CoercionTy <$> tcIfaceCo co++tcIfaceTupleTy :: TupleSort -> PromotionFlag -> IfaceAppArgs -> IfL Type+tcIfaceTupleTy sort is_promoted args+ = do { args' <- tcIfaceAppArgs args+      ; let arity = length args'+      ; base_tc <- tcTupleTyCon True sort arity+      ; case is_promoted of+          NotPromoted+            -> return (mkTyConApp base_tc args')++          IsPromoted+            -> do { let tc        = promoteDataCon (tyConSingleDataCon base_tc)+                        kind_args = map typeKind args'+                  ; return (mkTyConApp tc (kind_args ++ args')) } }++-- See Note [Unboxed tuple RuntimeRep vars] in TyCon+tcTupleTyCon :: Bool    -- True <=> typechecking a *type* (vs. an expr)+             -> TupleSort+             -> Arity   -- the number of args. *not* the tuple arity.+             -> IfL TyCon+tcTupleTyCon in_type sort arity+  = case sort of+      ConstraintTuple -> do { thing <- tcIfaceGlobal (cTupleTyConName arity)+                            ; return (tyThingTyCon thing) }+      BoxedTuple   -> return (tupleTyCon Boxed   arity)+      UnboxedTuple -> return (tupleTyCon Unboxed arity')+        where arity' | in_type   = arity `div` 2+                     | otherwise = arity+                      -- in expressions, we only have term args++tcIfaceAppArgs :: IfaceAppArgs -> IfL [Type]+tcIfaceAppArgs = mapM tcIfaceType . appArgsIfaceTypes++-----------------------------------------+tcIfaceCtxt :: IfaceContext -> IfL ThetaType+tcIfaceCtxt sts = mapM tcIfaceType sts++-----------------------------------------+tcIfaceTyLit :: IfaceTyLit -> IfL TyLit+tcIfaceTyLit (IfaceNumTyLit n) = return (NumTyLit n)+tcIfaceTyLit (IfaceStrTyLit n) = return (StrTyLit n)++{-+%************************************************************************+%*                                                                      *+                        Coercions+*                                                                      *+************************************************************************+-}++tcIfaceCo :: IfaceCoercion -> IfL Coercion+tcIfaceCo = go+  where+    go_mco IfaceMRefl    = pure MRefl+    go_mco (IfaceMCo co) = MCo <$> (go co)++    go (IfaceReflCo t)           = Refl <$> tcIfaceType t+    go (IfaceGReflCo r t mco)    = GRefl r <$> tcIfaceType t <*> go_mco mco+    go (IfaceFunCo r c1 c2)      = mkFunCo r <$> go c1 <*> go c2+    go (IfaceTyConAppCo r tc cs)+      = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs+    go (IfaceAppCo c1 c2)        = AppCo <$> go c1 <*> go c2+    go (IfaceForAllCo tv k c)  = do { k' <- go k+                                      ; bindIfaceBndr tv $ \ tv' ->+                                        ForAllCo tv' k' <$> go c }+    go (IfaceCoVarCo n)          = CoVarCo <$> go_var n+    go (IfaceAxiomInstCo n i cs) = AxiomInstCo <$> tcIfaceCoAxiom n <*> pure i <*> mapM go cs+    go (IfaceUnivCo p r t1 t2)   = UnivCo <$> tcIfaceUnivCoProv p <*> pure r+                                          <*> tcIfaceType t1 <*> tcIfaceType t2+    go (IfaceSymCo c)            = SymCo    <$> go c+    go (IfaceTransCo c1 c2)      = TransCo  <$> go c1+                                            <*> go c2+    go (IfaceInstCo c1 t2)       = InstCo   <$> go c1+                                            <*> go t2+    go (IfaceNthCo d c)          = do { c' <- go c+                                      ; return $ mkNthCo (nthCoRole d c') d c' }+    go (IfaceLRCo lr c)          = LRCo lr  <$> go c+    go (IfaceKindCo c)           = KindCo   <$> go c+    go (IfaceSubCo c)            = SubCo    <$> go c+    go (IfaceAxiomRuleCo ax cos) = AxiomRuleCo <$> tcIfaceCoAxiomRule ax+                                               <*> mapM go cos+    go (IfaceFreeCoVar c)        = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c)+    go (IfaceHoleCo c)           = pprPanic "tcIfaceCo:IfaceHoleCo"    (ppr c)++    go_var :: FastString -> IfL CoVar+    go_var = tcIfaceLclId++tcIfaceUnivCoProv :: IfaceUnivCoProv -> IfL UnivCoProvenance+tcIfaceUnivCoProv IfaceUnsafeCoerceProv     = return UnsafeCoerceProv+tcIfaceUnivCoProv (IfacePhantomProv kco)    = PhantomProv <$> tcIfaceCo kco+tcIfaceUnivCoProv (IfaceProofIrrelProv kco) = ProofIrrelProv <$> tcIfaceCo kco+tcIfaceUnivCoProv (IfacePluginProv str)     = return $ PluginProv str++{-+************************************************************************+*                                                                      *+                        Core+*                                                                      *+************************************************************************+-}++tcIfaceExpr :: IfaceExpr -> IfL CoreExpr+tcIfaceExpr (IfaceType ty)+  = Type <$> tcIfaceType ty++tcIfaceExpr (IfaceCo co)+  = Coercion <$> tcIfaceCo co++tcIfaceExpr (IfaceCast expr co)+  = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co++tcIfaceExpr (IfaceLcl name)+  = Var <$> tcIfaceLclId name++tcIfaceExpr (IfaceExt gbl)+  = Var <$> tcIfaceExtId gbl++tcIfaceExpr (IfaceLit lit)+  = do lit' <- tcIfaceLit lit+       return (Lit lit')++tcIfaceExpr (IfaceFCall cc ty) = do+    ty' <- tcIfaceType ty+    u <- newUnique+    dflags <- getDynFlags+    return (Var (mkFCallId dflags u cc ty'))++tcIfaceExpr (IfaceTuple sort args)+  = do { args' <- mapM tcIfaceExpr args+       ; tc <- tcTupleTyCon False sort arity+       ; let con_tys = map exprType args'+             some_con_args = map Type con_tys ++ args'+             con_args = case sort of+               UnboxedTuple -> map (Type . getRuntimeRep) con_tys ++ some_con_args+               _            -> some_con_args+                        -- Put the missing type arguments back in+             con_id   = dataConWorkId (tyConSingleDataCon tc)+       ; return (mkApps (Var con_id) con_args) }+  where+    arity = length args++tcIfaceExpr (IfaceLam (bndr, os) body)+  = bindIfaceBndr bndr $ \bndr' ->+    Lam (tcIfaceOneShot os bndr') <$> tcIfaceExpr body+  where+    tcIfaceOneShot IfaceOneShot b = setOneShotLambda b+    tcIfaceOneShot _            b = b++tcIfaceExpr (IfaceApp fun arg)+  = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg++tcIfaceExpr (IfaceECase scrut ty)+  = do { scrut' <- tcIfaceExpr scrut+       ; ty' <- tcIfaceType ty+       ; return (castBottomExpr scrut' ty') }++tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do+    scrut' <- tcIfaceExpr scrut+    case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)+    let+        scrut_ty   = exprType scrut'+        case_bndr' = mkLocalIdOrCoVar case_bndr_name scrut_ty+        tc_app     = splitTyConApp scrut_ty+                -- NB: Won't always succeed (polymorphic case)+                --     but won't be demanded in those cases+                -- NB: not tcSplitTyConApp; we are looking at Core here+                --     look through non-rec newtypes to find the tycon that+                --     corresponds to the datacon in this case alternative++    extendIfaceIdEnv [case_bndr'] $ do+     alts' <- mapM (tcIfaceAlt scrut' tc_app) alts+     return (Case scrut' case_bndr' (coreAltsType alts') alts')++tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info ji) rhs) body)+  = do  { name    <- newIfaceName (mkVarOccFS fs)+        ; ty'     <- tcIfaceType ty+        ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}+                              NotTopLevel name ty' info+        ; let id = mkLocalIdOrCoVarWithInfo name ty' id_info+                     `asJoinId_maybe` tcJoinInfo ji+        ; rhs' <- tcIfaceExpr rhs+        ; body' <- extendIfaceIdEnv [id] (tcIfaceExpr body)+        ; return (Let (NonRec id rhs') body') }++tcIfaceExpr (IfaceLet (IfaceRec pairs) body)+  = do { ids <- mapM tc_rec_bndr (map fst pairs)+       ; extendIfaceIdEnv ids $ do+       { pairs' <- zipWithM tc_pair pairs ids+       ; body' <- tcIfaceExpr body+       ; return (Let (Rec pairs') body') } }+ where+   tc_rec_bndr (IfLetBndr fs ty _ ji)+     = do { name <- newIfaceName (mkVarOccFS fs)+          ; ty'  <- tcIfaceType ty+          ; return (mkLocalIdOrCoVar name ty' `asJoinId_maybe` tcJoinInfo ji) }+   tc_pair (IfLetBndr _ _ info _, rhs) id+     = do { rhs' <- tcIfaceExpr rhs+          ; id_info <- tcIdInfo False {- Don't ignore prags; we are inside one! -}+                                NotTopLevel (idName id) (idType id) info+          ; return (setIdInfo id id_info, rhs') }++tcIfaceExpr (IfaceTick tickish expr) = do+    expr' <- tcIfaceExpr expr+    -- If debug flag is not set: Ignore source notes+    dbgLvl <- fmap debugLevel getDynFlags+    case tickish of+      IfaceSource{} | dbgLvl > 0+                    -> return expr'+      _otherwise    -> do+        tickish' <- tcIfaceTickish tickish+        return (Tick tickish' expr')++-------------------------+tcIfaceTickish :: IfaceTickish -> IfM lcl (Tickish Id)+tcIfaceTickish (IfaceHpcTick modl ix)   = return (HpcTick modl ix)+tcIfaceTickish (IfaceSCC  cc tick push) = return (ProfNote cc tick push)+tcIfaceTickish (IfaceSource src name)   = return (SourceNote src name)++-------------------------+tcIfaceLit :: Literal -> IfL Literal+-- Integer literals deserialise to (LitInteger i <error thunk>)+-- so tcIfaceLit just fills in the type.+-- See Note [Integer literals] in Literal+tcIfaceLit (LitNumber LitNumInteger i _)+  = do t <- tcIfaceTyConByName integerTyConName+       return (mkLitInteger i (mkTyConTy t))+-- Natural literals deserialise to (LitNatural i <error thunk>)+-- so tcIfaceLit just fills in the type.+-- See Note [Natural literals] in Literal+tcIfaceLit (LitNumber LitNumNatural i _)+  = do t <- tcIfaceTyConByName naturalTyConName+       return (mkLitNatural i (mkTyConTy t))+tcIfaceLit lit = return lit++-------------------------+tcIfaceAlt :: CoreExpr -> (TyCon, [Type])+           -> (IfaceConAlt, [FastString], IfaceExpr)+           -> IfL (AltCon, [TyVar], CoreExpr)+tcIfaceAlt _ _ (IfaceDefault, names, rhs)+  = ASSERT( null names ) do+    rhs' <- tcIfaceExpr rhs+    return (DEFAULT, [], rhs')++tcIfaceAlt _ _ (IfaceLitAlt lit, names, rhs)+  = ASSERT( null names ) do+    lit' <- tcIfaceLit lit+    rhs' <- tcIfaceExpr rhs+    return (LitAlt lit', [], rhs')++-- A case alternative is made quite a bit more complicated+-- by the fact that we omit type annotations because we can+-- work them out.  True enough, but its not that easy!+tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)+  = do  { con <- tcIfaceDataCon data_occ+        ; when (debugIsOn && not (con `elem` tyConDataCons tycon))+               (failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))+        ; tcIfaceDataAlt con inst_tys arg_strs rhs }++tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr+               -> IfL (AltCon, [TyVar], CoreExpr)+tcIfaceDataAlt con inst_tys arg_strs rhs+  = do  { us <- newUniqueSupply+        ; let uniqs = uniqsFromSupply us+        ; let (ex_tvs, arg_ids)+                      = dataConRepFSInstPat arg_strs uniqs con inst_tys++        ; rhs' <- extendIfaceEnvs  ex_tvs       $+                  extendIfaceIdEnv arg_ids      $+                  tcIfaceExpr rhs+        ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }++{-+************************************************************************+*                                                                      *+                IdInfo+*                                                                      *+************************************************************************+-}++tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails+tcIdDetails _  IfVanillaId = return VanillaId+tcIdDetails ty IfDFunId+  = return (DFunId (isNewTyCon (classTyCon cls)))+  where+    (_, _, cls, _) = tcSplitDFunTy ty++tcIdDetails _ (IfRecSelId tc naughty)+  = do { tc' <- either (fmap RecSelData . tcIfaceTyCon)+                       (fmap (RecSelPatSyn . tyThingPatSyn) . tcIfaceDecl False)+                       tc+       ; return (RecSelId { sel_tycon = tc', sel_naughty = naughty }) }+  where+    tyThingPatSyn (AConLike (PatSynCon ps)) = ps+    tyThingPatSyn _ = panic "tcIdDetails: expecting patsyn"++tcIdInfo :: Bool -> TopLevelFlag -> Name -> Type -> IfaceIdInfo -> IfL IdInfo+tcIdInfo ignore_prags toplvl name ty info = do+    lcl_env <- getLclEnv+    -- Set the CgInfo to something sensible but uninformative before+    -- we start; default assumption is that it has CAFs+    let init_info | if_boot lcl_env = vanillaIdInfo `setUnfoldingInfo` BootUnfolding+                  | otherwise       = vanillaIdInfo+    if ignore_prags+        then return init_info+        else case info of+                NoInfo -> return init_info+                HasInfo info -> foldlM tcPrag init_info info+  where+    tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo+    tcPrag info HsNoCafRefs        = return (info `setCafInfo`   NoCafRefs)+    tcPrag info (HsArity arity)    = return (info `setArityInfo` arity)+    tcPrag info (HsStrictness str) = return (info `setStrictnessInfo` str)+    tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)+    tcPrag info HsLevity           = return (info `setNeverLevPoly` ty)++        -- The next two are lazy, so they don't transitively suck stuff in+    tcPrag info (HsUnfold lb if_unf)+      = do { unf <- tcUnfolding toplvl name ty info if_unf+           ; let info1 | lb        = info `setOccInfo` strongLoopBreaker+                       | otherwise = info+           ; return (info1 `setUnfoldingInfo` unf) }++tcJoinInfo :: IfaceJoinInfo -> Maybe JoinArity+tcJoinInfo (IfaceJoinPoint ar) = Just ar+tcJoinInfo IfaceNotJoinPoint   = Nothing++tcUnfolding :: TopLevelFlag -> Name -> Type -> IdInfo -> IfaceUnfolding -> IfL Unfolding+tcUnfolding toplvl name _ info (IfCoreUnfold stable if_expr)+  = do  { dflags <- getDynFlags+        ; mb_expr <- tcPragExpr toplvl name if_expr+        ; let unf_src | stable    = InlineStable+                      | otherwise = InlineRhs+        ; return $ case mb_expr of+            Nothing -> NoUnfolding+            Just expr -> mkUnfolding dflags unf_src+                           True {- Top level -}+                           (isBottomingSig strict_sig)+                           expr+        }+  where+     -- Strictness should occur before unfolding!+    strict_sig = strictnessInfo info+tcUnfolding toplvl name _ _ (IfCompulsory if_expr)+  = do  { mb_expr <- tcPragExpr toplvl name if_expr+        ; return (case mb_expr of+                    Nothing   -> NoUnfolding+                    Just expr -> mkCompulsoryUnfolding expr) }++tcUnfolding toplvl name _ _ (IfInlineRule arity unsat_ok boring_ok if_expr)+  = do  { mb_expr <- tcPragExpr toplvl name if_expr+        ; return (case mb_expr of+                    Nothing   -> NoUnfolding+                    Just expr -> mkCoreUnfolding InlineStable True expr guidance )}+  where+    guidance = UnfWhen { ug_arity = arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }++tcUnfolding _toplvl name dfun_ty _ (IfDFunUnfold bs ops)+  = bindIfaceBndrs bs $ \ bs' ->+    do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops+       ; return (case mb_ops1 of+                    Nothing   -> noUnfolding+                    Just ops1 -> mkDFunUnfolding bs' (classDataCon cls) ops1) }+  where+    doc = text "Class ops for dfun" <+> ppr name+    (_, _, cls, _) = tcSplitDFunTy dfun_ty++{-+For unfoldings we try to do the job lazily, so that we never type check+an unfolding that isn't going to be looked at.+-}++tcPragExpr :: TopLevelFlag -> Name -> IfaceExpr -> IfL (Maybe CoreExpr)+tcPragExpr toplvl name expr+  = forkM_maybe doc $ do+    core_expr' <- tcIfaceExpr expr++    -- Check for type consistency in the unfolding+    -- See Note [Linting Unfoldings from Interfaces]+    when (isTopLevel toplvl) $ whenGOptM Opt_DoCoreLinting $ do+        in_scope <- get_in_scope+        dflags   <- getDynFlags+        case lintUnfolding dflags noSrcLoc in_scope core_expr' of+          Nothing       -> return ()+          Just fail_msg -> do { mod <- getIfModule+                              ; pprPanic "Iface Lint failure"+                                  (vcat [ text "In interface for" <+> ppr mod+                                        , hang doc 2 fail_msg+                                        , ppr name <+> equals <+> ppr core_expr'+                                        , text "Iface expr =" <+> ppr expr ]) }+    return core_expr'+  where+    doc = text "Unfolding of" <+> ppr name++    get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting+    get_in_scope+        = do { (gbl_env, lcl_env) <- getEnvs+             ; rec_ids <- case if_rec_types gbl_env of+                            Nothing -> return []+                            Just (_, get_env) -> do+                               { type_env <- setLclEnv () get_env+                               ; return (typeEnvIds type_env) }+             ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`+                       bindingsVars (if_id_env lcl_env) `unionVarSet`+                       mkVarSet rec_ids) }++    bindingsVars :: FastStringEnv Var -> VarSet+    bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm+      -- It's OK to use nonDetEltsUFM here because we immediately forget+      -- the ordering by creating a set++{-+************************************************************************+*                                                                      *+                Getting from Names to TyThings+*                                                                      *+************************************************************************+-}++tcIfaceGlobal :: Name -> IfL TyThing+tcIfaceGlobal name+  | Just thing <- wiredInNameTyThing_maybe name+        -- Wired-in things include TyCons, DataCons, and Ids+        -- Even though we are in an interface file, we want to make+        -- sure the instances and RULES of this thing (particularly TyCon) are loaded+        -- Imagine: f :: Double -> Double+  = do { ifCheckWiredInThing thing; return thing }++  | otherwise+  = do  { env <- getGblEnv+        ; case if_rec_types env of {    -- Note [Tying the knot]+            Just (mod, get_type_env)+                | nameIsLocalOrFrom mod name+                -> do           -- It's defined in the module being compiled+                { type_env <- setLclEnv () get_type_env         -- yuk+                ; case lookupNameEnv type_env name of+                    Just thing -> return thing+                    -- See Note [Knot-tying fallback on boot]+                    Nothing   -> via_external+                }++          ; _ -> via_external }}+  where+    via_external =  do+        { hsc_env <- getTopEnv+        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)+        ; case mb_thing of {+            Just thing -> return thing ;+            Nothing    -> do++        { mb_thing <- importDecl name   -- It's imported; go get it+        ; case mb_thing of+            Failed err      -> failIfM err+            Succeeded thing -> return thing+        }}}++-- Note [Tying the knot]+-- ~~~~~~~~~~~~~~~~~~~~~+-- The if_rec_types field is used when we are compiling M.hs, which indirectly+-- imports Foo.hi, which mentions M.T Then we look up M.T in M's type+-- environment, which is splatted into if_rec_types after we've built M's type+-- envt.+--+-- This is a dark and complicated part of GHC type checking, with a lot+-- of moving parts.  Interested readers should also look at:+--+--      * Note [Knot-tying typecheckIface]+--      * Note [DFun knot-tying]+--      * Note [hsc_type_env_var hack]+--      * Note [Knot-tying fallback on boot]+--+-- There is also a wiki page on the subject, see:+--+--      https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/tying-the-knot++-- Note [Knot-tying fallback on boot]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Suppose that you are typechecking A.hs, which transitively imports,+-- via B.hs, A.hs-boot. When we poke on B.hs and discover that it+-- has a reference to a type T from A, what TyThing should we wire+-- it up with? Clearly, if we have already typechecked T and+-- added it into the type environment, we should go ahead and use that+-- type. But what if we haven't typechecked it yet?+--+-- For the longest time, GHC adopted the policy that this was+-- *an error condition*; that you MUST NEVER poke on B.hs's reference+-- to a T defined in A.hs until A.hs has gotten around to kind-checking+-- T and adding it to the env. However, actually ensuring this is the+-- case has proven to be a bug farm, because it's really difficult to+-- actually ensure this never happens. The problem was especially poignant+-- with type family consistency checks, which eagerly happen before any+-- typechecking takes place.+--+-- Today, we take a different strategy: if we ever try to access+-- an entity from A which doesn't exist, we just fall back on the+-- definition of A from the hs-boot file. This is complicated in+-- its own way: it means that you may end up with a mix of A.hs and+-- A.hs-boot TyThings during the course of typechecking.  We don't+-- think (and have not observed) any cases where this would cause+-- problems, but the hypothetical situation one might worry about+-- is something along these lines in Core:+--+--    case x of+--        A -> e1+--        B -> e2+--+-- If, when typechecking this, we find x :: T, and the T we are hooked+-- up with is the abstract one from the hs-boot file, rather than the+-- one defined in this module with constructors A and B.  But it's hard+-- to see how this could happen, especially because the reference to+-- the constructor (A and B) means that GHC will always typecheck+-- this expression *after* typechecking T.++tcIfaceTyConByName :: IfExtName -> IfL TyCon+tcIfaceTyConByName name+  = do { thing <- tcIfaceGlobal name+       ; return (tyThingTyCon thing) }++tcIfaceTyCon :: IfaceTyCon -> IfL TyCon+tcIfaceTyCon (IfaceTyCon name info)+  = do { thing <- tcIfaceGlobal name+       ; return $ case ifaceTyConIsPromoted info of+           NotPromoted -> tyThingTyCon thing+           IsPromoted    -> promoteDataCon $ tyThingDataCon thing }++tcIfaceCoAxiom :: Name -> IfL (CoAxiom Branched)+tcIfaceCoAxiom name = do { thing <- tcIfaceImplicit name+                         ; return (tyThingCoAxiom thing) }+++tcIfaceCoAxiomRule :: IfLclName -> IfL CoAxiomRule+-- Unlike CoAxioms, which arise form user 'type instance' declarations,+-- there are a fixed set of CoAxiomRules,+-- currently enumerated in typeNatCoAxiomRules+tcIfaceCoAxiomRule n+  = case Map.lookup n typeNatCoAxiomRules of+        Just ax -> return ax+        _  -> pprPanic "tcIfaceCoAxiomRule" (ppr n)++tcIfaceDataCon :: Name -> IfL DataCon+tcIfaceDataCon name = do { thing <- tcIfaceGlobal name+                         ; case thing of+                                AConLike (RealDataCon dc) -> return dc+                                _       -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) }++tcIfaceExtId :: Name -> IfL Id+tcIfaceExtId name = do { thing <- tcIfaceGlobal name+                       ; case thing of+                          AnId id -> return id+                          _       -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) }++-- See Note [Resolving never-exported Names in TcIface]+tcIfaceImplicit :: Name -> IfL TyThing+tcIfaceImplicit n = do+    lcl_env <- getLclEnv+    case if_implicits_env lcl_env of+        Nothing -> tcIfaceGlobal n+        Just tenv ->+            case lookupTypeEnv tenv n of+                Nothing -> pprPanic "tcIfaceInst" (ppr n $$ ppr tenv)+                Just tything -> return tything++{-+************************************************************************+*                                                                      *+                Bindings+*                                                                      *+************************************************************************+-}++bindIfaceId :: IfaceIdBndr -> (Id -> IfL a) -> IfL a+bindIfaceId (fs, ty) thing_inside+  = do  { name <- newIfaceName (mkVarOccFS fs)+        ; ty' <- tcIfaceType ty+        ; let id = mkLocalIdOrCoVar name ty'+        ; extendIfaceIdEnv [id] (thing_inside id) }++bindIfaceIds :: [IfaceIdBndr] -> ([Id] -> IfL a) -> IfL a+bindIfaceIds [] thing_inside = thing_inside []+bindIfaceIds (b:bs) thing_inside+  = bindIfaceId b   $ \b'  ->+    bindIfaceIds bs $ \bs' ->+    thing_inside (b':bs')++bindIfaceBndr :: IfaceBndr -> (CoreBndr -> IfL a) -> IfL a+bindIfaceBndr (IfaceIdBndr bndr) thing_inside+  = bindIfaceId bndr thing_inside+bindIfaceBndr (IfaceTvBndr bndr) thing_inside+  = bindIfaceTyVar bndr thing_inside++bindIfaceBndrs :: [IfaceBndr] -> ([CoreBndr] -> IfL a) -> IfL a+bindIfaceBndrs []     thing_inside = thing_inside []+bindIfaceBndrs (b:bs) thing_inside+  = bindIfaceBndr b     $ \ b' ->+    bindIfaceBndrs bs   $ \ bs' ->+    thing_inside (b':bs')++-----------------------+bindIfaceForAllBndrs :: [IfaceForAllBndr] -> ([TyCoVarBinder] -> IfL a) -> IfL a+bindIfaceForAllBndrs [] thing_inside = thing_inside []+bindIfaceForAllBndrs (bndr:bndrs) thing_inside+  = bindIfaceForAllBndr bndr $ \tv vis ->+    bindIfaceForAllBndrs bndrs $ \bndrs' ->+    thing_inside (mkTyCoVarBinder vis tv : bndrs')++bindIfaceForAllBndr :: IfaceForAllBndr -> (TyCoVar -> ArgFlag -> IfL a) -> IfL a+bindIfaceForAllBndr (Bndr (IfaceTvBndr tv) vis) thing_inside+  = bindIfaceTyVar tv $ \tv' -> thing_inside tv' vis+bindIfaceForAllBndr (Bndr (IfaceIdBndr tv) vis) thing_inside+  = bindIfaceId tv $ \tv' -> thing_inside tv' vis++bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a+bindIfaceTyVar (occ,kind) thing_inside+  = do  { name <- newIfaceName (mkTyVarOccFS occ)+        ; tyvar <- mk_iface_tyvar name kind+        ; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }++bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a+bindIfaceTyVars [] thing_inside = thing_inside []+bindIfaceTyVars (bndr:bndrs) thing_inside+  = bindIfaceTyVar bndr   $ \tv  ->+    bindIfaceTyVars bndrs $ \tvs ->+    thing_inside (tv : tvs)++mk_iface_tyvar :: Name -> IfaceKind -> IfL TyVar+mk_iface_tyvar name ifKind+   = do { kind <- tcIfaceType ifKind+        ; return (Var.mkTyVar name kind) }++bindIfaceTyConBinders :: [IfaceTyConBinder]+                      -> ([TyConBinder] -> IfL a) -> IfL a+bindIfaceTyConBinders [] thing_inside = thing_inside []+bindIfaceTyConBinders (b:bs) thing_inside+  = bindIfaceTyConBinderX bindIfaceBndr b $ \ b'  ->+    bindIfaceTyConBinders bs              $ \ bs' ->+    thing_inside (b':bs')++bindIfaceTyConBinders_AT :: [IfaceTyConBinder]+                         -> ([TyConBinder] -> IfL a) -> IfL a+-- Used for type variable in nested associated data/type declarations+-- where some of the type variables are already in scope+--    class C a where { data T a b }+-- Here 'a' is in scope when we look at the 'data T'+bindIfaceTyConBinders_AT [] thing_inside+  = thing_inside []+bindIfaceTyConBinders_AT (b : bs) thing_inside+  = bindIfaceTyConBinderX bind_tv b  $ \b'  ->+    bindIfaceTyConBinders_AT      bs $ \bs' ->+    thing_inside (b':bs')+  where+    bind_tv tv thing+      = do { mb_tv <- lookupIfaceVar tv+           ; case mb_tv of+               Just b' -> thing b'+               Nothing -> bindIfaceBndr tv thing }++bindIfaceTyConBinderX :: (IfaceBndr -> (TyCoVar -> IfL a) -> IfL a)+                      -> IfaceTyConBinder+                      -> (TyConBinder -> IfL a) -> IfL a+bindIfaceTyConBinderX bind_tv (Bndr tv vis) thing_inside+  = bind_tv tv $ \tv' ->+    thing_inside (Bndr tv' vis)
+ compiler/iface/TcIface.hs-boot view
@@ -0,0 +1,19 @@+module TcIface where++import GhcPrelude+import IfaceSyn    ( IfaceDecl, IfaceClsInst, IfaceFamInst, IfaceRule,+                     IfaceAnnotation, IfaceCompleteMatch )+import TyCoRep     ( TyThing )+import TcRnTypes   ( IfL )+import InstEnv     ( ClsInst )+import FamInstEnv  ( FamInst )+import CoreSyn     ( CoreRule )+import HscTypes    ( CompleteMatch )+import Annotations ( Annotation )++tcIfaceDecl         :: Bool -> IfaceDecl -> IfL TyThing+tcIfaceRules        :: Bool -> [IfaceRule] -> IfL [CoreRule]+tcIfaceInst         :: IfaceClsInst -> IfL ClsInst+tcIfaceFamInst      :: IfaceFamInst -> IfL FamInst+tcIfaceAnnotations  :: [IfaceAnnotation] -> IfL [Annotation]+tcIfaceCompleteSigs :: [IfaceCompleteMatch] -> IfL [CompleteMatch]
+ compiler/llvmGen/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 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 view
@@ -0,0 +1,352 @@+--------------------------------------------------------------------------------+-- | 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 view
@@ -0,0 +1,95 @@+{-# 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 view
@@ -0,0 +1,499 @@+{-# 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 view
@@ -0,0 +1,894 @@+{-# 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 "readnon"+  ppr ReadOnly           = text "readonly"+  ppr Ssp                = text "ssp"+  ppr SspReq             = text "ssqreq"+  ppr NoRedZone          = text "noredzone"+  ppr NoImplicitFloat    = text "noimplicitfloat"+  ppr Naked              = text "naked"+++-- | Different types to call a function.+data LlvmCallType+  -- | Normal call, allocate a new stack frame.+  = StdCall+  -- | Tail call, perform the call in the current stack frame.+  | TailCall+  deriving (Eq,Show)++-- | Different calling conventions a function can use.+data LlvmCallConvention+  -- | The C calling convention.+  -- This calling convention (the default if no other calling convention is+  -- specified) matches the target C calling conventions. This calling+  -- convention supports varargs function calls and tolerates some mismatch in+  -- the declared prototype and implemented declaration of the function (as+  -- does normal C).+  = CC_Ccc+  -- | This calling convention attempts to make calls as fast as possible+  -- (e.g. by passing things in registers). This calling convention allows+  -- the target to use whatever tricks it wants to produce fast code for the+  -- target, without having to conform to an externally specified ABI+  -- (Application Binary Interface). Implementations of this convention should+  -- allow arbitrary tail call optimization to be supported. This calling+  -- convention does not support varargs and requires the prototype of al+  -- callees to exactly match the prototype of the function definition.+  | CC_Fastcc+  -- | This calling convention attempts to make code in the caller as efficient+  -- as possible under the assumption that the call is not commonly executed.+  -- As such, these calls often preserve all registers so that the call does+  -- not break any live ranges in the caller side. This calling convention+  -- does not support varargs and requires the prototype of all callees to+  -- exactly match the prototype of the function definition.+  | CC_Coldcc+  -- | The GHC-specific 'registerised' calling convention.+  | CC_Ghc+  -- | Any calling convention may be specified by number, allowing+  -- target-specific calling conventions to be used. Target specific calling+  -- conventions start at 64.+  | CC_Ncc Int+  -- | X86 Specific 'StdCall' convention. LLVM includes a specific alias for it+  -- rather than just using CC_Ncc.+  | CC_X86_Stdcc+  deriving (Eq)++instance Outputable LlvmCallConvention where+  ppr CC_Ccc       = text "ccc"+  ppr CC_Fastcc    = text "fastcc"+  ppr CC_Coldcc    = text "coldcc"+  ppr CC_Ghc       = text "ghccc"+  ppr (CC_Ncc i)   = text "cc " <> ppr i+  ppr CC_X86_Stdcc = text "x86_stdcallcc"+++-- | Functions can have a fixed amount of parameters, or a variable amount.+data LlvmParameterListType+  -- Fixed amount of arguments.+  = FixedArgs+  -- Variable amount of arguments.+  | VarArgs+  deriving (Eq,Show)+++-- | Linkage type of a symbol.+--+-- The description of the constructors is copied from the Llvm Assembly Language+-- Reference Manual <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"++        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++-- | Reverse or leave byte data alone to fix endianness on this target.+fixEndian :: [a] -> [a]+#if defined(WORDS_BIGENDIAN)+fixEndian = id+#else+fixEndian = reverse+#endif+++--------------------------------------------------------------------------------+-- * 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 view
@@ -0,0 +1,235 @@+{-# LANGUAGE CPP, TypeFamilies, ViewPatterns #-}++-- -----------------------------------------------------------------------------+-- | This is the top-level module in the LLVM code generator.+--+module LlvmCodeGen ( 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 BlockId+import CgUtils ( fixStgRegisters )+import Cmm+import CmmUtils+import Hoopl.Block+import Hoopl.Collections+import PprCmm++import BufWrite+import DynFlags+import ErrUtils+import FastString+import Outputable+import UniqSupply+import SysTools ( figureLlvmVersion )+import qualified Stream++import Control.Monad ( when )+import Data.Maybe ( fromMaybe, catMaybes )+import System.IO++-- -----------------------------------------------------------------------------+-- | Top-level of the LLVM Code generator+--+llvmCodeGen :: DynFlags -> Handle -> UniqSupply+               -> Stream.Stream IO RawCmmGroup ()+               -> IO ()+llvmCodeGen dflags h us cmm_stream+  = withTiming (pure dflags) (text "LLVM CodeGen") (const ()) $ do+       bufh <- newBufHandle h++       -- Pass header+       showPass dflags "LLVM CodeGen"++       -- get llvm version, cache for later use+       ver <- (fromMaybe supportedLlvmVersion) `fmap` figureLlvmVersion dflags++       -- warn if unsupported+       debugTraceMsg dflags 2+            (text "Using LLVM version:" <+> text (show ver))+       let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags+       when (ver /= supportedLlvmVersion && doWarn) $+           putMsg dflags (text "You are using an unsupported version of LLVM!"+                            $+$ text ("Currently only " +++                                      llvmVersionStr supportedLlvmVersion +++                                      " is supported.")+                            $+$ text "We will try though...")++       -- run code generation+       runLlvm dflags ver bufh us $+         llvmCodeGen' (liftStream cmm_stream)++       bFlush bufh++llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM ()+llvmCodeGen' cmm_stream+  = do  -- Preamble+        renderLlvm header+        ghcInternalFunctions+        cmmMetaLlvmPrelude++        -- Procedures+        let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream+        _ <- Stream.collect llvmStream++        -- Declare aliases for forward references+        renderLlvm . pprLlvmData =<< generateExternDecls++        -- Postamble+        cmmUsedLlvmGens+  where+    header :: SDoc+    header = sdocWithDynFlags $ \dflags ->+      let target = LLVM_TARGET+          layout = case lookup target (llvmTargets dflags) of+            Just (LlvmTarget dl _ _) -> dl+            Nothing -> error $ "Failed to lookup the datalayout for " ++ target ++ "; available targets: " ++ show (map fst $ llvmTargets dflags)+      in     text ("target datalayout = \"" ++ layout ++ "\"")+         $+$ text ("target triple = \"" ++ target ++ "\"")++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)++-- | LLVM can't handle entry blocks which loop back to themselves (could be+-- seen as an LLVM bug) so we rearrange the code to keep the original entry+-- label which branches to a newly generated second label that branches back+-- to itself. See: #11649+fixBottom :: RawCmmDecl -> LlvmM RawCmmDecl+fixBottom cp@(CmmProc hdr entry_lbl live g) =+    maybe (pure cp) fix_block $ mapLookup (g_entry g) blk_map+  where+    blk_map = toBlockMap g++    fix_block :: CmmBlock -> LlvmM RawCmmDecl+    fix_block blk+        | (CmmEntry e_lbl tickscp, middle, CmmBranch b_lbl) <- blockSplit blk+        , isEmptyBlock middle+        , e_lbl == b_lbl = do+            new_lbl <- mkBlockId <$> getUniqueM++            let fst_blk =+                    BlockCC (CmmEntry e_lbl tickscp) BNil (CmmBranch new_lbl)+                snd_blk =+                    BlockCC (CmmEntry new_lbl tickscp) BNil (CmmBranch new_lbl)++            pure . CmmProc hdr entry_lbl live . ofBlockMap (g_entry g)+                $ mapFromList [(e_lbl, fst_blk), (new_lbl, snd_blk)]++    fix_block _ = pure cp++fixBottom rcd = pure rcd++-- | 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+    fixed_cmm <- fixBottom $+                    {-# SCC "llvm_fix_regs" #-}+                    fixStgRegisters dflags cmm++    dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm])++    -- generate llvm code from cmm+    llvmBC <- withClearVars $ genLlvmProc fixed_cmm++    -- pretty print+    (docs, ivars) <- fmap unzip $ mapM pprLlvmCmmDecl llvmBC++    -- Output, note down used variables+    renderLlvm (vcat docs)+    mapM_ markUsedVar $ concat ivars++cmmLlvmGen _ = return ()++-- -----------------------------------------------------------------------------+-- | Generate meta data nodes+--++cmmMetaLlvmPrelude :: LlvmM ()+cmmMetaLlvmPrelude = do+  metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do+    -- Generate / lookup meta data IDs+    tbaaId <- getMetaUniqueId+    setUniqMeta uniq tbaaId+    parentId <- maybe (return Nothing) getUniqMeta parent+    -- Build definition+    return $ MetaUnnamed tbaaId $ MetaStruct $+          case parentId of+              Just p  -> [ MetaStr name, MetaNode p ]+              -- As of LLVM 4.0, a node without parents should be rendered as+              -- just a name on its own. Previously `null` was accepted as the+              -- name.+              Nothing -> [ MetaStr name ]+  renderLlvm $ ppLlvmMetas metas++-- -----------------------------------------------------------------------------+-- | Marks variables as used where necessary+--++cmmUsedLlvmGens :: LlvmM ()+cmmUsedLlvmGens = do++  -- LLVM would discard variables that are internal and not obviously+  -- used if we didn't provide these hints. This will generate a+  -- definition of the form+  --+  --   @llvm.used = appending global [42 x i8*] [i8* bitcast <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 view
@@ -0,0 +1,571 @@+{-# LANGUAGE CPP #-}++-- ----------------------------------------------------------------------------+-- | 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, llvmVersionStr,++        LlvmM,+        runLlvm, liftStream, withClearVars, varLookup, varInsert,+        markStackReg, checkStackReg,+        funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,+        dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,+        ghcInternalFunctions,++        getMetaUniqueId,+        setUniqMeta, getUniqMeta,++        cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,+        llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,+        llvmPtrBits, tysToParams, llvmFunSection,++        strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,+        getGlobalPtr, generateExternDecls,++        aliasify, llvmDefLabel+    ) where++#include "HsVersions.h"+#include "ghcautoconf.h"++import GhcPrelude++import Llvm+import LlvmCodeGen.Regs++import CLabel+import CodeGen.Platform ( activeStgRegs )+import DynFlags+import FastString+import Cmm              hiding ( succ )+import Outputable as Outp+import 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)++-- ----------------------------------------------------------------------------+-- * 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 (activeStgRegs platform))+    where platform = targetPlatform dflags+          isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live+          isPassed r = not (isSSE r) || isLive r+          isSSE (FloatReg _)  = True+          isSSE (DoubleReg _) = True+          isSSE (XmmReg _)    = True+          isSSE (YmmReg _)    = True+          isSSE (ZmmReg _)    = True+          isSSE _             = False++-- | 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+--++-- | LLVM Version Number+type LlvmVersion = (Int, Int)++-- | The LLVM Version that is currently supported.+supportedLlvmVersion :: LlvmVersion+supportedLlvmVersion = sUPPORTED_LLVM_VERSION++llvmVersionStr :: LlvmVersion -> String+llvmVersionStr (major, minor) = show major ++ "." ++ show minor++-- ----------------------------------------------------------------------------+-- * Environment Handling+--++data LlvmEnv = LlvmEnv+  { envVersion :: LlvmVersion      -- ^ LLVM version+  , envDynFlags :: DynFlags        -- ^ Dynamic flags+  , envOutput :: BufHandle         -- ^ Output buffer+  , envUniq :: UniqSupply          -- ^ Supply of 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) }++instance Functor LlvmM where+    fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env+                                  return (f x, env')++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+        us <- getEnv envUniq+        let (us1, us2) = splitUniqSupply us+        modifyEnv (\s -> s { envUniq = us2 })+        return us1++    getUniqueM = do+        us <- getEnv envUniq+        let (u,us') = takeUniqFromSupply us+        modifyEnv (\s -> s { envUniq = us' })+        return u++-- | 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 -> UniqSupply -> LlvmM () -> IO ()+runLlvm dflags ver out us m = do+    _ <- runLlvmM m env+    return ()+  where env = LlvmEnv { envFunMap = emptyUFM+                      , envVarMap = emptyUFM+                      , envStackRegs = []+                      , envUsedVars = []+                      , envAliases = emptyUniqSet+                      , envVersion = ver+                      , envDynFlags = dflags+                      , envOutput = out+                      , envUniq = us+                      , envFreshMeta = MetaId 0+                      , envUniqMeta = emptyUFM+                      }++-- | Get environment (internal)+getEnv :: (LlvmEnv -> a) -> LlvmM a+getEnv f = LlvmM (\env -> return (f env, env))++-- | Modify environment (internal)+modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM ()+modifyEnv f = LlvmM (\env -> return ((), f env))++-- | Lift a stream into the LlvmM monad+liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x+liftStream s = Stream.Stream $ do+  r <- liftIO $ Stream.runStream s+  case r of+    Left b        -> return (Left b)+    Right (a, r2) -> return (Right (a, liftStream r2))++-- | Clear variables from the environment for a subcomputation+withClearVars :: LlvmM a -> LlvmM a+withClearVars m = LlvmM $ \env -> do+    (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] }+    return (x, env' { envVarMap = emptyUFM, envStackRegs = [] })++-- | Insert variables or functions into the environment.+varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM ()+varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) s t }+funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) s t }++-- | Lookup variables or functions in the environment.+varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)+varLookup s = getEnv (flip lookupUFM s . envVarMap)+funLookup s = getEnv (flip lookupUFM s . envFunMap)++-- | Set a register as allocated on the stack+markStackReg :: GlobalReg -> LlvmM ()+markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env }++-- | Check whether a register is allocated on the stack+checkStackReg :: GlobalReg -> LlvmM Bool+checkStackReg r = getEnv ((elem r) . envStackRegs)++-- | Allocate a new global unnamed metadata identifier+getMetaUniqueId :: LlvmM MetaId+getMetaUniqueId = LlvmM $ \env ->+    return (envFreshMeta env, env { envFreshMeta = succ $ envFreshMeta env })++-- | Get the LLVM version we are generating code for+getLlvmVer :: LlvmM LlvmVersion+getLlvmVer = getEnv envVersion++-- | Get the platform we are generating code for+getDynFlag :: (DynFlags -> a) -> LlvmM a+getDynFlag f = getEnv (f . envDynFlags)++-- | Get the platform we are generating code for+getLlvmPlatform :: LlvmM Platform+getLlvmPlatform = getDynFlag targetPlatform++-- | Dumps the document if the corresponding flag has been set by the user+dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM ()+dumpIfSetLlvm flag hdr doc = do+  dflags <- getDynFlags+  liftIO $ dumpIfSet_dyn dflags flag hdr doc++-- | Prints the given contents to the output handle+renderLlvm :: Outp.SDoc -> LlvmM ()+renderLlvm sdoc = do++    -- Write to output+    dflags <- getDynFlags+    out <- getEnv envOutput+    liftIO $ Outp.bufLeftRenderSDoc dflags out+               (Outp.mkCodeStyle Outp.CStyle) sdoc++    -- Dump, if requested+    dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc+    return ()++-- | Marks a variable as "used"+markUsedVar :: LlvmVar -> LlvmM ()+markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env }++-- | Return all variables marked as "used" so far+getUsedVars :: LlvmM [LlvmVar]+getUsedVars = getEnv envUsedVars++-- | Saves that at some point we didn't know the type of the label and+-- generated a reference to a type variable instead+saveAlias :: LMString -> LlvmM ()+saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl }++-- | Sets metadata node for a given unique+setUniqMeta :: Unique -> MetaId -> LlvmM ()+setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m }++-- | Gets metadata node for given unique+getUniqMeta :: Unique -> LlvmM (Maybe MetaId)+getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta)++-- ----------------------------------------------------------------------------+-- * Internal functions+--++-- | Here we pre-initialise some functions that are used internally by GHC+-- so as to make sure they have the most general type in the case that+-- user code also uses these functions but with a different type than GHC+-- internally. (Main offender is treating return type as 'void' instead of+-- 'void *'). Fixes trac #5486.+ghcInternalFunctions :: LlvmM ()+ghcInternalFunctions = do+    dflags <- getDynFlags+    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 trival. As we already have a definition for+-- and therefore know the type of the referenced symbol, we can do+-- away with casting the alias to the desired type in @getSymbolPtr@+-- and instead just emit a reference to the definition symbol directly.+-- This is the @Just@ case in @getSymbolPtr@.
+ compiler/llvmGen/LlvmCodeGen/CodeGen.hs view
@@ -0,0 +1,2011 @@+{-# LANGUAGE CPP, GADTs #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+-- ----------------------------------------------------------------------------+-- | Handle conversion of CmmProc to LLVM code.+--+module LlvmCodeGen.CodeGen ( genLlvmProc ) where++#include "HsVersions.h"++import GhcPrelude++import Llvm+import LlvmCodeGen.Base+import LlvmCodeGen.Regs++import BlockId+import CodeGen.Platform ( activeStgRegs, callerSaves )+import CLabel+import Cmm+import PprCmm+import CmmUtils+import CmmSwitch+import Hoopl.Block+import Hoopl.Graph+import Hoopl.Collections++import DynFlags+import FastString+import ForeignCall+import Outputable hiding (panic, pprPanic)+import qualified Outputable+import 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 and will get the prologue.+basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock]+                      -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])+basicBlocksCodeGen _    []                     = panic "no entry block!"+basicBlocksCodeGen live (entryBlock:cmmBlocks)+  = do (prologue, prologueTops) <- funPrologue live (entryBlock:cmmBlocks)++       -- Generate code+       (BasicBlock bid entry, entryTops) <- basicBlockCodeGen entryBlock+       (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks++       -- Compose+       let entryBlock = BasicBlock bid (fromOL prologue ++ entry)+       return (entryBlock : blocks, prologueTops ++ entryTops ++ 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, [])++-- | Foreign Calls+genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual]+              -> LlvmM StmtData++-- Write barrier needs to be handled specially as it is implemented as an LLVM+-- intrinsic function.+genCall (PrimTarget MO_WriteBarrier) _ _ = do+    platform <- getLlvmPlatform+    if platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC]+       then return (nilOL, [])+       else barrier++genCall (PrimTarget MO_Touch) _ _+ = return (nilOL, [])++genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do+    dstV <- getCmmRegW (CmmLocal dst)+    let ty = cmmToLlvmType $ localRegType dst+        width = widthToLlvmFloat w+    castV <- lift $ mkLocalVar ty+    ve <- exprToVarW e+    statement $ Assignment castV $ Cast LM_Uitofp ve width+    statement $ Store castV dstV++genCall (PrimTarget (MO_UF_Conv _)) [_] args =+    panic $ "genCall: Too many arguments to MO_UF_Conv. " +++    "Can only handle 1, given" ++ show (length args) ++ "."++-- Handle prefetching data+genCall t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args+  | 0 <= localityInt && localityInt <= 3 = runStmtsDecls $ do+    let argTy = [i8Ptr, i32, i32, i32]+        funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible+                             CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing++    let (_, arg_hints) = foreignTargetHints t+    let args_hints' = zip args arg_hints+    argVars <- arg_varsW args_hints' ([], nilOL, [])+    fptr    <- liftExprData $ getFunPtr funTy t+    argVars' <- castVarsW Signed $ zip argVars argTy++    doTrashStmts+    let argSuffix = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1]+    statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) []+  | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt)++-- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg+-- and return types+genCall t@(PrimTarget (MO_PopCnt w)) dsts args =+    genCallSimpleCast w t dsts args++genCall t@(PrimTarget (MO_Pdep w)) dsts args =+    genCallSimpleCast2 w t dsts args+genCall t@(PrimTarget (MO_Pext w)) dsts args =+    genCallSimpleCast2 w t dsts args+genCall t@(PrimTarget (MO_Clz w)) dsts args =+    genCallSimpleCast w t dsts args+genCall t@(PrimTarget (MO_Ctz w)) dsts args =+    genCallSimpleCast w t dsts args+genCall t@(PrimTarget (MO_BSwap w)) dsts args =+    genCallSimpleCast w t dsts args+genCall t@(PrimTarget (MO_BRev w)) dsts args =+    genCallSimpleCast w t dsts args++genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do+    addrVar <- exprToVarW addr+    nVar <- exprToVarW n+    let targetTy = widthToLlvmInt width+        ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy)+    ptrVar <- doExprW (pLift targetTy) ptrExpr+    dstVar <- getCmmRegW (CmmLocal dst)+    let op = case amop of+               AMO_Add  -> LAO_Add+               AMO_Sub  -> LAO_Sub+               AMO_And  -> LAO_And+               AMO_Nand -> LAO_Nand+               AMO_Or   -> LAO_Or+               AMO_Xor  -> LAO_Xor+    retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst+    statement $ Store retVar dstVar++genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = runStmtsDecls $ do+    dstV <- getCmmRegW (CmmLocal dst)+    v1 <- genLoadW True addr (localRegType dst)+    statement $ Store v1 dstV++genCall (PrimTarget (MO_Cmpxchg _width))+        [dst] [addr, old, new] = runStmtsDecls $ do+    addrVar <- exprToVarW addr+    oldVar <- exprToVarW old+    newVar <- exprToVarW new+    let targetTy = getVarType oldVar+        ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy)+    ptrVar <- doExprW (pLift targetTy) ptrExpr+    dstVar <- getCmmRegW (CmmLocal dst)+    retVar <- doExprW (LMStructU [targetTy,i1])+              $ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst+    retVar' <- doExprW targetTy $ ExtractV retVar 0+    statement $ Store retVar' dstVar++genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do+    addrVar <- exprToVarW addr+    valVar <- exprToVarW val+    let ptrTy = pLift $ getVarType valVar+        ptrExpr = Cast LM_Inttoptr addrVar ptrTy+    ptrVar <- doExprW ptrTy ptrExpr+    statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst++-- Handle memcpy function specifically since llvm's intrinsic version takes+-- some extra parameters.+genCall t@(PrimTarget op) [] args+ | Just align <- machOpMemcpyishAlign op = runStmtsDecls $ do+    dflags <- getDynFlags+    let isVolTy = [i1]+        isVolVal = [mkIntLit i1 0]+        argTy | MO_Memset _ <- op = [i8Ptr, i8,    llvmWord dflags, i32] ++ isVolTy+              | otherwise         = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy+        funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible+                             CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing++    let (_, arg_hints) = foreignTargetHints t+    let args_hints = zip args arg_hints+    argVars       <- arg_varsW args_hints ([], nilOL, [])+    fptr          <- getFunPtrW funTy t+    argVars' <- castVarsW Signed $ zip argVars argTy++    doTrashStmts+    let alignVal = mkIntLit i32 align+        arguments = argVars' ++ (alignVal:isVolVal)+    statement $ Expr $ Call StdCall fptr arguments []++-- We handle MO_U_Mul2 by simply using a 'mul' instruction, but with operands+-- twice the width (we first zero-extend them), e.g., on 64-bit arch we will+-- generate 'mul' on 128-bit operands. Then we only need some plumbing to+-- extract the two 64-bit values out of 128-bit result.+genCall (PrimTarget (MO_U_Mul2 w)) [dstH, dstL] [lhs, rhs] = runStmtsDecls $ do+    let width = widthToLlvmInt w+        bitWidth = widthInBits w+        width2x = LMInt (bitWidth * 2)+    -- First zero-extend the operands ('mul' instruction requires the operands+    -- and the result to be of the same type). Note that we don't use 'castVars'+    -- because it tries to do LM_Sext.+    lhsVar <- exprToVarW lhs+    rhsVar <- exprToVarW rhs+    lhsExt <- doExprW width2x $ Cast LM_Zext lhsVar width2x+    rhsExt <- doExprW width2x $ Cast LM_Zext rhsVar width2x+    -- Do the actual multiplication (note that the result is also 2x width).+    retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt+    -- Extract the lower bits of the result into retL.+    retL <- doExprW width $ Cast LM_Trunc retV width+    -- Now we right-shift the higher bits by width.+    let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width+    retShifted <- doExprW width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit+    -- And extract them into retH.+    retH <- doExprW width $ Cast LM_Trunc retShifted width+    dstRegL <- getCmmRegW (CmmLocal dstL)+    dstRegH <- getCmmRegW (CmmLocal dstH)+    statement $ Store retL dstRegL+    statement $ Store retH dstRegH++-- MO_U_QuotRem2 is another case we handle by widening the registers to double+-- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The+-- main difference here is that we need to combine two words into one register+-- and then use both 'udiv' and 'urem' instructions to compute the result.+genCall (PrimTarget (MO_U_QuotRem2 w))+        [dstQ, dstR] [lhsH, lhsL, rhs] = runStmtsDecls $ do+    let width = widthToLlvmInt w+        bitWidth = widthInBits w+        width2x = LMInt (bitWidth * 2)+    -- First zero-extend all parameters to double width.+    let zeroExtend expr = do+            var <- exprToVarW expr+            doExprW width2x $ Cast LM_Zext var width2x+    lhsExtH <- zeroExtend lhsH+    lhsExtL <- zeroExtend lhsL+    rhsExt <- zeroExtend rhs+    -- Now we combine the first two parameters (that represent the high and low+    -- bits of the value). So first left-shift the high bits to their position+    -- and then bit-or them with the low bits.+    let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width+    lhsExtHShifted <- doExprW width2x $ LlvmOp LM_MO_Shl lhsExtH widthLlvmLit+    lhsExt <- doExprW width2x $ LlvmOp LM_MO_Or lhsExtHShifted lhsExtL+    -- Finally, we can call 'udiv' and 'urem' to compute the results.+    retExtDiv <- doExprW width2x $ LlvmOp LM_MO_UDiv lhsExt rhsExt+    retExtRem <- doExprW width2x $ LlvmOp LM_MO_URem lhsExt rhsExt+    -- And since everything is in 2x width, we need to truncate the results and+    -- then return them.+    let narrow var = doExprW width $ Cast LM_Trunc var width+    retDiv <- narrow retExtDiv+    retRem <- narrow retExtRem+    dstRegQ <- lift $ getCmmReg (CmmLocal dstQ)+    dstRegR <- lift $ getCmmReg (CmmLocal dstR)+    statement $ Store retDiv dstRegQ+    statement $ Store retRem dstRegR++-- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from+-- which we need to extract the actual values.+genCall t@(PrimTarget (MO_AddIntC w)) [dstV, dstO] [lhs, rhs] =+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]+genCall t@(PrimTarget (MO_SubIntC w)) [dstV, dstO] [lhs, rhs] =+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]++-- Similar to MO_{Add,Sub}IntC, but MO_Add2 expects the first element of the+-- return tuple to be the overflow bit and the second element to contain the+-- actual result of the addition. So we still use genCallWithOverflow but swap+-- the return registers.+genCall t@(PrimTarget (MO_Add2 w)) [dstO, dstV] [lhs, rhs] =+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]++genCall t@(PrimTarget (MO_AddWordC w)) [dstV, dstO] [lhs, rhs] =+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]++genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] =+    genCallWithOverflow t w [dstV, dstO] [lhs, rhs]++-- Handle all other foreign calls and prim ops.+genCall target res args = runStmtsDecls $ do+    dflags <- getDynFlags++    -- 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 ()++    doTrashStmts++    -- 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_Log    -> fsLit "logf"+    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_Log    -> fsLit "log"+    MO_F64_Sqrt   -> fsLit "llvm.sqrt.f64"+    MO_F64_Fabs   -> fsLit "llvm.fabs.f64"+    MO_F64_Pwr    -> fsLit "llvm.pow.f64"++    MO_F64_Sin    -> fsLit "llvm.sin.f64"+    MO_F64_Cos    -> fsLit "llvm.cos.f64"+    MO_F64_Tan    -> fsLit "tan"++    MO_F64_Asin   -> fsLit "asin"+    MO_F64_Acos   -> fsLit "acos"+    MO_F64_Atan   -> fsLit "atan"++    MO_F64_Sinh   -> fsLit "sinh"+    MO_F64_Cosh   -> fsLit "cosh"+    MO_F64_Tanh   -> fsLit "tanh"++    MO_F64_Asinh  -> fsLit "asinh"+    MO_F64_Acosh  -> fsLit "acosh"+    MO_F64_Atanh  -> fsLit "atanh"++    MO_Memcpy _   -> fsLit $ "llvm.memcpy."  ++ intrinTy1+    MO_Memmove _  -> fsLit $ "llvm.memmove." ++ intrinTy1+    MO_Memset _   -> fsLit $ "llvm.memset."  ++ intrinTy2+    MO_Memcmp _   -> fsLit $ "memcmp"++    (MO_PopCnt w) -> fsLit $ "llvm.ctpop."      ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    (MO_BSwap w)  -> fsLit $ "llvm.bswap."      ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    (MO_BRev w)   -> fsLit $ "llvm.bitreverse." ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    (MO_Clz w)    -> fsLit $ "llvm.ctlz."       ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    (MO_Ctz w)    -> fsLit $ "llvm.cttz."       ++ showSDoc dflags (ppr $ widthToLlvmInt w)++    (MO_Pdep w)   ->  let w' = showSDoc dflags (ppr $ widthInBits w)+                      in  if isBmi2Enabled dflags+                            then fsLit $ "llvm.x86.bmi.pdep."   ++ w'+                            else fsLit $ "hs_pdep"              ++ w'+    (MO_Pext w)   ->  let w' = showSDoc dflags (ppr $ widthInBits w)+                      in  if isBmi2Enabled dflags+                            then fsLit $ "llvm.x86.bmi.pext."   ++ w'+                            else fsLit $ "hs_pext"              ++ w'++    (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch"++    MO_AddIntC w    -> fsLit $ "llvm.sadd.with.overflow."+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    MO_SubIntC w    -> fsLit $ "llvm.ssub.with.overflow."+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    MO_Add2 w       -> fsLit $ "llvm.uadd.with.overflow."+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    MO_AddWordC w   -> fsLit $ "llvm.uadd.with.overflow."+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)+    MO_SubWordC w   -> fsLit $ "llvm.usub.with.overflow."+                             ++ showSDoc dflags (ppr $ widthToLlvmInt w)++    MO_S_QuotRem {}  -> unsupported+    MO_U_QuotRem {}  -> unsupported+    MO_U_QuotRem2 {} -> unsupported+    -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the+    -- appropriate case of genCall.+    MO_U_Mul2 {}     -> unsupported+    MO_WriteBarrier  -> unsupported+    MO_Touch         -> unsupported+    MO_UF_Conv _     -> unsupported++    MO_AtomicRead _  -> unsupported+    MO_AtomicRMW _ _ -> unsupported+    MO_AtomicWrite _ -> unsupported+    MO_Cmpxchg _     -> unsupported++-- | Tail function calls+genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData++-- Call to known function+genJump (CmmLit (CmmLabel lbl)) live = do+    (vf, stmts, top) <- getHsFunc live lbl+    (stgRegs, stgStmts) <- funEpilogue live+    let s1  = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs+    let s2  = Return Nothing+    return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top)+++-- Call to unknown function / address+genJump expr live = do+    fty <- llvmFunTy live+    (vf, stmts, top) <- exprToVar expr+    dflags <- getDynFlags++    let cast = case getVarType vf of+         ty | isPointer ty -> LM_Bitcast+         ty | isInt ty     -> LM_Inttoptr++         ty -> panic $ "genJump: Expr is of bad type for function call! ("+                     ++ showSDoc dflags (ppr ty) ++ ")"++    (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty)+    (stgRegs, stgStmts) <- funEpilogue live+    let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs+    let s3 = Return Nothing+    return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3,+            top)+++-- | CmmAssign operation+--+-- We use stack allocated variables for CmmReg. The optimiser will replace+-- these with registers when possible.+genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData+genAssign reg val = do+    vreg <- getCmmReg reg+    (vval, stmts2, top2) <- exprToVar val+    let stmts = stmts2++    let ty = (pLower . getVarType) vreg+    dflags <- getDynFlags+    case ty of+      -- Some registers are pointer types, so need to cast value to pointer+      LMPointer _ | getVarType vval == llvmWord dflags -> do+          (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty+          let s2 = Store v vreg+          return (stmts `snocOL` s1 `snocOL` s2, top2)++      LMVector _ _ -> do+          (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty+          let s2 = Store v vreg+          return (stmts `snocOL` s1 `snocOL` s2, top2)++      _ -> do+          let s1 = Store vval vreg+          return (stmts `snocOL` s1, top2)+++-- | CmmStore operation+genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData++-- First we try to detect a few common cases and produce better code for+-- these then the default case. We are mostly trying to detect Cmm code+-- like I32[Sp + n] and use 'getelementptr' operations instead of the+-- generic case that uses casts and pointer arithmetic+genStore addr@(CmmReg (CmmGlobal r)) val+    = genStore_fast addr r 0 val++genStore addr@(CmmRegOff (CmmGlobal r) n) val+    = genStore_fast addr r n val++genStore addr@(CmmMachOp (MO_Add _) [+                            (CmmReg (CmmGlobal r)),+                            (CmmLit (CmmInt n _))])+                val+    = genStore_fast addr r (fromInteger n) val++genStore addr@(CmmMachOp (MO_Sub _) [+                            (CmmReg (CmmGlobal r)),+                            (CmmLit (CmmInt n _))])+                val+    = genStore_fast addr r (negate $ fromInteger n) val++-- generic case+genStore addr val+    = getTBAAMeta topN >>= genStore_slow addr val++-- | CmmStore operation+-- This is a special case for storing to a global register pointer+-- offset such as I32[Sp+8].+genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr+              -> LlvmM StmtData+genStore_fast addr r n val+  = do dflags <- getDynFlags+       (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)+       meta          <- getTBAARegMeta r+       let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)+       case isPointer grt && rem == 0 of+            True -> do+                (vval,  stmts, top) <- exprToVar val+                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]+                -- We might need a different pointer type, so check+                case pLower grt == getVarType vval of+                     -- were fine+                     True  -> do+                         let s3 = MetaStmt meta $ Store vval ptr+                         return (stmts `appOL` s1 `snocOL` s2+                                 `snocOL` s3, top)++                     -- cast to pointer type needed+                     False -> do+                         let ty = (pLift . getVarType) vval+                         (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty+                         let s4 = MetaStmt meta $ Store vval ptr'+                         return (stmts `appOL` s1 `snocOL` s2+                                 `snocOL` s3 `snocOL` s4, top)++            -- If its a bit type then we use the slow method since+            -- we can't avoid casting anyway.+            False -> genStore_slow addr val meta+++-- | CmmStore operation+-- Generic case. Uses casts and pointer arithmetic if needed.+genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData+genStore_slow addr val meta = do+    (vaddr, stmts1, top1) <- exprToVar addr+    (vval,  stmts2, top2) <- exprToVar val++    let stmts = stmts1 `appOL` stmts2+    dflags <- getDynFlags+    case getVarType vaddr of+        -- sometimes we need to cast an int to a pointer before storing+        LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do+            (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty+            let s2 = MetaStmt meta $ Store v vaddr+            return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)++        LMPointer _ -> do+            let s1 = MetaStmt meta $ Store vval vaddr+            return (stmts `snocOL` s1, top1 ++ top2)++        i@(LMInt _) | i == llvmWord dflags -> do+            let vty = pLift $ getVarType vval+            (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty+            let s2 = MetaStmt meta $ Store vval vptr+            return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)++        other ->+            pprPanic "genStore: ptr not right type!"+                    (PprCmm.pprExpr addr <+> text (+                        "Size of Ptr: " ++ show (llvmPtrBits dflags) +++                        ", Size of var: " ++ show (llvmWidthInBits dflags other) +++                        ", Var: " ++ showSDoc dflags (ppr vaddr)))+++-- | Unconditional branch+genBranch :: BlockId -> LlvmM StmtData+genBranch id =+    let label = blockIdToLlvm id+    in return (unitOL $ Branch label, [])+++-- | Conditional branch+genCondBranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> LlvmM StmtData+genCondBranch cond idT idF likely = do+    let labelT = blockIdToLlvm idT+    let labelF = blockIdToLlvm idF+    -- See Note [Literals and branch conditions].+    (vc, stmts1, top1) <- exprToVarOpt i1Option cond+    if getVarType vc == i1+        then do+            (vc', (stmts2, top2)) <- case likely of+              Just b -> genExpectLit (if b then 1 else 0) i1  vc+              _      -> pure (vc, (nilOL, []))+            let s1 = BranchIf vc' labelT labelF+            return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2)+        else do+            dflags <- getDynFlags+            panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")"+++-- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var.+genExpectLit :: Integer -> LlvmType -> LlvmVar -> LlvmM (LlvmVar, StmtData)+genExpectLit expLit expTy var = do+  dflags <- getDynFlags++  let+    lit = LMLitVar $ LMIntLit expLit expTy++    llvmExpectName+      | isInt expTy = fsLit $ "llvm.expect." ++ showSDoc dflags (ppr expTy)+      | otherwise   = panic $ "genExpectedLit: Type not an int!"++  (llvmExpect, stmts, top) <-+    getInstrinct llvmExpectName expTy [expTy, expTy]+  (var', call) <- doExpr expTy $ Call StdCall llvmExpect [var, lit] []+  return (var', (stmts `snocOL` call, top))++{- Note [Literals and branch conditions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++It is important that whenever we generate branch conditions for+literals like '1', they are properly narrowed to an LLVM expression of+type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert+a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt+must be certain to return a properly narrowed type. genLit is+responsible for this, in the case of literal integers.++Often, we won't see direct statements like:++    if(1) {+      ...+    } else {+      ...+    }++at this point in the pipeline, because the Glorious Code Generator+will do trivial branch elimination in the sinking pass (among others,)+which will eliminate the expression entirely.++However, it's certainly possible and reasonable for this to occur in+hand-written C-- code. Consider something like:++    #if !defined(SOME_CONDITIONAL)+    #define CHECK_THING(x) 1+    #else+    #define CHECK_THING(x) some_operation((x))+    #endif++    f() {++      if (CHECK_THING(xyz)) {+        ...+      } else {+        ...+      }++    }++In such an instance, CHECK_THING might result in an *expression* in+one case, and a *literal* in the other, depending on what in+particular was #define'd. So we must be sure to properly narrow the+literal in this case to i1 as it won't be eliminated beforehand.++For a real example of this, see ./rts/StgStdThunks.cmm++-}++++-- | Switch branch+genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData+genSwitch cond ids = do+    (vc, stmts, top) <- exprToVar cond+    let ty = getVarType vc++    let labels = [ (mkIntLit ty ix, blockIdToLlvm b)+                 | (ix, b) <- switchTargetsCases ids ]+    -- out of range is undefined, so let's just branch to first label+    let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l+               | otherwise                          = snd (head labels)++    let s1 = Switch vc defLbl labels+    return $ (stmts `snocOL` s1, top)+++-- -----------------------------------------------------------------------------+-- * CmmExpr code generation+--++-- | An expression conversion return data:+--   * LlvmVar: The var holding the result of the expression+--   * LlvmStatements: Any statements needed to evaluate the expression+--   * LlvmCmmDecl: Any global data needed for this expression+type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl])++-- | Values which can be passed to 'exprToVar' to configure its+-- behaviour in certain circumstances.+--+-- Currently just used for determining if a comparison should return+-- a boolean (i1) or a word. See Note [Literals and branch conditions].+newtype EOption = EOption { i1Expected :: Bool }+-- XXX: EOption is an ugly and inefficient solution to this problem.++-- | i1 type expected (condition scrutinee).+i1Option :: EOption+i1Option = EOption True++-- | Word type expected (usual).+wordOption :: EOption+wordOption = EOption False++-- | Convert a CmmExpr to a list of LlvmStatements with the result of the+-- expression being stored in the returned LlvmVar.+exprToVar :: CmmExpr -> LlvmM ExprData+exprToVar = exprToVarOpt wordOption++exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData+exprToVarOpt opt e = case e of++    CmmLit lit+        -> genLit opt lit++    CmmLoad e' ty+        -> genLoad False e' ty++    -- Cmmreg in expression is the value, so must load. If you want actual+    -- reg pointer, call getCmmReg directly.+    CmmReg r -> do+        (v1, ty, s1) <- getCmmRegVal r+        case isPointer ty of+             True  -> do+                 -- Cmm wants the value, so pointer types must be cast to ints+                 dflags <- getDynFlags+                 (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags)+                 return (v2, s1 `snocOL` s2, [])++             False -> return (v1, s1, [])++    CmmMachOp op exprs+        -> genMachOp opt op exprs++    CmmRegOff r i+        -> do dflags <- getDynFlags+              exprToVar $ expandCmmReg dflags (r, i)++    CmmStackSlot _ _+        -> panic "exprToVar: CmmStackSlot not supported!"+++-- | Handle CmmMachOp expressions+genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData++-- Unary Machop+genMachOp _ op [x] = case op of++    MO_Not w ->+        let all1 = mkIntLit (widthToLlvmInt w) (-1)+        in negate (widthToLlvmInt w) all1 LM_MO_Xor++    MO_S_Neg w ->+        let all0 = mkIntLit (widthToLlvmInt w) 0+        in negate (widthToLlvmInt w) all0 LM_MO_Sub++    MO_F_Neg w ->+        let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w)+        in negate (widthToLlvmFloat w) all0 LM_MO_FSub++    MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp+    MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi++    MO_SS_Conv from to+        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext++    MO_UU_Conv from to+        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext++    MO_XX_Conv from to+        -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext++    MO_FF_Conv from to+        -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext++    MO_VS_Neg len w ->+        let ty    = widthToLlvmInt w+            vecty = LMVector len ty+            all0  = LMIntLit (-0) ty+            all0s = LMLitVar $ LMVectorLit (replicate len all0)+        in negateVec vecty all0s LM_MO_Sub++    MO_VF_Neg len w ->+        let ty    = widthToLlvmFloat w+            vecty = LMVector len ty+            all0  = LMFloatLit (-0) ty+            all0s = LMLitVar $ LMVectorLit (replicate len all0)+        in negateVec vecty all0s LM_MO_FSub++    MO_AlignmentCheck _ _ -> panic "-falignment-sanitisation is not supported by -fllvm"++    -- Handle unsupported cases explicitly so we get a warning+    -- of missing case when new MachOps added+    MO_Add _          -> panicOp+    MO_Mul _          -> panicOp+    MO_Sub _          -> panicOp+    MO_S_MulMayOflo _ -> panicOp+    MO_S_Quot _       -> panicOp+    MO_S_Rem _        -> panicOp+    MO_U_MulMayOflo _ -> panicOp+    MO_U_Quot _       -> panicOp+    MO_U_Rem _        -> panicOp++    MO_Eq  _          -> panicOp+    MO_Ne  _          -> panicOp+    MO_S_Ge _         -> panicOp+    MO_S_Gt _         -> panicOp+    MO_S_Le _         -> panicOp+    MO_S_Lt _         -> panicOp+    MO_U_Ge _         -> panicOp+    MO_U_Gt _         -> panicOp+    MO_U_Le _         -> panicOp+    MO_U_Lt _         -> panicOp++    MO_F_Add        _ -> panicOp+    MO_F_Sub        _ -> panicOp+    MO_F_Mul        _ -> panicOp+    MO_F_Quot       _ -> panicOp+    MO_F_Eq         _ -> panicOp+    MO_F_Ne         _ -> panicOp+    MO_F_Ge         _ -> panicOp+    MO_F_Gt         _ -> panicOp+    MO_F_Le         _ -> panicOp+    MO_F_Lt         _ -> panicOp++    MO_And          _ -> panicOp+    MO_Or           _ -> panicOp+    MO_Xor          _ -> panicOp+    MO_Shl          _ -> panicOp+    MO_U_Shr        _ -> panicOp+    MO_S_Shr        _ -> panicOp++    MO_V_Insert   _ _ -> panicOp+    MO_V_Extract  _ _ -> panicOp++    MO_V_Add      _ _ -> panicOp+    MO_V_Sub      _ _ -> panicOp+    MO_V_Mul      _ _ -> panicOp++    MO_VS_Quot    _ _ -> panicOp+    MO_VS_Rem     _ _ -> panicOp++    MO_VU_Quot    _ _ -> panicOp+    MO_VU_Rem     _ _ -> panicOp++    MO_VF_Insert  _ _ -> panicOp+    MO_VF_Extract _ _ -> panicOp++    MO_VF_Add     _ _ -> panicOp+    MO_VF_Sub     _ _ -> panicOp+    MO_VF_Mul     _ _ -> panicOp+    MO_VF_Quot    _ _ -> panicOp++    where+        negate ty v2 negOp = do+            (vx, stmts, top) <- exprToVar x+            (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx+            return (v1, stmts `snocOL` s1, top)++        negateVec ty v2 negOp = do+            (vx, stmts1, top) <- exprToVar x+            (vxs', stmts2) <- castVars Signed [(vx, ty)]+            let vx' = singletonPanic "genMachOp: negateVec" vxs'+            (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx'+            return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top)++        fiConv ty convOp = do+            (vx, stmts, top) <- exprToVar x+            (v1, s1) <- doExpr ty $ Cast convOp vx ty+            return (v1, stmts `snocOL` s1, top)++        sameConv from ty reduce expand = do+            x'@(vx, stmts, top) <- exprToVar x+            let sameConv' op = do+                    (v1, s1) <- doExpr ty $ Cast op vx ty+                    return (v1, stmts `snocOL` s1, top)+            dflags <- getDynFlags+            let toWidth = llvmWidthInBits dflags ty+            -- LLVM doesn't like trying to convert to same width, so+            -- need to check for that as we do get Cmm code doing it.+            case widthInBits from  of+                 w | w < toWidth -> sameConv' expand+                 w | w > toWidth -> sameConv' reduce+                 _w              -> return x'++        panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encountered"+                       ++ "with one argument! (" ++ show op ++ ")"++-- Handle GlobalRegs pointers+genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]+    = genMachOp_fast opt o r (fromInteger n) e++genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]+    = genMachOp_fast opt o r (negate . fromInteger $ n) e++-- Generic case+genMachOp opt op e = genMachOp_slow opt op e+++-- | Handle CmmMachOp expressions+-- This is a specialised method that handles Global register manipulations like+-- 'Sp - 16', using the getelementptr instruction.+genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr]+               -> LlvmM ExprData+genMachOp_fast opt op r n e+  = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)+       dflags <- getDynFlags+       let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)+       case isPointer grt && rem == 0 of+            True -> do+                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]+                (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags)+                return (var, s1 `snocOL` s2 `snocOL` s3, [])++            False -> genMachOp_slow opt op e+++-- | Handle CmmMachOp expressions+-- This handles all the cases not handle by the specialised genMachOp_fast.+genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData++-- Element extraction+genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do+    vval <- exprToVarW val+    vidx <- exprToVarW idx+    vval' <- singletonPanic "genMachOp_slow" <$>+             castVarsW Signed [(vval, LMVector l ty)]+    doExprW ty $ Extract vval' vidx+  where+    ty = widthToLlvmInt w++genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do+    vval <- exprToVarW val+    vidx <- exprToVarW idx+    vval' <- singletonPanic "genMachOp_slow" <$>+             castVarsW Signed [(vval, LMVector l ty)]+    doExprW ty $ Extract vval' vidx+  where+    ty = widthToLlvmFloat w++-- Element insertion+genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do+    vval <- exprToVarW val+    velt <- exprToVarW elt+    vidx <- exprToVarW idx+    vval' <- singletonPanic "genMachOp_slow" <$>+             castVarsW Signed [(vval, ty)]+    doExprW ty $ Insert vval' velt vidx+  where+    ty = LMVector l (widthToLlvmInt w)++genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do+    vval <- exprToVarW val+    velt <- exprToVarW elt+    vidx <- exprToVarW idx+    vval' <- singletonPanic "genMachOp_slow" <$>+             castVarsW Signed [(vval, ty)]+    doExprW ty $ Insert vval' velt vidx+  where+    ty = LMVector l (widthToLlvmFloat w)++-- Binary MachOp+genMachOp_slow opt op [x, y] = case op of++    MO_Eq _   -> genBinComp opt LM_CMP_Eq+    MO_Ne _   -> genBinComp opt LM_CMP_Ne++    MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt+    MO_S_Ge _ -> genBinComp opt LM_CMP_Sge+    MO_S_Lt _ -> genBinComp opt LM_CMP_Slt+    MO_S_Le _ -> genBinComp opt LM_CMP_Sle++    MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt+    MO_U_Ge _ -> genBinComp opt LM_CMP_Uge+    MO_U_Lt _ -> genBinComp opt LM_CMP_Ult+    MO_U_Le _ -> genBinComp opt LM_CMP_Ule++    MO_Add _ -> genBinMach LM_MO_Add+    MO_Sub _ -> genBinMach LM_MO_Sub+    MO_Mul _ -> genBinMach LM_MO_Mul++    MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!"++    MO_S_MulMayOflo w -> isSMulOK w x y++    MO_S_Quot _ -> genBinMach LM_MO_SDiv+    MO_S_Rem  _ -> genBinMach LM_MO_SRem++    MO_U_Quot _ -> genBinMach LM_MO_UDiv+    MO_U_Rem  _ -> genBinMach LM_MO_URem++    MO_F_Eq _ -> genBinComp opt LM_CMP_Feq+    MO_F_Ne _ -> genBinComp opt LM_CMP_Fne+    MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt+    MO_F_Ge _ -> genBinComp opt LM_CMP_Fge+    MO_F_Lt _ -> genBinComp opt LM_CMP_Flt+    MO_F_Le _ -> genBinComp opt LM_CMP_Fle++    MO_F_Add  _ -> genBinMach LM_MO_FAdd+    MO_F_Sub  _ -> genBinMach LM_MO_FSub+    MO_F_Mul  _ -> genBinMach LM_MO_FMul+    MO_F_Quot _ -> genBinMach LM_MO_FDiv++    MO_And _   -> genBinMach LM_MO_And+    MO_Or  _   -> genBinMach LM_MO_Or+    MO_Xor _   -> genBinMach LM_MO_Xor+    MO_Shl _   -> genBinMach LM_MO_Shl+    MO_U_Shr _ -> genBinMach LM_MO_LShr+    MO_S_Shr _ -> genBinMach LM_MO_AShr++    MO_V_Add l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add+    MO_V_Sub l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub+    MO_V_Mul l w   -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul++    MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv+    MO_VS_Rem  l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem++    MO_VU_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_UDiv+    MO_VU_Rem  l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_URem++    MO_VF_Add  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd+    MO_VF_Sub  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub+    MO_VF_Mul  l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul+    MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv++    MO_Not _       -> panicOp+    MO_S_Neg _     -> panicOp+    MO_F_Neg _     -> panicOp++    MO_SF_Conv _ _ -> panicOp+    MO_FS_Conv _ _ -> panicOp+    MO_SS_Conv _ _ -> panicOp+    MO_UU_Conv _ _ -> panicOp+    MO_XX_Conv _ _ -> panicOp+    MO_FF_Conv _ _ -> panicOp++    MO_V_Insert  {} -> panicOp+    MO_V_Extract {} -> panicOp++    MO_VS_Neg {} -> panicOp++    MO_VF_Insert  {} -> panicOp+    MO_VF_Extract {} -> panicOp++    MO_VF_Neg {} -> panicOp++    MO_AlignmentCheck {} -> panicOp++    where+        binLlvmOp ty binOp = runExprData $ do+            vx <- exprToVarW x+            vy <- exprToVarW y+            if getVarType vx == getVarType vy+                then do+                    doExprW (ty vx) $ binOp vx vy++                else do+                    -- Error. Continue anyway so we can debug the generated ll file.+                    dflags <- getDynFlags+                    let style = mkCodeStyle CStyle+                        toString doc = renderWithStyle dflags doc style+                        cmmToStr = (lines . toString . PprCmm.pprExpr)+                    statement $ Comment $ map fsLit $ cmmToStr x+                    statement $ Comment $ map fsLit $ cmmToStr y+                    doExprW (ty vx) $ binOp vx vy++        binCastLlvmOp ty binOp = runExprData $ do+            vx <- exprToVarW x+            vy <- exprToVarW y+            vxy' <- castVarsW Signed [(vx, ty), (vy, ty)]+            case vxy' of+              [vx',vy'] -> doExprW ty $ binOp vx' vy'+              _         -> panic "genMachOp_slow: binCastLlvmOp"++        -- | Need to use EOption here as Cmm expects word size results from+        -- comparisons while LLVM return i1. Need to extend to llvmWord type+        -- if expected. See Note [Literals and branch conditions].+        genBinComp opt cmp = do+            ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp)+            dflags <- getDynFlags+            if getVarType v1 == i1+                then case i1Expected opt of+                    True  -> return ed+                    False -> do+                        let w_ = llvmWord dflags+                        (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_+                        return (v2, stmts `snocOL` s1, top)+                else+                    panic $ "genBinComp: Compare returned type other then i1! "+                        ++ (showSDoc dflags $ ppr $ getVarType v1)++        genBinMach op = binLlvmOp getVarType (LlvmOp op)++        genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op)++        -- | Detect if overflow will occur in signed multiply of the two+        -- CmmExpr's. This is the LLVM assembly equivalent of the NCG+        -- implementation. Its much longer due to type information/safety.+        -- This should actually compile to only about 3 asm instructions.+        isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData+        isSMulOK _ x y = runExprData $ do+            vx <- exprToVarW x+            vy <- exprToVarW y++            dflags <- getDynFlags+            let word  = getVarType vx+            let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx)+            let shift = llvmWidthInBits dflags word+            let shift1 = toIWord dflags (shift - 1)+            let shift2 = toIWord dflags shift++            if isInt word+                then do+                    x1     <- doExprW word2 $ Cast LM_Sext vx word2+                    y1     <- doExprW word2 $ Cast LM_Sext vy word2+                    r1     <- doExprW word2 $ LlvmOp LM_MO_Mul x1 y1+                    rlow1  <- doExprW word $ Cast LM_Trunc r1 word+                    rlow2  <- doExprW word $ LlvmOp LM_MO_AShr rlow1 shift1+                    rhigh1 <- doExprW word2 $ LlvmOp LM_MO_AShr r1 shift2+                    rhigh2 <- doExprW word $ Cast LM_Trunc rhigh1 word+                    doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2++                else+                    panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")"++        panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"+                       ++ "with two arguments! (" ++ show op ++ ")"++-- More than two expression, invalid!+genMachOp_slow _ _ _ = panic "genMachOp: More than 2 expressions in MachOp!"+++-- | Handle CmmLoad expression.+genLoad :: Atomic -> CmmExpr -> CmmType -> LlvmM ExprData++-- First we try to detect a few common cases and produce better code for+-- these then the default case. We are mostly trying to detect Cmm code+-- like I32[Sp + n] and use 'getelementptr' operations instead of the+-- generic case that uses casts and pointer arithmetic+genLoad atomic e@(CmmReg (CmmGlobal r)) ty+    = genLoad_fast atomic e r 0 ty++genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty+    = genLoad_fast atomic e r n ty++genLoad atomic e@(CmmMachOp (MO_Add _) [+                            (CmmReg (CmmGlobal r)),+                            (CmmLit (CmmInt n _))])+                ty+    = genLoad_fast atomic e r (fromInteger n) ty++genLoad atomic e@(CmmMachOp (MO_Sub _) [+                            (CmmReg (CmmGlobal r)),+                            (CmmLit (CmmInt n _))])+                ty+    = genLoad_fast atomic e r (negate $ fromInteger n) ty++-- generic case+genLoad atomic e ty+    = getTBAAMeta topN >>= genLoad_slow atomic e ty++-- | Handle CmmLoad expression.+-- This is a special case for loading from a global register pointer+-- offset such as I32[Sp+8].+genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType+             -> LlvmM ExprData+genLoad_fast atomic e r n ty = do+    dflags <- getDynFlags+    (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)+    meta          <- getTBAARegMeta r+    let ty'      = cmmToLlvmType ty+        (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt  `div` 8)+    case isPointer grt && rem == 0 of+            True  -> do+                (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix]+                -- We might need a different pointer type, so check+                case grt == ty' of+                     -- were fine+                     True -> do+                         (var, s3) <- doExpr ty' (MExpr meta $ loadInstr ptr)+                         return (var, s1 `snocOL` s2 `snocOL` s3,+                                     [])++                     -- cast to pointer type needed+                     False -> do+                         let pty = pLift ty'+                         (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty+                         (var, s4) <- doExpr ty' (MExpr meta $ loadInstr ptr')+                         return (var, s1 `snocOL` s2 `snocOL` s3+                                    `snocOL` s4, [])++            -- If its a bit type then we use the slow method since+            -- we can't avoid casting anyway.+            False -> genLoad_slow atomic  e ty meta+  where+    loadInstr ptr | atomic    = ALoad SyncSeqCst False ptr+                  | otherwise = Load ptr++-- | Handle Cmm load expression.+-- Generic case. Uses casts and pointer arithmetic if needed.+genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData+genLoad_slow atomic e ty meta = runExprData $ do+    iptr <- exprToVarW e+    dflags <- getDynFlags+    case getVarType iptr of+         LMPointer _ -> do+                    doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr)++         i@(LMInt _) | i == llvmWord dflags -> do+                    let pty = LMPointer $ cmmToLlvmType ty+                    ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty+                    doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr)++         other -> do pprPanic "exprToVar: CmmLoad expression is not right type!"+                        (PprCmm.pprExpr e <+> text (+                            "Size of Ptr: " ++ show (llvmPtrBits dflags) +++                            ", Size of var: " ++ show (llvmWidthInBits dflags other) +++                            ", Var: " ++ showSDoc dflags (ppr iptr)))+  where+    loadInstr ptr | atomic    = ALoad SyncSeqCst False ptr+                  | otherwise = Load ptr+++-- | Handle CmmReg expression. This will return a pointer to the stack+-- location of the register. Throws an error if it isn't allocated on+-- the stack.+getCmmReg :: CmmReg -> LlvmM LlvmVar+getCmmReg (CmmLocal (LocalReg un _))+  = do exists <- varLookup un+       dflags <- getDynFlags+       case exists of+         Just ety -> return (LMLocalVar un $ pLift ety)+         Nothing  -> panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!"+           -- This should never happen, as every local variable should+           -- have been assigned a value at some point, triggering+           -- "funPrologue" to allocate it on the stack.++getCmmReg (CmmGlobal g)+  = do onStack <- checkStackReg g+       dflags <- getDynFlags+       if onStack+         then return (lmGlobalRegVar dflags g)+         else panic $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!"++-- | Return the value of a given register, as well as its type. Might+-- need to be load from stack.+getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements)+getCmmRegVal reg =+  case reg of+    CmmGlobal g -> do+      onStack <- checkStackReg g+      dflags <- getDynFlags+      if onStack then loadFromStack else do+        let r = lmGlobalRegArg dflags g+        return (r, getVarType r, nilOL)+    _ -> loadFromStack+ where loadFromStack = do+         ptr <- getCmmReg reg+         let ty = pLower $ getVarType ptr+         (v, s) <- doExpr ty (Load ptr)+         return (v, ty, unitOL s)++-- | Allocate a local CmmReg on the stack+allocReg :: CmmReg -> (LlvmVar, LlvmStatements)+allocReg (CmmLocal (LocalReg un ty))+  = let ty' = cmmToLlvmType ty+        var = LMLocalVar un (LMPointer ty')+        alc = Alloca ty' 1+    in (var, unitOL $ Assignment var alc)++allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should"+                    ++ " have been handled elsewhere!"+++-- | Generate code for a literal+genLit :: EOption -> CmmLit -> LlvmM ExprData+genLit opt (CmmInt i w)+  -- See Note [Literals and branch conditions].+  = let width | i1Expected opt = i1+              | otherwise      = LMInt (widthInBits w)+        -- comm  = Comment [ fsLit $ "EOption: " ++ show opt+        --                 , fsLit $ "Width  : " ++ show w+        --                 , fsLit $ "Width' : " ++ show (widthInBits w)+        --                 ]+    in return (mkIntLit width i, nilOL, [])++genLit _ (CmmFloat r w)+  = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),+              nilOL, [])++genLit opt (CmmVec ls)+  = do llvmLits <- mapM toLlvmLit ls+       return (LMLitVar $ LMVectorLit llvmLits, nilOL, [])+  where+    toLlvmLit :: CmmLit -> LlvmM LlvmLit+    toLlvmLit lit = do+        (llvmLitVar, _, _) <- genLit opt lit+        case llvmLitVar of+          LMLitVar llvmLit -> return llvmLit+          _ -> panic "genLit"++genLit _ cmm@(CmmLabel l)+  = do var <- getGlobalPtr =<< strCLabel_llvm l+       dflags <- getDynFlags+       let lmty = cmmToLlvmType $ cmmLitType dflags cmm+       (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags)+       return (v1, unitOL s1, [])++genLit opt (CmmLabelOff label off) = do+    dflags <- getDynFlags+    (vlbl, stmts, stat) <- genLit opt (CmmLabel label)+    let voff = toIWord dflags off+    (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff+    return (v1, stmts `snocOL` s1, stat)++genLit opt (CmmLabelDiffOff l1 l2 off w) = do+    dflags <- getDynFlags+    (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1)+    (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2)+    let voff = toIWord dflags off+    let ty1 = getVarType vl1+    let ty2 = getVarType vl2+    if (isInt ty1) && (isInt ty2)+       && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2)+       then do+            (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2+            (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff+            let ty = widthToLlvmInt w+            let stmts = stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2+            if w /= wordWidth dflags+              then do+                (v3, s3) <- doExpr ty $ Cast LM_Trunc v2 ty+                return (v3, stmts `snocOL` s3, stat1 ++ stat2)+              else+                return (v2, stmts, stat1 ++ stat2)+        else+            panic "genLit: CmmLabelDiffOff encountered with different label ty!"++genLit opt (CmmBlock b)+  = genLit opt (CmmLabel $ infoTblLbl b)++genLit _ CmmHighStackMark+  = panic "genStaticLit - CmmHighStackMark unsupported!"+++-- -----------------------------------------------------------------------------+-- * Misc+--++-- | Find CmmRegs that get assigned and allocate them on the stack+--+-- Any register that gets written needs to be allcoated on the+-- stack. This avoids having to map a CmmReg to an equivalent SSA form+-- and avoids having to deal with Phi node insertion.  This is also+-- the approach recommended by LLVM developers.+--+-- On the other hand, this is unnecessarily verbose if the register in+-- question is never written. Therefore we skip it where we can to+-- save a few lines in the output and hopefully speed compilation up a+-- bit.+funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData+funPrologue live cmmBlocks = do++  trash <- getTrashRegs+  let getAssignedRegs :: CmmNode O O -> [CmmReg]+      getAssignedRegs (CmmAssign reg _)  = [reg]+      -- Calls will trash all registers. Unfortunately, this needs them to+      -- be stack-allocated in the first place.+      getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs+      getAssignedRegs _                  = []+      getRegsBlock (_, body, _)          = concatMap getAssignedRegs $ blockToList body+      assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks+      isLive r     = r `elem` alwaysLive || r `elem` live++  dflags <- getDynFlags+  stmtss <- 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, [])++-- | Function epilogue. Load STG variables to use as argument for call.+-- STG Liveness optimisation done here.+funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)+funEpilogue live = do++    -- Have information and liveness optimisation is enabled?+    let liveRegs = alwaysLive ++ live+        isSSE (FloatReg _)  = True+        isSSE (DoubleReg _) = True+        isSSE (XmmReg _)    = True+        isSSE (YmmReg _)    = True+        isSSE (ZmmReg _)    = True+        isSSE _             = False++    -- Set to value or "undef" depending on whether the register is+    -- actually live+    dflags <- getDynFlags+    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+    loads <- flip mapM (activeStgRegs platform) $ \r -> case () of+      _ | r `elem` liveRegs  -> loadExpr r+        | not (isSSE r)      -> loadUndef r+        | otherwise          -> return (Nothing, nilOL)++    let (vars, stmts) = unzip loads+    return (catMaybes vars, concatOL stmts)+++-- | A series of statements to trash all the STG registers.+--+-- In LLVM we pass the STG registers around everywhere in function calls.+-- So this means LLVM considers them live across the entire function, when+-- in reality they usually aren't. For Caller save registers across C calls+-- the saving and restoring of them is done by the Cmm code generator,+-- using Cmm local vars. So to stop LLVM saving them as well (and saving+-- all of them since it thinks they're always live, we trash them just+-- before the call by assigning the 'undef' value to them. The ones we+-- need are restored from the Cmm local var and the ones we don't need+-- are fine to be trashed.+getTrashStmts :: LlvmM LlvmStatements+getTrashStmts = do+  regs <- getTrashRegs+  stmts <- flip mapM regs $ \ r -> do+    reg <- getCmmReg (CmmGlobal r)+    let ty = (pLower . getVarType) reg+    return $ Store (LMLitVar $ LMUndefLit ty) reg+  return $ toOL stmts++getTrashRegs :: LlvmM [GlobalReg]+getTrashRegs = do plat <- getLlvmPlatform+                  return $ filter (callerSaves plat) (activeStgRegs plat)++-- | Get a function pointer to the CLabel specified.+--+-- This is for Haskell functions, function type is assumed, so doesn't work+-- with foreign functions.+getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData+getHsFunc live lbl+  = do fty <- llvmFunTy live+       name <- strCLabel_llvm lbl+       getHsFunc' name fty++getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData+getHsFunc' name fty+  = do fun <- getGlobalPtr name+       if getVarType fun == fty+         then return (fun, nilOL, [])+         else do (v1, s1) <- doExpr (pLift fty)+                               $ Cast LM_Bitcast fun (pLift fty)+                 return  (v1, unitOL s1, [])++-- | Create a new local var+mkLocalVar :: LlvmType -> LlvmM LlvmVar+mkLocalVar ty = do+    un <- getUniqueM+    return $ LMLocalVar un ty+++-- | Execute an expression, assigning result to a var+doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement)+doExpr ty expr = do+    v <- mkLocalVar ty+    return (v, Assignment v expr)+++-- | Expand CmmRegOff+expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr+expandCmmReg dflags (reg, off)+  = let width = typeWidth (cmmRegType dflags reg)+        voff  = CmmLit $ CmmInt (fromIntegral off) width+    in CmmMachOp (MO_Add width) [CmmReg reg, voff]+++-- | Convert a block id into a appropriate Llvm label+blockIdToLlvm :: BlockId -> LlvmVar+blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel++-- | Create Llvm int Literal+mkIntLit :: Integral a => LlvmType -> a -> LlvmVar+mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty++-- | Convert int type to a LLvmVar of word or i32 size+toI32 :: Integral a => a -> LlvmVar+toI32 = mkIntLit i32++toIWord :: Integral a => DynFlags -> a -> LlvmVar+toIWord dflags = mkIntLit (llvmWord dflags)+++-- | Error functions+panic :: String -> a+panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s++pprPanic :: String -> SDoc -> a+pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d+++-- | Returns TBAA meta data by unique+getTBAAMeta :: Unique -> LlvmM [MetaAnnot]+getTBAAMeta u = do+    mi <- getUniqMeta u+    return [MetaAnnot tbaa (MetaNode i) | let Just i = mi]++-- | Returns TBAA meta data for given register+getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot]+getTBAARegMeta = getTBAAMeta . getTBAA+++-- | A more convenient way of accumulating LLVM statements and declarations.+data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl]++instance Semigroup LlvmAccum where+  LlvmAccum stmtsA declsA <> LlvmAccum stmtsB declsB =+        LlvmAccum (stmtsA Semigroup.<> stmtsB) (declsA Semigroup.<> declsB)++instance Monoid LlvmAccum where+    mempty = LlvmAccum nilOL []+    mappend = (Semigroup.<>)++liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar+liftExprData action = do+    (var, stmts, decls) <- lift action+    tell $ LlvmAccum stmts decls+    return var++statement :: LlvmStatement -> WriterT LlvmAccum LlvmM ()+statement stmt = tell $ LlvmAccum (unitOL stmt) []++doExprW :: LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar+doExprW a b = do+    (var, stmt) <- lift $ doExpr a b+    statement stmt+    return var++exprToVarW :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar+exprToVarW = liftExprData . exprToVar++runExprData :: WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData+runExprData action = do+    (var, LlvmAccum stmts decls) <- runWriterT action+    return (var, stmts, decls)++runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl])+runStmtsDecls action = do+    LlvmAccum stmts decls <- execWriterT action+    return (stmts, decls)++getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar+getCmmRegW = lift . getCmmReg++genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar+genLoadW atomic e ty = liftExprData $ genLoad atomic e ty++doTrashStmts :: WriterT LlvmAccum LlvmM ()+doTrashStmts = do+    stmts <- lift getTrashStmts+    tell $ LlvmAccum stmts mempty++-- | Return element of single-element list; 'panic' if list is not a single-element list+singletonPanic :: String -> [a] -> a+singletonPanic _ [x] = x+singletonPanic s _ = panic s
+ compiler/llvmGen/LlvmCodeGen/Data.hs view
@@ -0,0 +1,194 @@+{-# LANGUAGE CPP #-}+-- ----------------------------------------------------------------------------+-- | Handle conversion of CmmData to LLVM code.+--++module LlvmCodeGen.Data (+        genLlvmData, genData+    ) where++#include "HsVersions.h"++import GhcPrelude++import Llvm+import LlvmCodeGen.Base++import BlockId+import CLabel+import Cmm+import DynFlags+import 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+    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 _ -> 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 view
@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}++-- ----------------------------------------------------------------------------+-- | Pretty print helpers for the LLVM Code generator.+--+module LlvmCodeGen.Ppr (+        pprLlvmCmmDecl, pprLlvmData, infoSection+    ) where++#include "HsVersions.h"++import GhcPrelude++import Llvm+import LlvmCodeGen.Base+import LlvmCodeGen.Data++import CLabel+import Cmm++import FastString+import Outputable+import Unique++-- ----------------------------------------------------------------------------+-- * Top level+--++-- | Pretty print LLVM data code+pprLlvmData :: LlvmData -> SDoc+pprLlvmData (globals, types) =+    let ppLlvmTys (LMAlias    a) = ppLlvmAlias a+        ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f+        ppLlvmTys _other         = empty++        types'   = vcat $ map ppLlvmTys types+        globals' = ppLlvmGlobals globals+    in types' $+$ globals'+++-- | Pretty print LLVM code+pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])+pprLlvmCmmDecl (CmmData _ lmdata)+  = return (vcat $ map pprLlvmData lmdata, [])++pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks))+  = do let lbl = case mb_info of+                     Nothing                   -> entry_lbl+                     Just (Statics info_lbl _) -> info_lbl+           link = if externallyVisibleCLabel lbl+                      then ExternallyVisible+                      else Internal+           lmblocks = map (\(BasicBlock id stmts) ->+                                LlvmBlock (getUnique id) stmts) blks++       funDec <- llvmFunSig live lbl link+       dflags <- getDynFlags+       let buildArg = fsLit . showSDoc dflags . ppPlainName+           funArgs = map buildArg (llvmFunArgs dflags live)+           funSect = llvmFunSection dflags (decName funDec)++       -- generate the info table+       prefix <- case mb_info of+                     Nothing -> return Nothing+                     Just (Statics _ statics) -> do+                       infoStatics <- mapM genData statics+                       let infoTy = LMStruct $ map getStatType infoStatics+                       return $ Just $ LMStaticStruc infoStatics infoTy+++       let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect+                              prefix lmblocks+           name = decName $ funcDecl fun+           defName = llvmDefLabel name+           funcDecl' = (funcDecl fun) { decName = defName }+           fun' = fun { funcDecl = funcDecl' }+           funTy = LMFunction funcDecl'+           funVar = LMGlobalVar name+                                (LMPointer funTy)+                                link+                                Nothing+                                Nothing+                                Alias+           defVar = LMGlobalVar defName+                                (LMPointer funTy)+                                (funcLinkage funcDecl')+                                (funcSect fun)+                                (funcAlign funcDecl')+                                Alias+           alias = LMGlobal funVar+                            (Just $ LMBitc (LMStaticPointer defVar)+                                           i8Ptr)++       return (ppLlvmGlobal alias $+$ ppLlvmFunction fun', [])+++-- | The section we are putting info tables and their entry code into, should+-- be unique since we process the assembly pattern matching this.+infoSection :: String+infoSection = "X98A__STRIP,__me"
+ compiler/llvmGen/LlvmCodeGen/Regs.hs view
@@ -0,0 +1,136 @@+{-# LANGUAGE CPP #-}++--------------------------------------------------------------------------------+-- | Deal with Cmm registers+--++module LlvmCodeGen.Regs (+        lmGlobalRegArg, lmGlobalRegVar, alwaysLive,+        stgTBAA, baseN, stackN, heapN, rxN, topN, tbaa, getTBAA+    ) where++#include "HsVersions.h"++import GhcPrelude++import Llvm++import CmmExpr+import DynFlags+import FastString+import Outputable ( panic )+import Unique++-- | Get the LlvmVar function variable storing the real register+lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar+lmGlobalRegVar dflags = pVarLift . lmGlobalReg dflags "_Var"++-- | Get the LlvmVar function argument storing the real register+lmGlobalRegArg :: DynFlags -> GlobalReg -> LlvmVar+lmGlobalRegArg dflags = lmGlobalReg dflags "_Arg"++{- Need to make sure the names here can't conflict with the unique generated+   names. Uniques generated names containing only base62 chars. So using say+   the '_' char guarantees this.+-}+lmGlobalReg :: DynFlags -> String -> GlobalReg -> LlvmVar+lmGlobalReg dflags suf reg+  = case reg of+        BaseReg        -> ptrGlobal $ "Base" ++ suf+        Sp             -> ptrGlobal $ "Sp" ++ suf+        Hp             -> ptrGlobal $ "Hp" ++ suf+        VanillaReg 1 _ -> wordGlobal $ "R1" ++ suf+        VanillaReg 2 _ -> wordGlobal $ "R2" ++ suf+        VanillaReg 3 _ -> wordGlobal $ "R3" ++ suf+        VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf+        VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf+        VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf+        VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf+        VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf+        SpLim          -> wordGlobal $ "SpLim" ++ suf+        FloatReg 1     -> floatGlobal $"F1" ++ suf+        FloatReg 2     -> floatGlobal $"F2" ++ suf+        FloatReg 3     -> floatGlobal $"F3" ++ suf+        FloatReg 4     -> floatGlobal $"F4" ++ suf+        FloatReg 5     -> floatGlobal $"F5" ++ suf+        FloatReg 6     -> floatGlobal $"F6" ++ suf+        DoubleReg 1    -> doubleGlobal $ "D1" ++ suf+        DoubleReg 2    -> doubleGlobal $ "D2" ++ suf+        DoubleReg 3    -> doubleGlobal $ "D3" ++ suf+        DoubleReg 4    -> doubleGlobal $ "D4" ++ suf+        DoubleReg 5    -> doubleGlobal $ "D5" ++ suf+        DoubleReg 6    -> doubleGlobal $ "D6" ++ suf+        XmmReg 1       -> xmmGlobal $ "XMM1" ++ suf+        XmmReg 2       -> xmmGlobal $ "XMM2" ++ suf+        XmmReg 3       -> xmmGlobal $ "XMM3" ++ suf+        XmmReg 4       -> xmmGlobal $ "XMM4" ++ suf+        XmmReg 5       -> xmmGlobal $ "XMM5" ++ suf+        XmmReg 6       -> xmmGlobal $ "XMM6" ++ suf+        YmmReg 1       -> ymmGlobal $ "YMM1" ++ suf+        YmmReg 2       -> ymmGlobal $ "YMM2" ++ suf+        YmmReg 3       -> ymmGlobal $ "YMM3" ++ suf+        YmmReg 4       -> ymmGlobal $ "YMM4" ++ suf+        YmmReg 5       -> ymmGlobal $ "YMM5" ++ suf+        YmmReg 6       -> ymmGlobal $ "YMM6" ++ suf+        ZmmReg 1       -> zmmGlobal $ "ZMM1" ++ suf+        ZmmReg 2       -> zmmGlobal $ "ZMM2" ++ suf+        ZmmReg 3       -> zmmGlobal $ "ZMM3" ++ suf+        ZmmReg 4       -> zmmGlobal $ "ZMM4" ++ suf+        ZmmReg 5       -> zmmGlobal $ "ZMM5" ++ suf+        ZmmReg 6       -> zmmGlobal $ "ZMM6" ++ suf+        MachSp         -> wordGlobal $ "MachSp" ++ suf+        _other         -> panic $ "LlvmCodeGen.Reg: GlobalReg (" ++ (show reg)+                                ++ ") not supported!"+        -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc+        -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg+    where+        wordGlobal   name = LMNLocalVar (fsLit name) (llvmWord dflags)+        ptrGlobal    name = LMNLocalVar (fsLit name) (llvmWordPtr dflags)+        floatGlobal  name = LMNLocalVar (fsLit name) LMFloat+        doubleGlobal name = LMNLocalVar (fsLit name) LMDouble+        xmmGlobal    name = LMNLocalVar (fsLit name) (LMVector 4 (LMInt 32))+        ymmGlobal    name = LMNLocalVar (fsLit name) (LMVector 8 (LMInt 32))+        zmmGlobal    name = LMNLocalVar (fsLit name) (LMVector 16 (LMInt 32))++-- | A list of STG Registers that should always be considered alive+alwaysLive :: [GlobalReg]+alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node]++-- | STG Type Based Alias Analysis hierarchy+stgTBAA :: [(Unique, LMString, Maybe Unique)]+stgTBAA+  = [ (rootN,  fsLit "root",   Nothing)+    , (topN,   fsLit "top",   Just rootN)+    , (stackN, fsLit "stack", Just topN)+    , (heapN,  fsLit "heap",  Just topN)+    , (rxN,    fsLit "rx",    Just heapN)+    , (baseN,  fsLit "base",  Just topN)+    -- FIX: Not 100% sure if this hierarchy is complete.  I think the big thing+    -- is Sp is never aliased, so might want to change the hierarchy to have Sp+    -- on its own branch that is never aliased (e.g never use top as a TBAA+    -- node).+    ]++-- | Id values+-- The `rootN` node is the root (there can be more than one) of the TBAA+-- hierarchy and as of LLVM 4.0 should *only* be referenced by other nodes. It+-- should never occur in any LLVM instruction statement.+rootN, topN, stackN, heapN, rxN, baseN :: Unique+rootN  = getUnique (fsLit "LlvmCodeGen.Regs.rootN")+topN   = getUnique (fsLit "LlvmCodeGen.Regs.topN")+stackN = getUnique (fsLit "LlvmCodeGen.Regs.stackN")+heapN  = getUnique (fsLit "LlvmCodeGen.Regs.heapN")+rxN    = getUnique (fsLit "LlvmCodeGen.Regs.rxN")+baseN  = getUnique (fsLit "LlvmCodeGen.Regs.baseN")++-- | The TBAA metadata identifier+tbaa :: LMString+tbaa = fsLit "tbaa"++-- | Get the correct TBAA metadata information for this register type+getTBAA :: GlobalReg -> Unique+getTBAA BaseReg          = baseN+getTBAA Sp               = stackN+getTBAA Hp               = heapN+getTBAA (VanillaReg _ _) = rxN+getTBAA _                = topN
+ compiler/llvmGen/LlvmMangler.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 LlvmMangler ( llvmFixupAsm ) where++import GhcPrelude++import DynFlags ( DynFlags, targetPlatform )+import 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 (pure 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/Ar.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, CPP #-}+{- Note: [The need for Ar.hs]+Building `-staticlib` required the presence of libtool, and was a such+restricted to mach-o only. As libtool on macOS and gnu libtool are very+different, there was no simple portable way to support this.++libtool for static archives does essentially: concatinate the input archives,+add the input objects, and create a symbol index. Using `ar` for this task+fails as even `ar` (bsd and gnu, llvm, ...) do not provide the same+features across platforms (e.g. index prefixed retrieval of objects with+the same name.)++As Archives are rather simple structurally, we can just build the archives+with Haskell directly and use ranlib on the final result to get the symbol+index. This should allow us to work around with the differences/abailability+of libtool across differet platforms.+-}+module Ar+  (ArchiveEntry(..)+  ,Archive(..)+  ,afilter++  ,parseAr++  ,loadAr+  ,loadObj+  ,writeBSDAr+  ,writeGNUAr++  ,isBSDSymdef+  ,isGNUSymdef+  )+   where++import GhcPrelude++import Data.List (mapAccumL, isPrefixOf)+import Data.Monoid ((<>))+import Data.Binary.Get+import Data.Binary.Put+import Control.Monad+import Control.Applicative+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as C+import qualified Data.ByteString.Lazy as L+#if !defined(mingw32_HOST_OS)+import qualified System.Posix.Files as POSIX+#endif+import System.FilePath (takeFileName)++data ArchiveEntry = ArchiveEntry+    { filename :: String       -- ^ File name.+    , filetime :: Int          -- ^ File modification time.+    , fileown  :: Int          -- ^ File owner.+    , filegrp  :: Int          -- ^ File group.+    , filemode :: Int          -- ^ File mode.+    , filesize :: Int          -- ^ File size.+    , filedata :: B.ByteString -- ^ File bytes.+    } deriving (Eq, Show)++newtype Archive = Archive [ArchiveEntry]+        deriving (Eq, Show, Semigroup, Monoid)++afilter :: (ArchiveEntry -> Bool) -> Archive -> Archive+afilter f (Archive xs) = Archive (filter f xs)++isBSDSymdef, isGNUSymdef :: ArchiveEntry -> Bool+isBSDSymdef a = "__.SYMDEF" `isPrefixOf` (filename a)+isGNUSymdef a = "/" == (filename a)++-- | Archives have numeric values padded with '\x20' to the right.+getPaddedInt :: B.ByteString -> Int+getPaddedInt = read . C.unpack . C.takeWhile (/= '\x20')++putPaddedInt :: Int -> Int -> Put+putPaddedInt padding i = putPaddedString '\x20' padding (show i)++putPaddedString :: Char -> Int -> String -> Put+putPaddedString pad padding s = putByteString . C.pack . take padding $ s `mappend` (repeat pad)++getBSDArchEntries :: Get [ArchiveEntry]+getBSDArchEntries = do+    empty <- isEmpty+    if empty then+        return []+     else do+        name    <- getByteString 16+        when ('/' `C.elem` name && C.take 3 name /= "#1/") $+          fail "Looks like GNU Archive"+        time    <- getPaddedInt <$> getByteString 12+        own     <- getPaddedInt <$> getByteString 6+        grp     <- getPaddedInt <$> getByteString 6+        mode    <- getPaddedInt <$> getByteString 8+        st_size <- getPaddedInt <$> getByteString 10+        end     <- getByteString 2+        when (end /= "\x60\x0a") $+          fail ("[BSD Archive] Invalid archive header end marker for name: " +++                C.unpack name)+        off1    <- liftM fromIntegral bytesRead :: Get Int+        -- BSD stores extended filenames, by writing #1/<length> into the+        -- name field, the first @length@ bytes then represent the file name+        -- thus the payload size is filesize + file name length.+        name    <- if C.unpack (C.take 3 name) == "#1/" then+                        liftM (C.unpack . C.takeWhile (/= '\0')) (getByteString $ read $ C.unpack $ C.drop 3 name)+                    else+                        return $ C.unpack $ C.takeWhile (/= ' ') name+        off2    <- liftM fromIntegral bytesRead :: Get Int+        file    <- getByteString (st_size - (off2 - off1))+        -- data sections are two byte aligned (see #15396)+        when (odd st_size) $+          void (getByteString 1)++        rest    <- getBSDArchEntries+        return $ (ArchiveEntry name time own grp mode (st_size - (off2 - off1)) file) : rest++-- | GNU Archives feature a special '//' entry that contains the+-- extended names. Those are referred to as /<num>, where num is the+-- offset into the '//' entry.+-- In addition, filenames are terminated with '/' in the archive.+getGNUArchEntries :: Maybe ArchiveEntry -> Get [ArchiveEntry]+getGNUArchEntries extInfo = do+  empty <- isEmpty+  if empty+    then return []+    else+    do+      name    <- getByteString 16+      time    <- getPaddedInt <$> getByteString 12+      own     <- getPaddedInt <$> getByteString 6+      grp     <- getPaddedInt <$> getByteString 6+      mode    <- getPaddedInt <$> getByteString 8+      st_size <- getPaddedInt <$> getByteString 10+      end     <- getByteString 2+      when (end /= "\x60\x0a") $+        fail ("[BSD Archive] Invalid archive header end marker for name: " +++              C.unpack name)+      file <- getByteString st_size+      -- data sections are two byte aligned (see #15396)+      when (odd st_size) $+        void (getByteString 1)+      name <- return . C.unpack $+        if C.unpack (C.take 1 name) == "/"+        then case C.takeWhile (/= ' ') name of+               name@"/"  -> name               -- symbol table+               name@"//" -> name               -- extendedn file names table+               name      -> getExtName extInfo (read . C.unpack $ C.drop 1 name)+        else C.takeWhile (/= '/') name+      case name of+        "/"  -> getGNUArchEntries extInfo+        "//" -> getGNUArchEntries (Just (ArchiveEntry name time own grp mode st_size file))+        _    -> (ArchiveEntry name time own grp mode st_size file :) <$> getGNUArchEntries extInfo++  where+   getExtName :: Maybe ArchiveEntry -> Int -> B.ByteString+   getExtName Nothing _ = error "Invalid extended filename reference."+   getExtName (Just info) offset = C.takeWhile (/= '/') . C.drop offset $ filedata info++-- | put an Archive Entry. This assumes that the entries+-- have been preprocessed to account for the extenden file name+-- table section "//" e.g. for GNU Archives. Or that the names+-- have been move into the payload for BSD Archives.+putArchEntry :: ArchiveEntry -> PutM ()+putArchEntry (ArchiveEntry name time own grp mode st_size file) = do+  putPaddedString ' '  16 name+  putPaddedInt         12 time+  putPaddedInt          6 own+  putPaddedInt          6 grp+  putPaddedInt          8 mode+  putPaddedInt         10 (st_size + pad)+  putByteString           "\x60\x0a"+  putByteString           file+  when (pad == 1) $+    putWord8              0x0a+  where+    pad         = st_size `mod` 2++getArchMagic :: Get ()+getArchMagic = do+  magic <- liftM C.unpack $ getByteString 8+  if magic /= "!<arch>\n"+    then fail $ "Invalid magic number " ++ show magic+    else return ()++putArchMagic :: Put+putArchMagic = putByteString $ C.pack "!<arch>\n"++getArch :: Get Archive+getArch = Archive <$> do+  getArchMagic+  getBSDArchEntries <|> getGNUArchEntries Nothing++putBSDArch :: Archive -> PutM ()+putBSDArch (Archive as) = do+  putArchMagic+  mapM_ putArchEntry (processEntries as)++  where+    padStr pad size str = take size $ str <> repeat pad+    nameSize name = case length name `divMod` 4 of+      (n, 0) -> 4 * n+      (n, _) -> 4 * (n + 1)+    needExt name = length name > 16 || ' ' `elem` name+    processEntry :: ArchiveEntry -> ArchiveEntry+    processEntry archive@(ArchiveEntry name _ _ _ _ st_size _)+      | needExt name = archive { filename = "#1/" <> show sz+                               , filedata = C.pack (padStr '\0' sz name) <> filedata archive+                               , filesize = st_size + sz }+      | otherwise    = archive++      where sz = nameSize name++    processEntries = map processEntry++putGNUArch :: Archive -> PutM ()+putGNUArch (Archive as) = do+  putArchMagic+  mapM_ putArchEntry (processEntries as)++  where+    processEntry :: ArchiveEntry -> ArchiveEntry -> (ArchiveEntry, ArchiveEntry)+    processEntry extInfo archive@(ArchiveEntry name _ _ _ _ _ _)+      | length name > 15 = ( extInfo { filesize = filesize extInfo + length name + 2+                                    ,  filedata = filedata extInfo <>  C.pack name <> "/\n" }+                           , archive { filename = "/" <> show (filesize extInfo) } )+      | otherwise        = ( extInfo, archive { filename = name <> "/" } )++    processEntries :: [ArchiveEntry] -> [ArchiveEntry]+    processEntries =+      uncurry (:) . mapAccumL processEntry (ArchiveEntry "//" 0 0 0 0 0 mempty)++parseAr :: B.ByteString -> Archive+parseAr = runGet getArch . L.fromChunks . pure++writeBSDAr, writeGNUAr :: FilePath -> Archive -> IO ()+writeBSDAr fp = L.writeFile fp . runPut . putBSDArch+writeGNUAr fp = L.writeFile fp . runPut . putGNUArch++loadAr :: FilePath -> IO Archive+loadAr fp = parseAr <$> B.readFile fp++loadObj :: FilePath -> IO ArchiveEntry+loadObj fp = do+  payload <- B.readFile fp+  (modt, own, grp, mode) <- fileInfo fp+  return $ ArchiveEntry+    (takeFileName fp) modt own grp mode+    (B.length payload) payload++-- | Take a filePath and return (mod time, own, grp, mode in decimal)+fileInfo :: FilePath -> IO ( Int, Int, Int, Int) -- ^ mod time, own, grp, mode (in decimal)+#if defined(mingw32_HOST_OS)+-- on windows mod time, owner group and mode are zero.+fileInfo _ = pure (0,0,0,0)+#else+fileInfo fp = go <$> POSIX.getFileStatus fp+  where go status = ( fromEnum $ POSIX.modificationTime status+                    , fromIntegral $ POSIX.fileOwner status+                    , fromIntegral $ POSIX.fileGroup status+                    , oct2dec . fromIntegral $ POSIX.fileMode status+                    )++oct2dec :: Int -> Int+oct2dec = foldl' (\a b -> a * 10 + b) 0 . reverse . dec 8+  where dec _ 0 = []+        dec b i = let (rest, last) = i `quotRem` b+                  in last:dec b rest++#endif
+ compiler/main/CodeOutput.hs view
@@ -0,0 +1,267 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section{Code output phase}+-}++{-# LANGUAGE CPP #-}++module CodeOutput( codeOutput, outputForeignStubs ) where++#include "HsVersions.h"++import GhcPrelude++import AsmCodeGen ( nativeCodeGen )+import LlvmCodeGen ( llvmCodeGen )++import UniqSupply       ( mkSplitUniqSupply )++import Finder           ( mkStubPaths )+import PprC             ( writeCs )+import CmmLint          ( cmmLint )+import Packages+import Cmm              ( RawCmmGroup )+import HscTypes+import DynFlags+import Stream           (Stream)+import qualified Stream+import FileCleanup++import ErrUtils+import Outputable+import Module+import SrcLoc++import Control.Exception+import System.Directory+import System.FilePath+import System.IO++{-+************************************************************************+*                                                                      *+\subsection{Steering}+*                                                                      *+************************************************************************+-}++codeOutput :: DynFlags+           -> Module+           -> FilePath+           -> ModLocation+           -> ForeignStubs+           -> [(ForeignSrcLang, FilePath)]+           -- ^ additional files to be compiled with with the C compiler+           -> [InstalledUnitId]+           -> Stream IO RawCmmGroup ()                       -- Compiled C--+           -> IO (FilePath,+                  (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}),+                  [(ForeignSrcLang, FilePath)]{-foreign_fps-})++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 = withTiming (pure 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+        ; 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)+        }++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 ()+        -> [InstalledUnitId]+        -> IO ()++outputC dflags filenm cmm_stream packages+  = do+       -- ToDo: make the C backend consume the C-- incrementally, by+       -- pushing the cmm_stream inside (c.f. nativeCodeGen)+       rawcmms <- Stream.collect cmm_stream++       -- 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+          writeCs dflags h rawcmms++{-+************************************************************************+*                                                                      *+\subsection{Assembler}+*                                                                      *+************************************************************************+-}++outputAsm :: DynFlags -> Module -> ModLocation -> FilePath+          -> Stream IO RawCmmGroup ()+          -> IO ()+outputAsm dflags this_mod location filenm cmm_stream+ | sGhcWithNativeCodeGen $ settings 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+       return ()++ | otherwise+  = panic "This compiler was built without a native code generator"++{-+************************************************************************+*                                                                      *+\subsection{LLVM}+*                                                                      *+************************************************************************+-}++outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO ()+outputLlvm dflags filenm cmm_stream+  = do ncg_uniqs <- mkSplitUniqSupply 'n'++       {-# SCC "llvm_output" #-} doOutput filenm $+           \f -> {-# SCC "llvm_CodeGen" #-}+                 llvmCodeGen dflags f ncg_uniqs cmm_stream++{-+************************************************************************+*                                                                      *+\subsection{Foreign import/export}+*                                                                      *+************************************************************************+-}++outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs+                   -> IO (Bool,         -- Header file created+                          Maybe FilePath) -- C file created+outputForeignStubs dflags mod location stubs+ = do+   let stub_h = mkStubPaths dflags (moduleName mod) location+   stub_c <- newTempName dflags TFL_CurrentModule "c"++   case stubs of+     NoStubs ->+        return (False, Nothing)++     ForeignStubs h_code c_code -> do+        let+            stub_c_output_d = pprCode CStyle c_code+            stub_c_output_w = showSDoc dflags stub_c_output_d++            -- Header file protos for "foreign export"ed functions.+            stub_h_output_d = pprCode CStyle h_code+            stub_h_output_w = showSDoc dflags stub_h_output_d++        createDirectoryIfMissing True (takeDirectory stub_h)++        dumpIfSet_dyn dflags Opt_D_dump_foreign+                      "Foreign export header file" stub_h_output_d++        -- we need the #includes from the rts package for the stub files+        let rts_includes =+               let rts_pkg = getPackageDetails dflags rtsUnitId in+               concatMap mk_include (includes rts_pkg)+            mk_include i = "#include \"" ++ i ++ "\"\n"++            -- wrapper code mentions the ffi_arg type, which comes from ffi.h+            ffi_includes+              | sLibFFI $ settings 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" 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 = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"+   cplusplus_ftr = "#ifdef __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 view
@@ -0,0 +1,423 @@+{-# 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 imoprts, and we've+                -- already checked for that in processModDeps+          pp_ms loop_breaker $$ vcat (map pp_group groups)+        where+          (boot_only, others) = partition is_boot_only mss+          is_boot_only ms = not (any in_group (map snd (ms_imps ms)))+          in_group (L _ m) = m `elem` group_mods+          group_mods = map (moduleName . ms_mod) mss++          loop_breaker = head boot_only+          all_others   = tail boot_only ++ others+          groups =+            GHC.topSortModuleGraph True (mkModuleGraph all_others) Nothing++    pp_ms summary = text mod_str <> text (take (20 - length mod_str) (repeat ' '))+                       <+> (pp_imps empty (map snd (ms_imps summary)) $$+                            pp_imps (text "{-# SOURCE #-}") (map snd (ms_srcimps summary)))+        where+          mod_str = moduleNameString (moduleName (ms_mod summary))++    pp_imps :: SDoc -> [Located ModuleName] -> SDoc+    pp_imps _    [] = empty+    pp_imps what lms+        = case [m | L _ m <- lms, m `elem` cycle_mods] of+            [] -> empty+            ms -> what <+> text "imports" <+>+                                pprWithCommas ppr ms++-----------------------------------------------------------------+--+--              Flags+--+-----------------------------------------------------------------++depStartMarker, depEndMarker :: String+depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"+depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"+
+ compiler/main/DriverPipeline.hs view
@@ -0,0 +1,2272 @@+{-# LANGUAGE CPP, NamedFieldPuns, NondecreasingIndentation, BangPatterns, MultiWayIf #-}+{-# OPTIONS_GHC -fno-cse #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++-----------------------------------------------------------------------------+--+-- 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,+   linkingNeeded, checkLinkInfo, writeInterfaceOnlyMode+  ) where++#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 )+import BasicTypes       ( SuccessFlag(..) )+import Maybes           ( expectJust )+import SrcLoc+import LlvmCodeGen      ( llvmFixupAsm )+import MonadUtils+import Platform+import TcRnTypes+import Hooks+import qualified GHC.LanguageExtensions as LangExt+import FileCleanup+import Ar++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, Maybe Phase) -- ^ filename and starting phase+           -> IO (DynFlags, FilePath)+preprocess hsc_env (filename, mb_phase) =+  ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)+  runPipeline anyHsc hsc_env (filename, 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-}++-- ---------------------------------------------------------------------------++-- | 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 maybe_old_linkable+            source_modified0+ = do++   debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)++   (status, hmi0) <- 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]++   case (status, hsc_lang) of+        (HscUpToDate, _) ->+            -- TODO recomp014 triggers this assert. What's going on?!+            -- ASSERT( isJust maybe_old_linkable || isNoLink (ghcLink dflags) )+            return hmi0 { hm_linkable = maybe_old_linkable }+        (HscNotGeneratingCode, HscNothing) ->+            let mb_linkable = if isHsBootOrSig src_flavour+                                then Nothing+                                -- TODO: Questionable.+                                else Just (LM (ms_hs_date summary) this_mod [])+            in return hmi0 { hm_linkable = mb_linkable }+        (HscNotGeneratingCode, _) -> panic "compileOne HscNotGeneratingCode"+        (_, HscNothing) -> panic "compileOne HscNothing"+        (HscUpdateBoot, HscInterpreted) -> do+            return hmi0+        (HscUpdateBoot, _) -> do+            touchObjectFile dflags object_filename+            return hmi0+        (HscUpdateSig, HscInterpreted) ->+            let linkable = LM (ms_hs_date summary) this_mod []+            in return hmi0 { hm_linkable = Just linkable }+        (HscUpdateSig, _) -> 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,+                               Just (HscOut src_flavour+                                            mod_name HscUpdateSig))+                              (Just basename)+                              Persistent+                              (Just location)+                              []+            o_time <- getModificationUTCTime object_filename+            let linkable = LM o_time this_mod [DotO object_filename]+            return hmi0 { hm_linkable = Just linkable }+        (HscRecomp cgguts summary, HscInterpreted) -> do+            (hasStub, comp_bc, spt_entries) <-+                hscInteractive hsc_env cgguts summary++            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 hmi0 { hm_linkable = Just linkable }+        (HscRecomp cgguts summary, _) -> do+            output_fn <- getOutputFilename next_phase+                            (Temporary TFL_CurrentModule)+                            basename dflags next_phase (Just location)+            -- We're in --make mode: finish the compilation pipeline.+            _ <- runPipeline StopLn hsc_env+                              (output_fn,+                               Just (HscOut src_flavour mod_name (HscRecomp cgguts summary)))+                              (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 hmi0 { hm_linkable = 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, 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)+                  (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 sGhcWithInterpreter $ settings 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, 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 PhasePlus) -- ^ Input filename (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)    -- ^ (final flags, output filename)+runPipeline stop_phase hsc_env0 (input_fn, 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 ()++         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)    -- ^ (final flags, output filename)+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 }++  evalP (pipeLoop start_phase input_fn) env state++-- ---------------------------------------------------------------------------+-- outer pipeline loop++-- | pipeLoop runs phases until we reach the stop phase+pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, 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 (dflags, 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 (dflags, 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+           r <- pipeLoop next_phase output_fn+           case phase of+               HscOut {} ->+                   whenGeneratingDynamicToo dflags $ do+                       setDynFlags $ dynamicTooMkDynamicDynFlags dflags+                       -- TODO shouldn't ignore result:+                       _ <- pipeLoop phase input_fn+                       return ()+               _ ->+                   return ()+           return r++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 = LLVM_TARGET+        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets 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+            (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)+            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, _) <- liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'+                            mod_summary source_unchanged Nothing (1,1)++        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 cgguts mod_summary+              -> do output_fn <- phaseOutputFilename next_phase++                    PipeState{hsc_env=hsc_env'} <- getPipeState++                    (outputFilename, mStub, foreign_files) <- liftIO $+                      hscGenHardCode hsc_env' cgguts mod_summary output_fn+                    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++-- we don't support preprocessing .c files (with -E) now.  Doing so introduces+-- way too many hacks, and I can't say I've ever used it anyway.++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++        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 cc_phase `eqPhase` 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+                       ++ 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 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+        mySettings = settings 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++    -- Here are some libs that need to be linked at the *end* of+    -- the command line, because they contain symbols that are referred to+    -- by the RTS.  We can't therefore use the ordinary way opts for these.+    let debug_opts | WayDebug `elem` ways dflags = [+#if defined(HAVE_LIBBFD)+                        "-lbfd", "-liberty"+#endif+                         ]+                   | otherwise                   = []++        thread_opts | WayThreaded `elem` ways dflags = [+#if NEED_PTHREAD_LIB+                        "-lpthread"+#endif+                        ]+                    | otherwise                      = []++    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 sLdSupportsCompactUnwind mySettings &&+                             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 sLdIsGnuLd mySettings &&+                             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+                      ++ debug_opts+                      ++ thread_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 sLdIsGnuLd (settings 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 target_defs =+          [ "-D" ++ HOST_OS     ++ "_BUILD_OS",+            "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH",+            "-D" ++ TARGET_OS   ++ "_HOST_OS",+            "-D" ++ TARGET_ARCH ++ "_HOST_ARCH" ]+        -- remember, in code we *compile*, the HOST is the same our TARGET,+        -- and BUILD is the same as our HOST.++    let sse_defs =+          [ "-D__SSE__"      | isSseEnabled      dflags ] +++          [ "-D__SSE2__"     | isSse2Enabled     dflags ] +++          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]++    let avx_defs =+          [ "-D__AVX__"      | isAvxEnabled      dflags ] +++          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] +++          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] +++          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] +++          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] +++          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]++    backend_defs <- getBackendDefs dflags++    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]+    -- Default CPP defines in Haskell source+    ghcVersionH <- getGhcVersionPathName dflags+    let hsSourceCppOpts = [ "-include", ghcVersionH ]++    -- MIN_VERSION macros+    let uids = explicitPackages (pkgState dflags)+        pkgs = catMaybes (map (lookupPackage dflags) uids)+    mb_macro_include <-+        if not (null pkgs) && gopt Opt_VersionMacros dflags+            then do macro_stub <- newTempName dflags TFL_CurrentModule "h"+                    writeFile macro_stub (generatePackageVersionMacros pkgs)+                    -- Include version macros for every *exposed* package.+                    -- Without -hide-all-packages and with a package database+                    -- size of 1000 packages, it takes cpp an estimated 2+                    -- milliseconds to process this file. See #10970+                    -- comment 8.+                    return [SysTools.FileOption "-include" macro_stub]+            else return []++    cpp_prog       (   map SysTools.Option verbFlags+                    ++ map SysTools.Option include_paths+                    ++ map SysTools.Option hsSourceCppOpts+                    ++ map SysTools.Option target_defs+                    ++ map SysTools.Option backend_defs+                    ++ map SysTools.Option th_defs+                    ++ map SysTools.Option hscpp_opts+                    ++ map SysTools.Option sse_defs+                    ++ map SysTools.Option avx_defs+                    ++ mb_macro_include+        -- Set the language mode to assembler-with-cpp when preprocessing. This+        -- alleviates some of the C99 macro rules relating to whitespace and the hash+        -- operator, which we tend to abuse. Clang in particular is not very happy+        -- about this.+                    ++ [ SysTools.Option     "-x"+                       , SysTools.Option     "assembler-with-cpp"+                       , SysTools.Option     input_fn+        -- We hackily use Option instead of FileOption here, so that the file+        -- name is not back-slashed on Windows.  cpp is capable of+        -- dealing with / in filenames, so it works fine.  Furthermore+        -- if we put in backslashes, cpp outputs #line directives+        -- with *double* backslashes.   And that in turn means that+        -- our error messages get double backslashes in them.+        -- In due course we should arrange that the lexer deals+        -- with these \\ escapes properly.+                       , SysTools.Option     "-o"+                       , SysTools.FileOption "" output_fn+                       ])++getBackendDefs :: DynFlags -> IO [String]+getBackendDefs dflags | hscTarget dflags == HscLlvm = do+    llvmVer <- figureLlvmVersion dflags+    return $ case llvmVer of+               Just n -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format n ]+               _      -> []+  where+    format (major, minor)+      | minor >= 100 = error "getBackendDefs: Unsupported minor version"+      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int++getBackendDefs _ =+    return []++-- ---------------------------------------------------------------------------+-- Macros (cribbed from Cabal)++generatePackageVersionMacros :: [PackageConfig] -> String+generatePackageVersionMacros pkgs = concat+  -- Do not add any C-style comments. See #3389.+  [ generateMacros "" pkgname version+  | pkg <- pkgs+  , let version = packageVersion pkg+        pkgname = map fixchar (packageNameString pkg)+  ]++fixchar :: Char -> Char+fixchar '-' = '_'+fixchar c   = c++generateMacros :: String -> String -> Version -> String+generateMacros prefix name version =+  concat+  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"+  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"+  ,"  (major1) <  ",major1," || \\\n"+  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"+  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"+  ,"\n\n"+  ]+  where+    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)++-- ---------------------------------------------------------------------------+-- join object files into a single relocatable object file, using ld -r++{-+Note [Produce big objects on Windows]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The Windows Portable Executable object format has a limit of 32k sections, which+we tend to blow through pretty easily. Thankfully, there is a "big object"+extension, which raises this limit to 2^32. However, it must be explicitly+enabled in the toolchain:++ * the assembler accepts the -mbig-obj flag, which causes it to produce a+   bigobj-enabled COFF object.++ * the linker accepts the --oformat pe-bigobj-x86-64 flag. Despite what the name+   suggests, this tells the linker to produce a bigobj-enabled COFF object, no a+   PE executable.++We must enable bigobj output in a few places:++ * When merging object files (DriverPipeline.joinObjectFiles)++ * When assembling (DriverPipeline.runPhase (RealPhase As ...))++Unfortunately the big object format is not supported on 32-bit targets so+none of this can be used in that case.+-}++joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()+joinObjectFiles dflags o_files output_fn = do+  let mySettings = settings dflags+      ldIsGnuLd = sLdIsGnuLd mySettings+      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 sGccSupportsNoPie mySettings+                          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 | sLdSupportsBuildId mySettings = ["-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 sLdSupportsFilelist mySettings+     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 view
@@ -0,0 +1,316 @@+{-# LANGUAGE CPP, MagicHash #-}++-- | Dynamically lookup up values from modules and loading them.+module DynamicLoading (+        initializePlugins,+#if defined(GHCI)+        -- * Loading plugins+        loadFrontendPlugin,++        -- * Force loading information+        forceLoadModuleInterfaces,+        forceLoadNameModuleInterface,+        forceLoadTyCon,++        -- * Finding names+        lookupRdrNameInModuleForPlugins,++        -- * Loading values+        getValueSafely,+        getHValueSafely,+        lessUnsafeCoerce+#else+        pluginError+#endif+    ) where++import GhcPrelude+import DynFlags++#if defined(GHCI)+import Linker           ( linkModule, getHValue )+import GHCi             ( wormhole )+import SrcLoc           ( noSrcSpan )+import Finder           ( findPluginModule, cannotFindModule )+import TcRnMonad        ( initTcInteractive, initIfaceTcRn )+import LoadIface        ( loadPluginInterface )+import RdrName          ( RdrName, ImportSpec(..), ImpDeclSpec(..)+                        , ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName+                        , gre_name, mkRdrQual )+import OccName          ( OccName, mkVarOcc )+import RnNames          ( gresFromAvails )+import Plugins+import PrelNames        ( pluginTyConName, frontendPluginTyConName )++import HscTypes+import GHCi.RemoteTypes ( HValue )+import Type             ( Type, eqType, mkTyConTy, 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# )++#else++import HscTypes         ( HscEnv )+import Module           ( ModuleName, moduleNameString )+import Panic++import Data.List        ( intercalate )+import Control.Monad    ( unless )++#endif++-- | 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+#if !defined(GHCI)+initializePlugins _ df+  = do let pluginMods = pluginModNames df+       unless (null pluginMods) (pluginError pluginMods)+       return df+#else+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 })+       return $ df { cachedPlugins = loadedPlugins }+  where argumentsForPlugin p = map snd . filter ((== lpModuleName p) . fst)+#endif+++#if defined(GHCI)++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++#else++pluginError :: [ModuleName] -> a+pluginError modnames = throwGhcException (CmdLineError msg)+  where+    msg = "not built for interactive use - can't load plugins ("+            -- module names are not z-encoded+          ++ intercalate ", " (map moduleNameString modnames)+          ++ ")"++#endif
+ compiler/main/Elf.hs view
@@ -0,0 +1,467 @@+{-+-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 2015+--+-- ELF format tools+--+-----------------------------------------------------------------------------+-}++module Elf (+    readElfSectionByName,+    readElfNoteAsString,+    makeElfNote+  ) where++import GhcPrelude++import AsmUtils+import Exception+import DynFlags+import ErrUtils+import Maybes     (MaybeT(..),runMaybeT)+import Util       (charToC)+import Outputable (text,hcat,SDoc)++import Control.Monad (when)+import Data.Binary.Get+import Data.Word+import Data.Char (ord)+import Data.ByteString.Lazy (ByteString)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.ByteString.Lazy.Char8 as B8++{- Note [ELF specification]+   ~~~~~~~~~~~~~~~~~~~~~~~~++   ELF (Executable and Linking Format) is described in the System V Application+   Binary Interface (or ABI). The latter is composed of two parts: a generic+   part and a processor specific part. The generic ABI describes the parts of+   the interface that remain constant across all hardware implementations of+   System V.++   The latest release of the specification of the generic ABI is the version+   4.1 from March 18, 1997:++     - http://www.sco.com/developers/devspecs/gabi41.pdf++   Since 1997, snapshots of the draft for the "next" version are published:++     - http://www.sco.com/developers/gabi/++   Quoting the notice on the website: "There is more than one instance of these+   chapters to permit references to older instances to remain valid. All+   modifications to these chapters are forward-compatible, so that correct use+   of an older specification will not be invalidated by a newer instance.+   Approximately on a yearly basis, a new instance will be saved, as it reaches+   what appears to be a stable state."++   Nevertheless we will see that since 1998 it is not true for Note sections.++   Many ELF sections+   -----------------++   ELF-4.1: the normal section number fields in ELF are limited to 16 bits,+   which runs out of bits when you try to cram in more sections than that. Two+   fields are concerned: the one containing the number of the sections and the+   one containing the index of the section that contains section's names. (The+   same thing applies to the field containing the number of segments, but we+   don't care about it here).++   ELF-next: to solve this, theses fields in the ELF header have an escape+   value (different for each case), and the actual section number is stashed+   into unused fields in the first section header.++   We support this extension as it is forward-compatible with ELF-4.1.+   Moreover, GHC may generate objects with a lot of sections with the+   "function-sections" feature (one section per function).++   Note sections+   -------------++   Sections with type "note" (SHT_NOTE in the specification) are used to add+   arbitrary data into an ELF file. An entry in a note section is composed of a+   name, a type and a value.++   ELF-4.1: "The note information in sections and program header elements holds+   any number of entries, each of which is an array of 4-byte words in the+   format of the target processor." Each entry has the following format:+         | namesz |   Word32: size of the name string (including the ending \0)+         | descsz |   Word32: size of the value+         |  type  |   Word32: type of the note+         |  name  |   Name string (with \0 padding to ensure 4-byte alignment)+         |  ...   |+         |  desc  |   Value (with \0 padding to ensure 4-byte alignment)+         |  ...   |++   ELF-next: "The note information in sections and program header elements+   holds a variable amount of entries. In 64-bit objects (files with+   e_ident[EI_CLASS] equal to ELFCLASS64), each entry is an array of 8-byte+   words in the format of the target processor. In 32-bit objects (files with+   e_ident[EI_CLASS] equal to ELFCLASS32), each entry is an array of 4-byte+   words in the format of the target processor." (from 1998-2015 snapshots)++   This is not forward-compatible with ELF-4.1. In practice, for almost all+   platforms namesz, descz and type fields are 4-byte words for both 32-bit and+   64-bit objects (see elf.h and readelf source code).++   The only exception in readelf source code is for IA_64 machines with OpenVMS+   OS: "This OS has so many departures from the ELF standard that we test it at+   many places" (comment for is_ia64_vms() in readelf.c). In this case, namesz,+   descsz and type fields are 8-byte words and name and value fields are padded+   to ensure 8-byte alignment.++   We don't support this platform in the following code. Reading a note section+   could be done easily (by testing Machine and OS fields in the ELF header).+   Writing a note section, however, requires that we generate a different+   assembly code for GAS depending on the target platform and this is a little+   bit more involved.++-}+++-- | ELF header+--+-- The ELF header indicates the native word size (32-bit or 64-bit) and the+-- endianness of the target machine. We directly store getters for words of+-- different sizes as it is more convenient to use. We also store the word size+-- as it is useful to skip some uninteresting fields.+--+-- Other information such as the target machine and OS are left out as we don't+-- use them yet. We could add them in the future if we ever need them.+data ElfHeader = ElfHeader+   { gw16     :: Get Word16   -- ^ Get a Word16 with the correct endianness+   , gw32     :: Get Word32   -- ^ Get a Word32 with the correct endianness+   , gwN      :: Get Word64   -- ^ Get a Word with the correct word size+                              --   and endianness+   , wordSize :: Int          -- ^ Word size in bytes+   }+++-- | Read the ELF header+readElfHeader :: DynFlags -> ByteString -> IO (Maybe ElfHeader)+readElfHeader dflags bs = runGetOrThrow getHeader bs `catchIO` \_ -> do+    debugTraceMsg dflags 3 $+      text ("Unable to read ELF header")+    return Nothing+  where+    getHeader = do+      magic    <- getWord32be+      ws       <- getWord8+      endian   <- getWord8+      version  <- getWord8+      skip 9  -- skip OSABI, ABI version and padding+      when (magic /= 0x7F454C46 || version /= 1) $ fail "Invalid ELF header"++      case (ws, endian) of+          -- ELF 32, little endian+          (1,1) -> return . Just $ ElfHeader+                           getWord16le+                           getWord32le+                           (fmap fromIntegral getWord32le) 4+          -- ELF 32, big endian+          (1,2) -> return . Just $ ElfHeader+                           getWord16be+                           getWord32be+                           (fmap fromIntegral getWord32be) 4+          -- ELF 64, little endian+          (2,1) -> return . Just $ ElfHeader+                           getWord16le+                           getWord32le+                           (fmap fromIntegral getWord64le) 8+          -- ELF 64, big endian+          (2,2) -> return . Just $ ElfHeader+                           getWord16be+                           getWord32be+                           (fmap fromIntegral getWord64be) 8+          _     -> fail "Invalid ELF header"+++------------------+-- SECTIONS+------------------+++-- | Description of the section table+data SectionTable = SectionTable+  { sectionTableOffset :: Word64  -- ^ offset of the table describing sections+  , sectionEntrySize   :: Word16  -- ^ size of an entry in the section table+  , sectionEntryCount  :: Word64  -- ^ number of sections+  , sectionNameIndex   :: Word32  -- ^ index of a special section which+                                  --   contains section's names+  }++-- | Read the ELF section table+readElfSectionTable :: DynFlags+                    -> ElfHeader+                    -> ByteString+                    -> IO (Maybe SectionTable)++readElfSectionTable dflags hdr bs = action `catchIO` \_ -> do+    debugTraceMsg dflags 3 $+      text ("Unable to read ELF section table")+    return Nothing+  where+    getSectionTable :: Get SectionTable+    getSectionTable = do+      skip (24 + 2*wordSize hdr) -- skip header and some other fields+      secTableOffset <- gwN hdr+      skip 10+      entrySize      <- gw16 hdr+      entryCount     <- gw16 hdr+      secNameIndex   <- gw16 hdr+      return (SectionTable secTableOffset entrySize+                           (fromIntegral entryCount)+                           (fromIntegral secNameIndex))++    action = do+      secTable <- runGetOrThrow getSectionTable bs+      -- In some cases, the number of entries and the index of the section+      -- containing section's names must be found in unused fields of the first+      -- section entry (see Note [ELF specification])+      let+        offSize0 = fromIntegral $ sectionTableOffset secTable + 8+                                  + 3 * fromIntegral (wordSize hdr)+        offLink0 = fromIntegral $ offSize0 + fromIntegral (wordSize hdr)++      entryCount'     <- if sectionEntryCount secTable /= 0+                          then return (sectionEntryCount secTable)+                          else runGetOrThrow (gwN hdr) (LBS.drop offSize0 bs)+      entryNameIndex' <- if sectionNameIndex secTable /= 0xffff+                          then return (sectionNameIndex secTable)+                          else runGetOrThrow (gw32 hdr) (LBS.drop offLink0 bs)+      return (Just $ secTable+        { sectionEntryCount = entryCount'+        , sectionNameIndex  = entryNameIndex'+        })+++-- | A section+data Section = Section+  { entryName :: ByteString   -- ^ Name of the section+  , entryBS   :: ByteString   -- ^ Content of the section+  }++-- | Read a ELF section+readElfSectionByIndex :: DynFlags+                      -> ElfHeader+                      -> SectionTable+                      -> Word64+                      -> ByteString+                      -> IO (Maybe Section)++readElfSectionByIndex dflags hdr secTable i bs = action `catchIO` \_ -> do+    debugTraceMsg dflags 3 $+      text ("Unable to read ELF section")+    return Nothing+  where+    -- read an entry from the section table+    getEntry = do+      nameIndex <- gw32 hdr+      skip (4+2*wordSize hdr)+      offset    <- fmap fromIntegral $ gwN hdr+      size      <- fmap fromIntegral $ gwN hdr+      let bs' = LBS.take size (LBS.drop offset bs)+      return (nameIndex,bs')++    -- read the entry with the given index in the section table+    getEntryByIndex x = runGetOrThrow getEntry bs'+      where+        bs' = LBS.drop off bs+        off = fromIntegral $ sectionTableOffset secTable ++                             x * fromIntegral (sectionEntrySize secTable)++    -- Get the name of a section+    getEntryName nameIndex = do+      let idx = fromIntegral (sectionNameIndex secTable)+      (_,nameTable) <- getEntryByIndex idx+      let bs' = LBS.drop nameIndex nameTable+      runGetOrThrow getLazyByteStringNul bs'++    action = do+      (nameIndex,bs') <- getEntryByIndex (fromIntegral i)+      name            <- getEntryName (fromIntegral nameIndex)+      return (Just $ Section name bs')+++-- | Find a section from its name. Return the section contents.+--+-- We do not perform any check on the section type.+findSectionFromName :: DynFlags+                    -> ElfHeader+                    -> SectionTable+                    -> String+                    -> ByteString+                    -> IO (Maybe ByteString)+findSectionFromName dflags hdr secTable name bs =+    rec [0..sectionEntryCount secTable - 1]+  where+    -- convert the required section name into a ByteString to perform+    -- ByteString comparison instead of String comparison+    name' = B8.pack name++    -- compare recursively each section name and return the contents of+    -- the matching one, if any+    rec []     = return Nothing+    rec (x:xs) = do+      me <- readElfSectionByIndex dflags hdr secTable x bs+      case me of+        Just e | entryName e == name' -> return (Just (entryBS e))+        _                             -> rec xs+++-- | Given a section name, read its contents as a ByteString.+--+-- If the section isn't found or if there is any parsing error, we return+-- Nothing+readElfSectionByName :: DynFlags+                     -> ByteString+                     -> String+                     -> IO (Maybe LBS.ByteString)++readElfSectionByName dflags bs name = action `catchIO` \_ -> do+    debugTraceMsg dflags 3 $+      text ("Unable to read ELF section \"" ++ name ++ "\"")+    return Nothing+  where+    action = runMaybeT $ do+      hdr      <- MaybeT $ readElfHeader dflags bs+      secTable <- MaybeT $ readElfSectionTable dflags hdr bs+      MaybeT $ findSectionFromName dflags hdr secTable name bs++------------------+-- NOTE SECTIONS+------------------++-- | read a Note as a ByteString+--+-- If you try to read a note from a section which does not support the Note+-- format, the parsing is likely to fail and Nothing will be returned+readElfNoteBS :: DynFlags+              -> ByteString+              -> String+              -> String+              -> IO (Maybe LBS.ByteString)++readElfNoteBS dflags bs sectionName noteId = action `catchIO`  \_ -> do+    debugTraceMsg dflags 3 $+         text ("Unable to read ELF note \"" ++ noteId +++               "\" in section \"" ++ sectionName ++ "\"")+    return Nothing+  where+    -- align the getter on n bytes+    align n = do+      m <- bytesRead+      if m `mod` n == 0+        then return ()+        else skip 1 >> align n++    -- noteId as a bytestring+    noteId' = B8.pack noteId++    -- read notes recursively until the one with a valid identifier is found+    findNote hdr = do+      align 4+      namesz <- gw32 hdr+      descsz <- gw32 hdr+      _      <- gw32 hdr -- we don't use the note type+      name   <- if namesz == 0+                  then return LBS.empty+                  else getLazyByteStringNul+      align 4+      desc  <- if descsz == 0+                  then return LBS.empty+                  else getLazyByteString (fromIntegral descsz)+      if name == noteId'+        then return $ Just desc+        else findNote hdr+++    action = runMaybeT $ do+      hdr  <- MaybeT $ readElfHeader dflags bs+      sec  <- MaybeT $ readElfSectionByName dflags bs sectionName+      MaybeT $ runGetOrThrow (findNote hdr) sec++-- | read a Note as a String+--+-- If you try to read a note from a section which does not support the Note+-- format, the parsing is likely to fail and Nothing will be returned+readElfNoteAsString :: DynFlags+                    -> FilePath+                    -> String+                    -> String+                    -> IO (Maybe String)++readElfNoteAsString dflags path sectionName noteId = action `catchIO`  \_ -> do+    debugTraceMsg dflags 3 $+         text ("Unable to read ELF note \"" ++ noteId +++               "\" in section \"" ++ sectionName ++ "\"")+    return Nothing+  where+    action = do+      bs   <- LBS.readFile path+      note <- readElfNoteBS dflags bs sectionName noteId+      return (fmap B8.unpack note)+++-- | Generate the GAS code to create a Note section+--+-- Header fields for notes are 32-bit long (see Note [ELF specification]).+--+-- It seems there is no easy way to force GNU AS to generate a 32-bit word in+-- every case. Hence we use .int directive to create them: however "The byte+-- order and bit size of the number depends on what kind of target the assembly+-- is for." (https://sourceware.org/binutils/docs/as/Int.html#Int)+--+-- If we add new target platforms, we need to check that the generated words+-- are 32-bit long, otherwise we need to use platform specific directives to+-- force 32-bit .int in asWord32.+makeElfNote :: String -> String -> Word32 -> String -> SDoc+makeElfNote sectionName noteName typ contents = hcat [+    text "\t.section ",+    text sectionName,+    text ",\"\",",+    sectionType "note",+    text "\n",++    -- note name length (+ 1 for ending \0)+    asWord32 (length noteName + 1),++    -- note contents size+    asWord32 (length contents),++    -- note type+    asWord32 typ,++    -- note name (.asciz for \0 ending string) + padding+    text "\t.asciz \"",+    text noteName,+    text "\"\n",+    text "\t.align 4\n",++    -- note contents (.ascii to avoid ending \0) + padding+    text "\t.ascii \"",+    text (escape contents),+    text "\"\n",+    text "\t.align 4\n"]+  where+    escape :: String -> String+    escape = concatMap (charToC.fromIntegral.ord)++    asWord32 :: Show a => a -> SDoc+    asWord32 x = hcat [+      text "\t.int ",+      text (show x),+      text "\n"]+++------------------+-- Helpers+------------------++-- | runGet in IO monad that throws an IOException on failure+runGetOrThrow :: Get a -> LBS.ByteString -> IO a+runGetOrThrow g bs = case runGetOrFail g bs of+  Left _        -> fail "Error while reading file"+  Right (_,_,a) -> return a
+ compiler/main/Finder.hs view
@@ -0,0 +1,844 @@+{-+(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 = fst (splitUnitIdInsts (thisPackage dflags))+  in InstalledModule iuid mod_name++-- This returns a module because it's more convenient for users+addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module+addHomeModuleToFinder hsc_env mod_name loc = do+  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name+  addToFinderCache (hsc_FC hsc_env) mod (InstalledFound loc mod)+  return (mkModule (thisPackage (hsc_dflags hsc_env)) mod_name)++uncacheModule :: HscEnv -> ModuleName -> IO ()+uncacheModule hsc_env mod_name = do+  let mod = mkHomeInstalledModule (hsc_dflags hsc_env) mod_name+  removeFromFinderCache (hsc_FC hsc_env) mod++-- -----------------------------------------------------------------------------+--      The internal workers++findHomeModule :: HscEnv -> ModuleName -> IO FindResult+findHomeModule hsc_env mod_name = do+  r <- findInstalledHomeModule hsc_env mod_name+  return $ case r of+    InstalledFound loc _ -> Found loc (mkModule uid mod_name)+    InstalledNoPackage _ -> NoPackage uid -- impossible+    InstalledNotFound fps _ -> NotFound {+        fr_paths = fps,+        fr_pkg = Just uid,+        fr_mods_hidden = [],+        fr_pkgs_hidden = [],+        fr_unusables = [],+        fr_suggestions = []+      }+ where+  dflags = hsc_dflags hsc_env+  uid = thisPackage dflags++-- | Implements the search for a module name in the home package only.  Calling+-- this function directly is usually *not* what you want; currently, it's used+-- as a building block for the following operations:+--+--  1. When you do a normal package lookup, we first check if the module+--  is available in the home module, before looking it up in the package+--  database.+--+--  2. When you have a package qualified import with package name "this",+--  we shortcut to the home module.+--+--  3. When we look up an exact 'Module', if the unit id associated with+--  the module is the current home module do a look up in the home module.+--+--  4. Some special-case code in GHCi (ToDo: Figure out why that needs to+--  call this.)+findInstalledHomeModule :: HscEnv -> ModuleName -> IO InstalledFindResult+findInstalledHomeModule hsc_env mod_name =+   homeSearchCache hsc_env mod_name $+   let+     dflags = hsc_dflags hsc_env+     home_path = importPaths dflags+     hisuf = hiSuf dflags+     mod = mkHomeInstalledModule dflags mod_name++     source_exts =+      [ ("hs",   mkHomeModLocationSearched dflags mod_name "hs")+      , ("lhs",  mkHomeModLocationSearched dflags mod_name "lhs")+      , ("hsig",  mkHomeModLocationSearched dflags mod_name "hsig")+      , ("lhsig",  mkHomeModLocationSearched dflags mod_name "lhsig")+      ]++     -- we use mkHomeModHiOnlyLocation instead of mkHiOnlyModLocation so that+     -- when hiDir field is set in dflags, we know to look there (see #16500)+     hi_exts = [ (hisuf,                mkHomeModHiOnlyLocation dflags mod_name)+               , (addBootSuffix hisuf,  mkHomeModHiOnlyLocation dflags mod_name)+               ]++        -- In compilation manager modes, we look for source files in the home+        -- package because we can compile these automatically.  In one-shot+        -- compilation mode we look for .hi and .hi-boot files only.+     exts | isOneShot (ghcMode dflags) = hi_exts+          | otherwise                  = source_exts+   in++  -- special case for GHC.Prim; we won't find it in the filesystem.+  -- This is important only when compiling the base package (where GHC.Prim+  -- is a home module).+  if mod `installedModuleEq` gHC_PRIM+        then return (InstalledFound (error "GHC.Prim ModLocation") mod)+        else searchPathExts home_path mod exts+++-- | Search for a module in external packages only.+findPackageModule :: HscEnv -> InstalledModule -> IO InstalledFindResult+findPackageModule hsc_env mod = do+  let+        dflags = hsc_dflags hsc_env+        pkg_id = installedModuleUnitId mod+  --+  case lookupInstalledPackage dflags pkg_id of+     Nothing -> return (InstalledNoPackage pkg_id)+     Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf++-- | Look up the interface file associated with module @mod@.  This function+-- requires a few invariants to be upheld: (1) the 'Module' in question must+-- be the module identifier of the *original* implementation of a module,+-- not a reexport (this invariant is upheld by @Packages.hs@) and (2)+-- the 'PackageConfig' must be consistent with the unit id in the 'Module'.+-- The redundancy is to avoid an extra lookup in the package state+-- for the appropriate config.+findPackageModule_ :: HscEnv -> InstalledModule -> PackageConfig -> IO InstalledFindResult+findPackageModule_ hsc_env mod pkg_conf =+  ASSERT2( installedModuleUnitId mod == installedPackageConfigId pkg_conf, ppr (installedModuleUnitId mod) <+> ppr (installedPackageConfigId pkg_conf) )+  modLocationCache hsc_env mod $++  -- special case for GHC.Prim; we won't find it in the filesystem.+  if mod `installedModuleEq` gHC_PRIM+        then return (InstalledFound (error "GHC.Prim ModLocation") mod)+        else++  let+     dflags = hsc_dflags hsc_env+     tag = buildTag dflags++           -- hi-suffix for packages depends on the build tag.+     package_hisuf | null tag  = "hi"+                   | otherwise = tag ++ "_hi"++     mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf++     import_dirs = importDirs pkg_conf+      -- we never look for a .hi-boot file in an external package;+      -- .hi-boot files only make sense for the home package.+  in+  case import_dirs of+    [one] | MkDepend <- ghcMode dflags -> do+          -- there's only one place that this .hi file can be, so+          -- don't bother looking for it.+          let basename = moduleNameSlashes (installedModuleName mod)+          loc <- mk_hi_loc one basename+          return (InstalledFound loc mod)+    _otherwise ->+          searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)]++-- -----------------------------------------------------------------------------+-- General path searching++searchPathExts+  :: [FilePath]         -- paths to search+  -> InstalledModule             -- module name+  -> [ (+        FileExt,                                -- suffix+        FilePath -> BaseName -> IO ModLocation  -- action+       )+     ]+  -> IO InstalledFindResult++searchPathExts paths mod exts+   = do result <- search to_search+{-+        hPutStrLn stderr (showSDoc $+                vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts)+                    , nest 2 (vcat (map text paths))+                    , case result of+                        Succeeded (loc, p) -> text "Found" <+> ppr loc+                        Failed fs          -> text "not found"])+-}+        return result++  where+    basename = moduleNameSlashes (installedModuleName mod)++    to_search :: [(FilePath, IO ModLocation)]+    to_search = [ (file, fn path basename)+                | path <- paths,+                  (ext,fn) <- exts,+                  let base | path == "." = basename+                           | otherwise   = path </> basename+                      file = base <.> ext+                ]++    search [] = return (InstalledNotFound (map fst to_search) (Just (installedModuleUnitId mod)))++    search ((file, mk_result) : rest) = do+      b <- doesFileExist file+      if b+        then do { loc <- mk_result; return (InstalledFound loc mod) }+        else search rest++mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt+                          -> FilePath -> BaseName -> IO ModLocation+mkHomeModLocationSearched dflags mod suff path basename = do+   mkHomeModLocation2 dflags mod (path </> basename) suff++-- -----------------------------------------------------------------------------+-- Constructing a home module location++-- This is where we construct the ModLocation for a module in the home+-- package, for which we have a source file.  It is called from three+-- places:+--+--  (a) Here in the finder, when we are searching for a module to import,+--      using the search path (-i option).+--+--  (b) The compilation manager, when constructing the ModLocation for+--      a "root" module (a source file named explicitly on the command line+--      or in a :load command in GHCi).+--+--  (c) The driver in one-shot mode, when we need to construct a+--      ModLocation for a source file named on the command-line.+--+-- Parameters are:+--+-- mod+--      The name of the module+--+-- path+--      (a): The search path component where the source file was found.+--      (b) and (c): "."+--+-- src_basename+--      (a): (moduleNameSlashes mod)+--      (b) and (c): The filename of the source file, minus its extension+--+-- ext+--      The filename extension of the source file (usually "hs" or "lhs").++mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation+mkHomeModLocation dflags mod src_filename = do+   let (basename,extension) = splitExtension src_filename+   mkHomeModLocation2 dflags mod basename extension++mkHomeModLocation2 :: DynFlags+                   -> ModuleName+                   -> FilePath  -- Of source module, without suffix+                   -> String    -- Suffix+                   -> IO ModLocation+mkHomeModLocation2 dflags mod src_basename ext = do+   let mod_basename = moduleNameSlashes mod++       obj_fn = mkObjPath  dflags src_basename mod_basename+       hi_fn  = mkHiPath   dflags src_basename mod_basename+       hie_fn = mkHiePath  dflags src_basename mod_basename++   return (ModLocation{ ml_hs_file   = Just (src_basename <.> ext),+                        ml_hi_file   = hi_fn,+                        ml_obj_file  = obj_fn,+                        ml_hie_file  = hie_fn })++mkHomeModHiOnlyLocation :: DynFlags+                        -> ModuleName+                        -> FilePath+                        -> BaseName+                        -> IO ModLocation+mkHomeModHiOnlyLocation dflags mod path basename = do+   loc <- mkHomeModLocation2 dflags mod (path </> basename) ""+   return loc { ml_hs_file = Nothing }++mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String+                    -> IO ModLocation+mkHiOnlyModLocation dflags hisuf path basename+ = do let full_basename = path </> basename+          obj_fn = mkObjPath  dflags full_basename basename+          hie_fn = mkHiePath  dflags full_basename basename+      return ModLocation{    ml_hs_file   = Nothing,+                             ml_hi_file   = full_basename <.> hisuf,+                                -- Remove the .hi-boot suffix from+                                -- hi_file, if it had one.  We always+                                -- want the name of the real .hi file+                                -- in the ml_hi_file field.+                             ml_obj_file  = obj_fn,+                             ml_hie_file  = hie_fn+                  }++-- | Constructs the filename of a .o file for a given source file.+-- Does /not/ check whether the .o file exists+mkObjPath+  :: DynFlags+  -> FilePath           -- the filename of the source file, minus the extension+  -> String             -- the module name with dots replaced by slashes+  -> FilePath+mkObjPath dflags basename mod_basename = obj_basename <.> osuf+  where+                odir = objectDir dflags+                osuf = objectSuf dflags++                obj_basename | Just dir <- odir = dir </> mod_basename+                             | otherwise        = basename+++-- | Constructs the filename of a .hi file for a given source file.+-- Does /not/ check whether the .hi file exists+mkHiPath+  :: DynFlags+  -> FilePath           -- the filename of the source file, minus the extension+  -> String             -- the module name with dots replaced by slashes+  -> FilePath+mkHiPath dflags basename mod_basename = hi_basename <.> hisuf+ where+                hidir = hiDir dflags+                hisuf = hiSuf dflags++                hi_basename | Just dir <- hidir = dir </> mod_basename+                            | otherwise         = basename++-- | Constructs the filename of a .hie file for a given source file.+-- Does /not/ check whether the .hie file exists+mkHiePath+  :: DynFlags+  -> FilePath           -- the filename of the source file, minus the extension+  -> String             -- the module name with dots replaced by slashes+  -> FilePath+mkHiePath dflags basename mod_basename = hie_basename <.> hiesuf+ where+                hiedir = hieDir dflags+                hiesuf = hieSuf dflags++                hie_basename | Just dir <- hiedir = dir </> mod_basename+                             | otherwise          = basename++++-- -----------------------------------------------------------------------------+-- Filenames of the stub files++-- We don't have to store these in ModLocations, because they can be derived+-- from other available information, and they're only rarely needed.++mkStubPaths+  :: DynFlags+  -> ModuleName+  -> ModLocation+  -> FilePath++mkStubPaths dflags mod location+  = let+        stubdir = stubDir dflags++        mod_basename = moduleNameSlashes mod+        src_basename = dropExtension $ expectJust "mkStubPaths"+                                                  (ml_hs_file location)++        stub_basename0+            | Just dir <- stubdir = dir </> mod_basename+            | otherwise           = src_basename++        stub_basename = stub_basename0 ++ "_stub"+     in+        stub_basename <.> "h"++-- -----------------------------------------------------------------------------+-- findLinkable isn't related to the other stuff in here,+-- but there's no other obvious place for it++findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable)+findObjectLinkableMaybe mod locn+   = do let obj_fn = ml_obj_file locn+        maybe_obj_time <- modificationTimeIfExists obj_fn+        case maybe_obj_time of+          Nothing -> return Nothing+          Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time)++-- Make an object linkable when we know the object file exists, and we know+-- its modification time.+findObjectLinkable :: Module -> FilePath -> UTCTime -> IO Linkable+findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])+  -- We used to look for _stub.o files here, but that was a bug (#706)+  -- Now GHC merges the stub.o into the main .o (#3687)++-- -----------------------------------------------------------------------------+-- Error messages++cannotFindModule :: DynFlags -> ModuleName -> FindResult -> SDoc+cannotFindModule flags mod res =+  cantFindErr (sLit cannotFindMsg)+              (sLit "Ambiguous module name")+              flags mod res+  where+    cannotFindMsg =+      case res of+        NotFound { fr_mods_hidden = hidden_mods+                 , fr_pkgs_hidden = hidden_pkgs+                 , fr_unusables = unusables }+          | not (null hidden_mods && null hidden_pkgs && null unusables)+          -> "Could not load module"+        _ -> "Could not find module"++cannotFindInterface  :: DynFlags -> ModuleName -> InstalledFindResult -> SDoc+cannotFindInterface = cantFindInstalledErr (sLit "Failed to load interface for")+                                           (sLit "Ambiguous interface for")++cantFindErr :: PtrString -> PtrString -> DynFlags -> ModuleName -> FindResult+            -> SDoc+cantFindErr _ multiple_found _ mod_name (FoundMultiple mods)+  | Just pkgs <- unambiguousPackages+  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (+       sep [text "it was found in multiple packages:",+                hsep (map ppr pkgs) ]+    )+  | otherwise+  = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 (+       vcat (map pprMod mods)+    )+  where+    unambiguousPackages = foldl' unambiguousPackage (Just []) mods+    unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _)+        = Just (moduleUnitId m : xs)+    unambiguousPackage _ _ = Nothing++    pprMod (m, o) = text "it is bound as" <+> ppr m <+>+                                text "by" <+> pprOrigin m o+    pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden"+    pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable"+    pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma (+      if e == Just True+          then [text "package" <+> ppr (moduleUnitId m)]+          else [] +++      map ((text "a reexport in package" <+>)+                .ppr.packageConfigId) res +++      if f then [text "a package flag"] else []+      )++cantFindErr cannot_find _ dflags mod_name find_result+  = ptext cannot_find <+> quotes (ppr mod_name)+    $$ more_info+  where+    more_info+      = case find_result of+            NoPackage pkg+                -> text "no unit id matching" <+> quotes (ppr pkg) <+>+                   text "was found"++            NotFound { fr_paths = files, fr_pkg = mb_pkg+                     , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens+                     , fr_unusables = unusables, fr_suggestions = suggest }+                | Just pkg <- mb_pkg, pkg /= thisPackage dflags+                -> not_found_in_package pkg files++                | not (null suggest)+                -> pp_suggestions suggest $$ tried_these files dflags++                | null files && null mod_hiddens &&+                  null pkg_hiddens && null unusables+                -> text "It is not a module in the current program, or in any known package."++                | otherwise+                -> vcat (map pkg_hidden pkg_hiddens) $$+                   vcat (map mod_hidden mod_hiddens) $$+                   vcat (map unusable unusables) $$+                   tried_these files dflags++            _ -> panic "cantFindErr"++    build_tag = buildTag dflags++    not_found_in_package pkg files+       | build_tag /= ""+       = let+            build = if build_tag == "p" then "profiling"+                                        else "\"" ++ build_tag ++ "\""+         in+         text "Perhaps you haven't installed the " <> text build <>+         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$+         tried_these files dflags++       | otherwise+       = text "There are files missing in the " <> quotes (ppr pkg) <>+         text " package," $$+         text "try running 'ghc-pkg check'." $$+         tried_these files dflags++    pkg_hidden :: UnitId -> SDoc+    pkg_hidden pkgid =+        text "It is a member of the hidden package"+        <+> quotes (ppr pkgid)+        --FIXME: we don't really want to show the unit id here we should+        -- show the source package id or installed package id if it's ambiguous+        <> dot $$ pkg_hidden_hint pkgid+    pkg_hidden_hint pkgid+     | gopt Opt_BuildingCabalPackage dflags+        = let pkg = expectJust "pkg_hidden" (lookupPackage dflags pkgid)+           in text "Perhaps you need to add" <+>+              quotes (ppr (packageName pkg)) <+>+              text "to the build-depends in your .cabal file."+     | Just pkg <- lookupPackage dflags pkgid+         = text "You can run" <+>+           quotes (text ":set -package " <> ppr (packageName pkg)) <+>+           text "to expose it." $$+           text "(Note: this unloads all the modules in the current scope.)"+     | otherwise = Outputable.empty++    mod_hidden pkg =+        text "it is a hidden module in the package" <+> quotes (ppr pkg)++    unusable (pkg, reason)+      = text "It is a member of the package"+      <+> quotes (ppr pkg)+      $$ pprReason (text "which is") reason++    pp_suggestions :: [ModuleSuggestion] -> SDoc+    pp_suggestions sugs+      | null sugs = Outputable.empty+      | otherwise = hang (text "Perhaps you meant")+                       2 (vcat (map pp_sugg sugs))++    -- NB: Prefer the *original* location, and then reexports, and then+    -- package flags when making suggestions.  ToDo: if the original package+    -- also has a reexport, prefer that one+    pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o+      where provenance ModHidden = Outputable.empty+            provenance (ModUnusable _) = Outputable.empty+            provenance (ModOrigin{ fromOrigPackage = e,+                                   fromExposedReexport = res,+                                   fromPackageFlag = f })+              | Just True <- e+                 = parens (text "from" <+> ppr (moduleUnitId mod))+              | f && moduleName mod == m+                 = parens (text "from" <+> ppr (moduleUnitId mod))+              | (pkg:_) <- res+                 = parens (text "from" <+> ppr (packageConfigId pkg)+                    <> comma <+> text "reexporting" <+> ppr mod)+              | f+                 = parens (text "defined via package flags to be"+                    <+> ppr mod)+              | otherwise = Outputable.empty+    pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o+      where provenance ModHidden =  Outputable.empty+            provenance (ModUnusable _) = Outputable.empty+            provenance (ModOrigin{ fromOrigPackage = e,+                                   fromHiddenReexport = rhs })+              | Just False <- e+                 = parens (text "needs flag -package-key"+                    <+> ppr (moduleUnitId mod))+              | (pkg:_) <- rhs+                 = parens (text "needs flag -package-id"+                    <+> ppr (packageConfigId pkg))+              | otherwise = Outputable.empty++cantFindInstalledErr :: PtrString -> PtrString -> DynFlags -> ModuleName+                     -> InstalledFindResult -> SDoc+cantFindInstalledErr cannot_find _ dflags mod_name find_result+  = ptext cannot_find <+> quotes (ppr mod_name)+    $$ more_info+  where+    more_info+      = case find_result of+            InstalledNoPackage pkg+                -> text "no unit id matching" <+> quotes (ppr pkg) <+>+                   text "was found" $$ looks_like_srcpkgid pkg++            InstalledNotFound files mb_pkg+                | Just pkg <- mb_pkg, not (pkg `installedUnitIdEq` thisPackage dflags)+                -> not_found_in_package pkg files++                | null files+                -> text "It is not a module in the current program, or in any known package."++                | otherwise+                -> tried_these files dflags++            _ -> panic "cantFindInstalledErr"++    build_tag = buildTag dflags++    looks_like_srcpkgid :: InstalledUnitId -> SDoc+    looks_like_srcpkgid pk+     -- Unsafely coerce a unit id FastString into a source package ID+     -- FastString and see if it means anything.+     | (pkg:pkgs) <- searchPackageId dflags (SourcePackageId (installedUnitIdFS pk))+     = parens (text "This unit ID looks like the source package ID;" $$+       text "the real unit ID is" <+> quotes (ftext (installedUnitIdFS (unitId pkg))) $$+       (if null pkgs then Outputable.empty+        else text "and" <+> int (length pkgs) <+> text "other candidates"))+     -- Todo: also check if it looks like a package name!+     | otherwise = Outputable.empty++    not_found_in_package pkg files+       | build_tag /= ""+       = let+            build = if build_tag == "p" then "profiling"+                                        else "\"" ++ build_tag ++ "\""+         in+         text "Perhaps you haven't installed the " <> text build <>+         text " libraries for package " <> quotes (ppr pkg) <> char '?' $$+         tried_these files dflags++       | otherwise+       = text "There are files missing in the " <> quotes (ppr pkg) <>+         text " package," $$+         text "try running 'ghc-pkg check'." $$+         tried_these files dflags++tried_these :: [FilePath] -> DynFlags -> SDoc+tried_these files dflags+    | null files = Outputable.empty+    | verbosity dflags < 3 =+          text "Use -v (or `:set -v` in ghci) " <>+              text "to see a list of the files searched for."+    | otherwise =+          hang (text "Locations searched:") 2 $ vcat (map text files)
+ compiler/main/GHC.hs view
@@ -0,0 +1,1560 @@+{-# LANGUAGE CPP, NondecreasingIndentation, ScopedTypeVariables #-}+{-# LANGUAGE TupleSections, NamedFieldPuns #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2005-2012+--+-- The GHC API+--+-- -----------------------------------------------------------------------------++module GHC (+        -- * Initialisation+        defaultErrorHandler,+        defaultCleanupHandler,+        prettyPrintGhcErrors,+        withSignalHandlers,+        withCleanupSession,++        -- * GHC Monad+        Ghc, GhcT, GhcMonad(..), HscEnv,+        runGhc, runGhcT, initGhcMonad,+        gcatch, gbracket, gfinally,+        printException,+        handleSourceError,+        needsTemplateHaskellOrQQ,++        -- * Flags and settings+        DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt,+        GhcMode(..), GhcLink(..), defaultObjectTarget,+        parseDynamicFlags,+        getSessionDynFlags, setSessionDynFlags,+        getProgramDynFlags, setProgramDynFlags, setLogAction,+        getInteractiveDynFlags, setInteractiveDynFlags,++        -- * Targets+        Target(..), TargetId(..), Phase,+        setTargets,+        getTargets,+        addTarget,+        removeTarget,+        guessTarget,++        -- * Loading\/compiling the program+        depanal,+        load, LoadHowMuch(..), InteractiveImport(..),+        SuccessFlag(..), succeeded, failed,+        defaultWarnErrLogger, WarnErrLogger,+        workingDirectoryChanged,+        parseModule, typecheckModule, desugarModule, loadModule,+        ParsedModule(..), TypecheckedModule(..), DesugaredModule(..),+        TypecheckedSource, ParsedSource, RenamedSource,   -- ditto+        TypecheckedMod, ParsedMod,+        moduleInfo, renamedSource, typecheckedSource,+        parsedSource, coreModule,++        -- ** Compiling to Core+        CoreModule(..),+        compileToCoreModule, compileToCoreSimplified,++        -- * Inspecting the module structure of the program+        ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,+        mgLookupModule,+        ModSummary(..), ms_mod_name, ModLocation(..),+        getModSummary,+        getModuleGraph,+        isLoaded,+        topSortModuleGraph,++        -- * Inspecting modules+        ModuleInfo,+        getModuleInfo,+        modInfoTyThings,+        modInfoTopLevelScope,+        modInfoExports,+        modInfoExportsWithSelectors,+        modInfoInstances,+        modInfoIsExportedName,+        modInfoLookupName,+        modInfoIface,+        modInfoSafe,+        lookupGlobalName,+        findGlobalAnns,+        mkPrintUnqualifiedForModule,+        ModIface(..),+        SafeHaskellMode(..),++        -- * Querying the environment+        -- packageDbModules,++        -- * Printing+        PrintUnqualified, alwaysQualify,++        -- * Interactive evaluation++        -- ** Executing statements+        execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..),+        resumeExec,++        -- ** Adding new declarations+        runDecls, runDeclsWithLocation, runParsedDecls,++        -- ** Get/set the current context+        parseImportDecl,+        setContext, getContext,+        setGHCiMonad, getGHCiMonad,++        -- ** Inspecting the current context+        getBindings, getInsts, getPrintUnqual,+        findModule, lookupModule,+        isModuleTrusted, moduleTrustReqs,+        getNamesInScope,+        getRdrNamesInScope,+        getGRE,+        moduleIsInterpreted,+        getInfo,+        showModule,+        moduleIsBootOrNotObjectLinkable,+        getNameToInstancesIndex,++        -- ** Inspecting types and kinds+        exprType, TcRnExprMode(..),+        typeKind,++        -- ** Looking up a Name+        parseName,+        lookupName,++        -- ** Compiling expressions+        HValue, parseExpr, compileParsedExpr,+        InteractiveEval.compileExpr, dynCompileExpr,+        ForeignHValue,+        compileExprRemote, compileParsedExprRemote,++        -- ** Docs+        getDocs, GetDocsFailure(..),++        -- ** Other+        runTcInteractive,   -- Desired by some clients (#8878)+        isStmt, hasImport, isImport, isDecl,++        -- ** The debugger+        SingleStep(..),+        Resume(..),+        History(historyBreakInfo, historyEnclosingDecls),+        GHC.getHistorySpan, getHistoryModule,+        abandon, abandonAll,+        getResumeContext,+        GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,+        modInfoModBreaks,+        ModBreaks(..), BreakIndex,+        BreakInfo(breakInfo_number, breakInfo_module),+        InteractiveEval.back,+        InteractiveEval.forward,++        -- * Abstract syntax elements++        -- ** Packages+        UnitId,++        -- ** Modules+        Module, mkModule, pprModule, moduleName, moduleUnitId,+        ModuleName, mkModuleName, moduleNameString,++        -- ** Names+        Name,+        isExternalName, nameModule, pprParenSymName, nameSrcSpan,+        NamedThing(..),+        RdrName(Qual,Unqual),++        -- ** Identifiers+        Id, idType,+        isImplicitId, isDeadBinder,+        isExportedId, isLocalId, isGlobalId,+        isRecordSelector,+        isPrimOpId, isFCallId, isClassOpId_maybe,+        isDataConWorkId, idDataCon,+        isBottomingId, isDictonaryId,+        recordSelectorTyCon,++        -- ** Type constructors+        TyCon,+        tyConTyVars, tyConDataCons, tyConArity,+        isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon,+        isPrimTyCon, isFunTyCon,+        isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon,+        tyConClass_maybe,+        synTyConRhs_maybe, synTyConDefn_maybe, tyConKind,++        -- ** Type variables+        TyVar,+        alphaTyVars,++        -- ** Data constructors+        DataCon,+        dataConSig, dataConType, dataConTyCon, dataConFieldLabels,+        dataConIsInfix, isVanillaDataCon, dataConUserType,+        dataConSrcBangs,+        StrictnessMark(..), isMarkedStrict,++        -- ** Classes+        Class,+        classMethods, classSCTheta, classTvsFds, classATs,+        pprFundeps,++        -- ** Instances+        ClsInst,+        instanceDFunId,+        pprInstance, pprInstanceHdr,+        pprFamInst,++        FamInst,++        -- ** Types and Kinds+        Type, splitForAllTys, funResultTy,+        pprParendType, pprTypeApp,+        Kind,+        PredType,+        ThetaType, pprForAll, pprThetaArrowTy,++        -- ** Entities+        TyThing(..),++        -- ** Syntax+        module HsSyn, -- ToDo: remove extraneous bits++        -- ** Fixities+        FixityDirection(..),+        defaultFixity, maxPrecedence,+        negateFixity,+        compareFixity,+        LexicalFixity(..),++        -- ** Source locations+        SrcLoc(..), RealSrcLoc,+        mkSrcLoc, noSrcLoc,+        srcLocFile, srcLocLine, srcLocCol,+        SrcSpan(..), RealSrcSpan,+        mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan,+        srcSpanStart, srcSpanEnd,+        srcSpanFile,+        srcSpanStartLine, srcSpanEndLine,+        srcSpanStartCol, srcSpanEndCol,++        -- ** Located+        GenLocated(..), Located,++        -- *** Constructing Located+        noLoc, mkGeneralLocated,++        -- *** Deconstructing Located+        getLoc, unLoc,+        getRealSrcSpan, unRealSrcSpan,++        -- ** HasSrcSpan+        HasSrcSpan(..), SrcSpanLess, dL, cL,++        -- *** Combining and comparing Located values+        eqLocated, cmpLocated, combineLocs, addCLoc,+        leftmost_smallest, leftmost_largest, rightmost,+        spans, isSubspanOf,++        -- * Exceptions+        GhcException(..), showGhcException,++        -- * Token stream manipulations+        Token,+        getTokenStream, getRichTokenStream,+        showRichTokenStream, addSourceToTokens,++        -- * Pure interface to the parser+        parser,++        -- * API Annotations+        ApiAnns,AnnKeywordId(..),AnnotationComment(..),+        getAnnotation, getAndRemoveAnnotation,+        getAnnotationComments, getAndRemoveAnnotationComments,+        unicodeAnn,++        -- * Miscellaneous+        --sessionHscEnv,+        cyclicModuleErr,+  ) where++{-+ ToDo:++  * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.+-}++#include "HsVersions.h"++import GhcPrelude hiding (init)++import ByteCodeTypes+import InteractiveEval+import InteractiveEvalTypes+import GHCi+import GHCi.RemoteTypes++import PprTyThing       ( pprFamInst )+import HscMain+import GhcMake+import DriverPipeline   ( compileOne' )+import GhcMonad+import TcRnMonad        ( finalSafeMode, fixSafeInstances, initIfaceTcRn )+import LoadIface        ( loadSysInterface )+import TcRnTypes+import Packages+import NameSet+import RdrName+import HsSyn+import Type     hiding( typeKind )+import TcType+import Id+import TysPrim          ( alphaTyVars )+import TyCon+import Class+import DataCon+import Name             hiding ( varName )+import Avail+import InstEnv+import FamInstEnv ( FamInst )+import SrcLoc+import CoreSyn+import TidyPgm+import DriverPhases     ( Phase(..), isHaskellSrcFilename )+import Finder+import HscTypes+import CmdLineParser+import DynFlags hiding (WarnReason(..))+import SysTools+import SysTools.BaseDir+import Annotations+import Module+import Panic+import Platform+import Bag              ( listToBag )+import ErrUtils+import MonadUtils+import Util+import StringBuffer+import Outputable+import BasicTypes+import Maybes           ( expectJust )+import FastString+import qualified Parser+import Lexer+import ApiAnnotation+import qualified GHC.LanguageExtensions as LangExt+import NameEnv+import CoreFVs          ( orphNamesOfFamInst )+import FamInstEnv       ( famInstEnvElts )+import TcRnDriver+import Inst+import FamInst+import FileCleanup++import Data.Foldable+import qualified Data.Map.Strict as Map+import Data.Set (Set)+import qualified Data.Sequence as Seq+import System.Directory ( doesFileExist )+import Data.Maybe+import Data.Time+import Data.Typeable    ( Typeable )+import Data.Word        ( Word8 )+import Control.Monad+import System.Exit      ( exitWith, ExitCode(..) )+import Exception+import Data.IORef+import System.FilePath+++-- %************************************************************************+-- %*                                                                      *+--             Initialisation: exception handlers+-- %*                                                                      *+-- %************************************************************************+++-- | Install some default exception handlers and run the inner computation.+-- Unless you want to handle exceptions yourself, you should wrap this around+-- the top level of your program.  The default handlers output the error+-- message(s) to stderr and exit cleanly.+defaultErrorHandler :: (ExceptionMonad m)+                    => FatalMessager -> FlushOut -> m a -> m a+defaultErrorHandler fm (FlushOut flushOut) inner =+  -- top-level exception handler: any unrecognised exception is a compiler bug.+  ghandle (\exception -> liftIO $ do+           flushOut+           case fromException exception of+                -- an IO exception probably isn't our fault, so don't panic+                Just (ioe :: IOException) ->+                  fatalErrorMsg'' fm (show ioe)+                _ -> case fromException exception of+                     Just UserInterrupt ->+                         -- Important to let this one propagate out so our+                         -- calling process knows we were interrupted by ^C+                         liftIO $ throwIO UserInterrupt+                     Just StackOverflow ->+                         fatalErrorMsg'' fm "stack overflow: use +RTS -K<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 <- initLlvmConfig top_dir+                   ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig)+                   ; checkBrokenTablesNextToCode dflags+                   ; setUnsafeGlobalDynFlags dflags+                      -- c.f. DynFlags.parseDynamicFlagsFull, which+                      -- creates DynFlags and sets the UnsafeGlobalDynFlags+                   ; newHscEnv dflags }+       ; setSession env }++-- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which+-- breaks tables-next-to-code in dynamically linked modules. This+-- check should be more selective but there is currently no released+-- version where this bug is fixed.+-- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and+-- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333+checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m ()+checkBrokenTablesNextToCode dflags+  = do { broken <- checkBrokenTablesNextToCode' dflags+       ; when broken+         $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr+              ; liftIO $ fail "unsupported linker"+              }+       }+  where+    invalidLdErr = text "Tables-next-to-code not supported on ARM" <+>+                   text "when using binutils ld (please see:" <+>+                   text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"++checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool+checkBrokenTablesNextToCode' dflags+  | not (isARM arch)              = return False+  | WayDyn `notElem` ways dflags  = return False+  | not (tablesNextToCode dflags) = return False+  | otherwise                     = do+    linkerInfo <- liftIO $ getLinkerInfo dflags+    case linkerInfo of+      GnuLD _  -> return True+      _        -> return False+  where platform = targetPlatform dflags+        arch = platformArch platform+++-- %************************************************************************+-- %*                                                                      *+--             Flags & settings+-- %*                                                                      *+-- %************************************************************************++-- $DynFlags+--+-- The GHC session maintains two sets of 'DynFlags':+--+--   * The "interactive" @DynFlags@, which are used for everything+--     related to interactive evaluation, including 'runStmt',+--     'runDecls', 'exprType', 'lookupName' and so on (everything+--     under \"Interactive evaluation\" in this module).+--+--   * The "program" @DynFlags@, which are used when loading+--     whole modules with 'load'+--+-- 'setInteractiveDynFlags', 'getInteractiveDynFlags' work with the+-- interactive @DynFlags@.+--+-- 'setProgramDynFlags', 'getProgramDynFlags' work with the+-- program @DynFlags@.+--+-- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags'+-- retrieves the program @DynFlags@ (for backwards compatibility).+++-- | Updates both the interactive and program DynFlags in a Session.+-- This also reads the package database (unless it has already been+-- read), and prepares the compilers knowledge about packages.  It can+-- be called again to load new packages: just add new package flags to+-- (packageFlags dflags).+--+-- Returns a list of new packages that may need to be linked in using+-- the dynamic linker (see 'linkPackages') as a result of new package+-- flags.  If you are not doing linking or doing static linking, you+-- can ignore the list of packages returned.+--+setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]+setSessionDynFlags dflags = do+  dflags' <- checkNewDynFlags dflags+  (dflags'', preload) <- liftIO $ initPackages dflags'+  modifySession $ \h -> h{ hsc_dflags = dflags''+                         , hsc_IC = (hsc_IC h){ ic_dflags = dflags'' } }+  invalidateModSummaryCache+  return preload++-- | Sets the program 'DynFlags'.  Note: this invalidates the internal+-- cached module graph, causing more work to be done the next time+-- 'load' is called.+setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]+setProgramDynFlags dflags = setProgramDynFlags_ True dflags++-- | Set the action taken when the compiler produces a message.  This+-- can also be accomplished using 'setProgramDynFlags', but using+-- 'setLogAction' avoids invalidating the cached module graph.+setLogAction :: GhcMonad m => LogAction -> m ()+setLogAction action = do+  dflags' <- getProgramDynFlags+  void $ setProgramDynFlags_ False $+    dflags' { log_action = action }++setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId]+setProgramDynFlags_ invalidate_needed dflags = do+  dflags' <- checkNewDynFlags dflags+  dflags_prev <- getProgramDynFlags+  (dflags'', preload) <-+    if (packageFlagsChanged dflags_prev dflags')+       then liftIO $ initPackages dflags'+       else return (dflags', [])+  modifySession $ \h -> h{ hsc_dflags = dflags'' }+  when invalidate_needed $ invalidateModSummaryCache+  return preload+++-- When changing the DynFlags, we want the changes to apply to future+-- loads, but without completely discarding the program.  But the+-- DynFlags are cached in each ModSummary in the hsc_mod_graph, so+-- after a change to DynFlags, the changes would apply to new modules+-- but not existing modules; this seems undesirable.+--+-- Furthermore, the GHC API client might expect that changing+-- log_action would affect future compilation messages, but for those+-- modules we have cached ModSummaries for, we'll continue to use the+-- old log_action.  This is definitely wrong (#7478).+--+-- Hence, we invalidate the ModSummary cache after changing the+-- DynFlags.  We do this by tweaking the date on each ModSummary, so+-- that the next downsweep will think that all the files have changed+-- and preprocess them again.  This won't necessarily cause everything+-- to be recompiled, because by the time we check whether we need to+-- recopmile a module, we'll have re-summarised the module and have a+-- correct ModSummary.+--+invalidateModSummaryCache :: GhcMonad m => m ()+invalidateModSummaryCache =+  modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) }+ where+  inval ms = ms { ms_hs_date = addUTCTime (-1) (ms_hs_date ms) }++-- | Returns the program 'DynFlags'.+getProgramDynFlags :: GhcMonad m => m DynFlags+getProgramDynFlags = getSessionDynFlags++-- | Set the 'DynFlags' used to evaluate interactive expressions.+-- Note: this cannot be used for changes to packages.  Use+-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the+-- 'pkgState' into the interactive @DynFlags@.+setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()+setInteractiveDynFlags dflags = do+  dflags' <- checkNewDynFlags dflags+  dflags'' <- checkNewInteractiveDynFlags dflags'+  modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }}++-- | Get the 'DynFlags' used to evaluate interactive expressions.+getInteractiveDynFlags :: GhcMonad m => m DynFlags+getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))+++parseDynamicFlags :: MonadIO m =>+                     DynFlags -> [Located String]+                  -> m (DynFlags, [Located String], [Warn])+parseDynamicFlags = parseDynamicFlagsCmdLine++-- | Checks the set of new DynFlags for possibly erroneous option+-- combinations when invoking 'setSessionDynFlags' and friends, and if+-- found, returns a fixed copy (if possible).+checkNewDynFlags :: MonadIO m => DynFlags -> m DynFlags+checkNewDynFlags dflags = do+  -- See Note [DynFlags consistency]+  let (dflags', warnings) = makeDynFlagsConsistent dflags+  liftIO $ handleFlagWarnings dflags (map (Warn NoReason) warnings)+  return dflags'++checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags+checkNewInteractiveDynFlags dflags0 = do+  -- We currently don't support use of StaticPointers in expressions entered on+  -- the REPL. See #12356.+  if xopt LangExt.StaticPointers dflags0+  then do liftIO $ printOrThrowWarnings dflags0 $ listToBag+            [mkPlainWarnMsg dflags0 interactiveSrcSpan+             $ text "StaticPointers is not supported in GHCi interactive expressions."]+          return $ xopt_unset dflags0 LangExt.StaticPointers+  else return dflags0+++-- %************************************************************************+-- %*                                                                      *+--             Setting, getting, and modifying the targets+-- %*                                                                      *+-- %************************************************************************++-- ToDo: think about relative vs. absolute file paths. And what+-- happens when the current directory changes.++-- | Sets the targets for this session.  Each target may be a module name+-- or a filename.  The targets correspond to the set of root modules for+-- the program\/library.  Unloading the current program is achieved by+-- setting the current set of targets to be empty, followed by 'load'.+setTargets :: GhcMonad m => [Target] -> m ()+setTargets targets = modifySession (\h -> h{ hsc_targets = targets })++-- | Returns the current set of targets+getTargets :: GhcMonad m => m [Target]+getTargets = withSession (return . hsc_targets)++-- | Add another target.+addTarget :: GhcMonad m => Target -> m ()+addTarget target+  = modifySession (\h -> h{ hsc_targets = target : hsc_targets h })++-- | Remove a target+removeTarget :: GhcMonad m => TargetId -> m ()+removeTarget target_id+  = modifySession (\h -> h{ hsc_targets = filter (hsc_targets h) })+  where+   filter targets = [ t | t@(Target id _ _) <- targets, id /= target_id ]++-- | Attempts to guess what Target a string refers to.  This function+-- implements the @--make@/GHCi command-line syntax for filenames:+--+--   - if the string looks like a Haskell source filename, then interpret it+--     as such+--+--   - if adding a .hs or .lhs suffix yields the name of an existing file,+--     then use that+--+--   - otherwise interpret the string as a module name+--+guessTarget :: GhcMonad m => String -> Maybe Phase -> m Target+guessTarget str (Just phase)+   = return (Target (TargetFile str (Just phase)) True Nothing)+guessTarget str Nothing+   | isHaskellSrcFilename file+   = return (target (TargetFile file Nothing))+   | otherwise+   = do exists <- liftIO $ doesFileExist hs_file+        if exists+           then return (target (TargetFile hs_file Nothing))+           else do+        exists <- liftIO $ doesFileExist lhs_file+        if exists+           then return (target (TargetFile lhs_file Nothing))+           else do+        if looksLikeModuleName file+           then return (target (TargetModule (mkModuleName file)))+           else do+        dflags <- getDynFlags+        liftIO $ throwGhcExceptionIO+                 (ProgramError (showSDoc dflags $+                 text "target" <+> quotes (text file) <+>+                 text "is not a module name or a source file"))+     where+         (file,obj_allowed)+                | '*':rest <- str = (rest, False)+                | otherwise       = (str,  True)++         hs_file  = file <.> "hs"+         lhs_file = file <.> "lhs"++         target tid = Target tid obj_allowed Nothing+++-- | Inform GHC that the working directory has changed.  GHC will flush+-- its cache of module locations, since it may no longer be valid.+--+-- Note: Before changing the working directory make sure all threads running+-- in the same session have stopped.  If you change the working directory,+-- you should also unload the current program (set targets to empty,+-- followed by load).+workingDirectoryChanged :: GhcMonad m => m ()+workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches)+++-- %************************************************************************+-- %*                                                                      *+--             Running phases one at a time+-- %*                                                                      *+-- %************************************************************************++class ParsedMod m where+  modSummary   :: m -> ModSummary+  parsedSource :: m -> ParsedSource++class ParsedMod m => TypecheckedMod m where+  renamedSource     :: m -> Maybe RenamedSource+  typecheckedSource :: m -> TypecheckedSource+  moduleInfo        :: m -> ModuleInfo+  tm_internals      :: m -> (TcGblEnv, ModDetails)+        -- ToDo: improvements that could be made here:+        --  if the module succeeded renaming but not typechecking,+        --  we can still get back the GlobalRdrEnv and exports, so+        --  perhaps the ModuleInfo should be split up into separate+        --  fields.++class TypecheckedMod m => DesugaredMod m where+  coreModule :: m -> ModGuts++-- | The result of successful parsing.+data ParsedModule =+  ParsedModule { pm_mod_summary   :: ModSummary+               , pm_parsed_source :: ParsedSource+               , pm_extra_src_files :: [FilePath]+               , pm_annotations :: ApiAnns }+               -- See Note [Api annotations] in ApiAnnotation.hs++instance ParsedMod ParsedModule where+  modSummary m    = pm_mod_summary m+  parsedSource m = pm_parsed_source m++-- | The result of successful typechecking.  It also contains the parser+--   result.+data TypecheckedModule =+  TypecheckedModule { tm_parsed_module       :: ParsedModule+                    , tm_renamed_source      :: Maybe RenamedSource+                    , tm_typechecked_source  :: TypecheckedSource+                    , tm_checked_module_info :: ModuleInfo+                    , tm_internals_          :: (TcGblEnv, ModDetails)+                    }++instance ParsedMod TypecheckedModule where+  modSummary m   = modSummary (tm_parsed_module m)+  parsedSource m = parsedSource (tm_parsed_module m)++instance TypecheckedMod TypecheckedModule where+  renamedSource m     = tm_renamed_source m+  typecheckedSource m = tm_typechecked_source m+  moduleInfo m        = tm_checked_module_info m+  tm_internals m      = tm_internals_ m++-- | The result of successful desugaring (i.e., translation to core).  Also+--  contains all the information of a typechecked module.+data DesugaredModule =+  DesugaredModule { dm_typechecked_module :: TypecheckedModule+                  , dm_core_module        :: ModGuts+             }++instance ParsedMod DesugaredModule where+  modSummary m   = modSummary (dm_typechecked_module m)+  parsedSource m = parsedSource (dm_typechecked_module m)++instance TypecheckedMod DesugaredModule where+  renamedSource m     = renamedSource (dm_typechecked_module m)+  typecheckedSource m = typecheckedSource (dm_typechecked_module m)+  moduleInfo m        = moduleInfo (dm_typechecked_module m)+  tm_internals m      = tm_internals_ (dm_typechecked_module m)++instance DesugaredMod DesugaredModule where+  coreModule m = dm_core_module m++type ParsedSource      = Located (HsModule GhcPs)+type RenamedSource     = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],+                          Maybe LHsDocString)+type TypecheckedSource = LHsBinds GhcTc++-- NOTE:+--   - things that aren't in the output of the typechecker right now:+--     - the export list+--     - the imports+--     - type signatures+--     - type/data/newtype declarations+--     - class declarations+--     - instances+--   - extra things in the typechecker's output:+--     - default methods are turned into top-level decls.+--     - dictionary bindings++-- | Return the 'ModSummary' of a module with the given name.+--+-- The module must be part of the module graph (see 'hsc_mod_graph' and+-- 'ModuleGraph').  If this is not the case, this function will throw a+-- 'GhcApiError'.+--+-- This function ignores boot modules and requires that there is only one+-- non-boot module with the given name.+getModSummary :: GhcMonad m => ModuleName -> m ModSummary+getModSummary mod = do+   mg <- liftM hsc_mod_graph getSession+   let mods_by_name = [ ms | ms <- mgModSummaries mg+                      , ms_mod_name ms == mod+                      , not (isBootSummary ms) ]+   case mods_by_name of+     [] -> do dflags <- getDynFlags+              liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")+     [ms] -> return ms+     multiple -> do dflags <- getDynFlags+                    liftIO $ throwIO $ mkApiErr dflags (text "getModSummary is ambiguous: " <+> ppr multiple)++-- | Parse a module.+--+-- Throws a 'SourceError' on parse error.+parseModule :: GhcMonad m => ModSummary -> m ParsedModule+parseModule ms = do+   hsc_env <- getSession+   let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }+   hpm <- liftIO $ hscParse hsc_env_tmp ms+   return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)+                           (hpm_annotations hpm))+               -- See Note [Api annotations] in ApiAnnotation.hs++-- | Typecheck and rename a parsed module.+--+-- Throws a 'SourceError' if either fails.+typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule+typecheckModule pmod = do+ let ms = modSummary pmod+ hsc_env <- getSession+ let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }+ (tc_gbl_env, rn_info)+       <- liftIO $ hscTypecheckRename hsc_env_tmp ms $+                      HsParsedModule { hpm_module = parsedSource pmod,+                                       hpm_src_files = pm_extra_src_files pmod,+                                       hpm_annotations = pm_annotations pmod }+ details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env+ safe    <- liftIO $ finalSafeMode (ms_hspp_opts ms) tc_gbl_env++ return $+     TypecheckedModule {+       tm_internals_          = (tc_gbl_env, details),+       tm_parsed_module       = pmod,+       tm_renamed_source      = rn_info,+       tm_typechecked_source  = tcg_binds tc_gbl_env,+       tm_checked_module_info =+         ModuleInfo {+           minf_type_env  = md_types details,+           minf_exports   = md_exports details,+           minf_rdr_env   = Just (tcg_rdr_env tc_gbl_env),+           minf_instances = fixSafeInstances safe $ md_insts details,+           minf_iface     = Nothing,+           minf_safe      = safe,+           minf_modBreaks = emptyModBreaks+         }}++-- | Desugar a typechecked module.+desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule+desugarModule tcm = do+ let ms = modSummary tcm+ let (tcg, _) = tm_internals tcm+ hsc_env <- getSession+ let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms }+ guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg+ return $+     DesugaredModule {+       dm_typechecked_module = tcm,+       dm_core_module        = guts+     }++-- | Load a module.  Input doesn't need to be desugared.+--+-- A module must be loaded before dependent modules can be typechecked.  This+-- always includes generating a 'ModIface' and, depending on the+-- 'DynFlags.hscTarget', may also include code generation.+--+-- This function will always cause recompilation and will always overwrite+-- previous compilation results (potentially files on disk).+--+loadModule :: (TypecheckedMod mod, GhcMonad m) => mod -> m mod+loadModule tcm = do+   let ms = modSummary tcm+   let mod = ms_mod_name ms+   let loc = ms_location ms+   let (tcg, _details) = tm_internals tcm++   mb_linkable <- case ms_obj_date ms of+                     Just t | t > ms_hs_date ms  -> do+                         l <- liftIO $ findObjectLinkable (ms_mod ms)+                                                  (ml_obj_file loc) t+                         return (Just l)+                     _otherwise -> return Nothing++   let source_modified | isNothing mb_linkable = SourceModified+                       | otherwise             = SourceUnmodified+                       -- we can't determine stability here++   -- compile doesn't change the session+   hsc_env <- getSession+   mod_info <- liftIO $ compileOne' (Just tcg) Nothing+                                    hsc_env ms 1 1 Nothing mb_linkable+                                    source_modified++   modifySession $ \e -> e{ hsc_HPT = addToHpt (hsc_HPT e) mod mod_info }+   return tcm+++-- %************************************************************************+-- %*                                                                      *+--             Dealing with Core+-- %*                                                                      *+-- %************************************************************************++-- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for+-- the 'GHC.compileToCoreModule' interface.+data CoreModule+  = CoreModule {+      -- | Module name+      cm_module   :: !Module,+      -- | Type environment for types declared in this module+      cm_types    :: !TypeEnv,+      -- | Declarations+      cm_binds    :: CoreProgram,+      -- | Safe Haskell mode+      cm_safe     :: SafeHaskellMode+    }++instance Outputable CoreModule where+   ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb,+                    cm_safe = sf})+    = text "%module" <+> ppr mn <+> parens (ppr sf) <+> ppr te+      $$ vcat (map ppr cb)++-- | This is the way to get access to the Core bindings corresponding+-- to a module. 'compileToCore' parses, typechecks, and+-- desugars the module, then returns the resulting Core module (consisting of+-- the module name, type declarations, and function declarations) if+-- successful.+compileToCoreModule :: GhcMonad m => FilePath -> m CoreModule+compileToCoreModule = compileCore False++-- | Like compileToCoreModule, but invokes the simplifier, so+-- as to return simplified and tidied Core.+compileToCoreSimplified :: GhcMonad m => FilePath -> m CoreModule+compileToCoreSimplified = compileCore True++compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule+compileCore simplify fn = do+   -- First, set the target to the desired filename+   target <- guessTarget fn Nothing+   addTarget target+   _ <- load LoadAllTargets+   -- Then find dependencies+   modGraph <- depanal [] True+   case find ((== fn) . msHsFilePath) (mgModSummaries modGraph) of+     Just modSummary -> do+       -- Now we have the module name;+       -- parse, typecheck and desugar the module+       (tcg, mod_guts) <- -- TODO: space leaky: call hsc* directly?+         do tm <- typecheckModule =<< parseModule modSummary+            let tcg = fst (tm_internals tm)+            (,) tcg . coreModule <$> desugarModule tm+       liftM (gutsToCoreModule (mg_safe_haskell mod_guts)) $+         if simplify+          then do+             -- If simplify is true: simplify (hscSimplify), then tidy+             -- (tidyProgram).+             hsc_env <- getSession+             simpl_guts <- liftIO $ do+               plugins <- readIORef (tcg_th_coreplugins tcg)+               hscSimplify hsc_env plugins mod_guts+             tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts+             return $ Left tidy_guts+          else+             return $ Right mod_guts++     Nothing -> panic "compileToCoreModule: target FilePath not found in\+                           module dependency graph"+  where -- two versions, based on whether we simplify (thus run tidyProgram,+        -- which returns a (CgGuts, ModDetails) pair, or not (in which case+        -- we just have a ModGuts.+        gutsToCoreModule :: SafeHaskellMode+                         -> Either (CgGuts, ModDetails) ModGuts+                         -> CoreModule+        gutsToCoreModule safe_mode (Left (cg, md)) = CoreModule {+          cm_module = cg_module cg,+          cm_types  = md_types md,+          cm_binds  = cg_binds cg,+          cm_safe   = safe_mode+        }+        gutsToCoreModule safe_mode (Right mg) = CoreModule {+          cm_module  = mg_module mg,+          cm_types   = typeEnvFromEntities (bindersOfBinds (mg_binds mg))+                                           (mg_tcs mg)+                                           (mg_fam_insts mg),+          cm_binds   = mg_binds mg,+          cm_safe    = safe_mode+         }++-- %************************************************************************+-- %*                                                                      *+--             Inspecting the session+-- %*                                                                      *+-- %************************************************************************++-- | Get the module dependency graph.+getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary+getModuleGraph = liftM hsc_mod_graph getSession++-- | Return @True@ <==> module is loaded.+isLoaded :: GhcMonad m => ModuleName -> m Bool+isLoaded m = withSession $ \hsc_env ->+  return $! isJust (lookupHpt (hsc_HPT hsc_env) m)++-- | Return the bindings for the current interactive session.+getBindings :: GhcMonad m => m [TyThing]+getBindings = withSession $ \hsc_env ->+    return $ icInScopeTTs $ hsc_IC hsc_env++-- | Return the instances for the current interactive session.+getInsts :: GhcMonad m => m ([ClsInst], [FamInst])+getInsts = withSession $ \hsc_env ->+    return $ ic_instances (hsc_IC hsc_env)++getPrintUnqual :: GhcMonad m => m PrintUnqualified+getPrintUnqual = withSession $ \hsc_env ->+  return (icPrintUnqual (hsc_dflags hsc_env) (hsc_IC hsc_env))++-- | Container for information about a 'Module'.+data ModuleInfo = ModuleInfo {+        minf_type_env  :: TypeEnv,+        minf_exports   :: [AvailInfo],+        minf_rdr_env   :: Maybe GlobalRdrEnv,   -- Nothing for a compiled/package mod+        minf_instances :: [ClsInst],+        minf_iface     :: Maybe ModIface,+        minf_safe      :: SafeHaskellMode,+        minf_modBreaks :: ModBreaks+  }+        -- We don't want HomeModInfo here, because a ModuleInfo applies+        -- to package modules too.++-- | Request information about a loaded 'Module'+getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)  -- XXX: Maybe X+getModuleInfo mdl = withSession $ \hsc_env -> do+  let mg = hsc_mod_graph hsc_env+  if mgElemModule mg mdl+        then liftIO $ getHomeModuleInfo hsc_env mdl+        else do+  {- if isHomeModule (hsc_dflags hsc_env) mdl+        then return Nothing+        else -} liftIO $ getPackageModuleInfo hsc_env mdl+   -- ToDo: we don't understand what the following comment means.+   --    (SDM, 19/7/2011)+   -- getPackageModuleInfo will attempt to find the interface, so+   -- we don't want to call it for a home module, just in case there+   -- was a problem loading the module and the interface doesn't+   -- exist... hence the isHomeModule test here.  (ToDo: reinstate)++getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)+getPackageModuleInfo hsc_env mdl+  = do  eps <- hscEPS hsc_env+        iface <- hscGetModuleInterface hsc_env mdl+        let+            avails = mi_exports iface+            pte    = eps_PTE eps+            tys    = [ ty | name <- concatMap availNames avails,+                            Just ty <- [lookupTypeEnv pte name] ]+        --+        return (Just (ModuleInfo {+                        minf_type_env  = mkTypeEnv tys,+                        minf_exports   = avails,+                        minf_rdr_env   = Just $! availsToGlobalRdrEnv (moduleName mdl) avails,+                        minf_instances = error "getModuleInfo: instances for package module unimplemented",+                        minf_iface     = Just iface,+                        minf_safe      = getSafeMode $ mi_trust iface,+                        minf_modBreaks = emptyModBreaks+                }))++getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)+getHomeModuleInfo hsc_env mdl =+  case lookupHpt (hsc_HPT hsc_env) (moduleName mdl) of+    Nothing  -> return Nothing+    Just hmi -> do+      let details = hm_details hmi+          iface   = hm_iface hmi+      return (Just (ModuleInfo {+                        minf_type_env  = md_types details,+                        minf_exports   = md_exports details,+                        minf_rdr_env   = mi_globals $! hm_iface hmi,+                        minf_instances = md_insts details,+                        minf_iface     = Just iface,+                        minf_safe      = getSafeMode $ mi_trust iface+                       ,minf_modBreaks = getModBreaks hmi+                        }))++-- | The list of top-level entities defined in a module+modInfoTyThings :: ModuleInfo -> [TyThing]+modInfoTyThings minf = typeEnvElts (minf_type_env minf)++modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]+modInfoTopLevelScope minf+  = fmap (map gre_name . globalRdrEnvElts) (minf_rdr_env minf)++modInfoExports :: ModuleInfo -> [Name]+modInfoExports minf = concatMap availNames $! minf_exports minf++modInfoExportsWithSelectors :: ModuleInfo -> [Name]+modInfoExportsWithSelectors minf = concatMap availNamesWithSelectors $! minf_exports minf++-- | Returns the instances defined by the specified module.+-- Warning: currently unimplemented for package modules.+modInfoInstances :: ModuleInfo -> [ClsInst]+modInfoInstances = minf_instances++modInfoIsExportedName :: ModuleInfo -> Name -> Bool+modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf))++mkPrintUnqualifiedForModule :: GhcMonad m =>+                               ModuleInfo+                            -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X+mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do+  return (fmap (mkPrintUnqualified (hsc_dflags hsc_env)) (minf_rdr_env minf))++modInfoLookupName :: GhcMonad m =>+                     ModuleInfo -> Name+                  -> m (Maybe TyThing) -- XXX: returns a Maybe X+modInfoLookupName minf name = withSession $ \hsc_env -> do+   case lookupTypeEnv (minf_type_env minf) name of+     Just tyThing -> return (Just tyThing)+     Nothing      -> do+       eps <- liftIO $ readIORef (hsc_EPS hsc_env)+       return $! lookupType (hsc_dflags hsc_env)+                            (hsc_HPT hsc_env) (eps_PTE eps) name++modInfoIface :: ModuleInfo -> Maybe ModIface+modInfoIface = minf_iface++-- | Retrieve module safe haskell mode+modInfoSafe :: ModuleInfo -> SafeHaskellMode+modInfoSafe = minf_safe++modInfoModBreaks :: ModuleInfo -> ModBreaks+modInfoModBreaks = minf_modBreaks++isDictonaryId :: Id -> Bool+isDictonaryId id+  = case tcSplitSigmaTy (idType id) of {+      (_tvs, _theta, tau) -> isDictTy tau }++-- | Looks up a global name: that is, any top-level name in any+-- visible module.  Unlike 'lookupName', lookupGlobalName does not use+-- the interactive context, and therefore does not require a preceding+-- 'setContext'.+lookupGlobalName :: GhcMonad m => Name -> m (Maybe TyThing)+lookupGlobalName name = withSession $ \hsc_env -> do+   liftIO $ lookupTypeHscEnv hsc_env name++findGlobalAnns :: (GhcMonad m, Typeable a) => ([Word8] -> a) -> AnnTarget Name -> m [a]+findGlobalAnns deserialize target = withSession $ \hsc_env -> do+    ann_env <- liftIO $ prepareAnnotations hsc_env Nothing+    return (findAnns deserialize ann_env target)++-- | get the GlobalRdrEnv for a session+getGRE :: GhcMonad m => m GlobalRdrEnv+getGRE = withSession $ \hsc_env-> return $ ic_rn_gbl_env (hsc_IC hsc_env)++-- | Retrieve all type and family instances in the environment, indexed+-- by 'Name'. Each name's lists will contain every instance in which that name+-- is mentioned in the instance head.+getNameToInstancesIndex :: GhcMonad m+  => [Module]        -- ^ visible modules. An orphan instance will be returned+                     -- if it is visible from at least one module in the list.+  -> Maybe [Module]  -- ^ modules to load. If this is not specified, we load+                     -- modules for everything that is in scope unqualified.+  -> m (Messages, Maybe (NameEnv ([ClsInst], [FamInst])))+getNameToInstancesIndex visible_mods mods_to_load = do+  hsc_env <- getSession+  liftIO $ runTcInteractive hsc_env $+    do { case mods_to_load of+           Nothing -> loadUnqualIfaces hsc_env (hsc_IC hsc_env)+           Just mods ->+             let doc = text "Need interface for reporting instances in scope"+             in initIfaceTcRn $ mapM_ (loadSysInterface doc) mods++       ; InstEnvs {ie_global, ie_local} <- tcGetInstEnvs+       ; let visible_mods' = mkModuleSet visible_mods+       ; (pkg_fie, home_fie) <- tcGetFamInstEnvs+       -- We use Data.Sequence.Seq because we are creating left associated+       -- mappends.+       -- cls_index and fam_index below are adapted from TcRnDriver.lookupInsts+       ; let cls_index = Map.fromListWith mappend+                 [ (n, Seq.singleton ispec)+                 | ispec <- instEnvElts ie_local ++ instEnvElts ie_global+                 , instIsVisible visible_mods' ispec+                 , n <- nameSetElemsStable $ orphNamesOfClsInst ispec+                 ]+       ; let fam_index = Map.fromListWith mappend+                 [ (n, Seq.singleton fispec)+                 | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie+                 , n <- nameSetElemsStable $ orphNamesOfFamInst fispec+                 ]+       ; return $ mkNameEnv $+           [ (nm, (toList clss, toList fams))+           | (nm, (clss, fams)) <- Map.toList $ Map.unionWith mappend+               (fmap (,Seq.empty) cls_index)+               (fmap (Seq.empty,) fam_index)+           ] }++-- -----------------------------------------------------------------------------++{- ToDo: Move the primary logic here to compiler/main/Packages.hs+-- | Return all /external/ modules available in the package database.+-- Modules from the current session (i.e., from the 'HomePackageTable') are+-- not included.  This includes module names which are reexported by packages.+packageDbModules :: GhcMonad m =>+                    Bool  -- ^ Only consider exposed packages.+                 -> m [Module]+packageDbModules only_exposed = do+   dflags <- getSessionDynFlags+   let pkgs = eltsUFM (pkgIdMap (pkgState dflags))+   return $+     [ mkModule pid modname+     | p <- pkgs+     , not only_exposed || exposed p+     , let pid = packageConfigId p+     , modname <- exposedModules p+               ++ map exportName (reexportedModules p) ]+               -}++-- -----------------------------------------------------------------------------+-- Misc exported utils++dataConType :: DataCon -> Type+dataConType dc = idType (dataConWrapId dc)++-- | print a 'NamedThing', adding parentheses if the name is an operator.+pprParenSymName :: NamedThing a => a -> SDoc+pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))++-- ----------------------------------------------------------------------------+++-- ToDo:+--   - Data and Typeable instances for HsSyn.++-- ToDo: check for small transformations that happen to the syntax in+-- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)++-- ToDo: maybe use TH syntax instead of IfaceSyn?  There's already a way+-- to get from TyCons, Ids etc. to TH syntax (reify).++-- :browse will use either lm_toplev or inspect lm_interface, depending+-- on whether the module is interpreted or not.+++-- Extract the filename, stringbuffer content and dynflags associed to a module+--+-- XXX: Explain pre-conditions+getModuleSourceAndFlags :: GhcMonad m => Module -> m (String, StringBuffer, DynFlags)+getModuleSourceAndFlags mod = do+  m <- getModSummary (moduleName mod)+  case ml_hs_file $ ms_location m of+    Nothing -> do dflags <- getDynFlags+                  liftIO $ throwIO $ mkApiErr dflags (text "No source available for module " <+> ppr mod)+    Just sourceFile -> do+        source <- liftIO $ hGetStringBuffer sourceFile+        return (sourceFile, source, ms_hspp_opts m)+++-- | Return module source as token stream, including comments.+--+-- The module must be in the module graph and its source must be available.+-- Throws a 'HscTypes.SourceError' on parse error.+getTokenStream :: GhcMonad m => Module -> m [Located Token]+getTokenStream mod = do+  (sourceFile, source, flags) <- getModuleSourceAndFlags mod+  let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1+  case lexTokenStream source startLoc flags of+    POk _ ts  -> return ts+    PFailed pst ->+        do dflags <- getDynFlags+           throwErrors (getErrorMessages pst dflags)++-- | Give even more information on the source than 'getTokenStream'+-- This function allows reconstructing the source completely with+-- 'showRichTokenStream'.+getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)]+getRichTokenStream mod = do+  (sourceFile, source, flags) <- getModuleSourceAndFlags mod+  let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1+  case lexTokenStream source startLoc flags of+    POk _ ts -> return $ addSourceToTokens startLoc source ts+    PFailed pst ->+        do dflags <- getDynFlags+           throwErrors (getErrorMessages pst dflags)++-- | Given a source location and a StringBuffer corresponding to this+-- location, return a rich token stream with the source associated to the+-- tokens.+addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]+                  -> [(Located Token, String)]+addSourceToTokens _ _ [] = []+addSourceToTokens loc buf (t@(dL->L span _) : ts)+    = case span of+      UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts+      RealSrcSpan s   -> (t,str) : addSourceToTokens newLoc newBuf ts+        where+          (newLoc, newBuf, str) = go "" loc buf+          start = realSrcSpanStart s+          end = realSrcSpanEnd s+          go acc loc buf | loc < start = go acc nLoc nBuf+                         | start <= loc && loc < end = go (ch:acc) nLoc nBuf+                         | otherwise = (loc, buf, reverse acc)+              where (ch, nBuf) = nextChar buf+                    nLoc = advanceSrcLoc loc ch+++-- | Take a rich token stream such as produced from 'getRichTokenStream' and+-- return source code almost identical to the original code (except for+-- insignificant whitespace.)+showRichTokenStream :: [(Located Token, String)] -> String+showRichTokenStream ts = go startLoc ts ""+    where sourceFile = getFile $ map (getLoc . fst) ts+          getFile [] = panic "showRichTokenStream: No source file found"+          getFile (UnhelpfulSpan _ : xs) = getFile xs+          getFile (RealSrcSpan s : _) = srcSpanFile s+          startLoc = mkRealSrcLoc sourceFile 1 1+          go _ [] = id+          go loc ((dL->L span _, str):ts)+              = case span of+                UnhelpfulSpan _ -> go loc ts+                RealSrcSpan s+                 | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++)+                                       . (str ++)+                                       . go tokEnd ts+                 | otherwise -> ((replicate (tokLine - locLine) '\n') ++)+                               . ((replicate (tokCol - 1) ' ') ++)+                              . (str ++)+                              . go tokEnd ts+                  where (locLine, locCol) = (srcLocLine loc, srcLocCol loc)+                        (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s)+                        tokEnd = realSrcSpanEnd s++-- -----------------------------------------------------------------------------+-- Interactive evaluation++-- | Takes a 'ModuleName' and possibly a 'UnitId', and consults the+-- filesystem and package database to find the corresponding 'Module',+-- using the algorithm that is used for an @import@ declaration.+findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module+findModule mod_name maybe_pkg = withSession $ \hsc_env -> do+  let+    dflags   = hsc_dflags hsc_env+    this_pkg = thisPackage dflags+  --+  case maybe_pkg of+    Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do+      res <- findImportedModule hsc_env mod_name maybe_pkg+      case res of+        Found _ m -> return m+        err       -> throwOneError $ noModError dflags noSrcSpan mod_name err+    _otherwise -> do+      home <- lookupLoadedHomeModule mod_name+      case home of+        Just m  -> return m+        Nothing -> liftIO $ do+           res <- findImportedModule hsc_env mod_name maybe_pkg+           case res of+             Found loc m | moduleUnitId m /= this_pkg -> return m+                         | otherwise -> modNotLoadedError dflags m loc+             err -> throwOneError $ noModError dflags noSrcSpan mod_name err++modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a+modNotLoadedError dflags m loc = throwGhcExceptionIO $ CmdLineError $ showSDoc dflags $+   text "module is not loaded:" <+>+   quotes (ppr (moduleName m)) <+>+   parens (text (expectJust "modNotLoadedError" (ml_hs_file loc)))++-- | Like 'findModule', but differs slightly when the module refers to+-- a source file, and the file has not been loaded via 'load'.  In+-- this case, 'findModule' will throw an error (module not loaded),+-- but 'lookupModule' will check to see whether the module can also be+-- found in a package, and if so, that package 'Module' will be+-- returned.  If not, the usual module-not-found error will be thrown.+--+lookupModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module+lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg)+lookupModule mod_name Nothing = withSession $ \hsc_env -> do+  home <- lookupLoadedHomeModule mod_name+  case home of+    Just m  -> return m+    Nothing -> liftIO $ do+      res <- findExposedPackageModule hsc_env mod_name Nothing+      case res of+        Found _ m -> return m+        err       -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err++lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module)+lookupLoadedHomeModule mod_name = withSession $ \hsc_env ->+  case lookupHpt (hsc_HPT hsc_env) mod_name of+    Just mod_info      -> return (Just (mi_module (hm_iface mod_info)))+    _not_a_home_module -> return Nothing++-- | Check that a module is safe to import (according to Safe Haskell).+--+-- We return True to indicate the import is safe and False otherwise+-- although in the False case an error may be thrown first.+isModuleTrusted :: GhcMonad m => Module -> m Bool+isModuleTrusted m = withSession $ \hsc_env ->+    liftIO $ hscCheckSafe hsc_env m noSrcSpan++-- | Return if a module is trusted and the pkgs it depends on to be trusted.+moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set InstalledUnitId)+moduleTrustReqs m = withSession $ \hsc_env ->+    liftIO $ hscGetSafe hsc_env m noSrcSpan++-- | Set the monad GHCi lifts user statements into.+--+-- Checks that a type (in string form) is an instance of the+-- @GHC.GHCi.GHCiSandboxIO@ type class. Sets it to be the GHCi monad if it is,+-- throws an error otherwise.+setGHCiMonad :: GhcMonad m => String -> m ()+setGHCiMonad name = withSession $ \hsc_env -> do+    ty <- liftIO $ hscIsGHCiMonad hsc_env name+    modifySession $ \s ->+        let ic = (hsc_IC s) { ic_monad = ty }+        in s { hsc_IC = ic }++-- | Get the monad GHCi lifts user statements into.+getGHCiMonad :: GhcMonad m => m Name+getGHCiMonad = fmap (ic_monad . hsc_IC) getSession++getHistorySpan :: GhcMonad m => History -> m SrcSpan+getHistorySpan h = withSession $ \hsc_env ->+    return $ InteractiveEval.getHistorySpan hsc_env h++obtainTermFromVal :: GhcMonad m => Int ->  Bool -> Type -> a -> m Term+obtainTermFromVal bound force ty a = withSession $ \hsc_env ->+    liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a++obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term+obtainTermFromId bound force id = withSession $ \hsc_env ->+    liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id+++-- | Returns the 'TyThing' for a 'Name'.  The 'Name' may refer to any+-- entity known to GHC, including 'Name's defined using 'runStmt'.+lookupName :: GhcMonad m => Name -> m (Maybe TyThing)+lookupName name =+     withSession $ \hsc_env ->+       liftIO $ hscTcRcLookupName hsc_env name++-- -----------------------------------------------------------------------------+-- Pure API++-- | A pure interface to the module parser.+--+parser :: String         -- ^ Haskell module source text (full Unicode is supported)+       -> DynFlags       -- ^ the flags+       -> FilePath       -- ^ the filename (for source locations)+       -> (WarningMessages, Either ErrorMessages (Located (HsModule GhcPs)))++parser str dflags filename =+   let+       loc  = mkRealSrcLoc (mkFastString filename) 1 1+       buf  = stringToStringBuffer str+   in+   case unP Parser.parseModule (mkPState dflags buf loc) of++     PFailed pst ->+         let (warns,errs) = getMessages pst dflags in+         (warns, Left errs)++     POk pst rdr_module ->+         let (warns,_) = getMessages pst dflags in+         (warns, Right rdr_module)
+ compiler/main/GhcMake.hs view
@@ -0,0 +1,2598 @@+{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-}+{-# LANGUAGE NamedFieldPuns #-}++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2011+--+-- This module implements multi-module compilation, and is used+-- by --make and GHCi.+--+-- -----------------------------------------------------------------------------+module GhcMake(+        depanal,+        load, load', LoadHowMuch(..),++        topSortModuleGraph,++        ms_home_srcimps, ms_home_imps,++        IsBoot(..),+        summariseModule,+        hscSourceToIsBoot,+        findExtraSigImports,+        implicitRequirements,++        noModError, cyclicModuleErr,+        moduleGraphNodes, SummaryNode+    ) where++#include "HsVersions.h"++import GhcPrelude++import qualified Linker         ( unload )++import DriverPhases+import DriverPipeline+import DynFlags+import ErrUtils+import Finder+import GhcMonad+import HeaderInfo+import HscTypes+import Module+import TcIface          ( typecheckIface )+import TcRnMonad        ( initIfaceCheck )+import HscMain++import Bag              ( listToBag )+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 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+  let+         dflags  = hsc_dflags hsc_env+         targets = hsc_targets hsc_env+         old_graph = hsc_mod_graph hsc_env++  withTiming (pure 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+    mod_summaries <- reportImportErrors mod_summariesE++    let mod_graph = mkModuleGraph mod_summaries++    warnMissingHomeModules hsc_env mod_graph++    setSession hsc_env { hsc_mod_graph = mod_graph }+    return 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 ||+           --  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+    load' how_much (Just batchMsg) mod_graph++-- | Generalized version of 'load' which also supports a custom+-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally+-- produced by calling 'depanal'.+load' :: GhcMonad m => LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag+load' how_much mHscMessage mod_graph = do+    modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }+    guessOutputFile+    hsc_env <- getSession++    let hpt1   = hsc_HPT hsc_env+    let dflags = hsc_dflags hsc_env++    -- The "bad" boot modules are the ones for which we have+    -- B.hs-boot in the module graph, but no B.hs+    -- The downsweep should have ensured this does not happen+    -- (see msDeps)+    let all_home_mods =+          mkUniqSet [ ms_mod_name s+                    | s <- mgModSummaries mod_graph, not (isBootSummary s)]+    -- TODO: Figure out what the correct form of this assert is. It's violated+    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot+    -- files without corresponding hs files.+    --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,+    --                              not (ms_mod_name s `elem` all_home_mods)]+    -- ASSERT( null bad_boot_mods ) return ()++    -- check that the module given in HowMuch actually exists, otherwise+    -- topSortModuleGraph will bomb later.+    let checkHowMuch (LoadUpTo m)           = checkMod m+        checkHowMuch (LoadDependenciesOf m) = checkMod m+        checkHowMuch _ = id++        checkMod m and_then+            | m `elementOfUniqSet` all_home_mods = and_then+            | otherwise = do+                    liftIO $ errorMsg dflags (text "no such module:" <+>+                                     quotes (ppr m))+                    return Failed++    checkHowMuch how_much $ do++    -- mg2_with_srcimps drops the hi-boot nodes, returning a+    -- graph with cycles.  Among other things, it is used for+    -- backing out partially complete cycles following a failed+    -- upsweep, and for removing from hpt all the modules+    -- not in strict downwards closure, during calls to compile.+    let mg2_with_srcimps :: [SCC ModSummary]+        mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing++    -- If we can determine that any of the {-# SOURCE #-} imports+    -- are definitely unnecessary, then emit a warning.+    warnUnnecessarySourceImports mg2_with_srcimps++    let+        -- check the stability property for each module.+        stable_mods@(stable_obj,stable_bco)+            = checkStability hpt1 mg2_with_srcimps all_home_mods++        -- prune bits of the HPT which are definitely redundant now,+        -- to save space.+        pruned_hpt = pruneHomePackageTable hpt1+                            (flattenSCCs mg2_with_srcimps)+                            stable_mods++    _ <- liftIO $ evaluate pruned_hpt++    -- before we unload anything, make sure we don't leave an old+    -- interactive context around pointing to dead bindings.  Also,+    -- write the pruned HPT to allow the old HPT to be GC'd.+    setSession $ discardIC $ hsc_env { hsc_HPT = pruned_hpt }++    liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$+                            text "Stable BCO:" <+> ppr stable_bco)++    -- Unload any modules which are going to be re-linked this time around.+    let stable_linkables = [ linkable+                           | m <- nonDetEltsUniqSet stable_obj +++                                  nonDetEltsUniqSet stable_bco,+                             -- It's OK to use nonDetEltsUniqSet here+                             -- because it only affects linking. Besides+                             -- this list only serves as a poor man's set.+                             Just hmi <- [lookupHpt pruned_hpt m],+                             Just linkable <- [hm_linkable hmi] ]+    liftIO $ unload hsc_env stable_linkables++    -- We could at this point detect cycles which aren't broken by+    -- a source-import, and complain immediately, but it seems better+    -- to let upsweep_mods do this, so at least some useful work gets+    -- done before the upsweep is abandoned.+    --hPutStrLn stderr "after tsort:\n"+    --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))++    -- Now do the upsweep, calling compile for each module in+    -- turn.  Final result is version 3 of everything.++    -- Topologically sort the module graph, this time including hi-boot+    -- nodes, and possibly just including the portion of the graph+    -- reachable from the module specified in the 2nd argument to load.+    -- This graph should be cycle-free.+    -- If we're restricting the upsweep to a portion of the graph, we+    -- also want to retain everything that is still stable.+    let full_mg :: [SCC ModSummary]+        full_mg    = topSortModuleGraph False mod_graph Nothing++        maybe_top_mod = case how_much of+                            LoadUpTo m           -> Just m+                            LoadDependenciesOf m -> Just m+                            _                    -> Nothing++        partial_mg0 :: [SCC ModSummary]+        partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod++        -- LoadDependenciesOf m: we want the upsweep to stop just+        -- short of the specified module (unless the specified module+        -- is stable).+        partial_mg+            | LoadDependenciesOf _mod <- how_much+            = ASSERT( case last partial_mg0 of+                        AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )+              List.init partial_mg0+            | otherwise+            = partial_mg0++        stable_mg =+            [ AcyclicSCC ms+            | AcyclicSCC ms <- full_mg,+              stable_mod_summary ms ]++        stable_mod_summary ms =+          ms_mod_name ms `elementOfUniqSet` stable_obj ||+          ms_mod_name ms `elementOfUniqSet` stable_bco++        -- the modules from partial_mg that are not also stable+        -- NB. also keep cycles, we need to emit an error message later+        unstable_mg = filter not_stable partial_mg+          where not_stable (CyclicSCC _) = True+                not_stable (AcyclicSCC ms)+                   = not $ stable_mod_summary ms++        -- Load all the stable modules first, before attempting to load+        -- an unstable module (#7231).+        mg = stable_mg ++ unstable_mg++    -- clean up between compilations+    let cleanup = cleanCurrentModuleTempFiles . hsc_dflags+    liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")+                               2 (ppr mg))++    n_jobs <- case parMakeCount dflags of+                    Nothing -> liftIO getNumProcessors+                    Just n  -> return n+    let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs+                   | otherwise  = upsweep++    setSession hsc_env{ hsc_HPT = emptyHomePackageTable }+    (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $+      upsweep_fn mHscMessage pruned_hpt stable_mods cleanup mg++    -- Make modsDone be the summaries for each home module now+    -- available; this should equal the domain of hpt3.+    -- Get in in a roughly top .. bottom order (hence reverse).++    let modsDone = reverse modsUpswept++    -- Try and do linking in some form, depending on whether the+    -- upsweep was completely or only partially successful.++    if succeeded upsweep_ok++     then+       -- Easy; just relink it all.+       do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")++          -- Clean up after ourselves+          hsc_env1 <- getSession+          liftIO $ cleanCurrentModuleTempFiles dflags++          -- Issue a warning for the confusing case where the user+          -- said '-o foo' but we're not going to do any linking.+          -- We attempt linking if either (a) one of the modules is+          -- called Main, or (b) the user said -no-hs-main, indicating+          -- that main() is going to come from somewhere else.+          --+          let ofile = outputFile dflags+          let no_hs_main = gopt Opt_NoHsMain dflags+          let+            main_mod = mainModIs dflags+            a_root_is_Main = mgElemModule mod_graph main_mod+            do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib++          -- link everything together+          linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)++          if ghcLink dflags == LinkBinary && isJust ofile && not do_linking+             then do+                liftIO $ errorMsg dflags $ text+                   ("output was redirected with -o, " +++                    "but no output will be generated\n" +++                    "because there is no " +++                    moduleNameString (moduleName main_mod) ++ " module.")+                -- This should be an error, not a warning (#10895).+                loadFinish Failed linkresult+             else+                loadFinish Succeeded linkresult++     else+       -- Tricky.  We need to back out the effects of compiling any+       -- half-done cycles, both so as to clean up the top level envs+       -- and to avoid telling the interactive linker to link them.+       do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")++          let modsDone_names+                 = map ms_mod modsDone+          let mods_to_zap_names+                 = findPartiallyCompletedCycles modsDone_names+                      mg2_with_srcimps+          let (mods_to_clean, mods_to_keep) =+                partition ((`Set.member` mods_to_zap_names).ms_mod) modsDone+          hsc_env1 <- getSession+          let hpt4 = hsc_HPT hsc_env1+              -- We must change the lifetime to TFL_CurrentModule for any temp+              -- file created for an element of mod_to_clean during the upsweep.+              -- These include preprocessed files and object files for loaded+              -- modules.+              unneeded_temps = concat+                [ms_hspp_file : object_files+                | ModSummary{ms_mod, ms_hspp_file} <- mods_to_clean+                , let object_files = maybe [] linkableObjs $+                        lookupHpt hpt4 (moduleName ms_mod)+                        >>= hm_linkable+                ]+          liftIO $+            changeTempFilesLifetime dflags TFL_CurrentModule unneeded_temps+          liftIO $ cleanCurrentModuleTempFiles dflags++          let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)+                                          hpt4++          -- Clean up after ourselves++          -- there should be no Nothings where linkables should be, now+          let just_linkables =+                    isNoLink (ghcLink dflags)+                 || allHpt (isJust.hm_linkable)+                        (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)+                                hpt5)+          ASSERT( just_linkables ) do++          -- Link everything together+          linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt5++          modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt5 }+          loadFinish Failed linkresult+++-- | Finish up after a load.+loadFinish :: GhcMonad m => SuccessFlag -> SuccessFlag -> m SuccessFlag++-- If the link failed, unload everything and return.+loadFinish _all_ok Failed+  = do hsc_env <- getSession+       liftIO $ unload hsc_env []+       modifySession discardProg+       return Failed++-- Empty the interactive context and set the module context to the topmost+-- newly loaded module, or the Prelude if none were loaded.+loadFinish all_ok Succeeded+  = do modifySession discardIC+       return all_ok+++-- | Forget the current program, but retain the persistent info in HscEnv+discardProg :: HscEnv -> HscEnv+discardProg hsc_env+  = discardIC $ hsc_env { hsc_mod_graph = emptyMG+                        , hsc_HPT = emptyHomePackageTable }++-- | Discard the contents of the InteractiveContext, but keep the DynFlags.+-- It will also keep ic_int_print and ic_monad if their names are from+-- external packages.+discardIC :: HscEnv -> HscEnv+discardIC hsc_env+  = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print+                                , ic_monad = new_ic_monad } }+  where+  -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic+  !new_ic_int_print = keep_external_name ic_int_print+  !new_ic_monad = keep_external_name ic_monad+  dflags = ic_dflags old_ic+  old_ic = hsc_IC hsc_env+  empty_ic = emptyInteractiveContext dflags+  keep_external_name ic_name+    | nameIsFromExternalPackage this_pkg old_name = old_name+    | otherwise = ic_name empty_ic+    where+    this_pkg = thisPackage dflags+    old_name = ic_name old_ic++-- | If there is no -o option, guess the name of target executable+-- by using top-level source file name as a base.+guessOutputFile :: GhcMonad m => m ()+guessOutputFile = modifySession $ \env ->+    let dflags = hsc_dflags env+        -- Force mod_graph to avoid leaking env+        !mod_graph = hsc_mod_graph env+        mainModuleSrcPath :: Maybe String+        mainModuleSrcPath = do+            ms <- mgLookupModule mod_graph (mainModIs dflags)+            ml_hs_file (ms_location ms)+        name = fmap dropExtension mainModuleSrcPath++        name_exe = do+#if defined(mingw32_HOST_OS)+          -- we must add the .exe extension unconditionally here, otherwise+          -- when name has an extension of its own, the .exe extension will+          -- not be added by DriverPipeline.exeFileName.  See #2248+          name' <- fmap (<.> "exe") name+#else+          name' <- name+#endif+          mainModuleSrcPath' <- mainModuleSrcPath+          -- #9930: don't clobber input files (unless they ask for it)+          if name' == mainModuleSrcPath'+            then throwGhcException . UsageError $+                 "default output name would overwrite the input file; " +++                 "must specify -o explicitly"+            else Just name'+    in+    case outputFile dflags of+        Just _ -> env+        Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }++-- -----------------------------------------------------------------------------+--+-- | Prune the HomePackageTable+--+-- Before doing an upsweep, we can throw away:+--+--   - For non-stable modules:+--      - all ModDetails, all linked code+--   - all unlinked code that is out of date with respect to+--     the source file+--+-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the+-- space at the end of the upsweep, because the topmost ModDetails of the+-- old HPT holds on to the entire type environment from the previous+-- compilation.+pruneHomePackageTable :: HomePackageTable+                      -> [ModSummary]+                      -> StableModules+                      -> HomePackageTable+pruneHomePackageTable hpt summ (stable_obj, stable_bco)+  = mapHpt prune hpt+  where prune hmi+          | is_stable modl = hmi'+          | otherwise      = hmi'{ hm_details = emptyModDetails }+          where+           modl = moduleName (mi_module (hm_iface hmi))+           hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms+                = hmi{ hm_linkable = Nothing }+                | otherwise+                = hmi+                where ms = expectJust "prune" (lookupUFM ms_map modl)++        ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]++        is_stable m =+          m `elementOfUniqSet` stable_obj ||+          m `elementOfUniqSet` stable_bco++-- -----------------------------------------------------------------------------+--+-- | Return (names of) all those in modsDone who are part of a cycle as defined+-- by theGraph.+findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module+findPartiallyCompletedCycles modsDone theGraph+   = Set.unions+       [mods_in_this_cycle+       | CyclicSCC vs <- theGraph  -- Acyclic? Not interesting.+       , let names_in_this_cycle = Set.fromList (map ms_mod vs)+             mods_in_this_cycle =+                    Set.intersection (Set.fromList modsDone) names_in_this_cycle+         -- If size mods_in_this_cycle == size names_in_this_cycle,+         -- then this cycle has already been completed and we're not+         -- interested.+       , Set.size mods_in_this_cycle < Set.size names_in_this_cycle]+++-- ---------------------------------------------------------------------------+--+-- | Unloading+unload :: HscEnv -> [Linkable] -> IO ()+unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'+  = case ghcLink (hsc_dflags hsc_env) of+        LinkInMemory -> Linker.unload hsc_env stable_linkables+        _other -> return ()++-- -----------------------------------------------------------------------------+{- |++  Stability tells us which modules definitely do not need to be recompiled.+  There are two main reasons for having stability:++   - avoid doing a complete upsweep of the module graph in GHCi when+     modules near the bottom of the tree have not changed.++   - to tell GHCi when it can load object code: we can only load object code+     for a module when we also load object code fo  all of the imports of the+     module.  So we need to know that we will definitely not be recompiling+     any of these modules, and we can use the object code.++  The stability check is as follows.  Both stableObject and+  stableBCO are used during the upsweep phase later.++@+  stable m = stableObject m || stableBCO m++  stableObject m =+        all stableObject (imports m)+        && old linkable does not exist, or is == on-disk .o+        && date(on-disk .o) > date(.hs)++  stableBCO m =+        all stable (imports m)+        && date(BCO) > date(.hs)+@++  These properties embody the following ideas:++    - if a module is stable, then:++        - if it has been compiled in a previous pass (present in HPT)+          then it does not need to be compiled or re-linked.++        - if it has not been compiled in a previous pass,+          then we only need to read its .hi file from disk and+          link it to produce a 'ModDetails'.++    - if a modules is not stable, we will definitely be at least+      re-linking, and possibly re-compiling it during the 'upsweep'.+      All non-stable modules can (and should) therefore be unlinked+      before the 'upsweep'.++    - Note that objects are only considered stable if they only depend+      on other objects.  We can't link object code against byte code.++    - Note that even if an object is stable, we may end up recompiling+      if the interface is out of date because an *external* interface+      has changed.  The current code in GhcMake handles this case+      fairly poorly, so be careful.+-}++type StableModules =+  ( UniqSet ModuleName  -- stableObject+  , UniqSet ModuleName  -- stableBCO+  )+++checkStability+        :: HomePackageTable   -- HPT from last compilation+        -> [SCC ModSummary]   -- current module graph (cyclic)+        -> UniqSet ModuleName -- all home modules+        -> StableModules++checkStability hpt sccs all_home_mods =+  foldl' checkSCC (emptyUniqSet, emptyUniqSet) sccs+  where+   checkSCC :: StableModules -> SCC ModSummary -> StableModules+   checkSCC (stable_obj, stable_bco) scc0+     | stableObjects = (addListToUniqSet stable_obj scc_mods, stable_bco)+     | stableBCOs    = (stable_obj, addListToUniqSet stable_bco scc_mods)+     | otherwise     = (stable_obj, stable_bco)+     where+        scc = flattenSCC scc0+        scc_mods = map ms_mod_name scc+        home_module m =+          m `elementOfUniqSet` all_home_mods && m `notElem` scc_mods++        scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))+            -- all imports outside the current SCC, but in the home pkg++        stable_obj_imps = map (`elementOfUniqSet` stable_obj) scc_allimps+        stable_bco_imps = map (`elementOfUniqSet` stable_bco) scc_allimps++        stableObjects =+           and stable_obj_imps+           && all object_ok scc++        stableBCOs =+           and (zipWith (||) stable_obj_imps stable_bco_imps)+           && all bco_ok scc++        object_ok ms+          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False+          | Just t <- ms_obj_date ms  =  t >= ms_hs_date ms+                                         && same_as_prev t+          | otherwise = False+          where+             same_as_prev t = case lookupHpt hpt (ms_mod_name ms) of+                                Just hmi  | Just l <- hm_linkable hmi+                                 -> isObjectLinkable l && t == linkableTime l+                                _other  -> True+                -- why '>=' rather than '>' above?  If the filesystem stores+                -- times to the nearset second, we may occasionally find that+                -- the object & source have the same modification time,+                -- especially if the source was automatically generated+                -- and compiled.  Using >= is slightly unsafe, but it matches+                -- make's behaviour.+                --+                -- But see #5527, where someone ran into this and it caused+                -- a problem.++        bco_ok ms+          | gopt Opt_ForceRecomp (ms_hspp_opts ms) = False+          | otherwise = case lookupHpt hpt (ms_mod_name ms) of+                Just hmi  | Just l <- hm_linkable hmi ->+                        not (isObjectLinkable l) &&+                        linkableTime l >= ms_hs_date ms+                _other  -> False++{- Parallel Upsweep+ -+ - The parallel upsweep attempts to concurrently compile the modules in the+ - compilation graph using multiple Haskell threads.+ -+ - The Algorithm+ -+ - A Haskell thread is spawned for each module in the module graph, waiting for+ - its direct dependencies to finish building before it itself begins to build.+ -+ - Each module is associated with an initially empty MVar that stores the+ - result of that particular module's compile. If the compile succeeded, then+ - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that+ - module, and the module's HMI is deleted from the old HPT (synchronized by an+ - IORef) to save space.+ -+ - Instead of immediately outputting messages to the standard handles, all+ - compilation output is deferred to a per-module TQueue. A QSem is used to+ - limit the number of workers that are compiling simultaneously.+ -+ - Meanwhile, the main thread sequentially loops over all the modules in the+ - module graph, outputting the messages stored in each module's TQueue.+-}++-- | Each module is given a unique 'LogQueue' to redirect compilation messages+-- to. A 'Nothing' value contains the result of compilation, and denotes the+-- end of the message queue.+data LogQueue = LogQueue !(IORef [Maybe (WarnReason, Severity, SrcSpan, PprStyle, MsgDoc)])+                         !(MVar ())++-- | The graph of modules to compile and their corresponding result 'MVar' and+-- 'LogQueue'.+type CompilationGraph = [(ModSummary, MVar SuccessFlag, LogQueue)]++-- | Build a 'CompilationGraph' out of a list of strongly-connected modules,+-- also returning the first, if any, encountered module cycle.+buildCompGraph :: [SCC ModSummary] -> IO (CompilationGraph, Maybe [ModSummary])+buildCompGraph [] = return ([], Nothing)+buildCompGraph (scc:sccs) = case scc of+    AcyclicSCC ms -> do+        mvar <- newEmptyMVar+        log_queue <- do+            ref <- newIORef []+            sem <- newEmptyMVar+            return (LogQueue ref sem)+        (rest,cycle) <- buildCompGraph sccs+        return ((ms,mvar,log_queue):rest, cycle)+    CyclicSCC mss -> return ([], Just mss)++-- A Module and whether it is a boot module.+type BuildModule = (Module, IsBoot)++-- | 'Bool' indicating if a module is a boot module or not.  We need to treat+-- boot modules specially when building compilation graphs, since they break+-- cycles.  Regular source files and signature files are treated equivalently.+data IsBoot = IsBoot | NotBoot+    deriving (Ord, Eq, Show, Read)++-- | Tests if an 'HscSource' is a boot file, primarily for constructing+-- elements of 'BuildModule'.+hscSourceToIsBoot :: HscSource -> IsBoot+hscSourceToIsBoot HsBootFile = IsBoot+hscSourceToIsBoot _ = NotBoot++mkBuildModule :: ModSummary -> BuildModule+mkBuildModule ms = (ms_mod ms, if isBootSummary ms then IsBoot else NotBoot)++-- | The entry point to the parallel upsweep.+--+-- See also the simpler, sequential 'upsweep'.+parUpsweep+    :: GhcMonad m+    => Int+    -- ^ The number of workers we wish to run in parallel+    -> Maybe Messager+    -> HomePackageTable+    -> StableModules+    -> (HscEnv -> IO ())+    -> [SCC ModSummary]+    -> m (SuccessFlag,+          [ModSummary])+parUpsweep n_jobs mHscMessage old_hpt stable_mods cleanup sccs = do+    hsc_env <- getSession+    let dflags = hsc_dflags hsc_env++    when (not (null (unitIdsToCheck dflags))) $+      throwGhcException (ProgramError "Backpack typechecking not supported with -j")++    -- The bits of shared state we'll be using:++    -- The global HscEnv is updated with the module's HMI when a module+    -- successfully compiles.+    hsc_env_var <- liftIO $ newMVar hsc_env++    -- The old HPT is used for recompilation checking in upsweep_mod. When a+    -- module successfully gets compiled, its HMI is pruned from the old HPT.+    old_hpt_var <- liftIO $ newIORef old_hpt++    -- What we use to limit parallelism with.+    par_sem <- liftIO $ newQSem n_jobs+++    let updNumCapabilities = liftIO $ do+            n_capabilities <- getNumCapabilities+            n_cpus <- getNumProcessors+            -- Setting number of capabilities more than+            -- CPU count usually leads to high userspace+            -- lock contention. #9221+            let n_caps = min n_jobs n_cpus+            unless (n_capabilities /= 1) $ setNumCapabilities n_caps+            return n_capabilities+    -- Reset the number of capabilities once the upsweep ends.+    let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n++    gbracket updNumCapabilities resetNumCapabilities $ \_ -> do++    -- Sync the global session with the latest HscEnv once the upsweep ends.+    let finallySyncSession io = io `gfinally` do+            hsc_env <- liftIO $ readMVar hsc_env_var+            setSession hsc_env++    finallySyncSession $ do++    -- Build the compilation graph out of the list of SCCs. Module cycles are+    -- handled at the very end, after some useful work gets done. Note that+    -- this list is topologically sorted (by virtue of 'sccs' being sorted so).+    (comp_graph,cycle) <- liftIO $ buildCompGraph sccs+    let comp_graph_w_idx = zip comp_graph [1..]++    -- The list of all loops in the compilation graph.+    -- NB: For convenience, the last module of each loop (aka the module that+    -- finishes the loop) is prepended to the beginning of the loop.+    let graph = map fstOf3 (reverse comp_graph)+        boot_modules = mkModuleSet [ms_mod ms | ms <- graph, isBootSummary ms]+        comp_graph_loops = go graph boot_modules+          where+            remove ms bm+              | isBootSummary ms = delModuleSet bm (ms_mod ms)+              | otherwise = bm+            go [] _ = []+            go mg@(ms:mss) boot_modules+              | Just loop <- getModLoop ms mg (`elemModuleSet` boot_modules)+              = map mkBuildModule (ms:loop) : go mss (remove ms boot_modules)+              | otherwise+              = go mss (remove ms boot_modules)++    -- Build a Map out of the compilation graph with which we can efficiently+    -- look up the result MVar associated with a particular home module.+    let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)+        home_mod_map =+            Map.fromList [ (mkBuildModule ms, (mvar, idx))+                         | ((ms,mvar,_),idx) <- comp_graph_w_idx ]+++    liftIO $ label_self "main --make thread"+    -- For each module in the module graph, spawn a worker thread that will+    -- compile this module.+    let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) ->+            forkIOWithUnmask $ \unmask -> do+                liftIO $ label_self $ unwords+                    [ "worker --make thread"+                    , "for module"+                    , show (moduleNameString (ms_mod_name mod))+                    , "number"+                    , show mod_idx+                    ]+                -- Replace the default log_action with one that writes each+                -- message to the module's log_queue. The main thread will+                -- deal with synchronously printing these messages.+                --+                -- Use a local filesToClean var so that we can clean up+                -- intermediate files in a timely fashion (as soon as+                -- compilation for that module is finished) without having to+                -- worry about accidentally deleting a simultaneous compile's+                -- important files.+                lcl_files_to_clean <- newIORef emptyFilesToClean+                let lcl_dflags = dflags { log_action = parLogAction log_queue+                                        , filesToClean = lcl_files_to_clean }++                -- Unmask asynchronous exceptions and perform the thread-local+                -- work to compile the module (see parUpsweep_one).+                m_res <- try $ unmask $ prettyPrintGhcErrors lcl_dflags $+                        parUpsweep_one mod home_mod_map comp_graph_loops+                                       lcl_dflags mHscMessage cleanup+                                       par_sem hsc_env_var old_hpt_var+                                       stable_mods mod_idx (length sccs)++                res <- case m_res of+                    Right flag -> return flag+                    Left exc -> do+                        -- Don't print ThreadKilled exceptions: they are used+                        -- to kill the worker thread in the event of a user+                        -- interrupt, and the user doesn't have to be informed+                        -- about that.+                        when (fromException exc /= Just ThreadKilled)+                             (errorMsg lcl_dflags (text (show exc)))+                        return Failed++                -- Populate the result MVar.+                putMVar mvar res++                -- Write the end marker to the message queue, telling the main+                -- thread that it can stop waiting for messages from this+                -- particular compile.+                writeLogQueue log_queue Nothing++                -- Add the remaining files that weren't cleaned up to the+                -- global filesToClean ref, for cleanup later.+                FilesToClean+                  { ftcCurrentModule = cm_files+                  , ftcGhcSession = gs_files+                  } <- readIORef (filesToClean lcl_dflags)+                addFilesToClean dflags TFL_CurrentModule $ Set.toList cm_files+                addFilesToClean dflags TFL_GhcSession $ Set.toList gs_files++        -- Kill all the workers, masking interrupts (since killThread is+        -- interruptible). XXX: This is not ideal.+        ; killWorkers = uninterruptibleMask_ . mapM_ killThread }+++    -- Spawn the workers, making sure to kill them later. Collect the results+    -- of each compile.+    results <- liftIO $ bracket spawnWorkers killWorkers $ \_ ->+        -- Loop over each module in the compilation graph in order, printing+        -- each message from its log_queue.+        forM comp_graph $ \(mod,mvar,log_queue) -> do+            printLogs dflags log_queue+            result <- readMVar mvar+            if succeeded result then return (Just mod) else return Nothing+++    -- Collect and return the ModSummaries of all the successful compiles.+    -- NB: Reverse this list to maintain output parity with the sequential upsweep.+    let ok_results = reverse (catMaybes results)++    -- Handle any cycle in the original compilation graph and return the result+    -- of the upsweep.+    case cycle of+        Just mss -> do+            liftIO $ fatalErrorMsg dflags (cyclicModuleErr mss)+            return (Failed,ok_results)+        Nothing  -> do+            let success_flag = successIf (all isJust results)+            return (success_flag,ok_results)++  where+    writeLogQueue :: LogQueue -> Maybe (WarnReason,Severity,SrcSpan,PprStyle,MsgDoc) -> IO ()+    writeLogQueue (LogQueue ref sem) msg = do+        atomicModifyIORef' ref $ \msgs -> (msg:msgs,())+        _ <- tryPutMVar sem ()+        return ()++    -- The log_action callback that is used to synchronize messages from a+    -- worker thread.+    parLogAction :: LogQueue -> LogAction+    parLogAction log_queue _dflags !reason !severity !srcSpan !style !msg = do+        writeLogQueue log_queue (Just (reason,severity,srcSpan,style,msg))++    -- Print each message from the log_queue using the log_action from the+    -- session's DynFlags.+    printLogs :: DynFlags -> LogQueue -> IO ()+    printLogs !dflags (LogQueue ref sem) = read_msgs+      where read_msgs = do+                takeMVar sem+                msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)+                print_loop msgs++            print_loop [] = read_msgs+            print_loop (x:xs) = case x of+                Just (reason,severity,srcSpan,style,msg) -> do+                    putLogMsg dflags reason severity srcSpan style msg+                    print_loop xs+                -- Exit the loop once we encounter the end marker.+                Nothing -> return ()++-- The interruptible subset of the worker threads' work.+parUpsweep_one+    :: ModSummary+    -- ^ The module we wish to compile+    -> Map BuildModule (MVar SuccessFlag, Int)+    -- ^ The map of home modules and their result MVar+    -> [[BuildModule]]+    -- ^ The list of all module loops within the compilation graph.+    -> DynFlags+    -- ^ The thread-local DynFlags+    -> Maybe Messager+    -- ^ The messager+    -> (HscEnv -> IO ())+    -- ^ The callback for cleaning up intermediate files+    -> QSem+    -- ^ The semaphore for limiting the number of simultaneous compiles+    -> MVar HscEnv+    -- ^ The MVar that synchronizes updates to the global HscEnv+    -> IORef HomePackageTable+    -- ^ The old HPT+    -> StableModules+    -- ^ Sets of stable objects and BCOs+    -> Int+    -- ^ The index of this module+    -> Int+    -- ^ The total number of modules+    -> IO SuccessFlag+    -- ^ The result of this compile+parUpsweep_one mod home_mod_map comp_graph_loops lcl_dflags mHscMessage cleanup par_sem+               hsc_env_var old_hpt_var stable_mods mod_index num_mods = do++    let this_build_mod = mkBuildModule mod++    let home_imps     = map unLoc $ ms_home_imps mod+    let home_src_imps = map unLoc $ ms_home_srcimps mod++    -- All the textual imports of this module.+    let textual_deps = Set.fromList $ mapFst (mkModule (thisPackage lcl_dflags)) $+                            zip home_imps     (repeat NotBoot) +++                            zip home_src_imps (repeat IsBoot)++    -- Dealing with module loops+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~+    --+    -- Not only do we have to deal with explicit textual dependencies, we also+    -- have to deal with implicit dependencies introduced by import cycles that+    -- are broken by an hs-boot file. We have to ensure that:+    --+    -- 1. A module that breaks a loop must depend on all the modules in the+    --    loop (transitively or otherwise). This is normally always fulfilled+    --    by the module's textual dependencies except in degenerate loops,+    --    e.g.:+    --+    --    A.hs imports B.hs-boot+    --    B.hs doesn't import A.hs+    --    C.hs imports A.hs, B.hs+    --+    --    In this scenario, getModLoop will detect the module loop [A,B] but+    --    the loop finisher B doesn't depend on A. So we have to explicitly add+    --    A in as a dependency of B when we are compiling B.+    --+    -- 2. A module that depends on a module in an external loop can't proceed+    --    until the entire loop is re-typechecked.+    --+    -- These two invariants have to be maintained to correctly build a+    -- compilation graph with one or more loops.+++    -- The loop that this module will finish. After this module successfully+    -- compiles, this loop is going to get re-typechecked.+    let finish_loop = listToMaybe+            [ tail loop | loop <- comp_graph_loops+                        , head loop == this_build_mod ]++    -- If this module finishes a loop then it must depend on all the other+    -- modules in that loop because the entire module loop is going to be+    -- re-typechecked once this module gets compiled. These extra dependencies+    -- are this module's "internal" loop dependencies, because this module is+    -- inside the loop in question.+    let int_loop_deps = Set.fromList $+            case finish_loop of+                Nothing   -> []+                Just loop -> filter (/= this_build_mod) loop++    -- If this module depends on a module within a loop then it must wait for+    -- that loop to get re-typechecked, i.e. it must wait on the module that+    -- finishes that loop. These extra dependencies are this module's+    -- "external" loop dependencies, because this module is outside of the+    -- loop(s) in question.+    let ext_loop_deps = Set.fromList+            [ head loop | loop <- comp_graph_loops+                        , any (`Set.member` textual_deps) loop+                        , this_build_mod `notElem` loop ]+++    let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps]++    -- All of the module's home-module dependencies.+    let home_deps_with_idx =+            [ home_dep | dep <- Set.toList all_deps+                       , Just home_dep <- [Map.lookup dep home_mod_map] ]++    -- Sort the list of dependencies in reverse-topological order. This way, by+    -- the time we get woken up by the result of an earlier dependency,+    -- subsequent dependencies are more likely to have finished. This step+    -- effectively reduces the number of MVars that each thread blocks on.+    let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx++    -- Wait for the all the module's dependencies to finish building.+    deps_ok <- allM (fmap succeeded . readMVar) home_deps++    -- We can't build this module if any of its dependencies failed to build.+    if not deps_ok+      then return Failed+      else do+        -- Any hsc_env at this point is OK to use since we only really require+        -- that the HPT contains the HMIs of our dependencies.+        hsc_env <- readMVar hsc_env_var+        old_hpt <- readIORef old_hpt_var++        let logger err = printBagOfErrors lcl_dflags (srcErrorMessages err)++        -- Limit the number of parallel compiles.+        let withSem sem = bracket_ (waitQSem sem) (signalQSem sem)+        mb_mod_info <- withSem par_sem $+            handleSourceError (\err -> do logger err; return Nothing) $ do+                -- Have the ModSummary and HscEnv point to our local log_action+                -- and filesToClean var.+                let lcl_mod = localize_mod mod+                let lcl_hsc_env = localize_hsc_env hsc_env++                -- Re-typecheck the loop+                -- This is necessary to make sure the knot is tied when+                -- we close a recursive module loop, see bug #12035.+                type_env_var <- liftIO $ newIORef emptyNameEnv+                let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var =+                                    Just (ms_mod lcl_mod, type_env_var) }+                lcl_hsc_env'' <- case finish_loop of+                    Nothing   -> return lcl_hsc_env'+                    -- In the non-parallel case, the retypecheck prior to+                    -- typechecking the loop closer includes all modules+                    -- EXCEPT the loop closer.  However, our precomputed+                    -- SCCs include the loop closer, so we have to filter+                    -- it out.+                    Just loop -> typecheckLoop lcl_dflags lcl_hsc_env' $+                                 filter (/= moduleName (fst this_build_mod)) $+                                 map (moduleName . fst) loop++                -- Compile the module.+                mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt stable_mods+                                        lcl_mod mod_index num_mods+                return (Just mod_info)++        case mb_mod_info of+            Nothing -> return Failed+            Just mod_info -> do+                let this_mod = ms_mod_name mod++                -- Prune the old HPT unless this is an hs-boot module.+                unless (isBootSummary mod) $+                    atomicModifyIORef' old_hpt_var $ \old_hpt ->+                        (delFromHpt old_hpt this_mod, ())++                -- Update and fetch the global HscEnv.+                lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do+                    let hsc_env' = hsc_env+                                     { hsc_HPT = addToHpt (hsc_HPT hsc_env)+                                                           this_mod mod_info }+                    -- We've finished typechecking the module, now we must+                    -- retypecheck the loop AGAIN to ensure unfoldings are+                    -- updated.  This time, however, we include the loop+                    -- closer!+                    hsc_env'' <- case finish_loop of+                        Nothing   -> return hsc_env'+                        Just loop -> typecheckLoop lcl_dflags hsc_env' $+                                     map (moduleName . fst) loop+                    return (hsc_env'', localize_hsc_env hsc_env'')++                -- Clean up any intermediate files.+                cleanup lcl_hsc_env'+                return Succeeded++  where+    localize_mod mod+        = mod { ms_hspp_opts = (ms_hspp_opts mod)+                 { log_action = log_action lcl_dflags+                 , filesToClean = filesToClean lcl_dflags } }++    localize_hsc_env hsc_env+        = hsc_env { hsc_dflags = (hsc_dflags hsc_env)+                     { log_action = log_action lcl_dflags+                     , filesToClean = filesToClean lcl_dflags } }++-- -----------------------------------------------------------------------------+--+-- | The upsweep+--+-- This is where we compile each module in the module graph, in a pass+-- from the bottom to the top of the graph.+--+-- There better had not be any cyclic groups here -- we check for them.+upsweep+    :: GhcMonad m+    => Maybe Messager+    -> HomePackageTable            -- ^ HPT from last time round (pruned)+    -> StableModules               -- ^ stable modules (see checkStability)+    -> (HscEnv -> IO ())           -- ^ How to clean up unwanted tmp files+    -> [SCC ModSummary]            -- ^ Mods to do (the worklist)+    -> m (SuccessFlag,+          [ModSummary])+       -- ^ Returns:+       --+       --  1. A flag whether the complete upsweep was successful.+       --  2. The 'HscEnv' in the monad has an updated HPT+       --  3. A list of modules which succeeded loading.++upsweep mHscMessage old_hpt stable_mods cleanup sccs = do+   dflags <- getSessionDynFlags+   (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs)+                           (unitIdsToCheck dflags) done_holes+   return (res, reverse $ mgModSummaries done)+ where+  done_holes = emptyUniqSet++  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:_) _ _ _ _+   = do dflags <- getSessionDynFlags+        liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)+        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 -> return (Failed, done)+          Just mod_info -> do+                let this_mod = ms_mod_name mod++                        -- Add new info to hsc_env+                    hpt1     = addToHpt (hsc_HPT hsc_env2) this_mod mod_info+                    hsc_env3 = hsc_env2 { hsc_HPT = hpt1, hsc_type_env_var = Nothing }++                        -- Space-saving: delete the old HPT entry+                        -- for mod BUT if mod is a hs-boot+                        -- node, don't delete it.  For the+                        -- interface, the HPT entry is probaby for the+                        -- main Haskell source file.  Deleting it+                        -- would force the real module to be recompiled+                        -- every time.+                    old_hpt1 | isBootSummary mod = old_hpt+                             | otherwise = delFromHpt old_hpt this_mod++                    done' = extendMG done mod++                        -- fixup our HomePackageTable after we've finished compiling+                        -- a mutually-recursive loop.  We have to do this again+                        -- to make sure we have the final unfoldings, which may+                        -- not have been computed accurately in the previous+                        -- retypecheck.+                hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done'+                setSession hsc_env4++                        -- Add any necessary entries to the static pointer+                        -- table. See Note [Grand plan for static forms] in+                        -- StaticPtrTable.+                when (hscTarget (hsc_dflags hsc_env4) == HscInterpreted) $+                    liftIO $ hscAddSptEntries hsc_env4+                                 [ spt+                                 | Just linkable <- pure $ hm_linkable mod_info+                                 , unlinked <- linkableUnlinked linkable+                                 , BCOs _ spts <- pure unlinked+                                 , spt <- spts+                                 ]++                upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes'++unitIdsToCheck :: DynFlags -> [UnitId]+unitIdsToCheck dflags =+  nubSort $ concatMap goUnitId (explicitPackages (pkgState dflags))+ where+  goUnitId uid =+    case splitUnitIdInsts uid of+      (_, Just indef) ->+        let insts = indefUnitIdInsts indef+        in uid : concatMap (goUnitId . moduleUnitId . snd) insts+      _ -> []++maybeGetIfaceDate :: DynFlags -> ModLocation -> IO (Maybe UTCTime)+maybeGetIfaceDate dflags location+ | writeInterfaceOnlyMode dflags+    -- Minor optimization: it should be harmless to check the hi file location+    -- always, but it's better to avoid hitting the filesystem if possible.+    = modificationTimeIfExists (ml_hi_file location)+ | otherwise+    = return Nothing++-- | Compile a single module.  Always produce a Linkable for it if+-- successful.  If no compilation happened, return the old Linkable.+upsweep_mod :: HscEnv+            -> Maybe Messager+            -> HomePackageTable+            -> StableModules+            -> ModSummary+            -> Int  -- index of module+            -> Int  -- total number of modules+            -> IO HomeModInfo+upsweep_mod hsc_env mHscMessage old_hpt (stable_obj, stable_bco) summary mod_index nmods+   =    let+            this_mod_name = ms_mod_name summary+            this_mod    = ms_mod summary+            mb_obj_date = ms_obj_date summary+            mb_if_date  = ms_iface_date summary+            obj_fn      = ml_obj_file (ms_location summary)+            hs_date     = ms_hs_date summary++            is_stable_obj = this_mod_name `elementOfUniqSet` stable_obj+            is_stable_bco = this_mod_name `elementOfUniqSet` stable_bco++            old_hmi = lookupHpt old_hpt this_mod_name++            -- We're using the dflags for this module now, obtained by+            -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.+            dflags = ms_hspp_opts summary+            prevailing_target = hscTarget (hsc_dflags hsc_env)+            local_target      = hscTarget dflags++            -- If OPTIONS_GHC contains -fasm or -fllvm, be careful that+            -- we don't do anything dodgy: these should only work to change+            -- from -fllvm to -fasm and vice-versa, or away from -fno-code,+            -- otherwise we could end up trying to link object code to byte+            -- code.+            target = if prevailing_target /= local_target+                        && (not (isObjectTarget prevailing_target)+                            || not (isObjectTarget local_target))+                        && not (prevailing_target == HscNothing)+                        && not (prevailing_target == HscInterpreted)+                        then prevailing_target+                        else local_target++            -- store the corrected hscTarget into the summary+            summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }++            -- The old interface is ok if+            --  a) we're compiling a source file, and the old HPT+            --     entry is for a source file+            --  b) we're compiling a hs-boot file+            -- Case (b) allows an hs-boot file to get the interface of its+            -- real source file on the second iteration of the compilation+            -- manager, but that does no harm.  Otherwise the hs-boot file+            -- will always be recompiled++            mb_old_iface+                = case old_hmi of+                     Nothing                              -> Nothing+                     Just hm_info | isBootSummary summary -> Just iface+                                  | not (mi_boot iface)   -> Just iface+                                  | otherwise             -> Nothing+                                   where+                                     iface = hm_iface hm_info++            compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo+            compile_it  mb_linkable src_modified =+                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods+                             mb_old_iface mb_linkable src_modified++            compile_it_discard_iface :: Maybe Linkable -> SourceModified+                                     -> IO HomeModInfo+            compile_it_discard_iface mb_linkable  src_modified =+                  compileOne' Nothing mHscMessage hsc_env summary' mod_index nmods+                             Nothing mb_linkable src_modified++            -- With the HscNothing target we create empty linkables to avoid+            -- recompilation.  We have to detect these to recompile anyway if+            -- the target changed since the last compile.+            is_fake_linkable+               | Just hmi <- old_hmi, Just l <- hm_linkable hmi =+                  null (linkableUnlinked l)+               | otherwise =+                   -- we have no linkable, so it cannot be fake+                   False++            implies False _ = True+            implies True x  = x++        in+        case () of+         _+                -- Regardless of whether we're generating object code or+                -- byte code, we can always use an existing object file+                -- if it is *stable* (see checkStability).+          | is_stable_obj, Just hmi <- old_hmi -> do+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5+                           (text "skipping stable obj mod:" <+> ppr this_mod_name)+                return hmi+                -- object is stable, and we have an entry in the+                -- old HPT: nothing to do++          | is_stable_obj, isNothing old_hmi -> do+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5+                           (text "compiling stable on-disk mod:" <+> ppr this_mod_name)+                linkable <- liftIO $ findObjectLinkable this_mod obj_fn+                              (expectJust "upsweep1" mb_obj_date)+                compile_it (Just linkable) SourceUnmodifiedAndStable+                -- object is stable, but we need to load the interface+                -- off disk to make a HMI.++          | not (isObjectTarget target), is_stable_bco,+            (target /= HscNothing) `implies` not is_fake_linkable ->+                ASSERT(isJust old_hmi) -- must be in the old_hpt+                let Just hmi = old_hmi in do+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5+                           (text "skipping stable BCO mod:" <+> ppr this_mod_name)+                return hmi+                -- BCO is stable: nothing to do++          | not (isObjectTarget target),+            Just hmi <- old_hmi,+            Just l <- hm_linkable hmi,+            not (isObjectLinkable l),+            (target /= HscNothing) `implies` not is_fake_linkable,+            linkableTime l >= ms_hs_date summary -> do+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5+                           (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)+                compile_it (Just l) SourceUnmodified+                -- we have an old BCO that is up to date with respect+                -- to the source: do a recompilation check as normal.++          -- When generating object code, if there's an up-to-date+          -- object file on the disk, then we can use it.+          -- However, if the object file is new (compared to any+          -- linkable we had from a previous compilation), then we+          -- must discard any in-memory interface, because this+          -- means the user has compiled the source file+          -- separately and generated a new interface, that we must+          -- read from the disk.+          --+          | isObjectTarget target,+            Just obj_date <- mb_obj_date,+            obj_date >= hs_date -> do+                case old_hmi of+                  Just hmi+                    | Just l <- hm_linkable hmi,+                      isObjectLinkable l && linkableTime l == obj_date -> do+                          liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5+                                     (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)+                          compile_it (Just l) SourceUnmodified+                  _otherwise -> do+                          liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5+                                     (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)+                          linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date+                          compile_it_discard_iface (Just linkable) SourceUnmodified++          -- See Note [Recompilation checking in -fno-code mode]+          | writeInterfaceOnlyMode dflags,+            Just if_date <- mb_if_date,+            if_date >= hs_date -> do+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5+                           (text "skipping tc'd mod:" <+> ppr this_mod_name)+                compile_it Nothing SourceUnmodified++         _otherwise -> do+                liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5+                           (text "compiling mod:" <+> ppr this_mod_name)+                compile_it Nothing SourceModified+++{- Note [-fno-code mode]+~~~~~~~~~~~~~~~~~~~~~~~~+GHC offers the flag -fno-code for the purpose of parsing and typechecking a+program without generating object files. This is intended to be used by tooling+and IDEs to provide quick feedback on any parser or type errors as cheaply as+possible.++When GHC is invoked with -fno-code no object files or linked output will be+generated. As many errors and warnings as possible will be generated, as if+-fno-code had not been passed. The session DynFlags will have+hscTarget == HscNothing.++-fwrite-interface+~~~~~~~~~~~~~~~~+Whether interface files are generated in -fno-code mode is controlled by the+-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is+not also passed. Recompilation avoidance requires interface files, so passing+-fno-code without -fwrite-interface should be avoided. If -fno-code were+re-implemented today, -fwrite-interface would be discarded and it would be+considered always on; this behaviour is as it is for backwards compatibility.++================================================================+IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER+================================================================++Template Haskell+~~~~~~~~~~~~~~~~+A module using template haskell may invoke an imported function from inside a+splice. This will cause the type-checker to attempt to execute that code, which+would fail if no object files had been generated. See #8025. To rectify this,+during the downsweep we patch the DynFlags in the ModSummary of any home module+that is imported by a module that uses template haskell, to generate object+code.++The flavour of generated object code is chosen by defaultObjectTarget for the+target platform. It would likely be faster to generate bytecode, but this is not+supported on all platforms(?Please Confirm?), and does not support the entirety+of GHC haskell. See #1257.++The object files (and interface files if -fwrite-interface is disabled) produced+for template haskell are written to temporary files.++Note that since template haskell can run arbitrary IO actions, -fno-code mode+is no more secure than running without it.++Potential TODOS:+~~~~~+* Remove -fwrite-interface and have interface files always written in -fno-code+  mode+* Both .o and .dyn_o files are generated for template haskell, but we only need+  .dyn_o. Fix it.+* In make mode, a message like+  Compiling A (A.hs, /tmp/ghc_123.o)+  is shown if downsweep enabled object code generation for A. Perhaps we should+  show "nothing" or "temporary object file" instead. Note that one+  can currently use -keep-tmp-files and inspect the generated file with the+  current behaviour.+* Offer a -no-codedir command line option, and write what were temporary+  object files there. This would speed up recompilation.+* Use existing object files (if they are up to date) instead of always+  generating temporary ones.+-}++-- Note [Recompilation checking in -fno-code mode]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- If we are compiling with -fno-code -fwrite-interface, there won't+-- be any object code that we can compare against, nor should there+-- be: we're *just* generating interface files.  In this case, we+-- want to check if the interface file is new, in lieu of the object+-- file.  See also #9243.++-- Filter modules in the HPT+retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable+retainInTopLevelEnvs keep_these hpt+   = listToHpt   [ (mod, expectJust "retain" mb_mod_info)+                 | mod <- keep_these+                 , let mb_mod_info = lookupHpt hpt mod+                 , isJust mb_mod_info ]++-- ---------------------------------------------------------------------------+-- Typecheck module loops+{-+See bug #930.  This code fixes a long-standing bug in --make.  The+problem is that when compiling the modules *inside* a loop, a data+type that is only defined at the top of the loop looks opaque; but+after the loop is done, the structure of the data type becomes+apparent.++The difficulty is then that two different bits of code have+different notions of what the data type looks like.++The idea is that after we compile a module which also has an .hs-boot+file, we re-generate the ModDetails for each of the modules that+depends on the .hs-boot file, so that everyone points to the proper+TyCons, Ids etc. defined by the real module, not the boot module.+Fortunately re-generating a ModDetails from a ModIface is easy: the+function TcIface.typecheckIface does exactly that.++Picking the modules to re-typecheck is slightly tricky.  Starting from+the module graph consisting of the modules that have already been+compiled, we reverse the edges (so they point from the imported module+to the importing module), and depth-first-search from the .hs-boot+node.  This gives us all the modules that depend transitively on the+.hs-boot module, and those are exactly the modules that we need to+re-typecheck.++Following this fix, GHC can compile itself with --make -O2.+-}++reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv+reTypecheckLoop hsc_env ms graph+  | Just loop <- getModLoop ms mss appearsAsBoot+  -- SOME hs-boot files should still+  -- get used, just not the loop-closer.+  , let non_boot = filter (\l -> not (isBootSummary l &&+                                 ms_mod l == ms_mod ms)) loop+  = typecheckLoop (hsc_dflags hsc_env) hsc_env (map ms_mod_name non_boot)+  | otherwise+  = return hsc_env+  where+  mss = mgModSummaries graph+  appearsAsBoot = (`elemModuleSet` mgBootModules graph)++-- | Given a non-boot ModSummary @ms@ of a module, for which there exists a+-- corresponding boot file in @graph@, return the set of modules which+-- transitively depend on this boot file.  This function is slightly misnamed,+-- but its name "getModLoop" alludes to the fact that, when getModLoop is called+-- with a graph that does not contain @ms@ (non-parallel case) or is an+-- SCC with hs-boot nodes dropped (parallel-case), the modules which+-- depend on the hs-boot file are typically (but not always) the+-- modules participating in the recursive module loop.  The returned+-- list includes the hs-boot file.+--+-- Example:+--      let g represent the module graph:+--          C.hs+--          A.hs-boot imports C.hs+--          B.hs imports A.hs-boot+--          A.hs imports B.hs+--      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs]+--+--      It would also be permissible to omit A.hs from the graph,+--      in which case the result is [A.hs-boot, B.hs]+--+-- Example:+--      A counter-example to the claim that modules returned+--      by this function participate in the loop occurs here:+--+--      let g represent the module graph:+--          C.hs+--          A.hs-boot imports C.hs+--          B.hs imports A.hs-boot+--          A.hs imports B.hs+--          D.hs imports A.hs-boot+--      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs, D.hs]+--+--      Arguably, D.hs should import A.hs, not A.hs-boot, but+--      a dependency on the boot file is not illegal.+--+getModLoop+  :: ModSummary+  -> [ModSummary]+  -> (Module -> Bool) -- check if a module appears as a boot module in 'graph'+  -> Maybe [ModSummary]+getModLoop ms graph appearsAsBoot+  | not (isBootSummary ms)+  , appearsAsBoot this_mod+  , let mss = reachableBackwards (ms_mod_name ms) graph+  = Just mss+  | otherwise+  = Nothing+ where+  this_mod = ms_mod ms++-- NB: sometimes mods has duplicates; this is harmless because+-- any duplicates get clobbered in addListToHpt and never get forced.+typecheckLoop :: DynFlags -> HscEnv -> [ModuleName] -> IO HscEnv+typecheckLoop dflags hsc_env mods = do+  debugTraceMsg dflags 2 $+     text "Re-typechecking loop: " <> ppr mods+  new_hpt <-+    fixIO $ \new_hpt -> do+      let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }+      mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $+                mapM (typecheckIface . hm_iface) hmis+      let new_hpt = addListToHpt old_hpt+                        (zip mods [ hmi{ hm_details = details }+                                  | (hmi,details) <- zip hmis mds ])+      return new_hpt+  return hsc_env{ hsc_HPT = new_hpt }+  where+    old_hpt = hsc_HPT hsc_env+    hmis    = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods++reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]+reachableBackwards mod summaries+  = [ node_payload node | node <- reachableG (transposeG graph) root ]+  where -- the rest just sets up the graph:+        (graph, lookup_node) = moduleGraphNodes False summaries+        root  = expectJust "reachableBackwards" (lookup_node HsBootFile mod)++-- ---------------------------------------------------------------------------+--+-- | Topological sort of the module graph+topSortModuleGraph+          :: Bool+          -- ^ Drop hi-boot nodes? (see below)+          -> ModuleGraph+          -> Maybe ModuleName+             -- ^ Root module name.  If @Nothing@, use the full graph.+          -> [SCC ModSummary]+-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes+-- The resulting list of strongly-connected-components is in topologically+-- sorted order, starting with the module(s) at the bottom of the+-- dependency graph (ie compile them first) and ending with the ones at+-- the top.+--+-- Drop hi-boot nodes (first boolean arg)?+--+-- - @False@:   treat the hi-boot summaries as nodes of the graph,+--              so the graph must be acyclic+--+-- - @True@:    eliminate the hi-boot nodes, and instead pretend+--              the a source-import of Foo is an import of Foo+--              The resulting graph has no hi-boot nodes, but can be cyclic++topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod+  = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph+  where+    summaries = mgModSummaries module_graph+    -- stronglyConnCompG flips the original order, so if we reverse+    -- the summaries we get a stable topological sort.+    (graph, lookup_node) =+      moduleGraphNodes drop_hs_boot_nodes (reverse summaries)++    initial_graph = case mb_root_mod of+        Nothing -> graph+        Just root_mod ->+            -- restrict the graph to just those modules reachable from+            -- the specified module.  We do this by building a graph with+            -- the full set of nodes, and determining the reachable set from+            -- the specified node.+            let root | Just node <- lookup_node HsSrcFile root_mod+                     , graph `hasVertexG` node+                     = node+                     | otherwise+                     = throwGhcException (ProgramError "module does not exist")+            in graphFromEdgedVerticesUniq (seq root (reachableG graph root))++type SummaryNode = Node Int ModSummary++summaryNodeKey :: SummaryNode -> Int+summaryNodeKey = node_key++summaryNodeSummary :: SummaryNode -> ModSummary+summaryNodeSummary = node_payload++moduleGraphNodes :: Bool -> [ModSummary]+  -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)+moduleGraphNodes drop_hs_boot_nodes summaries =+  (graphFromEdgedVerticesUniq nodes, lookup_node)+  where+    numbered_summaries = zip summaries [1..]++    lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode+    lookup_node hs_src mod = Map.lookup (mod, hscSourceToIsBoot hs_src) node_map++    lookup_key :: HscSource -> ModuleName -> Maybe Int+    lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)++    node_map :: NodeMap SummaryNode+    node_map = Map.fromList [ ((moduleName (ms_mod s),+                                hscSourceToIsBoot (ms_hsc_src s)), node)+                            | node <- nodes+                            , let s = summaryNodeSummary node ]++    -- We use integers as the keys for the SCC algorithm+    nodes :: [SummaryNode]+    nodes = [ DigraphNode s key out_keys+            | (s, key) <- numbered_summaries+             -- Drop the hi-boot ones if told to do so+            , not (isBootSummary s && drop_hs_boot_nodes)+            , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) +++                             out_edge_keys HsSrcFile   (map unLoc (ms_home_imps s)) +++                             (-- see [boot-edges] below+                              if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile+                              then []+                              else case lookup_key HsBootFile (ms_mod_name s) of+                                    Nothing -> []+                                    Just k  -> [k]) ]++    -- [boot-edges] if this is a .hs and there is an equivalent+    -- .hs-boot, add a link from the former to the latter.  This+    -- has the effect of detecting bogus cases where the .hs-boot+    -- depends on the .hs, by introducing a cycle.  Additionally,+    -- it ensures that we will always process the .hs-boot before+    -- the .hs, and so the HomePackageTable will always have the+    -- most up to date information.++    -- Drop hs-boot nodes by using HsSrcFile as the key+    hs_boot_key | drop_hs_boot_nodes = HsSrcFile+                | otherwise          = HsBootFile++    out_edge_keys :: HscSource -> [ModuleName] -> [Int]+    out_edge_keys hi_boot ms = mapMaybe (lookup_key hi_boot) ms+        -- If we want keep_hi_boot_nodes, then we do lookup_key with+        -- IsBoot; else NotBoot++-- The nodes of the graph are keyed by (mod, is boot?) pairs+-- NB: hsig files show up as *normal* nodes (not boot!), since they don't+-- participate in cycles (for now)+type NodeKey   = (ModuleName, IsBoot)+type NodeMap a = Map.Map NodeKey a++msKey :: ModSummary -> NodeKey+msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot })+    = (moduleName mod, hscSourceToIsBoot boot)++mkNodeMap :: [ModSummary] -> NodeMap ModSummary+mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]++nodeMapElts :: NodeMap a -> [a]+nodeMapElts = Map.elems++-- | If there are {-# SOURCE #-} imports between strongly connected+-- components in the topological sort, then those imports can+-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE+-- were necessary, then the edge would be part of a cycle.+warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()+warnUnnecessarySourceImports sccs = do+  dflags <- getDynFlags+  when (wopt Opt_WarnUnusedImports dflags)+    (logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs)))+  where check dflags ms =+           let mods_in_this_cycle = map ms_mod_name ms in+           [ warn dflags i | m <- ms, i <- ms_home_srcimps m,+                             unLoc i `notElem`  mods_in_this_cycle ]++        warn :: DynFlags -> Located ModuleName -> WarnMsg+        warn dflags (L loc mod) =+           mkPlainErrMsg dflags loc+                (text "Warning: {-# SOURCE #-} unnecessary in import of "+                 <+> quotes (ppr mod))+++reportImportErrors :: MonadIO m => [Either ErrMsg b] -> m [b]+reportImportErrors xs | null errs = return oks+                      | otherwise = throwManyErrors errs+  where (errs, oks) = partitionEithers xs++throwManyErrors :: MonadIO m => [ErrMsg] -> m ab+throwManyErrors errs = liftIO $ throwIO $ mkSrcErr $ listToBag errs+++-----------------------------------------------------------------------------+--+-- | 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 ErrMsg 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 (settings dflags))+           map0+         else if hscTarget dflags == HscInterpreted+           then enableCodeGenForUnboxedTuples+             (defaultObjectTarget (settings 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 ErrMsg ModSummary)+        getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)+           = do exists <- liftIO $ doesFileExist file+                if exists+                    then Right `fmap` summariseFile hsc_env old_summaries file mb_phase+                                       obj_allowed maybe_buf+                    else return $ Left $ 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 ErrMsg 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 ErrMsg 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 ErrMsg 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 ErrMsg ModSummary]+  -> IO (NodeMap [Either ErrMsg 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+-- into GHCi while still allowing some code to be interpreted.+enableCodeGenForUnboxedTuples :: HscTarget+  -> NodeMap [Either ErrMsg ModSummary]+  -> IO (NodeMap [Either ErrMsg ModSummary])+enableCodeGenForUnboxedTuples =+  enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule+  where+    condition ms =+      xopt LangExt.UnboxedTuples (ms_hspp_opts ms) &&+      not (isBootSummary ms)+    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 ErrMsg ModSummary]+  -> IO (NodeMap [Either ErrMsg 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 <-+          if gopt Opt_WriteInterface dflags+            then return $ ml_hi_file ms_location+            else new_temp_file (hiSuf dflags) (dynHiSuf dflags)+        o_temp_file <- new_temp_file (objectSuf dflags) (dynObjectSuf dflags)+        return $+          ms+          { ms_location =+              ms_location {ml_hi_file = hi_file, ml_obj_file = o_temp_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 ErrMsg 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 ]++home_imps :: [(Maybe FastString, Located ModuleName)] -> [Located ModuleName]+home_imps imps = [ lmodname |  (mb_pkg, lmodname) <- imps,+                                  isLocal mb_pkg ]+  where isLocal Nothing = True+        isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special+        isLocal _ = False++ms_home_allimps :: ModSummary -> [ModuleName]+ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)++-- | Like 'ms_home_imps', but for SOURCE imports.+ms_home_srcimps :: ModSummary -> [Located ModuleName]+ms_home_srcimps = home_imps . ms_srcimps++-- | All of the (possibly) home module imports from a+-- 'ModSummary'; that is to say, each of these module names+-- could be a home import if an appropriately named file+-- existed.  (This is in contrast to package qualified+-- imports, which are guaranteed not to be home imports.)+ms_home_imps :: ModSummary -> [Located ModuleName]+ms_home_imps = home_imps . ms_imps++-----------------------------------------------------------------------------+-- 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 ModSummary++summariseFile hsc_env old_summaries file 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 file+   = 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+        if ms_hs_date old_summary == src_timestamp &&+           not (gopt Opt_ForceRecomp (hsc_dflags hsc_env))+           then do -- update the object-file timestamp+                  obj_timestamp <-+                    if isObjectTarget (hscTarget (hsc_dflags hsc_env))+                        || obj_allowed -- bug #1205+                        then liftIO $ getObjTimestamp location NotBoot+                        else return Nothing+                  hi_timestamp <- maybeGetIfaceDate dflags location+                  let hie_location = ml_hie_file location+                  hie_timestamp <- modificationTimeIfExists hie_location++                  -- We have to repopulate the Finder's cache because it+                  -- was flushed before the downsweep.+                  _ <- liftIO $ addHomeModuleToFinder hsc_env+                    (moduleName (ms_mod old_summary)) (ms_location old_summary)++                  return old_summary{ ms_obj_date = obj_timestamp+                                    , ms_iface_date = hi_timestamp+                                    , ms_hie_date = hie_timestamp }+           else+                new_summary src_timestamp++   | otherwise+   = do src_timestamp <- get_src_timestamp+        new_summary src_timestamp+  where+    get_src_timestamp = case maybe_buf of+                           Just (_,t) -> return t+                           Nothing    -> liftIO $ getModificationUTCTime file+                        -- getModificationUTCTime may fail++    new_summary src_timestamp = do+        let dflags = hsc_dflags hsc_env++        let hsc_src = if isHaskellSigFilename file then HsigFile else HsSrcFile++        (dflags', hspp_fn, buf)+            <- preprocessFile hsc_env file mb_phase maybe_buf++        (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file++        -- Make a ModLocation for this file+        location <- liftIO $ mkHomeModLocation dflags mod_name file++        -- 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 mod_name location++        -- 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 <-+            if isObjectTarget (hscTarget (hsc_dflags hsc_env))+               || obj_allowed -- bug #1205+                then liftIO $ modificationTimeIfExists (ml_obj_file location)+                else return Nothing++        hi_timestamp <- maybeGetIfaceDate dflags location+        hie_timestamp <- modificationTimeIfExists (ml_hie_file location)++        extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name+        required_by_imports <- implicitRequirements hsc_env the_imps++        return (ModSummary { ms_mod = mod,+                             ms_hsc_src = hsc_src,+                             ms_location = location,+                             ms_hspp_file = hspp_fn,+                             ms_hspp_opts = dflags',+                             ms_hspp_buf  = Just buf,+                             ms_parsed_mod = Nothing,+                             ms_srcimps = srcimps,+                             ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,+                             ms_hs_date = src_timestamp,+                             ms_iface_date = hi_timestamp,+                             ms_hie_date = hie_timestamp,+                             ms_obj_date = obj_timestamp })++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++-- 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 ErrMsg 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) -> check_timestamp old_summary location src_fn t+           Nothing    -> do+                m <- tryIO (getModificationUTCTime src_fn)+                case m of+                   Right t -> 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 src_timestamp+        | ms_hs_date old_summary == src_timestamp &&+          not (gopt Opt_ForceRecomp dflags) = do+                -- update the object-file timestamp+                obj_timestamp <-+                    if isObjectTarget (hscTarget (hsc_dflags hsc_env))+                       || obj_allowed -- bug #1205+                       then getObjTimestamp location is_boot+                       else return Nothing+                hi_timestamp <- maybeGetIfaceDate dflags location+                hie_timestamp <- modificationTimeIfExists (ml_hie_file location)+                return (Just (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 location (ms_mod old_summary) src_fn src_timestamp++    find_it = do+        found <- findImportedModule hsc_env wanted_mod Nothing+        case found of+             Found location mod+                | isJust (ml_hs_file location) ->+                        -- Home package+                         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 $ Just $ Left $ noHsFileErr dflags loc src_fn+          Just t  -> new_summary location' mod src_fn t+++    new_summary location mod src_fn src_timestamp+      = do+        -- Preprocess the source file and get its imports+        -- The dflags' contains the OPTIONS pragmas+        (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf+        (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn++        -- 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 (mod_name /= wanted_mod) $+                throwOneError $ mkPlainErrMsg dflags' mod_loc $+                              text "File name does not match module name:"+                              $$ text "Saw:" <+> quotes (ppr mod_name)+                              $$ text "Expected:" <+> quotes (ppr wanted_mod)++        when (hsc_src == HsigFile && isNothing (lookup mod_name (thisUnitIdInsts dflags))) $+            let suggested_instantiated_with =+                    hcat (punctuate comma $+                        [ ppr k <> text "=" <> ppr v+                        | (k,v) <- ((mod_name, mkHoleModule mod_name)+                                : thisUnitIdInsts dflags)+                        ])+            in throwOneError $ mkPlainErrMsg dflags' mod_loc $+                text "Unexpected signature:" <+> quotes (ppr mod_name)+                $$ if gopt Opt_BuildingCabalPackage dflags+                    then parens (text "Try adding" <+> quotes (ppr 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 mod_name <> text "> as necessary.")++                -- Find the object timestamp, and return the summary+        obj_timestamp <-+           if isObjectTarget (hscTarget (hsc_dflags hsc_env))+              || obj_allowed -- bug #1205+              then getObjTimestamp location is_boot+              else return Nothing++        hi_timestamp <- maybeGetIfaceDate dflags location+        hie_timestamp <- modificationTimeIfExists (ml_hie_file location)++        extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name+        required_by_imports <- implicitRequirements hsc_env the_imps++        return (Just (Right (ModSummary { ms_mod       = mod,+                              ms_hsc_src   = hsc_src,+                              ms_location  = location,+                              ms_hspp_file = hspp_fn,+                              ms_hspp_opts = dflags',+                              ms_hspp_buf  = Just buf,+                              ms_parsed_mod = Nothing,+                              ms_srcimps      = srcimps,+                              ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,+                              ms_hs_date   = 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)+++preprocessFile :: HscEnv+               -> FilePath+               -> Maybe Phase -- ^ Starting phase+               -> Maybe (StringBuffer,UTCTime)+               -> IO (DynFlags, FilePath, StringBuffer)+preprocessFile hsc_env src_fn mb_phase Nothing+  = do+        (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)+        buf <- hGetStringBuffer hspp_fn+        return (dflags', hspp_fn, buf)++preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))+  = do+        let dflags = hsc_dflags hsc_env+        let local_opts = getOptions dflags buf src_fn++        (dflags', leftovers, warns)+            <- parseDynamicFilePragma dflags local_opts+        checkProcessArgsResult dflags leftovers+        handleFlagWarnings dflags' warns++        let needs_preprocessing+                | Just (Unlit _) <- mb_phase    = True+                | Nothing <- mb_phase, Unlit _ <- startPhase src_fn  = True+                  -- note: local_opts is only required if there's no Unlit phase+                | xopt LangExt.Cpp dflags'      = True+                | gopt Opt_Pp  dflags'          = True+                | otherwise                     = False++        when needs_preprocessing $+           throwGhcExceptionIO (ProgramError "buffer needs preprocesing; interactive check disabled")++        return (dflags', src_fn, buf)+++-----------------------------------------------------------------------------+--                      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 -> ErrMsg+noHsFileErr dflags loc path+  = mkPlainErrMsg dflags loc $ text "Can't find" <+> text path++moduleNotFoundErr :: DynFlags -> ModuleName -> ErrMsg+moduleNotFoundErr dflags mod+  = 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++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 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 GhcPlugins".+--+-- Particularly interesting modules for plugin writers include+-- "CoreSyn" and "CoreMonad".+module GhcPlugins(+        module Plugins,+        module RdrName, module OccName, module Name, module Var, module Id, module IdInfo,+        module CoreMonad, module CoreSyn, module Literal, module DataCon,+        module CoreUtils, module MkCore, module CoreFVs, module CoreSubst,+        module Rules, module Annotations,+        module DynFlags, module Packages,+        module Module, module Type, module TyCon, module Coercion,+        module TysWiredIn, module HscTypes, module BasicTypes,+        module VarSet, module VarEnv, module NameSet, module NameEnv,+        module UniqSet, module UniqFM, module FiniteMap,+        module Util, module GHC.Serialized, module SrcLoc, module Outputable,+        module UniqSupply, module Unique, module FastString,++        -- * Getting 'Name's+        thNameToGhcName+    ) where++-- Plugin stuff itself+import Plugins++-- Variable naming+import RdrName+import OccName  hiding  ( varName {- conflicts with Var.varName -} )+import Name     hiding  ( varName {- reexport from OccName, conflicts with Var.varName -} )+import Var+import Id       hiding  ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} )+import IdInfo++-- Core+import CoreMonad+import CoreSyn+import Literal+import DataCon+import CoreUtils+import MkCore+import CoreFVs+import CoreSubst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst )+       -- These names are also exported by Type++-- Core "extras"+import Rules+import Annotations++-- Pipeline-related stuff+import DynFlags+import Packages++-- Important GHC types+import Module+import Type     hiding {- conflict with CoreSubst -}+                ( substTy, extendTvSubst, extendTvSubstList, isInScope )+import Coercion hiding {- conflict with CoreSubst -}+                ( substCo )+import TyCon+import TysWiredIn+import HscTypes+import BasicTypes hiding ( Version {- conflicts with Packages.Version -} )++-- Collections and maps+import VarSet+import VarEnv+import NameSet+import NameEnv+import UniqSet+import UniqFM+-- Conflicts with UniqFM:+--import LazyUniqFM+import FiniteMap++-- Common utilities+import Util+import GHC.Serialized+import SrcLoc+import Outputable+import UniqSupply+import Unique           ( Unique, Uniquable(..) )+import FastString+import Data.Maybe++import IfaceEnv         ( lookupOrigIO )+import GhcPrelude+import MonadUtils       ( mapMaybeM )+import Convert          ( 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/HeaderInfo.hs view
@@ -0,0 +1,352 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+--+-- | Parsing the top of a Haskell source file to get its module name,+-- imports and options.+--+-- (c) Simon Marlow 2005+-- (c) Lemmih 2006+--+-----------------------------------------------------------------------------++module HeaderInfo ( getImports+                  , mkPrelImports -- used by the renamer too+                  , getOptionsFromFile, getOptions+                  , optionsErrorMsgs,+                    checkProcessArgsResult ) where++#include "HsVersions.h"++import GhcPrelude++import HscTypes+import Parser           ( parseHeader )+import Lexer+import FastString+import HsSyn+import Module+import PrelNames+import StringBuffer+import SrcLoc+import DynFlags+import ErrUtils+import Util+import Outputable+import Pretty           ()+import Maybes+import Bag              ( emptyBag, listToBag, unitBag )+import MonadUtils+import Exception+import BasicTypes+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import System.IO+import System.IO.Unsafe+import Data.List++------------------------------------------------------------------------------++-- | Parse the imports of a source file.+--+-- Throws a 'SourceError' if parsing fails.+getImports :: DynFlags+           -> StringBuffer -- ^ Parse this.+           -> FilePath     -- ^ Filename the buffer came from.  Used for+                           --   reporting parse error locations.+           -> FilePath     -- ^ The original source filename (used for locations+                           --   in the function result)+           -> IO ([(Maybe FastString, Located ModuleName)],+                  [(Maybe FastString, Located ModuleName)],+                  Located ModuleName)+              -- ^ The source imports, normal imports, and the module name.+getImports dflags buf filename source_filename = do+  let loc  = mkRealSrcLoc (mkFastString filename) 1 1+  case unP parseHeader (mkPState dflags buf loc) of+    PFailed pst -> do+        -- assuming we're not logging warnings here as per below+      throwErrors (getErrorMessages pst dflags)+    POk pst rdr_module -> do+      let _ms@(_warns, errs) = getMessages pst dflags+      -- don't log warnings: they'll be reported when we parse the file+      -- for real.  See #2500.+          ms = (emptyBag, errs)+      -- logWarnings warns+      if errorsFound dflags ms+        then throwIO $ mkSrcErr errs+        else+          let   hsmod = unLoc rdr_module+                mb_mod = hsmodName hsmod+                imps = hsmodImports hsmod+                main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename)+                                       1 1)+                mod = mb_mod `orElse` cL main_loc mAIN_NAME+                (src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps++               -- GHC.Prim doesn't exist physically, so don't go looking for it.+                ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc+                                        . ideclName . unLoc)+                                       ord_idecls++                implicit_prelude = xopt LangExt.ImplicitPrelude dflags+                implicit_imports = mkPrelImports (unLoc mod) main_loc+                                                 implicit_prelude imps+                convImport (dL->L _ i) = (fmap sl_fs (ideclPkgQual i)+                                         , ideclName i)+              in+              return (map convImport src_idecls,+                      map convImport (implicit_imports ++ ordinary_imps),+                      mod)++mkPrelImports :: ModuleName+              -> SrcSpan    -- Attribute the "import Prelude" to this location+              -> Bool -> [LImportDecl GhcPs]+              -> [LImportDecl GhcPs]+-- Construct the implicit declaration "import Prelude" (or not)+--+-- NB: opt_NoImplicitPrelude is slightly different to import Prelude ();+-- because the former doesn't even look at Prelude.hi for instance+-- declarations, whereas the latter does.+mkPrelImports this_mod loc implicit_prelude import_decls+  | this_mod == pRELUDE_NAME+   || explicit_prelude_import+   || not implicit_prelude+  = []+  | otherwise = [preludeImportDecl]+  where+      explicit_prelude_import+       = notNull [ () | (dL->L _ (ImportDecl { ideclName = mod+                                        , ideclPkgQual = Nothing }))+                          <- import_decls+                      , unLoc mod == pRELUDE_NAME ]++      preludeImportDecl :: LImportDecl GhcPs+      preludeImportDecl+        = cL loc $ ImportDecl { ideclExt       = noExt,+                                ideclSourceSrc = NoSourceText,+                                ideclName      = cL loc pRELUDE_NAME,+                                ideclPkgQual   = Nothing,+                                ideclSource    = False,+                                ideclSafe      = False,  -- Not a safe import+                                ideclQualified = NotQualified,+                                ideclImplicit  = True,   -- Implicit!+                                ideclAs        = Nothing,+                                ideclHiding    = Nothing  }++--------------------------------------------------------------+-- Get options+--------------------------------------------------------------++-- | Parse OPTIONS and LANGUAGE pragmas of the source file.+--+-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)+getOptionsFromFile :: DynFlags+                   -> FilePath            -- ^ Input file+                   -> IO [Located String] -- ^ Parsed options, if any.+getOptionsFromFile dflags filename+    = Exception.bracket+              (openBinaryFile filename ReadMode)+              (hClose)+              (\handle -> do+                  opts <- fmap (getOptions' dflags)+                               (lazyGetToks dflags' filename handle)+                  seqList opts $ return opts)+    where -- We don't need to get haddock doc tokens when we're just+          -- getting the options from pragmas, and lazily lexing them+          -- correctly is a little tricky: If there is "\n" or "\n-"+          -- left at the end of a buffer then the haddock doc may+          -- continue past the end of the buffer, despite the fact that+          -- we already have an apparently-complete token.+          -- We therefore just turn Opt_Haddock off when doing the lazy+          -- lex.+          dflags' = gopt_unset dflags Opt_Haddock++blockSize :: Int+-- blockSize = 17 -- for testing :-)+blockSize = 1024++lazyGetToks :: DynFlags -> FilePath -> Handle -> IO [Located Token]+lazyGetToks dflags filename handle = do+  buf <- hGetStringBufferBlock handle blockSize+  unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False blockSize+ where+  loc  = mkRealSrcLoc (mkFastString filename) 1 1++  lazyLexBuf :: Handle -> PState -> Bool -> Int -> IO [Located Token]+  lazyLexBuf handle state eof size = do+    case unP (lexer False return) state of+      POk state' t -> do+        -- pprTrace "lazyLexBuf" (text (show (buffer state'))) (return ())+        if atEnd (buffer state') && not eof+           -- if this token reached the end of the buffer, and we haven't+           -- necessarily read up to the end of the file, then the token might+           -- be truncated, so read some more of the file and lex it again.+           then getMore handle state size+           else case unLoc t of+                  ITeof  -> return [t]+                  _other -> do rest <- lazyLexBuf handle state' eof size+                               return (t : rest)+      _ | not eof   -> getMore handle state size+        | otherwise -> return [cL (RealSrcSpan (last_loc state)) ITeof]+                         -- parser assumes an ITeof sentinel at the end++  getMore :: Handle -> PState -> Int -> IO [Located Token]+  getMore handle state size = do+     -- pprTrace "getMore" (text (show (buffer state))) (return ())+     let new_size = size * 2+       -- double the buffer size each time we read a new block.  This+       -- counteracts the quadratic slowdown we otherwise get for very+       -- large module names (#5981)+     nextbuf <- hGetStringBufferBlock handle new_size+     if (len nextbuf == 0) then lazyLexBuf handle state True new_size else do+       newbuf <- appendStringBuffers (buffer state) nextbuf+       unsafeInterleaveIO $ lazyLexBuf handle state{buffer=newbuf} False new_size+++getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token]+getToks dflags filename buf = lexAll (pragState dflags buf loc)+ where+  loc  = mkRealSrcLoc (mkFastString filename) 1 1++  lexAll state = case unP (lexer False return) state of+                   POk _      t@(dL->L _ ITeof) -> [t]+                   POk state' t -> t : lexAll state'+                   _ -> [cL (RealSrcSpan (last_loc state)) ITeof]+++-- | Parse OPTIONS and LANGUAGE pragmas of the source file.+--+-- Throws a 'SourceError' if flag parsing fails (including unsupported flags.)+getOptions :: DynFlags+           -> StringBuffer -- ^ Input Buffer+           -> FilePath     -- ^ Source filename.  Used for location info.+           -> [Located String] -- ^ Parsed options.+getOptions dflags buf filename+    = getOptions' dflags (getToks dflags filename buf)++-- The token parser is written manually because Happy can't+-- return a partial result when it encounters a lexer error.+-- We want to extract options before the buffer is passed through+-- CPP, so we can't use the same trick as 'getImports'.+getOptions' :: DynFlags+            -> [Located Token]      -- Input buffer+            -> [Located String]     -- Options.+getOptions' dflags toks+    = parseToks toks+    where+          parseToks (open:close:xs)+              | IToptions_prag str <- unLoc open+              , ITclose_prag       <- unLoc close+              = case toArgs str of+                  Left _err -> optionsParseError str dflags $   -- #15053+                                 combineSrcSpans (getLoc open) (getLoc close)+                  Right args -> map (cL (getLoc open)) args ++ parseToks xs+          parseToks (open:close:xs)+              | ITinclude_prag str <- unLoc open+              , ITclose_prag       <- unLoc close+              = map (cL (getLoc open)) ["-#include",removeSpaces str] +++                parseToks xs+          parseToks (open:close:xs)+              | ITdocOptions str <- unLoc open+              , ITclose_prag     <- unLoc close+              = map (cL (getLoc open)) ["-haddock-opts", removeSpaces str]+                ++ parseToks xs+          parseToks (open:xs)+              | ITlanguage_prag <- unLoc open+              = parseLanguage xs+          parseToks (comment:xs) -- Skip over comments+              | isComment (unLoc comment)+              = parseToks xs+          parseToks _ = []+          parseLanguage ((dL->L loc (ITconid fs)):rest)+              = checkExtension dflags (cL loc fs) :+                case rest of+                  (dL->L _loc ITcomma):more -> parseLanguage more+                  (dL->L _loc ITclose_prag):more -> parseToks more+                  (dL->L loc _):_ -> languagePragParseError dflags loc+                  [] -> panic "getOptions'.parseLanguage(1) went past eof token"+          parseLanguage (tok:_)+              = languagePragParseError dflags (getLoc tok)+          parseLanguage []+              = panic "getOptions'.parseLanguage(2) went past eof token"++          isComment :: Token -> Bool+          isComment c =+            case c of+              (ITlineComment {})     -> True+              (ITblockComment {})    -> True+              (ITdocCommentNext {})  -> True+              (ITdocCommentPrev {})  -> True+              (ITdocCommentNamed {}) -> True+              (ITdocSection {})      -> True+              _                      -> False++-----------------------------------------------------------------------------++-- | Complain about non-dynamic flags in OPTIONS pragmas.+--+-- Throws a 'SourceError' if the input list is non-empty claiming that the+-- input flags are unknown.+checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m ()+checkProcessArgsResult dflags flags+  = when (notNull flags) $+      liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags+    where mkMsg (dL->L loc flag)+              = mkPlainErrMsg dflags loc $+                  (text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+>+                   text flag)++-----------------------------------------------------------------------------++checkExtension :: DynFlags -> Located FastString -> Located String+checkExtension dflags (dL->L l ext)+-- Checks if a given extension is valid, and if so returns+-- its corresponding flag. Otherwise it throws an exception.+ =  let ext' = unpackFS ext in+    if ext' `elem` supportedLanguagesAndExtensions+    then cL l ("-X"++ext')+    else unsupportedExtnError dflags l ext'++languagePragParseError :: DynFlags -> SrcSpan -> a+languagePragParseError dflags loc =+    throwErr dflags loc $+       vcat [ text "Cannot parse LANGUAGE pragma"+            , text "Expecting comma-separated list of language options,"+            , text "each starting with a capital letter"+            , nest 2 (text "E.g. {-# LANGUAGE TemplateHaskell, GADTs #-}") ]++unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a+unsupportedExtnError dflags loc unsup =+    throwErr dflags loc $+        text "Unsupported extension: " <> text unsup $$+        if null suggestions then Outputable.empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)+  where+     suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions+++optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages+optionsErrorMsgs dflags unhandled_flags flags_lines _filename+  = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))+  where unhandled_flags_lines :: [Located String]+        unhandled_flags_lines = [ cL l f+                                | f <- unhandled_flags+                                , (dL->L l f') <- flags_lines+                                , f == f' ]+        mkMsg (dL->L flagSpan flag) =+            ErrUtils.mkPlainErrMsg dflags flagSpan $+                    text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag++optionsParseError :: String -> DynFlags -> SrcSpan -> a     -- #15053+optionsParseError str dflags loc =+  throwErr dflags loc $+      vcat [ text "Error while parsing OPTIONS_GHC pragma."+           , text "Expecting whitespace-separated list of GHC options."+           , text "  E.g. {-# OPTIONS_GHC -Wall -O2 #-}"+           , text ("Input was: " ++ show str) ]++throwErr :: DynFlags -> SrcSpan -> SDoc -> a                -- #15053+throwErr dflags loc doc =+  throw $ mkSrcErr $ unitBag $ mkPlainErrMsg dflags loc doc
+ compiler/main/HscMain.hs view
@@ -0,0 +1,1882 @@+{-# 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+    , 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+    , hscCompileCoreExpr+    -- * Low-level exports for hooks+    , hscCompileCoreExpr'+      -- We want to make sure that we export enough to be able to redefine+      -- hscFileFrontEnd in client code+    , hscParse', hscSimplify', hscDesugar', tcRnModule'+    , getHscEnv+    , hscSimpleIface', hscNormalIface'+    , 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 HsSyn+import HsDumpAst+import CoreSyn+import StringBuffer+import Parser+import Lexer+import SrcLoc+import TcRnDriver+import TcIface          ( typecheckIface )+import TcRnMonad+import NameCache        ( initNameCache )+import LoadIface        ( ifaceStats, initExternalPackageState )+import PrelInfo+import MkIface+import Desugar+import SimplCore+import TidyPgm+import CorePrep+import CoreToStg        ( coreToStg )+import qualified StgCmm ( codeGen )+import StgSyn+import StgFVs           ( annTopBindingsFreeVars )+import CostCentre+import ProfInit+import TyCon+import Name+import SimplStg         ( stg2stg )+import Cmm+import CmmParse         ( parseCmmFile )+import CmmBuildInfoTables+import CmmPipeline+import CmmInfo+import CodeOutput+import InstEnv+import FamInstEnv+import Fingerprint      ( Fingerprint )+import Hooks+import TcEnv+import PrelNames+import Plugins+import DynamicLoading   ( initializePlugins )++import DynFlags+import ErrUtils+import Platform ( platformOS, osSubsectionsViaSymbols )++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 HieAst           ( mkHieFile )+import HieTypes         ( getAsts, hie_asts )+import HieBin           ( readHieFile, writeHieFile )+import HieDebug         ( diffFile, validateScopes )++#include "HsVersions.h"+++{- **********************************************************************+%*                                                                      *+                Initialisation+%*                                                                      *+%********************************************************************* -}++newHscEnv :: DynFlags -> IO HscEnv+newHscEnv dflags = do+    eps_var <- newIORef initExternalPackageState+    us      <- mkSplitUniqSupply 'r'+    nc_var  <- newIORef (initNameCache us knownKeyNames)+    fc_var  <- newIORef emptyInstalledModuleEnv+    iserv_mvar <- newMVar Nothing+    emptyDynLinker <- uninitializedLinker+    return HscEnv {  hsc_dflags       = dflags+                  ,  hsc_targets      = []+                  ,  hsc_mod_graph    = emptyMG+                  ,  hsc_IC           = emptyInteractiveContext dflags+                  ,  hsc_HPT          = emptyHomePackageTable+                  ,  hsc_EPS          = eps_var+                  ,  hsc_NC           = nc_var+                  ,  hsc_FC           = fc_var+                  ,  hsc_type_env_var = Nothing+                  ,  hsc_iserv        = iserv_mvar+                  ,  hsc_dynLinker    = emptyDynLinker+                  }++-- -----------------------------------------------------------------------------++getWarnings :: Hsc WarningMessages+getWarnings = Hsc $ \_ w -> return (w, w)++clearWarnings :: Hsc ()+clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)++logWarnings :: WarningMessages -> Hsc ()+logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)++getHscEnv :: Hsc HscEnv+getHscEnv = Hsc $ \e w -> return (e, w)++handleWarnings :: Hsc ()+handleWarnings = do+    dflags <- getDynFlags+    w <- getWarnings+    liftIO $ printOrThrowWarnings dflags w+    clearWarnings++-- | log warning in the monad, and if there are errors then+-- throw a SourceError exception.+logWarningsReportErrors :: Messages -> Hsc ()+logWarningsReportErrors (warns,errs) = do+    logWarnings warns+    when (not $ isEmptyBag errs) $ throwErrors errs++-- | Log warnings and throw errors, assuming the messages+-- contain at least one error (e.g. coming from PFailed)+handleWarningsThrowErrors :: Messages -> Hsc a+handleWarningsThrowErrors (warns, errs) = do+    logWarnings warns+    dflags <- getDynFlags+    (wWarns, wErrs) <- warningsToMessages dflags <$> getWarnings+    liftIO $ printBagOfErrors dflags wWarns+    throwErrors (unionBags errs wErrs)++-- | Deal with errors and warnings returned by a compilation step+--+-- In order to reduce dependencies to other parts of the compiler, functions+-- outside the "main" parts of GHC return warnings and errors as a parameter+-- and signal success via by wrapping the result in a 'Maybe' type. This+-- function logs the returned warnings and propagates errors as exceptions+-- (of type 'SourceError').+--+-- This function assumes the following invariants:+--+--  1. If the second result indicates success (is of the form 'Just x'),+--     there must be no error messages in the first result.+--+--  2. If there are no error messages, but the second result indicates failure+--     there should be warnings in the first result. That is, if the action+--     failed, it must have been due to the warnings (i.e., @-Werror@).+ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a+ioMsgMaybe ioA = do+    ((warns,errs), mb_r) <- liftIO ioA+    logWarnings warns+    case mb_r of+        Nothing -> throwErrors errs+        Just r  -> ASSERT( isEmptyBag errs ) return r++-- | like ioMsgMaybe, except that we ignore error messages and return+-- 'Nothing' instead.+ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)+ioMsgMaybe' ioA = do+    ((warns,_errs), mb_r) <- liftIO $ ioA+    logWarnings warns+    return mb_r++-- -----------------------------------------------------------------------------+-- | Lookup things in the compiler's environment++hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name]+hscTcRnLookupRdrName hsc_env0 rdr_name+  = runInteractiveHsc hsc_env0 $+    do { hsc_env <- getHscEnv+       ; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name }++hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)+hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe' $ tcRnLookupName hsc_env name+      -- ignore errors: the only error we're likely to get is+      -- "name not found", and the Maybe in the return type+      -- is used to indicate that.++hscTcRnGetInfo :: HscEnv -> Name+               -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))+hscTcRnGetInfo hsc_env0 name+  = runInteractiveHsc hsc_env0 $+    do { hsc_env <- getHscEnv+       ; ioMsgMaybe' $ tcRnGetInfo hsc_env name }++hscIsGHCiMonad :: HscEnv -> String -> IO Name+hscIsGHCiMonad hsc_env name+  = runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name++hscGetModuleInterface :: HscEnv -> Module -> IO ModIface+hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe $ getModuleInterface hsc_env mod++-- -----------------------------------------------------------------------------+-- | Rename some import declarations+hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv+hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe $ tcRnImportDecls hsc_env import_decls++-- -----------------------------------------------------------------------------+-- | parse a file, returning the abstract syntax++hscParse :: HscEnv -> ModSummary -> IO HsParsedModule+hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary++-- internal version, that doesn't fail due to -Werror+hscParse' :: ModSummary -> Hsc HsParsedModule+hscParse' mod_summary+ | Just r <- ms_parsed_mod mod_summary = return r+ | otherwise = {-# SCC "Parser" #-}+    withTiming getDynFlags+               (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))+               (const ()) $ do+    dflags <- getDynFlags+    let src_filename  = ms_hspp_file mod_summary+        maybe_src_buf = ms_hspp_buf  mod_summary++    --------------------------  Parser  ----------------+    -- sometimes we already have the buffer in memory, perhaps+    -- because we needed to parse the imports out of it, or get the+    -- module name.+    buf <- case maybe_src_buf of+               Just b  -> return b+               Nothing -> liftIO $ hGetStringBuffer src_filename++    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1+    let parseMod | HsigFile == ms_hsc_src mod_summary+                 = parseSignature+                 | otherwise = parseModule++    case unP parseMod (mkPState dflags buf loc) of+        PFailed pst ->+            handleWarningsThrowErrors (getMessages pst dflags)+        POk pst rdr_module -> do+            let (warns, errs) = getMessages pst dflags+            logWarnings warns+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $+                                   ppr rdr_module+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $+                                   showAstData NoBlankSrcSpan rdr_module+            liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $+                                   ppSourceStats False rdr_module+            when (not $ isEmptyBag errs) $ throwErrors errs++            -- To get the list of extra source files, we take the list+            -- that the parser gave us,+            --   - eliminate files beginning with '<'.  gcc likes to use+            --     pseudo-filenames like "<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" $+                           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+              case validateScopes $ 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 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++    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 -> (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!"++-- | 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 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+--------------------------------------------------------------++-- Compile Haskell/boot in OneShot mode.+hscIncrementalCompile :: Bool+                      -> Maybe TcGblEnv+                      -> Maybe Messager+                      -> HscEnv+                      -> ModSummary+                      -> SourceModified+                      -> Maybe ModIface+                      -> (Int,Int)+                      -- HomeModInfo does not contain linkable, since we haven't+                      -- code-genned yet+                      -> IO (HscStatus, HomeModInfo)+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]+            hmi <- liftIO . fixIO $ \hmi' -> do+                let hsc_env' =+                        hsc_env {+                            hsc_HPT = addToHpt (hsc_HPT hsc_env)+                                        (ms_mod_name mod_summary) hmi'+                        }+                -- 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 HomeModInfo{+                    hm_details = details,+                    hm_iface = iface,+                    hm_linkable = Nothing }+            return (HscUpToDate, hmi)+        -- 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) ->+            finish mod_summary tc_result mb_old_hash++-- Runs the post-typechecking frontend (desugar and simplify),+-- and then generates and writes out the final interface. We want+-- to write the interface AFTER simplification so we can get+-- as up-to-date and good unfoldings and other info as possible+-- in the interface file.+finish :: ModSummary+       -> TcGblEnv+       -> Maybe Fingerprint+       -> Hsc (HscStatus, HomeModInfo)+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 = do+        let hsc_status =+              case (target, hsc_src) of+                (HscNothing, _) -> HscNotGeneratingCode+                (_, HsBootFile) -> HscUpdateBoot+                (_, HsigFile) -> HscUpdateSig+                _ -> panic "finish"+        (iface, no_change, details) <- liftIO $+          hscSimpleIface hsc_env tc_result mb_old_hash+        return (iface, no_change, details, hsc_status)+  (iface, no_change, details, hsc_status) <-+    -- 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.+    if should_desugar+      then do+        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+            (iface, no_change, details, cgguts) <-+              liftIO $ hscNormalIface hsc_env desugared_guts mb_old_hash+            return (iface, no_change, details, HscRecomp cgguts summary)+      else mk_simple_iface+  liftIO $ hscMaybeWriteIface dflags iface no_change summary+  return+    ( hsc_status+    , HomeModInfo+      {hm_details = details, hm_iface = iface, hm_linkable = Nothing})++hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()+hscMaybeWriteIface dflags iface no_change summary =+    let force_write_interface = gopt Opt_WriteInterface dflags+        write_interface = case hscTarget dflags of+                            HscNothing      -> False+                            HscInterpreted  -> False+                            _               -> True+    in when (write_interface || force_write_interface) $+            hscWriteIface dflags iface no_change summary++--------------------------------------------------------------+-- 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 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 _)) = panic "hscCheckSafeImports"++-- | Validate that safe imported modules are actually safe.  For modules in the+-- HomePackage (the package the module we are compiling in resides) this just+-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules+-- that reside in another package we also must check that the external package+-- is trusted. See the Note [Safe Haskell Trust Check] above for more+-- information.+--+-- The code for this is quite tricky as the whole algorithm is done in a few+-- distinct phases in different parts of the code base. See+-- RnNames.rnImportDecl for where package trust dependencies for a module are+-- collected and unioned.  Specifically see the Note [RnNames . Tracking Trust+-- Transitively] and the Note [RnNames . Trust Own Package].+checkSafeImports :: TcGblEnv -> Hsc TcGblEnv+checkSafeImports tcg_env+    = do+        dflags <- getDynFlags+        imps <- mapM condense imports'+        let (safeImps, regImps) = partition (\(_,_,s) -> s) imps++        -- We want to use the warning state specifically for detecting if safe+        -- inference has failed, so store and clear any existing warnings.+        oldErrs <- getWarnings+        clearWarnings++        -- Check safe imports are correct+        safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps+        safeErrs <- getWarnings+        clearWarnings++        -- Check non-safe imports are correct if inferring safety+        -- See the Note [Safe Haskell Inference]+        (infErrs, infPkgs) <- case (safeInferOn dflags) of+          False -> return (emptyBag, S.empty)+          True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps+                     infErrs <- getWarnings+                     clearWarnings+                     return (infErrs, infPkgs)++        -- restore old errors+        logWarnings oldErrs++        case (isEmptyBag safeErrs) of+          -- Failed safe check+          False -> liftIO . throwIO . mkSrcErr $ safeErrs++          -- Passed safe check+          True -> do+            let infPassed = isEmptyBag infErrs+            tcg_env' <- case (not infPassed) of+              True  -> markUnsafeInfer tcg_env infErrs+              False -> return tcg_env+            when (packageTrustOn dflags) $ checkPkgTrust pkgReqs+            let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed+            return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }++  where+    impInfo  = tcg_imports tcg_env     -- ImportAvails+    imports  = imp_mods impInfo        -- ImportedMods+    imports1 = moduleEnvToList imports -- (Module, [ImportedBy])+    imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal])+    pkgReqs  = imp_trust_pkgs impInfo  -- [UnitId]++    condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)+    condense (_, [])   = panic "HscMain.condense: Pattern match failure!"+    condense (m, x:xs) = do imv <- foldlM cond' x xs+                            return (m, imv_span imv, imv_is_safe imv)++    -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)+    cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal+    cond' v1 v2+        | imv_is_safe v1 /= imv_is_safe v2+        = do+            dflags <- getDynFlags+            throwOneError $ mkPlainErrMsg dflags (imv_span v1)+              (text "Module" <+> ppr (imv_name v1) <+>+              (text $ "is imported both as a safe and unsafe import!"))+        | otherwise+        = return v1++    -- easier interface to work with+    checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)+    checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l++    -- what pkg's to add to our trust requirements+    pkgTrustReqs :: DynFlags -> Set InstalledUnitId -> Set InstalledUnitId ->+          Bool -> ImportAvails+    pkgTrustReqs dflags req inf infPassed | safeInferOn dflags+                                  && not (safeHaskellModeEnabled dflags) && infPassed+                                   = emptyImportAvails {+                                       imp_trust_pkgs = req `S.union` inf+                                   }+    pkgTrustReqs dflags _   _ _ | safeHaskell dflags == Sf_Unsafe+                         = emptyImportAvails+    pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req }++-- | Check that a module is safe to import.+--+-- We return True to indicate the import is safe and False otherwise+-- although in the False case an exception may be thrown first.+hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool+hscCheckSafe hsc_env m l = runHsc hsc_env $ do+    dflags <- getDynFlags+    pkgs <- snd `fmap` hscCheckSafe' m l+    when (packageTrustOn dflags) $ checkPkgTrust pkgs+    errs <- getWarnings+    return $ isEmptyBag errs++-- | Return if a module is trusted and the pkgs it depends on to be trusted.+hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId)+hscGetSafe hsc_env m l = runHsc hsc_env $ do+    (self, pkgs) <- hscCheckSafe' m l+    good         <- isEmptyBag `fmap` getWarnings+    clearWarnings -- don't want them printed...+    let pkgs' | Just p <- self = S.insert p pkgs+              | otherwise      = pkgs+    return (good, pkgs')++-- | Is a module trusted? If not, throw or log errors depending on the type.+-- Return (regardless of trusted or not) if the trust type requires the modules+-- own package be trusted and a list of other packages required to be trusted+-- (these later ones haven't been checked) but the own package trust has been.+hscCheckSafe' :: Module -> SrcSpan+  -> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)+hscCheckSafe' m l = do+    dflags <- getDynFlags+    (tw, pkgs) <- isModSafe m l+    case tw of+        False                     -> return (Nothing, pkgs)+        True | isHomePkg dflags m -> return (Nothing, pkgs)+             -- TODO: do we also have to check the trust of the instantiation?+             -- Not necessary if that is reflected in dependencies+             | otherwise   -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs)+  where+    isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId)+    isModSafe m l = do+        dflags <- getDynFlags+        iface <- lookup' m+        case iface of+            -- can't load iface to check trust!+            Nothing -> throwOneError $ mkPlainErrMsg dflags l+                         $ text "Can't load the interface file for" <+> ppr m+                           <> text ", to check that it can be safely imported"++            -- got iface, check trust+            Just iface' ->+                let trust = getSafeMode $ mi_trust iface'+                    trust_own_pkg = mi_trust_pkg iface'+                    -- check module is trusted+                    safeM = trust `elem` [Sf_Safe, Sf_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'+                    -- 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 errs+                    return (trust == Sf_Trustworthy, pkgRs)++                where+                    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 dflags _ _ m+        | isHomePkg dflags m = True+        | otherwise = trusted $ getPackageDetails dflags (moduleUnitId m)++    lookup' :: Module -> Hsc (Maybe ModIface)+    lookup' m = do+        dflags <- getDynFlags+        hsc_env <- getHscEnv+        hsc_eps <- liftIO $ hscEPS hsc_env+        let pkgIfaceT = eps_PIT hsc_eps+            homePkgT  = hsc_HPT hsc_env+            iface     = lookupIfaceByModule dflags 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+--------------------------------------------------------------++hscSimpleIface :: HscEnv+               -> TcGblEnv+               -> Maybe Fingerprint+               -> IO (ModIface, Bool, ModDetails)+hscSimpleIface hsc_env tc_result mb_old_iface+    = runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface++hscSimpleIface' :: TcGblEnv+                -> Maybe Fingerprint+                -> Hsc (ModIface, Bool, 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, no_change)+        <- {-# SCC "MkFinalIface" #-}+           liftIO $+               mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result+    -- And the answer is ...+    liftIO $ dumpIfaceStats hsc_env+    return (new_iface, no_change, details)++hscNormalIface :: HscEnv+               -> ModGuts+               -> Maybe Fingerprint+               -> IO (ModIface, Bool, ModDetails, CgGuts)+hscNormalIface hsc_env simpl_result mb_old_iface =+    runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface++hscNormalIface' :: ModGuts+                -> Maybe Fingerprint+                -> Hsc (ModIface, Bool, ModDetails, CgGuts)+hscNormalIface' simpl_result mb_old_iface = do+    hsc_env <- getHscEnv+    (cg_guts, details) <- {-# SCC "CoreTidy" #-}+                          liftIO $ tidyProgram hsc_env simpl_result++    -- BUILD THE NEW ModIface and ModDetails+    --  and emit external core if necessary+    -- This has to happen *after* code gen so that the back-end+    -- info has been set. Not yet clear if it matters waiting+    -- until after code output+    (new_iface, no_change)+        <- {-# SCC "MkFinalIface" #-}+           liftIO $+               mkIface hsc_env mb_old_iface details simpl_result++    liftIO $ dumpIfaceStats hsc_env++    -- Return the prepared code.+    return (new_iface, no_change, details, cg_guts)++--------------------------------------------------------------+-- BackEnd combinators+--------------------------------------------------------------++hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()+hscWriteIface dflags iface no_change mod_summary = do+    let ifaceFile = ml_hi_file (ms_location mod_summary)+    unless no_change $+        {-# SCC "writeIface" #-}+        writeIfaceFile dflags ifaceFile iface+    whenGeneratingDynamicToo dflags $ do+        -- TODO: We should do a no_change check for the dynamic+        --       interface file too+        -- TODO: Should handle the dynamic hi filename properly+        let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags)+            dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile+            dynDflags = dynamicTooMkDynamicDynFlags dflags+        writeIfaceFile dynDflags dynIfaceFile' iface++-- | Compile to hard-code.+hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath+               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])+               -- ^ @Just f@ <=> _stub.c is f+hscGenHardCode hsc_env cgguts mod_summary 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+            location = ms_location mod_summary+            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 (pure dflags)+                   (text "CodeGen"<+>brackets (ppr this_mod))+                   (const ()) $ do+            cmms <- {-# SCC "StgCmm" #-}+                            doCodeGen hsc_env this_mod data_tycons+                                cost_centre_info+                                stg_binds hpc_info++            ------------------  Code output -----------------------+            rawcmms0 <- {-# SCC "cmmToRawCmm" #-}+                      cmmToRawCmm dflags cmms++            let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm"+                              (ppr a)+                            return a+                rawcmms1 = Stream.mapM dump rawcmms0++            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps)+                <- {-# SCC "codeOutput" #-}+                  codeOutput dflags this_mod output_filename location+                  foreign_stubs foreign_files dependencies rawcmms1+            return (output_filename, stub_c_exists, foreign_fps)+++hscInteractive :: HscEnv+               -> CgGuts+               -> ModSummary+               -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])+hscInteractive hsc_env cgguts mod_summary = 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++        location = ms_location mod_summary+        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 "Parsed Cmm" (ppr cmm)+        let -- Make up a module name to give the NCG. We can't pass bottom here+            -- lest we reproduce #11784.+            mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename+            cmm_mod = mkModule (thisPackage dflags) mod_name+        (_, cmmgroup) <- cmmPipeline hsc_env (emptySRT cmm_mod) cmm+        dumpIfSet_dyn dflags Opt_D_dump_cmm "Output Cmm" (ppr cmmgroup)+        rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)+        _ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []+             rawCmms+        return ()+  where+    no_loc = ModLocation{ ml_hs_file  = Just filename,+                          ml_hi_file  = panic "hscCompileCmmFile: no hi file",+                          ml_obj_file = panic "hscCompileCmmFile: no obj file",+                          ml_hie_file = panic "hscCompileCmmFile: no hie file"}++-------------------- Stuff for new code gen ---------------------++doCodeGen   :: HscEnv -> Module -> [TyCon]+            -> CollectedCCs+            -> [StgTopBinding]+            -> HpcInfo+            -> IO (Stream IO CmmGroup ())+         -- Note we produce a 'Stream' of CmmGroups, so that the+         -- backend can be run incrementally.  Otherwise it generates all+         -- the C-- up front, which has a significant space cost.+doCodeGen hsc_env this_mod data_tycons+              cost_centre_info stg_binds hpc_info = do+    let dflags = hsc_dflags hsc_env++    let stg_binds_w_fvs = annTopBindingsFreeVars stg_binds+    dumpIfSet_dyn dflags Opt_D_dump_stg_final+                  "STG for code gen:" (pprGenStgTopBindings stg_binds_w_fvs)+    let cmm_stream :: Stream IO CmmGroup ()+        cmm_stream = {-# SCC "StgCmm" #-}+            StgCmm.codeGen dflags this_mod data_tycons+                           cost_centre_info stg_binds_w_fvs hpc_info++        -- codegen consumes a stream of CmmGroup, and produces a new+        -- stream of CmmGroup (not necessarily synchronised: one+        -- CmmGroup on input may produce many CmmGroups on output due+        -- to proc-point splitting).++    let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg+                       "Cmm produced by codegen" (ppr a)+                     return a++        ppr_stream1 = Stream.mapM dump1 cmm_stream++    -- We are building a single SRT for the entire module, so+    -- we must thread it through all the procedures as we cps-convert them.+    us <- mkSplitUniqSupply 'S'++    -- When splitting, we generate one SRT per split chunk, otherwise+    -- we generate one SRT for the whole module.+    let+     pipeline_stream+      | gopt Opt_SplitSections dflags ||+        osSubsectionsViaSymbols (platformOS (targetPlatform dflags))+        = {-# SCC "cmmPipeline" #-}+          let run_pipeline us cmmgroup = do+                (_topSRT, cmmgroup) <-+                  cmmPipeline hsc_env (emptySRT this_mod) cmmgroup+                return (us, cmmgroup)++          in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1+                return ()++      | otherwise+        = {-# SCC "cmmPipeline" #-}+          let run_pipeline = cmmPipeline hsc_env+          in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1++    let+        dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm+                        "Output Cmm" (ppr a)+                     return a++        ppr_stream2 = Stream.mapM dump2 pipeline_stream++    return ppr_stream2++++myCoreToStg :: DynFlags -> Module -> CoreProgram+            -> IO ( [StgTopBinding] -- output program+                  , CollectedCCs )  -- CAF cost centre info (declared and used)+myCoreToStg dflags this_mod prepd_binds = do+    let (stg_binds, cost_centre_info)+         = {-# SCC "Core2Stg" #-}+           coreToStg dflags this_mod prepd_binds++    stg_binds2+        <- {-# SCC "Stg2Stg" #-}+           stg2stg dflags this_mod stg_binds++    return (stg_binds2, cost_centre_info)+++{- **********************************************************************+%*                                                                      *+\subsection{Compiling a do-statement}+%*                                                                      *+%********************************************************************* -}++{-+When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When+you run it you get a list of HValues that should be the same length as the list+of names; add them to the ClosureEnv.++A naked expression returns a singleton Name [it]. The stmt is lifted into the+IO monad as explained in Note [Interactively-bound Ids in GHCi] in HscTypes+-}++-- | Compile a stmt all the way to an HValue, but don't run it+--+-- We return Nothing to indicate an empty statement (or comment only), not a+-- parse error.+hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))+hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<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 TidyPgm), since those are the only ones+            -- that might later be looked up by name.  But we can exclude+            --    - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in HscTypes+            --    - Implicit Ids, which are implicit in tcs+            -- c.f. TcRnDriver.runTcInteractive, which reconstructs the TypeEnv++        new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns+        ictxt        = hsc_IC hsc_env+        -- See Note [Fixity declarations in GHCi]+        fix_env      = tcg_fix_env tc_gblenv+        new_ictxt    = extendInteractiveContext ictxt new_tythings cls_insts+                                                fam_insts defaults fix_env+    return (new_tythings, new_ictxt)++-- | Load the given static-pointer table entries into the interpreter.+-- See Note [Grand plan for static forms] in StaticPtrTable.+hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()+hscAddSptEntries hsc_env entries = do+    let add_spt_entry :: SptEntry -> IO ()+        add_spt_entry (SptEntry i fpr) = do+            val <- getHValue hsc_env (idName i)+            addSptEntry hsc_env fpr val+    mapM_ add_spt_entry entries++{-+  Note [Fixity declarations in GHCi]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++  To support fixity declarations on types defined within GHCi (as requested+  in #10018) we record the fixity environment in InteractiveContext.+  When we want to evaluate something TcRnDriver.runTcInteractive pulls out this+  fixity environment and uses it to initialize the global typechecker environment.+  After the typechecker has finished its business, an updated fixity environment+  (reflecting whatever fixity declarations were present in the statements we+  passed it) will be returned from hscParsedStmt. This is passed to+  updateFixityEnv, which will stuff it back into InteractiveContext, to be+  used in evaluating the next statement.++-}++hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)+hscImport hsc_env str = runInteractiveHsc hsc_env $ do+    (L _ (HsModule{hsmodImports=is})) <-+       hscParseThing parseModule str+    case is of+        [L _ i] -> return i+        _ -> liftIO $ throwOneError $+                 mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $+                     text "parse error in import declaration"++-- | Typecheck an expression (but don't run it)+hscTcExpr :: HscEnv+          -> TcRnExprMode+          -> String -- ^ The expression+          -> IO Type+hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  parsed_expr <- hscParseExpr expr+  ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr++-- | Find the kind of a type, after generalisation+hscKcType+  :: HscEnv+  -> Bool            -- ^ Normalise the type+  -> String          -- ^ The type as a string+  -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind+hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do+    hsc_env <- getHscEnv+    ty <- hscParseType str+    ioMsgMaybe $ tcRnType hsc_env 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+  = withTiming getDynFlags+               (text "Parser [source]")+               (const ()) $ {-# SCC "Parser" #-} do+    dflags <- getDynFlags++    let buf = stringToStringBuffer str+        loc = mkRealSrcLoc (fsLit source) linenumber 1++    case unP parser (mkPState dflags buf loc) of+        PFailed pst -> do+            handleWarningsThrowErrors (getMessages pst dflags)++        POk pst thing -> do+            logWarningsReportErrors (getMessages pst dflags)+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)+            liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $+                                   showAstData NoBlankSrcSpan thing+            return thing+++{- **********************************************************************+%*                                                                      *+        Desugar, simplify, convert to bytecode, and link an expression+%*                                                                      *+%********************************************************************* -}++hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue+hscCompileCoreExpr hsc_env =+  lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env++hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue+hscCompileCoreExpr' hsc_env srcspan ds_expr+    = do { let dflags = hsc_dflags hsc_env++           {- Simplify it -}+         ; simpl_expr <- simplifyExpr dflags ds_expr++           {- Tidy it (temporary, until coreSat does cloning) -}+         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr++           {- Prepare for codegen -}+         ; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr++           {- Lint if necessary -}+         ; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr++           {- Convert to BCOs -}+         ; bcos <- coreExprToBCOs hsc_env+                     (icInteractiveModule (hsc_IC hsc_env)) prepd_expr++           {- link it -}+         ; hval <- linkExpr hsc_env srcspan bcos++         ; return hval }+++{- **********************************************************************+%*                                                                      *+        Statistics on reading interfaces+%*                                                                      *+%********************************************************************* -}++dumpIfaceStats :: HscEnv -> IO ()+dumpIfaceStats hsc_env = do+    eps <- readIORef (hsc_EPS hsc_env)+    dumpIfSet dflags (dump_if_trace || dump_rn_stats)+              "Interface statistics"+              (ifaceStats eps)+  where+    dflags = hsc_dflags hsc_env+    dump_rn_stats = dopt Opt_D_dump_rn_stats dflags+    dump_if_trace = dopt Opt_D_dump_if_trace dflags+++{- **********************************************************************+%*                                                                      *+        Progress Messages: Module i of n+%*                                                                      *+%********************************************************************* -}++showModuleIndex :: (Int, Int) -> String+showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "+  where+    n_str = show n+    i_str = show i+    padded = replicate (length n_str - length i_str) ' ' ++ i_str
+ compiler/main/HscStats.hs view
@@ -0,0 +1,190 @@+-- |+-- Statistics for per-module compilations+--+-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998+--++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module HscStats ( ppSourceStats ) where++import GhcPrelude++import Bag+import HsSyn+import Outputable+import SrcLoc+import Util++import Data.Char++-- | Source Statistics+ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc+ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _))+  = (if short then hcat else vcat)+        (map pp_val+            [("ExportAll        ", export_all), -- 1 if no export list+             ("ExportDecls      ", export_ds),+             ("ExportModules    ", export_ms),+             ("Imports          ", imp_no),+             ("  ImpSafe        ", imp_safe),+             ("  ImpQual        ", imp_qual),+             ("  ImpAs          ", imp_as),+             ("  ImpAll         ", imp_all),+             ("  ImpPartial     ", imp_partial),+             ("  ImpHiding      ", imp_hiding),+             ("FixityDecls      ", fixity_sigs),+             ("DefaultDecls     ", default_ds),+             ("TypeDecls        ", type_ds),+             ("DataDecls        ", data_ds),+             ("NewTypeDecls     ", newt_ds),+             ("TypeFamilyDecls  ", type_fam_ds),+             ("DataConstrs      ", data_constrs),+             ("DataDerivings    ", data_derivs),+             ("ClassDecls       ", class_ds),+             ("ClassMethods     ", class_method_ds),+             ("DefaultMethods   ", default_method_ds),+             ("InstDecls        ", inst_ds),+             ("InstMethods      ", inst_method_ds),+             ("InstType         ", inst_type_ds),+             ("InstData         ", inst_data_ds),+             ("TypeSigs         ", bind_tys),+             ("ClassOpSigs      ", generic_sigs),+             ("ValBinds         ", val_bind_ds),+             ("FunBinds         ", fn_bind_ds),+             ("PatSynBinds      ", patsyn_ds),+             ("InlineMeths      ", method_inlines),+             ("InlineBinds      ", bind_inlines),+             ("SpecialisedMeths ", method_specs),+             ("SpecialisedBinds ", bind_specs)+            ])+  where+    decls = map unLoc ldecls++    pp_val (_, 0) = empty+    pp_val (str, n)+      | not short   = hcat [text str, int n]+      | otherwise   = hcat [text (trim str), equals, int n, semi]++    trim ls    = takeWhile (not.isSpace) (dropWhile isSpace ls)++    (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs)+        = count_sigs [d | SigD _ d <- decls]+                -- NB: this omits fixity decls on local bindings and+                -- in class decls. ToDo++    tycl_decls = [d | TyClD _ d <- decls]+    (class_ds, type_ds, data_ds, newt_ds, type_fam_ds) =+      countTyClDecls tycl_decls++    inst_decls = [d | InstD _ d <- decls]+    inst_ds    = length inst_decls+    default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls+    val_decls  = [d | ValD _ d <- decls]++    real_exports = case exports of { Nothing -> []; Just (dL->L _ es) -> es }+    n_exports    = length real_exports+    export_ms    = count (\ e -> case unLoc e of { IEModuleContents{} -> True+                                                 ; _ -> False})+                         real_exports+    export_ds    = n_exports - export_ms+    export_all   = case exports of { Nothing -> 1; _ -> 0 }++    (val_bind_ds, fn_bind_ds, patsyn_ds)+        = sum3 (map count_bind val_decls)++    (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding)+        = sum7 (map import_info imports)+    (data_constrs, data_derivs)+        = sum2 (map data_info tycl_decls)+    (class_method_ds, default_method_ds)+        = sum2 (map class_info tycl_decls)+    (inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds)+        = sum5 (map inst_info inst_decls)++    count_bind (PatBind { pat_lhs = (dL->L _ (VarPat{})) }) = (1,0,0)+    count_bind (PatBind {})                           = (0,1,0)+    count_bind (FunBind {})                           = (0,1,0)+    count_bind (PatSynBind {})                        = (0,0,1)+    count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b)++    count_sigs sigs = sum5 (map sig_info sigs)++    sig_info (FixSig {})     = (1,0,0,0,0)+    sig_info (TypeSig {})    = (0,1,0,0,0)+    sig_info (SpecSig {})    = (0,0,1,0,0)+    sig_info (InlineSig {})  = (0,0,0,1,0)+    sig_info (ClassOpSig {}) = (0,0,0,0,1)+    sig_info _               = (0,0,0,0,0)++    import_info (dL->L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual+                                     , ideclAs = as, ideclHiding = spec }))+        = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)+    import_info (dL->L _ (XImportDecl _)) = panic "import_info"+    import_info _ = panic " import_info: Impossible Match"+                             -- due to #15884++    safe_info False = 0+    safe_info True = 1+    qual_info NotQualified = 0+    qual_info _  = 1+    as_info Nothing  = 0+    as_info (Just _) = 1+    spec_info Nothing           = (0,0,0,0,1,0,0)+    spec_info (Just (False, _)) = (0,0,0,0,0,1,0)+    spec_info (Just (True, _))  = (0,0,0,0,0,0,1)++    data_info (DataDecl { tcdDataDefn = HsDataDefn+                                          { dd_cons = cs+                                          , dd_derivs = (dL->L _ derivs)}})+        = ( length cs+          , foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s)+                   0 derivs )+    data_info _ = (0,0)++    class_info decl@(ClassDecl {})+        = (classops, addpr (sum3 (map count_bind methods)))+      where+        methods = map unLoc $ bagToList (tcdMeths decl)+        (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl))+    class_info _ = (0,0)++    inst_info (TyFamInstD {}) = (0,0,0,1,0)+    inst_info (DataFamInstD {}) = (0,0,0,0,1)+    inst_info (ClsInstD { cid_inst = ClsInstDecl {cid_binds = inst_meths+                                                 , cid_sigs = inst_sigs+                                                 , cid_tyfam_insts = ats+                                                 , cid_datafam_insts = adts } })+        = case count_sigs (map unLoc inst_sigs) of+            (_,_,ss,is,_) ->+                  (addpr (sum3 (map count_bind methods)),+                   ss, is, length ats, length adts)+      where+        methods = map unLoc $ bagToList inst_meths+    inst_info (ClsInstD _ (XClsInstDecl _)) = panic "inst_info"+    inst_info (XInstDecl _)                 = panic "inst_info"++    -- TODO: use Sum monoid+    addpr :: (Int,Int,Int) -> Int+    sum2 :: [(Int, Int)] -> (Int, Int)+    sum3 :: [(Int, Int, Int)] -> (Int, Int, Int)+    sum5 :: [(Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int)+    sum7 :: [(Int, Int, Int, Int, Int, Int, Int)] -> (Int, Int, Int, Int, Int, Int, Int)+    add7 :: (Int, Int, Int, Int, Int, Int, Int) -> (Int, Int, Int, Int, Int, Int, Int)+         -> (Int, Int, Int, Int, Int, Int, Int)++    addpr (x,y,z) = x+y+z+    sum2 = foldr add2 (0,0)+      where+        add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)+    sum3 = foldr add3 (0,0,0)+      where+        add3 (x1,x2,x3) (y1,y2,y3) = (x1+y1,x2+y2,x3+y3)+    sum5 = foldr add5 (0,0,0,0,0)+      where+        add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)+    sum7 = foldr add7 (0,0,0,0,0,0,0)++    add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7)
+ compiler/main/InteractiveEval.hs view
@@ -0,0 +1,1046 @@+{-# LANGUAGE CPP, MagicHash, NondecreasingIndentation,+    RecordWildCards, BangPatterns #-}++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2005-2007+--+-- Running statements interactively+--+-- -----------------------------------------------------------------------------++module InteractiveEval (+        Resume(..), History(..),+        execStmt, execStmt', ExecOptions(..), execOptions, ExecResult(..), resumeExec,+        runDecls, runDeclsWithLocation, runParsedDecls,+        isStmt, hasImport, isImport, isDecl,+        parseImportDecl, SingleStep(..),+        abandon, abandonAll,+        getResumeContext,+        getHistorySpan,+        getModBreaks,+        getHistoryModule,+        back, forward,+        setContext, getContext,+        availsToGlobalRdrEnv,+        getNamesInScope,+        getRdrNamesInScope,+        moduleIsInterpreted,+        getInfo,+        exprType,+        typeKind,+        parseName,+        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 HsSyn+import HscTypes+import InstEnv+import IfaceEnv   ( newInteractiveBinder )+import FamInstEnv ( FamInst )+import CoreFVs    ( orphNamesOfFamInst )+import TyCon+import Type             hiding( typeKind )+import RepType+import TcType+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++-- -----------------------------------------------------------------------------+-- 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)++    | otherwise+    = panic "not_tracing" -- actually exhaustive, but GHC can't tell+++resumeExec :: GhcMonad m => (SrcSpan->Bool) -> SingleStep -> m ExecResult+resumeExec canLogSpan step+ = do+   hsc_env <- getSession+   let ic = hsc_IC hsc_env+       resume = ic_resume ic++   case resume of+     [] -> liftIO $+           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")+     (r:rs) -> do+        -- unbind the temporary locals by restoring the TypeEnv from+        -- before the breakpoint, and drop this Resume from the+        -- InteractiveContext.+        let (resume_tmp_te,resume_rdr_env) = resumeBindings r+            ic' = ic { ic_tythings = resume_tmp_te,+                       ic_rn_gbl_env = resume_rdr_env,+                       ic_resume   = rs }+        setSession hsc_env{ hsc_IC = ic' }++        -- remove any bindings created since the breakpoint from the+        -- linker's environment+        let old_names = map getName resume_tmp_te+            new_names = [ n | thing <- ic_tythings ic+                            , let n = getName thing+                            , not (n `elem` old_names) ]+            dl        = hsc_dynLinker hsc_env+        liftIO $ Linker.deleteFromLinkEnv dl new_names++        case r of+          Resume { resumeStmt = expr, resumeContext = fhv+                 , resumeBindings = bindings, resumeFinalIds = final_ids+                 , resumeApStack = apStack, resumeBreakInfo = mb_brkpt+                 , resumeSpan = span+                 , resumeHistory = hist } -> do+               withVirtualCWD $ do+                status <- liftIO $ GHCi.resumeStmt hsc_env (isStep step) fhv+                let prevHistoryLst = fromListBL 50 hist+                    hist' = case mb_brkpt of+                       Nothing -> prevHistoryLst+                       Just bi+                         | not $canLogSpan span -> prevHistoryLst+                         | otherwise -> mkHistory hsc_env apStack bi `consBL`+                                                        fromListBL 50 hist+                handleRunStatus step expr bindings final_ids status hist'++back :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)+back n = moveHist (+n)++forward :: GhcMonad m => Int -> m ([Name], Int, SrcSpan, String)+forward n = moveHist (subtract n)++moveHist :: GhcMonad m => (Int -> Int) -> m ([Name], Int, SrcSpan, String)+moveHist fn = do+  hsc_env <- getSession+  case ic_resume (hsc_IC hsc_env) of+     [] -> liftIO $+           throwGhcExceptionIO (ProgramError "not stopped at a breakpoint")+     (r:rs) -> do+        let ix = resumeHistoryIx r+            history = resumeHistory r+            new_ix = fn ix+        --+        when (history `lengthLessThan` new_ix) $ liftIO $+           throwGhcExceptionIO (ProgramError "no more logged breakpoints")+        when (new_ix < 0) $ liftIO $+           throwGhcExceptionIO (ProgramError "already at the beginning of the history")++        let+          update_ic apStack mb_info = do+            (hsc_env1, names, span, decl) <-+              liftIO $ bindLocalsAtBreakpoint hsc_env apStack mb_info+            let ic = hsc_IC hsc_env1+                r' = r { resumeHistoryIx = new_ix }+                ic' = ic { ic_resume = r':rs }++            setSession hsc_env1{ hsc_IC = ic' }++            return (names, new_ix, span, decl)++        -- careful: we want apStack to be the AP_STACK itself, not a thunk+        -- around it, hence the cases are carefully constructed below to+        -- make this the case.  ToDo: this is v. fragile, do something better.+        if new_ix == 0+           then case r of+                   Resume { resumeApStack = apStack,+                            resumeBreakInfo = mb_brkpt } ->+                          update_ic apStack mb_brkpt+           else case history !! (new_ix - 1) of+                   History{..} ->+                     update_ic historyApStack (Just historyBreakInfo)+++-- -----------------------------------------------------------------------------+-- After stopping at a breakpoint, add free variables to the environment++result_fs :: FastString+result_fs = fsLit "_result"++bindLocalsAtBreakpoint+        :: HscEnv+        -> ForeignHValue+        -> Maybe BreakInfo+        -> IO (HscEnv, [Name], SrcSpan, String)++-- Nothing case: we stopped when an exception was raised, not at a+-- breakpoint.  We have no location information or local variables to+-- bind, all we can do is bind a local variable to the exception+-- value.+bindLocalsAtBreakpoint hsc_env apStack Nothing = do+   let exn_occ = mkVarOccFS (fsLit "_exception")+       span    = mkGeneralSrcSpan (fsLit "<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)+       vars      = 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;+           -- we can't bind these at the prompt+       pointers = filter (\(id,_) -> isPointer id) vars+       isPointer id | [rep] <- typePrimRep (idType id)+                    , isGcPtrRep rep                   = True+                    | otherwise                        = False++       (ids, offsets) = unzip pointers++       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 = [ id | (id, Just _hv) <- zip ids mb_hValues ]+       (_,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 ]++rttiEnvironment :: HscEnv -> IO HscEnv+rttiEnvironment hsc_env@HscEnv{hsc_IC=ic} = do+   let tmp_ids = [id | AnId id <- ic_tythings ic]+       incompletelyTypedIds =+           [id | id <- tmp_ids+               , not $ noSkolems id+               , (occNameFS.nameOccName.idName) id /= result_fs]+   hsc_env' <- foldM improveTypes hsc_env (map idName incompletelyTypedIds)+   return hsc_env'+    where+     noSkolems = noFreeVarsOfType . idType+     improveTypes hsc_env@HscEnv{hsc_IC=ic} name = do+      let tmp_ids = [id | AnId id <- ic_tythings ic]+          Just id = find (\i -> idName i == name) tmp_ids+      if noSkolems id+         then return hsc_env+         else do+           mb_new_ty <- reconstructType hsc_env 10 id+           let old_ty = idType id+           case mb_new_ty of+             Nothing -> return hsc_env+             Just new_ty -> do+              case improveRTTIType hsc_env old_ty new_ty of+               Nothing -> return $+                        WARN(True, text (":print failed to calculate the "+                                           ++ "improvement for a type")) hsc_env+               Just subst -> do+                 let dflags = hsc_dflags hsc_env+                 dumpIfSet_dyn dflags Opt_D_dump_rtti "RTTI"+                   (fsep [text "RTTI Improvement for", ppr id, equals,+                          ppr subst])++                 let ic' = substInteractiveContext ic subst+                 return hsc_env{hsc_IC=ic'}++pushResume :: HscEnv -> Resume -> HscEnv+pushResume hsc_env resume = hsc_env { hsc_IC = ictxt1 }+  where+        ictxt0 = hsc_IC hsc_env+        ictxt1 = ictxt0 { ic_resume = resume : ic_resume ictxt0 }++-- -----------------------------------------------------------------------------+-- 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++-----------------------------------------------------------------------------+-- 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 noExt . L loc . (HsValBinds noExt) $+        ValBinds noExt+                     (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 noExt . 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 view
@@ -0,0 +1,206 @@+-----------------------------------------------------------------------------+--+-- 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    ( ArgFlag(..), TyThing(..), mkTyVarBinders, pprUserForAll )+import IfaceSyn ( ShowSub(..), ShowHowMuch(..), AltPpr(..)+  , showToHeader, pprIfaceDecl )+import CoAxiom ( coAxiomTyCon )+import HscTypes( tyThingParent_maybe )+import MkIface ( tyThingToIfaceDecl )+import Type ( tidyOpenType )+import FamInstEnv( FamInst(..), FamFlavor(..) )+import Type( Type, pprTypeApp, pprSigmaType )+import Name+import VarEnv( emptyTidyEnv )+import Outputable++-- -----------------------------------------------------------------------------+-- Pretty-printing entities that we get from the GHC API++{- Note [Pretty printing via IfaceSyn]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Our general plan for prett-printing+  - Types+  - TyCons+  - Classes+  - Pattern synonyms+  ...etc...++is to convert them to IfaceSyn, and pretty-print that. For example+  - pprType converts a Type to an IfaceType, and pretty prints that.+  - pprTyThing converts the TyThing to an IfaceDecl,+    and pretty prints that.++So IfaceSyn play a dual role:+  - it's the internal version of an interface files+  - it's used for pretty-printing++Why do this?++* A significant reason is that we need to be able+  to pretty-print IfaceSyn (to display Foo.hi), and it was a+  pain to duplicate masses of pretty-printing goop, esp for+  Type and IfaceType.++* When pretty-printing (a type, say), we want to tidy (with+  tidyType) to avoids having (forall a a. blah) where the two+  a's have different uniques.++  Alas, for type constructors, TyCon, tidying does not work well,+  because a TyCon includes DataCons which include Types, which mention+  TyCons. And tidying can't tidy a mutually recursive data structure+  graph, only trees.++* Interface files contains fast-strings, not uniques, so the very same+  tidying must take place when we convert to IfaceDecl. E.g.+  MkIface.tyThingToIfaceDecl which converts a TyThing (i.e. TyCon,+  Class etc) to an IfaceDecl.++  Bottom line: IfaceDecls are already 'tidy', so it's straightforward+  to print them.++* An alternative I once explored was to ensure that TyCons get type+  variables with distinct print-names. That's ok for type variables+  but less easy for kind variables. Processing data type declarations+  is already so complicated that I don't think it's sensible to add+  the extra requirement that it generates only "pretty" types and+  kinds.++Consequences:++- IfaceSyn (and IfaceType) must contain enough information to+  print nicely.  Hence, for example, the IfaceAppArgs type, which+  allows us to suppress invisible kind arguments in types+  (see Note [Suppressing invisible arguments] in IfaceType)++- In a few places we have info that is used only for pretty-printing,+  and is totally ignored when turning IfaceSyn back into TyCons+  etc (in TcIface). For example, IfaceClosedSynFamilyTyCon+  stores a [IfaceAxBranch] that is used only for pretty-printing.++- See Note [Free tyvars in IfaceType] in IfaceType++See #7730, #8776 for details   -}++--------------------+-- | Pretty-prints a 'FamInst' (type/data family instance) with its defining location.+pprFamInst :: FamInst -> SDoc+--  * For data instances we go via pprTyThing of the representational TyCon,+--    because there is already much cleverness associated with printing+--    data type declarations that I don't want to duplicate+--  * For type instances we print directly here; there is no TyCon+--    to give to pprTyThing+--+-- FamInstEnv.pprFamInst does a more quick-and-dirty job for internal purposes++pprFamInst (FamInst { fi_flavor = DataFamilyInst rep_tc })+  = pprTyThingInContextLoc (ATyCon rep_tc)++pprFamInst (FamInst { fi_flavor = SynFamilyInst, fi_axiom = axiom+                    , fi_tvs = tvs, fi_tys = lhs_tys, fi_rhs = rhs })+  = showWithLoc (pprDefinedAt (getName axiom)) $+    hang (text "type instance"+            <+> pprUserForAll (mkTyVarBinders Specified tvs)+                -- See Note [Printing foralls in type family instances]+                -- in IfaceType+            <+> pprTypeApp (coAxiomTyCon axiom) lhs_tys)+       2 (equals <+> ppr rhs)++----------------------------+-- | Pretty-prints a 'TyThing' with its defining location.+pprTyThingLoc :: TyThing -> SDoc+pprTyThingLoc tyThing+  = showWithLoc (pprDefinedAt (getName tyThing))+                (pprTyThing showToHeader tyThing)++-- | Pretty-prints the 'TyThing' header. For functions and data constructors+-- the function is equivalent to 'pprTyThing' but for type constructors+-- and classes it prints only the header part of the declaration.+pprTyThingHdr :: TyThing -> SDoc+pprTyThingHdr = pprTyThing showToHeader++-- | Pretty-prints a 'TyThing' in context: that is, if the entity+-- is a data constructor, record selector, or class method, then+-- the entity's parent declaration is pretty-printed with irrelevant+-- parts omitted.+pprTyThingInContext :: ShowSub -> TyThing -> SDoc+pprTyThingInContext show_sub thing+  = go [] thing+  where+    go ss thing+      = case tyThingParent_maybe thing of+          Just parent ->+            go (getOccName thing : ss) parent+          Nothing ->+            pprTyThing+              (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) })+              thing++-- | Like 'pprTyThingInContext', but adds the defining location.+pprTyThingInContextLoc :: TyThing -> SDoc+pprTyThingInContextLoc tyThing+  = showWithLoc (pprDefinedAt (getName tyThing))+                (pprTyThingInContext showToHeader tyThing)++-- | Pretty-prints a 'TyThing'.+pprTyThing :: ShowSub -> TyThing -> SDoc+-- We pretty-print 'TyThing' via 'IfaceDecl'+-- See Note [Pretty-printing TyThings]+pprTyThing ss ty_thing+  = pprIfaceDecl ss' (tyThingToIfaceDecl ty_thing)+  where+    ss' = case ss_how_much ss of+      ShowHeader (AltPpr Nothing)  -> ss { ss_how_much = ShowHeader ppr' }+      ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' }+      _                   -> ss++    ppr' = AltPpr $ ppr_bndr $ getName ty_thing++    ppr_bndr :: Name -> Maybe (OccName -> SDoc)+    ppr_bndr name+      | isBuiltInSyntax name+         = Nothing+      | otherwise+         = case nameModule_maybe name of+             Just mod -> Just $ \occ -> getPprStyle $ \sty ->+               pprModulePrefix sty mod occ <> ppr occ+             Nothing  -> WARN( True, ppr name ) Nothing+             -- Nothing is unexpected here; TyThings have External names++pprTypeForUser :: Type -> SDoc+-- The type is tidied+pprTypeForUser ty+  = pprSigmaType tidy_ty+  where+    (_, tidy_ty)     = tidyOpenType emptyTidyEnv ty+     -- Often the types/kinds we print in ghci are fully generalised+     -- and have no free variables, but it turns out that we sometimes+     -- print un-generalised kinds (eg when doing :k T), so it's+     -- better to use tidyOpenType here++showWithLoc :: SDoc -> SDoc -> SDoc+showWithLoc loc doc+    = hang doc 2 (char '\t' <> comment <+> loc)+                -- The tab tries to make them line up a bit+  where+    comment = text "--"
+ compiler/main/StaticPtrTable.hs view
@@ -0,0 +1,292 @@+-- | Code generation for the Static Pointer Table+--+-- (c) 2014 I/O Tweag+--+-- Each module that uses 'static' keyword declares an initialization function of+-- the form hs_spt_init_<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_spt_insert to insert the static+-- pointers of this module in the hashtable of the RTS, and it looks something+-- like this:+--+-- > static void hs_hpc_init_Main(void) __attribute__((constructor));+-- > static void hs_hpc_init_Main(void) {+-- >+-- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};+-- >   extern StgPtr Main_r2wb_closure;+-- >   hs_spt_insert(k0, &Main_r2wb_closure);+-- >+-- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};+-- >   extern StgPtr Main_r2wc_closure;+-- >   hs_spt_insert(k1, &Main_r2wc_closure);+-- >+-- > }+--+-- where the constants are fingerprints produced from the static forms.+--+-- The linker must find the definitions matching the @extern StgPtr <name>@+-- declarations. For this to work, the identifiers of static pointers need to be+-- exported. This is done in SetLevels.newLvlVar.+--+-- There is also a finalization function for the time when the module is+-- unloaded.+--+-- > static void hs_hpc_fini_Main(void) __attribute__((destructor));+-- > static void hs_hpc_fini_Main(void) {+-- >+-- >   static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};+-- >   hs_spt_remove(k0);+-- >+-- >   static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};+-- >   hs_spt_remove(k1);+-- >+-- > }+--++{-# LANGUAGE ViewPatterns, TupleSections #-}+module StaticPtrTable+    ( sptCreateStaticBinds+    , sptModuleInitCode+    ) where++{- Note [Grand plan for static forms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Static forms go through the compilation phases as follows.+Here is a running example:++   f x = let k = map toUpper+         in ...(static k)...++* The renamer looks for out-of-scope names in the body of the static+  form, as always. If all names are in scope, the free variables of the+  body are stored in AST at the location of the static form.++* The typechecker verifies that all free variables occurring in the+  static form are floatable to top level (see Note [Meaning of+  IdBindingInfo] in TcRnTypes).  In our example, 'k' is floatable.+  Even though it is bound in a nested let, we are fine.++* The desugarer replaces the static form with an application of the+  function 'makeStatic' (defined in module GHC.StaticPtr.Internal of+  base).  So we get++   f x = let k = map toUpper+         in ...fromStaticPtr (makeStatic location k)...++* The simplifier runs the FloatOut pass which moves the calls to 'makeStatic'+  to the top level. Thus the FloatOut pass is always executed, even when+  optimizations are disabled.  So we get++   k = map toUpper+   static_ptr = makeStatic location k+   f x = ...fromStaticPtr static_ptr...++  The FloatOut pass is careful to produce an /exported/ Id for a floated+  'makeStatic' call, so the binding is not removed or inlined by the+  simplifier.+  E.g. the code for `f` above might look like++    static_ptr = makeStatic location k+    f x = ...(case static_ptr of ...)...++  which might be simplified to++    f x = ...(case makeStatic location k of ...)...++  BUT the top-level binding for static_ptr must remain, so that it can be+  collected to populate the Static Pointer Table.++  Making the binding exported also has a necessary effect during the+  CoreTidy pass.++* The CoreTidy pass replaces all bindings of the form++  b = /\ ... -> makeStatic location value++  with++  b = /\ ... -> StaticPtr key (StaticPtrInfo "pkg key" "module" location) value++  where a distinct key is generated for each binding.++* If we are compiling to object code we insert a C stub (generated by+  sptModuleInitCode) into the final object which runs when the module is loaded,+  inserting the static forms defined by the module into the RTS's static pointer+  table.++* If we are compiling for the byte-code interpreter, we instead explicitly add+  the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter+  process' SPT table using the addSptEntry interpreter message. This happens+  in upsweep after we have compiled the module (see GhcMake.upsweep').+-}++import GhcPrelude++import CLabel+import CoreSyn+import CoreUtils (collectMakeStaticArgs)+import DataCon+import DynFlags+import HscTypes+import Id+import MkCore (mkStringExprFSWith)+import Module+import Name+import Outputable+import Platform+import PrelNames+import TcEnv (lookupGlobal)+import Type++import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State+import Data.List+import Data.Maybe+import GHC.Fingerprint+import qualified GHC.LanguageExtensions as LangExt++-- | Replaces all bindings of the form+--+-- > b = /\ ... -> makeStatic location value+--+--  with+--+-- > b = /\ ... ->+-- >   StaticPtr key (StaticPtrInfo "pkg key" "module" location) value+--+--  where a distinct key is generated for each binding.+--+-- It also yields the C stub that inserts these bindings into the static+-- pointer table.+sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram+                     -> IO ([SptEntry], CoreProgram)+sptCreateStaticBinds hsc_env this_mod binds+    | not (xopt LangExt.StaticPointers dflags) =+      return ([], binds)+    | otherwise = do+      -- Make sure the required interface files are loaded.+      _ <- lookupGlobal hsc_env unpackCStringName+      (fps, binds') <- evalStateT (go [] [] binds) 0+      return (fps, binds')+  where+    go fps bs xs = case xs of+      []        -> return (reverse fps, reverse bs)+      bnd : xs' -> do+        (fps', bnd') <- replaceStaticBind bnd+        go (reverse fps' ++ fps) (bnd' : bs) xs'++    dflags = hsc_dflags hsc_env++    -- Generates keys and replaces 'makeStatic' with 'StaticPtr'.+    --+    -- The 'Int' state is used to produce a different key for each binding.+    replaceStaticBind :: CoreBind+                      -> StateT Int IO ([SptEntry], CoreBind)+    replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e+                                        return (maybeToList mfp, NonRec b' e')+    replaceStaticBind (Rec rbs) = do+      (mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs+      return (catMaybes mfps, Rec rbs')++    replaceStatic :: Id -> CoreExpr+                  -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr))+    replaceStatic b e@(collectTyBinders -> (tvs, e0)) =+      case collectMakeStaticArgs e0 of+        Nothing      -> return (Nothing, (b, e))+        Just (_, t, info, arg) -> do+          (fp, e') <- mkStaticBind t info arg+          return (Just (SptEntry b fp), (b, foldr Lam e' tvs))++    mkStaticBind :: Type -> CoreExpr -> CoreExpr+                 -> StateT Int IO (Fingerprint, CoreExpr)+    mkStaticBind t srcLoc e = do+      i <- get+      put (i + 1)+      staticPtrInfoDataCon <-+        lift $ lookupDataConHscEnv staticPtrInfoDataConName+      let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i+      info <- mkConApp staticPtrInfoDataCon <$>+            (++[srcLoc]) <$>+            mapM (mkStringExprFSWith (lift . lookupIdHscEnv))+                 [ unitIdFS $ moduleUnitId this_mod+                 , moduleNameFS $ moduleName this_mod+                 ]++      -- The module interface of GHC.StaticPtr should be loaded at least+      -- when looking up 'fromStatic' during type-checking.+      staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName+      return (fp, mkConApp staticPtrDataCon+                               [ Type t+                               , mkWord64LitWordRep dflags w0+                               , mkWord64LitWordRep dflags w1+                               , info+                               , e ])++    mkStaticPtrFingerprint :: Int -> Fingerprint+    mkStaticPtrFingerprint n = fingerprintString $ intercalate ":"+        [ unitIdString $ moduleUnitId this_mod+        , moduleNameString $ moduleName this_mod+        , show n+        ]++    -- Choose either 'Word64#' or 'Word#' to represent the arguments of the+    -- 'Fingerprint' data constructor.+    mkWord64LitWordRep dflags+      | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64+      | otherwise = mkWordLit dflags . toInteger++    lookupIdHscEnv :: Name -> IO Id+    lookupIdHscEnv n = lookupTypeHscEnv hsc_env n >>=+                         maybe (getError n) (return . tyThingId)++    lookupDataConHscEnv :: Name -> IO DataCon+    lookupDataConHscEnv n = lookupTypeHscEnv hsc_env n >>=+                              maybe (getError n) (return . tyThingDataCon)++    getError n = pprPanic "sptCreateStaticBinds.get: not found" $+      text "Couldn't find" <+> ppr n++-- | @sptModuleInitCode module fps@ is a C stub to insert the static entries+-- of @module@ into the static pointer table.+--+-- @fps@ is a list associating each binding corresponding to a static entry with+-- its fingerprint.+sptModuleInitCode :: Module -> [SptEntry] -> SDoc+sptModuleInitCode _ [] = Outputable.empty+sptModuleInitCode this_mod entries = vcat+    [ text "static void hs_spt_init_" <> ppr this_mod+           <> text "(void) __attribute__((constructor));"+    , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"+    , braces $ vcat $+        [  text "static StgWord64 k" <> int i <> text "[2] = "+           <> pprFingerprint fp <> semi+        $$ text "extern StgPtr "+           <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi+        $$ text "hs_spt_insert" <> parens+             (hcat $ punctuate comma+                [ char 'k' <> int i+                , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n))+                ]+             )+        <> semi+        |  (i, SptEntry n fp) <- zip [0..] entries+        ]+    , text "static void hs_spt_fini_" <> ppr this_mod+           <> text "(void) __attribute__((destructor));"+    , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"+    , braces $ vcat $+        [  text "StgWord64 k" <> int i <> text "[2] = "+           <> pprFingerprint fp <> semi+        $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi+        | (i, (SptEntry _ fp)) <- zip [0..] entries+        ]+    ]+  where+    pprFingerprint :: Fingerprint -> SDoc+    pprFingerprint (Fingerprint w1 w2) =+      braces $ hcat $ punctuate comma+                 [ integer (fromIntegral w1) <> text "ULL"+                 , integer (fromIntegral w2) <> text "ULL"+                 ]
+ compiler/main/SysTools.hs view
@@ -0,0 +1,656 @@+{-+-----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 2001-2003+--+-- Access to system tools: gcc, cp, rm etc+--+-----------------------------------------------------------------------------+-}++{-# LANGUAGE CPP, MultiWayIf, ScopedTypeVariables #-}++module SysTools (+        -- * Initialisation+        initSysTools,+        initLlvmConfig,++        -- * Interface to system tools+        module SysTools.Tasks,+        module SysTools.Info,++        linkDynLib,++        copy,+        copyWithHeader,++        -- * General utilities+        Option(..),+        expandTopDir,++        -- * Platform-specifics+        libmLinkOpts,++        -- * Mac OS X frameworks+        getPkgFrameworkOpts,+        getFrameworkOpts+ ) where++#include "HsVersions.h"++import GhcPrelude++import Module+import Packages+import Config+import Outputable+import ErrUtils+import Platform+import Util+import DynFlags+import Fingerprint++import System.FilePath+import System.IO+import System.Directory+import SysTools.ExtraObj+import SysTools.Info+import SysTools.Tasks+import SysTools.BaseDir++{-+Note [How GHC finds toolchain utilities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++SysTools.initSysProgs figures out exactly where all the auxiliary programs+are, and initialises mutable variables to make it easy to call them.+To do this, it makes use of definitions in Config.hs, which is a Haskell+file containing variables whose value is figured out by the build system.++Config.hs contains two sorts of things++  cGCC,         The *names* of the programs+  cCPP            e.g.  cGCC = gcc+  cUNLIT                cCPP = gcc -E+  etc           They do *not* include paths+++  cUNLIT_DIR   The *path* to the directory containing unlit, split etc+  cSPLIT_DIR   *relative* to the root of the build tree,+                   for use when running *in-place* in a build tree (only)+++---------------------------------------------+NOTES for an ALTERNATIVE scheme (i.e *not* what is currently implemented):++Another hair-brained scheme for simplifying the current tool location+nightmare in GHC: Simon originally suggested using another+configuration file along the lines of GCC's specs file - which is fine+except that it means adding code to read yet another configuration+file.  What I didn't notice is that the current package.conf is+general enough to do this:++Package+    {name = "tools",    import_dirs = [],  source_dirs = [],+     library_dirs = [], hs_libraries = [], extra_libraries = [],+     include_dirs = [], c_includes = [],   package_deps = [],+     extra_ghc_opts = ["-pgmc/usr/bin/gcc","-pgml${topdir}/bin/unlit", ... etc.],+     extra_cc_opts = [], extra_ld_opts = []}++Which would have the advantage that we get to collect together in one+place the path-specific package stuff with the path-specific tool+stuff.+                End of NOTES+---------------------------------------------++************************************************************************+*                                                                      *+\subsection{Initialisation}+*                                                                      *+************************************************************************+-}++initLlvmConfig :: String+               -> IO LlvmConfig+initLlvmConfig top_dir+  = do+      targets <- readAndParse "llvm-targets" mkLlvmTarget+      passes <- readAndParse "llvm-passes" id+      return (targets, passes)+  where+    readAndParse name builder =+      do let llvmConfigFile = top_dir </> name+         llvmConfigStr <- readFile llvmConfigFile+         case maybeReadFuzzy llvmConfigStr of+           Just s -> return (fmap builder <$> s)+           Nothing -> pgmError ("Can't parse " ++ show llvmConfigFile)++    mkLlvmTarget :: (String, String, String) -> LlvmTarget+    mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs)+++initSysTools :: String          -- TopDir path+             -> IO Settings     -- Set all the mutable variables above, holding+                                --      (a) the system programs+                                --      (b) the package-config file+                                --      (c) the GHC usage message+initSysTools top_dir+  = do       -- see Note [topdir: How GHC finds its files]+             -- NB: top_dir is assumed to be in standard Unix+             -- format, '/' separated+       mtool_dir <- findToolDir top_dir+             -- see Note [tooldir: How GHC finds mingw on Windows]++       let installed :: FilePath -> FilePath+           installed file = top_dir </> file+           libexec :: FilePath -> FilePath+           libexec file = top_dir </> "bin" </> file+           settingsFile = installed "settings"+           platformConstantsFile = installed "platformConstants"++       settingsStr <- readFile settingsFile+       platformConstantsStr <- readFile platformConstantsFile+       mySettings <- case maybeReadFuzzy settingsStr of+                     Just s ->+                         return s+                     Nothing ->+                         pgmError ("Can't parse " ++ show settingsFile)+       platformConstants <- case maybeReadFuzzy platformConstantsStr of+                            Just s ->+                                return s+                            Nothing ->+                                pgmError ("Can't parse " +++                                          show platformConstantsFile)+       let getSetting key = case lookup key mySettings of+                            Just xs -> return $ expandTopDir top_dir xs+                            Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)+           getToolSetting key = expandToolDir mtool_dir <$> getSetting key+           getBooleanSetting key = case lookup key mySettings of+                                   Just "YES" -> return True+                                   Just "NO" -> return False+                                   Just xs -> pgmError ("Bad value for " ++ show key ++ ": " ++ show xs)+                                   Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)+           readSetting key = case lookup key mySettings of+                             Just xs ->+                                 case maybeRead xs of+                                 Just v -> return v+                                 Nothing -> pgmError ("Failed to read " ++ show key ++ " value " ++ show xs)+                             Nothing -> pgmError ("No entry for " ++ show key ++ " in " ++ show settingsFile)+       crossCompiling <- getBooleanSetting "cross compiling"+       targetPlatformString <- getSetting "target platform string"+       targetArch <- readSetting "target arch"+       targetOS <- readSetting "target os"+       targetWordSize <- readSetting "target word size"+       targetUnregisterised <- getBooleanSetting "Unregisterised"+       targetHasGnuNonexecStack <- readSetting "target has GNU nonexec stack"+       targetHasIdentDirective <- readSetting "target has .ident directive"+       targetHasSubsectionsViaSymbols <- readSetting "target has subsections via symbols"+       tablesNextToCode <- getBooleanSetting "Tables next to code"+       myExtraGccViaCFlags <- getSetting "GCC extra via C opts"+       -- On Windows, mingw is distributed with GHC,+       -- so we look in TopDir/../mingw/bin,+       -- as well as TopDir/../../mingw/bin for hadrian.+       -- It would perhaps be nice to be able to override this+       -- with the settings file, but it would be a little fiddly+       -- to make that possible, so for now you can't.+       gcc_prog <- getToolSetting "C compiler command"+       gcc_args_str <- getSetting "C compiler flags"+       gccSupportsNoPie <- getBooleanSetting "C compiler supports -no-pie"+       cpp_prog <- getToolSetting "Haskell CPP command"+       cpp_args_str <- getSetting "Haskell CPP flags"+       let unreg_gcc_args = if targetUnregisterised+                            then ["-DNO_REGS", "-DUSE_MINIINTERPRETER"]+                            else []+           cpp_args= map Option (words cpp_args_str)+           gcc_args = map Option (words gcc_args_str+                               ++ unreg_gcc_args)+       ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind"+       ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"+       ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"+       ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"++       let pkgconfig_path = installed "package.conf.d"+           ghc_usage_msg_path  = installed "ghc-usage.txt"+           ghci_usage_msg_path = installed "ghci-usage.txt"++       -- For all systems, unlit, split, mangle are GHC utilities+       -- architecture-specific stuff is done when building Config.hs+       unlit_path <- getToolSetting "unlit command"++       windres_path <- getToolSetting "windres command"+       libtool_path <- getToolSetting "libtool command"+       ar_path <- getToolSetting "ar command"+       ranlib_path <- getToolSetting "ranlib command"++       tmpdir <- getTemporaryDirectory++       touch_path <- getToolSetting "touch command"++       mkdll_prog <- getToolSetting "dllwrap command"+       let mkdll_args = []++       -- cpp is derived from gcc on all platforms+       -- HACK, see setPgmP below. We keep 'words' here to remember to fix+       -- Config.hs one day.+++       -- Other things being equal, as and ld are simply gcc+       gcc_link_args_str <- getSetting "C compiler link flags"+       let   as_prog  = gcc_prog+             as_args  = gcc_args+             ld_prog  = gcc_prog+             ld_args  = gcc_args ++ map Option (words gcc_link_args_str)++       -- We just assume on command line+       lc_prog <- getSetting "LLVM llc command"+       lo_prog <- getSetting "LLVM opt command"+       lcc_prog <- getSetting "LLVM clang command"++       let iserv_prog = libexec "ghc-iserv"++       let platform = Platform {+                          platformArch = targetArch,+                          platformOS   = targetOS,+                          platformWordSize = targetWordSize,+                          platformUnregisterised = targetUnregisterised,+                          platformHasGnuNonexecStack = targetHasGnuNonexecStack,+                          platformHasIdentDirective = targetHasIdentDirective,+                          platformHasSubsectionsViaSymbols = targetHasSubsectionsViaSymbols,+                          platformIsCrossCompiling = crossCompiling+                      }++       integerLibrary <- getSetting "integer library"+       integerLibraryType <- case integerLibrary of+         "integer-gmp" -> pure IntegerGMP+         "integer-simple" -> pure IntegerSimple+         _ -> pgmError $ unwords+           [ "Entry for"+           , show "integer library"+           , "must be one of"+           , show "integer-gmp"+           , "or"+           , show "integer-simple"+           ]++       ghcWithInterpreter <- getBooleanSetting "Use interpreter"+       ghcWithNativeCodeGen <- getBooleanSetting "Use native code generator"+       ghcWithSMP <- getBooleanSetting "Support SMP"+       ghcRTSWays <- getSetting "RTS ways"+       leadingUnderscore <- getBooleanSetting "Leading underscore"+       useLibFFI <- getBooleanSetting "Use LibFFI"+       ghcThreaded <- getBooleanSetting "Use Threads"+       ghcDebugged <- getBooleanSetting "Use Debugging"+       ghcRtsWithLibdw <- getBooleanSetting "RTS expects libdw"++       return $ Settings {+                    sTargetPlatform = platform,+                    sTmpDir         = normalise tmpdir,+                    sGhcUsagePath   = ghc_usage_msg_path,+                    sGhciUsagePath  = ghci_usage_msg_path,+                    sToolDir        = mtool_dir,+                    sTopDir         = top_dir,+                    sRawSettings    = mySettings,+                    sExtraGccViaCFlags = words myExtraGccViaCFlags,+                    sSystemPackageConfig = pkgconfig_path,+                    sLdSupportsCompactUnwind = ldSupportsCompactUnwind,+                    sLdSupportsBuildId       = ldSupportsBuildId,+                    sLdSupportsFilelist      = ldSupportsFilelist,+                    sLdIsGnuLd               = ldIsGnuLd,+                    sGccSupportsNoPie        = gccSupportsNoPie,+                    sProgramName             = "ghc",+                    sProjectVersion          = cProjectVersion,+                    sPgm_L   = unlit_path,+                    sPgm_P   = (cpp_prog, cpp_args),+                    sPgm_F   = "",+                    sPgm_c   = (gcc_prog, gcc_args),+                    sPgm_a   = (as_prog, as_args),+                    sPgm_l   = (ld_prog, ld_args),+                    sPgm_dll = (mkdll_prog,mkdll_args),+                    sPgm_T   = touch_path,+                    sPgm_windres = windres_path,+                    sPgm_libtool = libtool_path,+                    sPgm_ar = ar_path,+                    sPgm_ranlib = ranlib_path,+                    sPgm_lo  = (lo_prog,[]),+                    sPgm_lc  = (lc_prog,[]),+                    sPgm_lcc = (lcc_prog,[]),+                    sPgm_i   = iserv_prog,+                    sOpt_L       = [],+                    sOpt_P       = [],+                    sOpt_P_fingerprint = fingerprint0,+                    sOpt_F       = [],+                    sOpt_c       = [],+                    sOpt_cxx     = [],+                    sOpt_a       = [],+                    sOpt_l       = [],+                    sOpt_windres = [],+                    sOpt_lcc     = [],+                    sOpt_lo      = [],+                    sOpt_lc      = [],+                    sOpt_i       = [],+                    sPlatformConstants = platformConstants,++                    sTargetPlatformString = targetPlatformString,+                    sIntegerLibrary = integerLibrary,+                    sIntegerLibraryType = integerLibraryType,+                    sGhcWithInterpreter = ghcWithInterpreter,+                    sGhcWithNativeCodeGen = ghcWithNativeCodeGen,+                    sGhcWithSMP = ghcWithSMP,+                    sGhcRTSWays = ghcRTSWays,+                    sTablesNextToCode = tablesNextToCode,+                    sLeadingUnderscore = leadingUnderscore,+                    sLibFFI = useLibFFI,+                    sGhcThreaded = ghcThreaded,+                    sGhcDebugged = ghcDebugged,+                    sGhcRtsWithLibdw = ghcRtsWithLibdw+             }+++{- Note [Windows stack usage]++See: #8870 (and #8834 for related info) and #12186++On Windows, occasionally we need to grow the stack. In order to do+this, we would normally just bump the stack pointer - but there's a+catch on Windows.++If the stack pointer is bumped by more than a single page, then the+pages between the initial pointer and the resulting location must be+properly committed by the Windows virtual memory subsystem. This is+only needed in the event we bump by more than one page (i.e 4097 bytes+or more).++Windows compilers solve this by emitting a call to a special function+called _chkstk, which does this committing of the pages for you.++The reason this was causing a segfault was because due to the fact the+new code generator tends to generate larger functions, we needed more+stack space in GHC itself. In the x86 codegen, we needed approximately+~12kb of stack space in one go, which caused the process to segfault,+as the intervening pages were not committed.++GCC can emit such a check for us automatically but only when the flag+-fstack-check is used.++See https://gcc.gnu.org/onlinedocs/gnat_ugn/Stack-Overflow-Checking.html+for more information.++-}++copy :: DynFlags -> String -> FilePath -> FilePath -> IO ()+copy dflags purpose from to = copyWithHeader dflags purpose Nothing from to++copyWithHeader :: DynFlags -> String -> Maybe String -> FilePath -> FilePath+               -> IO ()+copyWithHeader dflags purpose maybe_header from to = do+  showPass dflags purpose++  hout <- openBinaryFile to   WriteMode+  hin  <- openBinaryFile from ReadMode+  ls <- hGetContents hin -- inefficient, but it'll do for now. ToDo: speed up+  maybe (return ()) (header hout) maybe_header+  hPutStr hout ls+  hClose hout+  hClose hin+ where+  -- write the header string in UTF-8.  The header is something like+  --   {-# LINE "foo.hs" #-}+  -- and we want to make sure a Unicode filename isn't mangled.+  header h str = do+   hSetEncoding h utf8+   hPutStr h str+   hSetBinaryMode h True++{-+************************************************************************+*                                                                      *+\subsection{Support code}+*                                                                      *+************************************************************************+-}++linkDynLib :: DynFlags -> [String] -> [InstalledUnitId] -> IO ()+linkDynLib dflags0 o_files dep_packages+ = do+    let -- This is a rather ugly hack to fix dynamically linked+        -- GHC on Windows. If GHC is linked with -threaded, then+        -- it links against libHSrts_thr. But if base is linked+        -- against libHSrts, then both end up getting loaded,+        -- and things go wrong. We therefore link the libraries+        -- with the same RTS flags that we link GHC with.+        dflags1 = if sGhcThreaded $ settings dflags0+          then addWay' WayThreaded dflags0+          else                     dflags0+        dflags2 = if sGhcDebugged $ settings dflags1+          then addWay' WayDebug dflags1+          else                  dflags1+        dflags = updateWays dflags2++        verbFlags = getVerbFlags dflags+        o_file = outputFile dflags++    pkgs <- getPreloadPackagesAnd dflags dep_packages++    let pkg_lib_paths = collectLibraryPaths dflags pkgs+    let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths+        get_pkg_lib_path_opts l+         | ( osElfTarget (platformOS (targetPlatform dflags)) ||+             osMachOTarget (platformOS (targetPlatform dflags)) ) &&+           dynLibLoader dflags == SystemDependent &&+           WayDyn `elem` ways dflags+            = ["-L" ++ l, "-Xlinker", "-rpath", "-Xlinker", l]+              -- See Note [-Xlinker -rpath vs -Wl,-rpath]+         | otherwise = ["-L" ++ l]++    let lib_paths = libraryPaths dflags+    let lib_path_opts = map ("-L"++) lib_paths++    -- We don't want to link our dynamic libs against the RTS package,+    -- because the RTS lib comes in several flavours and we want to be+    -- able to pick the flavour when a binary is linked.+    -- On Windows we need to link the RTS import lib as Windows does+    -- not allow undefined symbols.+    -- The RTS library path is still added to the library search path+    -- above in case the RTS is being explicitly linked in (see #3807).+    let platform = targetPlatform dflags+        os = platformOS platform+        pkgs_no_rts = case os of+                      OSMinGW32 ->+                          pkgs+                      _ ->+                          filter ((/= rtsUnitId) . packageConfigId) pkgs+    let pkg_link_opts = let (package_hs_libs, extra_libs, other_flags) = collectLinkOpts dflags pkgs_no_rts+                        in  package_hs_libs ++ extra_libs ++ other_flags++        -- probably _stub.o files+        -- and last temporary shared object file+    let extra_ld_inputs = ldInputs dflags++    -- frameworks+    pkg_framework_opts <- getPkgFrameworkOpts dflags platform+                                              (map unitId pkgs)+    let framework_opts = getFrameworkOpts dflags platform++    case os of+        OSMinGW32 -> do+            -------------------------------------------------------------+            -- Making a DLL+            -------------------------------------------------------------+            let output_fn = case o_file of+                            Just s -> s+                            Nothing -> "HSdll.dll"++            runLink dflags (+                    map Option verbFlags+                 ++ [ Option "-o"+                    , FileOption "" output_fn+                    , Option "-shared"+                    ] +++                    [ FileOption "-Wl,--out-implib=" (output_fn ++ ".a")+                    | gopt Opt_SharedImplib dflags+                    ]+                 ++ map (FileOption "") o_files++                 -- Permit the linker to auto link _symbol to _imp_symbol+                 -- This lets us link against DLLs without needing an "import library"+                 ++ [Option "-Wl,--enable-auto-import"]++                 ++ extra_ld_inputs+                 ++ map Option (+                    lib_path_opts+                 ++ pkg_lib_path_opts+                 ++ pkg_link_opts+                ))+        _ | os == OSDarwin -> do+            -------------------------------------------------------------------+            -- Making a darwin dylib+            -------------------------------------------------------------------+            -- About the options used for Darwin:+            -- -dynamiclib+            --   Apple's way of saying -shared+            -- -undefined dynamic_lookup:+            --   Without these options, we'd have to specify the correct+            --   dependencies for each of the dylibs. Note that we could+            --   (and should) do without this for all libraries except+            --   the RTS; all we need to do is to pass the correct+            --   HSfoo_dyn.dylib files to the link command.+            --   This feature requires Mac OS X 10.3 or later; there is+            --   a similar feature, -flat_namespace -undefined suppress,+            --   which works on earlier versions, but it has other+            --   disadvantages.+            -- -single_module+            --   Build the dynamic library as a single "module", i.e. no+            --   dynamic binding nonsense when referring to symbols from+            --   within the library. The NCG assumes that this option is+            --   specified (on i386, at least).+            -- -install_name+            --   Mac OS/X stores the path where a dynamic library is (to+            --   be) installed in the library itself.  It's called the+            --   "install name" of the library. Then any library or+            --   executable that links against it before it's installed+            --   will search for it in its ultimate install location.+            --   By default we set the install name to the absolute path+            --   at build time, but it can be overridden by the+            --   -dylib-install-name option passed to ghc. Cabal does+            --   this.+            -------------------------------------------------------------------++            let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }++            instName <- case dylibInstallName dflags of+                Just n -> return n+                Nothing -> return $ "@rpath" `combine` (takeFileName output_fn)+            runLink dflags (+                    map Option verbFlags+                 ++ [ Option "-dynamiclib"+                    , Option "-o"+                    , FileOption "" output_fn+                    ]+                 ++ map Option o_files+                 ++ [ Option "-undefined",+                      Option "dynamic_lookup",+                      Option "-single_module" ]+                 ++ (if platformArch platform == ArchX86_64+                     then [ ]+                     else [ Option "-Wl,-read_only_relocs,suppress" ])+                 ++ [ Option "-install_name", Option instName ]+                 ++ map Option lib_path_opts+                 ++ extra_ld_inputs+                 ++ map Option framework_opts+                 ++ map Option pkg_lib_path_opts+                 ++ map Option pkg_link_opts+                 ++ map Option pkg_framework_opts+                 ++ [ Option "-Wl,-dead_strip_dylibs" ]+              )+        _ -> do+            -------------------------------------------------------------------+            -- Making a DSO+            -------------------------------------------------------------------++            let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }+                unregisterised = platformUnregisterised (targetPlatform dflags)+            let bsymbolicFlag = -- we need symbolic linking to resolve+                                -- non-PIC intra-package-relocations for+                                -- performance (where symbolic linking works)+                                -- See Note [-Bsymbolic assumptions by GHC]+                                ["-Wl,-Bsymbolic" | not unregisterised]++            runLink dflags (+                    map Option verbFlags+                 ++ libmLinkOpts+                 ++ [ Option "-o"+                    , FileOption "" output_fn+                    ]+                 ++ map Option o_files+                 ++ [ Option "-shared" ]+                 ++ map Option bsymbolicFlag+                    -- Set the library soname. We use -h rather than -soname as+                    -- Solaris 10 doesn't support the latter:+                 ++ [ Option ("-Wl,-h," ++ takeFileName output_fn) ]+                 ++ extra_ld_inputs+                 ++ map Option lib_path_opts+                 ++ map Option pkg_lib_path_opts+                 ++ map Option pkg_link_opts+              )++-- | Some platforms require that we explicitly link against @libm@ if any+-- math-y things are used (which we assume to include all programs). See #14022.+libmLinkOpts :: [Option]+libmLinkOpts =+#if defined(HAVE_LIBM)+  [Option "-lm"]+#else+  []+#endif++getPkgFrameworkOpts :: DynFlags -> Platform -> [InstalledUnitId] -> IO [String]+getPkgFrameworkOpts dflags platform dep_packages+  | platformUsesFrameworks platform = do+    pkg_framework_path_opts <- do+        pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages+        return $ map ("-F" ++) pkg_framework_paths++    pkg_framework_opts <- do+        pkg_frameworks <- getPackageFrameworks dflags dep_packages+        return $ concat [ ["-framework", fw] | fw <- pkg_frameworks ]++    return (pkg_framework_path_opts ++ pkg_framework_opts)++  | otherwise = return []++getFrameworkOpts :: DynFlags -> Platform -> [String]+getFrameworkOpts dflags platform+  | platformUsesFrameworks platform = framework_path_opts ++ framework_opts+  | otherwise = []+  where+    framework_paths     = frameworkPaths dflags+    framework_path_opts = map ("-F" ++) framework_paths++    frameworks     = cmdlineFrameworks dflags+    -- reverse because they're added in reverse order from the cmd line:+    framework_opts = concat [ ["-framework", fw]+                            | fw <- reverse frameworks ]++{-+Note [-Bsymbolic assumptions by GHC]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++GHC has a few assumptions about interaction of relocations in NCG and linker:++1. -Bsymbolic resolves internal references when the shared library is linked,+   which is important for performance.+2. When there is a reference to data in a shared library from the main program,+   the runtime linker relocates the data object into the main program using an+   R_*_COPY relocation.+3. If we used -Bsymbolic, then this results in multiple copies of the data+   object, because some references have already been resolved to point to the+   original instance. This is bad!++We work around [3.] for native compiled code by avoiding the generation of+R_*_COPY relocations.++Unregisterised compiler can't evade R_*_COPY relocations easily thus we disable+-Bsymbolic linking there.++See related tickets: #4210, #15338+-}
+ compiler/main/SysTools/ExtraObj.hs view
@@ -0,0 +1,243 @@+-----------------------------------------------------------------------------+--+-- GHC Extra object linking code+--+-- (c) The GHC Team 2017+--+-----------------------------------------------------------------------------++module SysTools.ExtraObj (+  mkExtraObj, mkExtraObjToLinkIntoBinary, mkNoteObjsToLinkIntoBinary,+  checkLinkInfo, getLinkInfo, getCompilerInfo,+  ghcLinkInfoSectionName, ghcLinkInfoNoteName, platformSupportsSavingLinkOpts,+  haveRtsOptsFlags+) where++import AsmUtils+import ErrUtils+import DynFlags+import Packages+import Platform+import Outputable+import SrcLoc           ( noSrcSpan )+import Module+import Elf+import Util+import GhcPrelude++import Control.Monad+import Data.Maybe++import Control.Monad.IO.Class++import FileCleanup+import SysTools.Tasks+import SysTools.Info++mkExtraObj :: DynFlags -> Suffix -> String -> IO FilePath+mkExtraObj dflags extn xs+ = do cFile <- newTempName dflags TFL_CurrentModule extn+      oFile <- newTempName dflags TFL_GhcSession "o"+      writeFile cFile xs+      ccInfo <- liftIO $ getCompilerInfo dflags+      runCc Nothing dflags+            ([Option        "-c",+              FileOption "" cFile,+              Option        "-o",+              FileOption "" oFile]+              ++ if extn /= "s"+                    then cOpts+                    else asmOpts ccInfo)+      return oFile+    where+      -- Pass a different set of options to the C compiler depending one whether+      -- we're compiling C or assembler. When compiling C, we pass the usual+      -- set of include directories and PIC flags.+      cOpts = map Option (picCCOpts dflags)+                    ++ map (FileOption "-I")+                            (includeDirs $ getPackageDetails dflags rtsUnitId)++      -- When compiling assembler code, we drop the usual C options, and if the+      -- compiler is Clang, we add an extra argument to tell Clang to ignore+      -- unused command line options. See trac #11684.+      asmOpts ccInfo =+            if any (ccInfo ==) [Clang, AppleClang, AppleClang51]+                then [Option "-Qunused-arguments"]+                else []++-- When linking a binary, we need to create a C main() function that+-- starts everything off.  This used to be compiled statically as part+-- of the RTS, but that made it hard to change the -rtsopts setting,+-- so now we generate and compile a main() stub as part of every+-- binary and pass the -rtsopts setting directly to the RTS (#5373)+--+-- On Windows, when making a shared library we also may need a DllMain.+--+mkExtraObjToLinkIntoBinary :: DynFlags -> IO FilePath+mkExtraObjToLinkIntoBinary dflags = do+  when (gopt Opt_NoHsMain dflags && haveRtsOptsFlags dflags) $ do+     putLogMsg dflags NoReason SevInfo noSrcSpan+         (defaultUserStyle dflags)+         (text "Warning: -rtsopts and -with-rtsopts have no effect with -no-hs-main." $$+          text "    Call hs_init_ghc() from your main() function to set these options.")++  mkExtraObj dflags "c" (showSDoc dflags main)+  where+    main+      | gopt Opt_NoHsMain dflags = Outputable.empty+      | otherwise+          = case ghcLink dflags of+                  LinkDynLib -> if platformOS (targetPlatform dflags) == OSMinGW32+                                    then dllMain+                                    else Outputable.empty+                  _                      -> exeMain++    exeMain = vcat [+        text "#include \"Rts.h\"",+        text "extern StgClosure ZCMain_main_closure;",+        text "int main(int argc, char *argv[])",+        char '{',+        text " RtsConfig __conf = defaultRtsConfig;",+        text " __conf.rts_opts_enabled = "+            <> text (show (rtsOptsEnabled dflags)) <> semi,+        text " __conf.rts_opts_suggestions = "+            <> text (if rtsOptsSuggestions dflags+                        then "true"+                        else "false") <> semi,+        text "__conf.keep_cafs = "+            <> text (if gopt Opt_KeepCAFs dflags+                       then "true"+                       else "false") <> semi,+        case rtsOpts dflags of+            Nothing   -> Outputable.empty+            Just opts -> text "    __conf.rts_opts= " <>+                          text (show opts) <> semi,+        text " __conf.rts_hs_main = true;",+        text " return hs_main(argc,argv,&ZCMain_main_closure,__conf);",+        char '}',+        char '\n' -- final newline, to keep gcc happy+        ]++    dllMain = vcat [+        text "#include \"Rts.h\"",+        text "#include <windows.h>",+        text "#include <stdbool.h>",+        char '\n',+        text "bool",+        text "WINAPI",+        text "DllMain ( HINSTANCE hInstance STG_UNUSED",+        text "        , DWORD reason STG_UNUSED",+        text "        , LPVOID reserved STG_UNUSED",+        text "        )",+        text "{",+        text "  return true;",+        text "}",+        char '\n' -- final newline, to keep gcc happy+        ]++-- Write out the link info section into a new assembly file. Previously+-- this was included as inline assembly in the main.c file but this+-- is pretty fragile. gas gets upset trying to calculate relative offsets+-- that span the .note section (notably .text) when debug info is present+mkNoteObjsToLinkIntoBinary :: DynFlags -> [InstalledUnitId] -> IO [FilePath]+mkNoteObjsToLinkIntoBinary dflags dep_packages = do+   link_info <- getLinkInfo dflags dep_packages++   if (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))+     then fmap (:[]) $ mkExtraObj dflags "s" (showSDoc dflags (link_opts link_info))+     else return []++  where+    link_opts info = hcat [+      -- "link info" section (see Note [LinkInfo section])+      makeElfNote ghcLinkInfoSectionName ghcLinkInfoNoteName 0 info,++      -- ALL generated assembly must have this section to disable+      -- executable stacks.  See also+      -- compiler/nativeGen/AsmCodeGen.hs for another instance+      -- where we need to do this.+      if platformHasGnuNonexecStack (targetPlatform dflags)+        then text ".section .note.GNU-stack,\"\","+             <> sectionType "progbits" <> char '\n'+        else Outputable.empty+      ]++-- | Return the "link info" string+--+-- See Note [LinkInfo section]+getLinkInfo :: DynFlags -> [InstalledUnitId] -> IO String+getLinkInfo dflags dep_packages = do+   package_link_opts <- getPackageLinkOpts dflags dep_packages+   pkg_frameworks <- if platformUsesFrameworks (targetPlatform dflags)+                     then getPackageFrameworks dflags dep_packages+                     else return []+   let extra_ld_inputs = ldInputs dflags+   let+      link_info = (package_link_opts,+                   pkg_frameworks,+                   rtsOpts dflags,+                   rtsOptsEnabled dflags,+                   gopt Opt_NoHsMain dflags,+                   map showOpt extra_ld_inputs,+                   getOpts dflags opt_l)+   --+   return (show link_info)++platformSupportsSavingLinkOpts :: OS -> Bool+platformSupportsSavingLinkOpts os+ | os == OSSolaris2 = False -- see #5382+ | otherwise        = osElfTarget os++-- See Note [LinkInfo section]+ghcLinkInfoSectionName :: String+ghcLinkInfoSectionName = ".debug-ghc-link-info"+  -- if we use the ".debug" prefix, then strip will strip it by default++-- Identifier for the note (see Note [LinkInfo section])+ghcLinkInfoNoteName :: String+ghcLinkInfoNoteName = "GHC link info"++-- Returns 'False' if it was, and we can avoid linking, because the+-- previous binary was linked with "the same options".+checkLinkInfo :: DynFlags -> [InstalledUnitId] -> FilePath -> IO Bool+checkLinkInfo dflags pkg_deps exe_file+ | not (platformSupportsSavingLinkOpts (platformOS (targetPlatform dflags)))+ -- ToDo: Windows and OS X do not use the ELF binary format, so+ -- readelf does not work there.  We need to find another way to do+ -- this.+ = return False -- conservatively we should return True, but not+                -- linking in this case was the behaviour for a long+                -- time so we leave it as-is.+ | otherwise+ = do+   link_info <- getLinkInfo dflags pkg_deps+   debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info)+   m_exe_link_info <- readElfNoteAsString dflags exe_file+                          ghcLinkInfoSectionName ghcLinkInfoNoteName+   let sameLinkInfo = (Just link_info == m_exe_link_info)+   debugTraceMsg dflags 3 $ case m_exe_link_info of+     Nothing -> text "Exe link info: Not found"+     Just s+       | sameLinkInfo -> text ("Exe link info is the same")+       | otherwise    -> text ("Exe link info is different: " ++ s)+   return (not sameLinkInfo)++{- Note [LinkInfo section]+   ~~~~~~~~~~~~~~~~~~~~~~~++The "link info" is a string representing the parameters of the link. We save+this information in the binary, and the next time we link, if nothing else has+changed, we use the link info stored in the existing binary to decide whether+to re-link or not.++The "link info" string is stored in a ELF section called ".debug-ghc-link-info"+(see ghcLinkInfoSectionName) with the SHT_NOTE type.  For some time, it used to+not follow the specified record-based format (see #11022).++-}++haveRtsOptsFlags :: DynFlags -> Bool+haveRtsOptsFlags dflags =+        isJust (rtsOpts dflags) || case rtsOptsEnabled dflags of+                                       RtsOptsSafeOnly -> False+                                       _ -> True
+ compiler/main/SysTools/Info.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE ScopedTypeVariables #-}+-----------------------------------------------------------------------------+--+-- Compiler information functions+--+-- (c) The GHC Team 2017+--+-----------------------------------------------------------------------------+module SysTools.Info where++import Exception+import ErrUtils+import DynFlags+import Outputable+import Util++import Data.List+import Data.IORef++import System.IO++import Platform+import GhcPrelude++import SysTools.Process++{- Note [Run-time linker info]++See also: #5240, #6063, #10110++Before 'runLink', we need to be sure to get the relevant information+about the linker we're using at runtime to see if we need any extra+options. For example, GNU ld requires '--reduce-memory-overheads' and+'--hash-size=31' in order to use reasonable amounts of memory (see+trac #5240.) But this isn't supported in GNU gold.++Generally, the linker changing from what was detected at ./configure+time has always been possible using -pgml, but on Linux it can happen+'transparently' by installing packages like binutils-gold, which+change what /usr/bin/ld actually points to.++Clang vs GCC notes:++For gcc, 'gcc -Wl,--version' gives a bunch of output about how to+invoke the linker before the version information string. For 'clang',+the version information for 'ld' is all that's output. For this+reason, we typically need to slurp up all of the standard error output+and look through it.++Other notes:++We cache the LinkerInfo inside DynFlags, since clients may link+multiple times. The definition of LinkerInfo is there to avoid a+circular dependency.++-}++{- Note [ELF needed shared libs]++Some distributions change the link editor's default handling of+ELF DT_NEEDED tags to include only those shared objects that are+needed to resolve undefined symbols. For Template Haskell we need+the last temporary shared library also if it is not needed for the+currently linked temporary shared library. We specify --no-as-needed+to override the default. This flag exists in GNU ld and GNU gold.++The flag is only needed on ELF systems. On Windows (PE) and Mac OS X+(Mach-O) the flag is not needed.++-}++{- Note [Windows static libGCC]++The GCC versions being upgraded to in #10726 are configured with+dynamic linking of libgcc supported. This results in libgcc being+linked dynamically when a shared library is created.++This introduces thus an extra dependency on GCC dll that was not+needed before by shared libraries created with GHC. This is a particular+issue on Windows because you get a non-obvious error due to this missing+dependency. This dependent dll is also not commonly on your path.++For this reason using the static libgcc is preferred as it preserves+the same behaviour that existed before. There are however some very good+reasons to have the shared version as well as described on page 181 of+https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf :++"There are several situations in which an application should use the+ shared ‘libgcc’ instead of the static version. The most common of these+ is when the application wishes to throw and catch exceptions across different+ shared libraries. In that case, each of the libraries as well as the application+ itself should use the shared ‘libgcc’. "++-}++neededLinkArgs :: LinkerInfo -> [Option]+neededLinkArgs (GnuLD o)     = o+neededLinkArgs (GnuGold o)   = o+neededLinkArgs (LlvmLLD o)   = o+neededLinkArgs (DarwinLD o)  = o+neededLinkArgs (SolarisLD o) = o+neededLinkArgs (AixLD o)     = o+neededLinkArgs UnknownLD     = []++-- Grab linker info and cache it in DynFlags.+getLinkerInfo :: DynFlags -> IO LinkerInfo+getLinkerInfo dflags = do+  info <- readIORef (rtldInfo dflags)+  case info of+    Just v  -> return v+    Nothing -> do+      v <- getLinkerInfo' dflags+      writeIORef (rtldInfo dflags) (Just v)+      return v++-- See Note [Run-time linker info].+getLinkerInfo' :: DynFlags -> IO LinkerInfo+getLinkerInfo' dflags = do+  let platform = targetPlatform dflags+      os = platformOS platform+      (pgm,args0) = pgm_l dflags+      args1     = map Option (getOpts dflags opt_l)+      args2     = args0 ++ args1+      args3     = filter notNull (map showOpt args2)++      -- Try to grab the info from the process output.+      parseLinkerInfo stdo _stde _exitc+        | any ("GNU ld" `isPrefixOf`) stdo =+          -- GNU ld specifically needs to use less memory. This especially+          -- hurts on small object files. #5240.+          -- Set DT_NEEDED for all shared libraries. #10110.+          -- TODO: Investigate if these help or hurt when using split sections.+          return (GnuLD $ map Option ["-Wl,--hash-size=31",+                                      "-Wl,--reduce-memory-overheads",+                                      -- ELF specific flag+                                      -- see Note [ELF needed shared libs]+                                      "-Wl,--no-as-needed"])++        | any ("GNU gold" `isPrefixOf`) stdo =+          -- GNU gold only needs --no-as-needed. #10110.+          -- ELF specific flag, see Note [ELF needed shared libs]+          return (GnuGold [Option "-Wl,--no-as-needed"])++        | any ("LLD" `isPrefixOf`) stdo =+          return (LlvmLLD $ map Option [+                                      -- see Note [ELF needed shared libs]+                                      "-Wl,--no-as-needed"])++         -- Unknown linker.+        | otherwise = fail "invalid --version output, or linker is unsupported"++  -- Process the executable call+  info <- catchIO (do+             case os of+               OSSolaris2 ->+                 -- Solaris uses its own Solaris linker. Even all+                 -- GNU C are recommended to configure with Solaris+                 -- linker instead of using GNU binutils linker. Also+                 -- all GCC distributed with Solaris follows this rule+                 -- precisely so we assume here, the Solaris linker is+                 -- used.+                 return $ SolarisLD []+               OSAIX ->+                 -- IBM AIX uses its own non-binutils linker as well+                 return $ AixLD []+               OSDarwin ->+                 -- Darwin has neither GNU Gold or GNU LD, but a strange linker+                 -- that doesn't support --version. We can just assume that's+                 -- what we're using.+                 return $ DarwinLD []+               OSMinGW32 ->+                 -- GHC doesn't support anything but GNU ld on Windows anyway.+                 -- Process creation is also fairly expensive on win32, so+                 -- we short-circuit here.+                 return $ GnuLD $ map Option+                   [ -- Reduce ld memory usage+                     "-Wl,--hash-size=31"+                   , "-Wl,--reduce-memory-overheads"+                     -- Emit gcc stack checks+                     -- Note [Windows stack usage]+                   , "-fstack-check"+                     -- Force static linking of libGCC+                     -- Note [Windows static libGCC]+                   , "-static-libgcc" ]+               _ -> do+                 -- In practice, we use the compiler as the linker here. Pass+                 -- -Wl,--version to get linker version info.+                 (exitc, stdo, stde) <- readProcessEnvWithExitCode pgm+                                        (["-Wl,--version"] ++ args3)+                                        c_locale_env+                 -- Split the output by lines to make certain kinds+                 -- of processing easier. In particular, 'clang' and 'gcc'+                 -- have slightly different outputs for '-Wl,--version', but+                 -- it's still easy to figure out.+                 parseLinkerInfo (lines stdo) (lines stde) exitc+            )+            (\err -> do+                debugTraceMsg dflags 2+                    (text "Error (figuring out linker information):" <+>+                     text (show err))+                errorMsg dflags $ hang (text "Warning:") 9 $+                  text "Couldn't figure out linker information!" $$+                  text "Make sure you're using GNU ld, GNU gold" <+>+                  text "or the built in OS X linker, etc."+                return UnknownLD)+  return info++-- Grab compiler info and cache it in DynFlags.+getCompilerInfo :: DynFlags -> IO CompilerInfo+getCompilerInfo dflags = do+  info <- readIORef (rtccInfo dflags)+  case info of+    Just v  -> return v+    Nothing -> do+      v <- getCompilerInfo' dflags+      writeIORef (rtccInfo dflags) (Just v)+      return v++-- See Note [Run-time linker info].+getCompilerInfo' :: DynFlags -> IO CompilerInfo+getCompilerInfo' dflags = do+  let (pgm,_) = pgm_c dflags+      -- Try to grab the info from the process output.+      parseCompilerInfo _stdo stde _exitc+        -- Regular GCC+        | any ("gcc version" `isInfixOf`) stde =+          return GCC+        -- Regular clang+        | any ("clang version" `isInfixOf`) stde =+          return Clang+        -- FreeBSD clang+        | any ("FreeBSD clang version" `isInfixOf`) stde =+          return Clang+        -- XCode 5.1 clang+        | any ("Apple LLVM version 5.1" `isPrefixOf`) stde =+          return AppleClang51+        -- XCode 5 clang+        | any ("Apple LLVM version" `isPrefixOf`) stde =+          return AppleClang+        -- XCode 4.1 clang+        | any ("Apple clang version" `isPrefixOf`) stde =+          return AppleClang+         -- Unknown linker.+        | otherwise = fail "invalid -v output, or compiler is unsupported"++  -- Process the executable call+  info <- catchIO (do+                (exitc, stdo, stde) <-+                    readProcessEnvWithExitCode pgm ["-v"] c_locale_env+                -- Split the output by lines to make certain kinds+                -- of processing easier.+                parseCompilerInfo (lines stdo) (lines stde) exitc+            )+            (\err -> do+                debugTraceMsg dflags 2+                    (text "Error (figuring out C compiler information):" <+>+                     text (show err))+                errorMsg dflags $ hang (text "Warning:") 9 $+                  text "Couldn't figure out C compiler information!" $$+                  text "Make sure you're using GNU gcc, or clang"+                return UnknownCC)+  return info
+ compiler/main/SysTools/Process.hs view
@@ -0,0 +1,347 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+--+-- Misc process handling code for SysTools+--+-- (c) The GHC Team 2017+--+-----------------------------------------------------------------------------+module SysTools.Process where++#include "HsVersions.h"++import Exception+import ErrUtils+import DynFlags+import FastString+import Outputable+import Panic+import GhcPrelude+import Util+import SrcLoc           ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )++import Control.Concurrent+import Data.Char++import System.Exit+import System.Environment+import System.FilePath+import System.IO+import System.IO.Error as IO+import System.Process++import FileCleanup++-- Similar to System.Process.readCreateProcessWithExitCode, but stderr is+-- inherited from the parent process, and output to stderr is not captured.+readCreateProcessWithExitCode'+    :: CreateProcess+    -> IO (ExitCode, String)    -- ^ stdout+readCreateProcessWithExitCode' proc = do+    (_, Just outh, _, pid) <-+        createProcess proc{ std_out = CreatePipe }++    -- fork off a thread to start consuming the output+    output  <- hGetContents outh+    outMVar <- newEmptyMVar+    _ <- forkIO $ evaluate (length output) >> putMVar outMVar ()++    -- wait on the output+    takeMVar outMVar+    hClose outh++    -- wait on the process+    ex <- waitForProcess pid++    return (ex, output)++replaceVar :: (String, String) -> [(String, String)] -> [(String, String)]+replaceVar (var, value) env =+    (var, value) : filter (\(var',_) -> var /= var') env++-- | Version of @System.Process.readProcessWithExitCode@ that takes a+-- key-value tuple to insert into the environment.+readProcessEnvWithExitCode+    :: String -- ^ program path+    -> [String] -- ^ program args+    -> (String, String) -- ^ addition to the environment+    -> IO (ExitCode, String, String) -- ^ (exit_code, stdout, stderr)+readProcessEnvWithExitCode prog args env_update = do+    current_env <- getEnvironment+    readCreateProcessWithExitCode (proc prog args) {+        env = Just (replaceVar env_update current_env) } ""++-- Don't let gcc localize version info string, #8825+c_locale_env :: (String, String)+c_locale_env = ("LANGUAGE", "C")++-- If the -B<dir> option is set, add <dir> to PATH.  This works around+-- a bug in gcc on Windows Vista where it can't find its auxiliary+-- binaries (see bug #1110).+getGccEnv :: [Option] -> IO (Maybe [(String,String)])+getGccEnv opts =+  if null b_dirs+     then return Nothing+     else do env <- getEnvironment+             return (Just (map mangle_path env))+ where+  (b_dirs, _) = partitionWith get_b_opt opts++  get_b_opt (Option ('-':'B':dir)) = Left dir+  get_b_opt other = Right other++  mangle_path (path,paths) | map toUpper path == "PATH"+        = (path, '\"' : head b_dirs ++ "\";" ++ paths)+  mangle_path other = other+++-----------------------------------------------------------------------------+-- Running an external program++runSomething :: DynFlags+             -> String          -- For -v message+             -> String          -- Command name (possibly a full path)+                                --      assumed already dos-ified+             -> [Option]        -- Arguments+                                --      runSomething will dos-ify them+             -> IO ()++runSomething dflags phase_name pgm args =+  runSomethingFiltered dflags id phase_name pgm args Nothing Nothing++-- | Run a command, placing the arguments in an external response file.+--+-- This command is used in order to avoid overlong command line arguments on+-- Windows. The command line arguments are first written to an external,+-- temporary response file, and then passed to the linker via @filepath.+-- response files for passing them in. See:+--+--     https://gcc.gnu.org/wiki/Response_Files+--     https://gitlab.haskell.org/ghc/ghc/issues/10777+runSomethingResponseFile+  :: DynFlags -> (String->String) -> String -> String -> [Option]+  -> Maybe [(String,String)] -> IO ()++runSomethingResponseFile dflags filter_fn phase_name pgm args mb_env =+    runSomethingWith dflags phase_name pgm args $ \real_args -> do+        fp <- getResponseFile real_args+        let args = ['@':fp]+        r <- builderMainLoop dflags filter_fn pgm args Nothing mb_env+        return (r,())+  where+    getResponseFile args = do+      fp <- newTempName dflags TFL_CurrentModule "rsp"+      withFile fp WriteMode $ \h -> do+#if defined(mingw32_HOST_OS)+          hSetEncoding h latin1+#else+          hSetEncoding h utf8+#endif+          hPutStr h $ unlines $ map escape args+      return fp++    -- Note: Response files have backslash-escaping, double quoting, and are+    -- whitespace separated (some implementations use newline, others any+    -- whitespace character). Therefore, escape any backslashes, newlines, and+    -- double quotes in the argument, and surround the content with double+    -- quotes.+    --+    -- Another possibility that could be considered would be to convert+    -- backslashes in the argument to forward slashes. This would generally do+    -- the right thing, since backslashes in general only appear in arguments+    -- as part of file paths on Windows, and the forward slash is accepted for+    -- those. However, escaping is more reliable, in case somehow a backslash+    -- appears in a non-file.+    escape x = concat+        [ "\""+        , concatMap+            (\c ->+                case c of+                    '\\' -> "\\\\"+                    '\n' -> "\\n"+                    '\"' -> "\\\""+                    _    -> [c])+            x+        , "\""+        ]++runSomethingFiltered+  :: DynFlags -> (String->String) -> String -> String -> [Option]+  -> Maybe FilePath -> Maybe [(String,String)] -> IO ()++runSomethingFiltered dflags filter_fn phase_name pgm args mb_cwd mb_env = do+    runSomethingWith dflags phase_name pgm args $ \real_args -> do+        r <- builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env+        return (r,())++runSomethingWith+  :: DynFlags -> String -> String -> [Option]+  -> ([String] -> IO (ExitCode, a))+  -> IO a++runSomethingWith dflags phase_name pgm args io = do+  let real_args = filter notNull (map showOpt args)+      cmdLine = showCommandForUser pgm real_args+  traceCmd dflags phase_name cmdLine $ handleProc pgm phase_name $ io real_args++handleProc :: String -> String -> IO (ExitCode, r) -> IO r+handleProc pgm phase_name proc = do+    (rc, r) <- proc `catchIO` handler+    case rc of+      ExitSuccess{} -> return r+      ExitFailure n -> throwGhcExceptionIO (+            ProgramError ("`" ++ takeFileName pgm ++ "'" +++                          " failed in phase `" ++ phase_name ++ "'." +++                          " (Exit code: " ++ show n ++ ")"))+  where+    handler err =+       if IO.isDoesNotExistError err+          then does_not_exist+          else throwGhcExceptionIO (ProgramError $ show err)++    does_not_exist = throwGhcExceptionIO (InstallationError ("could not execute: " ++ pgm))+++builderMainLoop :: DynFlags -> (String -> String) -> FilePath+                -> [String] -> Maybe FilePath -> Maybe [(String, String)]+                -> IO ExitCode+builderMainLoop dflags filter_fn pgm real_args mb_cwd mb_env = do+  chan <- newChan++  -- We use a mask here rather than a bracket because we want+  -- to distinguish between cleaning up with and without an+  -- exception. This is to avoid calling terminateProcess+  -- unless an exception was raised.+  let safely inner = mask $ \restore -> do+        -- acquire+        (hStdIn, hStdOut, hStdErr, hProcess) <- restore $+          runInteractiveProcess pgm real_args mb_cwd mb_env+        let cleanup_handles = do+              hClose hStdIn+              hClose hStdOut+              hClose hStdErr+        r <- try $ restore $ do+          hSetBuffering hStdOut LineBuffering+          hSetBuffering hStdErr LineBuffering+          let make_reader_proc h = forkIO $ readerProc chan h filter_fn+          bracketOnError (make_reader_proc hStdOut) killThread $ \_ ->+            bracketOnError (make_reader_proc hStdErr) killThread $ \_ ->+            inner hProcess+        case r of+          -- onException+          Left (SomeException e) -> do+            terminateProcess hProcess+            cleanup_handles+            throw e+          -- cleanup when there was no exception+          Right s -> do+            cleanup_handles+            return s+  safely $ \h -> do+    -- we don't want to finish until 2 streams have been complete+    -- (stdout and stderr)+    log_loop chan (2 :: Integer)+    -- after that, we wait for the process to finish and return the exit code.+    waitForProcess h+  where+    -- t starts at the number of streams we're listening to (2) decrements each+    -- time a reader process sends EOF. We are safe from looping forever if a+    -- reader thread dies, because they send EOF in a finally handler.+    log_loop _ 0 = return ()+    log_loop chan t = do+      msg <- readChan chan+      case msg of+        BuildMsg msg -> do+          putLogMsg dflags NoReason SevInfo noSrcSpan+              (defaultUserStyle dflags) msg+          log_loop chan t+        BuildError loc msg -> do+          putLogMsg dflags NoReason SevError (mkSrcSpan loc loc)+              (defaultUserStyle dflags) msg+          log_loop chan t+        EOF ->+          log_loop chan  (t-1)++readerProc :: Chan BuildMessage -> Handle -> (String -> String) -> IO ()+readerProc chan hdl filter_fn =+    (do str <- hGetContents hdl+        loop (linesPlatform (filter_fn str)) Nothing)+    `finally`+       writeChan chan EOF+        -- ToDo: check errors more carefully+        -- ToDo: in the future, the filter should be implemented as+        -- a stream transformer.+    where+        loop []     Nothing    = return ()+        loop []     (Just err) = writeChan chan err+        loop (l:ls) in_err     =+                case in_err of+                  Just err@(BuildError srcLoc msg)+                    | leading_whitespace l -> do+                        loop ls (Just (BuildError srcLoc (msg $$ text l)))+                    | otherwise -> do+                        writeChan chan err+                        checkError l ls+                  Nothing -> do+                        checkError l ls+                  _ -> panic "readerProc/loop"++        checkError l ls+           = case parseError l of+                Nothing -> do+                    writeChan chan (BuildMsg (text l))+                    loop ls Nothing+                Just (file, lineNum, colNum, msg) -> do+                    let srcLoc = mkSrcLoc (mkFastString file) lineNum colNum+                    loop ls (Just (BuildError srcLoc (text msg)))++        leading_whitespace []    = False+        leading_whitespace (x:_) = isSpace x++parseError :: String -> Maybe (String, Int, Int, String)+parseError s0 = case breakColon s0 of+                Just (filename, s1) ->+                    case breakIntColon s1 of+                    Just (lineNum, s2) ->+                        case breakIntColon s2 of+                        Just (columnNum, s3) ->+                            Just (filename, lineNum, columnNum, s3)+                        Nothing ->+                            Just (filename, lineNum, 0, s2)+                    Nothing -> Nothing+                Nothing -> Nothing++breakColon :: String -> Maybe (String, String)+breakColon xs = case break (':' ==) xs of+                    (ys, _:zs) -> Just (ys, zs)+                    _ -> Nothing++breakIntColon :: String -> Maybe (Int, String)+breakIntColon xs = case break (':' ==) xs of+                       (ys, _:zs)+                        | not (null ys) && all isAscii ys && all isDigit ys ->+                           Just (read ys, zs)+                       _ -> Nothing++data BuildMessage+  = BuildMsg   !SDoc+  | BuildError !SrcLoc !SDoc+  | EOF++-- Divvy up text stream into lines, taking platform dependent+-- line termination into account.+linesPlatform :: String -> [String]+#if !defined(mingw32_HOST_OS)+linesPlatform ls = lines ls+#else+linesPlatform "" = []+linesPlatform xs =+  case lineBreak xs of+    (as,xs1) -> as : linesPlatform xs1+  where+   lineBreak "" = ("","")+   lineBreak ('\r':'\n':xs) = ([],xs)+   lineBreak ('\n':xs) = ([],xs)+   lineBreak (x:xs) = let (as,bs) = lineBreak xs in (x:as,bs)++#endif
+ compiler/main/SysTools/Tasks.hs view
@@ -0,0 +1,359 @@+{-# LANGUAGE ScopedTypeVariables #-}+-----------------------------------------------------------------------------+--+-- Tasks running external programs for SysTools+--+-- (c) The GHC Team 2017+--+-----------------------------------------------------------------------------+module SysTools.Tasks where++import Exception+import ErrUtils+import HscTypes+import DynFlags+import Outputable+import Platform+import Util++import Data.Char+import Data.List++import System.IO+import System.Process+import GhcPrelude++import LlvmCodeGen.Base (llvmVersionStr, supportedLlvmVersion)++import SysTools.Process+import SysTools.Info++{-+************************************************************************+*                                                                      *+\subsection{Running an external program}+*                                                                      *+************************************************************************+-}++runUnlit :: DynFlags -> [Option] -> IO ()+runUnlit dflags args = do+  let prog = pgm_L dflags+      opts = getOpts dflags opt_L+  runSomething dflags "Literate pre-processor" prog+               (map Option opts ++ args)++runCpp :: DynFlags -> [Option] -> IO ()+runCpp dflags args =   do+  let (p,args0) = pgm_P dflags+      args1 = map Option (getOpts dflags opt_P)+      args2 = [Option "-Werror" | gopt Opt_WarnIsError dflags]+                ++ [Option "-Wundef" | wopt Opt_WarnCPPUndef dflags]+  mb_env <- getGccEnv args2+  runSomethingFiltered dflags id  "C pre-processor" p+                       (args0 ++ args1 ++ args2 ++ args) Nothing mb_env++runPp :: DynFlags -> [Option] -> IO ()+runPp dflags args =   do+  let prog = pgm_F dflags+      opts = map Option (getOpts dflags opt_F)+  runSomething dflags "Haskell pre-processor" prog (args ++ opts)++-- | Run compiler of C-like languages and raw objects (such as gcc or clang).+runCc :: Maybe ForeignSrcLang -> DynFlags -> [Option] -> IO ()+runCc mLanguage dflags args =   do+  let (p,args0) = pgm_c dflags+      args1 = map Option userOpts+      args2 = args0 ++ languageOptions ++ args ++ args1+      -- We take care to pass -optc flags in args1 last to ensure that the+      -- user can override flags passed by GHC. See #14452.+  mb_env <- getGccEnv args2+  runSomethingResponseFile dflags cc_filter "C Compiler" p args2 mb_env+ where+  -- discard some harmless warnings from gcc that we can't turn off+  cc_filter = unlines . doFilter . lines++  {-+  gcc gives warnings in chunks like so:+      In file included from /foo/bar/baz.h:11,+                       from /foo/bar/baz2.h:22,+                       from wibble.c:33:+      /foo/flibble:14: global register variable ...+      /foo/flibble:15: warning: call-clobbered r...+  We break it up into its chunks, remove any call-clobbered register+  warnings from each chunk, and then delete any chunks that we have+  emptied of warnings.+  -}+  doFilter = unChunkWarnings . filterWarnings . chunkWarnings []+  -- We can't assume that the output will start with an "In file inc..."+  -- line, so we start off expecting a list of warnings rather than a+  -- location stack.+  chunkWarnings :: [String] -- The location stack to use for the next+                            -- list of warnings+                -> [String] -- The remaining lines to look at+                -> [([String], [String])]+  chunkWarnings loc_stack [] = [(loc_stack, [])]+  chunkWarnings loc_stack xs+      = case break loc_stack_start xs of+        (warnings, lss:xs') ->+            case span loc_start_continuation xs' of+            (lsc, xs'') ->+                (loc_stack, warnings) : chunkWarnings (lss : lsc) xs''+        _ -> [(loc_stack, xs)]++  filterWarnings :: [([String], [String])] -> [([String], [String])]+  filterWarnings [] = []+  -- If the warnings are already empty then we are probably doing+  -- something wrong, so don't delete anything+  filterWarnings ((xs, []) : zs) = (xs, []) : filterWarnings zs+  filterWarnings ((xs, ys) : zs) = case filter wantedWarning ys of+                                       [] -> filterWarnings zs+                                       ys' -> (xs, ys') : filterWarnings zs++  unChunkWarnings :: [([String], [String])] -> [String]+  unChunkWarnings [] = []+  unChunkWarnings ((xs, ys) : zs) = xs ++ ys ++ unChunkWarnings zs++  loc_stack_start        s = "In file included from " `isPrefixOf` s+  loc_start_continuation s = "                 from " `isPrefixOf` s+  wantedWarning w+   | "warning: call-clobbered register used" `isContainedIn` w = False+   | otherwise = True++  -- force the C compiler to interpret this file as C when+  -- compiling .hc files, by adding the -x c option.+  -- Also useful for plain .c files, just in case GHC saw a+  -- -x c option.+  (languageOptions, userOpts) = case mLanguage of+    Nothing -> ([], userOpts_c)+    Just language -> ([Option "-x", Option languageName], opts) where+      (languageName, opts) = case language of+        LangCxx    -> ("c++",           userOpts_cxx)+        LangObjc   -> ("objective-c",   userOpts_c)+        LangObjcxx -> ("objective-c++", userOpts_cxx)+        _          -> ("c",             userOpts_c)+  userOpts_c   = getOpts dflags opt_c+  userOpts_cxx = getOpts dflags opt_cxx++isContainedIn :: String -> String -> Bool+xs `isContainedIn` ys = any (xs `isPrefixOf`) (tails ys)++-- | Run the linker with some arguments and return the output+askLd :: DynFlags -> [Option] -> IO String+askLd dflags args = do+  let (p,args0) = pgm_l dflags+      args1     = map Option (getOpts dflags opt_l)+      args2     = args0 ++ args1 ++ args+  mb_env <- getGccEnv args2+  runSomethingWith dflags "gcc" p args2 $ \real_args ->+    readCreateProcessWithExitCode' (proc p real_args){ env = mb_env }++runAs :: DynFlags -> [Option] -> IO ()+runAs dflags args = do+  let (p,args0) = pgm_a dflags+      args1 = map Option (getOpts dflags opt_a)+      args2 = args0 ++ args1 ++ args+  mb_env <- getGccEnv args2+  runSomethingFiltered dflags id "Assembler" p args2 Nothing mb_env++-- | Run the LLVM Optimiser+runLlvmOpt :: DynFlags -> [Option] -> IO ()+runLlvmOpt dflags args = do+  let (p,args0) = pgm_lo dflags+      args1 = map Option (getOpts dflags opt_lo)+      -- We take care to pass -optlo flags (e.g. args0) last to ensure that the+      -- user can override flags passed by GHC. See #14821.+  runSomething dflags "LLVM Optimiser" p (args1 ++ args ++ args0)++-- | Run the LLVM Compiler+runLlvmLlc :: DynFlags -> [Option] -> IO ()+runLlvmLlc dflags args = do+  let (p,args0) = pgm_lc dflags+      args1 = map Option (getOpts dflags opt_lc)+  runSomething dflags "LLVM Compiler" p (args0 ++ args1 ++ args)++-- | Run the clang compiler (used as an assembler for the LLVM+-- backend on OS X as LLVM doesn't support the OS X system+-- assembler)+runClang :: DynFlags -> [Option] -> IO ()+runClang dflags args = do+  let (clang,_) = pgm_lcc dflags+      -- be careful what options we call clang with+      -- see #5903 and #7617 for bugs caused by this.+      (_,args0) = pgm_a dflags+      args1 = map Option (getOpts dflags opt_a)+      args2 = args0 ++ args1 ++ args+  mb_env <- getGccEnv args2+  Exception.catch (do+        runSomethingFiltered dflags id "Clang (Assembler)" clang args2 Nothing mb_env+    )+    (\(err :: SomeException) -> do+        errorMsg dflags $+            text ("Error running clang! you need clang installed to use the" +++                  " LLVM backend") $+$+            text "(or GHC tried to execute clang incorrectly)"+        throwIO err+    )++-- | Figure out which version of LLVM we are running this session+figureLlvmVersion :: DynFlags -> IO (Maybe (Int, Int))+figureLlvmVersion dflags = do+  let (pgm,opts) = pgm_lc dflags+      args = filter notNull (map showOpt opts)+      -- we grab the args even though they should be useless just in+      -- case the user is using a customised 'llc' that requires some+      -- of the options they've specified. llc doesn't care what other+      -- options are specified when '-version' is used.+      args' = args ++ ["-version"]+  ver <- catchIO (do+              (pin, pout, perr, _) <- runInteractiveProcess pgm args'+                                              Nothing Nothing+              {- > llc -version+                  LLVM (http://llvm.org/):+                    LLVM version 3.5.2+                    ...+              -}+              hSetBinaryMode pout False+              _     <- hGetLine pout+              vline <- dropWhile (not . isDigit) `fmap` hGetLine pout+              v     <- case span (/= '.') vline of+                        ("",_)  -> fail "no digits!"+                        (x,y) -> return (read x+                                        , read $ takeWhile isDigit $ drop 1 y)++              hClose pin+              hClose pout+              hClose perr+              return $ Just v+            )+            (\err -> do+                debugTraceMsg dflags 2+                    (text "Error (figuring out LLVM version):" <+>+                      text (show err))+                errorMsg dflags $ vcat+                    [ text "Warning:", nest 9 $+                          text "Couldn't figure out LLVM version!" $$+                          text ("Make sure you have installed LLVM " +++                                llvmVersionStr supportedLlvmVersion) ]+                return Nothing)+  return ver+++runLink :: DynFlags -> [Option] -> IO ()+runLink dflags args = do+  -- See Note [Run-time linker info]+  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags+  let (p,args0) = pgm_l dflags+      args1     = map Option (getOpts dflags opt_l)+      args2     = args0 ++ linkargs ++ args1 ++ args+  mb_env <- getGccEnv args2+  runSomethingResponseFile dflags ld_filter "Linker" p args2 mb_env+  where+    ld_filter = case (platformOS (targetPlatform dflags)) of+                  OSSolaris2 -> sunos_ld_filter+                  _ -> id+{-+  SunOS/Solaris ld emits harmless warning messages about unresolved+  symbols in case of compiling into shared library when we do not+  link against all the required libs. That is the case of GHC which+  does not link against RTS library explicitly in order to be able to+  choose the library later based on binary application linking+  parameters. The warnings look like:++Undefined                       first referenced+  symbol                             in file+stg_ap_n_fast                       ./T2386_Lib.o+stg_upd_frame_info                  ./T2386_Lib.o+templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o+templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o+templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o+templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o+newCAF                              ./T2386_Lib.o+stg_bh_upd_frame_info               ./T2386_Lib.o+stg_ap_ppp_fast                     ./T2386_Lib.o+templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o+stg_ap_p_fast                       ./T2386_Lib.o+stg_ap_pp_fast                      ./T2386_Lib.o+ld: warning: symbol referencing errors++  this is actually coming from T2386 testcase. The emitting of those+  warnings is also a reason why so many TH testcases fail on Solaris.++  Following filter code is SunOS/Solaris linker specific and should+  filter out only linker warnings. Please note that the logic is a+  little bit more complex due to the simple reason that we need to preserve+  any other linker emitted messages. If there are any. Simply speaking+  if we see "Undefined" and later "ld: warning:..." then we omit all+  text between (including) the marks. Otherwise we copy the whole output.+-}+    sunos_ld_filter :: String -> String+    sunos_ld_filter = unlines . sunos_ld_filter' . lines+    sunos_ld_filter' x = if (undefined_found x && ld_warning_found x)+                          then (ld_prefix x) ++ (ld_postfix x)+                          else x+    breakStartsWith x y = break (isPrefixOf x) y+    ld_prefix = fst . breakStartsWith "Undefined"+    undefined_found = not . null . snd . breakStartsWith "Undefined"+    ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"+    ld_postfix = tail . snd . ld_warn_break+    ld_warning_found = not . null . snd . ld_warn_break+++runLibtool :: DynFlags -> [Option] -> IO ()+runLibtool dflags args = do+  linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags+  let args1      = map Option (getOpts dflags opt_l)+      args2      = [Option "-static"] ++ args1 ++ args ++ linkargs+      libtool    = pgm_libtool dflags+  mb_env <- getGccEnv args2+  runSomethingFiltered dflags id "Linker" libtool args2 Nothing mb_env++runAr :: DynFlags -> Maybe FilePath -> [Option] -> IO ()+runAr dflags cwd args = do+  let ar = pgm_ar dflags+  runSomethingFiltered dflags id "Ar" ar args cwd Nothing++askAr :: DynFlags -> Maybe FilePath -> [Option] -> IO String+askAr dflags mb_cwd args = do+  let ar = pgm_ar dflags+  runSomethingWith dflags "Ar" ar args $ \real_args ->+    readCreateProcessWithExitCode' (proc ar real_args){ cwd = mb_cwd }++runRanlib :: DynFlags -> [Option] -> IO ()+runRanlib dflags args = do+  let ranlib = pgm_ranlib dflags+  runSomethingFiltered dflags id "Ranlib" ranlib args Nothing Nothing++runMkDLL :: DynFlags -> [Option] -> IO ()+runMkDLL dflags args = do+  let (p,args0) = pgm_dll dflags+      args1 = args0 ++ args+  mb_env <- getGccEnv (args0++args)+  runSomethingFiltered dflags id "Make DLL" p args1 Nothing mb_env++runWindres :: DynFlags -> [Option] -> IO ()+runWindres dflags args = do+  let (gcc, gcc_args) = pgm_c dflags+      windres = pgm_windres dflags+      opts = map Option (getOpts dflags opt_windres)+      quote x = "\"" ++ x ++ "\""+      args' = -- If windres.exe and gcc.exe are in a directory containing+              -- spaces then windres fails to run gcc. We therefore need+              -- to tell it what command to use...+              Option ("--preprocessor=" +++                      unwords (map quote (gcc :+                                          map showOpt gcc_args +++                                          map showOpt opts +++                                          ["-E", "-xc", "-DRC_INVOKED"])))+              -- ...but if we do that then if windres calls popen then+              -- it can't understand the quoting, so we have to use+              -- --use-temp-file so that it interprets it correctly.+              -- See #1828.+            : Option "--use-temp-file"+            : args+  mb_env <- getGccEnv gcc_args+  runSomethingFiltered dflags id "Windres" windres args' Nothing mb_env++touch :: DynFlags -> String -> String -> IO ()+touch dflags purpose arg =+  runSomething dflags purpose (pgm_T dflags) [FileOption "" arg]
+ compiler/main/TidyPgm.hs view
@@ -0,0 +1,1463 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section{Tidying up Core}+-}++{-# LANGUAGE CPP, ViewPatterns #-}++module TidyPgm (+       mkBootModDetailsTc, tidyProgram, globaliseAndTidyId+   ) where++#include "HsVersions.h"++import GhcPrelude++import TcRnTypes+import DynFlags+import CoreSyn+import CoreUnfold+import CoreFVs+import CoreTidy+import CoreMonad+import CorePrep+import CoreUtils        (rhsIsStatic)+import CoreStats        (coreBindsStats, CoreStats(..))+import CoreSeq          (seqBinds)+import CoreLint+import Literal+import Rules+import PatSyn+import ConLike+import CoreArity        ( exprArity, exprBotStrictness_maybe )+import StaticPtrTable+import VarEnv+import VarSet+import Var+import Id+import MkId             ( mkDictSelRhs )+import IdInfo+import InstEnv+import FamInstEnv+import Type             ( tidyTopType )+import Demand           ( appIsBottom, isTopSig, isBottomingSig )+import BasicTypes+import Name hiding (varName)+import NameSet+import NameEnv+import NameCache+import Avail+import IfaceEnv+import TcEnv+import TcRnMonad+import DataCon+import TyCon+import Class+import Module+import Packages( isDllName )+import HscTypes+import Maybes+import UniqSupply+import Outputable+import qualified ErrUtils as Err++import Control.Monad+import Data.Function+import Data.List        ( sortBy )+import Data.IORef       ( atomicModifyIORef' )++{-+Constructing the TypeEnv, Instances, Rules from which the+ModIface is constructed, and which goes on to subsequent modules in+--make mode.++Most of the interface file is obtained simply by serialising the+TypeEnv.  One important consequence is that if the *interface file*+has pragma info if and only if the final TypeEnv does. This is not so+important for *this* module, but it's essential for ghc --make:+subsequent compilations must not see (e.g.) the arity if the interface+file does not contain arity If they do, they'll exploit the arity;+then the arity might change, but the iface file doesn't change =>+recompilation does not happen => disaster.++For data types, the final TypeEnv will have a TyThing for the TyCon,+plus one for each DataCon; the interface file will contain just one+data type declaration, but it is de-serialised back into a collection+of TyThings.++************************************************************************+*                                                                      *+                Plan A: simpleTidyPgm+*                                                                      *+************************************************************************+++Plan A: mkBootModDetails: omit pragmas, make interfaces small+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Ignore the bindings++* Drop all WiredIn things from the TypeEnv+        (we never want them in interface files)++* Retain all TyCons and Classes in the TypeEnv, to avoid+        having to find which ones are mentioned in the+        types of exported Ids++* Trim off the constructors of non-exported TyCons, both+        from the TyCon and from the TypeEnv++* Drop non-exported Ids from the TypeEnv++* Tidy the types of the DFunIds of Instances,+  make them into GlobalIds, (they already have External Names)+  and add them to the TypeEnv++* Tidy the types of the (exported) Ids in the TypeEnv,+  make them into GlobalIds (they already have External Names)++* Drop rules altogether++* Tidy the bindings, to ensure that the Caf and Arity+  information is correct for each top-level binder; the+  code generator needs it. And to ensure that local names have+  distinct OccNames in case of object-file splitting++* If this an hsig file, drop the instances altogether too (they'll+  get pulled in by the implicit module import.+-}++-- This is Plan A: make a small type env when typechecking only,+-- or when compiling a hs-boot file, or simply when not using -O+--+-- We don't look at the bindings at all -- there aren't any+-- for hs-boot files++mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails+mkBootModDetailsTc hsc_env+        TcGblEnv{ tcg_exports   = exports,+                  tcg_type_env  = type_env, -- just for the Ids+                  tcg_tcs       = tcs,+                  tcg_patsyns   = pat_syns,+                  tcg_insts     = insts,+                  tcg_fam_insts = fam_insts,+                  tcg_mod       = this_mod+                }+  = -- This timing isn't terribly useful since the result isn't forced, but+    -- the message is useful to locating oneself in the compilation process.+    Err.withTiming (pure dflags)+                   (text "CoreTidy"<+>brackets (ppr this_mod))+                   (const ()) $+    do  { let { insts'     = map (tidyClsInstDFun globaliseAndTidyId) insts+              ; pat_syns'  = map (tidyPatSynIds   globaliseAndTidyId) pat_syns+              ; type_env1  = mkBootTypeEnv (availsToNameSet exports)+                                           (typeEnvIds type_env) tcs fam_insts+              ; type_env2  = extendTypeEnvWithPatSyns pat_syns' type_env1+              ; dfun_ids   = map instanceDFunId insts'+              ; type_env'  = extendTypeEnvWithIds type_env2 dfun_ids+              }+        ; return (ModDetails { md_types     = type_env'+                             , md_insts     = insts'+                             , md_fam_insts = fam_insts+                             , md_rules     = []+                             , md_anns      = []+                             , md_exports   = exports+                             , md_complete_sigs = []+                             })+        }+  where+    dflags = hsc_dflags hsc_env++mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv+mkBootTypeEnv exports ids tcs fam_insts+  = tidyTypeEnv True $+       typeEnvFromEntities final_ids tcs fam_insts+  where+        -- Find the LocalIds in the type env that are exported+        -- Make them into GlobalIds, and tidy their types+        --+        -- It's very important to remove the non-exported ones+        -- because we don't tidy the OccNames, and if we don't remove+        -- the non-exported ones we'll get many things with the+        -- same name in the interface file, giving chaos.+        --+        -- Do make sure that we keep Ids that are already Global.+        -- When typechecking an .hs-boot file, the Ids come through as+        -- GlobalIds.+    final_ids = [ (if isLocalId id then globaliseAndTidyId id+                                   else id)+                        `setIdUnfolding` BootUnfolding+                | id <- ids+                , keep_it id ]++        -- default methods have their export flag set, but everything+        -- else doesn't (yet), because this is pre-desugaring, so we+        -- must test both.+    keep_it id = isExportedId id || idName id `elemNameSet` exports++++globaliseAndTidyId :: Id -> Id+-- Takes a LocalId with an External Name,+-- makes it into a GlobalId+--     * unchanged Name (might be Internal or External)+--     * unchanged details+--     * VanillaIdInfo (makes a conservative assumption about Caf-hood)+globaliseAndTidyId id+  = Id.setIdType (globaliseId id) tidy_type+  where+    tidy_type = tidyTopType (idType id)++{-+************************************************************************+*                                                                      *+        Plan B: tidy bindings, make TypeEnv full of IdInfo+*                                                                      *+************************************************************************++Plan B: include pragmas, make interfaces+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Step 1: Figure out which Ids are externally visible+          See Note [Choosing external Ids]++* Step 2: Gather the externally visible rules, separately from+          the top-level bindings.+          See Note [Finding external rules]++* Step 3: Tidy the bindings, externalising appropriate Ids+          See Note [Tidy the top-level bindings]++* Drop all Ids from the TypeEnv, and add all the External Ids from+  the bindings.  (This adds their IdInfo to the TypeEnv; and adds+  floated-out Ids that weren't even in the TypeEnv before.)++Note [Choosing external Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also the section "Interface stability" in the+recompilation-avoidance commentary:+  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance++First we figure out which Ids are "external" Ids.  An+"external" Id is one that is visible from outside the compilation+unit.  These are+  a) the user exported ones+  b) the ones bound to static forms+  c) ones mentioned in the unfoldings, workers, or+     rules of externally-visible ones++While figuring out which Ids are external, we pick a "tidy" OccName+for each one.  That is, we make its OccName distinct from the other+external OccNames in this module, so that in interface files and+object code we can refer to it unambiguously by its OccName.  The+OccName for each binder is prefixed by the name of the exported Id+that references it; e.g. if "f" references "x" in its unfolding, then+"x" is renamed to "f_x".  This helps distinguish the different "x"s+from each other, and means that if "f" is later removed, things that+depend on the other "x"s will not need to be recompiled.  Of course,+if there are multiple "f_x"s, then we have to disambiguate somehow; we+use "f_x0", "f_x1" etc.++As far as possible we should assign names in a deterministic fashion.+Each time this module is compiled with the same options, we should end+up with the same set of external names with the same types.  That is,+the ABI hash in the interface should not change.  This turns out to be+quite tricky, since the order of the bindings going into the tidy+phase is already non-deterministic, as it is based on the ordering of+Uniques, which are assigned unpredictably.++To name things in a stable way, we do a depth-first-search of the+bindings, starting from the exports sorted by name.  This way, as long+as the bindings themselves are deterministic (they sometimes aren't!),+the order in which they are presented to the tidying phase does not+affect the names we assign.++Note [Tidy the top-level bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Next we traverse the bindings top to bottom.  For each *top-level*+binder++ 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal,+    reflecting the fact that from now on we regard it as a global,+    not local, Id++ 2. Give it a system-wide Unique.+    [Even non-exported things need system-wide Uniques because the+    byte-code generator builds a single Name->BCO symbol table.]++    We use the NameCache kept in the HscEnv as the+    source of such system-wide uniques.++    For external Ids, use the original-name cache in the NameCache+    to ensure that the unique assigned is the same as the Id had+    in any previous compilation run.++ 3. Rename top-level Ids according to the names we chose in step 1.+    If it's an external Id, make it have a External Name, otherwise+    make it have an Internal Name.  This is used by the code generator+    to decide whether to make the label externally visible++ 4. Give it its UTTERLY FINAL IdInfo; in ptic,+        * its unfolding, if it should have one++        * its arity, computed from the number of visible lambdas++        * its CAF info, computed from what is free in its RHS+++Finally, substitute these new top-level binders consistently+throughout, including in unfoldings.  We also tidy binders in+RHSs, so that they print nicely in interfaces.+-}++tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)+tidyProgram hsc_env  (ModGuts { mg_module    = mod+                              , mg_exports   = exports+                              , mg_rdr_env   = rdr_env+                              , mg_tcs       = tcs+                              , mg_insts     = cls_insts+                              , mg_fam_insts = fam_insts+                              , mg_binds     = binds+                              , mg_patsyns   = patsyns+                              , mg_rules     = imp_rules+                              , mg_anns      = anns+                              , mg_complete_sigs = complete_sigs+                              , mg_deps      = deps+                              , mg_foreign   = foreign_stubs+                              , mg_foreign_files = foreign_files+                              , mg_hpc_info  = hpc_info+                              , mg_modBreaks = modBreaks+                              })++  = Err.withTiming (pure dflags)+                   (text "CoreTidy"<+>brackets (ppr mod))+                   (const ()) $+    do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags+              ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags+              ; print_unqual = mkPrintUnqualified dflags rdr_env+              }++        ; let { type_env = typeEnvFromEntities [] tcs fam_insts++              ; implicit_binds+                  = concatMap getClassImplicitBinds (typeEnvClasses type_env) +++                    concatMap getTyConImplicitBinds (typeEnvTyCons type_env)+              }++        ; (unfold_env, tidy_occ_env)+              <- chooseExternalIds hsc_env mod omit_prags expose_all+                                   binds implicit_binds imp_rules+        ; let { (trimmed_binds, trimmed_rules)+                    = findExternalRules omit_prags binds imp_rules unfold_env }++        ; (tidy_env, tidy_binds)+                 <- tidyTopBinds hsc_env mod unfold_env tidy_occ_env trimmed_binds++        ; let { final_ids  = [ id | id <- bindersOfBinds tidy_binds,+                                    isExternalName (idName id)]+              ; type_env1  = extendTypeEnvWithIds type_env final_ids++              ; tidy_cls_insts = map (tidyClsInstDFun (tidyVarOcc tidy_env)) cls_insts+                -- A DFunId will have a binding in tidy_binds, and so will now be in+                -- tidy_type_env, replete with IdInfo.  Its name will be unchanged since+                -- it was born, but we want Global, IdInfo-rich (or not) DFunId in the+                -- tidy_cls_insts.  Similarly the Ids inside a PatSyn.++              ; tidy_rules = tidyRules tidy_env trimmed_rules+                -- You might worry that the tidy_env contains IdInfo-rich stuff+                -- and indeed it does, but if omit_prags is on, ext_rules is+                -- empty++                -- Tidy the Ids inside each PatSyn, very similarly to DFunIds+                -- and then override the PatSyns in the type_env with the new tidy ones+                -- This is really the only reason we keep mg_patsyns at all; otherwise+                -- they could just stay in type_env+              ; tidy_patsyns = map (tidyPatSynIds (tidyVarOcc tidy_env)) patsyns+              ; type_env2    = extendTypeEnvWithPatSyns tidy_patsyns type_env1++              ; tidy_type_env = tidyTypeEnv omit_prags type_env2+              }+          -- See Note [Grand plan for static forms] in StaticPtrTable.+        ; (spt_entries, tidy_binds') <-+             sptCreateStaticBinds hsc_env mod tidy_binds+        ; let { spt_init_code = sptModuleInitCode mod spt_entries+              ; add_spt_init_code =+                  case hscTarget dflags of+                    -- If we are compiling for the interpreter we will insert+                    -- any necessary SPT entries dynamically+                    HscInterpreted -> id+                    -- otherwise add a C stub to do so+                    _              -> (`appendStubC` spt_init_code)+              }++        ; let { -- See Note [Injecting implicit bindings]+                all_tidy_binds = implicit_binds ++ tidy_binds'++              -- Get the TyCons to generate code for.  Careful!  We must use+              -- the untidied TypeEnv here, because we need+              --  (a) implicit TyCons arising from types and classes defined+              --      in this module+              --  (b) wired-in TyCons, which are normally removed from the+              --      TypeEnv we put in the ModDetails+              --  (c) Constructors even if they are not exported (the+              --      tidied TypeEnv has trimmed these away)+              ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)+              }++        ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules++          -- If the endPass didn't print the rules, but ddump-rules is+          -- on, print now+        ; unless (dopt Opt_D_dump_simpl dflags) $+            Err.dumpIfSet_dyn dflags Opt_D_dump_rules+              (showSDoc dflags (ppr CoreTidy <+> text "rules"))+              (pprRulesForUser dflags tidy_rules)++          -- Print one-line size info+        ; let cs = coreBindsStats tidy_binds+        ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats"+            (text "Tidy size (terms,types,coercions)"+             <+> ppr (moduleName mod) <> colon+             <+> int (cs_tm cs)+             <+> int (cs_ty cs)+             <+> int (cs_co cs) )++        ; return (CgGuts { cg_module   = mod,+                           cg_tycons   = alg_tycons,+                           cg_binds    = all_tidy_binds,+                           cg_foreign  = add_spt_init_code foreign_stubs,+                           cg_foreign_files = foreign_files,+                           cg_dep_pkgs = map fst $ dep_pkgs deps,+                           cg_hpc_info = hpc_info,+                           cg_modBreaks = modBreaks,+                           cg_spt_entries = spt_entries },++                   ModDetails { md_types     = tidy_type_env,+                                md_rules     = tidy_rules,+                                md_insts     = tidy_cls_insts,+                                md_fam_insts = fam_insts,+                                md_exports   = exports,+                                md_anns      = anns,      -- are already tidy+                                md_complete_sigs = complete_sigs+                              })+        }+  where+    dflags = hsc_dflags hsc_env++tidyTypeEnv :: Bool       -- Compiling without -O, so omit prags+            -> TypeEnv -> TypeEnv++-- The completed type environment is gotten from+--      a) the types and classes defined here (plus implicit things)+--      b) adding Ids with correct IdInfo, including unfoldings,+--              gotten from the bindings+-- From (b) we keep only those Ids with External names;+--          the CoreTidy pass makes sure these are all and only+--          the externally-accessible ones+-- This truncates the type environment to include only the+-- exported Ids and things needed from them, which saves space+--+-- See Note [Don't attempt to trim data types]++tidyTypeEnv omit_prags type_env+ = let+        type_env1 = filterNameEnv (not . isWiredInName . getName) type_env+          -- (1) remove wired-in things+        type_env2 | omit_prags = mapNameEnv trimThing type_env1+                  | otherwise  = type_env1+          -- (2) trimmed if necessary+    in+    type_env2++--------------------------+trimThing :: TyThing -> TyThing+-- Trim off inessentials, for boot files and no -O+trimThing (AnId id)+   | not (isImplicitId id)+   = AnId (id `setIdInfo` vanillaIdInfo)++trimThing other_thing+  = other_thing++extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv+extendTypeEnvWithPatSyns tidy_patsyns type_env+  = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]++{-+Note [Don't attempt to trim data types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For some time GHC tried to avoid exporting the data constructors+of a data type if it wasn't strictly necessary to do so; see #835.+But "strictly necessary" accumulated a longer and longer list+of exceptions, and finally I gave up the battle:++    commit 9a20e540754fc2af74c2e7392f2786a81d8d5f11+    Author: Simon Peyton Jones <simonpj@microsoft.com>+    Date:   Thu Dec 6 16:03:16 2012 +0000++    Stop attempting to "trim" data types in interface files++    Without -O, we previously tried to make interface files smaller+    by not including the data constructors of data types.  But+    there are a lot of exceptions, notably when Template Haskell is+    involved or, more recently, DataKinds.++    However #7445 shows that even without TemplateHaskell, using+    the Data class and invoking Language.Haskell.TH.Quote.dataToExpQ+    is enough to require us to expose the data constructors.++    So I've given up on this "optimisation" -- it's probably not+    important anyway.  Now I'm simply not attempting to trim off+    the data constructors.  The gain in simplicity is worth the+    modest cost in interface file growth, which is limited to the+    bits reqd to describe those data constructors.++************************************************************************+*                                                                      *+        Implicit bindings+*                                                                      *+************************************************************************++Note [Injecting implicit bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We inject the implicit bindings right at the end, in CoreTidy.+Some of these bindings, notably record selectors, are not+constructed in an optimised form.  E.g. record selector for+        data T = MkT { x :: {-# UNPACK #-} !Int }+Then the unfolding looks like+        x = \t. case t of MkT x1 -> let x = I# x1 in x+This generates bad code unless it's first simplified a bit.  That is+why CoreUnfold.mkImplicitUnfolding uses simpleOptExpr to do a bit of+optimisation first.  (Only matters when the selector is used curried;+eg map x ys.)  See #2070.++[Oct 09: in fact, record selectors are no longer implicit Ids at all,+because we really do want to optimise them properly. They are treated+much like any other Id.  But doing "light" optimisation on an implicit+Id still makes sense.]++At one time I tried injecting the implicit bindings *early*, at the+beginning of SimplCore.  But that gave rise to real difficulty,+because GlobalIds are supposed to have *fixed* IdInfo, but the+simplifier and other core-to-core passes mess with IdInfo all the+time.  The straw that broke the camels back was when a class selector+got the wrong arity -- ie the simplifier gave it arity 2, whereas+importing modules were expecting it to have arity 1 (#2844).+It's much safer just to inject them right at the end, after tidying.++Oh: two other reasons for injecting them late:++  - If implicit Ids are already in the bindings when we start TidyPgm,+    we'd have to be careful not to treat them as external Ids (in+    the sense of chooseExternalIds); else the Ids mentioned in *their*+    RHSs will be treated as external and you get an interface file+    saying      a18 = <blah>+    but nothing referring to a18 (because the implicit Id is the+    one that does, and implicit Ids don't appear in interface files).++  - More seriously, the tidied type-envt will include the implicit+    Id replete with a18 in its unfolding; but we won't take account+    of a18 when computing a fingerprint for the class; result chaos.++There is one sort of implicit binding that is injected still later,+namely those for data constructor workers. Reason (I think): it's+really just a code generation trick.... binding itself makes no sense.+See Note [Data constructor workers] in CorePrep.+-}++getTyConImplicitBinds :: TyCon -> [CoreBind]+getTyConImplicitBinds tc = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))++getClassImplicitBinds :: Class -> [CoreBind]+getClassImplicitBinds cls+  = [ NonRec op (mkDictSelRhs cls val_index)+    | (op, val_index) <- classAllSelIds cls `zip` [0..] ]++get_defn :: Id -> CoreBind+get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))++{-+************************************************************************+*                                                                      *+\subsection{Step 1: finding externals}+*                                                                      *+************************************************************************++See Note [Choosing external Ids].+-}++type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})+  -- Maps each top-level Id to its new Name (the Id is tidied in step 2)+  -- The Unique is unchanged.  If the new Name is external, it will be+  -- visible in the interface file.+  --+  -- Bool => expose unfolding or not.++chooseExternalIds :: HscEnv+                  -> Module+                  -> Bool -> Bool+                  -> [CoreBind]+                  -> [CoreBind]+                  -> [CoreRule]+                  -> IO (UnfoldEnv, TidyOccEnv)+                  -- Step 1 from the notes above++chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules+  = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env+       ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders+       ; tidy_internal internal_ids unfold_env1 occ_env1 }+ where+  nc_var = hsc_NC hsc_env++  -- init_ext_ids is the initial list of Ids that should be+  -- externalised.  It serves as the starting point for finding a+  -- deterministic, tidy, renaming for all external Ids in this+  -- module.+  --+  -- It is sorted, so that it has a deterministic order (i.e. it's the+  -- same list every time this module is compiled), in contrast to the+  -- bindings, which are ordered non-deterministically.+  init_work_list = zip init_ext_ids init_ext_ids+  init_ext_ids   = sortBy (compare `on` getOccName) $ filter is_external binders++  -- An Id should be external if either (a) it is exported,+  -- (b) it appears in the RHS of a local rule for an imported Id, or+  -- See Note [Which rules to expose]+  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars++  rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules++  binders          = map fst $ flattenBinds binds+  implicit_binders = bindersOfBinds implicit_binds+  binder_set       = mkVarSet binders++  avoids   = [getOccName name | bndr <- binders ++ implicit_binders,+                                let name = idName bndr,+                                isExternalName name ]+                -- In computing our "avoids" list, we must include+                --      all implicit Ids+                --      all things with global names (assigned once and for+                --                                      all by the renamer)+                -- since their names are "taken".+                -- The type environment is a convenient source of such things.+                -- In particular, the set of binders doesn't include+                -- implicit Ids at this stage.++        -- We also make sure to avoid any exported binders.  Consider+        --      f{-u1-} = 1     -- Local decl+        --      ...+        --      f{-u2-} = 2     -- Exported decl+        --+        -- The second exported decl must 'get' the name 'f', so we+        -- have to put 'f' in the avoids list before we get to the first+        -- decl.  tidyTopId then does a no-op on exported binders.+  init_occ_env = initTidyOccEnv avoids+++  search :: [(Id,Id)]    -- The work-list: (external id, referring id)+                         -- Make a tidy, external Name for the external id,+                         --   add it to the UnfoldEnv, and do the same for the+                         --   transitive closure of Ids it refers to+                         -- The referring id is used to generate a tidy+                         ---  name for the external id+         -> UnfoldEnv    -- id -> (new Name, show_unfold)+         -> TidyOccEnv   -- occ env for choosing new Names+         -> IO (UnfoldEnv, TidyOccEnv)++  search [] unfold_env occ_env = return (unfold_env, occ_env)++  search ((idocc,referrer) : rest) unfold_env occ_env+    | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env+    | otherwise = do+      (occ_env', name') <- tidyTopName mod nc_var (Just referrer) occ_env idocc+      let+          (new_ids, show_unfold)+                | omit_prags = ([], False)+                | otherwise  = addExternal expose_all refined_id++                -- 'idocc' is an *occurrence*, but we need to see the+                -- unfolding in the *definition*; so look up in binder_set+          refined_id = case lookupVarSet binder_set idocc of+                         Just id -> id+                         Nothing -> WARN( True, ppr idocc ) idocc++          unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)+          referrer' | isExportedId refined_id = refined_id+                    | otherwise               = referrer+      --+      search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env'++  tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv+                -> IO (UnfoldEnv, TidyOccEnv)+  tidy_internal []       unfold_env occ_env = return (unfold_env,occ_env)+  tidy_internal (id:ids) unfold_env occ_env = do+      (occ_env', name') <- tidyTopName mod nc_var Nothing occ_env id+      let unfold_env' = extendVarEnv unfold_env id (name',False)+      tidy_internal ids unfold_env' occ_env'++addExternal :: Bool -> Id -> ([Id], Bool)+addExternal expose_all id = (new_needed_ids, show_unfold)+  where+    new_needed_ids = bndrFvsInOrder show_unfold id+    idinfo         = idInfo id+    show_unfold    = show_unfolding (unfoldingInfo idinfo)+    never_active   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))+    loop_breaker   = isStrongLoopBreaker (occInfo idinfo)+    bottoming_fn   = isBottomingSig (strictnessInfo idinfo)++        -- Stuff to do with the Id's unfolding+        -- We leave the unfolding there even if there is a worker+        -- In GHCi the unfolding is used by importers++    show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })+       =  expose_all         -- 'expose_all' says to expose all+                             -- unfoldings willy-nilly++       || isStableSource src     -- Always expose things whose+                                 -- source is an inline rule++       || not (bottoming_fn      -- No need to inline bottom functions+           || never_active       -- Or ones that say not to+           || loop_breaker       -- Or that are loop breakers+           || neverUnfoldGuidance guidance)+    show_unfolding (DFunUnfolding {}) = True+    show_unfolding _                  = False++{-+************************************************************************+*                                                                      *+               Deterministic free variables+*                                                                      *+************************************************************************++We want a deterministic free-variable list.  exprFreeVars gives us+a VarSet, which is in a non-deterministic order when converted to a+list.  Hence, here we define a free-variable finder that returns+the free variables in the order that they are encountered.++See Note [Choosing external Ids]+-}++bndrFvsInOrder :: Bool -> Id -> [Id]+bndrFvsInOrder show_unfold id+  = run (dffvLetBndr show_unfold id)++run :: DFFV () -> [Id]+run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of+                 ((_,ids),_) -> ids++newtype DFFV a+  = DFFV (VarSet              -- Envt: non-top-level things that are in scope+                              -- we don't want to record these as free vars+      -> (VarSet, [Var])      -- Input State: (set, list) of free vars so far+      -> ((VarSet,[Var]),a))  -- Output state++instance Functor DFFV where+    fmap = liftM++instance Applicative DFFV where+    pure a = DFFV $ \_ st -> (st, a)+    (<*>) = ap++instance Monad DFFV where+  (DFFV m) >>= k = DFFV $ \env st ->+    case m env st of+       (st',a) -> case k a of+                     DFFV f -> f env st'++extendScope :: Var -> DFFV a -> DFFV a+extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st)++extendScopeList :: [Var] -> DFFV a -> DFFV a+extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st)++insert :: Var -> DFFV ()+insert v = DFFV $ \ env (set, ids) ->+           let keep_me = isLocalId v &&+                         not (v `elemVarSet` env) &&+                           not (v `elemVarSet` set)+           in if keep_me+              then ((extendVarSet set v, v:ids), ())+              else ((set,                ids),   ())+++dffvExpr :: CoreExpr -> DFFV ()+dffvExpr (Var v)              = insert v+dffvExpr (App e1 e2)          = dffvExpr e1 >> dffvExpr e2+dffvExpr (Lam v e)            = extendScope v (dffvExpr e)+dffvExpr (Tick (Breakpoint _ ids) e) = mapM_ insert ids >> dffvExpr e+dffvExpr (Tick _other e)    = dffvExpr e+dffvExpr (Cast e _)           = dffvExpr e+dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e)+dffvExpr (Let (Rec prs) e)    = extendScopeList (map fst prs) $+                                (mapM_ dffvBind prs >> dffvExpr e)+dffvExpr (Case e b _ as)      = dffvExpr e >> extendScope b (mapM_ dffvAlt as)+dffvExpr _other               = return ()++dffvAlt :: (t, [Var], CoreExpr) -> DFFV ()+dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r)++dffvBind :: (Id, CoreExpr) -> DFFV ()+dffvBind(x,r)+  | not (isId x) = dffvExpr r+  | otherwise    = dffvLetBndr False x >> dffvExpr r+                -- Pass False because we are doing the RHS right here+                -- If you say True you'll get *exponential* behaviour!++dffvLetBndr :: Bool -> Id -> DFFV ()+-- Gather the free vars of the RULES and unfolding of a binder+-- We always get the free vars of a *stable* unfolding, but+-- for a *vanilla* one (InlineRhs), the flag controls what happens:+--   True <=> get fvs of even a *vanilla* unfolding+--   False <=> ignore an InlineRhs+-- For nested bindings (call from dffvBind) we always say "False" because+--       we are taking the fvs of the RHS anyway+-- For top-level bindings (call from addExternal, via bndrFvsInOrder)+--       we say "True" if we are exposing that unfolding+dffvLetBndr vanilla_unfold id+  = do { go_unf (unfoldingInfo idinfo)+       ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) }+  where+    idinfo = idInfo id++    go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src })+       = case src of+           InlineRhs | vanilla_unfold -> dffvExpr rhs+                     | otherwise      -> return ()+           _                          -> dffvExpr rhs++    go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args })+             = extendScopeList bndrs $ mapM_ dffvExpr args+    go_unf _ = return ()++    go_rule (BuiltinRule {}) = return ()+    go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs })+      = extendScopeList bndrs (dffvExpr rhs)++{-+************************************************************************+*                                                                      *+               findExternalRules+*                                                                      *+************************************************************************++Note [Finding external rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The complete rules are gotten by combining+   a) local rules for imported Ids+   b) rules embedded in the top-level Ids++There are two complications:+  * Note [Which rules to expose]+  * Note [Trimming auto-rules]++Note [Which rules to expose]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The function 'expose_rule' filters out rules that mention, on the LHS,+Ids that aren't externally visible; these rules can't fire in a client+module.++The externally-visible binders are computed (by chooseExternalIds)+assuming that all orphan rules are externalised (see init_ext_ids in+function 'search'). So in fact it's a bit conservative and we may+export more than we need.  (It's a sort of mutual recursion.)++Note [Trimming auto-rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Second, with auto-specialisation we may specialise local or imported+dfuns or INLINE functions, and then later inline them.  That may leave+behind something like+   RULE "foo" forall d. f @ Int d = f_spec+where f is either local or imported, and there is no remaining+reference to f_spec except from the RULE.++Now that RULE *might* be useful to an importing module, but that is+purely speculative, and meanwhile the code is taking up space and+codegen time.  I found that binary sizes jumped by 6-10% when I+started to specialise INLINE functions (again, Note [Inline+specialisations] in Specialise).++So it seems better to drop the binding for f_spec, and the rule+itself, if the auto-generated rule is the *only* reason that it is+being kept alive.++(The RULE still might have been useful in the past; that is, it was+the right thing to have generated it in the first place.  See Note+[Inline specialisations] in Specialise.  But now it has served its+purpose, and can be discarded.)++So findExternalRules does this:+  * Remove all bindings that are kept alive *only* by isAutoRule rules+      (this is done in trim_binds)+  * Remove all auto rules that mention bindings that have been removed+      (this is done by filtering by keep_rule)++NB: if a binding is kept alive for some *other* reason (e.g. f_spec is+called in the final code), we keep the rule too.++This stuff is the only reason for the ru_auto field in a Rule.+-}++findExternalRules :: Bool       -- Omit pragmas+                  -> [CoreBind]+                  -> [CoreRule] -- Local rules for imported fns+                  -> UnfoldEnv  -- Ids that are exported, so we need their rules+                  -> ([CoreBind], [CoreRule])+-- See Note [Finding external rules]+findExternalRules omit_prags binds imp_id_rules unfold_env+  = (trimmed_binds, filter keep_rule all_rules)+  where+    imp_rules         = filter expose_rule imp_id_rules+    imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules++    user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet+                           | otherwise       = ruleRhsFreeVars rule++    (trimmed_binds, local_bndrs, _, all_rules) = trim_binds binds++    keep_rule rule = ruleFreeVars rule `subVarSet` local_bndrs+        -- Remove rules that make no sense, because they mention a+        -- local binder (on LHS or RHS) that we have now discarded.+        -- (NB: ruleFreeVars only includes LocalIds)+        --+        -- LHS: we have already filtered out rules that mention internal Ids+        --     on LHS but that isn't enough because we might have by now+        --     discarded a binding with an external Id. (How?+        --     chooseExternalIds is a bit conservative.)+        --+        -- RHS: the auto rules that might mention a binder that has+        --      been discarded; see Note [Trimming auto-rules]++    expose_rule rule+        | omit_prags = False+        | otherwise  = all is_external_id (ruleLhsFreeIdsList rule)+                -- Don't expose a rule whose LHS mentions a locally-defined+                -- Id that is completely internal (i.e. not visible to an+                -- importing module).  NB: ruleLhsFreeIds only returns LocalIds.+                -- See Note [Which rules to expose]++    is_external_id id = case lookupVarEnv unfold_env id of+                          Just (name, _) -> isExternalName name+                          Nothing        -> False++    trim_binds :: [CoreBind]+               -> ( [CoreBind]   -- Trimmed bindings+                  , VarSet       -- Binders of those bindings+                  , VarSet       -- Free vars of those bindings + rhs of user rules+                                 -- (we don't bother to delete the binders)+                  , [CoreRule])  -- All rules, imported + from the bindings+    -- This function removes unnecessary bindings, and gathers up rules from+    -- the bindings we keep.  See Note [Trimming auto-rules]+    trim_binds []  -- Base case, start with imp_user_rule_fvs+       = ([], emptyVarSet, imp_user_rule_fvs, imp_rules)++    trim_binds (bind:binds)+       | any needed bndrs    -- Keep binding+       = ( bind : binds', bndr_set', needed_fvs', local_rules ++ rules )+       | otherwise           -- Discard binding altogether+       = stuff+       where+         stuff@(binds', bndr_set, needed_fvs, rules)+                       = trim_binds binds+         needed bndr   = isExportedId bndr || bndr `elemVarSet` needed_fvs++         bndrs         = bindersOf  bind+         rhss          = rhssOfBind bind+         bndr_set'     = bndr_set `extendVarSetList` bndrs++         needed_fvs'   = needed_fvs                                   `unionVarSet`+                         mapUnionVarSet idUnfoldingVars   bndrs       `unionVarSet`+                              -- Ignore type variables in the type of bndrs+                         mapUnionVarSet exprFreeVars      rhss        `unionVarSet`+                         mapUnionVarSet user_rule_rhs_fvs local_rules+            -- In needed_fvs', we don't bother to delete binders from the fv set++         local_rules  = [ rule+                        | id <- bndrs+                        , is_external_id id   -- Only collect rules for external Ids+                        , rule <- idCoreRules id+                        , expose_rule rule ]  -- and ones that can fire in a client++{-+************************************************************************+*                                                                      *+               tidyTopName+*                                                                      *+************************************************************************++This is where we set names to local/global based on whether they really are+externally visible (see comment at the top of this module).  If the name+was previously local, we have to give it a unique occurrence name if+we intend to externalise it.+-}++tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv+            -> Id -> IO (TidyOccEnv, Name)+tidyTopName mod nc_var maybe_ref occ_env id+  | global && internal = return (occ_env, localiseName name)++  | global && external = return (occ_env, name)+        -- Global names are assumed to have been allocated by the renamer,+        -- so they already have the "right" unique+        -- And it's a system-wide unique too++  -- Now we get to the real reason that all this is in the IO Monad:+  -- we have to update the name cache in a nice atomic fashion++  | local  && internal = do { new_local_name <- atomicModifyIORef' nc_var mk_new_local+                            ; return (occ_env', new_local_name) }+        -- Even local, internal names must get a unique occurrence, because+        -- if we do -split-objs we externalise the name later, in the code generator+        --+        -- Similarly, we must make sure it has a system-wide Unique, because+        -- the byte-code generator builds a system-wide Name->BCO symbol table++  | local  && external = do { new_external_name <- atomicModifyIORef' nc_var mk_new_external+                            ; return (occ_env', new_external_name) }++  | otherwise = panic "tidyTopName"+  where+    name        = idName id+    external    = isJust maybe_ref+    global      = isExternalName name+    local       = not global+    internal    = not external+    loc         = nameSrcSpan name++    old_occ     = nameOccName name+    new_occ | Just ref <- maybe_ref+            , ref /= id+            = mkOccName (occNameSpace old_occ) $+                   let+                       ref_str = occNameString (getOccName ref)+                       occ_str = occNameString old_occ+                   in+                   case occ_str of+                     '$':'w':_ -> occ_str+                        -- workers: the worker for a function already+                        -- includes the occname for its parent, so there's+                        -- no need to prepend the referrer.+                     _other | isSystemName name -> ref_str+                            | otherwise         -> ref_str ++ '_' : occ_str+                        -- If this name was system-generated, then don't bother+                        -- to retain its OccName, just use the referrer.  These+                        -- system-generated names will become "f1", "f2", etc. for+                        -- a referrer "f".+            | otherwise = old_occ++    (occ_env', occ') = tidyOccName occ_env new_occ++    mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc)+                    where+                      (uniq, us) = takeUniqFromSupply (nsUniqs nc)++    mk_new_external nc = allocateGlobalBinder nc mod occ' loc+        -- If we want to externalise a currently-local name, check+        -- whether we have already assigned a unique for it.+        -- If so, use it; if not, extend the table.+        -- All this is done by allcoateGlobalBinder.+        -- This is needed when *re*-compiling a module in GHCi; we must+        -- use the same name for externally-visible things as we did before.++{-+************************************************************************+*                                                                      *+\subsection{Step 2: top-level tidying}+*                                                                      *+************************************************************************+-}++-- TopTidyEnv: when tidying we need to know+--   * nc_var: The NameCache, containing a unique supply and any pre-ordained Names.+--        These may have arisen because the+--        renamer read in an interface file mentioning M.$wf, say,+--        and assigned it unique r77.  If, on this compilation, we've+--        invented an Id whose name is $wf (but with a different unique)+--        we want to rename it to have unique r77, so that we can do easy+--        comparisons with stuff from the interface file+--+--   * occ_env: The TidyOccEnv, which tells us which local occurrences+--     are 'used'+--+--   * subst_env: A Var->Var mapping that substitutes the new Var for the old++tidyTopBinds :: HscEnv+             -> Module+             -> UnfoldEnv+             -> TidyOccEnv+             -> CoreProgram+             -> IO (TidyEnv, CoreProgram)++tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds+  = do mkIntegerId <- lookupMkIntegerName dflags hsc_env+       mkNaturalId <- lookupMkNaturalName dflags hsc_env+       integerSDataCon <- lookupIntegerSDataConName dflags hsc_env+       naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env+       let cvt_literal nt i = case nt of+             LitNumInteger -> Just (cvtLitInteger dflags mkIntegerId integerSDataCon i)+             LitNumNatural -> Just (cvtLitNatural dflags mkNaturalId naturalSDataCon i)+             _             -> Nothing+           result      = tidy cvt_literal init_env binds+       seqBinds (snd result) `seq` return result+       -- This seqBinds avoids a spike in space usage (see #13564)+  where+    dflags = hsc_dflags hsc_env++    init_env = (init_occ_env, emptyVarEnv)++    tidy _           env []     = (env, [])+    tidy cvt_literal env (b:bs)+        = let (env1, b')  = tidyTopBind dflags this_mod cvt_literal unfold_env+                                        env b+              (env2, bs') = tidy cvt_literal env1 bs+          in  (env2, b':bs')++------------------------+tidyTopBind  :: DynFlags+             -> Module+             -> (LitNumType -> Integer -> Maybe CoreExpr)+             -> UnfoldEnv+             -> TidyEnv+             -> CoreBind+             -> (TidyEnv, CoreBind)++tidyTopBind dflags this_mod cvt_literal unfold_env+            (occ_env,subst1) (NonRec bndr rhs)+  = (tidy_env2,  NonRec bndr' rhs')+  where+    Just (name',show_unfold) = lookupVarEnv unfold_env bndr+    caf_info      = hasCafRefs dflags this_mod+                               (subst1, cvt_literal)+                               (idArity bndr) rhs+    (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name'+                                (bndr, rhs)+    subst2        = extendVarEnv subst1 bndr bndr'+    tidy_env2     = (occ_env, subst2)++tidyTopBind dflags this_mod cvt_literal unfold_env+            (occ_env, subst1) (Rec prs)+  = (tidy_env2, Rec prs')+  where+    prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs)+           | (id,rhs) <- prs,+             let (name',show_unfold) =+                    expectJust "tidyTopBind" $ lookupVarEnv unfold_env id+           ]++    subst2    = extendVarEnvList subst1 (bndrs `zip` map fst prs')+    tidy_env2 = (occ_env, subst2)++    bndrs = map fst prs++        -- the CafInfo for a recursive group says whether *any* rhs in+        -- the group may refer indirectly to a CAF (because then, they all do).+    caf_info+        | or [ mayHaveCafRefs (hasCafRefs dflags this_mod+                                          (subst1, cvt_literal)+                                          (idArity bndr) rhs)+             | (bndr,rhs) <- prs ] = MayHaveCafRefs+        | otherwise                = NoCafRefs++-----------------------------------------------------------+tidyTopPair :: DynFlags+            -> Bool  -- show unfolding+            -> TidyEnv  -- The TidyEnv is used to tidy the IdInfo+                        -- It is knot-tied: don't look at it!+            -> CafInfo+            -> Name             -- New name+            -> (Id, CoreExpr)   -- Binder and RHS before tidying+            -> (Id, CoreExpr)+        -- This function is the heart of Step 2+        -- The rec_tidy_env is the one to use for the IdInfo+        -- It's necessary because when we are dealing with a recursive+        -- group, a variable late in the group might be mentioned+        -- in the IdInfo of one early in the group++tidyTopPair dflags show_unfold rhs_tidy_env caf_info name' (bndr, rhs)+  = (bndr1, rhs1)+  where+    bndr1    = mkGlobalId details name' ty' idinfo'+    details  = idDetails bndr   -- Preserve the IdDetails+    ty'      = tidyTopType (idType bndr)+    rhs1     = tidyExpr rhs_tidy_env rhs+    idinfo'  = tidyTopIdInfo dflags rhs_tidy_env name' rhs rhs1 (idInfo bndr)+                             show_unfold caf_info++-- tidyTopIdInfo creates the final IdInfo for top-level+-- binders.  There are two delicate pieces:+--+--  * Arity.  After CoreTidy, this arity must not change any more.+--      Indeed, CorePrep must eta expand where necessary to make+--      the manifest arity equal to the claimed arity.+--+--  * CAF info.  This must also remain valid through to code generation.+--      We add the info here so that it propagates to all+--      occurrences of the binders in RHSs, and hence to occurrences in+--      unfoldings, which are inside Ids imported by GHCi. Ditto RULES.+--      CoreToStg makes use of this when constructing SRTs.+tidyTopIdInfo :: DynFlags -> TidyEnv -> Name -> CoreExpr -> CoreExpr+              -> IdInfo -> Bool -> CafInfo -> IdInfo+tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info+  | not is_external     -- For internal Ids (not externally visible)+  = vanillaIdInfo       -- we only need enough info for code generation+                        -- Arity and strictness info are enough;+                        --      c.f. CoreTidy.tidyLetBndr+        `setCafInfo`        caf_info+        `setArityInfo`      arity+        `setStrictnessInfo` final_sig+        `setUnfoldingInfo`  minimal_unfold_info  -- See note [Preserve evaluatedness]+                                                 -- in CoreTidy++  | otherwise           -- Externally-visible Ids get the whole lot+  = vanillaIdInfo+        `setCafInfo`           caf_info+        `setArityInfo`         arity+        `setStrictnessInfo`    final_sig+        `setOccInfo`           robust_occ_info+        `setInlinePragInfo`    (inlinePragInfo idinfo)+        `setUnfoldingInfo`     unfold_info+                -- NB: we throw away the Rules+                -- They have already been extracted by findExternalRules+  where+    is_external = isExternalName name++    --------- OccInfo ------------+    robust_occ_info = zapFragileOcc (occInfo idinfo)+    -- It's important to keep loop-breaker information+    -- when we are doing -fexpose-all-unfoldings++    --------- Strictness ------------+    mb_bot_str = exprBotStrictness_maybe orig_rhs++    sig = strictnessInfo idinfo+    final_sig | not $ isTopSig sig+              = WARN( _bottom_hidden sig , ppr name ) sig+              -- try a cheap-and-cheerful bottom analyser+              | Just (_, nsig) <- mb_bot_str = nsig+              | otherwise                    = sig++    _bottom_hidden id_sig = case mb_bot_str of+                                  Nothing         -> False+                                  Just (arity, _) -> not (appIsBottom id_sig arity)++    --------- Unfolding ------------+    unf_info = unfoldingInfo idinfo+    unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs+                | otherwise   = minimal_unfold_info+    minimal_unfold_info = zapUnfolding unf_info+    unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs+    is_bot = isBottomingSig final_sig+    -- NB: do *not* expose the worker if show_unfold is off,+    --     because that means this thing is a loop breaker or+    --     marked NOINLINE or something like that+    -- This is important: if you expose the worker for a loop-breaker+    -- then you can make the simplifier go into an infinite loop, because+    -- in effect the unfolding is exposed.  See #1709+    --+    -- You might think that if show_unfold is False, then the thing should+    -- not be w/w'd in the first place.  But a legitimate reason is this:+    --    the function returns bottom+    -- In this case, show_unfold will be false (we don't expose unfoldings+    -- for bottoming functions), but we might still have a worker/wrapper+    -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.hs+++    --------- Arity ------------+    -- Usually the Id will have an accurate arity on it, because+    -- the simplifier has just run, but not always.+    -- One case I found was when the last thing the simplifier+    -- did was to let-bind a non-atomic argument and then float+    -- it to the top level. So it seems more robust just to+    -- fix it here.+    arity = exprArity orig_rhs++{-+************************************************************************+*                                                                      *+           Figuring out CafInfo for an expression+*                                                                      *+************************************************************************++hasCafRefs decides whether a top-level closure can point into the dynamic heap.+We mark such things as `MayHaveCafRefs' because this information is+used to decide whether a particular closure needs to be referenced+in an SRT or not.++There are two reasons for setting MayHaveCafRefs:+        a) The RHS is a CAF: a top-level updatable thunk.+        b) The RHS refers to something that MayHaveCafRefs++Possible improvement: In an effort to keep the number of CAFs (and+hence the size of the SRTs) down, we could also look at the expression and+decide whether it requires a small bounded amount of heap, so we can ignore+it as a CAF.  In these cases however, we would need to use an additional+CAF list to keep track of non-collectable CAFs.++Note [Disgusting computation of CafRefs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We compute hasCafRefs here, because IdInfo is supposed to be finalised+after TidyPgm.  But CorePrep does some transformations that affect CAF-hood.+So we have to *predict* the result here, which is revolting.++In particular CorePrep expands Integer and Natural literals. So in the+prediction code here we resort to applying the same expansion (cvt_literal).+Ugh!+-}++type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr)+  -- The env finds the Caf-ness of the Id+  -- The LitNumType -> Integer -> CoreExpr is the desugaring functions for+  -- Integer and Natural literals+  -- See Note [Disgusting computation of CafRefs]++hasCafRefs :: DynFlags -> Module+           -> CafRefEnv -> Arity -> CoreExpr+           -> CafInfo+hasCafRefs dflags this_mod (subst, cvt_literal) arity expr+  | is_caf || mentions_cafs = MayHaveCafRefs+  | otherwise               = NoCafRefs+ where+  mentions_cafs   = cafRefsE expr+  is_dynamic_name = isDllName dflags this_mod+  is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name+                                         cvt_literal expr)++  -- NB. we pass in the arity of the expression, which is expected+  -- to be calculated by exprArity.  This is because exprArity+  -- knows how much eta expansion is going to be done by+  -- CorePrep later on, and we don't want to duplicate that+  -- knowledge in rhsIsStatic below.++  cafRefsE :: Expr a -> Bool+  cafRefsE (Var id)            = cafRefsV id+  cafRefsE (Lit lit)           = cafRefsL lit+  cafRefsE (App f a)           = cafRefsE f || cafRefsE a+  cafRefsE (Lam _ e)           = cafRefsE e+  cafRefsE (Let b e)           = cafRefsEs (rhssOfBind b) || cafRefsE e+  cafRefsE (Case e _ _ alts)   = cafRefsE e || cafRefsEs (rhssOfAlts alts)+  cafRefsE (Tick _n e)         = cafRefsE e+  cafRefsE (Cast e _co)        = cafRefsE e+  cafRefsE (Type _)            = False+  cafRefsE (Coercion _)        = False++  cafRefsEs :: [Expr a] -> Bool+  cafRefsEs []     = False+  cafRefsEs (e:es) = cafRefsE e || cafRefsEs es++  cafRefsL :: Literal -> Bool+  -- Don't forget that mk_integer id might have Caf refs!+  -- We first need to convert the Integer into its final form, to+  -- see whether mkInteger is used. Same for LitNatural.+  cafRefsL (LitNumber nt i _) = case cvt_literal nt i of+    Just e  -> cafRefsE e+    Nothing -> False+  cafRefsL _                = False++  cafRefsV :: Id -> Bool+  cafRefsV id+    | not (isLocalId id)                = mayHaveCafRefs (idCafInfo id)+    | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id')+    | otherwise                         = False+++{-+************************************************************************+*                                                                      *+                  Old, dead, type-trimming code+*                                                                      *+************************************************************************++We used to try to "trim off" the constructors of data types that are+not exported, to reduce the size of interface files, at least without+-O.  But that is not always possible: see the old Note [When we can't+trim types] below for exceptions.++Then (#7445) I realised that the TH problem arises for any data type+that we have deriving( Data ), because we can invoke+   Language.Haskell.TH.Quote.dataToExpQ+to get a TH Exp representation of a value built from that data type.+You don't even need {-# LANGUAGE TemplateHaskell #-}.++At this point I give up. The pain of trimming constructors just+doesn't seem worth the gain.  So I've dumped all the code, and am just+leaving it here at the end of the module in case something like this+is ever resurrected.+++Note [When we can't trim types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The basic idea of type trimming is to export algebraic data types+abstractly (without their data constructors) when compiling without+-O, unless of course they are explicitly exported by the user.++We always export synonyms, because they can be mentioned in the type+of an exported Id.  We could do a full dependency analysis starting+from the explicit exports, but that's quite painful, and not done for+now.++But there are some times we can't do that, indicated by the 'no_trim_types' flag.++First, Template Haskell.  Consider (#2386) this+        module M(T, makeOne) where+          data T = Yay String+          makeOne = [| Yay "Yep" |]+Notice that T is exported abstractly, but makeOne effectively exports it too!+A module that splices in $(makeOne) will then look for a declaration of Yay,+so it'd better be there.  Hence, brutally but simply, we switch off type+constructor trimming if TH is enabled in this module.++Second, data kinds.  Consider (#5912)+     {-# LANGUAGE DataKinds #-}+     module M() where+     data UnaryTypeC a = UnaryDataC a+     type Bug = 'UnaryDataC+We always export synonyms, so Bug is exposed, and that means that+UnaryTypeC must be too, even though it's not explicitly exported.  In+effect, DataKinds means that we'd need to do a full dependency analysis+to see what data constructors are mentioned.  But we don't do that yet.++In these two cases we just switch off type trimming altogether.++mustExposeTyCon :: Bool         -- Type-trimming flag+                -> NameSet      -- Exports+                -> TyCon        -- The tycon+                -> Bool         -- Can its rep be hidden?+-- We are compiling without -O, and thus trying to write as little as+-- possible into the interface file.  But we must expose the details of+-- any data types whose constructors or fields are exported+mustExposeTyCon no_trim_types exports tc+  | no_trim_types               -- See Note [When we can't trim types]+  = True++  | not (isAlgTyCon tc)         -- Always expose synonyms (otherwise we'd have to+                                -- figure out whether it was mentioned in the type+                                -- of any other exported thing)+  = True++  | isEnumerationTyCon tc       -- For an enumeration, exposing the constructors+  = True                        -- won't lead to the need for further exposure++  | isFamilyTyCon tc            -- Open type family+  = True++  -- Below here we just have data/newtype decls or family instances++  | null data_cons              -- Ditto if there are no data constructors+  = True                        -- (NB: empty data types do not count as enumerations+                                -- see Note [Enumeration types] in TyCon++  | any exported_con data_cons  -- Expose rep if any datacon or field is exported+  = True++  | isNewTyCon tc && isFFITy (snd (newTyConRhs tc))+  = True   -- Expose the rep for newtypes if the rep is an FFI type.+           -- For a very annoying reason.  'Foreign import' is meant to+           -- be able to look through newtypes transparently, but it+           -- can only do that if it can "see" the newtype representation++  | otherwise+  = False+  where+    data_cons = tyConDataCons tc+    exported_con con = any (`elemNameSet` exports)+                           (dataConName con : dataConFieldLabels con)+-}
+ compiler/nativeGen/AsmCodeGen.hs view
@@ -0,0 +1,1204 @@+-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 1993-2004+--+-- This is the top-level module in the native code generator.+--+-- -----------------------------------------------------------------------------++{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms #-}++#if !defined(GHC_LOADED_INTO_GHCI)+{-# LANGUAGE UnboxedTuples #-}+#endif++module AsmCodeGen (+                    -- * Module entry point+                    nativeCodeGen++                    -- * Test-only exports: see trac #12744+                    -- used by testGraphNoSpills, which needs to access+                    -- the register allocator intermediate data structures+                    -- cmmNativeGen emits+                  , cmmNativeGen+                  , NcgImpl(..)+                  , x86NcgImpl+                  ) where++#include "HsVersions.h"+#include "nativeGen/NCG.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 Platform+import BlockLayout+import Config+import Instruction+import PIC+import Reg+import NCGMonad+import CFG+import Dwarf+import Debug++import BlockId+import CgUtils          ( fixStgRegisters )+import Cmm+import CmmUtils+import Hoopl.Collections+import Hoopl.Label+import Hoopl.Block+import CmmOpt           ( cmmMachOpFold )+import PprCmm+import CLabel++import UniqFM+import UniqSupply+import DynFlags+import Util++import BasicTypes       ( Alignment )+import qualified Pretty+import BufWrite+import Outputable+import FastString+import UniqSet+import ErrUtils+import Module+import Stream (Stream)+import qualified Stream++-- DEBUGGING ONLY+--import OrdList++import Data.List+import Data.Maybe+import Data.Ord         ( comparing )+import Control.Exception+import Control.Monad+import System.IO++{-+The native-code generator has machine-independent and+machine-dependent modules.++This module ("AsmCodeGen") is the top-level machine-independent+module.  Before entering machine-dependent land, we do some+machine-independent optimisations (defined below) on the+'CmmStmts's.++We convert to the machine-specific 'Instr' datatype with+'cmmCodeGen', assuming an infinite supply of registers.  We then use+a machine-independent register allocator ('regAlloc') to rejoin+reality.  Obviously, 'regAlloc' has machine-specific helper+functions (see about "RegAllocInfo" below).++Finally, we order the basic blocks of the function so as to minimise+the number of jumps between blocks, by utilising fallthrough wherever+possible.++The machine-dependent bits break down as follows:++  * ["MachRegs"]  Everything about the target platform's machine+    registers (and immediate operands, and addresses, which tend to+    intermingle/interact with registers).++  * ["MachInstrs"]  Includes the 'Instr' datatype (possibly should+    have a module of its own), plus a miscellany of other things+    (e.g., 'targetDoubleSize', 'smStablePtrTable', ...)++  * ["MachCodeGen"]  is where 'Cmm' stuff turns into+    machine instructions.++  * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really+    a 'SDoc').++  * ["RegAllocInfo"] In the register allocator, we manipulate+    'MRegsState's, which are 'BitSet's, one bit per machine register.+    When we want to say something about a specific machine register+    (e.g., ``it gets clobbered by this instruction''), we set/unset+    its bit.  Obviously, we do this 'BitSet' thing for efficiency+    reasons.++    The 'RegAllocInfo' module collects together the machine-specific+    info needed to do register allocation.++   * ["RegisterAlloc"] The (machine-independent) register allocator.+-}++--------------------+nativeCodeGen :: DynFlags -> Module -> ModLocation -> Handle -> UniqSupply+              -> Stream IO RawCmmGroup ()+              -> IO UniqSupply+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 UniqSupply+       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)+      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 ()+               -> IO UniqSupply+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') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us+                                         cmms ngs0+        finishNativeGen dflags modLoc bufh us' ngs++finishNativeGen :: Instruction instr+                => DynFlags+                -> ModLocation+                -> BufHandle+                -> UniqSupply+                -> NativeGenAcc statics instr+                -> IO UniqSupply+finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs+ = 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)+        when (not (null stats)) $ do++          -- build the global register conflict graph+          let graphGlobal+                  = foldl' Color.union Color.initGraph+                  $ [ Color.raGraph stat+                          | stat@Color.RegAllocStatsStart{} <- stats]++          dump_stats (Color.pprStats stats graphGlobal)++          let platform = targetPlatform dflags+          dumpIfSet_dyn dflags+                  Opt_D_dump_asm_conflicts "Register conflict graph"+                  $ Color.dotGraph+                          (targetRegDotColor platform)+                          (Color.trivColorable platform+                                  (targetVirtualRegSqueeze platform)+                                  (targetRealRegSqueeze platform))+                  $ graphGlobal+++        -- dump global NCG stats for linear allocator+        let linearStats = concat (ngs_linearStats ngs)+        when (not (null linearStats)) $+          dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)++        -- write out the imports+        printSDocLn Pretty.LeftMode dflags h (mkCodeStyle AsmStyle)+                $ makeImportsDoc dflags (concat (ngs_imports ngs))+        return us'+  where+    dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats"++cmmNativeGenStream :: (Outputable statics, Outputable instr+                      ,Outputable jumpDest, Instruction instr)+              => DynFlags+              -> Module -> ModLocation+              -> NcgImpl statics instr jumpDest+              -> BufHandle+              -> UniqSupply+              -> Stream IO RawCmmGroup ()+              -> NativeGenAcc statics instr+              -> IO (NativeGenAcc statics instr, UniqSupply)++cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs+ = do r <- Stream.runStream cmm_stream+      case r of+        Left () ->+          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)+        Right (cmms, cmm_stream') -> 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+          dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"+            (vcat $ map ppr ldbgs)++          -- Accumulate debug information for emission in finishNativeGen.+          let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }++          cmmNativeGenStream dflags this_mod modLoc ncgImpl h us'+              cmm_stream' ngs''++-- | 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 $ seqString (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)++    seqString []            = ()+    seqString (x:xs)        = x `seq` seqString xs+++emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO ()+emitNativeCode dflags h sdoc = do++        {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc dflags h+                                      (mkCodeStyle AsmStyle) sdoc++        -- dump native code+        dumpIfSet_dyn dflags+                Opt_D_dump_asm "Asm code"+                sdoc++-- | Complete native code generation phase for a single top-level chunk of Cmm.+--      Dumping the output of each stage along the way.+--      Global conflict graph and NGC stats+cmmNativeGen+    :: forall statics instr jumpDest. (Instruction instr,+        Outputable statics, Outputable instr, Outputable jumpDest)+    => DynFlags+    -> Module -> ModLocation+    -> NcgImpl statics instr jumpDest+        -> UniqSupply+        -> DwarfFiles+        -> LabelMap DebugBlock+        -> RawCmmDecl                                   -- ^ the cmm to generate code for+        -> Int                                          -- ^ sequence number of this top thing+        -> IO   ( UniqSupply+                , DwarfFiles+                , [NatCmmDecl statics instr]                -- native code+                , [CLabel]                                  -- things imported by this cmm+                , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator+                , Maybe [Linear.RegAllocStats]              -- stats for the linear register allocators+                , LabelMap [UnwindPoint]                    -- unwinding information for blocks+                )++cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count+ = do+        let platform = targetPlatform dflags++        -- rewrite assignments to global regs+        let fixed_cmm =+                {-# SCC "fixStgRegisters" #-}+                fixStgRegisters dflags cmm++        -- cmm to cmm optimisations+        let (opt_cmm, imports) =+                {-# SCC "cmmToCmm" #-}+                cmmToCmm dflags this_mod fixed_cmm++        dumpIfSet_dyn dflags+                Opt_D_dump_opt_cmm "Optimised Cmm"+                (pprCmmGroup [opt_cmm])++        let cmmCfg = {-# SCC "getCFG" #-}+                     getCfgProc (cfgWeightInfo dflags) opt_cmm++        -- generate native code from cmm+        let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) =+                {-# SCC "genMachCode" #-}+                initUs us $ genMachCode dflags this_mod modLoc+                                        (cmmTopCodeGen ncgImpl)+                                        fileIds dbgMap opt_cmm cmmCfg+++        dumpIfSet_dyn dflags+                Opt_D_dump_asm_native "Native code"+                (vcat $ map (pprNatCmmDecl ncgImpl) native)++        dumpIfSet_dyn dflags+                Opt_D_dump_cfg_weights "CFG Weights"+                (pprEdgeWeights nativeCfgWeights)++        -- tag instructions with register liveness information+        -- also drops dead code+        let livenessCfg = if (backendMaintainsCfg dflags)+                                then Just nativeCfgWeights+                                else Nothing+        let (withLiveness, usLive) =+                {-# SCC "regLiveness" #-}+                initUs usGen+                        $ mapM (cmmTopLiveness livenessCfg platform) native++        dumpIfSet_dyn dflags+                Opt_D_dump_asm_liveness "Liveness annotations added"+                (vcat $ map ppr withLiveness)++        -- allocate registers+        (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear, raStats, stack_updt_blks) <-+         if ( gopt Opt_RegsGraph dflags+           || gopt Opt_RegsIterative dflags )+          then do+                -- the regs usable for allocation+                let (alloc_regs :: UniqFM (UniqSet RealReg))+                        = foldr (\r -> plusUFM_C unionUniqSets+                                        $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))+                                emptyUFM+                        $ allocatableRegs ncgImpl++                -- do the graph coloring register allocation+                let ((alloced, maybe_more_stack, regAllocStats), usAlloc)+                        = {-# SCC "RegAlloc-color" #-}+                          initUs usLive+                          $ Color.regAlloc+                                dflags+                                alloc_regs+                                (mkUniqSet [0 .. maxSpillSlots ncgImpl])+                                (maxSpillSlots ncgImpl)+                                withLiveness+                                livenessCfg++                let ((alloced', stack_updt_blks), usAlloc')+                        = initUs usAlloc $+                                case maybe_more_stack of+                                Nothing     -> return (alloced, [])+                                Just amount -> do+                                    (alloced',stack_updt_blks) <- unzip <$>+                                                (mapM ((ncgAllocMoreStack ncgImpl) amount) alloced)+                                    return (alloced', concat stack_updt_blks )+++                -- dump out what happened during register allocation+                dumpIfSet_dyn dflags+                        Opt_D_dump_asm_regalloc "Registers allocated"+                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)++                dumpIfSet_dyn dflags+                        Opt_D_dump_asm_regalloc_stages "Build/spill stages"+                        (vcat   $ map (\(stage, stats)+                                        -> text "# --------------------------"+                                        $$ text "#  cmm " <> int count <> text " Stage " <> int stage+                                        $$ ppr stats)+                                $ zip [0..] regAllocStats)++                let mPprStats =+                        if dopt Opt_D_dump_asm_stats dflags+                         then Just regAllocStats else Nothing++                -- force evaluation of the Maybe to avoid space leak+                mPprStats `seq` return ()++                return  ( alloced', usAlloc'+                        , mPprStats+                        , Nothing+                        , [], stack_updt_blks)++          else do+                -- do linear register allocation+                let reg_alloc proc = do+                       (alloced, maybe_more_stack, ra_stats) <-+                               Linear.regAlloc dflags proc+                       case maybe_more_stack of+                         Nothing -> return ( alloced, ra_stats, [] )+                         Just amount -> do+                           (alloced',stack_updt_blks) <-+                               ncgAllocMoreStack ncgImpl amount alloced+                           return (alloced', ra_stats, stack_updt_blks )++                let ((alloced, regAllocStats, stack_updt_blks), usAlloc)+                        = {-# SCC "RegAlloc-linear" #-}+                          initUs usLive+                          $ liftM unzip3+                          $ mapM reg_alloc withLiveness++                dumpIfSet_dyn dflags+                        Opt_D_dump_asm_regalloc "Registers allocated"+                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)++                let mPprStats =+                        if dopt Opt_D_dump_asm_stats dflags+                         then Just (catMaybes regAllocStats) else Nothing++                -- force evaluation of the Maybe to avoid space leak+                mPprStats `seq` return ()++                return  ( alloced, usAlloc+                        , Nothing+                        , mPprStats, (catMaybes regAllocStats)+                        , concat stack_updt_blks )++        -- Fixupblocks the register allocator inserted (from, regMoves, to)+        let cfgRegAllocUpdates :: [(BlockId,BlockId,BlockId)]+            cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats)++        let cfgWithFixupBlks =+                addNodesBetween nativeCfgWeights cfgRegAllocUpdates++        -- Insert stack update blocks+        let postRegCFG =+                foldl' (\m (from,to) -> addImmediateSuccessor from to m )+                       cfgWithFixupBlks stack_updt_blks++        ---- generate jump tables+        let tabled      =+                {-# SCC "generateJumpTables" #-}+                generateJumpTables ncgImpl alloced++        dumpIfSet_dyn dflags+                Opt_D_dump_cfg_weights "CFG Update information"+                ( text "stack:" <+> ppr stack_updt_blks $$+                  text "linearAlloc:" <+> ppr cfgRegAllocUpdates )++        ---- shortcut branches+        let (shorted, postShortCFG)     =+                {-# SCC "shortcutBranches" #-}+                shortcutBranches dflags ncgImpl tabled postRegCFG++        let optimizedCFG =+                optimizeCFG (cfgWeightInfo dflags) cmm postShortCFG++        dumpIfSet_dyn dflags+                Opt_D_dump_cfg_weights "CFG Final Weights"+                ( pprEdgeWeights optimizedCFG )++        --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+                return $! seq (sanityCheckCfg optimizedCFG 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 = (invertCondBranches ncgImpl) optimizedCFG+                invert top@CmmData {} = top+                invert (CmmProc info lbl live (ListGraph blocks)) =+                    CmmProc info lbl live (ListGraph $ invertConds info blocks)++        ---- expansion of SPARC synthetic instrs+        let expanded =+                {-# SCC "sparc_expand" #-}+                ncgExpandTop ncgImpl branchOpt+                --ncgExpandTop ncgImpl sequenced++        dumpIfSet_dyn dflags+                Opt_D_dump_asm_expanded "Synthetic instructions expanded"+                (vcat $ map (pprNatCmmDecl ncgImpl) expanded)++        -- generate unwinding information from cmm+        let unwinds :: BlockMap [UnwindPoint]+            unwinds =+                {-# SCC "unwindingInfo" #-}+                foldl' addUnwind mapEmpty expanded+              where+                addUnwind acc proc =+                    acc `mapUnion` computeUnwinding dflags ncgImpl proc++        return  ( usAlloc+                , fileIds'+                , expanded+                , lastMinuteImports ++ imports+                , ppr_raStatsColor+                , ppr_raStatsLinear+                , unwinds )++-- | Make sure all blocks we want the layout algorithm to place have been placed.+checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]+            -> [NatCmmDecl statics instr]+checkLayout procsUnsequenced procsSequenced =+        ASSERT2(setNull diff,+                ppr "Block sequencing dropped blocks:" <> ppr diff)+        procsSequenced+  where+        blocks1 = foldl' (setUnion) setEmpty $+                        map getBlockIds procsUnsequenced :: LabelSet+        blocks2 = foldl' (setUnion) setEmpty $+                        map getBlockIds procsSequenced+        diff = setDifference blocks1 blocks2++        getBlockIds (CmmData _ _) = setEmpty+        getBlockIds (CmmProc _ _ _ (ListGraph blocks)) =+                setFromList $ map blockId blocks++-- | Compute unwinding tables for the blocks of a procedure+computeUnwinding :: Instruction instr+                 => DynFlags -> NcgImpl statics instr jumpDest+                 -> NatCmmDecl statics instr+                    -- ^ the native code generated for the procedure+                 -> LabelMap [UnwindPoint]+                    -- ^ unwinding tables for all points of all blocks of the+                    -- procedure+computeUnwinding dflags _ _+  | debugLevel dflags == 0         = mapEmpty+computeUnwinding _ _ (CmmData _ _) = mapEmpty+computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) =+    -- In general we would need to push unwinding information down the+    -- block-level call-graph to ensure that we fully account for all+    -- relevant register writes within a procedure.+    --+    -- However, the only unwinding information that we care about in GHC is for+    -- Sp. The fact that CmmLayoutStack already ensures that we have unwind+    -- information at the beginning of every block means that there is no need+    -- to perform this sort of push-down.+    mapFromList [ (blk_lbl, extractUnwindPoints ncgImpl instrs)+                | BasicBlock blk_lbl instrs <- blks ]++-- | Build a doc for all the imports.+--+makeImportsDoc :: DynFlags -> [CLabel] -> SDoc+makeImportsDoc dflags imports+ = dyld_stubs imports+            $$+            -- On recent versions of Darwin, the linker supports+            -- dead-stripping of code and data on a per-symbol basis.+            -- There's a hack to make this work in PprMach.pprNatCmmDecl.+            (if platformHasSubsectionsViaSymbols platform+             then text ".subsections_via_symbols"+             else Outputable.empty)+            $$+                -- On recent GNU ELF systems one can mark an object file+                -- as not requiring an executable stack. If all objects+                -- linked into a program have this note then the program+                -- will not use an executable stack, which is good for+                -- security. GHC generated code does not need an executable+                -- stack so add the note in:+            (if platformHasGnuNonexecStack platform+             then text ".section .note.GNU-stack,\"\"," <> sectionType "progbits"+             else Outputable.empty)+            $$+                -- And just because every other compiler does, let's stick in+                -- an identifier directive: .ident "GHC x.y.z"+            (if platformHasIdentDirective platform+             then let compilerIdent = text "GHC" <+> text cProjectVersion+                   in text ".ident" <+> doubleQuotes compilerIdent+             else Outputable.empty)++ where+        platform = targetPlatform dflags+        arch = platformArch platform+        os   = platformOS   platform++        -- Generate "symbol stubs" for all external symbols that might+        -- come from a dynamic library.+        dyld_stubs :: [CLabel] -> SDoc+{-      dyld_stubs imps = vcat $ map pprDyldSymbolStub $+                                    map head $ group $ sort imps-}+        -- (Hack) sometimes two Labels pretty-print the same, but have+        -- different uniques; so we compare their text versions...+        dyld_stubs imps+                | needImportedSymbols dflags arch os+                = vcat $+                        (pprGotDeclaration dflags arch os :) $+                        map ( pprImportedSymbol dflags platform . fst . head) $+                        groupBy (\(_,a) (_,b) -> a == b) $+                        sortBy (\(_,a) (_,b) -> compare a b) $+                        map doPpr $+                        imps+                | otherwise+                = Outputable.empty++        doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel dflags lbl) astyle)+        astyle = mkCodeStyle AsmStyle++-- -----------------------------------------------------------------------------+-- Generate jump tables++-- Analyzes all native code and generates data sections for all jump+-- table instructions.+generateJumpTables+        :: NcgImpl statics instr jumpDest+        -> [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]+generateJumpTables ncgImpl xs = concatMap f xs+    where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs+          f p = [p]+          g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)++-- -----------------------------------------------------------------------------+-- Shortcut branches++shortcutBranches+        :: forall statics instr jumpDest. (Outputable jumpDest) => DynFlags+        -> NcgImpl statics instr jumpDest+        -> [NatCmmDecl statics instr]+        -> CFG+        -> ([NatCmmDecl statics instr],CFG)++shortcutBranches dflags ncgImpl tops weights+  | gopt Opt_AsmShortcutting dflags+  = ( map (apply_mapping ncgImpl mapping) tops'+    , shortcutWeightMap weights mappingBid )+  | 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]+#endif++newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> OptMResult a)++instance Functor CmmOptM where+    fmap = liftM++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 view
@@ -0,0 +1,758 @@+--+-- Copyright (c) 2018 Andreas Klebinger+--++{-# LANGUAGE TypeFamilies, ScopedTypeVariables, CPP #-}++{-# OPTIONS_GHC -fprof-auto #-}+--{-# OPTIONS_GHC -ddump-simpl -ddump-to-file -ddump-cmm #-}++module BlockLayout+    ( sequenceTop )+where++#include "HsVersions.h"+import GhcPrelude++import Instruction+import NCGMonad+import CFG++import BlockId+import Cmm+import Hoopl.Collections+import Hoopl.Label+import Hoopl.Block++import DynFlags (gopt, GeneralFlag(..), DynFlags, backendMaintainsCfg)+import UniqFM+import Util+import Unique++import Digraph+import Outputable+import Maybes++-- DEBUGGING ONLY+--import Debug+--import Debug.Trace+import ListSetOps (removeDups)+import PprCmm ()++import OrdList+import Data.List+import Data.Foldable (toList)+import Hoopl.Graph++import qualified Data.Set as Set++{-+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  ~~~ Note [Chain based CFG serialization]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++  For additional information also look at+  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/code-layout++  We have a CFG with edge weights based on which we try to place blocks next to+  each other.++  Edge weights not only represent likelyhood of control transfer between blocks+  but also how much a block would benefit from being placed sequentially after+  it's predecessor.+  For example blocks which are preceeded by an info table are more likely to end+  up in a different cache line than their predecessor. So there is less benefit+  in 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 sequentially is important have already+  been placed in the same chain.++  -----------------------------------------------------------------------------+      First try to create a lists of good chains.+  -----------------------------------------------------------------------------++  We do so by taking a block not yet placed in a chain and+  looking at these cases:++  *)  Check if the best predecessor of the block is at the end of a chain.+      If so add the current block to the end of that chain.++      Eg if we look at block C and already have the chain (A -> B)+      then we extend the chain to (A -> B -> C).++      Combined with the fact that we process blocks in reverse post order+      this means loop bodies and trivially sequential control flow already+      ends up as a single chain.++  *)  Otherwise we create a singleton chain from the block we are looking at.+      Eg if we have from the example above already constructed (A->B)+      and look at D we create the chain (D) resulting in the chains [A->B, D]++  -----------------------------------------------------------------------------+      We then try to fuse chains.+  -----------------------------------------------------------------------------++  There are edge cases which result in two chains being created which trivially+  represent linear control flow. For example we might have the chains+  [(A-B-C),(D-E)] with an cfg triangle:++      A----->C->D->E+       \->B-/++  We also get three independent chains if two branches end with a jump+  to a common successor.++  We take care of these cases by fusing chains which are connected by an+  edge.++  We do so by looking at the list of edges sorted by weight.+  Given the edge (C -> D) we try to find two chains such that:+      * C is at the end of chain one.+      * D is in front of chain two.+      * If two such chains exist we fuse them.+  We then remove the edge and repeat the process for the rest of the edges.++  -----------------------------------------------------------------------------+      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.++  TODO: If we remove edges as we use them (eg if we build up A->B remove A->B+        from the list) we could save some more work in later phases.+++  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  ~~~ Note [Triangle Control Flow]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++  Checking if an argument is already evaluating 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++-- | Only edges heavier than this are considered+--   for fusing two chains into a single chain.+fuseEdgeThreshold :: EdgeWeight+fuseEdgeThreshold = 0++-- | 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) }++instance Eq (BlockChain) where+    (BlockChain blks1) == (BlockChain blks2)+        = fromOL blks1 == fromOL blks2++-- Useful for things like sets and debugging purposes, sorts by blocks+-- in the chain.+instance Ord (BlockChain) where+   (BlockChain lbls1) `compare` (BlockChain lbls2)+       = (fromOL lbls1) `compare` (fromOL lbls2)++instance Outputable (BlockChain) where+    ppr (BlockChain blks) =+        parens (text "Chain:" <+> ppr (fromOL $ blks) )++data WeightedEdge = WeightedEdge !BlockId !BlockId EdgeWeight deriving (Eq)+++-- | Non deterministic! (Uniques) Sorts edges by weight and nodes.+instance Ord WeightedEdge where+  compare (WeightedEdge from1 to1 weight1)+          (WeightedEdge from2 to2 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 WeightedEdge where+    ppr (WeightedEdge from to info) =+        ppr from <> text "->" <> ppr to <> brackets (ppr info)++type WeightedEdgeList = [WeightedEdge]++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++chainMember :: BlockId -> BlockChain -> Bool+chainMember bid chain+  = elem bid $ fromOL . chainBlocks $ chain+--   = setMember bid . chainMembers $ chain++chainSingleton :: BlockId -> BlockChain+chainSingleton lbl+    = BlockChain (unitOL lbl)++chainSnoc :: BlockChain -> BlockId -> BlockChain+chainSnoc (BlockChain blks) lbl+  = BlockChain (blks `snocOL` lbl)++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++-- | For a given list of chains try to fuse chains with strong+--   edges between them into a single chain.+--   Returns the list of fused chains together with a set of+--   used edges. The set of edges is indirectly encoded in the+--   chains so doesn't need to be considered for later passes.+fuseChains :: WeightedEdgeList -> LabelMap BlockChain+           -> (LabelMap BlockChain, Set.Set WeightedEdge)+fuseChains weights chains+    = let fronts = mapFromList $+                    map (\chain -> (headOL . chainBlocks $ chain,chain)) $+                    mapElems chains :: LabelMap BlockChain+          (chains', used, _) = applyEdges weights chains fronts Set.empty+      in (chains', used)+    where+        applyEdges :: WeightedEdgeList -> LabelMap BlockChain+                   -> LabelMap BlockChain -> Set.Set WeightedEdge+                   -> (LabelMap BlockChain, Set.Set WeightedEdge, LabelMap BlockChain)+        applyEdges [] chainsEnd chainsFront used+            = (chainsEnd, used, chainsFront)+        applyEdges (edge@(WeightedEdge from to w):edges) chainsEnd chainsFront used+            --Since we order edges descending by weight we can stop here+            | w <= fuseEdgeThreshold+            = ( chainsEnd, used, chainsFront)+            --Fuse the two chains+            | Just c1 <- mapLookup from chainsEnd+            , Just c2 <- mapLookup to chainsFront+            , c1 /= c2+            = let newChain = chainConcat c1 c2+                  front = headOL . chainBlocks $ newChain+                  end = lastOL . chainBlocks $ newChain+                  chainsFront' = mapInsert front newChain $+                                 mapDelete to chainsFront+                  chainsEnd'   = mapInsert end newChain $+                                 mapDelete from chainsEnd+              in applyEdges edges chainsEnd' chainsFront'+                            (Set.insert edge used)+            | otherwise+            --Check next edge+            = applyEdges edges chainsEnd chainsFront used+++-- 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 later after the former doesn't result in sequential+-- control flow it is still be benefical since 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 ...+--+-- Simple heuristic to chose which chains we want to combine:+--   * Process edges in descending priority.+--   * Check if there is a edge near the end of one chain which goes+--     to a block near the start of another edge.+--+-- While we could take into account the space between the two blocks which+-- share an edge this blows up compile times quite a bit. It requires+-- us to find all edges between two chains, check the distance for all edges,+-- rank them based on the distance and and only then we can select two chains+-- to combine. Which would add a lot of complexity for little gain.++-- | For a given list of chains and edges try to combine chains with strong+--   edges between them.+combineNeighbourhood :: WeightedEdgeList -> [BlockChain]+                     -> [BlockChain]+combineNeighbourhood edges chains+    = -- pprTraceIt "Neigbours" $+      applyEdges edges endFrontier startFrontier+    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 :: WeightedEdgeList -> FrontierMap -> FrontierMap+                   -> [BlockChain]+        applyEdges [] chainEnds _chainFronts =+            ordNub $ map snd $ mapElems chainEnds+        applyEdges ((WeightedEdge from to _w):edges) chainEnds chainFronts+            | Just (c1_e,c1) <- mapLookup from chainEnds+            , Just (c2_f,c2) <- mapLookup to chainFronts+            , c1 /= c2 -- Avoid trying to concat a short 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+            | otherwise+            = --pprTrace "noNeigbours" (ppr ()) $+              applyEdges edges chainEnds chainFronts+         where++        getFronts chain = takeL neighbourOverlapp chain+        getEnds chain = takeR neighbourOverlapp chain++++-- See [Chain based CFG serialization]+buildChains :: CFG -> [BlockId]+            -> ( LabelMap BlockChain  -- Resulting chains.+               , Set.Set (BlockId, BlockId)) --List of fused edges.+buildChains succWeights blocks+  = let (_, fusedEdges, chains) = buildNext setEmpty mapEmpty blocks Set.empty+    in (chains, fusedEdges)+  where+    -- We keep a map from the last block in a chain to the chain itself.+    -- This we we can easily check if an block should be appened to an+    -- existing chain!+    buildNext :: LabelSet+              -> LabelMap BlockChain -- Map from last element to chain.+              -> [BlockId] -- Blocks to place+              -> Set.Set (BlockId, BlockId)+              -> ( [BlockChain]  -- Placed Blocks+                 , Set.Set (BlockId, BlockId) --List of fused edges+                 , LabelMap BlockChain+                 )+    buildNext _placed chains [] linked =+        ([], linked, chains)+    buildNext placed chains (block:todo) linked+        | setMember block placed+        = buildNext placed chains todo linked+        | otherwise+        = buildNext placed' chains' todo linked'+      where+        placed' = (foldl' (flip setInsert) placed placedBlocks)+        linked' = Set.union linked linkedEdges+        (placedBlocks, chains', linkedEdges) = findChain block++        --Add the block to a existing or new chain+        --Returns placed blocks, list of resulting chains+        --and fused edges+        findChain :: BlockId+                -> ([BlockId],LabelMap BlockChain, Set.Set (BlockId, BlockId))+        findChain block+        -- B) place block at end of existing chain if+        -- there is no better block to append.+          | (pred:_) <- preds+          , alreadyPlaced pred+          , Just predChain <- mapLookup pred chains+          , (best:_) <- filter (not . alreadyPlaced) $ getSuccs pred+          , best == lbl+          = --pprTrace "B.2)" (ppr (pred,lbl)) $+            let newChain = chainSnoc predChain block+                chainMap = mapInsert lbl newChain $ mapDelete pred chains+            in  ( [lbl]+                , chainMap+                , Set.singleton (pred,lbl) )++          | otherwise+          = --pprTrace "single" (ppr lbl)+            ( [lbl]+            , mapInsert lbl (chainSingleton lbl) chains+            , Set.empty)+            where+              alreadyPlaced blkId = (setMember blkId placed)+              lbl = block+              getSuccs = map fst . getSuccEdgesSorted succWeights+              preds = map fst $ getSuccEdgesSorted predWeights lbl+    --For efficiency we also create the map to look up predecessors here+    predWeights = reverseEdges succWeights++++-- We make the CFG a Hoopl Graph, so we can reuse revPostOrder.+newtype BlockNode e x = BN (BlockId,[BlockId])+instance NonLocal (BlockNode) where+  entryLabel (BN (lbl,_))   = lbl+  successors (BN (_,succs)) = succs++fromNode :: BlockNode C C -> BlockId+fromNode (BN x) = fst x++sequenceChain :: forall a i. (Instruction i, Outputable i) => LabelMap a -> CFG+            -> [GenBasicBlock i] -> [GenBasicBlock i]+sequenceChain _info _weights    [] = []+sequenceChain _info _weights    [x] = [x]+sequenceChain  info weights'     blocks@((BasicBlock entry _):_) =+    --Optimization, delete edges of weight <= 0.+    --This significantly improves performance whenever+    --we iterate over all edges, which is a few times!+    let weights :: CFG+        weights+            = filterEdges (\_f _t edgeInfo -> edgeWeight edgeInfo > 0) weights'+        blockMap :: LabelMap (GenBasicBlock i)+        blockMap+            = foldl' (\m blk@(BasicBlock lbl _ins) ->+                        mapInsert lbl blk m)+                     mapEmpty blocks++        toNode :: BlockId -> BlockNode C C+        toNode bid =+            -- sorted such that heavier successors come first.+            BN (bid,map fst . getSuccEdgesSorted weights' $ bid)++        orderedBlocks :: [BlockId]+        orderedBlocks+            = map fromNode $+              revPostorderFrom (fmap (toNode . blockId) blockMap) entry++        (builtChains, builtEdges)+            = {-# SCC "buildChains" #-}+              --pprTraceIt "generatedChains" $+              --pprTrace "orderedBlocks" (ppr orderedBlocks) $+              buildChains weights orderedBlocks++        rankedEdges :: WeightedEdgeList+        -- Sort edges descending, remove fused eges+        rankedEdges =+            map (\(from, to, weight) -> WeightedEdge from to weight) .+            filter (\(from, to, _)+                        -> not (Set.member (from,to) builtEdges)) .+            sortWith (\(_,_,w) -> - w) $ weightedEdgeList weights++        (fusedChains, fusedEdges)+            = ASSERT(noDups $ mapElems builtChains)+              {-# SCC "fuseChains" #-}+              --(pprTrace "RankedEdges" $ ppr rankedEdges) $+              --pprTraceIt "FusedChains" $+              fuseChains rankedEdges builtChains++        rankedEdges' =+            filter (\edge -> not $ Set.member edge fusedEdges) $ rankedEdges++        neighbourChains+            = ASSERT(noDups $ mapElems fusedChains)+              {-# SCC "groupNeighbourChains" #-}+              --pprTraceIt "ResultChains" $+              combineNeighbourhood rankedEdges' (mapElems fusedChains)++        --Make sure the first block stays first+        ([entryChain],chains')+            = ASSERT(noDups $ neighbourChains)+              partition (chainMember entry) neighbourChains+        (entryChain':entryRest)+            | inFront entry entryChain = [entryChain]+            | (rest,entry) <- breakChainAt entry entryChain+            = [entry,rest]+            | otherwise = pprPanic "Entry point eliminated" $+                            ppr ([entryChain],chains')++        prepedChains+            = entryChain':(entryRest++chains') :: [BlockChain]+        blockList+            -- = (concatMap chainToBlocks prepedChains)+            = (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 =+            --pprTraceIt "placedBlocks" $+            blockList ++ unplaced+        getBlock bid = expectJust "Block placment" $ mapLookup bid blockMap+    in+        --Assert we placed all blocks given as input+        ASSERT(all (\bid -> mapMember bid blockMap) placedBlocks)+        dropJumps info $ map getBlock placedBlocks++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 --Use new layout code+    -> NcgImpl statics instr jumpDest -> CFG+    -> NatCmmDecl statics instr -> 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+  = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $+                            sequenceChain info edgeWeights blocks )+  | otherwise+  --Use old algorithm+  = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $+                            sequenceBlocks cfg info blocks)+  where+    cfg+      | (gopt Opt_WeightlessBlocklayout dflags) ||+        (not $ backendMaintainsCfg dflags)+      -- Don't make use of cfg in the old algorithm+      = Nothing+      -- Use cfg in the old algorithm+      | otherwise = Just edgeWeights++-- 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 view
@@ -0,0 +1,651 @@+--+-- Copyright (c) 2018 Andreas Klebinger+--++{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE CPP #-}++module CFG+    ( CFG, CfgEdge(..), EdgeInfo(..), EdgeWeight(..)+    , TransitionSource(..)++    --Modify the CFG+    , addWeightEdge, addEdge, delEdge+    , addNodesBetween, shortcutWeightMap+    , reverseEdges, filterEdges+    , addImmediateSuccessor+    , mkWeightInfo, adjustEdgeWeight++    --Query the CFG+    , infoEdgeList, edgeList+    , getSuccessorEdges, getSuccessors+    , getSuccEdgesSorted, weightedEdgeList+    , getEdgeInfo+    , getCfgNodes, hasNode+    , loopMembers++    --Construction/Misc+    , getCfg, getCfgProc, pprEdgeWeights, sanityCheckCfg++    --Find backedges and update their weight+    , optimizeCFG )+where++#include "HsVersions.h"++import GhcPrelude++import BlockId+import Cmm ( RawCmmDecl, GenCmmDecl( .. ), CmmBlock, succ, g_entry+           , CmmGraph )+import CmmNode+import CmmUtils+import CmmSwitch+import Hoopl.Collections+import Hoopl.Label+import Hoopl.Block+import qualified Hoopl.Graph as G++import Util+import Digraph++import Outputable+-- DEBUGGING ONLY+--import Debug+--import OrdList+--import Debug.Trace+import PprCmm ()+import qualified DynFlags as D++import Data.List++-- import qualified Data.IntMap.Strict as M --TODO: LabelMap++type Edge = (BlockId, BlockId)+type Edges = [Edge]++newtype EdgeWeight+  = EdgeWeight Int+  deriving (Eq,Ord,Enum,Num,Real,Integral)++instance Outputable EdgeWeight where+  ppr (EdgeWeight w) = ppr w++type EdgeInfoMap edgeInfo = LabelMap (LabelMap edgeInfo)++-- | A control flow graph where edges have been annotated with a weight.+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 for 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 (CmmNode O C)+  | AsmCodeGen+  deriving (Eq)++-- | Information about edges+data EdgeInfo+  = EdgeInfo+  { transitionSource :: !TransitionSource+  , edgeWeight :: !EdgeWeight+  } deriving (Eq)++instance Outputable EdgeInfo where+  ppr edgeInfo = text "weight:" <+> ppr (edgeWeight edgeInfo)++-- Allow specialization+{-# INLINEABLE mkWeightInfo #-}+-- | Convenience function, generate edge info based+--   on weight not originating from cmm.+mkWeightInfo :: Integral n => n -> EdgeInfo+mkWeightInfo = EdgeInfo AsmCodeGen . fromIntegral++-- | 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+  = addEdge from to (info { edgeWeight = f weight}) cfg+  | otherwise = cfg++getCfgNodes :: CFG -> LabelSet+getCfgNodes m = mapFoldMapWithKey (\k v -> setFromList (k:mapKeys v)) m++hasNode :: CFG -> BlockId -> Bool+hasNode m node = mapMember node m || any (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:" <+> ppr m $$+            msg )+            False+    where+      cfgNodes = getCfgNodes m :: LabelSet+      diff = (setUnion cfgNodes blockSet) `setDifference` (setIntersection cfgNodes blockSet) :: LabelSet++-- | Filter the CFG with a custom function f.+--   Paramaeters are `f from to edgeInfo`+filterEdges :: (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG+filterEdges f cfg =+    mapMapWithKey filterSources cfg+    where+      filterSources from m =+        mapFilterWithKey (\to w -> f from to w) m+++{- Note [Updating the CFG during shortcutting]++See Note [What is shortcutting] in the control flow optimization+code (CmmContFlowOpt.hs) for a slightly more in depth explanation on shortcutting.++In the native backend we shortcut jumps at the assembly level. (AsmCodeGen.hs)+This means we remove blocks containing only one jump from the code+and instead redirecting all jumps targeting this block to the deleted+blocks jump target.++However we want to have an accurate representation of control+flow in the CFG. So we add/remove edges accordingly to account+for the eliminated blocks and new edges.++If we shortcut A -> B -> C to A -> C:+* We delete edges A -> B and B -> C+* Replacing them with the edge A -> C++We also try to preserve jump weights while doing so.++Note that:+* The edge B -> C can't have interesting weights since+  the block B consists of a single unconditional jump without branching.+* We delete the edge A -> B and add the edge A -> C.+* The edge A -> B can be one of many edges originating from A so likely+  has edge weights we want to preserve.++For this reason we simply store the edge info from the original A -> B+edge and apply this information to the new edge A -> C.++Sometimes we have a scenario where jump target C is not represented by an+BlockId but an immediate value. I'm only aware of this happening without+tables next to code currently.++Then we go from A ---> B - -> IMM   to   A - -> IMM where the dashed arrows+are not stored in the CFG.++In that case we simply delete the edge A -> B.++In terms of implementation the native backend first builds a mapping+from blocks suitable for shortcutting to their jump targets.+Then it redirects all jump instructions to these blocks using the+built up mapping.+This function (shortcutWeightMap) takes the same mapping and+applies the mapping to the CFG in the way layed out above.++-}+shortcutWeightMap :: CFG -> LabelMap (Maybe BlockId) -> CFG+shortcutWeightMap cfg cuts =+  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 addDest from cfg+    where+        addDest Nothing = Just $ mapSingleton to info+        addDest (Just wm) = Just $ mapInsert to info wm++-- | Adds a edge with the given weight to the cfg+--   If there already existed an edge it is overwritten.+--   `addWeightEdge from to weight cfg`+addWeightEdge :: BlockId -> BlockId -> EdgeWeight -> CFG -> CFG+addWeightEdge from to weight cfg =+    addEdge from to (mkWeightInfo weight) cfg++delEdge :: BlockId -> BlockId -> CFG -> CFG+delEdge from to m =+    mapAlter remDest from m+    where+        remDest Nothing = Nothing+        remDest (Just wm) = Just $ mapDelete to wm++-- | Destinations from bid ordered by weight (descending)+getSuccEdgesSorted :: CFG -> BlockId -> [(BlockId,EdgeInfo)]+getSuccEdgesSorted m bid =+    let destMap = mapFindWithDefault mapEmpty bid m+        cfgEdges = mapToList destMap+        sortedEdges = sortWith (negate . edgeWeight . snd) cfgEdges+    in  --pprTrace "getSuccEdgesSorted" (ppr bid <+> text "map:" <+> ppr m)+        sortedEdges++-- | Get successors of a given node with edge weights.+getSuccessorEdges :: CFG -> BlockId -> [(BlockId,EdgeInfo)]+getSuccessorEdges m bid = maybe [] mapToList $ mapLookup bid 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++reverseEdges :: CFG -> CFG+reverseEdges cfg = foldr add mapEmpty flatElems+  where+    elems = mapToList $ fmap mapToList cfg :: [(BlockId,[(BlockId,EdgeInfo)])]+    flatElems =+        concatMap (\(from,ws) -> map (\(to,info) -> (to,from,info)) ws ) elems+    add (to,from,info) m = addEdge to from info m++-- | Returns a unordered list of all edges with info+infoEdgeList :: CFG -> [CfgEdge]+infoEdgeList m =+  mapFoldMapWithKey+    (\from toMap ->+      map (\(to,info) -> CfgEdge from to info) (mapToList toMap))+    m++-- | Unordered list of edges with weight as Tuple (from,to,weight)+weightedEdgeList :: CFG -> [(BlockId,BlockId,EdgeWeight)]+weightedEdgeList m =+  mapFoldMapWithKey+    (\from toMap ->+      map (\(to,info) ->+        (from,to, edgeWeight info)) (mapToList toMap))+    m+      --  (\(from, tos) -> map (\(to,info) -> (from,to, edgeWeight info)) tos )++-- | Returns a unordered list of all edges without weights+edgeList :: CFG -> [Edge]+edgeList m =+        mapFoldMapWithKey (\from toMap -> fmap (from,) (mapKeys toMap)) m++-- | Get successors of a given node without edge weights.+getSuccessors :: CFG -> BlockId -> [BlockId]+getSuccessors m bid+    | Just wm <- mapLookup bid m+    = mapKeys wm+    | otherwise = []++pprEdgeWeights :: CFG -> SDoc+pprEdgeWeights m =+    let edges = sort $ weightedEdgeList m+        printEdge (from, to, 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 (from, to, _weight) = [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+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 )+      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 how often execution will transer control+  along each edge as well as how much we gain by placing eg A before+  C.++  We rank edges in this order:+  * Unconditional Control Transfer - They will always+    transfer control to their target. Unless there is a info table+    we can turn the jump into a fallthrough as well.+    We use 20k as default, so it's easy to spot if values have been+    modified but unlikely that we run into issues with overflow.+  * If branches (likely) - We assume branches marked as likely+    are taken more than 80% of the time.+    By ranking them below unconditional jumps we make sure we+    prefer the unconditional if there is a conditional and+    unconditional edge towards a block.+  * If branches (regular) - The false branch can potentially be turned+    into a fallthrough so we prefer it slightly over the true branch.+  * Unlikely branches - These can be assumed to be taken less than 20%+    of the time. So we given them one of the lowest priorities.+  * Switches - Switches at this level are implemented as jump tables+    so have a larger number of successors. So without more information+    we can only say that each individual successor is unlikely to be+    jumped to and we rank them accordingly.+  * Calls - We currently ignore calls completly:+        * By the time we return from a call there is a good chance+          that the address we return to has already been evicted from+          cache eliminating a main advantage sequential placement brings.+        * Calls always require a info table in front of their return+          address. This reduces the chance that we return to the same+          cache line further.+++-}+-- | Generate weights for a Cmm proc based on some simple heuristics.+getCfgProc :: D.CfgWeights -> RawCmmDecl -> CFG+getCfgProc _       (CmmData {}) = mapEmpty+getCfgProc weights (CmmProc _info _lab _live graph) = getCfg weights graph++getCfg :: D.CfgWeights -> CmmGraph -> CFG+getCfg weights graph =+  foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks+  where+    D.CFGWeights+            { D.uncondWeight = uncondWeight+            , D.condBranchWeight = condBranchWeight+            , D.switchWeight = switchWeight+            , D.callWeight = callWeight+            , D.likelyCondWeight = likelyCondWeight+            , D.unlikelyCondWeight = unlikelyCondWeight+            --  Last two are used in other places+            --, D.infoTablePenalty = infoTablePenalty+            --, D.backEdgeBonus = backEdgeBonus+            } = weights+    -- Explicitly add all nodes to the cfg to ensure they are part of the+    -- CFG.+    edgelessCfg = mapFromList $ zip (map G.entryLabel blocks) (repeat mapEmpty)+    insertEdge :: CFG -> ((BlockId,BlockId),EdgeInfo) -> CFG+    insertEdge m ((from,to),weight) =+      mapAlter f from m+        where+          f :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)+          f Nothing = Just $ mapSingleton to weight+          f (Just destMap) = Just $ mapInsert to weight destMap+    getBlockEdges :: CmmBlock -> [((BlockId,BlockId),EdgeInfo)]+    getBlockEdges block =+      case branch of+        CmmBranch dest -> [mkEdge dest uncondWeight]+        CmmCondBranch _c 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]+        (CmmSwitch _e ids) ->+          let switchTargets = switchTargetsToList ids+              --Compiler performance hack - for very wide switches don't+              --consider targets for layout.+              adjustedWeight =+                if (length switchTargets > 10) then -1 else switchWeight+          in map (\x -> mkEdge x adjustedWeight) switchTargets+        (CmmCall { cml_cont = Just cont})  -> [mkEdge cont callWeight]+        (CmmForeignCall {Cmm.succ = cont}) -> [mkEdge cont callWeight]+        (CmmCall { cml_cont = Nothing })   -> []+        other ->+            panic "Foo" $+            ASSERT2(False, ppr "Unkown successor cause:" <>+              (ppr branch <+> text "=>" <> ppr (G.successors other)))+            map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other+      where+        bid = G.entryLabel block+        mkEdgeInfo = EdgeInfo (CmmSource branch) . fromIntegral+        mkEdge target weight = ((bid,target), mkEdgeInfo weight)+        branch = lastNode block :: CmmNode O C++    blocks = revPostorder graph :: [CmmBlock]++--Find back edges by BFS+findBackEdges :: 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 =+    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+++{- Note [Optimize for Fallthrough]++-}+    -- | If a block has two successors, favour the one with fewer+    -- predecessors. (As that one is more likely to become a fallthrough)+    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 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 setFoldl update cfg nodes+      where+        fallthroughTarget :: BlockId -> EdgeInfo -> Bool+        fallthroughTarget to (EdgeInfo source _weight)+          | mapMember to info = False+          | AsmCodeGen <- source = True+          | CmmSource (CmmBranch {}) <- source = True+          | CmmSource (CmmCondBranch {}) <- source = True+          | otherwise = False++-- | Determine loop membership of blocks based on SCC analysis+--   Ideally we would replace this with a variant giving us loop+--   levels instead but the SCC code will do for now.+loopMembers :: 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 (setElems $ 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
+ compiler/nativeGen/CPrim.hs view
@@ -0,0 +1,133 @@+-- | Generating C symbol names emitted by the compiler.+module CPrim+    ( atomicReadLabel+    , atomicWriteLabel+    , atomicRMWLabel+    , cmpxchgLabel+    , popCntLabel+    , pdepLabel+    , pextLabel+    , bSwapLabel+    , bRevLabel+    , clzLabel+    , ctzLabel+    , word2FloatLabel+    ) where++import GhcPrelude++import CmmType+import CmmMachOp+import Outputable++popCntLabel :: Width -> String+popCntLabel w = "hs_popcnt" ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "popCntLabel: Unsupported word width " (ppr w)++pdepLabel :: Width -> String+pdepLabel w = "hs_pdep" ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "pdepLabel: Unsupported word width " (ppr w)++pextLabel :: Width -> String+pextLabel w = "hs_pext" ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "pextLabel: Unsupported word width " (ppr w)++bSwapLabel :: Width -> String+bSwapLabel w = "hs_bswap" ++ pprWidth w+  where+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "bSwapLabel: Unsupported word width " (ppr w)++bRevLabel :: Width -> String+bRevLabel w = "hs_bitrev" ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "bRevLabel: Unsupported word width " (ppr w)++clzLabel :: Width -> String+clzLabel w = "hs_clz" ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "clzLabel: Unsupported word width " (ppr w)++ctzLabel :: Width -> String+ctzLabel w = "hs_ctz" ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "ctzLabel: Unsupported word width " (ppr w)++word2FloatLabel :: Width -> String+word2FloatLabel w = "hs_word2float" ++ pprWidth w+  where+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "word2FloatLabel: Unsupported word width " (ppr w)++atomicRMWLabel :: Width -> AtomicMachOp -> String+atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "atomicRMWLabel: Unsupported word width " (ppr w)++    pprFunName AMO_Add  = "add"+    pprFunName AMO_Sub  = "sub"+    pprFunName AMO_And  = "and"+    pprFunName AMO_Nand = "nand"+    pprFunName AMO_Or   = "or"+    pprFunName AMO_Xor  = "xor"++cmpxchgLabel :: Width -> String+cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "cmpxchgLabel: Unsupported word width " (ppr w)++atomicReadLabel :: Width -> String+atomicReadLabel w = "hs_atomicread" ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "atomicReadLabel: Unsupported word width " (ppr w)++atomicWriteLabel :: Width -> String+atomicWriteLabel w = "hs_atomicwrite" ++ pprWidth w+  where+    pprWidth W8  = "8"+    pprWidth W16 = "16"+    pprWidth W32 = "32"+    pprWidth W64 = "64"+    pprWidth w   = pprPanic "atomicWriteLabel: Unsupported word width " (ppr w)
+ compiler/nativeGen/Dwarf.hs view
@@ -0,0 +1,269 @@+module Dwarf (+  dwarfGen+  ) where++import GhcPrelude++import CLabel+import CmmExpr         ( GlobalReg(..) )+import Config          ( cProjectName, cProjectVersion )+import CoreSyn         ( Tickish(..) )+import Debug+import DynFlags+import Module+import Outputable+import Platform+import Unique+import UniqSupply++import Dwarf.Constants+import Dwarf.Types++import Control.Arrow    ( first )+import Control.Monad    ( mfilter )+import Data.Maybe+import Data.List        ( sortBy )+import Data.Ord         ( comparing )+import qualified Data.Map as Map+import System.FilePath+import System.Directory ( getCurrentDirectory )++import qualified Hoopl.Label as H+import qualified Hoopl.Collections as H++-- | Generate DWARF/debug information+dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]+            -> IO (SDoc, UniqSupply)+dwarfGen _  _      us [] = return (empty, us)+dwarfGen df modLoc us blocks = do++  -- Convert debug data structures to DWARF info records+  -- We strip out block information when running with -g0 or -g1.+  let procs = debugSplitProcs blocks+      stripBlocks dbg+        | debugLevel df < 2 = dbg { dblBlocks = [] }+        | otherwise         = dbg+  compPath <- getCurrentDirectory+  let lowLabel = dblCLabel $ head procs+      highLabel = mkAsmTempEndLabel $ dblCLabel $ last procs+      dwarfUnit = DwarfCompileUnit+        { dwChildren = map (procToDwarf df) (map stripBlocks procs)+        , dwName = fromMaybe "" (ml_hs_file modLoc)+        , dwCompDir = addTrailingPathSeparator compPath+        , dwProducer = cProjectName ++ " " ++ cProjectVersion+        , dwLowLabel = lowLabel+        , dwHighLabel = highLabel+        , dwLineLabel = dwarfLineLabel+        }++  -- Check whether we have any source code information, so we do not+  -- end up writing a pointer to an empty .debug_line section+  -- (dsymutil on Mac Os gets confused by this).+  let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk)+                      || any haveSrcIn (dblBlocks blk)+      haveSrc = any haveSrcIn procs++  -- .debug_abbrev section: Declare the format we're using+  let abbrevSct = pprAbbrevDecls haveSrc++  -- .debug_info section: Information records on procedures and blocks+  let -- unique to identify start and end compilation unit .debug_inf+      (unitU, us') = takeUniqFromSupply us+      infoSct = vcat [ ptext dwarfInfoLabel <> colon+                     , dwarfInfoSection+                     , compileUnitHeader unitU+                     , pprDwarfInfo haveSrc dwarfUnit+                     , compileUnitFooter unitU+                     ]++  -- .debug_line section: Generated mainly by the assembler, but we+  -- need to label it+  let lineSct = dwarfLineSection $$+                ptext dwarfLineLabel <> colon++  -- .debug_frame section: Information about the layout of the GHC stack+  let (framesU, us'') = takeUniqFromSupply us'+      frameSct = dwarfFrameSection $$+                 ptext dwarfFrameLabel <> colon $$+                 pprDwarfFrame (debugFrame framesU procs)++  -- .aranges section: Information about the bounds of compilation units+  let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs+               | otherwise                 = [DwarfARange lowLabel highLabel]+  let aranges = dwarfARangesSection $$ pprDwarfARanges aranges' unitU++  return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')++-- | Build an address range entry for one proc.+-- With split sections, each proc needs its own entry, since they may get+-- scattered in the final binary. Without split sections, we could make a+-- single arange based on the first/last proc.+mkDwarfARange :: DebugBlock -> DwarfARange+mkDwarfARange proc = DwarfARange start end+  where+    start = dblCLabel proc+    end = mkAsmTempEndLabel start++-- | Header for a compilation unit, establishing global format+-- parameters+compileUnitHeader :: Unique -> SDoc+compileUnitHeader unitU = sdocWithPlatform $ \plat ->+  let cuLabel = mkAsmTempLabel unitU  -- sits right before initialLength field+      length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel+               <> text "-4"       -- length of initialLength field+  in vcat [ ppr cuLabel <> colon+          , text "\t.long " <> length  -- compilation unit size+          , pprHalf 3                          -- DWARF version+          , sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)+                                               -- abbrevs offset+          , text "\t.byte " <> ppr (platformWordSize 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 view
@@ -0,0 +1,229 @@+-- | 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 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 view
@@ -0,0 +1,614 @@+module Dwarf.Types+  ( -- * Dwarf information+    DwarfInfo(..)+  , pprDwarfInfo+  , pprAbbrevDecls+    -- * Dwarf address range table+  , DwarfARange(..)+  , pprDwarfARanges+    -- * Dwarf frame+  , DwarfFrame(..), DwarfFrameProc(..), DwarfFrameBlock(..)+  , pprDwarfFrame+    -- * Utilities+  , pprByte+  , pprHalf+  , pprData4'+  , pprDwWord+  , pprWord+  , pprLEBWord+  , pprLEBInt+  , wordAlign+  , sectionOffset+  )+  where++import GhcPrelude++import Debug+import CLabel+import CmmExpr         ( GlobalReg(..) )+import Encoding+import FastString+import Outputable+import 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 CodeGen.Platform++-- | 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 = platformWordSize 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+      initialLength = 8 + paddingSize + 2*2*wordSize+  in pprDwWord (ppr initialLength)+     $$ pprHalf 2+     $$ sectionOffset (ppr $ mkAsmTempLabel $ unitU)+                      (ptext dwarfInfoLabel)+     $$ pprByte (fromIntegral wordSize)+     $$ pprByte 0+     $$ pad paddingSize+     -- body+     $$ vcat (map pprDwarfARange arngs)+     -- terminus+     $$ pprWord (char '0')+     $$ pprWord (char '0')++pprDwarfARange :: DwarfARange -> SDoc+pprDwarfARange arng = pprWord (ppr $ dwArngStartLabel arng) $$ pprWord length+  where+    length = ppr (dwArngEndLabel arng)+             <> char '-' <> ppr (dwArngStartLabel arng)++-- | Information about unwind instructions for a procedure. This+-- corresponds to a "Common Information Entry" (CIE) in DWARF.+data DwarfFrame+  = DwarfFrame+    { dwCieLabel :: CLabel+    , dwCieInit  :: UnwindTable+    , dwCieProcs :: [DwarfFrameProc]+    }++-- | Unwind instructions for an individual procedure. Corresponds to a+-- "Frame Description Entry" (FDE) in DWARF.+data DwarfFrameProc+  = DwarfFrameProc+    { dwFdeProc    :: CLabel+    , dwFdeHasInfo :: Bool+    , dwFdeBlocks  :: [DwarfFrameBlock]+      -- ^ List of blocks. Order must match asm!+    }++-- | Unwind instructions for a block. Will become part of the+-- containing FDE.+data DwarfFrameBlock+  = DwarfFrameBlock+    { dwFdeBlkHasInfo :: Bool+    , dwFdeUnwind     :: [UnwindPoint]+      -- ^ these unwind points must occur in the same order as they occur+      -- in the block+    }++instance Outputable DwarfFrameBlock where+  ppr (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> ppr unwinds++-- | Header for the @.debug_frame@ section. Here we emit the "Common+-- Information Entry" record that etablishes general call frame+-- parameters and the default stack layout.+pprDwarfFrame :: DwarfFrame -> SDoc+pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}+  = sdocWithPlatform $ \plat ->+    let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")+        cieEndLabel = mkAsmTempEndLabel cieLabel+        length      = ppr cieEndLabel <> char '-' <> ppr cieStartLabel+        spReg       = dwarfGlobalRegNo plat Sp+        retReg      = dwarfReturnRegNo plat+        wordSize    = platformWordSize 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` platformWordSize plat) == 0 -- expected case+  = pprByte (dW_CFA_offset + dwarfGlobalRegNo plat g) $$+    pprLEBWord (fromIntegral ((-o) `div` platformWordSize 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+      8      -> text "3"+      4      -> text "2"+      _other -> error "wordAlign: Unsupported word size!"+    _other   -> ppr (platformWordSize 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+    4 -> text "\t.long "+    8 -> text "\t.quad "+    n -> panic $ "pprWord: Unsupported target platform word length " +++                 show n ++ "!"++-- | 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 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 currenly shared by all architectures because+--              NCGMonad need to know about it to make a VReg. It would be better+--              to have architecture specific formats, and do the overloading+--              properly. eg SPARC doesn't care about FF80.+--+module Format (+    Format(..),+    intFormat,+    floatFormat,+    isFloatFormat,+    cmmTypeFormat,+    formatToWidth,+    formatInBytes+)++where++import GhcPrelude++import Cmm+import Outputable++-- It looks very like the old MachRep, but it's now of purely local+-- significance, here in the native code generator.  You can change it+-- without global consequences.+--+-- A major use is as an opcode qualifier; thus the opcode+--      mov.l a b+-- might be encoded+--      MOV II32 a b+-- where the Format field encodes the ".l" part.++-- ToDo: it's not clear to me that we need separate signed-vs-unsigned formats+--        here.  I've removed them from the x86 version, we'll see what happens --SDM++-- ToDo: quite a few occurrences of Format could usefully be replaced by Width++data Format+        = II8+        | II16+        | II32+        | II64+        | FF32+        | FF64+        deriving (Show, Eq)+++-- | Get the integer format of this width.+intFormat :: Width -> Format+intFormat width+ = case width of+        W8      -> II8+        W16     -> II16+        W32     -> II32+        W64     -> II64+        other   -> sorry $ "The native code generator cannot " +++            "produce code for Format.intFormat " ++ show other+            ++ "\n\tConsider using the llvm backend with -fllvm"+++-- | Get the float format of this width.+floatFormat :: Width -> Format+floatFormat width+ = case width of+        W32     -> FF32+        W64     -> FF64++        other   -> pprPanic "Format.floatFormat" (ppr other)+++-- | Check if a format represents a floating point value.+isFloatFormat :: Format -> Bool+isFloatFormat format+ = case format of+        FF32    -> True+        FF64    -> True+        _       -> False+++-- | Convert a Cmm type to a Format.+cmmTypeFormat :: CmmType -> Format+cmmTypeFormat ty+        | isFloatType ty        = floatFormat (typeWidth ty)+        | otherwise             = intFormat (typeWidth ty)+++-- | Get the Width of a Format.+formatToWidth :: Format -> Width+formatToWidth format+ = case format of+        II8             -> W8+        II16            -> W16+        II32            -> W32+        II64            -> W64+        FF32            -> W32+        FF64            -> W64+++formatInBytes :: Format -> Int+formatInBytes = widthInBytes . formatToWidth
+ compiler/nativeGen/Instruction.hs view
@@ -0,0 +1,202 @@++module Instruction (+        RegUsage(..),+        noUsage,+        GenBasicBlock(..), blockId,+        ListGraph(..),+        NatCmm,+        NatCmmDecl,+        NatBasicBlock,+        topInfoTable,+        entryBlocks,+        Instruction(..)+)++where++import GhcPrelude++import Reg++import BlockId+import Hoopl.Collections+import Hoopl.Label+import DynFlags+import Cmm hiding (topInfoTable)+import 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/NCG.h view
@@ -0,0 +1,11 @@+/* -----------------------------------------------------------------------------++   (c) The University of Glasgow, 1994-2004++   Native-code generator header file - just useful macros for now.++   -------------------------------------------------------------------------- */++#pragma once++#include "ghc_boot_platform.h"
+ compiler/nativeGen/NCGMonad.hs view
@@ -0,0 +1,293 @@+{-# LANGUAGE CPP #-}++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 1993-2004+--+-- The native code generator's monad.+--+-- -----------------------------------------------------------------------------++module NCGMonad (+        NcgImpl(..),+        NatM_State(..), mkNatM_State,++        NatM, -- instance Monad+        initNat,+        addImportNat,+        addNodeBetweenNat,+        addImmediateSuccessorNat,+        updateCfgNat,+        getUniqueNat,+        mapAccumLNat,+        setDeltaNat,+        getDeltaNat,+        getThisModuleNat,+        getBlockIdNat,+        getNewLabelNat,+        getNewRegNat,+        getNewRegPairNat,+        getPicBaseMaybeNat,+        getPicBaseNat,+        getDynFlags,+        getModLoc,+        getFileId,+        getDebugBlock,++        DwarfFiles+)++where++#include "HsVersions.h"++import GhcPrelude++import Reg+import Format+import TargetReg++import BlockId+import Hoopl.Collections+import Hoopl.Label+import CLabel           ( CLabel )+import Debug+import FastString       ( FastString )+import UniqFM+import UniqSupply+import Unique           ( Unique )+import DynFlags+import Module++import Control.Monad    ( liftM, ap )++import Instruction+import Outputable (SDoc, pprPanic, ppr)+import Cmm (RawCmmDecl, CmmStatics)+import CFG++data NcgImpl statics instr jumpDest = NcgImpl {+    cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],+    generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),+    getJumpDestBlockId        :: jumpDest -> Maybe BlockId,+    canShortcut               :: instr -> Maybe jumpDest,+    shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,+    shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,+    pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,+    maxSpillSlots             :: Int,+    allocatableRegs           :: [RealReg],+    ncgExpandTop              :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr],+    ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr+                              -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),+    -- ^ The list of block ids records the redirected jumps to allow us to update+    -- the CFG.+    ncgMakeFarBranches        :: LabelMap CmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr],+    extractUnwindPoints       :: [instr] -> [UnwindPoint],+    -- ^ given the instruction sequence of a block, produce a list of+    -- the block's 'UnwindPoint's+    -- See Note [What is this unwinding business?] in Debug+    -- and Note [Unwinding information in the NCG] in this module.+    invertCondBranches        :: 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))++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 Functor NatM where+      fmap = liftM++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 -> ((), st { natm_cfg = f (natm_cfg st) })++-- | Record that we added a block between `from` and `old`.+addNodeBetweenNat :: BlockId -> BlockId -> BlockId -> NatM ()+addNodeBetweenNat from between to+ = do   df <- getDynFlags+        let jmpWeight = fromIntegral . uncondWeight .+                        cfgWeightInfo $ df+        updateCfgNat (updateCfg jmpWeight from between to)+  where+    -- When transforming A -> B to A -> A' -> B+    -- A -> A' keeps the old edge info while+    -- A' -> B gets the info for an unconditional+    -- jump.+    updateCfg weight from between old m+        | Just info <- getEdgeInfo from old m+        = addEdge from between info .+          addWeightEdge between old weight .+          delEdge from old $ m+        | otherwise+        = pprPanic "Faild to update cfg: Untracked edge" (ppr (from,to))+++-- | Place `succ` after `block` and change any edges+--   block -> X to `succ` -> X+addImmediateSuccessorNat :: BlockId -> BlockId -> NatM ()+addImmediateSuccessorNat block succ+        = updateCfgNat (addImmediateSuccessor block succ)++getBlockIdNat :: NatM BlockId+getBlockIdNat+ = do   u <- getUniqueNat+        return (mkBlockId u)+++getNewLabelNat :: NatM CLabel+getNewLabelNat+ = blockLbl <$> getBlockIdNat+++getNewRegNat :: Format -> NatM Reg+getNewRegNat rep+ = do u <- getUniqueNat+      dflags <- getDynFlags+      return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep)+++getNewRegPairNat :: Format -> NatM (Reg,Reg)+getNewRegPairNat rep+ = do u <- getUniqueNat+      dflags <- getDynFlags+      let vLo = targetMkVirtualReg (targetPlatform dflags) u rep+      let lo  = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep+      let hi  = RegVirtual $ getHiVirtualRegFromLo vLo+      return (lo, hi)+++getPicBaseMaybeNat :: NatM (Maybe Reg)+getPicBaseMaybeNat+        = NatM (\state -> (natm_pic state, state))+++getPicBaseNat :: Format -> NatM Reg+getPicBaseNat rep+ = do   mbPicBase <- getPicBaseMaybeNat+        case mbPicBase of+                Just picBase -> return picBase+                Nothing+                 -> do+                        reg <- getNewRegNat rep+                        NatM (\state -> (reg, state { natm_pic = Just reg }))++getModLoc :: NatM ModLocation+getModLoc+        = NatM $ \ st -> (natm_modloc st, st)++getFileId :: FastString -> NatM Int+getFileId f = NatM $ \st ->+  case lookupUFM (natm_fileid st) f of+    Just (_,n) -> (n, st)+    Nothing    -> let n = 1 + sizeUFM (natm_fileid st)+                      fids = addToUFM (natm_fileid st) f (f,n)+                  in n `seq` fids `seq` (n, st { natm_fileid = fids  })++getDebugBlock :: Label -> NatM (Maybe DebugBlock)+getDebugBlock l = NatM $ \st -> (mapLookup l (natm_debug_map st), st)
+ compiler/nativeGen/PIC.hs view
@@ -0,0 +1,838 @@+{-+  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 Platform+import Instruction+import Reg+import NCGMonad+++import Hoopl.Collections+import Cmm+import CLabel           ( CLabel, ForeignLabelSource(..), pprCLabel,+                          mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..),+                          dynamicLinkerLabelInfo, mkPicBaseLabel,+                          labelDynamic, externallyVisibleCLabel )++import CLabel           ( mkForeignLabel )+++import BasicTypes+import Module++import Outputable++import DynFlags+import FastString++++--------------------------------------------------------------------------------+-- It gets called by the cmmToCmm pass for every CmmLabel in the Cmm+-- code. It does The Right Thing(tm) to convert the CmmLabel into a+-- position-independent, dynamic-linking-aware reference to the thing+-- in question.+-- Note that this also has to be called from MachCodeGen in order to+-- access static data like floating point literals (labels that were+-- created after the cmmToCmm pass).+-- The function must run in a monad that can keep track of imported symbols+-- A function for recording an imported symbol must be passed in:+-- - addImportCmmOpt for the CmmOptM monad+-- - addImportNat for the NatM monad.++data ReferenceKind+        = DataReference+        | CallReference+        | JumpReference+        deriving(Eq)++class Monad m => CmmMakeDynamicReferenceM m where+    addImport :: CLabel -> m ()+    getThisModule :: m Module++instance CmmMakeDynamicReferenceM NatM where+    addImport = addImportNat+    getThisModule = getThisModuleNat++cmmMakeDynamicReference+  :: CmmMakeDynamicReferenceM m+  => DynFlags+  -> ReferenceKind     -- whether this is the target of a jump+  -> CLabel            -- the label+  -> m CmmExpr++cmmMakeDynamicReference dflags referenceKind lbl+  | Just _ <- dynamicLinkerLabelInfo lbl+  = return $ CmmLit $ CmmLabel lbl   -- already processed it, pass through++  | otherwise+  = do this_mod <- getThisModule+       case howToAccessLabel+                dflags+                (platformArch $ targetPlatform dflags)+                (platformOS   $ targetPlatform dflags)+                this_mod+                referenceKind lbl of++        AccessViaStub -> do+              let stub = mkDynamicLinkerLabel CodeStub lbl+              addImport stub+              return $ CmmLit $ CmmLabel stub++        AccessViaSymbolPtr -> do+              let symbolPtr = mkDynamicLinkerLabel SymbolPtr lbl+              addImport symbolPtr+              return $ CmmLoad (cmmMakePicReference dflags symbolPtr) (bWord dflags)++        AccessDirectly -> case referenceKind of+                -- for data, we might have to make some calculations:+              DataReference -> return $ cmmMakePicReference dflags lbl+                -- all currently supported processors support+                -- PC-relative branch and call instructions,+                -- so just jump there if it's a call or a jump+              _ -> return $ CmmLit $ CmmLabel lbl+++-- -----------------------------------------------------------------------------+-- Create a position independent reference to a label.+-- (but do not bother with dynamic linking).+-- We calculate the label's address by adding some (platform-dependent)+-- offset to our base register; this offset is calculated by+-- the function picRelative in the platform-dependent part below.++cmmMakePicReference :: DynFlags -> CLabel -> CmmExpr+cmmMakePicReference dflags lbl++        -- Windows doesn't need PIC,+        -- everything gets relocated at runtime+        | OSMinGW32 <- platformOS $ targetPlatform dflags+        = CmmLit $ CmmLabel lbl++        | OSAIX <- platformOS $ targetPlatform dflags+        = CmmMachOp (MO_Add W32)+                [ CmmReg (CmmGlobal PicBaseReg)+                , CmmLit $ picRelative dflags+                                (platformArch   $ targetPlatform dflags)+                                (platformOS     $ targetPlatform dflags)+                                lbl ]++        -- both ABI versions default to medium code model+        | ArchPPC_64 _ <- platformArch $ targetPlatform dflags+        = CmmMachOp (MO_Add W32) -- code model medium+                [ CmmReg (CmmGlobal PicBaseReg)+                , CmmLit $ picRelative dflags+                                (platformArch   $ targetPlatform dflags)+                                (platformOS     $ targetPlatform dflags)+                                lbl ]++        | (positionIndependent dflags || gopt Opt_ExternalDynamicRefs dflags)+            && absoluteLabel lbl+        = CmmMachOp (MO_Add (wordWidth dflags))+                [ CmmReg (CmmGlobal PicBaseReg)+                , CmmLit $ picRelative dflags+                                (platformArch   $ targetPlatform dflags)+                                (platformOS     $ targetPlatform dflags)+                                lbl ]++        | otherwise+        = CmmLit $ CmmLabel lbl+++absoluteLabel :: CLabel -> Bool+absoluteLabel lbl+ = case dynamicLinkerLabelInfo lbl of+        Just (GotSymbolPtr, _)    -> False+        Just (GotSymbolOffset, _) -> False+        _                         -> True+++--------------------------------------------------------------------------------+-- Knowledge about how special dynamic linker labels like symbol+-- pointers, code stubs and GOT offsets look like is located in the+-- module CLabel.++-- We have to decide which labels need to be accessed+-- indirectly or via a piece of stub code.+data LabelAccessStyle+        = AccessViaStub+        | AccessViaSymbolPtr+        | AccessDirectly++howToAccessLabel+        :: DynFlags -> Arch -> OS -> Module -> ReferenceKind -> CLabel -> LabelAccessStyle+++-- Windows+-- In Windows speak, a "module" is a set of objects linked into the+-- same Portable Exectuable (PE) file. (both .exe and .dll files are PEs).+--+-- If we're compiling a multi-module program then symbols from other modules+-- are accessed by a symbol pointer named __imp_SYMBOL. At runtime we have the+-- following.+--+--   (in the local module)+--     __imp_SYMBOL: addr of SYMBOL+--+--   (in the other module)+--     SYMBOL: the real function / data.+--+-- To access the function at SYMBOL from our local module, we just need to+-- dereference the local __imp_SYMBOL.+--+-- If not compiling with -dynamic we assume that all our code will be linked+-- into the same .exe file. In this case we always access symbols directly,+-- and never use __imp_SYMBOL.+--+howToAccessLabel dflags _ OSMinGW32 this_mod _ lbl++        -- Assume all symbols will be in the same PE, so just access them directly.+        | not (gopt Opt_ExternalDynamicRefs dflags)+        = AccessDirectly++        -- If the target symbol is in another PE we need to access it via the+        --      appropriate __imp_SYMBOL pointer.+        | labelDynamic dflags this_mod lbl+        = AccessViaSymbolPtr++        -- Target symbol is in the same PE as the caller, so just access it directly.+        | otherwise+        = AccessDirectly+++-- Mach-O (Darwin, Mac OS X)+--+-- Indirect access is required in the following cases:+--  * things imported from a dynamic library+--  * (not on x86_64) data from a different module, if we're generating PIC code+-- It is always possible to access something indirectly,+-- even when it's not necessary.+--+howToAccessLabel dflags arch OSDarwin this_mod DataReference lbl+        -- data access to a dynamic library goes via a symbol pointer+        | labelDynamic dflags this_mod lbl+        = AccessViaSymbolPtr++        -- when generating PIC code, all cross-module data references must+        -- must go via a symbol pointer, too, because the assembler+        -- cannot generate code for a label difference where one+        -- label is undefined. Doesn't apply t x86_64.+        -- Unfortunately, we don't know whether it's cross-module,+        -- so we do it for all externally visible labels.+        -- This is a slight waste of time and space, but otherwise+        -- we'd need to pass the current Module all the way in to+        -- this function.+        | arch /= ArchX86_64+        , positionIndependent dflags && externallyVisibleCLabel lbl+        = AccessViaSymbolPtr++        | otherwise+        = AccessDirectly++howToAccessLabel dflags arch OSDarwin this_mod JumpReference lbl+        -- dyld code stubs don't work for tailcalls because the+        -- stack alignment is only right for regular calls.+        -- Therefore, we have to go via a symbol pointer:+        | arch == ArchX86 || arch == ArchX86_64+        , labelDynamic dflags this_mod lbl+        = AccessViaSymbolPtr+++howToAccessLabel dflags arch OSDarwin this_mod _ lbl+        -- Code stubs are the usual method of choice for imported code;+        -- not needed on x86_64 because Apple's new linker, ld64, generates+        -- them automatically.+        | arch /= ArchX86_64+        , labelDynamic dflags this_mod lbl+        = AccessViaStub++        | otherwise+        = AccessDirectly+++----------------------------------------------------------------------------+-- AIX++-- quite simple (for now)+howToAccessLabel _dflags _arch OSAIX _this_mod kind _lbl+        = case kind of+            DataReference -> AccessViaSymbolPtr+            CallReference -> AccessDirectly+            JumpReference -> AccessDirectly++-- ELF (Linux)+--+-- ELF tries to pretend to the main application code that dynamic linking does+-- not exist. While this may sound convenient, it tends to mess things up in+-- very bad ways, so we have to be careful when we generate code for a non-PIE+-- main program (-dynamic but no -fPIC).+--+-- Indirect access is required for references to imported symbols+-- from position independent code. It is also required from the main program+-- when dynamic libraries containing Haskell code are used.++howToAccessLabel _ (ArchPPC_64 _) os _ kind _+        | osElfTarget os+        = case kind of+          -- ELF PPC64 (powerpc64-linux), AIX, MacOS 9, BeOS/PPC+          DataReference -> AccessViaSymbolPtr+          -- RTLD does not generate stubs for function descriptors+          -- in tail calls. Create a symbol pointer and generate+          -- the code to load the function descriptor at the call site.+          JumpReference -> AccessViaSymbolPtr+          -- regular calls are handled by the runtime linker+          _             -> AccessDirectly++howToAccessLabel dflags _ os _ _ _+        -- no PIC -> the dynamic linker does everything for us;+        --           if we don't dynamically link to Haskell code,+        --           it actually manages to do so without messing things up.+        | osElfTarget os+        , not (positionIndependent dflags) &&+          not (gopt Opt_ExternalDynamicRefs dflags)+        = AccessDirectly++howToAccessLabel dflags arch os this_mod DataReference lbl+        | osElfTarget os+        = case () of+            -- A dynamic label needs to be accessed via a symbol pointer.+          _ | labelDynamic dflags this_mod lbl+            -> AccessViaSymbolPtr++            -- For PowerPC32 -fPIC, we have to access even static data+            -- via a symbol pointer (see below for an explanation why+            -- PowerPC32 Linux is especially broken).+            | arch == ArchPPC+            , positionIndependent dflags+            -> AccessViaSymbolPtr++            | otherwise+            -> AccessDirectly+++        -- In most cases, we have to avoid symbol stubs on ELF, for the following reasons:+        --   on i386, the position-independent symbol stubs in the Procedure Linkage Table+        --   require the address of the GOT to be loaded into register %ebx on entry.+        --   The linker will take any reference to the symbol stub as a hint that+        --   the label in question is a code label. When linking executables, this+        --   will cause the linker to replace even data references to the label with+        --   references to the symbol stub.++        -- This leaves calling a (foreign) function from non-PIC code+        -- (AccessDirectly, because we get an implicit symbol stub)+        -- and calling functions from PIC code on non-i386 platforms (via a symbol stub)++howToAccessLabel dflags arch os this_mod CallReference lbl+        | osElfTarget os+        , labelDynamic dflags this_mod lbl && not (positionIndependent dflags)+        = AccessDirectly++        | osElfTarget os+        , arch /= ArchX86+        , labelDynamic dflags this_mod lbl+        , positionIndependent dflags+        = AccessViaStub++howToAccessLabel dflags _ os this_mod _ lbl+        | osElfTarget os+        = if labelDynamic dflags this_mod lbl+            then AccessViaSymbolPtr+            else AccessDirectly++-- all other platforms+howToAccessLabel dflags _ _ _ _ _+        | not (positionIndependent dflags)+        = AccessDirectly++        | otherwise+        = panic "howToAccessLabel: PIC not defined for this platform"++++-- -------------------------------------------------------------------+-- | Says what we have to add to our 'PIC base register' in order to+--      get the address of a label.++picRelative :: DynFlags -> Arch -> OS -> CLabel -> CmmLit++-- Darwin, but not x86_64:+-- The PIC base register points to the PIC base label at the beginning+-- of the current CmmDecl. We just have to use a label difference to+-- get the offset.+-- We have already made sure that all labels that are not from the current+-- module are accessed indirectly ('as' can't calculate differences between+-- undefined labels).+picRelative dflags arch OSDarwin lbl+        | arch /= ArchX86_64+        = CmmLabelDiffOff lbl mkPicBaseLabel 0 (wordWidth dflags)++-- On AIX we use an indirect local TOC anchored by 'gotLabel'.+-- This way we use up only one global TOC entry per compilation-unit+-- (this is quite similiar to GCC's @-mminimal-toc@ compilation mode)+picRelative dflags _ OSAIX lbl+        = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags)++-- PowerPC Linux:+-- The PIC base register points to our fake GOT. Use a label difference+-- to get the offset.+-- We have made sure that *everything* is accessed indirectly, so this+-- is only used for offsets from the GOT to symbol pointers inside the+-- GOT.+picRelative dflags ArchPPC os lbl+        | osElfTarget os+        = CmmLabelDiffOff lbl gotLabel 0 (wordWidth dflags)+++-- Most Linux versions:+-- The PIC base register points to the GOT. Use foo@got for symbol+-- pointers, and foo@gotoff for everything else.+-- Linux and Darwin on x86_64:+-- The PIC base register is %rip, we use foo@gotpcrel for symbol pointers,+-- and a GotSymbolOffset label for other things.+-- For reasons of tradition, the symbol offset label is written as a plain label.+picRelative _ arch os lbl+        | osElfTarget os || (os == OSDarwin && arch == ArchX86_64)+        = let   result+                        | Just (SymbolPtr, lbl') <- dynamicLinkerLabelInfo lbl+                        = CmmLabel $ mkDynamicLinkerLabel GotSymbolPtr lbl'++                        | otherwise+                        = CmmLabel $ mkDynamicLinkerLabel GotSymbolOffset lbl++          in    result++picRelative _ _ _ _+        = panic "PositionIndependentCode.picRelative undefined for this platform"++++--------------------------------------------------------------------------------++needImportedSymbols :: DynFlags -> Arch -> OS -> Bool+needImportedSymbols dflags arch os+        | os    == OSDarwin+        , arch  /= ArchX86_64+        = True++        | os    == OSAIX+        = True++        -- PowerPC Linux: -fPIC or -dynamic+        | osElfTarget os+        , arch  == ArchPPC+        = positionIndependent dflags || gopt Opt_ExternalDynamicRefs dflags++        -- PowerPC 64 Linux: always+        | osElfTarget os+        , arch == ArchPPC_64 ELF_V1 || arch == ArchPPC_64 ELF_V2+        = True++        -- i386 (and others?): -dynamic but not -fPIC+        | osElfTarget os+        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2+        = gopt Opt_ExternalDynamicRefs dflags &&+          not (positionIndependent dflags)++        | otherwise+        = False++-- gotLabel+-- The label used to refer to our "fake GOT" from+-- position-independent code.+gotLabel :: CLabel+gotLabel+        -- HACK: this label isn't really foreign+        = mkForeignLabel+                (fsLit ".LCTOC1")+                Nothing ForeignLabelInThisPackage IsData++++--------------------------------------------------------------------------------+-- We don't need to declare any offset tables.+-- However, for PIC on x86, we need a small helper function.+pprGotDeclaration :: DynFlags -> Arch -> OS -> SDoc+pprGotDeclaration dflags ArchX86 OSDarwin+        | positionIndependent dflags+        = vcat [+                text ".section __TEXT,__textcoal_nt,coalesced,no_toc",+                text ".weak_definition ___i686.get_pc_thunk.ax",+                text ".private_extern ___i686.get_pc_thunk.ax",+                text "___i686.get_pc_thunk.ax:",+                text "\tmovl (%esp), %eax",+                text "\tret" ]++pprGotDeclaration _ _ OSDarwin+        = empty++-- Emit XCOFF TOC section+pprGotDeclaration _ _ OSAIX+        = vcat $ [ text ".toc"+                 , text ".tc ghc_toc_table[TC],.LCTOC1"+                 , text ".csect ghc_toc_table[RW]"+                   -- See Note [.LCTOC1 in PPC PIC code]+                 , text ".set .LCTOC1,$+0x8000"+                 ]+++-- PPC 64 ELF v1 needs a Table Of Contents (TOC)+pprGotDeclaration _ (ArchPPC_64 ELF_V1) _+        = text ".section \".toc\",\"aw\""+-- In ELF v2 we also need to tell the assembler that we want ABI+-- version 2. This would normally be done at the top of the file+-- right after a file directive, but I could not figure out how+-- to do that.+pprGotDeclaration _ (ArchPPC_64 ELF_V2) _+        = vcat [ text ".abiversion 2",+                 text ".section \".toc\",\"aw\""+               ]++-- Emit GOT declaration+-- Output whatever needs to be output once per .s file.+pprGotDeclaration dflags arch os+        | osElfTarget os+        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2+        , not (positionIndependent dflags)+        = empty++        | osElfTarget os+        , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2+        = vcat [+                -- See Note [.LCTOC1 in PPC PIC code]+                text ".section \".got2\",\"aw\"",+                text ".LCTOC1 = .+32768" ]++pprGotDeclaration _ _ _+        = panic "pprGotDeclaration: no match"+++--------------------------------------------------------------------------------+-- On Darwin, we have to generate our own stub code for lazy binding..+-- For each processor architecture, there are two versions, one for PIC+-- and one for non-PIC.+--++pprImportedSymbol :: DynFlags -> Platform -> CLabel -> SDoc+pprImportedSymbol dflags (Platform { platformArch = ArchX86, platformOS = 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 { platformOS = OSDarwin }) _+        = empty++-- XCOFF / AIX+--+-- Similiar to PPC64 ELF v1, there's dedicated TOC register (r2). To+-- workaround the limitation of a global TOC we use an indirect TOC+-- with the label `ghc_toc_table`.+--+-- See also GCC's `-mminimal-toc` compilation mode or+-- http://www.ibm.com/developerworks/rational/library/overview-toc-aix/+--+-- NB: No DSO-support yet++pprImportedSymbol dflags (Platform { platformOS = 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 { platformArch = 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 view
@@ -0,0 +1,2446 @@+{-# 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"+#include "nativeGen/NCG.h"+#include "../includes/MachDeps.h"++-- NCG stuff:+import GhcPrelude++import CodeGen.Platform+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 Platform++-- Our intermediate code:+import BlockId+import PprCmm           ( pprExpr )+import Cmm+import CmmUtils+import CmmSwitch+import CLabel+import Hoopl.Block+import Hoopl.Graph++-- The rest:+import OrdList+import Outputable+import DynFlags++import Control.Monad    ( mapAndUnzipM, when )+import Data.Bits+import Data.Word++import BasicTypes+import FastString+import Util++-- -----------------------------------------------------------------------------+-- Top-level of the instruction selector++-- | 'InstrBlock's are the insn sequences generated by the insn selectors.+-- They are really trees of insns to facilitate fast appending, where a+-- left-to-right traversal (pre-order?) yields the insns in the correct+-- order.++cmmTopCodeGen+        :: RawCmmDecl+        -> NatM [NatCmmDecl CmmStatics Instr]++cmmTopCodeGen (CmmProc info lab live graph) = do+  let blocks = toBlockListEntryFirst graph+  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks+  dflags <- getDynFlags+  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)+      tops = proc : concat statics+      os   = platformOS $ targetPlatform dflags+      arch = platformArch $ targetPlatform dflags+  case arch of+    ArchPPC | os == OSAIX -> return tops+            | otherwise -> do+      picBaseMb <- getPicBaseMaybeNat+      case picBaseMb of+           Just picBase -> initializePicBase_ppc arch os picBase tops+           Nothing -> return tops+    ArchPPC_64 ELF_V1 -> fixup_entry tops+                      -- generating function descriptor is handled in+                      -- pretty printer+    ArchPPC_64 ELF_V2 -> fixup_entry tops+                      -- generating function prologue is handled in+                      -- pretty printer+    _          -> panic "PPC.cmmTopCodeGen: unknown arch"+    where+      fixup_entry (CmmProc info lab live (ListGraph (entry:blocks)) : statics)+        = do+        let BasicBlock bID insns = entry+        bID' <- if lab == (blockLbl bID)+                then newBlockId+                else return bID+        let b' = BasicBlock bID' insns+        return (CmmProc info lab live (ListGraph (b':blocks)) : statics)+      fixup_entry _ = panic "cmmTopCodegen: Broken CmmProc"++cmmTopCodeGen (CmmData sec dat) = do+  return [CmmData sec dat]  -- no translation, we just use CmmStatic++basicBlockCodeGen+        :: Block CmmNode C C+        -> NatM ( [NatBasicBlock Instr]+                , [NatCmmDecl CmmStatics Instr])++basicBlockCodeGen block = do+  let (_, nodes, tail)  = blockSplit block+      id = entryLabel block+      stmts = blockToList nodes+  mid_instrs <- stmtsToInstrs stmts+  tail_instrs <- stmtToInstrs tail+  let instrs = mid_instrs `appOL` tail_instrs+  -- code generation may introduce new basic block boundaries, which+  -- are indicated by the NEWBLOCK instruction.  We must split up the+  -- instruction stream into basic blocks again.  Also, we extract+  -- LDATAs here too.+  let+        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs++        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)+          = ([], BasicBlock id instrs : blocks, statics)+        mkBlocks (LDATA sec dat) (instrs,blocks,statics)+          = (instrs, blocks, CmmData sec dat:statics)+        mkBlocks instr (instrs,blocks,statics)+          = (instr:instrs, blocks, statics)+  return (BasicBlock id top : other_blocks, statics)++stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock+stmtsToInstrs stmts+   = do instrss <- mapM stmtToInstrs stmts+        return (concatOL instrss)++stmtToInstrs :: CmmNode e x -> NatM InstrBlock+stmtToInstrs stmt = do+  dflags <- getDynFlags+  case stmt of+    CmmComment s   -> return (unitOL (COMMENT s))+    CmmTick {}     -> return nilOL+    CmmUnwind {}   -> return nilOL++    CmmAssign reg src+      | isFloatType ty -> assignReg_FltCode format reg src+      | target32Bit (targetPlatform dflags) &&+        isWord64 ty    -> assignReg_I64Code      reg src+      | otherwise      -> assignReg_IntCode format reg src+        where ty = cmmRegType dflags reg+              format = cmmTypeFormat ty++    CmmStore addr src+      | isFloatType ty -> assignMem_FltCode format addr src+      | target32Bit (targetPlatform dflags) &&+        isWord64 ty    -> assignMem_I64Code      addr src+      | otherwise      -> assignMem_IntCode format addr src+        where ty = cmmExprType dflags src+              format = cmmTypeFormat ty++    CmmUnsafeForeignCall target result_regs args+       -> genCCall target result_regs args++    CmmBranch id          -> genBranch id+    CmmCondBranch arg true false prediction -> do+      b1 <- genCondJump true arg prediction+      b2 <- genBranch false+      return (b1 `appOL` b2)+    CmmSwitch arg ids -> do dflags <- getDynFlags+                            genSwitch dflags arg ids+    CmmCall { cml_target = arg+            , cml_args_regs = gregs } -> do+                                dflags <- getDynFlags+                                genJump arg (jumpRegs dflags gregs)+    _ ->+      panic "stmtToInstrs: statement should have been cps'd away"++jumpRegs :: DynFlags -> [GlobalReg] -> [Reg]+jumpRegs dflags gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]+    where platform = targetPlatform dflags++--------------------------------------------------------------------------------+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.+--      They are really trees of insns to facilitate fast appending, where a+--      left-to-right traversal yields the insns in the correct order.+--+type InstrBlock+        = OrdList Instr+++-- | Register's passed up the tree.  If the stix code forces the register+--      to live in a pre-decided machine register, it comes out as @Fixed@;+--      otherwise, it comes out as @Any@, and the parent can decide which+--      register to put it in.+--+data Register+        = Fixed Format Reg InstrBlock+        | Any   Format (Reg -> InstrBlock)+++swizzleRegisterRep :: Register -> Format -> Register+swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code+swizzleRegisterRep (Any _ codefn)     format = Any   format codefn+++-- | Grab the Reg for a CmmReg+getRegisterReg :: Platform -> CmmReg -> Reg++getRegisterReg _ (CmmLocal (LocalReg u pk))+  = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)++getRegisterReg platform (CmmGlobal mid)+  = case globalRegMaybe platform mid of+        Just reg -> RegReal reg+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)+        -- By this stage, the only MagicIds remaining should be the+        -- ones which map to a real machine register on this+        -- platform.  Hence ...++-- | Convert a BlockId to some CmmStatic data+jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic+jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))+jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)+    where blockLabel = blockLbl blockid++++-- -----------------------------------------------------------------------------+-- General things for putting together code sequences++-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert+-- CmmExprs into CmmRegOff?+mangleIndexTree :: DynFlags -> CmmExpr -> CmmExpr+mangleIndexTree dflags (CmmRegOff reg off)+  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]+  where width = typeWidth (cmmRegType dflags reg)++mangleIndexTree _ _+        = panic "PPC.CodeGen.mangleIndexTree: no match"++-- -----------------------------------------------------------------------------+--  Code gen for 64-bit arithmetic on 32-bit platforms++{-+Simple support for generating 64-bit code (ie, 64 bit values and 64+bit assignments) on 32-bit platforms.  Unlike the main code generator+we merely shoot for generating working code as simply as possible, and+pay little attention to code quality.  Specifically, there is no+attempt to deal cleverly with the fixed-vs-floating register+distinction; all values are generated into (pairs of) floating+registers, even if this would mean some redundant reg-reg moves as a+result.  Only one of the VRegUniques is returned, since it will be+of the VRegUniqueLo form, and the upper-half VReg can be determined+by applying getHiVRegFromLo to it.+-}++data ChildCode64        -- a.k.a "Register64"+      = ChildCode64+           InstrBlock   -- code+           Reg          -- the lower 32-bit temporary which contains the+                        -- result; use getHiVRegFromLo to find the other+                        -- VRegUnique.  Rules of this simplified insn+                        -- selection game are therefore that the returned+                        -- Reg may be modified+++-- | Compute an expression into a register, but+--      we don't mind which one it is.+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)+getSomeReg expr = do+  r <- getRegister expr+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, code tmp)+    Fixed _ reg code ->+        return (reg, code)++getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock)+getI64Amodes addrTree = do+    Amode hi_addr addr_code <- getAmode D addrTree+    case addrOffset hi_addr 4 of+        Just lo_addr -> return (hi_addr, lo_addr, addr_code)+        Nothing      -> do (hi_ptr, code) <- getSomeReg addrTree+                           return (AddrRegImm hi_ptr (ImmInt 0),+                                   AddrRegImm hi_ptr (ImmInt 4),+                                   code)+++assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock+assignMem_I64Code addrTree valueTree = do+        (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree+        ChildCode64 vcode rlo <- iselExpr64 valueTree+        let+                rhi = getHiVRegFromLo rlo++                -- Big-endian store+                mov_hi = ST II32 rhi hi_addr+                mov_lo = ST II32 rlo lo_addr+        return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)+++assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock+assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do+   ChildCode64 vcode r_src_lo <- iselExpr64 valueTree+   let+         r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32+         r_dst_hi = getHiVRegFromLo r_dst_lo+         r_src_hi = getHiVRegFromLo r_src_lo+         mov_lo = MR r_dst_lo r_src_lo+         mov_hi = MR r_dst_hi r_src_hi+   return (+        vcode `snocOL` mov_lo `snocOL` mov_hi+     )++assignReg_I64Code _ _+   = panic "assignReg_I64Code(powerpc): invalid lvalue"+++iselExpr64        :: CmmExpr -> NatM ChildCode64+iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do+    (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree+    (rlo, rhi) <- getNewRegPairNat II32+    let mov_hi = LD II32 rhi hi_addr+        mov_lo = LD II32 rlo lo_addr+    return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)+                         rlo++iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty+   = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))++iselExpr64 (CmmLit (CmmInt i _)) = do+  (rlo,rhi) <- getNewRegPairNat II32+  let+        half0 = fromIntegral (fromIntegral i :: Word16)+        half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)+        half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16)+        half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16)++        code = toOL [+                LIS rlo (ImmInt half1),+                OR rlo rlo (RIImm $ ImmInt half0),+                LIS rhi (ImmInt half3),+                OR rhi rhi (RIImm $ ImmInt half2)+                ]+  return (ChildCode64 code rlo)++iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do+   ChildCode64 code1 r1lo <- iselExpr64 e1+   ChildCode64 code2 r2lo <- iselExpr64 e2+   (rlo,rhi) <- getNewRegPairNat II32+   let+        r1hi = getHiVRegFromLo r1lo+        r2hi = getHiVRegFromLo r2lo+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ ADDC rlo r1lo r2lo,+                       ADDE rhi r1hi r2hi ]+   return (ChildCode64 code rlo)++iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do+   ChildCode64 code1 r1lo <- iselExpr64 e1+   ChildCode64 code2 r2lo <- iselExpr64 e2+   (rlo,rhi) <- getNewRegPairNat II32+   let+        r1hi = getHiVRegFromLo r1lo+        r2hi = getHiVRegFromLo r2lo+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ SUBFC rlo r2lo (RIReg r1lo),+                       SUBFE rhi r2hi r1hi ]+   return (ChildCode64 code rlo)++iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do+    (expr_reg,expr_code) <- getSomeReg expr+    (rlo, rhi) <- getNewRegPairNat II32+    let mov_hi = LI rhi (ImmInt 0)+        mov_lo = MR rlo expr_reg+    return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)+                         rlo++iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do+    (expr_reg,expr_code) <- getSomeReg expr+    (rlo, rhi) <- getNewRegPairNat II32+    let mov_hi = SRA II32 rhi expr_reg (RIImm (ImmInt 31))+        mov_lo = MR rlo expr_reg+    return $ ChildCode64 (expr_code `snocOL` mov_lo `snocOL` mov_hi)+                         rlo+iselExpr64 expr+   = pprPanic "iselExpr64(powerpc)" (pprExpr expr)++++getRegister :: CmmExpr -> NatM Register+getRegister e = do dflags <- getDynFlags+                   getRegister' dflags e++getRegister' :: DynFlags -> CmmExpr -> NatM Register++getRegister' dflags (CmmReg (CmmGlobal PicBaseReg))+  | OSAIX <- platformOS (targetPlatform dflags) = do+        let code dst = toOL [ LD II32 dst tocAddr ]+            tocAddr = AddrRegImm toc (ImmLit (text "ghc_toc_table[TC]"))+        return (Any II32 code)+  | target32Bit (targetPlatform dflags) = do+      reg <- getPicBaseNat $ archWordFormat (target32Bit (targetPlatform dflags))+      return (Fixed (archWordFormat (target32Bit (targetPlatform dflags)))+                    reg nilOL)+  | otherwise = return (Fixed II64 toc nilOL)++getRegister' dflags (CmmReg reg)+  = return (Fixed (cmmTypeFormat (cmmRegType dflags reg))+                  (getRegisterReg (targetPlatform dflags) reg) nilOL)++getRegister' dflags tree@(CmmRegOff _ _)+  = getRegister' dflags (mangleIndexTree dflags tree)++    -- for 32-bit architectuers, support some 64 -> 32 bit conversions:+    -- TO_W_(x), TO_W_(x >> 32)++getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32)+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | target32Bit (targetPlatform dflags) = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 (getHiVRegFromLo rlo) code++getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32)+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | target32Bit (targetPlatform dflags) = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 (getHiVRegFromLo rlo) code++getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) [x])+ | target32Bit (targetPlatform dflags) = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) [x])+ | target32Bit (targetPlatform dflags) = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister' dflags (CmmLoad mem pk)+ | not (isWord64 pk) = do+        let platform = targetPlatform dflags+        Amode addr addr_code <- getAmode D mem+        let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk)+                       addr_code `snocOL` LD format dst addr+        return (Any format code)+ | not (target32Bit (targetPlatform dflags)) = do+        Amode addr addr_code <- getAmode DS mem+        let code dst = addr_code `snocOL` LD II64 dst addr+        return (Any II64 code)++          where format = cmmTypeFormat pk++-- catch simple cases of zero- or sign-extended load+getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do+    Amode addr addr_code <- getAmode D mem+    return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))++getRegister' _ (CmmMachOp (MO_XX_Conv W8 W32) [CmmLoad mem _]) = do+    Amode addr addr_code <- getAmode D mem+    return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr))++getRegister' _ (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad mem _]) = do+    Amode addr addr_code <- getAmode D mem+    return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))++getRegister' _ (CmmMachOp (MO_XX_Conv W8 W64) [CmmLoad mem _]) = do+    Amode addr addr_code <- getAmode D mem+    return (Any II64 (\dst -> addr_code `snocOL` LD II8 dst addr))++-- Note: there is no Load Byte Arithmetic instruction, so no signed case here++getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do+    Amode addr addr_code <- getAmode D mem+    return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr))++getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do+    Amode addr addr_code <- getAmode D mem+    return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr))++getRegister' _ (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad mem _]) = do+    Amode addr addr_code <- getAmode D mem+    return (Any II64 (\dst -> addr_code `snocOL` LD II16 dst addr))++getRegister' _ (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad mem _]) = do+    Amode addr addr_code <- getAmode D mem+    return (Any II64 (\dst -> addr_code `snocOL` LA II16 dst addr))++getRegister' _ (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad mem _]) = do+    Amode addr addr_code <- getAmode D mem+    return (Any II64 (\dst -> addr_code `snocOL` LD II32 dst addr))++getRegister' _ (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad mem _]) = do+    -- lwa is DS-form. See Note [Power instruction format]+    Amode addr addr_code <- getAmode DS mem+    return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr))++getRegister' dflags (CmmMachOp mop [x]) -- unary MachOps+  = case mop of+      MO_Not rep   -> triv_ucode_int rep NOT++      MO_F_Neg w   -> triv_ucode_float w FNEG+      MO_S_Neg w   -> triv_ucode_int   w NEG++      MO_FF_Conv W64 W32 -> trivialUCode  FF32 FRSP x+      MO_FF_Conv W32 W64 -> conversionNop FF64 x++      MO_FS_Conv from to -> coerceFP2Int from to x+      MO_SF_Conv from to -> coerceInt2FP from to x++      MO_SS_Conv from to+        | from >= to -> conversionNop (intFormat to) x+        | otherwise  -> triv_ucode_int to (EXTS (intFormat from))++      MO_UU_Conv from to+        | from >= to -> conversionNop (intFormat to) x+        | otherwise  -> clearLeft from to++      MO_XX_Conv _ to -> conversionNop (intFormat to) x++      _ -> panic "PPC.CodeGen.getRegister: no match"++    where+        triv_ucode_int   width instr = trivialUCode (intFormat    width) instr x+        triv_ucode_float width instr = trivialUCode (floatFormat  width) instr x++        conversionNop new_format expr+            = do e_code <- getRegister' dflags expr+                 return (swizzleRegisterRep e_code new_format)++        clearLeft from to+            = do (src1, code1) <- getSomeReg x+                 let arch_fmt  = intFormat (wordWidth dflags)+                     arch_bits = widthInBits (wordWidth dflags)+                     size      = widthInBits from+                     code dst  = code1 `snocOL`+                                 CLRLI arch_fmt dst src1 (arch_bits - size)+                 return (Any (intFormat to) code)++getRegister' _ (CmmMachOp mop [x, y]) -- dyadic PrimOps+  = case mop of+      MO_F_Eq _ -> condFltReg EQQ x y+      MO_F_Ne _ -> condFltReg NE  x y+      MO_F_Gt _ -> condFltReg GTT x y+      MO_F_Ge _ -> condFltReg GE  x y+      MO_F_Lt _ -> condFltReg LTT x y+      MO_F_Le _ -> condFltReg LE  x y++      MO_Eq rep -> condIntReg EQQ rep x y+      MO_Ne rep -> condIntReg NE  rep x y++      MO_S_Gt rep -> condIntReg GTT rep x y+      MO_S_Ge rep -> condIntReg GE  rep x y+      MO_S_Lt rep -> condIntReg LTT rep x y+      MO_S_Le rep -> condIntReg LE  rep x y++      MO_U_Gt rep -> condIntReg GU  rep x y+      MO_U_Ge rep -> condIntReg GEU rep x y+      MO_U_Lt rep -> condIntReg LU  rep x y+      MO_U_Le rep -> condIntReg LEU rep x y++      MO_F_Add w  -> triv_float w FADD+      MO_F_Sub w  -> triv_float w FSUB+      MO_F_Mul w  -> triv_float w FMUL+      MO_F_Quot w -> triv_float w FDIV++         -- optimize addition with 32-bit immediate+         -- (needed for PIC)+      MO_Add W32 ->+        case y of+          CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate W32 True imm+            -> trivialCode W32 True ADD x (CmmLit $ CmmInt imm immrep)+          CmmLit lit+            -> do+                (src, srcCode) <- getSomeReg x+                let imm = litToImm lit+                    code dst = srcCode `appOL` toOL [+                                    ADDIS dst src (HA imm),+                                    ADD dst dst (RIImm (LO imm))+                                ]+                return (Any II32 code)+          _ -> trivialCode W32 True ADD x y++      MO_Add rep -> trivialCode rep True ADD x y+      MO_Sub rep ->+        case y of+          CmmLit (CmmInt imm immrep) | Just _ <- makeImmediate rep True (-imm)+            -> trivialCode rep True ADD x (CmmLit $ CmmInt (-imm) immrep)+          _ -> case x of+                 CmmLit (CmmInt imm _)+                   | Just _ <- makeImmediate rep True imm+                   -- subfi ('substract from' with immediate) doesn't exist+                   -> trivialCode rep True SUBFC y x+                 _ -> trivialCodeNoImm' (intFormat rep) SUBF y x++      MO_Mul rep -> shiftMulCode rep True MULL x y+      MO_S_MulMayOflo rep -> do+        (src1, code1) <- getSomeReg x+        (src2, code2) <- getSomeReg y+        let+          format = intFormat rep+          code dst = code1 `appOL` code2+                       `appOL` toOL [ MULLO format dst src1 src2+                                    , MFOV  format dst+                                    ]+        return (Any format code)++      MO_S_Quot rep -> divCode rep True x y+      MO_U_Quot rep -> divCode rep False x y++      MO_S_Rem rep -> remainder rep True x y+      MO_U_Rem rep -> remainder rep False x y++      MO_And rep   -> case y of+        (CmmLit (CmmInt imm _)) | imm == -8 || imm == -4+            -> do+                (src, srcCode) <- getSomeReg x+                let clear_mask = if imm == -4 then 2 else 3+                    fmt = intFormat rep+                    code dst = srcCode+                               `appOL` unitOL (CLRRI fmt dst src clear_mask)+                return (Any fmt code)+        _ -> trivialCode rep False AND x y+      MO_Or rep    -> trivialCode rep False OR x y+      MO_Xor rep   -> trivialCode rep False XOR x y++      MO_Shl rep   -> shiftMulCode rep False SL x y+      MO_S_Shr rep -> srCode rep True SRA x y+      MO_U_Shr rep -> srCode rep False SR x y+      _         -> panic "PPC.CodeGen.getRegister: no match"++  where+    triv_float :: Width -> (Format -> Reg -> Reg -> Reg -> Instr) -> NatM Register+    triv_float width instr = trivialCodeNoImm (floatFormat width) instr x y++    remainder :: Width -> Bool -> CmmExpr -> CmmExpr -> NatM Register+    remainder rep sgn x y = do+      let fmt = intFormat rep+      tmp <- getNewRegNat fmt+      code <- remainderCode rep sgn tmp x y+      return (Any fmt code)+++getRegister' _ (CmmLit (CmmInt i rep))+  | Just imm <- makeImmediate rep True i+  = let+        code dst = unitOL (LI dst imm)+    in+        return (Any (intFormat rep) code)++getRegister' _ (CmmLit (CmmFloat f frep)) = do+    lbl <- getNewLabelNat+    dflags <- getDynFlags+    dynRef <- cmmMakeDynamicReference dflags DataReference lbl+    Amode addr addr_code <- getAmode D dynRef+    let format = floatFormat frep+        code dst =+            LDATA (Section ReadOnlyData lbl)+                  (Statics lbl [CmmStaticLit (CmmFloat f frep)])+            `consOL` (addr_code `snocOL` LD format dst addr)+    return (Any format code)++getRegister' dflags (CmmLit lit)+  | target32Bit (targetPlatform dflags)+  = let rep = cmmLitType dflags lit+        imm = litToImm lit+        code dst = toOL [+              LIS dst (HA imm),+              ADD dst dst (RIImm (LO imm))+          ]+    in return (Any (cmmTypeFormat rep) code)+  | otherwise+  = do lbl <- getNewLabelNat+       dflags <- getDynFlags+       dynRef <- cmmMakeDynamicReference dflags DataReference lbl+       Amode addr addr_code <- getAmode D dynRef+       let rep = cmmLitType dflags lit+           format = cmmTypeFormat rep+           code dst =+            LDATA (Section ReadOnlyData lbl) (Statics lbl [CmmStaticLit lit])+            `consOL` (addr_code `snocOL` LD format dst addr)+       return (Any format code)++getRegister' _ other = pprPanic "getRegister(ppc)" (pprExpr other)++    -- extend?Rep: wrap integer expression of type `from`+    -- in a conversion to `to`+extendSExpr :: Width -> Width -> CmmExpr -> CmmExpr+extendSExpr from to x = CmmMachOp (MO_SS_Conv from to) [x]++extendUExpr :: Width -> Width -> CmmExpr -> CmmExpr+extendUExpr from to x = CmmMachOp (MO_UU_Conv from to) [x]++-- -----------------------------------------------------------------------------+--  The 'Amode' type: Memory addressing modes passed up the tree.++data Amode+        = Amode AddrMode InstrBlock++{-+Now, given a tree (the argument to a CmmLoad) that references memory,+produce a suitable addressing mode.++A Rule of the Game (tm) for Amodes: use of the addr bit must+immediately follow use of the code part, since the code part puts+values in registers which the addr then refers to.  So you can't put+anything in between, lest it overwrite some of those registers.  If+you need to do some other computation between the code part and use of+the addr bit, first store the effective address from the amode in a+temporary, then do the other computation, and then use the temporary:++    code+    LEA amode, tmp+    ... other computation ...+    ... (tmp) ...+-}++{- Note [Power instruction format]+In some instructions the 16 bit offset must be a multiple of 4, i.e.+the two least significant bits must be zero. The "Power ISA" specification+calls these instruction formats "DS-FORM" and the instructions with+arbitrary 16 bit offsets are "D-FORM".++The Power ISA specification document can be obtained from www.power.org.+-}+data InstrForm = D | DS++getAmode :: InstrForm -> CmmExpr -> NatM Amode+getAmode inf tree@(CmmRegOff _ _)+  = do dflags <- getDynFlags+       getAmode inf (mangleIndexTree dflags tree)++getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)])+  | Just off <- makeImmediate W32 True (-i)+  = do+        (reg, code) <- getSomeReg x+        return (Amode (AddrRegImm reg off) code)+++getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit (CmmInt i _)])+  | Just off <- makeImmediate W32 True i+  = do+        (reg, code) <- getSomeReg x+        return (Amode (AddrRegImm reg off) code)++getAmode D (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)])+  | Just off <- makeImmediate W64 True (-i)+  = do+        (reg, code) <- getSomeReg x+        return (Amode (AddrRegImm reg off) code)+++getAmode D (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)])+  | Just off <- makeImmediate W64 True i+  = do+        (reg, code) <- getSomeReg x+        return (Amode (AddrRegImm reg off) code)++getAmode DS (CmmMachOp (MO_Sub W64) [x, CmmLit (CmmInt i _)])+  | Just off <- makeImmediate W64 True (-i)+  = do+        (reg, code) <- getSomeReg x+        (reg', off', code')  <-+                     if i `mod` 4 == 0+                      then do return (reg, off, code)+                      else do+                           tmp <- getNewRegNat II64+                           return (tmp, ImmInt 0,+                                  code `snocOL` ADD tmp reg (RIImm off))+        return (Amode (AddrRegImm reg' off') code')++getAmode DS (CmmMachOp (MO_Add W64) [x, CmmLit (CmmInt i _)])+  | Just off <- makeImmediate W64 True i+  = do+        (reg, code) <- getSomeReg x+        (reg', off', code')  <-+                     if i `mod` 4 == 0+                      then do return (reg, off, code)+                      else do+                           tmp <- getNewRegNat II64+                           return (tmp, ImmInt 0,+                                  code `snocOL` ADD tmp reg (RIImm off))+        return (Amode (AddrRegImm reg' off') code')++   -- optimize addition with 32-bit immediate+   -- (needed for PIC)+getAmode _ (CmmMachOp (MO_Add W32) [x, CmmLit lit])+  = do+        dflags <- getDynFlags+        (src, srcCode) <- getSomeReg x+        let imm = litToImm lit+        case () of+            _ | OSAIX <- platformOS (targetPlatform dflags)+              , isCmmLabelType lit ->+                    -- HA16/LO16 relocations on labels not supported on AIX+                    return (Amode (AddrRegImm src imm) srcCode)+              | otherwise -> do+                    tmp <- getNewRegNat II32+                    let code = srcCode `snocOL` ADDIS tmp src (HA imm)+                    return (Amode (AddrRegImm tmp (LO imm)) code)+  where+      isCmmLabelType (CmmLabel {})        = True+      isCmmLabelType (CmmLabelOff {})     = True+      isCmmLabelType (CmmLabelDiffOff {}) = True+      isCmmLabelType _                    = False++getAmode _ (CmmLit lit)+  = do+        dflags <- getDynFlags+        case platformArch $ targetPlatform dflags of+             ArchPPC -> do+                 tmp <- getNewRegNat II32+                 let imm = litToImm lit+                     code = unitOL (LIS tmp (HA imm))+                 return (Amode (AddrRegImm tmp (LO imm)) code)+             _        -> do -- TODO: Load from TOC,+                            -- see getRegister' _ (CmmLit lit)+                 tmp <- getNewRegNat II64+                 let imm = litToImm lit+                     code =  toOL [+                          LIS tmp (HIGHESTA imm),+                          OR tmp tmp (RIImm (HIGHERA imm)),+                          SL  II64 tmp tmp (RIImm (ImmInt 32)),+                          ORIS tmp tmp (HA imm)+                          ]+                 return (Amode (AddrRegImm tmp (LO imm)) code)++getAmode _ (CmmMachOp (MO_Add W32) [x, y])+  = do+        (regX, codeX) <- getSomeReg x+        (regY, codeY) <- getSomeReg y+        return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))++getAmode _ (CmmMachOp (MO_Add W64) [x, y])+  = do+        (regX, codeX) <- getSomeReg x+        (regY, codeY) <- getSomeReg y+        return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY))++getAmode _ other+  = do+        (reg, code) <- getSomeReg other+        let+            off  = ImmInt 0+        return (Amode (AddrRegImm reg off) code)+++--  The 'CondCode' type:  Condition codes passed up the tree.+data CondCode+        = CondCode Bool Cond InstrBlock++-- Set up a condition code for a conditional branch.++getCondCode :: CmmExpr -> NatM CondCode++-- almost the same as everywhere else - but we need to+-- extend small integers to 32 bit or 64 bit first++getCondCode (CmmMachOp mop [x, y])+  = do+    case mop of+      MO_F_Eq W32 -> condFltCode EQQ x y+      MO_F_Ne W32 -> condFltCode NE  x y+      MO_F_Gt W32 -> condFltCode GTT x y+      MO_F_Ge W32 -> condFltCode GE  x y+      MO_F_Lt W32 -> condFltCode LTT x y+      MO_F_Le W32 -> condFltCode LE  x y++      MO_F_Eq W64 -> condFltCode EQQ x y+      MO_F_Ne W64 -> condFltCode NE  x y+      MO_F_Gt W64 -> condFltCode GTT x y+      MO_F_Ge W64 -> condFltCode GE  x y+      MO_F_Lt W64 -> condFltCode LTT x y+      MO_F_Le W64 -> condFltCode LE  x y++      MO_Eq rep -> condIntCode EQQ rep x y+      MO_Ne rep -> condIntCode NE  rep x y++      MO_S_Gt rep -> condIntCode GTT rep x y+      MO_S_Ge rep -> condIntCode GE  rep x y+      MO_S_Lt rep -> condIntCode LTT rep x y+      MO_S_Le rep -> condIntCode LE  rep x y++      MO_U_Gt rep -> condIntCode GU  rep x y+      MO_U_Ge rep -> condIntCode GEU rep x y+      MO_U_Lt rep -> condIntCode LU  rep x y+      MO_U_Le rep -> condIntCode LEU rep x y++      _ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop)++getCondCode _ = panic "getCondCode(2)(powerpc)"+++-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be+-- passed back up the tree.++condIntCode :: Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode+condIntCode cond width x y = do+  dflags <- getDynFlags+  condIntCode' (target32Bit (targetPlatform dflags)) cond width x y++condIntCode' :: Bool -> Cond -> Width -> CmmExpr -> CmmExpr -> NatM CondCode++-- simple code for 64-bit on 32-bit platforms+condIntCode' True cond W64 x y+  | condUnsigned cond+  = do+      ChildCode64 code_x x_lo <- iselExpr64 x+      ChildCode64 code_y y_lo <- iselExpr64 y+      let x_hi = getHiVRegFromLo x_lo+          y_hi = getHiVRegFromLo y_lo+      end_lbl <- getBlockIdNat+      let code = code_x `appOL` code_y `appOL` toOL+                 [ CMPL II32 x_hi (RIReg y_hi)+                 , BCC NE end_lbl Nothing+                 , CMPL II32 x_lo (RIReg y_lo)+                 , BCC ALWAYS end_lbl Nothing++                 , NEWBLOCK end_lbl+                 ]+      return (CondCode False cond code)+  | otherwise+  = do+      ChildCode64 code_x x_lo <- iselExpr64 x+      ChildCode64 code_y y_lo <- iselExpr64 y+      let x_hi = getHiVRegFromLo x_lo+          y_hi = getHiVRegFromLo y_lo+      end_lbl <- getBlockIdNat+      cmp_lo  <- getBlockIdNat+      let code = code_x `appOL` code_y `appOL` toOL+                 [ CMP II32 x_hi (RIReg y_hi)+                 , BCC NE end_lbl Nothing+                 , CMP II32 x_hi (RIImm (ImmInt 0))+                 , BCC LE cmp_lo Nothing+                 , CMPL II32 x_lo (RIReg y_lo)+                 , BCC ALWAYS end_lbl Nothing+                 , 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_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 similiar to LinuxPPC64/ELFv1+                       `appOL`  codeBefore+                       `snocOL` ST spFormat toc (AddrRegImm sp (ImmInt 20))+                       `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 0))+                       `snocOL` LD II32 toc (AddrRegImm dynReg (ImmInt 4))+                       `snocOL` MTCTR r11+                       `snocOL` LD II32 r11 (AddrRegImm dynReg (ImmInt 8))+                       `snocOL` BCTRL usedRegs+                       `snocOL` LD spFormat toc (AddrRegImm sp (ImmInt 20))+                       `appOL`  codeAfter)+                     _               -> return ( dynCode+                       `snocOL` MTCTR dynReg+                       `appOL`  codeBefore+                       `snocOL` BCTRL usedRegs+                       `appOL`  codeAfter)+    where+        platform = targetPlatform dflags++        uses_pic_base_implicitly = do+            -- See Note [implicit register in PPC PIC code]+            -- on why we claim to use PIC register here+            when (positionIndependent dflags && target32Bit platform) $ do+                _ <- getPicBaseNat $ archWordFormat True+                return ()++        initialStackOffset = case gcp of+                             GCPAIX     -> 24+                             GCP32ELF   -> 8+                             GCP64ELF 1 -> 48+                             GCP64ELF 2 -> 32+                             _ -> panic "genCall': unknown calling convention"+            -- size of linkage area + size of arguments, in bytes+        stackDelta finalStack = case gcp of+                                GCPAIX ->+                                    roundTo 16 $ (24 +) $ max 32 $ sum $+                                    map (widthInBytes . typeWidth) argReps+                                GCP32ELF -> roundTo 16 finalStack+                                GCP64ELF 1 ->+                                    roundTo 16 $ (48 +) $ max 64 $ sum $+                                    map (roundTo 8 . widthInBytes . typeWidth)+                                        argReps+                                GCP64ELF 2 ->+                                    roundTo 16 $ (32 +) $ max 64 $ sum $+                                    map (roundTo 8 . widthInBytes . typeWidth)+                                        argReps+                                _ -> panic "genCall': unknown calling conv."++        argReps = map (cmmExprType dflags) args+        (argHints, _) = foreignTargetHints target++        roundTo a x | x `mod` a == 0 = x+                    | otherwise = x + a - (x `mod` a)++        spFormat = if target32Bit platform then II32 else II64++        -- TODO: Do not create a new stack frame if delta is too large.+        move_sp_down finalStack+               | delta > stackFrameHeaderSize dflags =+                        toOL [STU spFormat sp (AddrRegImm sp (ImmInt (-delta))),+                              DELTA (-delta)]+               | otherwise = nilOL+               where delta = stackDelta finalStack+        move_sp_up finalStack+               | delta > stackFrameHeaderSize dflags =+                        toOL [ADD sp sp (RIImm (ImmInt delta)),+                              DELTA 0]+               | otherwise = nilOL+               where delta = stackDelta finalStack++        -- A NOP instruction is required after a call (bl instruction)+        -- on AIX and 64-Bit Linux.+        -- If the call is to a function with a different TOC (r2) the+        -- link editor replaces the NOP instruction with a load of the TOC+        -- from the stack to restore the TOC.+        maybeNOP = case gcp of+           GCP32ELF        -> nilOL+           -- See Section 3.9.4 of OpenPower ABI+           GCPAIX          -> unitOL NOP+           -- See Section 3.5.11 of PPC64 ELF v1.9+           GCP64ELF 1      -> unitOL NOP+           -- See Section 2.3.6 of PPC64 ELF v2+           GCP64ELF 2      -> unitOL NOP+           _               -> panic "maybeNOP: Unknown PowerPC 64-bit ABI"++        passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed)+        passArguments ((arg,arg_ty,_):args) gprs fprs stackOffset+               accumCode accumUsed | isWord64 arg_ty+                                     && target32Bit (targetPlatform dflags) =+            do+                ChildCode64 code vr_lo <- iselExpr64 arg+                let vr_hi = getHiVRegFromLo vr_lo++                case gcp of+                    GCPAIX ->+                        do let storeWord vr (gpr:_) _ = MR gpr vr+                               storeWord vr [] offset+                                   = ST II32 vr (AddrRegImm sp (ImmInt offset))+                           passArguments args+                                         (drop 2 gprs)+                                         fprs+                                         (stackOffset+8)+                                         (accumCode `appOL` code+                                               `snocOL` storeWord vr_hi gprs stackOffset+                                               `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4))+                                         ((take 2 gprs) ++ accumUsed)+                    GCP32ELF ->+                        do let stackOffset' = roundTo 8 stackOffset+                               stackCode = accumCode `appOL` code+                                   `snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset'))+                                   `snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4)))+                               regCode hireg loreg =+                                   accumCode `appOL` code+                                       `snocOL` MR hireg vr_hi+                                       `snocOL` MR loreg vr_lo++                           case gprs of+                               hireg : loreg : regs | even (length gprs) ->+                                   passArguments args regs fprs stackOffset+                                                 (regCode hireg loreg) (hireg : loreg : accumUsed)+                               _skipped : hireg : loreg : regs ->+                                   passArguments args regs fprs stackOffset+                                                 (regCode hireg loreg) (hireg : loreg : accumUsed)+                               _ -> -- only one or no regs left+                                   passArguments args [] fprs (stackOffset'+8)+                                                 stackCode accumUsed+                    GCP64ELF _ -> panic "passArguments: 32 bit code"++        passArguments ((arg,rep,hint):args) gprs fprs stackOffset accumCode accumUsed+            | reg : _ <- regs = do+                register <- getRegister arg_pro+                let code = case register of+                            Fixed _ freg fcode -> fcode `snocOL` MR reg freg+                            Any _ acode -> acode reg+                    stackOffsetRes = case gcp of+                                     -- The PowerOpen ABI requires that we+                                     -- reserve stack slots for register+                                     -- parameters+                                     GCPAIX    -> stackOffset + stackBytes+                                     -- ... the SysV ABI 32-bit doesn't.+                                     GCP32ELF -> stackOffset+                                     -- ... but SysV ABI 64-bit does.+                                     GCP64ELF _ -> stackOffset + stackBytes+                passArguments args+                              (drop nGprs gprs)+                              (drop nFprs fprs)+                              stackOffsetRes+                              (accumCode `appOL` code)+                              (reg : accumUsed)+            | otherwise = do+                (vr, code) <- getSomeReg arg_pro+                passArguments args+                              (drop nGprs gprs)+                              (drop nFprs fprs)+                              (stackOffset' + stackBytes)+                              (accumCode `appOL` code+                                         `snocOL` ST format_pro vr stackSlot)+                              accumUsed+            where+                arg_pro+                   | isBitsType rep = CmmMachOp (conv_op (typeWidth rep) (wordWidth dflags)) [arg]+                   | otherwise      = arg+                format_pro+                   | isBitsType rep = intFormat (wordWidth dflags)+                   | otherwise      = cmmTypeFormat rep+                conv_op = case hint of+                            SignedHint -> MO_SS_Conv+                            _          -> MO_UU_Conv++                stackOffset' = case gcp of+                               GCPAIX ->+                                   -- The 32bit PowerOPEN ABI is happy with+                                   -- 32bit-alignment ...+                                   stackOffset+                               GCP32ELF+                                   -- ... the SysV ABI requires 8-byte+                                   -- alignment for doubles.+                                | isFloatType rep && typeWidth rep == W64 ->+                                   roundTo 8 stackOffset+                                | otherwise ->+                                   stackOffset+                               GCP64ELF _ ->+                                   -- Everything on the stack is mapped to+                                   -- 8-byte aligned doublewords+                                   stackOffset+                stackOffset''+                     | isFloatType rep && typeWidth rep == W32 =+                         case gcp of+                         -- The ELF v1 ABI Section 3.2.3 requires:+                         -- "Single precision floating point values+                         -- are mapped to the second word in a single+                         -- doubleword"+                         GCP64ELF 1      -> stackOffset' + 4+                         _               -> stackOffset'+                     | otherwise = stackOffset'++                stackSlot = AddrRegImm sp (ImmInt stackOffset'')+                (nGprs, nFprs, stackBytes, regs)+                    = case gcp of+                      GCPAIX ->+                          case cmmTypeFormat rep of+                          II8  -> (1, 0, 4, gprs)+                          II16 -> (1, 0, 4, gprs)+                          II32 -> (1, 0, 4, gprs)+                          -- The PowerOpen ABI requires that we skip a+                          -- corresponding number of GPRs when we use+                          -- the FPRs.+                          --+                          -- E.g. for a `double` two GPRs are skipped,+                          -- whereas for a `float` one GPR is skipped+                          -- when parameters are assigned to+                          -- registers.+                          --+                          -- The PowerOpen ABI specification can be found at+                          -- ftp://www.sourceware.org/pub/binutils/ppc-docs/ppc-poweropen/+                          FF32 -> (1, 1, 4, fprs)+                          FF64 -> (2, 1, 8, fprs)+                          II64 -> panic "genCCall' passArguments II64"++                      GCP32ELF ->+                          case cmmTypeFormat rep of+                          II8  -> (1, 0, 4, gprs)+                          II16 -> (1, 0, 4, gprs)+                          II32 -> (1, 0, 4, gprs)+                          -- ... the SysV ABI doesn't.+                          FF32 -> (0, 1, 4, fprs)+                          FF64 -> (0, 1, 8, fprs)+                          II64 -> panic "genCCall' passArguments II64"+                      GCP64ELF _ ->+                          case cmmTypeFormat rep of+                          II8  -> (1, 0, 8, gprs)+                          II16 -> (1, 0, 8, gprs)+                          II32 -> (1, 0, 8, gprs)+                          II64 -> (1, 0, 8, gprs)+                          -- The ELFv1 ABI requires that we skip a+                          -- corresponding number of GPRs when we use+                          -- the FPRs.+                          FF32 -> (1, 1, 8, fprs)+                          FF64 -> (1, 1, 8, fprs)++        moveResult reduceToFF32 =+            case dest_regs of+                [] -> nilOL+                [dest]+                    | reduceToFF32 && isFloat32 rep   -> unitOL (FRSP r_dest f1)+                    | isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1)+                    | isWord64 rep && target32Bit (targetPlatform dflags)+                       -> toOL [MR (getHiVRegFromLo r_dest) r3,+                                MR r_dest r4]+                    | otherwise -> unitOL (MR r_dest r3)+                    where rep = cmmRegType dflags (CmmLocal dest)+                          r_dest = getRegisterReg platform (CmmLocal dest)+                _ -> panic "genCCall' moveResult: Bad dest_regs"++        outOfLineMachOp mop =+            do+                dflags <- getDynFlags+                mopExpr <- cmmMakeDynamicReference dflags CallReference $+                              mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction+                let mopLabelOrExpr = case mopExpr of+                        CmmLit (CmmLabel lbl) -> Left lbl+                        _ -> Right mopExpr+                return (mopLabelOrExpr, reduce)+            where+                (functionName, reduce) = case mop of+                    MO_F32_Exp   -> (fsLit "exp", True)+                    MO_F32_Log   -> (fsLit "log", 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_Log   -> (fsLit "log", False)+                    MO_F64_Sqrt  -> (fsLit "sqrt", False)+                    MO_F64_Fabs  -> unsupported++                    MO_F64_Sin   -> (fsLit "sin", False)+                    MO_F64_Cos   -> (fsLit "cos", False)+                    MO_F64_Tan   -> (fsLit "tan", False)++                    MO_F64_Asin  -> (fsLit "asin", False)+                    MO_F64_Acos  -> (fsLit "acos", False)+                    MO_F64_Atan  -> (fsLit "atan", False)++                    MO_F64_Sinh  -> (fsLit "sinh", False)+                    MO_F64_Cosh  -> (fsLit "cosh", False)+                    MO_F64_Tanh  -> (fsLit "tanh", False)+                    MO_F64_Pwr   -> (fsLit "pow", False)++                    MO_F64_Asinh -> (fsLit "asinh", False)+                    MO_F64_Acosh -> (fsLit "acosh", False)+                    MO_F64_Atanh -> (fsLit "atanh", False)++                    MO_UF_Conv w -> (fsLit $ word2FloatLabel w, False)++                    MO_Memcpy _  -> (fsLit "memcpy", False)+                    MO_Memset _  -> (fsLit "memset", False)+                    MO_Memmove _ -> (fsLit "memmove", False)+                    MO_Memcmp _  -> (fsLit "memcmp", False)++                    MO_BSwap w   -> (fsLit $ bSwapLabel w, False)+                    MO_BRev w    -> (fsLit $ bRevLabel w, False)+                    MO_PopCnt w  -> (fsLit $ popCntLabel w, False)+                    MO_Pdep w    -> (fsLit $ pdepLabel w, False)+                    MO_Pext w    -> (fsLit $ pextLabel w, False)+                    MO_Clz _     -> unsupported+                    MO_Ctz _     -> unsupported+                    MO_AtomicRMW {} -> unsupported+                    MO_Cmpxchg w -> (fsLit $ cmpxchgLabel w, False)+                    MO_AtomicRead _  -> unsupported+                    MO_AtomicWrite _ -> unsupported++                    MO_S_QuotRem {}  -> unsupported+                    MO_U_QuotRem {}  -> unsupported+                    MO_U_QuotRem2 {} -> unsupported+                    MO_Add2 {}       -> unsupported+                    MO_AddWordC {}   -> unsupported+                    MO_SubWordC {}   -> unsupported+                    MO_AddIntC {}    -> unsupported+                    MO_SubIntC {}    -> unsupported+                    MO_U_Mul2 {}     -> unsupported+                    MO_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 view
@@ -0,0 +1,63 @@+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 view
@@ -0,0 +1,712 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Machine-dependent assembly language+--+-- (c) The University of Glasgow 1993-2004+--+-----------------------------------------------------------------------------++#include "HsVersions.h"+#include "nativeGen/NCG.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 CodeGen.Platform+import BlockId+import Hoopl.Collections+import Hoopl.Label+import DynFlags+import Cmm+import CmmInfo+import FastString+import CLabel+import Outputable+import 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 ((platformWordSize platform) `quot` 8)+    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 view
@@ -0,0 +1,994 @@+-----------------------------------------------------------------------------+--+-- Pretty-printing assembly language+--+-- (c) The University of Glasgow 1993-2005+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-orphans #-}+module PPC.Ppr (pprNatCmmDecl) where++import GhcPrelude++import PPC.Regs+import PPC.Instr+import PPC.Cond+import PprBase+import Instruction+import Format+import Reg+import RegClass+import TargetReg++import Cmm hiding (topInfoTable)+import Hoopl.Collections+import Hoopl.Label++import BlockId+import CLabel+import PprCmmExpr ()++import Unique                ( pprUniqueAlways, getUnique )+import Platform+import FastString+import Outputable+import DynFlags++import Data.Word+import Data.Int+import Data.Bits++-- -----------------------------------------------------------------------------+-- Printing this stuff out++pprNatCmmDecl :: NatCmmDecl CmmStatics Instr -> SDoc+pprNatCmmDecl (CmmData section dats) =+  pprSectionAlign section $$ pprDatas dats++pprNatCmmDecl proc@(CmmProc top_info lbl _ (ListGraph blocks)) =+  case topInfoTable proc of+    Nothing ->+       sdocWithPlatform $ \platform ->+         -- special case for code without info table:+         pprSectionAlign (Section Text lbl) $$+         (case platformArch platform of+            ArchPPC_64 ELF_V1 -> pprFunctionDescriptor lbl+            ArchPPC_64 ELF_V2 -> pprFunctionPrologue lbl+            _ -> pprLabel lbl) $$ -- blocks guaranteed not null,+                                     -- so label needed+         vcat (map (pprBasicBlock top_info) blocks)++    Just (Statics info_lbl _) ->+      sdocWithPlatform $ \platform ->+      pprSectionAlign (Section Text info_lbl) $$+      (if platformHasSubsectionsViaSymbols platform+          then ppr (mkDeadStripPreventer info_lbl) <> char ':'+          else empty) $$+      vcat (map (pprBasicBlock top_info) blocks) $$+      -- above: Even the first block gets a label, because with branch-chain+      -- elimination, it might be the target of a goto.+      (if platformHasSubsectionsViaSymbols platform+       then+       -- See Note [Subsections Via Symbols] in X86/Ppr.hs+                text "\t.long "+            <+> ppr info_lbl+            <+> char '-'+            <+> ppr (mkDeadStripPreventer info_lbl)+       else empty)++pprFunctionDescriptor :: CLabel -> SDoc+pprFunctionDescriptor lab = pprGloblDecl lab+                        $$  text "\t.section \".opd\", \"aw\""+                        $$  text "\t.align 3"+                        $$  ppr lab <> char ':'+                        $$  text "\t.quad ."+                        <>  ppr lab+                        <>  text ",.TOC.@tocbase,0"+                        $$  text "\t.previous"+                        $$  text "\t.type"+                        <+> ppr lab+                        <>  text ", @function"+                        $$  char '.' <> ppr lab <> char ':'++pprFunctionPrologue :: CLabel ->SDoc+pprFunctionPrologue lab =  pprGloblDecl lab+                        $$  text ".type "+                        <> ppr lab+                        <> text ", @function"+                        $$ ppr lab <> char ':'+                        $$ text "0:\taddis\t" <> pprReg toc+                        <> text ",12,.TOC.-0b@ha"+                        $$ text "\taddi\t" <> pprReg toc+                        <> char ',' <> pprReg toc <> text ",.TOC.-0b@l"+                        $$ text "\t.localentry\t" <> ppr lab+                        <> text ",.-" <> ppr lab++pprBasicBlock :: LabelMap CmmStatics -> NatBasicBlock Instr -> SDoc+pprBasicBlock info_env (BasicBlock blockid instrs)+  = maybe_infotable $$+    pprLabel (blockLbl blockid) $$+    vcat (map pprInstr instrs)+  where+    maybe_infotable = case mapLookup blockid info_env of+       Nothing   -> empty+       Just (Statics info_lbl info) ->+           pprAlignForSection Text $$+           vcat (map pprData info) $$+           pprLabel info_lbl++++pprDatas :: CmmStatics -> SDoc+-- See note [emit-time elimination of static indirections] in CLabel.+pprDatas (Statics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+  | lbl == mkIndStaticInfoLabel+  , let labelInd (CmmLabelOff l _) = Just l+        labelInd (CmmLabel l) = Just l+        labelInd _ = Nothing+  , Just ind' <- labelInd ind+  , alias `mayRedirectTo` ind'+  = pprGloblDecl alias+    $$ text ".equiv" <+> ppr alias <> comma <> ppr (CmmLabel ind')+pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats)++pprData :: CmmStatic -> SDoc+pprData (CmmString str)          = pprBytes str+pprData (CmmUninitialised bytes) = text ".space " <> int bytes+pprData (CmmStaticLit lit)       = pprDataItem lit++pprGloblDecl :: CLabel -> SDoc+pprGloblDecl lbl+  | not (externallyVisibleCLabel lbl) = empty+  | otherwise = text ".globl " <> ppr lbl++pprTypeAndSizeDecl :: CLabel -> SDoc+pprTypeAndSizeDecl lbl+  = sdocWithPlatform $ \platform ->+    if platformOS platform == OSLinux && externallyVisibleCLabel lbl+    then text ".type " <>+         ppr lbl <> text ", @object"+    else empty++pprLabel :: CLabel -> SDoc+pprLabel lbl = pprGloblDecl lbl+            $$ pprTypeAndSizeDecl lbl+            $$ (ppr lbl <> char ':')++-- -----------------------------------------------------------------------------+-- pprInstr: print an 'Instr'++instance Outputable Instr where+    ppr instr = pprInstr instr+++pprReg :: Reg -> SDoc++pprReg r+  = case r of+      RegReal    (RealRegSingle i) -> ppr_reg_no i+      RegReal    (RealRegPair{})   -> panic "PPC.pprReg: no reg pairs on this arch"+      RegVirtual (VirtualRegI  u)  -> text "%vI_"   <> pprUniqueAlways u+      RegVirtual (VirtualRegHi u)  -> text "%vHi_"  <> pprUniqueAlways u+      RegVirtual (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u+      RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u++  where+    ppr_reg_no :: Int -> SDoc+    ppr_reg_no i+         | i <= 31   = int i      -- GPRs+         | i <= 63   = int (i-32) -- FPRs+         | otherwise = text "very naughty powerpc register"++++pprFormat :: Format -> SDoc+pprFormat x+ = ptext (case x of+                II8  -> sLit "b"+                II16 -> sLit "h"+                II32 -> sLit "w"+                II64 -> sLit "d"+                FF32 -> sLit "fs"+                FF64 -> sLit "fd")+++pprCond :: Cond -> SDoc+pprCond c+ = ptext (case c of {+                ALWAYS  -> sLit "";+                EQQ     -> sLit "eq";  NE    -> sLit "ne";+                LTT     -> sLit "lt";  GE    -> sLit "ge";+                GTT     -> sLit "gt";  LE    -> sLit "le";+                LU      -> sLit "lt";  GEU   -> sLit "ge";+                GU      -> sLit "gt";  LEU   -> sLit "le"; })+++pprImm :: Imm -> SDoc++pprImm (ImmInt i)     = int i+pprImm (ImmInteger i) = integer i+pprImm (ImmCLbl l)    = ppr l+pprImm (ImmIndex l i) = ppr l <> char '+' <> int i+pprImm (ImmLit s)     = s++pprImm (ImmFloat _)  = text "naughty float immediate"+pprImm (ImmDouble _) = text "naughty double immediate"++pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b+pprImm (ImmConstantDiff a b) = pprImm a <> char '-'+                   <> lparen <> pprImm b <> rparen++pprImm (LO (ImmInt i))     = pprImm (LO (ImmInteger (toInteger i)))+pprImm (LO (ImmInteger i)) = pprImm (ImmInteger (toInteger lo16))+  where+    lo16 = fromInteger (i .&. 0xffff) :: Int16++pprImm (LO i)+  = pprImm i <> text "@l"++pprImm (HI i)+  = pprImm i <> text "@h"++pprImm (HA (ImmInt i))     = pprImm (HA (ImmInteger (toInteger i)))+pprImm (HA (ImmInteger i)) = pprImm (ImmInteger ha16)+  where+    ha16 = if lo16 >= 0x8000 then hi16+1 else hi16+    hi16 = (i `shiftR` 16)+    lo16 = i .&. 0xffff++pprImm (HA i)+  = pprImm i <> text "@ha"++pprImm (HIGHERA i)+  = pprImm i <> text "@highera"++pprImm (HIGHESTA i)+  = pprImm i <> text "@highesta"+++pprAddr :: AddrMode -> SDoc+pprAddr (AddrRegReg r1 r2)+  = pprReg r1 <> char ',' <+> pprReg r2+pprAddr (AddrRegImm r1 (ImmInt i))+  = hcat [ int i, char '(', pprReg r1, char ')' ]+pprAddr (AddrRegImm r1 (ImmInteger i))+  = hcat [ integer i, char '(', pprReg r1, char ')' ]+pprAddr (AddrRegImm r1 imm)+  = hcat [ pprImm imm, char '(', pprReg r1, char ')' ]+++pprSectionAlign :: Section -> SDoc+pprSectionAlign sec@(Section seg _) =+ sdocWithPlatform $ \platform ->+   pprSectionHeader platform sec $$+   pprAlignForSection seg++-- | Print appropriate alignment for the given section type.+pprAlignForSection :: SectionType -> SDoc+pprAlignForSection seg =+ sdocWithPlatform $ \platform ->+ let ppc64    = not $ target32Bit platform+ in ptext $ case seg of+       Text              -> sLit ".align 2"+       Data+        | ppc64          -> sLit ".align 3"+        | otherwise      -> sLit ".align 2"+       ReadOnlyData+        | ppc64          -> sLit ".align 3"+        | otherwise      -> sLit ".align 2"+       RelocatableReadOnlyData+        | ppc64          -> sLit ".align 3"+        | otherwise      -> sLit ".align 2"+       UninitialisedData+        | ppc64          -> sLit ".align 3"+        | otherwise      -> sLit ".align 2"+       ReadOnlyData16    -> sLit ".align 4"+       -- TODO: This is copied from the ReadOnlyData case, but it can likely be+       -- made more efficient.+       CString+        | ppc64          -> sLit ".align 3"+        | otherwise      -> sLit ".align 2"+       OtherSection _    -> panic "PprMach.pprSectionAlign: unknown section"++pprDataItem :: CmmLit -> SDoc+pprDataItem lit+  = sdocWithDynFlags $ \dflags ->+    vcat (ppr_item (cmmTypeFormat $ cmmLitType dflags lit) lit dflags)+    where+        imm = litToImm lit+        archPPC_64 dflags = not $ target32Bit $ targetPlatform dflags++        ppr_item II8   _ _ = [text "\t.byte\t" <> pprImm imm]++        ppr_item II32  _ _ = [text "\t.long\t" <> pprImm imm]++        ppr_item II64 _ dflags+           | archPPC_64 dflags = [text "\t.quad\t" <> pprImm imm]+++        ppr_item FF32 (CmmFloat r _) _+           = let bs = floatToBytes (fromRational r)+             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs++        ppr_item FF64 (CmmFloat r _) _+           = let bs = doubleToBytes (fromRational r)+             in  map (\b -> text "\t.byte\t" <> pprImm (ImmInt b)) bs++        ppr_item II16 _ _      = [text "\t.short\t" <> pprImm imm]++        ppr_item II64 (CmmInt x _) dflags+           | not(archPPC_64 dflags) =+                [text "\t.long\t"+                    <> int (fromIntegral+                        (fromIntegral (x `shiftR` 32) :: Word32)),+                 text "\t.long\t"+                    <> int (fromIntegral (fromIntegral x :: Word32))]++        ppr_item _ _ _+                = panic "PPC.Ppr.pprDataItem: no match"+++pprInstr :: Instr -> SDoc++pprInstr (COMMENT _) = empty -- nuke 'em+{-+pprInstr (COMMENT s) =+     if platformOS platform == OSLinux+     then text "# " <> ftext s+     else text "; " <> ftext s+-}+pprInstr (DELTA d)+   = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d)))++pprInstr (NEWBLOCK _)+   = panic "PprMach.pprInstr: NEWBLOCK"++pprInstr (LDATA _ _)+   = panic "PprMach.pprInstr: LDATA"++{-+pprInstr (SPILL reg slot)+   = hcat [+           text "\tSPILL",+        char '\t',+        pprReg reg,+        comma,+        text "SLOT" <> parens (int slot)]++pprInstr (RELOAD slot reg)+   = hcat [+           text "\tRELOAD",+        char '\t',+        text "SLOT" <> parens (int slot),+        comma,+        pprReg reg]+-}++pprInstr (LD fmt reg addr) = hcat [+        char '\t',+        text "l",+        ptext (case fmt of+            II8  -> sLit "bz"+            II16 -> sLit "hz"+            II32 -> sLit "wz"+            II64 -> sLit "d"+            FF32 -> sLit "fs"+            FF64 -> sLit "fd"+            ),+        case addr of AddrRegImm _ _ -> empty+                     AddrRegReg _ _ -> char 'x',+        char '\t',+        pprReg reg,+        text ", ",+        pprAddr addr+    ]++pprInstr (LDFAR fmt reg (AddrRegImm source off)) =+   sdocWithPlatform $ \platform -> vcat [+         pprInstr (ADDIS (tmpReg platform) source (HA off)),+         pprInstr (LD fmt reg (AddrRegImm (tmpReg platform) (LO off)))+    ]+pprInstr (LDFAR _ _ _) =+   panic "PPC.Ppr.pprInstr LDFAR: no match"++pprInstr (LDR fmt reg1 addr) = hcat [+  text "\tl",+  case fmt of+    II32 -> char 'w'+    II64 -> char 'd'+    _    -> panic "PPC.Ppr.Instr LDR: no match",+  text "arx\t",+  pprReg reg1,+  text ", ",+  pprAddr addr+  ]++pprInstr (LA fmt reg addr) = hcat [+        char '\t',+        text "l",+        ptext (case fmt of+            II8  -> sLit "ba"+            II16 -> sLit "ha"+            II32 -> sLit "wa"+            II64 -> sLit "d"+            FF32 -> sLit "fs"+            FF64 -> sLit "fd"+            ),+        case addr of AddrRegImm _ _ -> empty+                     AddrRegReg _ _ -> char 'x',+        char '\t',+        pprReg reg,+        text ", ",+        pprAddr addr+    ]+pprInstr (ST fmt reg addr) = hcat [+        char '\t',+        text "st",+        pprFormat fmt,+        case addr of AddrRegImm _ _ -> empty+                     AddrRegReg _ _ -> char 'x',+        char '\t',+        pprReg reg,+        text ", ",+        pprAddr addr+    ]+pprInstr (STFAR fmt reg (AddrRegImm source off)) =+   sdocWithPlatform $ \platform -> vcat [+         pprInstr (ADDIS (tmpReg platform) source (HA off)),+         pprInstr (ST fmt reg (AddrRegImm (tmpReg platform) (LO off)))+    ]+pprInstr (STFAR _ _ _) =+   panic "PPC.Ppr.pprInstr STFAR: no match"+pprInstr (STU fmt reg addr) = hcat [+        char '\t',+        text "st",+        pprFormat fmt,+        char 'u',+        case addr of AddrRegImm _ _ -> empty+                     AddrRegReg _ _ -> char 'x',+        char '\t',+        pprReg reg,+        text ", ",+        pprAddr addr+    ]+pprInstr (STC fmt reg1 addr) = hcat [+  text "\tst",+  case fmt of+    II32 -> char 'w'+    II64 -> char 'd'+    _    -> panic "PPC.Ppr.Instr STC: no match",+  text "cx.\t",+  pprReg reg1,+  text ", ",+  pprAddr addr+  ]+pprInstr (LIS reg imm) = hcat [+        char '\t',+        text "lis",+        char '\t',+        pprReg reg,+        text ", ",+        pprImm imm+    ]+pprInstr (LI reg imm) = hcat [+        char '\t',+        text "li",+        char '\t',+        pprReg reg,+        text ", ",+        pprImm imm+    ]+pprInstr (MR reg1 reg2)+    | reg1 == reg2 = empty+    | otherwise = hcat [+        char '\t',+        sdocWithPlatform $ \platform ->+        case targetClassOfReg platform reg1 of+            RcInteger -> text "mr"+            _ -> text "fmr",+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2+    ]+pprInstr (CMP fmt reg ri) = hcat [+        char '\t',+        op,+        char '\t',+        pprReg reg,+        text ", ",+        pprRI ri+    ]+    where+        op = hcat [+                text "cmp",+                pprFormat fmt,+                case ri of+                    RIReg _ -> empty+                    RIImm _ -> char 'i'+            ]+pprInstr (CMPL fmt reg ri) = hcat [+        char '\t',+        op,+        char '\t',+        pprReg reg,+        text ", ",+        pprRI ri+    ]+    where+        op = hcat [+                text "cmpl",+                pprFormat fmt,+                case ri of+                    RIReg _ -> empty+                    RIImm _ -> char 'i'+            ]+pprInstr (BCC cond blockid prediction) = hcat [+        char '\t',+        text "b",+        pprCond cond,+        pprPrediction prediction,+        char '\t',+        ppr lbl+    ]+    where lbl = mkLocalBlockLabel (getUnique blockid)+          pprPrediction p = case p of+            Nothing    -> empty+            Just True  -> char '+'+            Just False -> char '-'++pprInstr (BCCFAR cond blockid prediction) = vcat [+        hcat [+            text "\tb",+            pprCond (condNegate cond),+            neg_prediction,+            text "\t$+8"+        ],+        hcat [+            text "\tb\t",+            ppr lbl+        ]+    ]+    where lbl = mkLocalBlockLabel (getUnique blockid)+          neg_prediction = case prediction of+            Nothing    -> empty+            Just True  -> char '-'+            Just False -> char '+'++pprInstr (JMP lbl _)+  -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL"+  | isForeignLabel lbl = panic "PPC.Ppr.pprInstr: JMP to ForeignLabel"+  | otherwise =+    hcat [ -- an alias for b that takes a CLabel+        char '\t',+        text "b",+        char '\t',+        ppr lbl+    ]++pprInstr (MTCTR reg) = hcat [+        char '\t',+        text "mtctr",+        char '\t',+        pprReg reg+    ]+pprInstr (BCTR _ _ _) = hcat [+        char '\t',+        text "bctr"+    ]+pprInstr (BL lbl _) = do+    sdocWithPlatform $ \platform -> case platformOS platform of+        OSAIX ->+          -- On AIX, "printf" denotes a function-descriptor (for use+          -- by function pointers), whereas the actual entry-code+          -- address is denoted by the dot-prefixed ".printf" label.+          -- Moreover, the PPC NCG only ever emits a BL instruction+          -- for calling C ABI functions. Most of the time these calls+          -- originate from FFI imports and have a 'ForeignLabel',+          -- but when profiling the codegen inserts calls via+          -- 'emitRtsCallGen' which are 'CmmLabel's even though+          -- they'd technically be more like 'ForeignLabel's.+          hcat [+            text "\tbl\t.",+            ppr lbl+          ]+        _ ->+          hcat [+            text "\tbl\t",+            ppr lbl+          ]+pprInstr (BCTRL _) = hcat [+        char '\t',+        text "bctrl"+    ]+pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri+pprInstr (ADDIS reg1 reg2 imm) = hcat [+        char '\t',+        text "addis",+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprImm imm+    ]++pprInstr (ADDO reg1 reg2 reg3) = pprLogic (sLit "addo") reg1 reg2 (RIReg reg3)+pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3)+pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3)+pprInstr (ADDZE reg1 reg2) = pprUnary (sLit "addze") reg1 reg2+pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3)+pprInstr (SUBFO reg1 reg2 reg3) = pprLogic (sLit "subfo") reg1 reg2 (RIReg reg3)+pprInstr (SUBFC reg1 reg2 ri) = hcat [+        char '\t',+        text "subf",+        case ri of+            RIReg _ -> empty+            RIImm _ -> char 'i',+        text "c\t",+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprRI ri+    ]+pprInstr (SUBFE reg1 reg2 reg3) = pprLogic (sLit "subfe") reg1 reg2 (RIReg reg3)+pprInstr (MULL fmt reg1 reg2 ri) = pprMul fmt reg1 reg2 ri+pprInstr (MULLO fmt reg1 reg2 reg3) = hcat [+        char '\t',+        text "mull",+        case fmt of+          II32 -> char 'w'+          II64 -> char 'd'+          _    -> panic "PPC: illegal format",+        text "o\t",+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprReg reg3+    ]+pprInstr (MFOV fmt reg) = vcat [+        hcat [+            char '\t',+            text "mfxer",+            char '\t',+            pprReg reg+            ],+        hcat [+            char '\t',+            text "extr",+            case fmt of+              II32 -> char 'w'+              II64 -> char 'd'+              _    -> panic "PPC: illegal format",+            text "i\t",+            pprReg reg,+            text ", ",+            pprReg reg,+            text ", 1, ",+            case fmt of+              II32 -> text "1"+              II64 -> text "33"+              _    -> panic "PPC: illegal format"+            ]+        ]++pprInstr (MULHU fmt reg1 reg2 reg3) = hcat [+        char '\t',+        text "mulh",+        case fmt of+          II32 -> char 'w'+          II64 -> char 'd'+          _    -> panic "PPC: illegal format",+        text "u\t",+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprReg reg3+    ]++pprInstr (DIV fmt sgn reg1 reg2 reg3) = pprDiv fmt sgn reg1 reg2 reg3++        -- for some reason, "andi" doesn't exist.+        -- we'll use "andi." instead.+pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [+        char '\t',+        text "andi.",+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprImm imm+    ]+pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri+pprInstr (ANDC reg1 reg2 reg3) = pprLogic (sLit "andc") reg1 reg2 (RIReg reg3)+pprInstr (NAND reg1 reg2 reg3) = pprLogic (sLit "nand") reg1 reg2 (RIReg reg3)++pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri+pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri++pprInstr (ORIS reg1 reg2 imm) = hcat [+        char '\t',+        text "oris",+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprImm imm+    ]++pprInstr (XORIS reg1 reg2 imm) = hcat [+        char '\t',+        text "xoris",+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprImm imm+    ]++pprInstr (EXTS fmt reg1 reg2) = hcat [+        char '\t',+        text "exts",+        pprFormat fmt,+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2+    ]+pprInstr (CNTLZ fmt reg1 reg2) = hcat [+        char '\t',+        text "cntlz",+        case fmt of+          II32 -> char 'w'+          II64 -> char 'd'+          _    -> panic "PPC: illegal format",+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2+    ]++pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2+pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2++pprInstr (SR II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0  || i > 31 =+    -- Handle the case where we are asked to shift a 32 bit register by+    -- less than zero or more than 31 bits. We convert this into a clear+    -- of the destination register.+    -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/5900+    pprInstr (XOR reg1 reg2 (RIReg reg2))++pprInstr (SL II32 reg1 reg2 (RIImm (ImmInt i))) | i < 0  || i > 31 =+    -- As above for SR, but for left shifts.+    -- Fixes ticket https://gitlab.haskell.org/ghc/ghc/issues/10870+    pprInstr (XOR reg1 reg2 (RIReg reg2))++pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt i))) | i > 31 =+    -- PT: I don't know what to do for negative shift amounts:+    -- For now just panic.+    --+    -- For shift amounts greater than 31 set all bit to the+    -- value of the sign bit, this also what sraw does.+    pprInstr (SRA II32 reg1 reg2 (RIImm (ImmInt 31)))++pprInstr (SL fmt reg1 reg2 ri) =+         let op = case fmt of+                       II32 -> "slw"+                       II64 -> "sld"+                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"+         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)++pprInstr (SR fmt reg1 reg2 ri) =+         let op = case fmt of+                       II32 -> "srw"+                       II64 -> "srd"+                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"+         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)++pprInstr (SRA fmt reg1 reg2 ri) =+         let op = case fmt of+                       II32 -> "sraw"+                       II64 -> "srad"+                       _    -> panic "PPC.Ppr.pprInstr: shift illegal size"+         in pprLogic (sLit op) reg1 reg2 (limitShiftRI fmt ri)++pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [+        text "\trlwinm\t",+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        int sh,+        text ", ",+        int mb,+        text ", ",+        int me+    ]++pprInstr (CLRLI fmt reg1 reg2 n) = hcat [+        text "\tclrl",+        pprFormat fmt,+        text "i ",+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        int n+    ]+pprInstr (CLRRI fmt reg1 reg2 n) = hcat [+        text "\tclrr",+        pprFormat fmt,+        text "i ",+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        int n+    ]++pprInstr (FADD fmt reg1 reg2 reg3) = pprBinaryF (sLit "fadd") fmt reg1 reg2 reg3+pprInstr (FSUB fmt reg1 reg2 reg3) = pprBinaryF (sLit "fsub") fmt reg1 reg2 reg3+pprInstr (FMUL fmt reg1 reg2 reg3) = pprBinaryF (sLit "fmul") fmt reg1 reg2 reg3+pprInstr (FDIV fmt reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") fmt reg1 reg2 reg3+pprInstr (FABS reg1 reg2) = pprUnary (sLit "fabs") reg1 reg2+pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2++pprInstr (FCMP reg1 reg2) = hcat [+        char '\t',+        text "fcmpu\t0, ",+            -- Note: we're using fcmpu, not fcmpo+            -- The difference is with fcmpo, compare with NaN is an invalid operation.+            -- We don't handle invalid fp ops, so we don't care.+            -- Morever, we use `fcmpu 0, ...` rather than `fcmpu cr0, ...` for+            -- better portability since some non-GNU assembler (such as+            -- IBM's `as`) tend not to support the symbolic register name cr0.+            -- This matches the syntax that GCC seems to emit for PPC targets.+        pprReg reg1,+        text ", ",+        pprReg reg2+    ]++pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2+pprInstr (FCTIDZ reg1 reg2) = pprUnary (sLit "fctidz") reg1 reg2+pprInstr (FCFID reg1 reg2) = pprUnary (sLit "fcfid") reg1 reg2+pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2++pprInstr (CRNOR dst src1 src2) = hcat [+        text "\tcrnor\t",+        int dst,+        text ", ",+        int src1,+        text ", ",+        int src2+    ]++pprInstr (MFCR reg) = hcat [+        char '\t',+        text "mfcr",+        char '\t',+        pprReg reg+    ]++pprInstr (MFLR reg) = hcat [+        char '\t',+        text "mflr",+        char '\t',+        pprReg reg+    ]++pprInstr (FETCHPC reg) = vcat [+        text "\tbcl\t20,31,1f",+        hcat [ text "1:\tmflr\t", pprReg reg ]+    ]++pprInstr HWSYNC = text "\tsync"++pprInstr ISYNC  = text "\tisync"++pprInstr LWSYNC = text "\tlwsync"++pprInstr NOP = text "\tnop"+++pprLogic :: PtrString -> Reg -> Reg -> RI -> SDoc+pprLogic op reg1 reg2 ri = hcat [+        char '\t',+        ptext op,+        case ri of+            RIReg _ -> empty+            RIImm _ -> char 'i',+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprRI ri+    ]+++pprMul :: Format -> Reg -> Reg -> RI -> SDoc+pprMul fmt reg1 reg2 ri = hcat [+        char '\t',+        text "mull",+        case ri of+            RIReg _ -> case fmt of+              II32 -> char 'w'+              II64 -> char 'd'+              _    -> panic "PPC: illegal format"+            RIImm _ -> char 'i',+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprRI ri+    ]+++pprDiv :: Format -> Bool -> Reg -> Reg -> Reg -> SDoc+pprDiv fmt sgn reg1 reg2 reg3 = hcat [+        char '\t',+        text "div",+        case fmt of+          II32 -> char 'w'+          II64 -> char 'd'+          _    -> panic "PPC: illegal format",+        if sgn then empty else char 'u',+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprReg reg3+    ]+++pprUnary :: PtrString -> Reg -> Reg -> SDoc+pprUnary op reg1 reg2 = hcat [+        char '\t',+        ptext op,+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2+    ]+++pprBinaryF :: PtrString -> Format -> Reg -> Reg -> Reg -> SDoc+pprBinaryF op fmt reg1 reg2 reg3 = hcat [+        char '\t',+        ptext op,+        pprFFormat fmt,+        char '\t',+        pprReg reg1,+        text ", ",+        pprReg reg2,+        text ", ",+        pprReg reg3+    ]++pprRI :: RI -> SDoc+pprRI (RIReg r) = pprReg r+pprRI (RIImm r) = pprImm r+++pprFFormat :: Format -> SDoc+pprFFormat FF64     = empty+pprFFormat FF32     = char 's'+pprFFormat _        = panic "PPC.Ppr.pprFFormat: no match"++    -- limit immediate argument for shift instruction to range 0..63+    -- for 64 bit size and 0..32 otherwise+limitShiftRI :: Format -> RI -> RI+limitShiftRI II64 (RIImm (ImmInt i)) | i > 63 || i < 0 =+  panic $ "PPC.Ppr: Shift by " ++ show i ++ " bits is not allowed."+limitShiftRI II32 (RIImm (ImmInt i)) | i > 31 || i < 0 =+  panic $ "PPC.Ppr: 32 bit: Shift by " ++ show i ++ " bits is not allowed."+limitShiftRI _ x = x
+ compiler/nativeGen/PPC/RegInfo.hs view
@@ -0,0 +1,81 @@+{-# 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 "nativeGen/NCG.h"+#include "HsVersions.h"++import GhcPrelude++import PPC.Instr++import BlockId+import Cmm+import CLabel++import Unique+import Outputable (ppr, text, Outputable, (<>))++data JumpDest = DestBlockId BlockId++-- Debug Instance+instance Outputable JumpDest where+  ppr (DestBlockId bid) = text "jd<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 view
@@ -0,0 +1,334 @@+{-# 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 "nativeGen/NCG.h"+#include "HsVersions.h"++import GhcPrelude++import Reg+import RegClass+import Format++import Cmm+import CLabel           ( CLabel )+import Unique++import CodeGen.Platform+import DynFlags+import Outputable+import 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 view
@@ -0,0 +1,275 @@+{-# LANGUAGE MagicHash #-}++-----------------------------------------------------------------------------+--+-- Pretty-printing assembly language+--+-- (c) The University of Glasgow 1993-2005+--+-----------------------------------------------------------------------------++module PprBase (+        castFloatToWord8Array,+        castDoubleToWord8Array,+        floatToBytes,+        doubleToBytes,+        pprASCII,+        pprBytes,+        pprSectionHeader+)++where++import GhcPrelude++import AsmUtils+import CLabel+import Cmm+import DynFlags+import FastString+import Outputable+import 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/Reg.hs view
@@ -0,0 +1,241 @@+-- | An architecture independent description of a register.+--      This needs to stay architecture independent because it is used+--      by NCGMonad and the register allocators, which are shared+--      by all architectures.+--+module Reg (+        RegNo,+        Reg(..),+        regPair,+        regSingle,+        isRealReg,      takeRealReg,+        isVirtualReg,   takeVirtualReg,++        VirtualReg(..),+        renameVirtualReg,+        classOfVirtualReg,+        getHiVirtualRegFromLo,+        getHiVRegFromLo,++        RealReg(..),+        regNosOfRealReg,+        realRegsAlias,++        liftPatchFnToRegReg+)++where++import GhcPrelude++import Outputable+import Unique+import RegClass+import Data.List++-- | An identifier for a primitive real machine register.+type RegNo+        = Int++-- VirtualRegs are virtual registers.  The register allocator will+--      eventually have to map them into RealRegs, or into spill slots.+--+--      VirtualRegs are allocated on the fly, usually to represent a single+--      value in the abstract assembly code (i.e. dynamic registers are+--      usually single assignment).+--+--      The  single assignment restriction isn't necessary to get correct code,+--      although a better register allocation will result if single+--      assignment is used -- because the allocator maps a VirtualReg into+--      a single RealReg, even if the VirtualReg has multiple live ranges.+--+--      Virtual regs can be of either class, so that info is attached.+--+data VirtualReg+        = VirtualRegI  {-# UNPACK #-} !Unique+        | VirtualRegHi {-# UNPACK #-} !Unique  -- High part of 2-word register+        | VirtualRegF  {-# UNPACK #-} !Unique+        | VirtualRegD  {-# UNPACK #-} !Unique++        deriving (Eq, Show)++-- This is laborious, but necessary. We can't derive Ord because+-- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the+-- implementation. See Note [No Ord for Unique]+-- This is non-deterministic but we do not currently support deterministic+-- code-generation. See Note [Unique Determinism and code generation]+instance Ord VirtualReg where+  compare (VirtualRegI a) (VirtualRegI b) = nonDetCmpUnique a b+  compare (VirtualRegHi a) (VirtualRegHi b) = nonDetCmpUnique a b+  compare (VirtualRegF a) (VirtualRegF b) = nonDetCmpUnique a b+  compare (VirtualRegD a) (VirtualRegD b) = nonDetCmpUnique a b++  compare VirtualRegI{} _ = LT+  compare _ VirtualRegI{} = GT+  compare VirtualRegHi{} _ = LT+  compare _ VirtualRegHi{} = GT+  compare VirtualRegF{} _ = LT+  compare _ VirtualRegF{} = GT++++instance Uniquable VirtualReg where+        getUnique reg+         = case reg of+                VirtualRegI u   -> u+                VirtualRegHi u  -> u+                VirtualRegF u   -> u+                VirtualRegD u   -> u++instance Outputable VirtualReg where+        ppr reg+         = case reg of+                VirtualRegI  u  -> text "%vI_"   <> pprUniqueAlways u+                VirtualRegHi u  -> text "%vHi_"  <> pprUniqueAlways u+                -- this code is kinda wrong on x86+                -- because float and double occupy the same register set+                -- namely SSE2 register xmm0 .. xmm15+                VirtualRegF  u  -> text "%vFloat_"   <> pprUniqueAlways u+                VirtualRegD  u  -> text "%vDouble_"   <> pprUniqueAlways u++++renameVirtualReg :: Unique -> VirtualReg -> VirtualReg+renameVirtualReg u r+ = case r of+        VirtualRegI _   -> VirtualRegI  u+        VirtualRegHi _  -> VirtualRegHi u+        VirtualRegF _   -> VirtualRegF  u+        VirtualRegD _   -> VirtualRegD  u+++classOfVirtualReg :: VirtualReg -> RegClass+classOfVirtualReg vr+ = case vr of+        VirtualRegI{}   -> RcInteger+        VirtualRegHi{}  -> RcInteger+        VirtualRegF{}   -> RcFloat+        VirtualRegD{}   -> RcDouble++++-- Determine the upper-half vreg for a 64-bit quantity on a 32-bit platform+-- when supplied with the vreg for the lower-half of the quantity.+-- (NB. Not reversible).+getHiVirtualRegFromLo :: VirtualReg -> VirtualReg+getHiVirtualRegFromLo reg+ = case reg of+        -- makes a pseudo-unique with tag 'H'+        VirtualRegI u   -> VirtualRegHi (newTagUnique u 'H')+        _               -> panic "Reg.getHiVirtualRegFromLo"++getHiVRegFromLo :: Reg -> Reg+getHiVRegFromLo reg+ = case reg of+        RegVirtual  vr  -> RegVirtual (getHiVirtualRegFromLo vr)+        RegReal _       -> panic "Reg.getHiVRegFromLo"+++------------------------------------------------------------------------------------+-- | RealRegs are machine regs which are available for allocation, in+--      the usual way.  We know what class they are, because that's part of+--      the processor's architecture.+--+--      RealRegPairs are pairs of real registers that are allocated together+--      to hold a larger value, such as with Double regs on SPARC.+--+data RealReg+        = RealRegSingle {-# UNPACK #-} !RegNo+        | RealRegPair   {-# UNPACK #-} !RegNo {-# UNPACK #-} !RegNo+        deriving (Eq, Show, Ord)++instance Uniquable RealReg where+        getUnique reg+         = case reg of+                RealRegSingle i         -> mkRegSingleUnique i+                RealRegPair r1 r2       -> mkRegPairUnique (r1 * 65536 + r2)++instance Outputable RealReg where+        ppr reg+         = case reg of+                RealRegSingle i         -> text "%r"  <> int i+                RealRegPair r1 r2       -> text "%r(" <> int r1+                                           <> vbar <> int r2 <> text ")"++regNosOfRealReg :: RealReg -> [RegNo]+regNosOfRealReg rr+ = case rr of+        RealRegSingle r1        -> [r1]+        RealRegPair   r1 r2     -> [r1, r2]+++realRegsAlias :: RealReg -> RealReg -> Bool+realRegsAlias rr1 rr2+        = not $ null $ intersect (regNosOfRealReg rr1) (regNosOfRealReg rr2)++--------------------------------------------------------------------------------+-- | A register, either virtual or real+data Reg+        = RegVirtual !VirtualReg+        | RegReal    !RealReg+        deriving (Eq, Ord)++regSingle :: RegNo -> Reg+regSingle regNo         = RegReal $ RealRegSingle regNo++regPair :: RegNo -> RegNo -> Reg+regPair regNo1 regNo2   = RegReal $ RealRegPair regNo1 regNo2+++-- We like to have Uniques for Reg so that we can make UniqFM and UniqSets+-- in the register allocator.+instance Uniquable Reg where+        getUnique reg+         = case reg of+                RegVirtual vr   -> getUnique vr+                RegReal    rr   -> getUnique rr++-- | Print a reg in a generic manner+--      If you want the architecture specific names, then use the pprReg+--      function from the appropriate Ppr module.+instance Outputable Reg where+        ppr reg+         = case reg of+                RegVirtual vr   -> ppr vr+                RegReal    rr   -> ppr rr+++isRealReg :: Reg -> Bool+isRealReg reg+ = case reg of+        RegReal _       -> True+        RegVirtual _    -> False++takeRealReg :: Reg -> Maybe RealReg+takeRealReg reg+ = case reg of+        RegReal rr      -> Just rr+        _               -> Nothing+++isVirtualReg :: Reg -> Bool+isVirtualReg reg+ = case reg of+        RegReal _       -> False+        RegVirtual _    -> True++takeVirtualReg :: Reg -> Maybe VirtualReg+takeVirtualReg reg+ = case reg of+        RegReal _       -> Nothing+        RegVirtual vr   -> Just vr+++-- | The patch function supplied by the allocator maps VirtualReg to RealReg+--      regs, but sometimes we want to apply it to plain old Reg.+--+liftPatchFnToRegReg  :: (VirtualReg -> RealReg) -> (Reg -> Reg)+liftPatchFnToRegReg patchF reg+ = case reg of+        RegVirtual vr   -> RegReal (patchF vr)+        RegReal _       -> reg
+ compiler/nativeGen/RegAlloc/Graph/ArchBase.hs view
@@ -0,0 +1,161 @@++-- | 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 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 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 view
@@ -0,0 +1,99 @@+-- | Register coalescing.+module RegAlloc.Graph.Coalesce (+        regCoalesce,+        slurpJoinMovs+) where+import GhcPrelude++import RegAlloc.Liveness+import Instruction+import Reg++import Cmm+import Bag+import Digraph+import UniqFM+import UniqSet+import UniqSupply+++-- | Do register coalescing on this top level thing+--+--   For Reg -> Reg moves, if the first reg dies at the same time the+--   second reg is born then the mov only serves to join live ranges.+--   The two regs can be renamed to be the same and the move instruction+--   safely erased.+regCoalesce+        :: Instruction instr+        => [LiveCmmDecl statics instr]+        -> UniqSM [LiveCmmDecl statics instr]++regCoalesce code+ = do+        let joins       = foldl' unionBags emptyBag+                        $ map slurpJoinMovs code++        let alloc       = foldl' buildAlloc emptyUFM+                        $ bagToList joins++        let patched     = map (patchEraseLive (sinkReg alloc)) code++        return patched+++-- | Add a v1 = v2 register renaming to the map.+--   The register with the lowest lexical name is set as the+--   canonical version.+buildAlloc :: UniqFM Reg -> (Reg, Reg) -> UniqFM Reg+buildAlloc fm (r1, r2)+ = let  rmin    = min r1 r2+        rmax    = max r1 r2+   in   addToUFM fm rmax rmin+++-- | Determine the canonical name for a register by following+--   v1 = v2 renamings in this map.+sinkReg :: UniqFM Reg -> Reg -> Reg+sinkReg fm r+ = case lookupUFM fm r of+        Nothing -> r+        Just r' -> sinkReg fm r'+++-- | Slurp out mov instructions that only serve to join live ranges.+--+--   During a mov, if the source reg dies and the destination reg is+--   born then we can rename the two regs to the same thing and+--   eliminate the move.+slurpJoinMovs+        :: Instruction instr+        => LiveCmmDecl statics instr+        -> Bag (Reg, Reg)++slurpJoinMovs live+        = slurpCmm emptyBag live+ where+        slurpCmm   rs  CmmData{}+         = rs++        slurpCmm   rs (CmmProc _ _ _ sccs)+         = foldl' slurpBlock rs (flattenSCCs sccs)++        slurpBlock rs (BasicBlock _ instrs)+         = foldl' slurpLI    rs instrs++        slurpLI    rs (LiveInstr _      Nothing)    = rs+        slurpLI    rs (LiveInstr instr (Just live))+                | Just (r1, r2) <- takeRegRegMoveInstr instr+                , elementOfUniqSet r1 $ liveDieRead live+                , elementOfUniqSet r2 $ liveBorn live++                -- only coalesce movs between two virtuals for now,+                -- else we end up with allocatable regs in the live+                -- regs list..+                , isVirtualReg r1 && isVirtualReg r2+                = consBag (r1, r2) rs++                | otherwise+                = rs+
+ compiler/nativeGen/RegAlloc/Graph/Main.hs view
@@ -0,0 +1,469 @@+{-# 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 Platform+import UniqFM+import UniqSet+import UniqSupply+import Util (seqList)+import CFG++import Data.Maybe+import Control.Monad+++-- | The maximum number of build\/spill cycles we'll allow.+--+--   It should only take 3 or 4 cycles for the allocator to converge.+--   If it takes any longer than this it's probably in an infinite loop,+--   so it's better just to bail out and report a bug.+maxSpinCount    :: Int+maxSpinCount    = 10+++-- | The top level of the graph coloring register allocator.+regAlloc+        :: (Outputable statics, Outputable instr, Instruction instr)+        => DynFlags+        -> UniqFM (UniqSet RealReg)     -- ^ registers we can use for allocation+        -> UniqSet Int                  -- ^ set of available spill slots.+        -> Int                          -- ^ current number of spill slots+        -> [LiveCmmDecl statics instr]  -- ^ code annotated with liveness information.+        -> Maybe CFG                    -- ^ CFG of basic blocks if available+        -> UniqSM ( [NatCmmDecl statics instr]+                  , Maybe Int, [RegAllocStats statics instr] )+           -- ^ code with registers allocated, additional stacks required+           -- and stats for each stage of allocation++regAlloc dflags regsFree slotsFree slotsCount code cfg+ = do+        -- TODO: the regClass function is currently hard coded to the default+        --       target architecture. Would prefer to determine this from dflags.+        --       There are other uses of targetRegClass later in this module.+        let platform = targetPlatform dflags+            triv = trivColorable platform+                        (targetVirtualRegSqueeze platform)+                        (targetRealRegSqueeze platform)++        (code_final, debug_codeGraphs, slotsCount', _)+                <- regAlloc_spin dflags 0+                        triv+                        regsFree slotsFree slotsCount [] code cfg++        let needStack+                | slotsCount == slotsCount'+                = Nothing+                | otherwise+                = Just slotsCount'++        return  ( code_final+                , needStack+                , reverse debug_codeGraphs )+++-- | Perform solver iterations for the graph coloring allocator.+--+--   We extract a register confict graph from the provided cmm code,+--   and try to colour it. If that works then we use the solution rewrite+--   the code with real hregs. If coloring doesn't work we add spill code+--   and try to colour it again. After `maxSpinCount` iterations we give up.+--+regAlloc_spin+        :: forall instr statics.+           (Instruction instr,+            Outputable instr,+            Outputable statics)+        => DynFlags+        -> Int  -- ^ Number of solver iterations we've already performed.+        -> Color.Triv VirtualReg RegClass RealReg+                -- ^ Function for calculating whether a register is trivially+                --   colourable.+        -> UniqFM (UniqSet RealReg)      -- ^ Free registers that we can allocate.+        -> UniqSet Int                   -- ^ Free stack slots that we can use.+        -> Int                           -- ^ Number of spill slots in use+        -> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to.+        -> [LiveCmmDecl statics instr]   -- ^ Liveness annotated code to allocate.+        -> Maybe CFG+        -> UniqSM ( [NatCmmDecl statics instr]+                  , [RegAllocStats statics instr]+                  , Int                  -- Slots in use+                  , Color.Graph VirtualReg RegClass RealReg)++regAlloc_spin dflags spinCount triv regsFree slotsFree slotsCount debug_codeGraphs code cfg+ = do+        let platform = targetPlatform dflags++        -- If any of these dump flags are turned on we want to hang on to+        -- intermediate structures in the allocator - otherwise tell the+        -- allocator to ditch them early so we don't end up creating space leaks.+        let dump = or+                [ dopt Opt_D_dump_asm_regalloc_stages dflags+                , dopt Opt_D_dump_asm_stats dflags+                , dopt Opt_D_dump_asm_conflicts dflags ]++        -- Check that we're not running off down the garden path.+        when (spinCount > maxSpinCount)+         $ pprPanic "regAlloc_spin: max build/spill cycle count exceeded."+           (  text "It looks like the register allocator is stuck in an infinite loop."+           $$ text "max cycles  = " <> int maxSpinCount+           $$ text "regsFree    = " <> (hcat $ punctuate space $ map ppr+                                             $ nonDetEltsUniqSet $ unionManyUniqSets+                                             $ nonDetEltsUFM regsFree)+              -- This is non-deterministic but we do not+              -- currently support deterministic code-generation.+              -- See Note [Unique Determinism and code generation]+           $$ text "slotsFree   = " <> ppr (sizeUniqSet slotsFree))++        -- Build the register conflict graph from the cmm code.+        (graph  :: Color.Graph VirtualReg RegClass RealReg)+                <- {-# SCC "BuildGraph" #-} buildGraph code++        -- VERY IMPORTANT:+        --   We really do want the graph to be fully evaluated _before_ we+        --   start coloring. If we don't do this now then when the call to+        --   Color.colorGraph forces bits of it, the heap will be filled with+        --   half evaluated pieces of graph and zillions of apply thunks.+        seqGraph graph `seq` return ()++        -- Build a map of the cost of spilling each instruction.+        -- This is a lazy binding, so the map will only be computed if we+        -- actually have to spill to the stack.+        let spillCosts  = foldl' plusSpillCostInfo zeroSpillCostInfo+                        $ map (slurpSpillCostInfo platform cfg) code++        -- The function to choose regs to leave uncolored.+        let spill       = chooseSpill spillCosts++        -- Record startup state in our log.+        let stat1+             = if spinCount == 0+                 then   Just $ RegAllocStatsStart+                        { raLiveCmm     = code+                        , raGraph       = graph+                        , raSpillCosts  = spillCosts }+                 else   Nothing++        -- Try and color the graph.+        let (graph_colored, rsSpill, rmCoalesce)+                = {-# SCC "ColorGraph" #-}+                  Color.colorGraph+                       (gopt Opt_RegsIterative dflags)+                       spinCount+                       regsFree triv spill graph++        -- Rewrite registers in the code that have been coalesced.+        let patchF reg+                | RegVirtual vr <- reg+                = case lookupUFM rmCoalesce vr of+                        Just vr'        -> patchF (RegVirtual vr')+                        Nothing         -> reg++                | otherwise+                = reg++        let (code_coalesced :: [LiveCmmDecl statics instr])+                = map (patchEraseLive patchF) code++        -- Check whether we've found a coloring.+        if isEmptyUniqSet rsSpill++         -- Coloring was successful because no registers needed to be spilled.+         then do+                -- if -fasm-lint is turned on then validate the graph.+                -- This checks for bugs in the graph allocator itself.+                let graph_colored_lint  =+                        if gopt Opt_DoAsmLinting dflags+                                then Color.validateGraph (text "")+                                        True    -- Require all nodes to be colored.+                                        graph_colored+                                else graph_colored++                -- Rewrite the code to use real hregs, using the colored graph.+                let code_patched+                        = map (patchRegsFromGraph platform graph_colored_lint)+                              code_coalesced++                -- Clean out unneeded SPILL/RELOAD meta instructions.+                --   The spill code generator just spills the entire live range+                --   of a vreg, but it might not need to be on the stack for+                --   its entire lifetime.+                let code_spillclean+                        = map (cleanSpills platform) code_patched++                -- Strip off liveness information from the allocated code.+                -- Also rewrite SPILL/RELOAD meta instructions into real machine+                -- instructions along the way+                let code_final+                        = map (stripLive dflags) code_spillclean++                -- Record what happened in this stage for debugging+                let stat+                     =  RegAllocStatsColored+                        { raCode                = code+                        , raGraph               = graph+                        , raGraphColored        = graph_colored_lint+                        , raCoalesced           = rmCoalesce+                        , raCodeCoalesced       = code_coalesced+                        , raPatched             = code_patched+                        , raSpillClean          = code_spillclean+                        , raFinal               = code_final+                        , raSRMs                = foldl' addSRM (0, 0, 0)+                                                $ map countSRMs code_spillclean }++                -- Bundle up all the register allocator statistics.+                --   .. but make sure to drop them on the floor if they're not+                --      needed, otherwise we'll get a space leak.+                let statList =+                        if dump then [stat] ++ maybeToList stat1 ++ debug_codeGraphs+                                else []++                -- Ensure all the statistics are evaluated, to avoid space leaks.+                seqList statList (return ())++                return  ( code_final+                        , statList+                        , slotsCount+                        , graph_colored_lint)++         -- Coloring was unsuccessful. We need to spill some register to the+         -- stack, make a new graph, and try to color it again.+         else do+                -- if -fasm-lint is turned on then validate the graph+                let graph_colored_lint  =+                        if gopt Opt_DoAsmLinting dflags+                                then Color.validateGraph (text "")+                                        False   -- don't require nodes to be colored+                                        graph_colored+                                else graph_colored++                -- Spill uncolored regs to the stack.+                (code_spilled, slotsFree', slotsCount', spillStats)+                        <- regSpill platform code_coalesced slotsFree slotsCount rsSpill++                -- Recalculate liveness information.+                -- NOTE: we have to reverse the SCCs here to get them back into+                --       the reverse-dependency order required by computeLiveness.+                --       If they're not in the correct order that function will panic.+                code_relive     <- mapM (regLiveness platform . reverseBlocksInTops)+                                        code_spilled++                -- Record what happened in this stage for debugging.+                let stat        =+                        RegAllocStatsSpill+                        { raCode        = code+                        , raGraph       = graph_colored_lint+                        , raCoalesced   = rmCoalesce+                        , raSpillStats  = spillStats+                        , raSpillCosts  = spillCosts+                        , raSpilled     = code_spilled }++                -- Bundle up all the register allocator statistics.+                --   .. but make sure to drop them on the floor if they're not+                --      needed, otherwise we'll get a space leak.+                let statList =+                        if dump+                                then [stat] ++ maybeToList stat1 ++ debug_codeGraphs+                                else []++                -- Ensure all the statistics are evaluated, to avoid space leaks.+                seqList statList (return ())++                regAlloc_spin dflags (spinCount + 1) triv regsFree slotsFree'+                              slotsCount' statList code_relive cfg+++-- | Build a graph from the liveness and coalesce information in this code.+buildGraph+        :: Instruction instr+        => [LiveCmmDecl statics instr]+        -> UniqSM (Color.Graph VirtualReg RegClass RealReg)++buildGraph code+ = do+        -- Slurp out the conflicts and reg->reg moves from this code.+        let (conflictList, moveList) =+                unzip $ map slurpConflicts code++        -- Slurp out the spill/reload coalesces.+        let moveList2           = map slurpReloadCoalesce code++        -- Add the reg-reg conflicts to the graph.+        let conflictBag         = unionManyBags conflictList+        let graph_conflict+                = foldrBag graphAddConflictSet Color.initGraph conflictBag++        -- Add the coalescences edges to the graph.+        let moveBag+                = unionBags (unionManyBags moveList2)+                            (unionManyBags moveList)++        let graph_coalesce+                = foldrBag graphAddCoalesce graph_conflict moveBag++        return  graph_coalesce+++-- | Add some conflict edges to the graph.+--   Conflicts between virtual and real regs are recorded as exclusions.+graphAddConflictSet+        :: UniqSet Reg+        -> Color.Graph VirtualReg RegClass RealReg+        -> Color.Graph VirtualReg RegClass RealReg++graphAddConflictSet set graph+ = let  virtuals        = mkUniqSet+                        [ vr | RegVirtual vr <- nonDetEltsUniqSet set ]++        graph1  = Color.addConflicts virtuals classOfVirtualReg graph++        graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 classOfVirtualReg r2)+                        graph1+                        [ (vr, rr)+                                | RegVirtual vr <- nonDetEltsUniqSet set+                                , RegReal    rr <- nonDetEltsUniqSet set]+                          -- See Note [Unique Determinism and code generation]++   in   graph2+++-- | Add some coalesence edges to the graph+--   Coalesences between virtual and real regs are recorded as preferences.+graphAddCoalesce+        :: (Reg, Reg)+        -> Color.Graph VirtualReg RegClass RealReg+        -> Color.Graph VirtualReg RegClass RealReg++graphAddCoalesce (r1, r2) graph+        | RegReal rr            <- r1+        , RegVirtual vr         <- r2+        = Color.addPreference (vr, classOfVirtualReg vr) rr graph++        | RegReal rr            <- r2+        , RegVirtual vr         <- r1+        = Color.addPreference (vr, classOfVirtualReg vr) rr graph++        | RegVirtual vr1        <- r1+        , RegVirtual vr2        <- r2+        = Color.addCoalesce+                (vr1, classOfVirtualReg vr1)+                (vr2, classOfVirtualReg vr2)+                graph++        -- We can't coalesce two real regs, but there could well be existing+        --      hreg,hreg moves in the input code. We'll just ignore these+        --      for coalescing purposes.+        | RegReal _             <- r1+        , RegReal _             <- r2+        = graph++        | otherwise+        = panic "graphAddCoalesce"+++-- | Patch registers in code using the reg -> reg mapping in this graph.+patchRegsFromGraph+        :: (Outputable statics, Outputable instr, Instruction instr)+        => Platform -> Color.Graph VirtualReg RegClass RealReg+        -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr++patchRegsFromGraph platform graph code+ = patchEraseLive patchF code+ where+        -- Function to lookup the hardreg for a virtual reg from the graph.+        patchF reg+                -- leave real regs alone.+                | RegReal{}     <- reg+                = reg++                -- this virtual has a regular node in the graph.+                | RegVirtual vr <- reg+                , Just node     <- Color.lookupNode graph vr+                = case Color.nodeColor node of+                        Just color      -> RegReal    color+                        Nothing         -> RegVirtual vr++                -- no node in the graph for this virtual, bad news.+                | otherwise+                = pprPanic "patchRegsFromGraph: register mapping failed."+                        (  text "There is no node in the graph for register "+                                <> ppr reg+                        $$ ppr code+                        $$ Color.dotGraph+                                (\_ -> text "white")+                                (trivColorable platform+                                        (targetVirtualRegSqueeze platform)+                                        (targetRealRegSqueeze platform))+                                graph)+++-----+-- for when laziness just isn't what you wanted...+--  We need to deepSeq the whole graph before trying to colour it to avoid+--  space leaks.+seqGraph :: Color.Graph VirtualReg RegClass RealReg -> ()+seqGraph graph          = seqNodes (nonDetEltsUFM (Color.graphMap graph))+   -- See Note [Unique Determinism and code generation]++seqNodes :: [Color.Node VirtualReg RegClass RealReg] -> ()+seqNodes ns+ = case ns of+        []              -> ()+        (n : ns)        -> seqNode n `seq` seqNodes ns++seqNode :: Color.Node VirtualReg RegClass RealReg -> ()+seqNode node+        =     seqVirtualReg     (Color.nodeId node)+        `seq` seqRegClass       (Color.nodeClass node)+        `seq` seqMaybeRealReg   (Color.nodeColor node)+        `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeConflicts node)))+        `seq` (seqRealRegList    (nonDetEltsUniqSet (Color.nodeExclusions node)))+        `seq` (seqRealRegList (Color.nodePreference node))+        `seq` (seqVirtualRegList (nonDetEltsUniqSet (Color.nodeCoalesce node)))+              -- It's OK to use nonDetEltsUniqSet for seq++seqVirtualReg :: VirtualReg -> ()+seqVirtualReg reg = reg `seq` ()++seqRealReg :: RealReg -> ()+seqRealReg reg = reg `seq` ()++seqRegClass :: RegClass -> ()+seqRegClass c = c `seq` ()++seqMaybeRealReg :: Maybe RealReg -> ()+seqMaybeRealReg mr+ = case mr of+        Nothing         -> ()+        Just r          -> seqRealReg r++seqVirtualRegList :: [VirtualReg] -> ()+seqVirtualRegList rs+ = case rs of+        []              -> ()+        (r : rs)        -> seqVirtualReg r `seq` seqVirtualRegList rs++seqRealRegList :: [RealReg] -> ()+seqRealRegList rs+ = case rs of+        []              -> ()+        (r : rs)        -> seqRealReg r `seq` seqRealRegList rs
+ compiler/nativeGen/RegAlloc/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 RegAlloc.Graph.Spill (+        regSpill,+        SpillStats(..),+        accSpillSL+) where+import GhcPrelude++import RegAlloc.Liveness+import Instruction+import Reg+import Cmm hiding (RegSet)+import BlockId+import Hoopl.Collections++import MonadUtils+import State+import Unique+import UniqFM+import UniqSet+import UniqSupply+import Outputable+import Platform++import Data.List+import Data.Maybe+import Data.IntSet              (IntSet)+import qualified Data.IntSet    as IntSet+++-- | Spill all these virtual regs to stack slots.+--+--   Bumps the number of required stack slots if required.+--+--+--   TODO: See if we can split some of the live ranges instead of just globally+--         spilling the virtual reg. This might make the spill cleaner's job easier.+--+--   TODO: On CISCy x86 and x86_64 we don't necessarily have to add a mov instruction+--         when making spills. If an instr is using a spilled virtual we may be able to+--         address the spill slot directly.+--+regSpill+        :: Instruction instr+        => Platform+        -> [LiveCmmDecl statics instr]  -- ^ the code+        -> UniqSet Int                  -- ^ available stack slots+        -> Int                          -- ^ current number of spill slots.+        -> UniqSet VirtualReg           -- ^ the regs to spill+        -> UniqSM+            ([LiveCmmDecl statics instr]+                 -- code with SPILL and RELOAD meta instructions added.+            , UniqSet Int               -- left over slots+            , Int                       -- slot count in use now.+            , SpillStats )              -- stats about what happened during spilling++regSpill platform code slotsFree slotCount regs++        -- Not enough slots to spill these regs.+        | sizeUniqSet slotsFree < sizeUniqSet regs+        = -- pprTrace "Bumping slot count:" (ppr slotCount <> text " -> " <> ppr (slotCount+512)) $+          let slotsFree' = (addListToUniqSet slotsFree [slotCount+1 .. slotCount+512])+          in regSpill platform code slotsFree' (slotCount+512) regs++        | otherwise+        = do+                -- Allocate a slot for each of the spilled regs.+                let slots       = take (sizeUniqSet regs) $ nonDetEltsUniqSet slotsFree+                let regSlotMap  = listToUFM+                                $ zip (nonDetEltsUniqSet regs) slots+                    -- This is non-deterministic but we do not+                    -- currently support deterministic code-generation.+                    -- See Note [Unique Determinism and code generation]++                -- Grab the unique supply from the monad.+                us      <- getUniqueSupplyM++                -- Run the spiller on all the blocks.+                let (code', state')     =+                        runState (mapM (regSpill_top platform regSlotMap) code)+                                 (initSpillS us)++                return  ( code'+                        , minusUniqSet slotsFree (mkUniqSet slots)+                        , slotCount+                        , makeSpillStats state')+++-- | Spill some registers to stack slots in a top-level thing.+regSpill_top+        :: Instruction instr+        => Platform+        -> RegMap Int+                -- ^ map of vregs to slots they're being spilled to.+        -> LiveCmmDecl statics instr+                -- ^ the top level thing.+        -> SpillM (LiveCmmDecl statics instr)++regSpill_top platform regSlotMap cmm+ = case cmm of+        CmmData{}+         -> return cmm++        CmmProc info label live sccs+         |  LiveInfo static firstId liveVRegsOnEntry liveSlotsOnEntry <- info+         -> do+                -- The liveVRegsOnEntry contains the set of vregs that are live+                -- on entry to each basic block. If we spill one of those vregs+                -- we remove it from that set and add the corresponding slot+                -- number to the liveSlotsOnEntry set. The spill cleaner needs+                -- this information to erase unneeded spill and reload instructions+                -- after we've done a successful allocation.+                let liveSlotsOnEntry' :: BlockMap IntSet+                    liveSlotsOnEntry'+                        = mapFoldlWithKey patchLiveSlot+                                          liveSlotsOnEntry liveVRegsOnEntry++                let info'+                        = LiveInfo static firstId+                                liveVRegsOnEntry+                                liveSlotsOnEntry'++                -- Apply the spiller to all the basic blocks in the CmmProc.+                sccs'   <- mapM (mapSCCM (regSpill_block platform regSlotMap)) sccs++                return  $ CmmProc info' label live sccs'++ where  -- Given a BlockId and the set of registers live in it,+        -- if registers in this block are being spilled to stack slots,+        -- then record the fact that these slots are now live in those blocks+        -- in the given slotmap.+        patchLiveSlot+                :: BlockMap IntSet -> BlockId -> RegSet -> BlockMap IntSet++        patchLiveSlot slotMap blockId regsLive+         = let+                -- Slots that are already recorded as being live.+                curSlotsLive    = fromMaybe IntSet.empty+                                $ mapLookup blockId slotMap++                moreSlotsLive   = IntSet.fromList+                                $ catMaybes+                                $ map (lookupUFM regSlotMap)+                                $ nonDetEltsUniqSet regsLive+                    -- See Note [Unique Determinism and code generation]++                slotMap'+                 = mapInsert blockId (IntSet.union curSlotsLive moreSlotsLive)+                             slotMap++           in   slotMap'+++-- | Spill some registers to stack slots in a basic block.+regSpill_block+        :: Instruction instr+        => Platform+        -> UniqFM Int   -- ^ map of vregs to slots they're being spilled to.+        -> LiveBasicBlock instr+        -> SpillM (LiveBasicBlock instr)++regSpill_block platform regSlotMap (BasicBlock i instrs)+ = do   instrss'        <- mapM (regSpill_instr platform regSlotMap) instrs+        return  $ BasicBlock i (concat instrss')+++-- | Spill some registers to stack slots in a single instruction.+--   If the instruction uses registers that need to be spilled, then it is+--   prefixed (or postfixed) with the appropriate RELOAD or SPILL meta+--   instructions.+regSpill_instr+        :: Instruction instr+        => Platform+        -> UniqFM Int -- ^ map of vregs to slots they're being spilled to.+        -> LiveInstr instr+        -> SpillM [LiveInstr instr]++regSpill_instr _ _ li@(LiveInstr _ Nothing)+ = do   return [li]++regSpill_instr platform regSlotMap+        (LiveInstr instr (Just _))+ = do+        -- work out which regs are read and written in this instr+        let RU rlRead rlWritten = regUsageOfInstr platform instr++        -- sometimes a register is listed as being read more than once,+        --      nub this so we don't end up inserting two lots of spill code.+        let rsRead_             = nub rlRead+        let rsWritten_          = nub rlWritten++        -- if a reg is modified, it appears in both lists, want to undo this..+        let rsRead              = rsRead_    \\ rsWritten_+        let rsWritten           = rsWritten_ \\ rsRead_+        let rsModify            = intersect rsRead_ rsWritten_++        -- work out if any of the regs being used are currently being spilled.+        let rsSpillRead         = filter (\r -> elemUFM r regSlotMap) rsRead+        let rsSpillWritten      = filter (\r -> elemUFM r regSlotMap) rsWritten+        let rsSpillModify       = filter (\r -> elemUFM r regSlotMap) rsModify++        -- rewrite the instr and work out spill code.+        (instr1, prepost1)      <- mapAccumLM (spillRead   regSlotMap) instr  rsSpillRead+        (instr2, prepost2)      <- mapAccumLM (spillWrite  regSlotMap) instr1 rsSpillWritten+        (instr3, prepost3)      <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify++        let (mPrefixes, mPostfixes)     = unzip (prepost1 ++ prepost2 ++ prepost3)+        let prefixes                    = concat mPrefixes+        let postfixes                   = concat mPostfixes++        -- final code+        let instrs'     =  prefixes+                        ++ [LiveInstr instr3 Nothing]+                        ++ postfixes++        return $ instrs'+++-- | Add a RELOAD met a instruction to load a value for an instruction that+--   writes to a vreg that is being spilled.+spillRead+        :: Instruction instr+        => UniqFM Int+        -> instr+        -> Reg+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))++spillRead regSlotMap instr reg+ | Just slot     <- lookupUFM regSlotMap reg+ = do    (instr', nReg)  <- patchInstr reg instr++         modify $ \s -> s+                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 0, 1) }++         return  ( instr'+                 , ( [LiveInstr (RELOAD slot nReg) Nothing]+                 , []) )++ | otherwise     = panic "RegSpill.spillRead: no slot defined for spilled reg"+++-- | Add a SPILL meta instruction to store a value for an instruction that+--   writes to a vreg that is being spilled.+spillWrite+        :: Instruction instr+        => UniqFM Int+        -> instr+        -> Reg+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))++spillWrite regSlotMap instr reg+ | Just slot     <- lookupUFM regSlotMap reg+ = do    (instr', nReg)  <- patchInstr reg instr++         modify $ \s -> s+                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }++         return  ( instr'+                 , ( []+                   , [LiveInstr (SPILL nReg slot) Nothing]))++ | otherwise     = panic "RegSpill.spillWrite: no slot defined for spilled reg"+++-- | Add both RELOAD and SPILL meta instructions for an instruction that+--   both reads and writes to a vreg that is being spilled.+spillModify+        :: Instruction instr+        => UniqFM Int+        -> instr+        -> Reg+        -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr']))++spillModify regSlotMap instr reg+ | Just slot     <- lookupUFM regSlotMap reg+ = do    (instr', nReg)  <- patchInstr reg instr++         modify $ \s -> s+                { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 1) }++         return  ( instr'+                 , ( [LiveInstr (RELOAD slot nReg) Nothing]+                   , [LiveInstr (SPILL nReg slot) Nothing]))++ | otherwise     = panic "RegSpill.spillModify: no slot defined for spilled reg"+++-- | Rewrite uses of this virtual reg in an instr to use a different+--   virtual reg.+patchInstr+        :: Instruction instr+        => Reg -> instr -> SpillM (instr, Reg)++patchInstr reg instr+ = do   nUnique         <- newUnique++        -- The register we're rewriting is suppoed to be virtual.+        -- If it's not then something has gone horribly wrong.+        let nReg+             = case reg of+                RegVirtual vr+                 -> RegVirtual (renameVirtualReg nUnique vr)++                RegReal{}+                 -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg"++        let instr'      = patchReg1 reg nReg instr+        return          (instr', nReg)+++patchReg1+        :: Instruction instr+        => Reg -> Reg -> instr -> instr++patchReg1 old new instr+ = let  patchF r+                | r == old      = new+                | otherwise     = r+   in   patchRegsOfInstr instr patchF+++-- Spiller monad --------------------------------------------------------------+-- | State monad for the spill code generator.+type SpillM a+        = State SpillS a++-- | Spill code generator state.+data SpillS+        = SpillS+        { -- | Unique supply for generating fresh vregs.+          stateUS       :: UniqSupply++          -- | Spilled vreg vs the number of times it was loaded, stored.+        , stateSpillSL  :: UniqFM (Reg, Int, Int) }+++-- | Create a new spiller state.+initSpillS :: UniqSupply -> SpillS+initSpillS uniqueSupply+        = SpillS+        { stateUS       = uniqueSupply+        , stateSpillSL  = emptyUFM }+++-- | Allocate a new unique in the spiller monad.+newUnique :: SpillM Unique+newUnique+ = do   us      <- gets stateUS+        case takeUniqFromSupply us of+         (uniq, us')+          -> do modify $ \s -> s { stateUS = us' }+                return uniq+++-- | Add a spill/reload count to a stats record for a register.+accSpillSL :: (Reg, Int, Int) -> (Reg, Int, Int) -> (Reg, Int, Int)+accSpillSL (r1, s1, l1) (_, s2, l2)+        = (r1, s1 + s2, l1 + l2)+++-- Spiller stats --------------------------------------------------------------+-- | Spiller statistics.+--   Tells us what registers were spilled.+data SpillStats+        = SpillStats+        { spillStoreLoad        :: UniqFM (Reg, Int, Int) }+++-- | Extract spiller statistics from the spiller state.+makeSpillStats :: SpillS -> SpillStats+makeSpillStats s+        = SpillStats+        { spillStoreLoad        = stateSpillSL s }+++instance Outputable SpillStats where+ ppr stats+        = pprUFM (spillStoreLoad stats)+                 (vcat . map (\(r, s, l) -> ppr r <+> int s <+> int l))
+ compiler/nativeGen/RegAlloc/Graph/SpillClean.hs view
@@ -0,0 +1,614 @@++-- | Clean out unneeded spill\/reload instructions.+--+--   Handling of join points+--   ~~~~~~~~~~~~~~~~~~~~~~~+--+--   B1:                          B2:+--    ...                          ...+--       RELOAD SLOT(0), %r1          RELOAD SLOT(0), %r1+--       ... A ...                    ... B ...+--       jump B3                      jump B3+--+--                B3: ... C ...+--                    RELOAD SLOT(0), %r1+--                    ...+--+--   The Plan+--   ~~~~~~~~+--   As long as %r1 hasn't been written to in A, B or C then we don't need+--   the reload in B3.+--+--   What we really care about here is that on the entry to B3, %r1 will+--   always have the same value that is in SLOT(0) (ie, %r1 is _valid_)+--+--   This also works if the reloads in B1\/B2 were spills instead, because+--   spilling %r1 to a slot makes that slot have the same value as %r1.+--+module RegAlloc.Graph.SpillClean (+        cleanSpills+) where+import GhcPrelude++import RegAlloc.Liveness+import Instruction+import Reg++import BlockId+import Cmm+import UniqSet+import UniqFM+import Unique+import State+import Outputable+import Platform+import Hoopl.Collections++import Data.List+import Data.Maybe+import Data.IntSet              (IntSet)+import qualified Data.IntSet    as IntSet+++-- | The identification number of a spill slot.+--   A value is stored in a spill slot when we don't have a free+--   register to hold it.+type Slot = Int+++-- | Clean out unneeded spill\/reloads from this top level thing.+cleanSpills+        :: Instruction instr+        => Platform+        -> LiveCmmDecl statics instr+        -> LiveCmmDecl statics instr++cleanSpills platform cmm+        = evalState (cleanSpin platform 0 cmm) initCleanS+++-- | Do one pass of cleaning.+cleanSpin+        :: Instruction instr+        => Platform+        -> Int                              -- ^ Iteration number for the cleaner.+        -> LiveCmmDecl statics instr        -- ^ Liveness annotated code to clean.+        -> CleanM (LiveCmmDecl statics instr)++cleanSpin platform spinCount code+ = do+        -- Initialise count of cleaned spill and reload instructions.+        modify $ \s -> s+                { sCleanedSpillsAcc     = 0+                , sCleanedReloadsAcc    = 0+                , sReloadedBy           = emptyUFM }++        code_forward    <- mapBlockTopM (cleanBlockForward platform) code+        code_backward   <- cleanTopBackward code_forward++        -- During the cleaning of each block we collected information about+        -- what regs were valid across each jump. Based on this, work out+        -- whether it will be safe to erase reloads after join points for+        -- the next pass.+        collateJoinPoints++        -- Remember how many spill and reload instructions we cleaned in this pass.+        spills          <- gets sCleanedSpillsAcc+        reloads         <- gets sCleanedReloadsAcc+        modify $ \s -> s+                { sCleanedCount = (spills, reloads) : sCleanedCount s }++        -- If nothing was cleaned in this pass or the last one+        --      then we're done and it's time to bail out.+        cleanedCount    <- gets sCleanedCount+        if take 2 cleanedCount == [(0, 0), (0, 0)]+           then return code++        -- otherwise go around again+           else cleanSpin platform (spinCount + 1) code_backward+++-------------------------------------------------------------------------------+-- | Clean out unneeded reload instructions,+--   while walking forward over the code.+cleanBlockForward+        :: Instruction instr+        => Platform+        -> LiveBasicBlock instr+        -> CleanM (LiveBasicBlock instr)++cleanBlockForward platform (BasicBlock blockId instrs)+ = do+        -- See if we have a valid association for the entry to this block.+        jumpValid       <- gets sJumpValid+        let assoc       = case lookupUFM jumpValid blockId of+                                Just assoc      -> assoc+                                Nothing         -> emptyAssoc++        instrs_reload   <- cleanForward platform blockId assoc [] instrs+        return  $ BasicBlock blockId instrs_reload++++-- | Clean out unneeded reload instructions.+--+--   Walking forwards across the code+--     On a reload, if we know a reg already has the same value as a slot+--     then we don't need to do the reload.+--+cleanForward+        :: Instruction instr+        => Platform+        -> BlockId                  -- ^ the block that we're currently in+        -> Assoc Store              -- ^ two store locations are associated if+                                    --     they have the same value+        -> [LiveInstr instr]        -- ^ acc+        -> [LiveInstr instr]        -- ^ instrs to clean (in backwards order)+        -> CleanM [LiveInstr instr] -- ^ cleaned instrs  (in forward   order)++cleanForward _ _ _ acc []+        = return acc++-- Rewrite live range joins via spill slots to just a spill and a reg-reg move+-- hopefully the spill will be also be cleaned in the next pass+cleanForward platform blockId assoc acc (li1 : li2 : instrs)++        | LiveInstr (SPILL  reg1  slot1) _      <- li1+        , LiveInstr (RELOAD slot2 reg2)  _      <- li2+        , slot1 == slot2+        = do+                modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }+                cleanForward platform blockId assoc acc+                 $ li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing+                       : instrs++cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs)+        | Just (r1, r2) <- takeRegRegMoveInstr i1+        = if r1 == r2+                -- Erase any left over nop reg reg moves while we're here+                -- this will also catch any nop moves that the previous case+                -- happens to add.+                then cleanForward platform blockId assoc acc instrs++                -- If r1 has the same value as some slots and we copy r1 to r2,+                --      then r2 is now associated with those slots instead+                else do let assoc'      = addAssoc (SReg r1) (SReg r2)+                                        $ delAssoc (SReg r2)+                                        $ assoc++                        cleanForward platform blockId assoc' (li : acc) instrs+++cleanForward platform blockId assoc acc (li : instrs)++        -- Update association due to the spill.+        | LiveInstr (SPILL reg slot) _  <- li+        = let   assoc'  = addAssoc (SReg reg)  (SSlot slot)+                        $ delAssoc (SSlot slot)+                        $ assoc+          in    cleanForward platform blockId assoc' (li : acc) instrs++        -- Clean a reload instr.+        | LiveInstr (RELOAD{}) _        <- li+        = do    (assoc', mli)   <- cleanReload platform blockId assoc li+                case mli of+                 Nothing        -> cleanForward platform blockId assoc' acc+                                                instrs++                 Just li'       -> cleanForward platform blockId assoc' (li' : acc)+                                                instrs++        -- Remember the association over a jump.+        | LiveInstr instr _     <- li+        , targets               <- jumpDestsOfInstr instr+        , not $ null targets+        = do    mapM_ (accJumpValid assoc) targets+                cleanForward platform blockId assoc (li : acc) instrs++        -- Writing to a reg changes its value.+        | LiveInstr instr _     <- li+        , RU _ written          <- regUsageOfInstr platform instr+        = let assoc'    = foldr delAssoc assoc (map SReg $ nub written)+          in  cleanForward platform blockId assoc' (li : acc) instrs++++-- | Try and rewrite a reload instruction to something more pleasing+cleanReload+        :: Instruction instr+        => Platform+        -> BlockId+        -> Assoc Store+        -> LiveInstr instr+        -> CleanM (Assoc Store, Maybe (LiveInstr instr))++cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _)++        -- If the reg we're reloading already has the same value as the slot+        --      then we can erase the instruction outright.+        | elemAssoc (SSlot slot) (SReg reg) assoc+        = do    modify  $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }+                return  (assoc, Nothing)++        -- If we can find another reg with the same value as this slot then+        --      do a move instead of a reload.+        | Just reg2     <- findRegOfSlot assoc slot+        = do    modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 }++                let assoc'      = addAssoc (SReg reg) (SReg reg2)+                                $ delAssoc (SReg reg)+                                $ assoc++                return  ( assoc'+                        , Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing)++        -- Gotta keep this instr.+        | otherwise+        = do    -- Update the association.+                let assoc'+                        = addAssoc (SReg reg)  (SSlot slot)+                                -- doing the reload makes reg and slot the same value+                        $ delAssoc (SReg reg)+                                -- reg value changes on reload+                        $ assoc++                -- Remember that this block reloads from this slot.+                accBlockReloadsSlot blockId slot++                return  (assoc', Just li)++cleanReload _ _ _ _+        = panic "RegSpillClean.cleanReload: unhandled instr"+++-------------------------------------------------------------------------------+-- | Clean out unneeded spill instructions,+--   while walking backwards over the code.+--+--      If there were no reloads from a slot between a spill and the last one+--      then the slot was never read and we don't need the spill.+--+--      SPILL   r0 -> s1+--      RELOAD  s1 -> r2+--      SPILL   r3 -> s1        <--- don't need this spill+--      SPILL   r4 -> s1+--      RELOAD  s1 -> r5+--+--      Maintain a set of+--              "slots which were spilled to but not reloaded from yet"+--+--      Walking backwards across the code:+--       a) On a reload from a slot, remove it from the set.+--+--       a) On a spill from a slot+--              If the slot is in set then we can erase the spill,+--               because it won't be reloaded from until after the next spill.+--+--              otherwise+--               keep the spill and add the slot to the set+--+-- TODO: This is mostly inter-block+--       we should really be updating the noReloads set as we cross jumps also.+--+-- TODO: generate noReloads from liveSlotsOnEntry+--+cleanTopBackward+        :: Instruction instr+        => LiveCmmDecl statics instr+        -> CleanM (LiveCmmDecl statics instr)++cleanTopBackward cmm+ = case cmm of+        CmmData{}+         -> return cmm++        CmmProc info label live sccs+         | LiveInfo _ _ _ liveSlotsOnEntry <- info+         -> do  sccs'   <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs+                return  $ CmmProc info label live sccs'+++cleanBlockBackward+        :: Instruction instr+        => BlockMap IntSet+        -> LiveBasicBlock instr+        -> CleanM (LiveBasicBlock instr)++cleanBlockBackward liveSlotsOnEntry (BasicBlock blockId instrs)+ = do   instrs_spill    <- cleanBackward liveSlotsOnEntry  emptyUniqSet  [] instrs+        return  $ BasicBlock blockId instrs_spill++++cleanBackward+        :: Instruction instr+        => BlockMap IntSet          -- ^ Slots live on entry to each block+        -> UniqSet Int              -- ^ Slots that have been spilled, but not reloaded from+        -> [LiveInstr instr]        -- ^ acc+        -> [LiveInstr instr]        -- ^ Instrs to clean (in forwards order)+        -> CleanM [LiveInstr instr] -- ^ Cleaned instrs  (in backwards order)++cleanBackward liveSlotsOnEntry noReloads acc lis+ = do   reloadedBy      <- gets sReloadedBy+        cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc lis+++cleanBackward'+        :: Instruction instr+        => BlockMap IntSet+        -> UniqFM [BlockId]+        -> UniqSet Int+        -> [LiveInstr instr]+        -> [LiveInstr instr]+        -> State CleanS [LiveInstr instr]++cleanBackward' _ _ _      acc []+        = return  acc++cleanBackward' liveSlotsOnEntry reloadedBy noReloads acc (li : instrs)++        -- If nothing ever reloads from this slot then we don't need the spill.+        | LiveInstr (SPILL _ slot) _    <- li+        , Nothing       <- lookupUFM reloadedBy (SSlot slot)+        = do    modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }+                cleanBackward liveSlotsOnEntry noReloads acc instrs++        | LiveInstr (SPILL _ slot) _    <- li+        = if elementOfUniqSet slot noReloads++           -- We can erase this spill because the slot won't be read until+           -- after the next one+           then do+                modify $ \s -> s { sCleanedSpillsAcc = sCleanedSpillsAcc s + 1 }+                cleanBackward liveSlotsOnEntry noReloads acc instrs++           else do+                -- This slot is being spilled to, but we haven't seen any reloads yet.+                let noReloads'  = addOneToUniqSet noReloads slot+                cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs++        -- if we reload from a slot then it's no longer unused+        | LiveInstr (RELOAD slot _) _   <- li+        , noReloads'            <- delOneFromUniqSet noReloads slot+        = cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs++        -- If a slot is live in a jump target then assume it's reloaded there.+        --+        -- TODO: A real dataflow analysis would do a better job here.+        --       If the target block _ever_ used the slot then we assume+        --       it always does, but if those reloads are cleaned the slot+        --       liveness map doesn't get updated.+        | LiveInstr instr _     <- li+        , targets               <- jumpDestsOfInstr instr+        = do+                let slotsReloadedByTargets+                        = IntSet.unions+                        $ catMaybes+                        $ map (flip mapLookup liveSlotsOnEntry)+                        $ targets++                let noReloads'+                        = foldl' delOneFromUniqSet noReloads+                        $ IntSet.toList slotsReloadedByTargets++                cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs++        -- some other instruction+        | otherwise+        = cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs+++-- | Combine the associations from all the inward control flow edges.+--+collateJoinPoints :: CleanM ()+collateJoinPoints+ = modify $ \s -> s+        { sJumpValid    = mapUFM intersects (sJumpValidAcc s)+        , sJumpValidAcc = emptyUFM }++intersects :: [Assoc Store]     -> Assoc Store+intersects []           = emptyAssoc+intersects assocs       = foldl1' intersectAssoc assocs+++-- | See if we have a reg with the same value as this slot in the association table.+findRegOfSlot :: Assoc Store -> Int -> Maybe Reg+findRegOfSlot assoc slot+        | close                 <- closeAssoc (SSlot slot) assoc+        , Just (SReg reg)       <- find isStoreReg $ nonDetEltsUniqSet close+           -- See Note [Unique Determinism and code generation]+        = Just reg++        | otherwise+        = Nothing+++-------------------------------------------------------------------------------+-- | Cleaner monad.+type CleanM+        = State CleanS++-- | Cleaner state.+data CleanS+        = CleanS+        { -- | Regs which are valid at the start of each block.+          sJumpValid            :: UniqFM (Assoc Store)++          -- | Collecting up what regs were valid across each jump.+          --    in the next pass we can collate these and write the results+          --    to sJumpValid.+        , sJumpValidAcc         :: UniqFM [Assoc Store]++          -- | Map of (slot -> blocks which reload from this slot)+          --    used to decide if whether slot spilled to will ever be+          --    reloaded from on this path.+        , sReloadedBy           :: UniqFM [BlockId]++          -- | Spills and reloads cleaned each pass (latest at front)+        , sCleanedCount         :: [(Int, Int)]++          -- | Spills and reloads that have been cleaned in this pass so far.+        , sCleanedSpillsAcc     :: Int+        , sCleanedReloadsAcc    :: Int }+++-- | Construct the initial cleaner state.+initCleanS :: CleanS+initCleanS+        = CleanS+        { sJumpValid            = emptyUFM+        , sJumpValidAcc         = emptyUFM++        , sReloadedBy           = emptyUFM++        , sCleanedCount         = []++        , sCleanedSpillsAcc     = 0+        , sCleanedReloadsAcc    = 0 }+++-- | Remember the associations before a jump.+accJumpValid :: Assoc Store -> BlockId -> CleanM ()+accJumpValid assocs target+ = modify $ \s -> s {+        sJumpValidAcc = addToUFM_C (++)+                                (sJumpValidAcc s)+                                target+                                [assocs] }+++accBlockReloadsSlot :: BlockId -> Slot -> CleanM ()+accBlockReloadsSlot blockId slot+ = modify $ \s -> s {+        sReloadedBy = addToUFM_C (++)+                                (sReloadedBy s)+                                (SSlot slot)+                                [blockId] }+++-------------------------------------------------------------------------------+-- A store location can be a stack slot or a register+data Store+        = SSlot Int+        | SReg  Reg+++-- | Check if this is a reg store.+isStoreReg :: Store -> Bool+isStoreReg ss+ = case ss of+        SSlot _ -> False+        SReg  _ -> True+++-- Spill cleaning is only done once all virtuals have been allocated to realRegs+instance Uniquable Store where+    getUnique (SReg  r)+        | RegReal (RealRegSingle i)     <- r+        = mkRegSingleUnique i++        | RegReal (RealRegPair r1 r2)   <- r+        = mkRegPairUnique (r1 * 65535 + r2)++        | otherwise+        = error $ "RegSpillClean.getUnique: found virtual reg during spill clean,"+                ++ "only real regs expected."++    getUnique (SSlot i) = mkRegSubUnique i    -- [SLPJ] I hope "SubUnique" is ok+++instance Outputable Store where+        ppr (SSlot i)   = text "slot" <> int i+        ppr (SReg  r)   = ppr r+++-------------------------------------------------------------------------------+-- Association graphs.+-- In the spill cleaner, two store locations are associated if they are known+-- to hold the same value.+--+type Assoc a    = UniqFM (UniqSet a)++-- | An empty association+emptyAssoc :: Assoc a+emptyAssoc      = emptyUFM+++-- | Add an association between these two things.+addAssoc :: Uniquable a+         => a -> a -> Assoc a -> Assoc a++addAssoc a b m+ = let  m1      = addToUFM_C unionUniqSets m  a (unitUniqSet b)+        m2      = addToUFM_C unionUniqSets m1 b (unitUniqSet a)+   in   m2+++-- | Delete all associations to a node.+delAssoc :: (Uniquable a)+         => a -> Assoc a -> Assoc a++delAssoc a m+        | Just aSet     <- lookupUFM  m a+        , m1            <- delFromUFM m a+        = nonDetFoldUniqSet (\x m -> delAssoc1 x a m) m1 aSet+          -- It's OK to use nonDetFoldUFM here because deletion is commutative++        | otherwise     = m+++-- | Delete a single association edge (a -> b).+delAssoc1 :: Uniquable a+          => a -> a -> Assoc a -> Assoc a++delAssoc1 a b m+        | Just aSet     <- lookupUFM m a+        = addToUFM m a (delOneFromUniqSet aSet b)++        | otherwise     = m+++-- | Check if these two things are associated.+elemAssoc :: (Uniquable a)+          => a -> a -> Assoc a -> Bool++elemAssoc a b m+        = elementOfUniqSet b (closeAssoc a m)+++-- | Find the refl. trans. closure of the association from this point.+closeAssoc :: (Uniquable a)+        => a -> Assoc a -> UniqSet a++closeAssoc a assoc+ =      closeAssoc' assoc emptyUniqSet (unitUniqSet a)+ where+        closeAssoc' assoc visited toVisit+         = case nonDetEltsUniqSet toVisit of+             -- See Note [Unique Determinism and code generation]++                -- nothing else to visit, we're done+                []      -> visited++                (x:_)+                 -- we've already seen this node+                 |  elementOfUniqSet x visited+                 -> closeAssoc' assoc visited (delOneFromUniqSet toVisit x)++                 -- haven't seen this node before,+                 --     remember to visit all its neighbors+                 |  otherwise+                 -> let neighbors+                         = case lookupUFM assoc x of+                                Nothing         -> emptyUniqSet+                                Just set        -> set++                   in closeAssoc' assoc+                        (addOneToUniqSet visited x)+                        (unionUniqSets   toVisit neighbors)++-- | Intersect two associations.+intersectAssoc :: Assoc a -> Assoc a -> Assoc a+intersectAssoc a b+        = intersectUFM_C (intersectUniqSets) a b+
+ compiler/nativeGen/RegAlloc/Graph/SpillCost.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE ScopedTypeVariables #-}+module RegAlloc.Graph.SpillCost (+        SpillCostRecord,+        plusSpillCostRecord,+        pprSpillCostRecord,++        SpillCostInfo,+        zeroSpillCostInfo,+        plusSpillCostInfo,++        slurpSpillCostInfo,+        chooseSpill,++        lifeMapFromSpillCostInfo+) where+import GhcPrelude++import RegAlloc.Liveness+import Instruction+import RegClass+import Reg++import GraphBase++import Hoopl.Collections (mapLookup)+import Cmm+import UniqFM+import UniqSet+import Digraph          (flattenSCCs)+import Outputable+import Platform+import State+import CFG++import Data.List        (nub, minimumBy)+import Data.Maybe+import Control.Monad (join)+++-- | Records the expected cost to spill some regster.+type SpillCostRecord+ =      ( VirtualReg    -- register name+        , Int           -- number of writes to this reg+        , Int           -- number of reads from this reg+        , Int)          -- number of instrs this reg was live on entry to+++-- | Map of `SpillCostRecord`+type SpillCostInfo+        = UniqFM SpillCostRecord++-- | Block membership in a loop+type LoopMember = Bool++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)+                $ flattenSCCs sccs++        -- Lookup the regs that are live on entry to this block in+        --      the info table from the CmmProc.+        countBlock info (BasicBlock blockId instrs)+                | LiveInfo _ _ blockLive _ <- info+                , Just rsLiveEntry  <- mapLookup blockId blockLive+                , rsLiveEntry_virt  <- takeVirtuals rsLiveEntry+                = countLIs (loopMember blockId) rsLiveEntry_virt instrs++                | otherwise+                = error "RegAlloc.SpillCost.slurpSpillCostInfo: bad block"++        countLIs :: LoopMember -> UniqSet VirtualReg -> [LiveInstr instr] -> SpillCostState+        countLIs _      _      []+                = return ()++        -- Skip over comment and delta pseudo instrs.+        countLIs inLoop rsLive (LiveInstr instr Nothing : lis)+                | isMetaInstr instr+                = countLIs inLoop rsLive lis++                | otherwise+                = pprPanic "RegSpillCost.slurpSpillCostInfo"+                $ text "no liveness information on instruction " <> ppr instr++        countLIs inLoop rsLiveEntry (LiveInstr instr (Just live) : lis)+         = do+                -- Increment the lifetime counts for regs live on entry to this instr.+                mapM_ (incLifetime (loopCount inLoop)) $ 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 (loopCount inLoop)) $ catMaybes $ map takeVirtualReg $ nub read+                mapM_ (incDefs (loopCount inLoop)) $ 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 inLoop rsLiveNext lis++        loopCount inLoop+          | inLoop = 10+          | otherwise = 1+        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 count reg = modify $ \s -> addToUFM_C plusSpillCostRecord s reg (reg, 0, 0, count)++        loopBlocks = CFG.loopMembers <$> cfg+        loopMember bid+          | Just isMember <- join (mapLookup bid <$> loopBlocks)+          = isMember+          | otherwise+          = False++-- | 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 Reg RegClass Reg+        -> Reg+        -> 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.+        | lifetime > allocatableRegsInClass (regClass reg) * 10+        = 0++        -- Otherwise revert to chaitin's regular cost function.+        | otherwise     = fromIntegral (uses + defs)+                        / fromIntegral (nodeDegree graph reg)+        where (_, defs, uses, lifetime)+                = fromMaybe (reg, 0, 0, 0) $ lookupUFM info reg+-}++-- Just spill the longest live range.+spillCost_length+        :: SpillCostInfo+        -> Graph VirtualReg RegClass RealReg+        -> VirtualReg+        -> Float++spillCost_length info _ reg+        | lifetime <= 1         = 1/0+        | otherwise             = 1 / fromIntegral lifetime+        where (_, _, _, lifetime)+                = fromMaybe (reg, 0, 0, 0)+                $ lookupUFM info reg+++-- | Extract a map of register lifetimes from a `SpillCostInfo`.+lifeMapFromSpillCostInfo :: SpillCostInfo -> UniqFM (VirtualReg, Int)+lifeMapFromSpillCostInfo info+        = listToUFM+        $ map (\(r, _, _, life) -> (r, (r, life)))+        $ nonDetEltsUFM info+        -- See Note [Unique Determinism and code generation]+++-- | Determine the degree (number of neighbors) of this node which+--   have the same class.+nodeDegree+        :: (VirtualReg -> RegClass)+        -> Graph VirtualReg RegClass RealReg+        -> VirtualReg+        -> Int++nodeDegree classOfVirtualReg graph reg+        | Just node     <- lookupUFM (graphMap graph) reg++        , virtConflicts+           <- length+           $ filter (\r -> classOfVirtualReg r == classOfVirtualReg reg)+           $ nonDetEltsUniqSet+           -- See Note [Unique Determinism and code generation]+           $ nodeConflicts node++        = virtConflicts + sizeUniqSet (nodeExclusions node)++        | otherwise+        = 0+++-- | Show a spill cost record, including the degree from the graph+--   and final calulated spill cost.+pprSpillCostRecord+        :: (VirtualReg -> RegClass)+        -> (Reg -> SDoc)+        -> Graph VirtualReg RegClass RealReg+        -> SpillCostRecord+        -> SDoc++pprSpillCostRecord regClass pprReg graph (reg, uses, defs, life)+        =  hsep+        [ pprReg (RegVirtual reg)+        , ppr uses+        , ppr defs+        , ppr life+        , ppr $ nodeDegree regClass graph reg+        , text $ show $ (fromIntegral (uses + defs)+                       / fromIntegral (nodeDegree regClass graph reg) :: Float) ]+
+ compiler/nativeGen/RegAlloc/Graph/Stats.hs view
@@ -0,0 +1,347 @@+{-# LANGUAGE BangPatterns, CPP #-}++-- | Carries interesting info for debugging / profiling of the+--   graph coloring register allocator.+module RegAlloc.Graph.Stats (+        RegAllocStats (..),++        pprStats,+        pprStatsSpills,+        pprStatsLifetimes,+        pprStatsConflict,+        pprStatsLifeConflict,++        countSRMs, addSRM+) where++#include "nativeGen/NCG.h"++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 PprCmm()+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 view
@@ -0,0 +1,271 @@+{-# LANGUAGE CPP #-}++module RegAlloc.Graph.TrivColorable (+        trivColorable,+)++where++#include "HsVersions.h"++import GhcPrelude++import RegClass+import Reg++import GraphBase++import UniqSet+import Platform+import Panic++-- trivColorable ---------------------------------------------------------------++-- trivColorable function for the graph coloring allocator+--+--      This gets hammered by scanGraph during register allocation,+--      so needs to be fairly efficient.+--+--      NOTE:   This only works for arcitectures with just RcInteger and RcDouble+--              (which are disjoint) ie. x86, x86_64 and ppc+--+--      The number of allocatable regs is hard coded in here so we can do+--              a fast comparison in trivColorable.+--+--      It's ok if these numbers are _less_ than the actual number of free+--              regs, but they can't be more or the register conflict+--              graph won't color.+--+--      If the graph doesn't color then the allocator will panic, but it won't+--              generate bad object code or anything nasty like that.+--+--      There is an allocatableRegsInClass :: RegClass -> Int, but doing+--      the unboxing is too slow for us here.+--      TODO: Is that still true? Could we use allocatableRegsInClass+--      without losing performance now?+--+--      Look at includes/stg/MachRegs.h to get the numbers.+--+++-- Disjoint registers ----------------------------------------------------------+--+--      The definition has been unfolded into individual cases for speed.+--      Each architecture has a different register setup, so we use a+--      different regSqueeze function for each.+--+accSqueeze+        :: Int+        -> Int+        -> (reg -> Int)+        -> UniqSet reg+        -> Int++accSqueeze count maxCount squeeze us = acc count (nonDetEltsUniqSet us)+  -- See Note [Unique Determinism and code generation]+  where acc count [] = count+        acc count _ | count >= maxCount = count+        acc count (r:rs) = acc (count + squeeze r) rs++{- Note [accSqueeze]+~~~~~~~~~~~~~~~~~~~~+BL 2007/09+Doing a nice fold over the UniqSet makes trivColorable use+32% of total compile time and 42% of total alloc when compiling SHA1.hs from darcs.+Therefore the UniqFM is made non-abstract and we use custom fold.++MS 2010/04+When converting UniqFM to use Data.IntMap, the fold cannot use UniqFM internal+representation any more. But it is imperative that the accSqueeze stops+the folding if the count gets greater or equal to maxCount. We thus convert+UniqFM to a (lazy) list, do the fold and stops if necessary, which was+the most efficient variant tried. Benchmark compiling 10-times SHA1.hs follows.+(original = previous implementation, folding = fold of the whole UFM,+ lazyFold = the current implementation,+ hackFold = using internal representation of Data.IntMap)++                                 original  folding   hackFold  lazyFold+ -O -fasm (used everywhere)      31.509s   30.387s   30.791s   30.603s+                                 100.00%   96.44%    97.72%    97.12%+ -fregs-graph                    67.938s   74.875s   62.673s   64.679s+                                 100.00%   110.21%   92.25%    95.20%+ -fregs-iterative                89.761s   143.913s  81.075s   86.912s+                                 100.00%   160.33%   90.32%    96.83%+ -fnew-codegen                   38.225s   37.142s   37.551s   37.119s+                                 100.00%   97.17%    98.24%    97.11%+ -fnew-codegen -fregs-graph      91.786s   91.51s    87.368s   86.88s+                                 100.00%   99.70%    95.19%    94.65%+ -fnew-codegen -fregs-iterative  206.72s   343.632s  194.694s  208.677s+                                 100.00%   166.23%   94.18%    100.95%+-}++trivColorable+        :: Platform+        -> (RegClass -> VirtualReg -> Int)+        -> (RegClass -> RealReg    -> Int)+        -> Triv VirtualReg RegClass RealReg++trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions+        | let cALLOCATABLE_REGS_INTEGER+                  =        (case platformArch platform of+                            ArchX86       -> 3+                            ArchX86_64    -> 5+                            ArchPPC       -> 16+                            ArchSPARC     -> 14+                            ArchSPARC64   -> panic "trivColorable ArchSPARC64"+                            ArchPPC_64 _  -> 15+                            ArchARM _ _ _ -> panic "trivColorable ArchARM"+                            ArchARM64     -> panic "trivColorable ArchARM64"+                            ArchAlpha     -> panic "trivColorable ArchAlpha"+                            ArchMipseb    -> panic "trivColorable ArchMipseb"+                            ArchMipsel    -> panic "trivColorable ArchMipsel"+                            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"+                            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"+                            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 view
@@ -0,0 +1,141 @@++-- | Put common type definitions here to break recursive module dependencies.++module RegAlloc.Linear.Base (+        BlockAssignment,++        Loc(..),+        regsOfLoc,++        -- for stats+        SpillReason(..),+        RegAllocStats(..),++        -- the allocator monad+        RA_State(..),+)++where++import GhcPrelude++import RegAlloc.Linear.StackMap+import RegAlloc.Liveness+import Reg++import DynFlags+import Outputable+import Unique+import UniqFM+import UniqSupply+import BlockId+++-- | Used to store the register assignment on entry to a basic block.+--      We use this to handle join points, where multiple branch instructions+--      target a particular label. We have to insert fixup code to make+--      the register assignments from the different sources match up.+--+type BlockAssignment freeRegs+        = BlockMap (freeRegs, RegMap Loc)+++-- | Where a vreg is currently stored+--      A temporary can be marked as living in both a register and memory+--      (InBoth), for example if it was recently loaded from a spill location.+--      This makes it cheap to spill (no save instruction required), but we+--      have to be careful to turn this into InReg if the value in the+--      register is changed.++--      This is also useful when a temporary is about to be clobbered.  We+--      save it in a spill location, but mark it as InBoth because the current+--      instruction might still want to read it.+--+data Loc+        -- | vreg is in a register+        = InReg   !RealReg++        -- | vreg is held in a stack slot+        | InMem   {-# UNPACK #-}  !StackSlot+++        -- | vreg is held in both a register and a stack slot+        | InBoth   !RealReg+                   {-# UNPACK #-} !StackSlot+        deriving (Eq, Show, Ord)++instance Outputable Loc where+        ppr l = text (show l)+++-- | Get the reg numbers stored in this Loc.+regsOfLoc :: Loc -> [RealReg]+regsOfLoc (InReg r)    = [r]+regsOfLoc (InBoth r _) = [r]+regsOfLoc (InMem _)    = []+++-- | Reasons why instructions might be inserted by the spiller.+--      Used when generating stats for -ddrop-asm-stats.+--+data SpillReason+        -- | vreg was spilled to a slot so we could use its+        --      current hreg for another vreg+        = SpillAlloc    !Unique++        -- | vreg was moved because its hreg was clobbered+        | SpillClobber  !Unique++        -- | vreg was loaded from a spill slot+        | SpillLoad     !Unique++        -- | reg-reg move inserted during join to targets+        | SpillJoinRR   !Unique++        -- | reg-mem move inserted during join to targets+        | SpillJoinRM   !Unique+++-- | Used to carry interesting stats out of the register allocator.+data RegAllocStats+        = RegAllocStats+        { ra_spillInstrs        :: UniqFM [Int]+        , ra_fixupList     :: [(BlockId,BlockId,BlockId)]+        -- ^ (from,fixup,to) : We inserted fixup code between from and to+        }+++-- | The register allocator state+data RA_State freeRegs+        = RA_State++        {+        -- | the current mapping from basic blocks to+        --      the register assignments at the beginning of that block.+          ra_blockassig :: BlockAssignment freeRegs++        -- | free machine registers+        , ra_freeregs   :: !freeRegs++        -- | assignment of temps to locations+        , ra_assig      :: RegMap Loc++        -- | current stack delta+        , ra_delta      :: Int++        -- | free stack slots for spilling+        , ra_stack      :: StackMap++        -- | unique supply for generating names for join point fixup blocks.+        , ra_us         :: UniqSupply++        -- | Record why things were spilled, for -ddrop-asm-stats.+        --      Just keep a list here instead of a map of regs -> reasons.+        --      We don't want to slow down the allocator if we're not going to emit the stats.+        , ra_spills     :: [SpillReason]+        , ra_DynFlags   :: DynFlags++        -- | (from,fixup,to) : We inserted fixup code between from and to+        , ra_fixups     :: [(BlockId,BlockId,BlockId)] }++
+ compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE CPP #-}++module RegAlloc.Linear.FreeRegs (+    FR(..),+    maxSpillSlots+)++#include "HsVersions.h"++where++import GhcPrelude++import Reg+import RegClass++import DynFlags+import Panic+import 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+                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 view
@@ -0,0 +1,377 @@++-- | Handles joining of a jump instruction to its targets.++--      The first time we encounter a jump to a particular basic block, we+--      record the assignment of temporaries.  The next time we encounter a+--      jump to the same block, we compare our current assignment to the+--      stored one.  They might be different if spilling has occurred in one+--      branch; so some fixup code will be required to match up the assignments.+--+module RegAlloc.Linear.JoinToTargets (joinToTargets) where++import GhcPrelude++import RegAlloc.Linear.State+import RegAlloc.Linear.Base+import RegAlloc.Linear.FreeRegs+import RegAlloc.Liveness+import Instruction+import Reg++import BlockId+import Hoopl.Collections+import Digraph+import DynFlags+import Outputable+import Unique+import UniqFM+import UniqSet++-- | For a jump instruction at the end of a block, generate fixup code so its+--      vregs are in the correct regs for its destination.+--+joinToTargets+        :: (FR freeRegs, Instruction instr, Outputable instr)+        => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs+                                        --      that are known to be live on the entry to each block.++        -> BlockId                      -- ^ id of the current block+        -> instr                        -- ^ branch instr on the end of the source block.++        -> RegM freeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code.+                         , instr)               -- the original branch+                                                -- instruction, but maybe+                                                -- patched to jump+                                                -- to a fixup block first.++joinToTargets block_live id instr++        -- we only need to worry about jump instructions.+        | not $ isJumpishInstr instr+        = return ([], instr)++        | otherwise+        = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr)++-----+joinToTargets'+        :: (FR freeRegs, Instruction instr, Outputable instr)+        => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs+                                        --      that are known to be live on the entry to each block.++        -> [NatBasicBlock instr]        -- ^ acc blocks of fixup code.++        -> BlockId                      -- ^ id of the current block+        -> instr                        -- ^ branch instr on the end of the source block.++        -> [BlockId]                    -- ^ branch destinations still to consider.++        -> RegM freeRegs ([NatBasicBlock instr], instr)++-- no more targets to consider. all done.+joinToTargets' _          new_blocks _ instr []+        = return (new_blocks, instr)++-- handle a branch target.+joinToTargets' block_live new_blocks block_id instr (dest:dests)+ = do+        -- get the map of where the vregs are stored on entry to each basic block.+        block_assig     <- getBlockAssigR++        -- get the assignment on entry to the branch instruction.+        assig           <- getAssigR++        -- adjust the current assignment to remove any vregs that are not live+        -- on entry to the destination block.+        let Just live_set       = mapLookup dest block_live+        let still_live uniq _   = uniq `elemUniqSet_Directly` live_set+        let adjusted_assig      = filterUFM_Directly still_live assig++        -- and free up those registers which are now free.+        let to_free =+                [ r     | (reg, loc) <- nonDetUFMToList assig+                        -- This is non-deterministic but we do not+                        -- currently support deterministic code-generation.+                        -- See Note [Unique Determinism and code generation]+                        , not (elemUniqSet_Directly reg live_set)+                        , r          <- regsOfLoc loc ]++        case mapLookup dest block_assig of+         Nothing+          -> joinToTargets_first+                        block_live new_blocks block_id instr dest dests+                        block_assig adjusted_assig to_free++         Just (_, dest_assig)+          -> joinToTargets_again+                        block_live new_blocks block_id instr dest dests+                        adjusted_assig dest_assig+++-- this is the first time we jumped to this block.+joinToTargets_first :: (FR freeRegs, Instruction instr, Outputable instr)+                    => BlockMap RegSet+                    -> [NatBasicBlock instr]+                    -> BlockId+                    -> instr+                    -> BlockId+                    -> [BlockId]+                    -> BlockAssignment freeRegs+                    -> RegMap Loc+                    -> [RealReg]+                    -> RegM freeRegs ([NatBasicBlock instr], instr)+joinToTargets_first block_live new_blocks block_id instr dest dests+        block_assig src_assig+        to_free++ = do   dflags <- getDynFlags+        let platform = targetPlatform dflags++        -- free up the regs that are not live on entry to this block.+        freeregs        <- getFreeRegsR+        let freeregs' = foldl' (flip $ frReleaseReg platform) freeregs to_free++        -- remember the current assignment on entry to this block.+        setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig)++        joinToTargets' block_live new_blocks block_id instr dests+++-- we've jumped to this block before+joinToTargets_again :: (Instruction instr, FR freeRegs, Outputable instr)+                    => BlockMap RegSet+                    -> [NatBasicBlock instr]+                    -> BlockId+                    -> instr+                    -> BlockId+                    -> [BlockId]+                    -> UniqFM Loc+                    -> UniqFM Loc+                    -> RegM freeRegs ([NatBasicBlock instr], instr)+joinToTargets_again+    block_live new_blocks block_id instr dest dests+    src_assig dest_assig++        -- the assignments already match, no problem.+        | nonDetUFMToList dest_assig == nonDetUFMToList src_assig+        -- This is non-deterministic but we do not+        -- currently support deterministic code-generation.+        -- See Note [Unique Determinism and code generation]+        = joinToTargets' block_live new_blocks block_id instr dests++        -- assignments don't match, need fixup code+        | otherwise+        = do++                -- make a graph of what things need to be moved where.+                let graph = makeRegMovementGraph src_assig dest_assig++                -- look for cycles in the graph. This can happen if regs need to be swapped.+                -- Note that we depend on the fact that this function does a+                --      bottom up traversal of the tree-like portions of the graph.+                --+                --  eg, if we have+                --      R1 -> R2 -> R3+                --+                --  ie move value in R1 to R2 and value in R2 to R3.+                --+                -- We need to do the R2 -> R3 move before R1 -> R2.+                --+                let sccs  = stronglyConnCompFromEdgedVerticesOrdR graph++              -- debugging+                {-+                pprTrace+                        ("joinToTargets: making fixup code")+                        (vcat   [ text "        in block: "     <> ppr block_id+                                , text " jmp instruction: "     <> ppr instr+                                , text "  src assignment: "     <> ppr src_assig+                                , text " dest assignment: "     <> ppr dest_assig+                                , text "  movement graph: "     <> ppr graph+                                , text "   sccs of graph: "     <> ppr sccs+                                , text ""])+                        (return ())+                -}+                delta           <- getDeltaR+                fixUpInstrs_    <- mapM (handleComponent delta instr) sccs+                let fixUpInstrs = concat fixUpInstrs_++                -- make a new basic block containing the fixup code.+                --      A the end of the current block we will jump to the fixup one,+                --      then that will jump to our original destination.+                fixup_block_id <- mkBlockId <$> getUniqueR+                let block = BasicBlock fixup_block_id+                                $ fixUpInstrs ++ mkJumpInstr dest++                -- if we didn't need any fixups, then don't include the block+                case fixUpInstrs of+                 []     -> joinToTargets' block_live new_blocks block_id instr dests++                 -- patch the original branch instruction so it goes to our+                 --     fixup block instead.+                 _      -> let  instr'  =  patchJumpInstr instr+                                            (\bid -> if bid == dest+                                                        then fixup_block_id+                                                        else bid) -- no change!++                           in do+                                {- --debugging+                                pprTrace "FixUpEdge info:"+                                    (+                                    text "inBlock:" <> ppr block_id $$+                                    text "instr:" <> ppr instr $$+                                    text "instr':" <> ppr instr' $$+                                    text "fixup_block_id':" <>+                                        ppr fixup_block_id $$+                                    text "dest:" <> ppr dest+                                    ) (return ())+                                -}+                                recordFixupBlock block_id fixup_block_id dest+                                joinToTargets' block_live (block : new_blocks)+                                               block_id instr' dests+++-- | Construct a graph of register\/spill movements.+--+--      Cyclic components seem to occur only very rarely.+--+--      We cut some corners by not handling memory-to-memory moves.+--      This shouldn't happen because every temporary gets its own stack slot.+--+makeRegMovementGraph :: RegMap Loc -> RegMap Loc -> [Node Loc Unique]+makeRegMovementGraph adjusted_assig dest_assig+ = [ node       | (vreg, src) <- nonDetUFMToList adjusted_assig+                    -- This is non-deterministic but we do not+                    -- currently support deterministic code-generation.+                    -- See Note [Unique Determinism and code generation]+                    -- source reg might not be needed at the dest:+                , Just loc <- [lookupUFM_Directly dest_assig vreg]+                , node <- expandNode vreg src loc ]+++-- | Expand out the destination, so InBoth destinations turn into+--      a combination of InReg and InMem.++--      The InBoth handling is a little tricky here.  If the destination is+--      InBoth, then we must ensure that the value ends up in both locations.+--      An InBoth  destination must conflict with an InReg or InMem source, so+--      we expand an InBoth destination as necessary.+--+--      An InBoth source is slightly different: we only care about the register+--      that the source value is in, so that we can move it to the destinations.+--+expandNode+        :: a+        -> Loc                  -- ^ source of move+        -> Loc                  -- ^ destination of move+        -> [Node Loc a ]++expandNode vreg loc@(InReg src) (InBoth dst mem)+        | src == dst = [DigraphNode vreg loc [InMem mem]]+        | otherwise  = [DigraphNode vreg loc [InReg dst, InMem mem]]++expandNode vreg loc@(InMem src) (InBoth dst mem)+        | src == mem = [DigraphNode vreg loc [InReg dst]]+        | otherwise  = [DigraphNode vreg loc [InReg dst, InMem mem]]++expandNode _        (InBoth _ src) (InMem dst)+        | src == dst = [] -- guaranteed to be true++expandNode _        (InBoth src _) (InReg dst)+        | src == dst = []++expandNode vreg     (InBoth src _) dst+        = expandNode vreg (InReg src) dst++expandNode vreg src dst+        | src == dst = []+        | otherwise  = [DigraphNode vreg src [dst]]+++-- | Generate fixup code for a particular component in the move graph+--      This component tells us what values need to be moved to what+--      destinations. We have eliminated any possibility of single-node+--      cycles in expandNode above.+--+handleComponent+        :: Instruction instr+        => Int -> instr -> SCC (Node Loc Unique)+        -> RegM freeRegs [instr]++-- If the graph is acyclic then we won't get the swapping problem below.+--      In this case we can just do the moves directly, and avoid having to+--      go via a spill slot.+--+handleComponent delta _  (AcyclicSCC (DigraphNode vreg src dsts))+        = mapM (makeMove delta vreg src) dsts+++-- Handle some cyclic moves.+--      This can happen if we have two regs that need to be swapped.+--      eg:+--           vreg   source loc   dest loc+--          (vreg1, InReg r1,    [InReg r2])+--          (vreg2, InReg r2,    [InReg r1])+--+--      To avoid needing temp register, we just spill all the source regs, then+--      reaload them into their destination regs.+--+--      Note that we can not have cycles that involve memory locations as+--      sources as single destination because memory locations (stack slots)+--      are allocated exclusively for a virtual register and therefore can not+--      require a fixup.+--+handleComponent delta instr+        (CyclicSCC ((DigraphNode vreg (InReg sreg) ((InReg dreg: _))) : rest))+        -- dest list may have more than one element, if the reg is also InMem.+ = do+        -- spill the source into its slot+        (instrSpill, slot)+                        <- spillR (RegReal sreg) vreg++        -- reload into destination reg+        instrLoad       <- loadR (RegReal dreg) slot++        remainingFixUps <- mapM (handleComponent delta instr)+                                (stronglyConnCompFromEdgedVerticesOrdR rest)++        -- make sure to do all the reloads after all the spills,+        --      so we don't end up clobbering the source values.+        return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad])++handleComponent _ _ (CyclicSCC _)+ = panic "Register Allocator: handleComponent cyclic"+++-- | Move a vreg between these two locations.+--+makeMove+    :: Instruction instr+    => Int      -- ^ current C stack delta.+    -> Unique   -- ^ unique of the vreg that we're moving.+    -> Loc      -- ^ source location.+    -> Loc      -- ^ destination location.+    -> RegM freeRegs instr  -- ^ move instruction.++makeMove delta vreg src dst+ = do dflags <- getDynFlags+      let platform = targetPlatform dflags++      case (src, dst) of+          (InReg s, InReg d) ->+              do recordSpill (SpillJoinRR vreg)+                 return $ mkRegRegMoveInstr platform (RegReal s) (RegReal d)+          (InMem s, InReg d) ->+              do recordSpill (SpillJoinRM vreg)+                 return $ mkLoadInstr dflags (RegReal d) delta s+          (InReg s, InMem d) ->+              do recordSpill (SpillJoinRM vreg)+                 return $ mkSpillInstr dflags (RegReal s) delta d+          _ ->+              -- we don't handle memory to memory moves.+              -- they shouldn't happen because we don't share+              -- stack slots between vregs.+              panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("+                  ++ show dst ++ ")"+                  ++ " we don't handle mem->mem moves.")+
+ compiler/nativeGen/RegAlloc/Linear/Main.hs view
@@ -0,0 +1,917 @@+{-# LANGUAGE BangPatterns, CPP, ScopedTypeVariables #-}++-----------------------------------------------------------------------------+--+-- The register allocator+--+-- (c) The University of Glasgow 2004+--+-----------------------------------------------------------------------------++{-+The algorithm is roughly:++  1) Compute strongly connected components of the basic block list.++  2) Compute liveness (mapping from pseudo register to+     point(s) of death?).++  3) Walk instructions in each basic block.  We keep track of+        (a) Free real registers (a bitmap?)+        (b) Current assignment of temporaries to machine registers and/or+            spill slots (call this the "assignment").+        (c) Partial mapping from basic block ids to a virt-to-loc mapping.+            When we first encounter a branch to a basic block,+            we fill in its entry in this table with the current mapping.++     For each instruction:+        (a) For each temporary *read* by the instruction:+            If the temporary does not have a real register allocation:+                - Allocate a real register from the free list.  If+                  the list is empty:+                  - Find a temporary to spill.  Pick one that is+                    not used in this instruction (ToDo: not+                    used for a while...)+                  - generate a spill instruction+                - If the temporary was previously spilled,+                  generate an instruction to read the temp from its spill loc.+            (optimisation: if we can see that a real register is going to+            be used soon, then don't use it for allocation).++        (b) For each real register clobbered by this instruction:+            If a temporary resides in it,+                If the temporary is live after this instruction,+                    Move the temporary to another (non-clobbered & free) reg,+                    or spill it to memory.  Mark the temporary as residing+                    in both memory and a register if it was spilled (it might+                    need to be read by this instruction).++            (ToDo: this is wrong for jump instructions?)++            We do this after step (a), because if we start with+               movq v1, %rsi+            which is an instruction that clobbers %rsi, if v1 currently resides+            in %rsi we want to get+               movq %rsi, %freereg+               movq %rsi, %rsi     -- will disappear+            instead of+               movq %rsi, %freereg+               movq %freereg, %rsi++        (c) Update the current assignment++        (d) If the instruction is a branch:+              if the destination block already has a register assignment,+                Generate a new block with fixup code and redirect the+                jump to the new block.+              else,+                Update the block id->assignment mapping with the current+                assignment.++        (e) Delete all register assignments for temps which are read+            (only) and die here.  Update the free register list.++        (f) Mark all registers clobbered by this instruction as not free,+            and mark temporaries which have been spilled due to clobbering+            as in memory (step (a) marks then as in both mem & reg).++        (g) For each temporary *written* by this instruction:+            Allocate a real register as for (b), spilling something+            else if necessary.+                - except when updating the assignment, drop any memory+                  locations that the temporary was previously in, since+                  they will be no longer valid after this instruction.++        (h) Delete all register assignments for temps which are+            written and die here (there should rarely be any).  Update+            the free register list.++        (i) Rewrite the instruction with the new mapping.++        (j) For each spilled reg known to be now dead, re-add its stack slot+            to the free list.++-}++module RegAlloc.Linear.Main (+        regAlloc,+        module  RegAlloc.Linear.Base,+        module  RegAlloc.Linear.Stats+  ) where++#include "HsVersions.h"+++import GhcPrelude++import RegAlloc.Linear.State+import RegAlloc.Linear.Base+import RegAlloc.Linear.StackMap+import RegAlloc.Linear.FreeRegs+import RegAlloc.Linear.Stats+import RegAlloc.Linear.JoinToTargets+import qualified RegAlloc.Linear.PPC.FreeRegs    as PPC+import qualified RegAlloc.Linear.SPARC.FreeRegs  as SPARC+import qualified RegAlloc.Linear.X86.FreeRegs    as X86+import qualified RegAlloc.Linear.X86_64.FreeRegs as X86_64+import TargetReg+import RegAlloc.Liveness+import Instruction+import Reg++import BlockId+import Hoopl.Collections+import Cmm hiding (RegSet)++import Digraph+import DynFlags+import Unique+import UniqSet+import UniqFM+import UniqSupply+import Outputable+import 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)+      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 CmmPipeline we+                   -- call removeUnreachableBlocks at the end for this+                   -- reason.++                        | otherwise -> doSpill WriteNew+++-- reading is redundant with reason, but we keep it around because it's+-- convenient and it maintains the recursive structure of the allocator. -- EZY+allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, Outputable instr)+                        => Bool+                        -> [VirtualReg]+                        -> [instr]+                        -> [RealReg]+                        -> VirtualReg+                        -> [VirtualReg]+                        -> UniqFM Loc+                        -> SpillLoc+                        -> RegM freeRegs ([instr], [RealReg])+allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc+ = do   dflags <- getDynFlags+        let platform = targetPlatform dflags+        freeRegs                <- getFreeRegsR+        let freeRegs_thisClass  = frGetFreeRegs platform (classOfVirtualReg r) freeRegs++        case freeRegs_thisClass of++         -- case (2): we have a free register+         (my_reg : _) ->+           do   spills'   <- loadTemp r spill_loc my_reg spills++                setAssigR       (addToUFM assig r $! newLocation spill_loc my_reg)+                setFreeRegsR $  frAllocateReg platform my_reg freeRegs++                allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs+++          -- case (3): we need to push something out to free up a register+         [] ->+           do   let inRegOrBoth (InReg _) = True+                    inRegOrBoth (InBoth _ _) = True+                    inRegOrBoth _ = False+                let candidates' =+                      flip delListFromUFM keep $+                      filterUFM inRegOrBoth $+                      assig+                      -- This is non-deterministic but we do not+                      -- currently support deterministic code-generation.+                      -- See Note [Unique Determinism and code generation]+                let candidates = nonDetUFMToList candidates'++                -- the vregs we could kick out that are already in a slot+                let candidates_inBoth+                        = [ (temp, reg, mem)+                          | (temp, InBoth reg mem) <- candidates+                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]++                -- the vregs we could kick out that are only in a reg+                --      this would require writing the reg to a new slot before using it.+                let candidates_inReg+                        = [ (temp, reg)+                          | (temp, InReg reg) <- candidates+                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]++                let result++                        -- we have a temporary that is in both register and mem,+                        -- just free up its register for use.+                        | (temp, my_reg, slot) : _      <- candidates_inBoth+                        = do    spills' <- loadTemp r spill_loc my_reg spills+                                let assig1  = addToUFM assig temp (InMem slot)+                                let assig2  = addToUFM assig1 r $! newLocation spill_loc my_reg++                                setAssigR assig2+                                allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs++                        -- otherwise, we need to spill a temporary that currently+                        -- resides in a register.+                        | (temp_to_push_out, (my_reg :: RealReg)) : _+                                        <- candidates_inReg+                        = do+                                (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out+                                let spill_store  = (if reading then id else reverse)+                                                        [ -- COMMENT (fsLit "spill alloc")+                                                           spill_insn ]++                                -- record that this temp was spilled+                                recordSpill (SpillAlloc temp_to_push_out)++                                -- update the register assignment+                                let assig1  = addToUFM assig temp_to_push_out   (InMem slot)+                                let assig2  = addToUFM assig1 r                 $! newLocation spill_loc my_reg+                                setAssigR assig2++                                -- if need be, load up a spilled temp into the reg we've just freed up.+                                spills' <- loadTemp r spill_loc my_reg spills++                                allocateRegsAndSpill reading keep+                                        (spill_store ++ spills')+                                        (my_reg:alloc) rs+++                        -- there wasn't anything to spill, so we're screwed.+                        | otherwise+                        = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")+                        $ vcat+                                [ text "allocating vreg:  " <> text (show r)+                                , text "assignment:       " <> ppr assig+                                , text "freeRegs:         " <> text (show freeRegs)+                                , text "initFreeRegs:     " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ]++                result+++-- | Calculate a new location after a register has been loaded.+newLocation :: SpillLoc -> RealReg -> Loc+-- if the tmp was read from a slot, then now its in a reg as well+newLocation (ReadMem slot) my_reg = InBoth my_reg slot+-- writes will always result in only the register being available+newLocation _ my_reg = InReg my_reg++-- | Load up a spilled temporary if we need to (read from memory).+loadTemp+        :: (Instruction instr)+        => VirtualReg   -- the temp being loaded+        -> SpillLoc     -- the current location of this temp+        -> RealReg      -- the hreg to load the temp into+        -> [instr]+        -> RegM freeRegs [instr]++loadTemp vreg (ReadMem slot) hreg spills+ = do+        insn <- loadR (RegReal hreg) slot+        recordSpill (SpillLoad $ getUnique vreg)+        return  $  {- COMMENT (fsLit "spill load") : -} insn : spills++loadTemp _ _ _ spills =+   return spills+
+ compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs view
@@ -0,0 +1,61 @@+-- | Free regs map for PowerPC+module RegAlloc.Linear.PPC.FreeRegs+where++import GhcPrelude++import PPC.Regs+import RegClass+import Reg++import Outputable+import 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 view
@@ -0,0 +1,187 @@++-- | Free regs map for SPARC+module RegAlloc.Linear.SPARC.FreeRegs+where++import GhcPrelude++import SPARC.Regs+import RegClass+import Reg++import CodeGen.Platform+import Outputable+import Platform++import Data.Word+import Data.Bits+++--------------------------------------------------------------------------------+-- SPARC is like PPC, except for twinning of floating point regs.+--      When we allocate a double reg we must take an even numbered+--      float reg, as well as the one after it.+++-- Holds bitmaps showing what registers are currently allocated.+--      The float and double reg bitmaps overlap, but we only alloc+--      float regs into the float map, and double regs into the double map.+--+--      Free regs have a bit set in the corresponding bitmap.+--+data FreeRegs+        = FreeRegs+                !Word32         -- int    reg bitmap    regs  0..31+                !Word32         -- float  reg bitmap    regs 32..63+                !Word32         -- double reg bitmap    regs 32..63++instance Show FreeRegs where+        show = showFreeRegs++-- | A reg map where no regs are free to be allocated.+noFreeRegs :: FreeRegs+noFreeRegs = FreeRegs 0 0 0+++-- | The initial set of free regs.+initFreeRegs :: Platform -> FreeRegs+initFreeRegs platform+ =      foldl' (flip $ releaseReg platform) noFreeRegs allocatableRegs+++-- | Get all the free registers of this class.+getFreeRegs :: RegClass -> FreeRegs -> [RealReg]        -- lazily+getFreeRegs cls (FreeRegs g f d)+        | RcInteger <- cls = map RealRegSingle                  $ go 1 g 1 0+        | RcFloat   <- cls = map RealRegSingle                  $ go 1 f 1 32+        | RcDouble  <- cls = map (\i -> RealRegPair i (i+1))    $ go 2 d 1 32+        | otherwise = pprPanic "RegAllocLinear.getFreeRegs: Bad register class " (ppr cls)+        where+                go _    _      0    _+                        = []++                go step bitmap mask ix+                        | bitmap .&. mask /= 0+                        = ix : (go step bitmap (mask `shiftL` step) $! ix + step)++                        | otherwise+                        = go step bitmap (mask `shiftL` step) $! ix + step+++-- | Grab a register.+allocateReg :: Platform -> RealReg -> FreeRegs -> FreeRegs+allocateReg platform+         reg@(RealRegSingle r)+             (FreeRegs g f d)++        -- can't allocate free regs+        | not $ freeReg platform r+        = pprPanic "SPARC.FreeRegs.allocateReg: not allocating pinned reg" (ppr reg)++        -- a general purpose reg+        | r <= 31+        = let   mask    = complement (bitMask r)+          in    FreeRegs+                        (g .&. mask)+                        f+                        d++        -- a float reg+        | r >= 32, r <= 63+        = let   mask    = complement (bitMask (r - 32))++                -- the mask of the double this FP reg aliases+                maskLow = if r `mod` 2 == 0+                                then complement (bitMask (r - 32))+                                else complement (bitMask (r - 32 - 1))+          in    FreeRegs+                        g+                        (f .&. mask)+                        (d .&. maskLow)++        | otherwise+        = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)++allocateReg _+         reg@(RealRegPair r1 r2)+             (FreeRegs g f d)++        | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0+        , r2 >= 32, r2 <= 63+        = let   mask1   = complement (bitMask (r1 - 32))+                mask2   = complement (bitMask (r2 - 32))+          in+                FreeRegs+                        g+                        ((f .&. mask1) .&. mask2)+                        (d .&. mask1)++        | otherwise+        = pprPanic "SPARC.FreeRegs.releaseReg: not allocating bad reg" (ppr reg)++++-- | Release a register from allocation.+--      The register liveness information says that most regs die after a C call,+--      but we still don't want to allocate to some of them.+--+releaseReg :: Platform -> RealReg -> FreeRegs -> FreeRegs+releaseReg platform+         reg@(RealRegSingle r)+        regs@(FreeRegs g f d)++        -- don't release pinned reg+        | not $ freeReg platform r+        = regs++        -- a general purpose reg+        | r <= 31+        = let   mask    = bitMask r+          in    FreeRegs (g .|. mask) f d++        -- a float reg+        | r >= 32, r <= 63+        = let   mask    = bitMask (r - 32)++                -- the mask of the double this FP reg aliases+                maskLow = if r `mod` 2 == 0+                                then bitMask (r - 32)+                                else bitMask (r - 32 - 1)+          in    FreeRegs+                        g+                        (f .|. mask)+                        (d .|. maskLow)++        | otherwise+        = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)++releaseReg _+         reg@(RealRegPair r1 r2)+             (FreeRegs g f d)++        | r1 >= 32, r1 <= 63, r1 `mod` 2 == 0+        , r2 >= 32, r2 <= 63+        = let   mask1   = bitMask (r1 - 32)+                mask2   = bitMask (r2 - 32)+          in+                FreeRegs+                        g+                        ((f .|. mask1) .|. mask2)+                        (d .|. mask1)++        | otherwise+        = pprPanic "SPARC.FreeRegs.releaseReg: not releasing bad reg" (ppr reg)++++bitMask :: Int -> Word32+bitMask n       = 1 `shiftL` n+++showFreeRegs :: FreeRegs -> String+showFreeRegs regs+        =  "FreeRegs\n"+        ++ "    integer: " ++ (show $ getFreeRegs RcInteger regs)       ++ "\n"+        ++ "      float: " ++ (show $ getFreeRegs RcFloat   regs)       ++ "\n"+        ++ "     double: " ++ (show $ getFreeRegs RcDouble  regs)       ++ "\n"+
+ compiler/nativeGen/RegAlloc/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 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 view
@@ -0,0 +1,185 @@+{-# LANGUAGE CPP, PatternSynonyms #-}++#if !defined(GHC_LOADED_INTO_GHCI)+{-# LANGUAGE UnboxedTuples #-}+#endif++-- | State monad for the linear register allocator.++--      Here we keep all the state that the register allocator keeps track+--      of as it walks the instructions in a basic block.++module RegAlloc.Linear.State (+        RA_State(..),+        RegM,+        runR,++        spillR,+        loadR,++        getFreeRegsR,+        setFreeRegsR,++        getAssigR,+        setAssigR,++        getBlockAssigR,+        setBlockAssigR,++        setDeltaR,+        getDeltaR,++        getUniqueR,++        recordSpill,+        recordFixupBlock+)+where++import GhcPrelude++import RegAlloc.Linear.Stats+import RegAlloc.Linear.StackMap+import RegAlloc.Linear.Base+import RegAlloc.Liveness+import Instruction+import Reg+import BlockId++import DynFlags+import Unique+import UniqSupply++import Control.Monad (liftM, 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++#endif++-- | The register allocator monad type.+newtype RegM freeRegs a+        = RegM { unReg :: RA_State freeRegs -> RA_Result freeRegs a }++instance Functor (RegM freeRegs) where+      fmap = liftM++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 view
@@ -0,0 +1,87 @@+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 view
@@ -0,0 +1,53 @@++-- | Free regs map for i386+module RegAlloc.Linear.X86.FreeRegs+where++import GhcPrelude++import X86.Regs+import RegClass+import Reg+import Panic+import 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 view
@@ -0,0 +1,54 @@++-- | 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 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 view
@@ -0,0 +1,1024 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+--+-- The register liveness determinator+--+-- (c) The University of Glasgow 2004-2013+--+-----------------------------------------------------------------------------++module RegAlloc.Liveness (+        RegSet,+        RegMap, emptyRegMap,+        BlockMap, mapEmpty,+        LiveCmmDecl,+        InstrSR   (..),+        LiveInstr (..),+        Liveness (..),+        LiveInfo (..),+        LiveBasicBlock,++        mapBlockTop,    mapBlockTopM,   mapSCCM,+        mapGenBlockTop, mapGenBlockTopM,+        stripLive,+        stripLiveBlock,+        slurpConflicts,+        slurpReloadCoalesce,+        eraseDeltasLive,+        patchEraseLive,+        patchRegsLiveInstr,+        reverseBlocksInTops,+        regLiveness,+        cmmTopLiveness+  ) where+import GhcPrelude++import Reg+import Instruction++import BlockId+import CFG+import Hoopl.Collections+import Hoopl.Label+import Cmm hiding (RegSet, emptyRegSet)+import PprCmm()++import Digraph+import DynFlags+import MonadUtils+import Outputable+import 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.+            = 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/RegClass.hs view
@@ -0,0 +1,32 @@+-- | An architecture independent description of a register's class.+module RegClass+        ( RegClass (..) )++where++import GhcPrelude++import  Outputable+import  Unique+++-- | The class of a register.+--      Used in the register allocator.+--      We treat all registers in a class as being interchangable.+--+data RegClass+        = RcInteger+        | RcFloat+        | RcDouble+        deriving Eq+++instance Uniquable RegClass where+    getUnique RcInteger = mkRegClassUnique 0+    getUnique RcFloat   = mkRegClassUnique 1+    getUnique RcDouble  = mkRegClassUnique 2++instance Outputable RegClass where+    ppr RcInteger       = Outputable.text "I"+    ppr RcFloat         = Outputable.text "F"+    ppr RcDouble        = Outputable.text "D"
+ compiler/nativeGen/SPARC/AddrMode.hs view
@@ -0,0 +1,44 @@++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 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 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 view
@@ -0,0 +1,695 @@+{-# 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"+#include "nativeGen/NCG.h"+#include "../includes/MachDeps.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.Ppr        ()+import SPARC.Instr+import SPARC.Imm+import SPARC.AddrMode+import SPARC.Regs+import SPARC.Stack+import Instruction+import Format+import NCGMonad   ( NatM, getNewRegNat, getNewLabelNat )++-- Our intermediate code:+import BlockId+import Cmm+import CmmUtils+import CmmSwitch+import Hoopl.Block+import Hoopl.Graph+import PIC+import Reg+import CLabel+import CPrim++-- The rest:+import BasicTypes+import DynFlags+import FastString+import OrdList+import Outputable+import 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_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_Log    -> fsLit "logf"+        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_Log    -> fsLit "log"+        MO_F64_Sqrt   -> fsLit "sqrt"+        MO_F64_Fabs   -> unsupported+        MO_F64_Pwr    -> fsLit "pow"++        MO_F64_Sin    -> fsLit "sin"+        MO_F64_Cos    -> fsLit "cos"+        MO_F64_Tan    -> fsLit "tan"++        MO_F64_Asin   -> fsLit "asin"+        MO_F64_Acos   -> fsLit "acos"+        MO_F64_Atan   -> fsLit "atan"++        MO_F64_Sinh   -> fsLit "sinh"+        MO_F64_Cosh   -> fsLit "cosh"+        MO_F64_Tanh   -> fsLit "tanh"++        MO_F64_Asinh  -> fsLit "asinh"+        MO_F64_Acosh  -> fsLit "acosh"+        MO_F64_Atanh  -> fsLit "atanh"++        MO_UF_Conv w -> fsLit $ word2FloatLabel w++        MO_Memcpy _  -> fsLit "memcpy"+        MO_Memset _  -> fsLit "memset"+        MO_Memmove _ -> fsLit "memmove"+        MO_Memcmp _  -> fsLit "memcmp"++        MO_BSwap w   -> fsLit $ bSwapLabel w+        MO_BRev w    -> fsLit $ bRevLabel w+        MO_PopCnt w  -> fsLit $ popCntLabel w+        MO_Pdep w    -> fsLit $ pdepLabel w+        MO_Pext w    -> fsLit $ pextLabel w+        MO_Clz w     -> fsLit $ clzLabel w+        MO_Ctz w     -> fsLit $ ctzLabel w+        MO_AtomicRMW w amop -> fsLit $ atomicRMWLabel w amop+        MO_Cmpxchg w -> fsLit $ cmpxchgLabel w+        MO_AtomicRead w -> fsLit $ atomicReadLabel w+        MO_AtomicWrite w -> fsLit $ atomicWriteLabel w++        MO_S_QuotRem {}  -> unsupported+        MO_U_QuotRem {}  -> unsupported+        MO_U_QuotRem2 {} -> unsupported+        MO_Add2 {}       -> unsupported+        MO_AddWordC {}   -> unsupported+        MO_SubWordC {}   -> unsupported+        MO_AddIntC {}    -> unsupported+        MO_SubIntC {}    -> unsupported+        MO_U_Mul2 {}     -> unsupported+        MO_WriteBarrier  -> unsupported+        MO_Touch         -> unsupported+        (MO_Prefetch_Data _) -> unsupported+    where unsupported = panic ("outOfLineCmmOp: " ++ show mop+                            ++ " not supported here")+
+ compiler/nativeGen/SPARC/CodeGen/Amode.hs view
@@ -0,0 +1,74 @@+module SPARC.CodeGen.Amode (+        getAmode+)++where++import GhcPrelude++import {-# SOURCE #-} SPARC.CodeGen.Gen32+import SPARC.CodeGen.Base+import SPARC.AddrMode+import SPARC.Imm+import SPARC.Instr+import SPARC.Regs+import SPARC.Base+import NCGMonad+import Format++import Cmm++import OrdList+++-- | Generate code to reference a memory address.+getAmode+        :: CmmExpr      -- ^ expr producing an address+        -> NatM Amode++getAmode tree@(CmmRegOff _ _)+    = do dflags <- getDynFlags+         getAmode (mangleIndexTree dflags tree)++getAmode (CmmMachOp (MO_Sub _) [x, CmmLit (CmmInt i _)])+  | fits13Bits (-i)+  = do+       (reg, code) <- getSomeReg x+       let+         off  = ImmInt (-(fromInteger i))+       return (Amode (AddrRegImm reg off) code)+++getAmode (CmmMachOp (MO_Add _) [x, CmmLit (CmmInt i _)])+  | fits13Bits i+  = do+       (reg, code) <- getSomeReg x+       let+         off  = ImmInt (fromInteger i)+       return (Amode (AddrRegImm reg off) code)++getAmode (CmmMachOp (MO_Add _) [x, y])+  = do+    (regX, codeX) <- getSomeReg x+    (regY, codeY) <- getSomeReg y+    let+        code = codeX `appOL` codeY+    return (Amode (AddrRegReg regX regY) code)++getAmode (CmmLit lit)+  = do+        let imm__2      = litToImm lit+        tmp1    <- getNewRegNat II32+        tmp2    <- getNewRegNat II32++        let code = toOL [ SETHI (HI imm__2) tmp1+                        , OR    False tmp1 (RIImm (LO imm__2)) tmp2]++        return (Amode (AddrRegReg tmp2 g0) code)++getAmode other+  = do+       (reg, code) <- getSomeReg other+       let+            off  = ImmInt 0+       return (Amode (AddrRegImm reg off) code)
+ compiler/nativeGen/SPARC/CodeGen/Base.hs view
@@ -0,0 +1,119 @@+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 CodeGen.Platform+import DynFlags+import Cmm+import PprCmmExpr ()+import 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 view
@@ -0,0 +1,110 @@+module SPARC.CodeGen.CondCode (+        getCondCode,+        condIntCode,+        condFltCode+)++where++import GhcPrelude++import {-# SOURCE #-} SPARC.CodeGen.Gen32+import SPARC.CodeGen.Base+import SPARC.Instr+import SPARC.Regs+import SPARC.Cond+import SPARC.Imm+import SPARC.Base+import NCGMonad+import Format++import Cmm++import OrdList+import Outputable+++getCondCode :: CmmExpr -> NatM CondCode+getCondCode (CmmMachOp mop [x, y])+  =+    case mop of+      MO_F_Eq W32 -> condFltCode EQQ x y+      MO_F_Ne W32 -> condFltCode NE  x y+      MO_F_Gt W32 -> condFltCode GTT x y+      MO_F_Ge W32 -> condFltCode GE  x y+      MO_F_Lt W32 -> condFltCode LTT x y+      MO_F_Le W32 -> condFltCode LE  x y++      MO_F_Eq W64 -> condFltCode EQQ x y+      MO_F_Ne W64 -> condFltCode NE  x y+      MO_F_Gt W64 -> condFltCode GTT x y+      MO_F_Ge W64 -> condFltCode GE  x y+      MO_F_Lt W64 -> condFltCode LTT x y+      MO_F_Le W64 -> condFltCode LE  x y++      MO_Eq   _   -> condIntCode EQQ  x y+      MO_Ne   _   -> condIntCode NE   x y++      MO_S_Gt _   -> condIntCode GTT  x y+      MO_S_Ge _   -> condIntCode GE   x y+      MO_S_Lt _   -> condIntCode LTT  x y+      MO_S_Le _   -> condIntCode LE   x y++      MO_U_Gt _   -> condIntCode GU   x y+      MO_U_Ge _   -> condIntCode GEU  x y+      MO_U_Lt _   -> condIntCode LU   x y+      MO_U_Le _   -> condIntCode LEU  x y++      _           -> pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr (CmmMachOp mop [x,y]))++getCondCode other = pprPanic "SPARC.CodeGen.CondCode.getCondCode" (ppr other)++++++-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be+-- passed back up the tree.++condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode+condIntCode cond x (CmmLit (CmmInt y _))+  | fits13Bits y+  = do+       (src1, code) <- getSomeReg x+       let+           src2 = ImmInt (fromInteger y)+           code' = code `snocOL` SUB False True src1 (RIImm src2) g0+       return (CondCode False cond code')++condIntCode cond x y = do+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    let+        code__2 = code1 `appOL` code2 `snocOL`+                  SUB False True src1 (RIReg src2) g0+    return (CondCode False cond code__2)+++condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode+condFltCode cond x y = do+    dflags <- getDynFlags+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    tmp <- getNewRegNat FF64+    let+        promote x = FxTOy FF32 FF64 x tmp++        pk1   = cmmExprType dflags x+        pk2   = cmmExprType dflags y++        code__2 =+                if pk1 `cmmEqType` pk2 then+                    code1 `appOL` code2 `snocOL`+                    FCMP True (cmmTypeFormat pk1) src1 src2+                else if typeWidth pk1 == W32 then+                    code1 `snocOL` promote src1 `appOL` code2 `snocOL`+                    FCMP True FF64 tmp src2+                else+                    code1 `appOL` code2 `snocOL` promote src2 `snocOL`+                    FCMP True FF64 src1 tmp+    return (CondCode True cond code__2)
+ compiler/nativeGen/SPARC/CodeGen/Expand.hs view
@@ -0,0 +1,155 @@+-- | 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 SPARC.Ppr        ()+import Instruction+import Reg+import Format+import Cmm+++import Outputable+import OrdList++-- | Expand out synthetic instructions in this top level thing+expandTop :: NatCmmDecl CmmStatics Instr -> NatCmmDecl CmmStatics Instr+expandTop top@(CmmData{})+        = top++expandTop (CmmProc info lbl live (ListGraph blocks))+        = CmmProc info lbl live (ListGraph $ map expandBlock blocks)+++-- | Expand out synthetic instructions in this block+expandBlock :: NatBasicBlock Instr -> NatBasicBlock Instr++expandBlock (BasicBlock label instrs)+ = let  instrs_ol       = expandBlockInstrs instrs+        instrs'         = fromOL instrs_ol+   in   BasicBlock label instrs'+++-- | Expand out some instructions+expandBlockInstrs :: [Instr] -> OrdList Instr+expandBlockInstrs []    = nilOL++expandBlockInstrs (ii:is)+ = let  ii_doubleRegs   = remapRegPair ii+        is_misaligned   = expandMisalignedDoubles ii_doubleRegs++   in   is_misaligned `appOL` expandBlockInstrs is++++-- | In the SPARC instruction set the FP register pairs that are used+--      to hold 64 bit floats are refered to by just the first reg+--      of the pair. Remap our internal reg pairs to the appropriate reg.+--+--      For example:+--          ldd [%l1], (%f0 | %f1)+--+--      gets mapped to+--          ldd [$l1], %f0+--+remapRegPair :: Instr -> Instr+remapRegPair instr+ = let  patchF reg+         = case reg of+                RegReal (RealRegSingle _)+                        -> reg++                RegReal (RealRegPair r1 r2)++                        -- sanity checking+                        | r1         >= 32+                        , r1         <= 63+                        , r1 `mod` 2 == 0+                        , r2         == r1 + 1+                        -> RegReal (RealRegSingle r1)++                        | otherwise+                        -> pprPanic "SPARC.CodeGen.Expand: not remapping dodgy looking reg pair " (ppr reg)++                RegVirtual _+                        -> pprPanic "SPARC.CodeGen.Expand: not remapping virtual reg " (ppr reg)++   in   patchRegsOfInstr instr patchF+++++-- Expand out 64 bit load/stores into individual instructions to handle+--      possible double alignment problems.+--+--      TODO:   It'd be better to use a scratch reg instead of the add/sub thing.+--              We might be able to do this faster if we use the UA2007 instr set+--              instead of restricting ourselves to SPARC V9.+--+expandMisalignedDoubles :: Instr -> OrdList Instr+expandMisalignedDoubles instr++        -- Translate to:+        --    add g1,g2,g1+        --    ld  [g1],%fn+        --    ld  [g1+4],%f(n+1)+        --    sub g1,g2,g1           -- to restore g1+        | LD FF64 (AddrRegReg r1 r2) fReg       <- instr+        =       toOL    [ ADD False False r1 (RIReg r2) r1+                        , LD  FF32  (AddrRegReg r1 g0)          fReg+                        , LD  FF32  (AddrRegImm r1 (ImmInt 4))  (fRegHi fReg)+                        , SUB False False r1 (RIReg r2) r1 ]++        -- Translate to+        --    ld  [addr],%fn+        --    ld  [addr+4],%f(n+1)+        | LD FF64 addr fReg                     <- instr+        = let   Just addr'      = addrOffset addr 4+          in    toOL    [ LD  FF32  addr        fReg+                        , LD  FF32  addr'       (fRegHi fReg) ]++        -- Translate to:+        --    add g1,g2,g1+        --    st  %fn,[g1]+        --    st  %f(n+1),[g1+4]+        --    sub g1,g2,g1           -- to restore g1+        | ST FF64 fReg (AddrRegReg r1 r2)       <- instr+        =       toOL    [ ADD False False r1 (RIReg r2) r1+                        , ST  FF32  fReg           (AddrRegReg r1 g0)+                        , ST  FF32  (fRegHi fReg)  (AddrRegImm r1 (ImmInt 4))+                        , SUB False False r1 (RIReg r2) r1 ]++        -- Translate to+        --    ld  [addr],%fn+        --    ld  [addr+4],%f(n+1)+        | ST FF64 fReg addr                     <- instr+        = let   Just addr'      = addrOffset addr 4+          in    toOL    [ ST  FF32  fReg           addr+                        , ST  FF32  (fRegHi fReg)  addr'         ]++        -- some other instr+        | otherwise+        = unitOL instr++++-- | The high partner for this float reg.+fRegHi :: Reg -> Reg+fRegHi (RegReal (RealRegSingle r1))+        | r1            >= 32+        , r1            <= 63+        , r1 `mod` 2 == 0+        = (RegReal $ RealRegSingle (r1 + 1))++-- Can't take high partner for non-low reg.+fRegHi reg+        = pprPanic "SPARC.CodeGen.Expand: can't take fRegHi from " (ppr reg)
+ compiler/nativeGen/SPARC/CodeGen/Gen32.hs view
@@ -0,0 +1,692 @@+-- | Evaluation of 32 bit values.+module SPARC.CodeGen.Gen32 (+        getSomeReg,+        getRegister+)++where++import GhcPrelude++import SPARC.CodeGen.CondCode+import SPARC.CodeGen.Amode+import SPARC.CodeGen.Gen64+import SPARC.CodeGen.Base+import SPARC.Stack+import SPARC.Instr+import SPARC.Cond+import SPARC.AddrMode+import SPARC.Imm+import SPARC.Regs+import SPARC.Base+import NCGMonad+import Format+import Reg++import Cmm++import Control.Monad (liftM)+import DynFlags+import OrdList+import Outputable++-- | The dual to getAnyReg: compute an expression into a register, but+--      we don't mind which one it is.+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)+getSomeReg expr = do+  r <- getRegister expr+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, code tmp)+    Fixed _ reg code ->+        return (reg, code)++++-- | Make code to evaluate a 32 bit expression.+--+getRegister :: CmmExpr -> NatM Register++getRegister (CmmReg reg)+  = do dflags <- getDynFlags+       let platform = targetPlatform dflags+       return (Fixed (cmmTypeFormat (cmmRegType dflags reg))+                     (getRegisterReg platform reg) nilOL)++getRegister tree@(CmmRegOff _ _)+  = do dflags <- getDynFlags+       getRegister (mangleIndexTree dflags tree)++getRegister (CmmMachOp (MO_UU_Conv W64 W32)+             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 (getHiVRegFromLo rlo) code++getRegister (CmmMachOp (MO_SS_Conv W64 W32)+             [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 (getHiVRegFromLo rlo) code++getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 rlo code+++-- Load a literal float into a float register.+--      The actual literal is stored in a new data area, and we load it+--      at runtime.+getRegister (CmmLit (CmmFloat f W32)) = do++    -- a label for the new data area+    lbl <- getNewLabelNat+    tmp <- getNewRegNat II32++    let code dst = toOL [+            -- the data area+            LDATA (Section ReadOnlyData lbl) $ Statics lbl+                         [CmmStaticLit (CmmFloat f W32)],++            -- load the literal+            SETHI (HI (ImmCLbl lbl)) tmp,+            LD II32 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]++    return (Any FF32 code)++getRegister (CmmLit (CmmFloat d W64)) = do+    lbl <- getNewLabelNat+    tmp <- getNewRegNat II32+    let code dst = toOL [+            LDATA (Section ReadOnlyData lbl) $ Statics lbl+                         [CmmStaticLit (CmmFloat d W64)],+            SETHI (HI (ImmCLbl lbl)) tmp,+            LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst]+    return (Any FF64 code)+++-- Unary machine ops+getRegister (CmmMachOp mop [x])+  = case mop of+        -- Floating point negation -------------------------+        MO_F_Neg W32            -> trivialUFCode FF32 (FNEG FF32) x+        MO_F_Neg W64            -> trivialUFCode FF64 (FNEG FF64) x+++        -- Integer negation --------------------------------+        MO_S_Neg rep            -> trivialUCode (intFormat rep) (SUB False False g0) x+        MO_Not rep              -> trivialUCode (intFormat rep) (XNOR False g0) x+++        -- Float word size conversion ----------------------+        MO_FF_Conv W64 W32      -> coerceDbl2Flt x+        MO_FF_Conv W32 W64      -> coerceFlt2Dbl x+++        -- Float <-> Signed Int conversion -----------------+        MO_FS_Conv from to      -> coerceFP2Int from to x+        MO_SF_Conv from to      -> coerceInt2FP from to x+++        -- Unsigned integer word size conversions ----------++        -- If it's the same size, then nothing needs to be done.+        MO_UU_Conv from to+         | from == to           -> conversionNop (intFormat to)  x++        -- To narrow an unsigned word, mask out the high bits to simulate what would+        --      happen if we copied the value into a smaller register.+        MO_UU_Conv W16 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))+        MO_UU_Conv W32 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))++        -- for narrowing 32 bit to 16 bit, don't use a literal mask value like the W16->W8+        --      case because the only way we can load it is via SETHI, which needs 2 ops.+        --      Do some shifts to chop out the high bits instead.+        MO_UU_Conv W32 W16+         -> do  tmpReg          <- getNewRegNat II32+                (xReg, xCode)   <- getSomeReg x+                let code dst+                        =       xCode+                        `appOL` toOL+                                [ SLL xReg   (RIImm $ ImmInt 16) tmpReg+                                , SRL tmpReg (RIImm $ ImmInt 16) dst]++                return  $ Any II32 code++                --       trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16))++        -- To widen an unsigned word we don't have to do anything.+        --      Just leave it in the same register and mark the result as the new size.+        MO_UU_Conv W8  W16      -> conversionNop (intFormat W16)  x+        MO_UU_Conv W8  W32      -> conversionNop (intFormat W32)  x+        MO_UU_Conv W16 W32      -> conversionNop (intFormat W32)  x+++        -- Signed integer word size conversions ------------++        -- Mask out high bits when narrowing them+        MO_SS_Conv W16 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))+        MO_SS_Conv W32 W8       -> trivialCode W8  (AND False) x (CmmLit (CmmInt 255 W8))+        MO_SS_Conv W32 W16      -> trivialCode W16 (AND False) x (CmmLit (CmmInt 65535 W16))++        -- Sign extend signed words when widening them.+        MO_SS_Conv W8  W16      -> integerExtend W8  W16 x+        MO_SS_Conv W8  W32      -> integerExtend W8  W32 x+        MO_SS_Conv W16 W32      -> integerExtend W16 W32 x++        _                       -> panic ("Unknown unary mach op: " ++ show mop)+++-- Binary machine ops+getRegister (CmmMachOp mop [x, y])+  = case mop of+      MO_Eq _           -> condIntReg EQQ x y+      MO_Ne _           -> condIntReg NE x y++      MO_S_Gt _         -> condIntReg GTT x y+      MO_S_Ge _         -> condIntReg GE x y+      MO_S_Lt _         -> condIntReg LTT x y+      MO_S_Le _         -> condIntReg LE x y++      MO_U_Gt W32       -> condIntReg GU  x y+      MO_U_Ge W32       -> condIntReg GEU x y+      MO_U_Lt W32       -> condIntReg LU  x y+      MO_U_Le W32       -> condIntReg LEU x y++      MO_U_Gt W16       -> condIntReg GU  x y+      MO_U_Ge W16       -> condIntReg GEU x y+      MO_U_Lt W16       -> condIntReg LU  x y+      MO_U_Le W16       -> condIntReg LEU x y++      MO_Add W32        -> trivialCode W32 (ADD False False) x y+      MO_Sub W32        -> trivialCode W32 (SUB False False) x y++      MO_S_MulMayOflo rep -> imulMayOflo rep x y++      MO_S_Quot W32     -> idiv True  False x y+      MO_U_Quot W32     -> idiv False False x y++      MO_S_Rem  W32     -> irem True  x y+      MO_U_Rem  W32     -> irem False x y++      MO_F_Eq _         -> condFltReg EQQ x y+      MO_F_Ne _         -> condFltReg NE x y++      MO_F_Gt _         -> condFltReg GTT x y+      MO_F_Ge _         -> condFltReg GE x y+      MO_F_Lt _         -> condFltReg LTT x y+      MO_F_Le _         -> condFltReg LE x y++      MO_F_Add  w       -> trivialFCode w FADD x y+      MO_F_Sub  w       -> trivialFCode w FSUB x y+      MO_F_Mul  w       -> trivialFCode w FMUL x y+      MO_F_Quot w       -> trivialFCode w FDIV x y++      MO_And rep        -> trivialCode rep (AND False) x y+      MO_Or  rep        -> trivialCode rep (OR  False) x y+      MO_Xor rep        -> trivialCode rep (XOR False) x y++      MO_Mul rep        -> trivialCode rep (SMUL False) x y++      MO_Shl rep        -> trivialCode rep SLL  x y+      MO_U_Shr rep      -> trivialCode rep SRL x y+      MO_S_Shr rep      -> trivialCode rep SRA x y++      _                 -> pprPanic "getRegister(sparc) - binary CmmMachOp (1)" (pprMachOp mop)++getRegister (CmmLoad mem pk) = do+    Amode src code <- getAmode mem+    let+        code__2 dst     = code `snocOL` LD (cmmTypeFormat pk) src dst+    return (Any (cmmTypeFormat pk) code__2)++getRegister (CmmLit (CmmInt i _))+  | fits13Bits i+  = let+        src = ImmInt (fromInteger i)+        code dst = unitOL (OR False g0 (RIImm src) dst)+    in+        return (Any II32 code)++getRegister (CmmLit lit)+  = let imm = litToImm lit+        code dst = toOL [+            SETHI (HI imm) dst,+            OR False dst (RIImm (LO imm)) dst]+    in return (Any II32 code)+++getRegister _+        = panic "SPARC.CodeGen.Gen32.getRegister: no match"+++-- | sign extend and widen+integerExtend+        :: Width                -- ^ width of source expression+        -> Width                -- ^ width of result+        -> CmmExpr              -- ^ source expression+        -> NatM Register++integerExtend from to expr+ = do   -- load the expr into some register+        (reg, e_code)   <- getSomeReg expr+        tmp             <- getNewRegNat II32+        let bitCount+                = case (from, to) of+                        (W8,  W32)      -> 24+                        (W16, W32)      -> 16+                        (W8,  W16)      -> 24+                        _               -> panic "SPARC.CodeGen.Gen32: no match"+        let code dst+                = e_code++                -- local shift word left to load the sign bit+                `snocOL`  SLL reg (RIImm (ImmInt bitCount)) tmp++                -- arithmetic shift right to sign extend+                `snocOL`  SRA tmp (RIImm (ImmInt bitCount)) dst++        return (Any (intFormat to) code)+++-- | For nop word format conversions we set the resulting value to have the+--      required size, but don't need to generate any actual code.+--+conversionNop+        :: Format -> CmmExpr -> NatM Register++conversionNop new_rep expr+ = do   e_code <- getRegister expr+        return (setFormatOfRegister e_code new_rep)++++-- | Generate an integer division instruction.+idiv :: Bool -> Bool -> CmmExpr -> CmmExpr -> NatM Register++-- For unsigned division with a 32 bit numerator,+--              we can just clear the Y register.+idiv False cc x y+ = do+        (a_reg, a_code)         <- getSomeReg x+        (b_reg, b_code)         <- getSomeReg y++        let code dst+                =       a_code+                `appOL` b_code+                `appOL` toOL+                        [ WRY  g0 g0+                        , UDIV cc a_reg (RIReg b_reg) dst]++        return (Any II32 code)+++-- For _signed_ division with a 32 bit numerator,+--              we have to sign extend the numerator into the Y register.+idiv True cc x y+ = do+        (a_reg, a_code)         <- getSomeReg x+        (b_reg, b_code)         <- getSomeReg y++        tmp                     <- getNewRegNat II32++        let code dst+                =       a_code+                `appOL` b_code+                `appOL` toOL+                        [ SRA  a_reg (RIImm (ImmInt 16)) tmp            -- sign extend+                        , SRA  tmp   (RIImm (ImmInt 16)) tmp++                        , WRY  tmp g0+                        , SDIV cc a_reg (RIReg b_reg) dst]++        return (Any II32 code)+++-- | Do an integer remainder.+--+--       NOTE:  The SPARC v8 architecture manual says that integer division+--              instructions _may_ generate a remainder, depending on the implementation.+--              If so it is _recommended_ that the remainder is placed in the Y register.+--+--          The UltraSparc 2007 manual says Y is _undefined_ after division.+--+--              The SPARC T2 doesn't store the remainder, not sure about the others.+--              It's probably best not to worry about it, and just generate our own+--              remainders.+--+irem :: Bool -> CmmExpr -> CmmExpr -> NatM Register++-- For unsigned operands:+--              Division is between a 64 bit numerator and a 32 bit denominator,+--              so we still have to clear the Y register.+irem False x y+ = do+        (a_reg, a_code) <- getSomeReg x+        (b_reg, b_code) <- getSomeReg y++        tmp_reg         <- getNewRegNat II32++        let code dst+                =       a_code+                `appOL` b_code+                `appOL` toOL+                        [ WRY   g0 g0+                        , UDIV  False         a_reg (RIReg b_reg) tmp_reg+                        , UMUL  False       tmp_reg (RIReg b_reg) tmp_reg+                        , SUB   False False   a_reg (RIReg tmp_reg) dst]++        return  (Any II32 code)++++-- For signed operands:+--              Make sure to sign extend into the Y register, or the remainder+--              will have the wrong sign when the numerator is negative.+--+--      TODO:   When sign extending, GCC only shifts the a_reg right by 17 bits,+--              not the full 32. Not sure why this is, something to do with overflow?+--              If anyone cares enough about the speed of signed remainder they+--              can work it out themselves (then tell me). -- BL 2009/01/20+irem True x y+ = do+        (a_reg, a_code) <- getSomeReg x+        (b_reg, b_code) <- getSomeReg y++        tmp1_reg        <- getNewRegNat II32+        tmp2_reg        <- getNewRegNat II32++        let code dst+                =       a_code+                `appOL` b_code+                `appOL` toOL+                        [ SRA   a_reg      (RIImm (ImmInt 16)) tmp1_reg -- sign extend+                        , SRA   tmp1_reg   (RIImm (ImmInt 16)) tmp1_reg -- sign extend+                        , WRY   tmp1_reg g0++                        , SDIV  False          a_reg (RIReg b_reg)    tmp2_reg+                        , SMUL  False       tmp2_reg (RIReg b_reg)    tmp2_reg+                        , SUB   False False    a_reg (RIReg tmp2_reg) dst]++        return (Any II32 code)+++imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+imulMayOflo rep a b+ = do+        (a_reg, a_code) <- getSomeReg a+        (b_reg, b_code) <- getSomeReg b+        res_lo <- getNewRegNat II32+        res_hi <- getNewRegNat II32++        let shift_amt  = case rep of+                          W32 -> 31+                          W64 -> 63+                          _ -> panic "shift_amt"++        let code dst = a_code `appOL` b_code `appOL`+                       toOL [+                           SMUL False a_reg (RIReg b_reg) res_lo,+                           RDY res_hi,+                           SRA res_lo (RIImm (ImmInt shift_amt)) res_lo,+                           SUB False False res_lo (RIReg res_hi) dst+                        ]+        return (Any II32 code)+++-- -----------------------------------------------------------------------------+-- 'trivial*Code': deal with trivial instructions++-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',+-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.+-- Only look for constants on the right hand side, because that's+-- where the generic optimizer will have put them.++-- Similarly, for unary instructions, we don't have to worry about+-- matching an StInt as the argument, because genericOpt will already+-- have handled the constant-folding.++trivialCode+        :: Width+        -> (Reg -> RI -> Reg -> Instr)+        -> CmmExpr+        -> CmmExpr+        -> NatM Register++trivialCode _ instr x (CmmLit (CmmInt y _))+  | fits13Bits y+  = do+      (src1, code) <- getSomeReg x+      let+        src2 = ImmInt (fromInteger y)+        code__2 dst = code `snocOL` instr src1 (RIImm src2) dst+      return (Any II32 code__2)+++trivialCode _ instr x y = do+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    let+        code__2 dst = code1 `appOL` code2 `snocOL`+                      instr src1 (RIReg src2) dst+    return (Any II32 code__2)+++trivialFCode+        :: Width+        -> (Format -> Reg -> Reg -> Reg -> Instr)+        -> CmmExpr+        -> CmmExpr+        -> NatM Register++trivialFCode pk instr x y = do+    dflags <- getDynFlags+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    tmp <- getNewRegNat FF64+    let+        promote x = FxTOy FF32 FF64 x tmp++        pk1   = cmmExprType dflags x+        pk2   = cmmExprType dflags y++        code__2 dst =+                if pk1 `cmmEqType` pk2 then+                    code1 `appOL` code2 `snocOL`+                    instr (floatFormat pk) src1 src2 dst+                else if typeWidth pk1 == W32 then+                    code1 `snocOL` promote src1 `appOL` code2 `snocOL`+                    instr FF64 tmp src2 dst+                else+                    code1 `appOL` code2 `snocOL` promote src2 `snocOL`+                    instr FF64 src1 tmp dst+    return (Any (cmmTypeFormat $ if pk1 `cmmEqType` pk2 then pk1 else cmmFloat W64)+                code__2)++++trivialUCode+        :: Format+        -> (RI -> Reg -> Instr)+        -> CmmExpr+        -> NatM Register++trivialUCode format instr x = do+    (src, code) <- getSomeReg x+    let+        code__2 dst = code `snocOL` instr (RIReg src) dst+    return (Any format code__2)+++trivialUFCode+        :: Format+        -> (Reg -> Reg -> Instr)+        -> CmmExpr+        -> NatM Register++trivialUFCode pk instr x = do+    (src, code) <- getSomeReg x+    let+        code__2 dst = code `snocOL` instr src dst+    return (Any pk code__2)+++++-- Coercions -------------------------------------------------------------------++-- | Coerce a integer value to floating point+coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register+coerceInt2FP width1 width2 x = do+    (src, code) <- getSomeReg x+    let+        code__2 dst = code `appOL` toOL [+            ST (intFormat width1) src (spRel (-2)),+            LD (intFormat width1) (spRel (-2)) dst,+            FxTOy (intFormat width1) (floatFormat width2) dst dst]+    return (Any (floatFormat $ width2) code__2)++++-- | Coerce a floating point value to integer+--+--   NOTE: On sparc v9 there are no instructions to move a value from an+--         FP register directly to an int register, so we have to use a load/store.+--+coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register+coerceFP2Int width1 width2 x+ = do   let fformat1      = floatFormat width1+            fformat2      = floatFormat width2++            iformat2      = intFormat   width2++        (fsrc, code)    <- getSomeReg x+        fdst            <- getNewRegNat fformat2++        let code2 dst+                =       code+                `appOL` toOL+                        -- convert float to int format, leaving it in a float reg.+                        [ FxTOy fformat1 iformat2 fsrc fdst++                        -- store the int into mem, then load it back to move+                        --      it into an actual int reg.+                        , ST    fformat2 fdst (spRel (-2))+                        , LD    iformat2 (spRel (-2)) dst]++        return (Any iformat2 code2)+++-- | Coerce a double precision floating point value to single precision.+coerceDbl2Flt :: CmmExpr -> NatM Register+coerceDbl2Flt x = do+    (src, code) <- getSomeReg x+    return (Any FF32 (\dst -> code `snocOL` FxTOy FF64 FF32 src dst))+++-- | Coerce a single precision floating point value to double precision+coerceFlt2Dbl :: CmmExpr -> NatM Register+coerceFlt2Dbl x = do+    (src, code) <- getSomeReg x+    return (Any FF64 (\dst -> code `snocOL` FxTOy FF32 FF64 src dst))+++++-- Condition Codes -------------------------------------------------------------+--+-- Evaluate a comparison, and get the result into a register.+--+-- Do not fill the delay slots here. you will confuse the register allocator.+--+condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register+condIntReg EQQ x (CmmLit (CmmInt 0 _)) = do+    (src, code) <- getSomeReg x+    let+        code__2 dst = code `appOL` toOL [+            SUB False True g0 (RIReg src) g0,+            SUB True False g0 (RIImm (ImmInt (-1))) dst]+    return (Any II32 code__2)++condIntReg EQQ x y = do+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    let+        code__2 dst = code1 `appOL` code2 `appOL` toOL [+            XOR False src1 (RIReg src2) dst,+            SUB False True g0 (RIReg dst) g0,+            SUB True False g0 (RIImm (ImmInt (-1))) dst]+    return (Any II32 code__2)++condIntReg NE x (CmmLit (CmmInt 0 _)) = do+    (src, code) <- getSomeReg x+    let+        code__2 dst = code `appOL` toOL [+            SUB False True g0 (RIReg src) g0,+            ADD True False g0 (RIImm (ImmInt 0)) dst]+    return (Any II32 code__2)++condIntReg NE x y = do+    (src1, code1) <- getSomeReg x+    (src2, code2) <- getSomeReg y+    let+        code__2 dst = code1 `appOL` code2 `appOL` toOL [+            XOR False src1 (RIReg src2) dst,+            SUB False True g0 (RIReg dst) g0,+            ADD True False g0 (RIImm (ImmInt 0)) dst]+    return (Any II32 code__2)++condIntReg cond x y = do+    bid1 <- liftM (\a -> seq a a) getBlockIdNat+    bid2 <- liftM (\a -> seq a a) getBlockIdNat+    CondCode _ cond cond_code <- condIntCode cond x y+    let+        code__2 dst+         =      cond_code+          `appOL` toOL+                [ BI cond False bid1+                , NOP++                , OR False g0 (RIImm (ImmInt 0)) dst+                , BI ALWAYS False bid2+                , NOP++                , NEWBLOCK bid1+                , OR False g0 (RIImm (ImmInt 1)) dst+                , BI ALWAYS False bid2+                , NOP++                , NEWBLOCK bid2]++    return (Any II32 code__2)+++condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register+condFltReg cond x y = do+    bid1 <- liftM (\a -> seq a a) getBlockIdNat+    bid2 <- liftM (\a -> seq a a) getBlockIdNat++    CondCode _ cond cond_code <- condFltCode cond x y+    let+        code__2 dst+         =      cond_code+          `appOL` toOL+                [ NOP+                , BF cond False bid1+                , NOP++                , OR False g0 (RIImm (ImmInt 0)) dst+                , BI ALWAYS False bid2+                , NOP++                , NEWBLOCK bid1+                , OR False g0 (RIImm (ImmInt 1)) dst+                , BI ALWAYS False bid2+                , NOP++                , NEWBLOCK bid2 ]++    return (Any II32 code__2)
+ compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot view
@@ -0,0 +1,16 @@++module SPARC.CodeGen.Gen32 (+        getSomeReg,+        getRegister+)++where++import SPARC.CodeGen.Base+import NCGMonad+import Reg++import Cmm++getSomeReg  :: CmmExpr -> NatM (Reg, InstrBlock)+getRegister :: CmmExpr -> NatM Register
+ compiler/nativeGen/SPARC/CodeGen/Gen64.hs view
@@ -0,0 +1,216 @@+-- | Evaluation of 64 bit values on 32 bit platforms.+module SPARC.CodeGen.Gen64 (+        assignMem_I64Code,+        assignReg_I64Code,+        iselExpr64+)++where++import GhcPrelude++import {-# SOURCE #-} SPARC.CodeGen.Gen32+import SPARC.CodeGen.Base+import SPARC.CodeGen.Amode+import SPARC.Regs+import SPARC.AddrMode+import SPARC.Imm+import SPARC.Instr+import SPARC.Ppr()+import NCGMonad+import Instruction+import Format+import Reg++import Cmm++import DynFlags+import OrdList+import Outputable++-- | Code to assign a 64 bit value to memory.+assignMem_I64Code+        :: CmmExpr              -- ^ expr producing the destination address+        -> CmmExpr              -- ^ expr producing the source value.+        -> NatM InstrBlock++assignMem_I64Code addrTree valueTree+ = do+     ChildCode64 vcode rlo      <- iselExpr64 valueTree++     (src, acode) <- getSomeReg addrTree+     let+         rhi = getHiVRegFromLo rlo++         -- Big-endian store+         mov_hi = ST II32 rhi (AddrRegImm src (ImmInt 0))+         mov_lo = ST II32 rlo (AddrRegImm src (ImmInt 4))++         code   = vcode `appOL` acode `snocOL` mov_hi `snocOL` mov_lo++{-     pprTrace "assignMem_I64Code"+        (vcat   [ text "addrTree:  " <+> ppr addrTree+                , text "valueTree: " <+> ppr valueTree+                , text "vcode:"+                , vcat $ map ppr $ fromOL vcode+                , text ""+                , text "acode:"+                , vcat $ map ppr $ fromOL acode ])+       $ -}+     return code+++-- | Code to assign a 64 bit value to a register.+assignReg_I64Code+        :: CmmReg               -- ^ the destination register+        -> CmmExpr              -- ^ expr producing the source value+        -> NatM InstrBlock++assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree+ = do+     ChildCode64 vcode r_src_lo <- iselExpr64 valueTree+     let+         r_dst_lo = RegVirtual $ mkVirtualReg u_dst (cmmTypeFormat pk)+         r_dst_hi = getHiVRegFromLo r_dst_lo+         r_src_hi = getHiVRegFromLo r_src_lo+         mov_lo = mkMOV r_src_lo r_dst_lo+         mov_hi = mkMOV r_src_hi r_dst_hi+         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg++     return (vcode `snocOL` mov_hi `snocOL` mov_lo)++assignReg_I64Code _ _+   = panic "assignReg_I64Code(sparc): invalid lvalue"+++++-- | Get the value of an expression into a 64 bit register.++iselExpr64 :: CmmExpr -> NatM ChildCode64++-- Load a 64 bit word+iselExpr64 (CmmLoad addrTree ty)+ | isWord64 ty+ = do   Amode amode addr_code   <- getAmode addrTree+        let result++                | AddrRegReg r1 r2      <- amode+                = do    rlo     <- getNewRegNat II32+                        tmp     <- getNewRegNat II32+                        let rhi = getHiVRegFromLo rlo++                        return  $ ChildCode64+                                (        addr_code+                                `appOL`  toOL+                                         [ ADD False False r1 (RIReg r2) tmp+                                         , LD II32 (AddrRegImm tmp (ImmInt 0)) rhi+                                         , LD II32 (AddrRegImm tmp (ImmInt 4)) rlo ])+                                rlo++                | AddrRegImm r1 (ImmInt i) <- amode+                = do    rlo     <- getNewRegNat II32+                        let rhi = getHiVRegFromLo rlo++                        return  $ ChildCode64+                                (        addr_code+                                `appOL`  toOL+                                         [ LD II32 (AddrRegImm r1 (ImmInt $ 0 + i)) rhi+                                         , LD II32 (AddrRegImm r1 (ImmInt $ 4 + i)) rlo ])+                                rlo++                | otherwise+                = panic "SPARC.CodeGen.Gen64: no match"++        result+++-- Add a literal to a 64 bit integer+iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)])+ = do   ChildCode64 code1 r1_lo <- iselExpr64 e1+        let r1_hi       = getHiVRegFromLo r1_lo++        r_dst_lo        <- getNewRegNat II32+        let r_dst_hi    =  getHiVRegFromLo r_dst_lo++        let code =      code1+                `appOL` toOL+                        [ ADD False True  r1_lo (RIImm (ImmInteger i)) r_dst_lo+                        , ADD True  False r1_hi (RIReg g0)         r_dst_hi ]++        return  $ ChildCode64 code r_dst_lo+++-- Addition of II64+iselExpr64 (CmmMachOp (MO_Add _) [e1, e2])+ = do   ChildCode64 code1 r1_lo <- iselExpr64 e1+        let r1_hi       = getHiVRegFromLo r1_lo++        ChildCode64 code2 r2_lo <- iselExpr64 e2+        let r2_hi       = getHiVRegFromLo r2_lo++        r_dst_lo        <- getNewRegNat II32+        let r_dst_hi    = getHiVRegFromLo r_dst_lo++        let code =      code1+                `appOL` code2+                `appOL` toOL+                        [ ADD False True  r1_lo (RIReg r2_lo) r_dst_lo+                        , ADD True  False r1_hi (RIReg r2_hi) r_dst_hi ]++        return  $ ChildCode64 code r_dst_lo+++iselExpr64 (CmmReg (CmmLocal (LocalReg uq ty)))+ | isWord64 ty+ = do+     r_dst_lo <-  getNewRegNat II32+     let r_dst_hi = getHiVRegFromLo r_dst_lo+         r_src_lo = RegVirtual $ mkVirtualReg uq II32+         r_src_hi = getHiVRegFromLo r_src_lo+         mov_lo = mkMOV r_src_lo r_dst_lo+         mov_hi = mkMOV r_src_hi r_dst_hi+         mkMOV sreg dreg = OR False g0 (RIReg sreg) dreg+     return (+            ChildCode64 (toOL [mov_hi, mov_lo]) r_dst_lo+         )++-- Convert something into II64+iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr])+ = do+        r_dst_lo        <- getNewRegNat II32+        let r_dst_hi    = getHiVRegFromLo r_dst_lo++        -- compute expr and load it into r_dst_lo+        (a_reg, a_code) <- getSomeReg expr++        dflags <- getDynFlags+        let platform = targetPlatform dflags+            code        = a_code+                `appOL` toOL+                        [ mkRegRegMoveInstr platform g0    r_dst_hi     -- clear high 32 bits+                        , mkRegRegMoveInstr platform a_reg r_dst_lo ]++        return  $ ChildCode64 code r_dst_lo++-- only W32 supported for now+iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr])+ = do+        r_dst_lo        <- getNewRegNat II32+        let r_dst_hi    = getHiVRegFromLo r_dst_lo++        -- compute expr and load it into r_dst_lo+        (a_reg, a_code) <- getSomeReg expr++        dflags          <- getDynFlags+        let platform    = targetPlatform dflags+            code        = a_code+                `appOL` toOL+                        [ SRA a_reg (RIImm (ImmInt 31)) r_dst_hi+                        , mkRegRegMoveInstr platform a_reg r_dst_lo ]++        return  $ ChildCode64 code r_dst_lo+++iselExpr64 expr+   = pprPanic "iselExpr64(sparc)" (ppr expr)
+ compiler/nativeGen/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 SPARC.CodeGen.Sanity (+        checkBlock+)++where++import GhcPrelude++import SPARC.Instr+import SPARC.Ppr        ()+import Instruction++import Cmm++import Outputable+++-- | Enforce intra-block invariants.+--+checkBlock :: CmmBlock+           -> NatBasicBlock Instr+           -> NatBasicBlock Instr++checkBlock cmm block@(BasicBlock _ instrs)+        | checkBlockInstrs instrs+        = block++        | otherwise+        = pprPanic+                ("SPARC.CodeGen: bad block\n")+                ( vcat  [ text " -- cmm -----------------\n"+                        , ppr cmm+                        , text " -- native code ---------\n"+                        , ppr block ])+++checkBlockInstrs :: [Instr] -> Bool+checkBlockInstrs ii++        -- An unconditional jumps end the block.+        --      There must be an unconditional jump in the block, otherwise+        --      the register liveness determinator will get the liveness+        --      information wrong.+        --+        --      If the block ends with a cmm call that never returns+        --      then there can be unreachable instructions after the jump,+        --      but we don't mind here.+        --+        | instr : NOP : _       <- ii+        , isUnconditionalJump instr+        = True++        -- All jumps must have a NOP in their branch delay slot.+        --      The liveness determinator and register allocators aren't smart+        --      enough to handle branch delay slots.+        --+        | instr : NOP : is      <- ii+        , isJumpishInstr instr+        = checkBlockInstrs is++        -- keep checking+        | _:i2:is               <- ii+        = checkBlockInstrs (i2:is)++        -- this block is no good+        | otherwise+        = False
+ compiler/nativeGen/SPARC/Cond.hs view
@@ -0,0 +1,54 @@+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 view
@@ -0,0 +1,67 @@+module SPARC.Imm (+        -- immediate values+        Imm(..),+        strImmLit,+        litToImm+)++where++import GhcPrelude++import Cmm+import CLabel++import Outputable++-- | An immediate value.+--      Not all of these are directly representable by the machine.+--      Things like ImmLit are slurped out and put in a data segment instead.+--+data Imm+        = ImmInt        Int++        -- Sigh.+        | ImmInteger    Integer++        -- AbstractC Label (with baggage)+        | ImmCLbl       CLabel++        -- Simple string+        | ImmLit        SDoc+        | ImmIndex      CLabel Int+        | ImmFloat      Rational+        | ImmDouble     Rational++        | ImmConstantSum  Imm Imm+        | ImmConstantDiff Imm Imm++        | LO    Imm+        | HI    Imm+++-- | Create a ImmLit containing this string.+strImmLit :: String -> Imm+strImmLit s = ImmLit (text s)+++-- | Convert a CmmLit to an Imm.+--      Narrow to the width: a CmmInt might be out of+--      range, but we assume that ImmInteger only contains+--      in-range values.  A signed value should be fine here.+--+litToImm :: CmmLit -> Imm+litToImm lit+ = case lit of+        CmmInt i w              -> ImmInteger (narrowS w i)+        CmmFloat f W32          -> ImmFloat f+        CmmFloat f W64          -> ImmDouble f+        CmmLabel l              -> ImmCLbl l+        CmmLabelOff l off       -> ImmIndex l off++        CmmLabelDiffOff l1 l2 off _+         -> ImmConstantSum+                (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))+                (ImmInt off)++        _               -> panic "SPARC.Regs.litToImm: no match"
+ compiler/nativeGen/SPARC/Instr.hs view
@@ -0,0 +1,482 @@+{-# LANGUAGE CPP #-}++-----------------------------------------------------------------------------+--+-- Machine-dependent assembly language+--+-- (c) The University of Glasgow 1993-2004+--+-----------------------------------------------------------------------------+#include "HsVersions.h"+#include "nativeGen/NCG.h"++module SPARC.Instr (+        RI(..),+        riZero,++        fpRelEA,+        moveSp,++        isUnconditionalJump,++        Instr(..),+        maxSpillSlots+)++where++import GhcPrelude++import SPARC.Stack+import SPARC.Imm+import SPARC.AddrMode+import SPARC.Cond+import SPARC.Regs+import SPARC.Base+import TargetReg+import Instruction+import RegClass+import Reg+import Format++import CLabel+import CodeGen.Platform+import BlockId+import DynFlags+import Cmm+import FastString+import Outputable+import 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 view
@@ -0,0 +1,646 @@+{-# 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"+#include "nativeGen/NCG.h"++import GhcPrelude++import SPARC.Regs+import SPARC.Instr+import SPARC.Cond+import SPARC.Imm+import SPARC.AddrMode+import SPARC.Base+import Instruction+import Reg+import Format+import PprBase++import Cmm hiding (topInfoTable)+import PprCmm()+import BlockId+import CLabel+import Hoopl.Label+import Hoopl.Collections++import Unique           ( pprUniqueAlways )+import Outputable+import 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 view
@@ -0,0 +1,259 @@+-- -----------------------------------------------------------------------------+--+-- (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 CodeGen.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 view
@@ -0,0 +1,74 @@+module SPARC.ShortcutJump (+        JumpDest(..), getJumpDestBlockId,+        canShortcut,+        shortcutJump,+        shortcutStatics,+        shortBlockId+)++where++import GhcPrelude++import SPARC.Instr+import SPARC.Imm++import CLabel+import BlockId+import Cmm++import Panic+import Outputable++data JumpDest+        = DestBlockId BlockId+        | DestImm Imm++-- Debug Instance+instance Outputable JumpDest where+  ppr (DestBlockId bid) = text "blk:" <> ppr bid+  ppr (DestImm _bid)    = text "imm:?"++getJumpDestBlockId :: JumpDest -> Maybe BlockId+getJumpDestBlockId (DestBlockId bid) = Just bid+getJumpDestBlockId _                 = Nothing+++canShortcut :: Instr -> Maybe JumpDest+canShortcut _ = Nothing+++shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr+shortcutJump _ other = other++++shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics+shortcutStatics fn (Statics lbl statics)+  = Statics lbl $ map (shortcutStatic fn) statics+  -- we need to get the jump tables, so apply the mapping to the entries+  -- of a CmmData too.++shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel+shortcutLabel fn lab+  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn blkId+  | otherwise                              = lab++shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic+shortcutStatic fn (CmmStaticLit (CmmLabel lab))+        = CmmStaticLit (CmmLabel (shortcutLabel fn lab))+shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w))+        = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w)+-- slightly dodgy, we're ignoring the second label, but this+-- works with the way we use CmmLabelDiffOff for jump tables now.+shortcutStatic _ other_static+        = other_static+++shortBlockId :: (BlockId -> Maybe JumpDest) -> BlockId -> CLabel+shortBlockId fn blockid =+   case fn blockid of+      Nothing -> blockLbl blockid+      Just (DestBlockId blockid')  -> shortBlockId fn blockid'+      Just (DestImm (ImmCLbl lbl)) -> lbl+      _other -> panic "shortBlockId"
+ compiler/nativeGen/SPARC/Stack.hs view
@@ -0,0 +1,59 @@+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 view
@@ -0,0 +1,132 @@+{-# 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 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+      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+      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+      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+      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+      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 view
@@ -0,0 +1,3446 @@+{-# LANGUAGE CPP, GADTs, NondecreasingIndentation #-}++-- The default iteration limit is a bit too low for the definitions+-- in this module.+{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}++-----------------------------------------------------------------------------+--+-- 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"+#include "nativeGen/NCG.h"+#include "../includes/MachDeps.h"++-- NCG stuff:+import GhcPrelude++import X86.Instr+import X86.Cond+import X86.Regs+import X86.RegInfo++--TODO: Remove - Just for development/debugging+import X86.Ppr()++import CodeGen.Platform+import CPrim+import Debug            ( DebugBlock(..), UnwindPoint(..), UnwindTable+                        , UnwindExpr(UwReg), toUnwindExpr )+import Instruction+import PIC+import NCGMonad   ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat+                  , getDeltaNat, getBlockIdNat, getPicBaseNat, getNewRegPairNat+                  , getPicBaseMaybeNat, getDebugBlock, getFileId+                  , addImmediateSuccessorNat, updateCfgNat)+import CFG+import Format+import Reg+import Platform++-- Our intermediate code:+import BasicTypes+import BlockId+import Module           ( primUnitId )+import PprCmm           ()+import CmmUtils+import CmmSwitch+import Cmm+import Hoopl.Block+import Hoopl.Collections+import Hoopl.Graph+import Hoopl.Label+import CLabel+import CoreSyn          ( Tickish(..) )+import SrcLoc           ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )++-- The rest:+import ForeignCall      ( CCallConv(..) )+import OrdList+import Outputable+import FastString+import DynFlags+import Util+import UniqSupply       ( getUniqueM )++import Control.Monad+import Data.Bits+import Data.Foldable (fold)+import Data.Int+import Data.Maybe+import Data.Word++import qualified Data.Map as M++is32BitPlatform :: NatM Bool+is32BitPlatform = do+    dflags <- getDynFlags+    return $ target32Bit (targetPlatform dflags)++sse2Enabled :: NatM Bool+sse2Enabled = do+  dflags <- getDynFlags+  case platformArch (targetPlatform dflags) of+  -- We Assume  SSE1 and SSE2 operations are available on both+  -- x86 and x86_64. Historically we didn't default to SSE2 and+  -- SSE1 on x86, which results in defacto nondeterminism for how+  -- rounding behaves in the associated x87 floating point instructions+  -- because variations in the spill/fpu stack placement of arguments for+  -- operations would change the precision and final result of what+  -- would otherwise be the same expressions with respect to single or+  -- double precision IEEE floating point computations.+    ArchX86_64 -> return True+    ArchX86    -> return True+    _          -> panic "trying to generate x86/x86_64 on the wrong platform"+++sse4_2Enabled :: NatM Bool+sse4_2Enabled = do+  dflags <- getDynFlags+  return (isSse4_2Enabled dflags)+++cmmTopCodeGen+        :: RawCmmDecl+        -> NatM [NatCmmDecl (Alignment, CmmStatics) Instr]++cmmTopCodeGen (CmmProc info lab live graph) = do+  let blocks = toBlockListEntryFirst graph+  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks+  picBaseMb <- getPicBaseMaybeNat+  dflags <- getDynFlags+  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)+      tops = proc : concat statics+      os   = platformOS $ targetPlatform dflags++  case picBaseMb of+      Just picBase -> initializePicBase_x86 ArchX86 os picBase tops+      Nothing -> return tops++cmmTopCodeGen (CmmData sec dat) = do+  return [CmmData sec (mkAlignment 1, dat)]  -- no translation, we just use CmmStatic+++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 <- stmtsToInstrs id stmts+  tail_instrs <- stmtToInstrs id tail+  let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_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++stmtsToInstrs :: BlockId -> [CmmNode e x] -> NatM InstrBlock+stmtsToInstrs bid stmts+   = do instrss <- mapM (stmtToInstrs bid) stmts+        return (concatOL instrss)++-- | `bid` refers to the current block and is used to update the CFG+--   if new blocks are inserted in the control flow.+stmtToInstrs :: BlockId -> CmmNode e x -> NatM InstrBlock+stmtToInstrs bid stmt = do+  dflags <- getDynFlags+  is32Bit <- is32BitPlatform+  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++    CmmUnsafeForeignCall target result_regs args+       -> genCCall dflags is32Bit target result_regs args bid++    CmmBranch id          -> return $ genBranch id++    --We try to arrange blocks such that the likely branch is the fallthrough+    --in CmmContFlowOpt. So we can assume the condition is likely false here.+    CmmCondBranch arg true false _ -> genCondBranch bid true false arg+    CmmSwitch arg ids -> do dflags <- getDynFlags+                            genSwitch dflags arg ids+    CmmCall { cml_target = arg+            , cml_args_regs = gregs } -> do+                                dflags <- getDynFlags+                                genJump arg (jumpRegs dflags gregs)+    _ ->+      panic "stmtToInstrs: statement should have been cps'd away"+++jumpRegs :: DynFlags -> [GlobalReg] -> [Reg]+jumpRegs dflags gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]+    where platform = targetPlatform dflags++--------------------------------------------------------------------------------+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.+--      They are really trees of insns to facilitate fast appending, where a+--      left-to-right traversal yields the insns in the correct order.+--+type InstrBlock+        = OrdList Instr+++-- | Condition codes passed up the tree.+--+data CondCode+        = CondCode Bool Cond InstrBlock+++-- | a.k.a "Register64"+--      Reg is the lower 32-bit temporary which contains the result.+--      Use getHiVRegFromLo to find the other VRegUnique.+--+--      Rules of this simplified insn selection game are therefore that+--      the returned Reg may be modified+--+data ChildCode64+   = ChildCode64+        InstrBlock+        Reg+++-- | Register's passed up the tree.  If the stix code forces the register+--      to live in a pre-decided machine register, it comes out as @Fixed@;+--      otherwise, it comes out as @Any@, and the parent can decide which+--      register to put it in.+--+data Register+        = Fixed Format Reg InstrBlock+        | Any   Format (Reg -> InstrBlock)+++swizzleRegisterRep :: Register -> Format -> Register+swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code+swizzleRegisterRep (Any _ codefn)     format = Any   format codefn+++-- | Grab the Reg for a CmmReg+getRegisterReg :: Platform  -> CmmReg -> Reg++getRegisterReg _   (CmmLocal (LocalReg u pk))+  = -- by Assuming SSE2, Int,Word,Float,Double all can be register allocated+   let fmt = cmmTypeFormat pk in+        RegVirtual (mkVirtualReg u fmt)++getRegisterReg platform  (CmmGlobal mid)+  = case globalRegMaybe platform mid of+        Just reg -> RegReal $ reg+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)+        -- By this stage, the only MagicIds remaining should be the+        -- ones which map to a real machine register on this+        -- platform.  Hence ...+++-- | Memory addressing modes passed up the tree.+data Amode+        = Amode AddrMode InstrBlock++{-+Now, given a tree (the argument to a CmmLoad) that references memory,+produce a suitable addressing mode.++A Rule of the Game (tm) for Amodes: use of the addr bit must+immediately follow use of the code part, since the code part puts+values in registers which the addr then refers to.  So you can't put+anything in between, lest it overwrite some of those registers.  If+you need to do some other computation between the code part and use of+the addr bit, first store the effective address from the amode in a+temporary, then do the other computation, and then use the temporary:++    code+    LEA amode, tmp+    ... other computation ...+    ... (tmp) ...+-}+++-- | Check whether an integer will fit in 32 bits.+--      A CmmInt is intended to be truncated to the appropriate+--      number of bits, so here we truncate it to Int64.  This is+--      important because e.g. -1 as a CmmInt might be either+--      -1 or 18446744073709551615.+--+is32BitInteger :: Integer -> Bool+is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000+  where i64 = fromIntegral i :: Int64+++-- | Convert a BlockId to some CmmStatic data+jumpTableEntry :: DynFlags -> Maybe BlockId -> CmmStatic+jumpTableEntry dflags Nothing = CmmStaticLit (CmmInt 0 (wordWidth dflags))+jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)+    where blockLabel = blockLbl blockid+++-- -----------------------------------------------------------------------------+-- General things for putting together code sequences++-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert+-- CmmExprs into CmmRegOff?+mangleIndexTree :: DynFlags -> CmmReg -> Int -> CmmExpr+mangleIndexTree dflags reg off+  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]+  where width = typeWidth (cmmRegType dflags reg)++-- | The dual to getAnyReg: compute an expression into a register, but+--      we don't mind which one it is.+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)+getSomeReg expr = do+  r <- getRegister expr+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, code tmp)+    Fixed _ reg code ->+        return (reg, code)+++assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock+assignMem_I64Code addrTree valueTree = do+  Amode addr addr_code <- getAmode addrTree+  ChildCode64 vcode rlo <- iselExpr64 valueTree+  let+        rhi = getHiVRegFromLo rlo++        -- Little-endian store+        mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)+        mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))+  return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)+++assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock+assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do+   ChildCode64 vcode r_src_lo <- iselExpr64 valueTree+   let+         r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32+         r_dst_hi = getHiVRegFromLo r_dst_lo+         r_src_hi = getHiVRegFromLo r_src_lo+         mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)+         mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)+   return (+        vcode `snocOL` mov_lo `snocOL` mov_hi+     )++assignReg_I64Code _ _+   = panic "assignReg_I64Code(i386): invalid lvalue"+++iselExpr64        :: CmmExpr -> NatM ChildCode64+iselExpr64 (CmmLit (CmmInt i _)) = do+  (rlo,rhi) <- getNewRegPairNat II32+  let+        r = fromIntegral (fromIntegral i :: Word32)+        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)+        code = toOL [+                MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),+                MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)+                ]+  return (ChildCode64 code rlo)++iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do+   Amode addr addr_code <- getAmode addrTree+   (rlo,rhi) <- getNewRegPairNat II32+   let+        mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)+        mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)+   return (+            ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi)+                        rlo+     )++iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty+   = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32))++-- we handle addition, but rather badly+iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do+   ChildCode64 code1 r1lo <- iselExpr64 e1+   (rlo,rhi) <- getNewRegPairNat II32+   let+        r = fromIntegral (fromIntegral i :: Word32)+        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)+        r1hi = getHiVRegFromLo r1lo+        code =  code1 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]+   return (ChildCode64 code rlo)++iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do+   ChildCode64 code1 r1lo <- iselExpr64 e1+   ChildCode64 code2 r2lo <- iselExpr64 e2+   (rlo,rhi) <- getNewRegPairNat II32+   let+        r1hi = getHiVRegFromLo r1lo+        r2hi = getHiVRegFromLo r2lo+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       ADD II32 (OpReg r2lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       ADC II32 (OpReg r2hi) (OpReg rhi) ]+   return (ChildCode64 code rlo)++iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do+   ChildCode64 code1 r1lo <- iselExpr64 e1+   ChildCode64 code2 r2lo <- iselExpr64 e2+   (rlo,rhi) <- getNewRegPairNat II32+   let+        r1hi = getHiVRegFromLo r1lo+        r2hi = getHiVRegFromLo r2lo+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       SUB II32 (OpReg r2lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       SBB II32 (OpReg r2hi) (OpReg rhi) ]+   return (ChildCode64 code rlo)++iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do+     fn <- getAnyReg expr+     r_dst_lo <-  getNewRegNat II32+     let r_dst_hi = getHiVRegFromLo r_dst_lo+         code = fn r_dst_lo+     return (+             ChildCode64 (code `snocOL`+                          MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi))+                          r_dst_lo+            )++iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do+     fn <- getAnyReg expr+     r_dst_lo <-  getNewRegNat II32+     let r_dst_hi = getHiVRegFromLo r_dst_lo+         code = fn r_dst_lo+     return (+             ChildCode64 (code `snocOL`+                          MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL`+                          CLTD II32 `snocOL`+                          MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL`+                          MOV II32 (OpReg edx) (OpReg r_dst_hi))+                          r_dst_lo+            )++iselExpr64 expr+   = pprPanic "iselExpr64(i386)" (ppr expr)+++--------------------------------------------------------------------------------+getRegister :: CmmExpr -> NatM Register+getRegister e = do dflags <- getDynFlags+                   is32Bit <- is32BitPlatform+                   getRegister' dflags is32Bit e++getRegister' :: DynFlags -> Bool -> CmmExpr -> NatM Register++getRegister' dflags is32Bit (CmmReg reg)+  = case reg of+        CmmGlobal PicBaseReg+         | is32Bit ->+            -- on x86_64, we have %rip for PicBaseReg, but it's not+            -- a full-featured register, it can only be used for+            -- rip-relative addressing.+            do reg' <- getPicBaseNat (archWordFormat is32Bit)+               return (Fixed (archWordFormat is32Bit) reg' nilOL)+        _ ->+            do+               let+                 fmt = cmmTypeFormat (cmmRegType dflags reg)+                 format  = fmt+               --+               let platform = targetPlatform dflags+               return (Fixed format+                             (getRegisterReg platform  reg)+                             nilOL)+++getRegister' dflags is32Bit (CmmRegOff r n)+  = getRegister' dflags is32Bit $ mangleIndexTree dflags r n++getRegister' dflags is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])+  = addAlignmentCheck align <$> getRegister' dflags is32Bit e++-- for 32-bit architectures, support some 64 -> 32 bit conversions:+-- TO_W_(x), TO_W_(x >> 32)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32)+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | is32Bit = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 (getHiVRegFromLo rlo) code++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32)+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | is32Bit = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 (getHiVRegFromLo rlo) code++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x])+ | is32Bit = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x])+ | is32Bit = do+  ChildCode64 code rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =+  float_const_sse2  where+  float_const_sse2+    | f == 0.0 = do+      let+          format = floatFormat w+          code dst = unitOL  (XOR format (OpReg dst) (OpReg dst))+        -- I don't know why there are xorpd, xorps, and pxor instructions.+        -- They all appear to do the same thing --SDM+      return (Any format code)++   | otherwise = do+      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+      loadFloatAmode w addr code++-- catch simple cases of zero- or sign-extended load+getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do+  code <- intLoadCode (MOVZxL II8) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do+  code <- intLoadCode (MOVSxL II8) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do+  code <- intLoadCode (MOVZxL II16) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do+  code <- intLoadCode (MOVSxL II16) addr+  return (Any II32 code)++-- catch simple cases of zero- or sign-extended load+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _])+ | not is32Bit = do+  code <- intLoadCode (MOVZxL II8) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II8) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _])+ | not is32Bit = do+  code <- intLoadCode (MOVZxL II16) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II16) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _])+ | not is32Bit = do+  code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II32) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),+                                     CmmLit displacement])+ | not is32Bit = do+      return $ Any II64 (\dst -> unitOL $+        LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))++getRegister' dflags is32Bit (CmmMachOp mop [x]) = do -- unary MachOps+    case mop of+      MO_F_Neg w  -> sse2NegCode w x+++      MO_S_Neg w -> triv_ucode NEGI (intFormat w)+      MO_Not w   -> triv_ucode NOT  (intFormat w)++      -- Nop conversions+      MO_UU_Conv W32 W8  -> toI8Reg  W32 x+      MO_SS_Conv W32 W8  -> toI8Reg  W32 x+      MO_XX_Conv W32 W8  -> toI8Reg  W32 x+      MO_UU_Conv W16 W8  -> toI8Reg  W16 x+      MO_SS_Conv W16 W8  -> toI8Reg  W16 x+      MO_XX_Conv W16 W8  -> toI8Reg  W16 x+      MO_UU_Conv W32 W16 -> toI16Reg W32 x+      MO_SS_Conv W32 W16 -> toI16Reg W32 x+      MO_XX_Conv W32 W16 -> toI16Reg W32 x++      MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x+      MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x+      MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x+      MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+      MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+      MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+      MO_UU_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x+      MO_SS_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x+      MO_XX_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x++      MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x+      MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x+      MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x++      -- widenings+      MO_UU_Conv W8  W32 -> integerExtend W8  W32 MOVZxL x+      MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x+      MO_UU_Conv W8  W16 -> integerExtend W8  W16 MOVZxL x++      MO_SS_Conv W8  W32 -> integerExtend W8  W32 MOVSxL x+      MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x+      MO_SS_Conv W8  W16 -> integerExtend W8  W16 MOVSxL x++      -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we+      -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register+      -- has 8-bit version). So for 32-bit code, we'll just zero-extend.+      MO_XX_Conv W8  W32+          | is32Bit   -> integerExtend W8 W32 MOVZxL x+          | otherwise -> integerExtend W8 W32 MOV x+      MO_XX_Conv W8  W16+          | is32Bit   -> integerExtend W8 W16 MOVZxL x+          | otherwise -> integerExtend W8 W16 MOV x+      MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x++      MO_UU_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVZxL x+      MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x+      MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x+      MO_SS_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVSxL x+      MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x+      MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x+      -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl.+      -- However, we don't want the register allocator to throw it+      -- away as an unnecessary reg-to-reg move, so we keep it in+      -- the form of a movzl and print it as a movl later.+      -- This doesn't apply to MO_XX_Conv since in this case we don't care about+      -- the upper bits. So we can just use MOV.+      MO_XX_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOV x+      MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x+      MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x++      MO_FF_Conv W32 W64 -> coerceFP2FP W64 x+++      MO_FF_Conv W64 W32 -> coerceFP2FP W32 x++      MO_FS_Conv from to -> coerceFP2Int from to x+      MO_SF_Conv from to -> coerceInt2FP from to x++      MO_V_Insert {}   -> needLlvm+      MO_V_Extract {}  -> needLlvm+      MO_V_Add {}      -> needLlvm+      MO_V_Sub {}      -> needLlvm+      MO_V_Mul {}      -> needLlvm+      MO_VS_Quot {}    -> needLlvm+      MO_VS_Rem {}     -> needLlvm+      MO_VS_Neg {}     -> needLlvm+      MO_VU_Quot {}    -> needLlvm+      MO_VU_Rem {}     -> needLlvm+      MO_VF_Insert {}  -> needLlvm+      MO_VF_Extract {} -> needLlvm+      MO_VF_Add {}     -> needLlvm+      MO_VF_Sub {}     -> needLlvm+      MO_VF_Mul {}     -> needLlvm+      MO_VF_Quot {}    -> needLlvm+      MO_VF_Neg {}     -> needLlvm++      _other -> pprPanic "getRegister" (pprMachOp mop)+   where+        triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register+        triv_ucode instr format = trivialUCode format (instr format) x++        -- signed or unsigned extension.+        integerExtend :: Width -> Width+                      -> (Format -> Operand -> Operand -> Instr)+                      -> CmmExpr -> NatM Register+        integerExtend from to instr expr = do+            (reg,e_code) <- if from == W8 then getByteReg expr+                                          else getSomeReg expr+            let+                code dst =+                  e_code `snocOL`+                  instr (intFormat from) (OpReg reg) (OpReg dst)+            return (Any (intFormat to) code)++        toI8Reg :: Width -> CmmExpr -> NatM Register+        toI8Reg new_rep expr+            = do codefn <- getAnyReg expr+                 return (Any (intFormat new_rep) codefn)+                -- HACK: use getAnyReg to get a byte-addressable register.+                -- If the source was a Fixed register, this will add the+                -- mov instruction to put it into the desired destination.+                -- We're assuming that the destination won't be a fixed+                -- non-byte-addressable register; it won't be, because all+                -- fixed registers are word-sized.++        toI16Reg = toI8Reg -- for now++        conversionNop :: Format -> CmmExpr -> NatM Register+        conversionNop new_format expr+            = do e_code <- getRegister' dflags is32Bit expr+                 return (swizzleRegisterRep e_code new_format)+++getRegister' _ is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps+  case mop of+      MO_F_Eq _ -> condFltReg is32Bit EQQ x y+      MO_F_Ne _ -> condFltReg is32Bit NE  x y+      MO_F_Gt _ -> condFltReg is32Bit GTT x y+      MO_F_Ge _ -> condFltReg is32Bit GE  x y+      -- Invert comparison condition and swap operands+      -- See Note [SSE Parity Checks]+      MO_F_Lt _ -> condFltReg is32Bit GTT  y x+      MO_F_Le _ -> condFltReg is32Bit GE   y x++      MO_Eq _   -> condIntReg EQQ x y+      MO_Ne _   -> condIntReg NE  x y++      MO_S_Gt _ -> condIntReg GTT x y+      MO_S_Ge _ -> condIntReg GE  x y+      MO_S_Lt _ -> condIntReg LTT x y+      MO_S_Le _ -> condIntReg LE  x y++      MO_U_Gt _ -> condIntReg GU  x y+      MO_U_Ge _ -> condIntReg GEU x y+      MO_U_Lt _ -> condIntReg LU  x y+      MO_U_Le _ -> condIntReg LEU x y++      MO_F_Add w   -> trivialFCode_sse2 w ADD  x y++      MO_F_Sub w   -> trivialFCode_sse2 w SUB  x y++      MO_F_Quot w  -> trivialFCode_sse2 w FDIV x y++      MO_F_Mul w   -> trivialFCode_sse2 w MUL x y+++      MO_Add rep -> add_code rep x y+      MO_Sub rep -> sub_code rep x y++      MO_S_Quot rep -> div_code rep True  True  x y+      MO_S_Rem  rep -> div_code rep True  False x y+      MO_U_Quot rep -> div_code rep False True  x y+      MO_U_Rem  rep -> div_code rep False False x y++      MO_S_MulMayOflo rep -> imulMayOflo rep x y++      MO_Mul W8  -> imulW8 x y+      MO_Mul rep -> triv_op rep IMUL+      MO_And rep -> triv_op rep AND+      MO_Or  rep -> triv_op rep OR+      MO_Xor rep -> triv_op rep XOR++        {- Shift ops on x86s have constraints on their source, it+           either has to be Imm, CL or 1+            => trivialCode is not restrictive enough (sigh.)+        -}+      MO_Shl rep   -> shift_code rep SHL x y {-False-}+      MO_U_Shr rep -> shift_code rep SHR x y {-False-}+      MO_S_Shr rep -> shift_code rep SAR x y {-False-}++      MO_V_Insert {}   -> needLlvm+      MO_V_Extract {}  -> needLlvm+      MO_V_Add {}      -> needLlvm+      MO_V_Sub {}      -> needLlvm+      MO_V_Mul {}      -> needLlvm+      MO_VS_Quot {}    -> needLlvm+      MO_VS_Rem {}     -> needLlvm+      MO_VS_Neg {}     -> needLlvm+      MO_VF_Insert {}  -> needLlvm+      MO_VF_Extract {} -> needLlvm+      MO_VF_Add {}     -> needLlvm+      MO_VF_Sub {}     -> needLlvm+      MO_VF_Mul {}     -> needLlvm+      MO_VF_Quot {}    -> needLlvm+      MO_VF_Neg {}     -> needLlvm++      _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)+  where+    --------------------+    triv_op width instr = trivialCode width op (Just op) x y+                        where op   = instr (intFormat width)++    -- Special case for IMUL for bytes, since the result of IMULB will be in+    -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider+    -- values.+    imulW8 :: CmmExpr -> CmmExpr -> NatM Register+    imulW8 arg_a arg_b = do+        (a_reg, a_code) <- getNonClobberedReg arg_a+        b_code <- getAnyReg arg_b++        let code = a_code `appOL` b_code eax `appOL`+                   toOL [ IMUL2 format (OpReg a_reg) ]+            format = intFormat W8++        return (Fixed format eax code)+++    imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+    imulMayOflo rep a b = do+         (a_reg, a_code) <- getNonClobberedReg a+         b_code <- getAnyReg b+         let+             shift_amt  = case rep of+                           W32 -> 31+                           W64 -> 63+                           _ -> panic "shift_amt"++             format = intFormat rep+             code = a_code `appOL` b_code eax `appOL`+                        toOL [+                           IMUL2 format (OpReg a_reg),   -- result in %edx:%eax+                           SAR format (OpImm (ImmInt shift_amt)) (OpReg eax),+                                -- sign extend lower part+                           SUB format (OpReg edx) (OpReg eax)+                                -- compare against upper+                           -- eax==0 if high part == sign extended low part+                        ]+         return (Fixed format eax code)++    --------------------+    shift_code :: Width+               -> (Format -> Operand -> Operand -> Instr)+               -> CmmExpr+               -> CmmExpr+               -> NatM Register++    {- Case1: shift length as immediate -}+    shift_code width instr x (CmmLit lit) = do+          x_code <- getAnyReg x+          let+               format = intFormat width+               code dst+                  = x_code dst `snocOL`+                    instr format (OpImm (litToImm lit)) (OpReg dst)+          return (Any format code)++    {- Case2: shift length is complex (non-immediate)+      * y must go in %ecx.+      * we cannot do y first *and* put its result in %ecx, because+        %ecx might be clobbered by x.+      * if we do y second, then x cannot be+        in a clobbered reg.  Also, we cannot clobber x's reg+        with the instruction itself.+      * so we can either:+        - do y first, put its result in a fresh tmp, then copy it to %ecx later+        - do y second and put its result into %ecx.  x gets placed in a fresh+          tmp.  This is likely to be better, because the reg alloc can+          eliminate this reg->reg move here (it won't eliminate the other one,+          because the move is into the fixed %ecx).+    -}+    shift_code width instr x y{-amount-} = do+        x_code <- getAnyReg x+        let format = intFormat width+        tmp <- getNewRegNat format+        y_code <- getAnyReg y+        let+           code = x_code tmp `appOL`+                  y_code ecx `snocOL`+                  instr format (OpReg ecx) (OpReg tmp)+        return (Fixed format tmp code)++    --------------------+    add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register+    add_code rep x (CmmLit (CmmInt y _))+        | is32BitInteger y = add_int rep x y+    add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y+      where format = intFormat rep+    -- TODO: There are other interesting patterns we want to replace+    --     with a LEA, e.g. `(x + offset) + (y << shift)`.++    --------------------+    sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register+    sub_code rep x (CmmLit (CmmInt y _))+        | is32BitInteger (-y) = add_int rep x (-y)+    sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y++    -- our three-operand add instruction:+    add_int width x y = do+        (x_reg, x_code) <- getSomeReg x+        let+            format = intFormat width+            imm = ImmInt (fromInteger y)+            code dst+               = x_code `snocOL`+                 LEA format+                        (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm))+                        (OpReg dst)+        --+        return (Any format code)++    ----------------------++    -- See Note [DIV/IDIV for bytes]+    div_code W8 signed quotient x y = do+        let widen | signed    = MO_SS_Conv W8 W16+                  | otherwise = MO_UU_Conv W8 W16+        div_code+            W16+            signed+            quotient+            (CmmMachOp widen [x])+            (CmmMachOp widen [y])++    div_code width signed quotient x y = do+           (y_op, y_code) <- getRegOrMem y -- cannot be clobbered+           x_code <- getAnyReg x+           let+             format = intFormat width+             widen | signed    = CLTD format+                   | otherwise = XOR format (OpReg edx) (OpReg edx)++             instr | signed    = IDIV+                   | otherwise = DIV++             code = y_code `appOL`+                    x_code eax `appOL`+                    toOL [widen, instr format y_op]++             result | quotient  = eax+                    | otherwise = edx++           return (Fixed format result code)+++getRegister' _ _ (CmmLoad mem pk)+  | isFloatType pk+  = do+    Amode addr mem_code <- getAmode mem+    loadFloatAmode  (typeWidth pk) addr mem_code++getRegister' _ is32Bit (CmmLoad mem pk)+  | is32Bit && not (isWord64 pk)+  = do+    code <- intLoadCode instr mem+    return (Any format code)+  where+    width = typeWidth pk+    format = intFormat width+    instr = case width of+                W8     -> MOVZxL II8+                _other -> MOV format+        -- We always zero-extend 8-bit loads, if we+        -- can't think of anything better.  This is because+        -- we can't guarantee access to an 8-bit variant of every register+        -- (esi and edi don't have 8-bit variants), so to make things+        -- simpler we do our 8-bit arithmetic with full 32-bit registers.++-- Simpler memory load code on x86_64+getRegister' _ is32Bit (CmmLoad mem pk)+ | not is32Bit+  = do+    code <- intLoadCode (MOV format) mem+    return (Any format code)+  where format = intFormat $ typeWidth pk++getRegister' _ is32Bit (CmmLit (CmmInt 0 width))+  = let+        format = intFormat width++        -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits+        format1 = if is32Bit then format+                           else case format of+                                II64 -> II32+                                _ -> format+        code dst+           = unitOL (XOR format1 (OpReg dst) (OpReg dst))+    in+        return (Any format code)++  -- optimisation for loading small literals on x86_64: take advantage+  -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit+  -- instruction forms are shorter.+getRegister' dflags is32Bit (CmmLit lit)+  | not is32Bit, isWord64 (cmmLitType dflags lit), not (isBigLit lit)+  = let+        imm = litToImm lit+        code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))+    in+        return (Any II64 code)+  where+   isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff+   isBigLit _ = False+        -- note1: not the same as (not.is32BitLit), because that checks for+        -- signed literals that fit in 32 bits, but we want unsigned+        -- literals here.+        -- note2: all labels are small, because we're assuming the+        -- small memory model (see gcc docs, -mcmodel=small).++getRegister' dflags _ (CmmLit lit)+  = do let format = cmmTypeFormat (cmmLitType dflags lit)+           imm = litToImm lit+           code dst = unitOL (MOV format (OpImm imm) (OpReg dst))+       return (Any format code)++getRegister' _ _ other+    | isVecExpr other  = needLlvm+    | otherwise        = pprPanic "getRegister(x86)" (ppr other)+++intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr+   -> NatM (Reg -> InstrBlock)+intLoadCode instr mem = do+  Amode src mem_code <- getAmode mem+  return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))++-- Compute an expression into *any* register, adding the appropriate+-- move instruction if necessary.+getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)+getAnyReg expr = do+  r <- getRegister expr+  anyReg r++anyReg :: Register -> NatM (Reg -> InstrBlock)+anyReg (Any _ code)          = return code+anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)++-- A bit like getSomeReg, but we want a reg that can be byte-addressed.+-- Fixed registers might not be byte-addressable, so we make sure we've+-- got a temporary, inserting an extra reg copy if necessary.+getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)+getByteReg expr = do+  is32Bit <- is32BitPlatform+  if is32Bit+      then do r <- getRegister expr+              case r of+                Any rep code -> do+                    tmp <- getNewRegNat rep+                    return (tmp, code tmp)+                Fixed rep reg code+                    | isVirtualReg reg -> return (reg,code)+                    | otherwise -> do+                        tmp <- getNewRegNat rep+                        return (tmp, code `snocOL` reg2reg rep reg tmp)+                    -- ToDo: could optimise slightly by checking for+                    -- byte-addressable real registers, but that will+                    -- happen very rarely if at all.+      else getSomeReg expr -- all regs are byte-addressable on x86_64++-- Another variant: this time we want the result in a register that cannot+-- be modified by code to evaluate an arbitrary expression.+getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)+getNonClobberedReg expr = do+  dflags <- getDynFlags+  r <- getRegister expr+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, code tmp)+    Fixed rep reg code+        -- only certain regs can be clobbered+        | reg `elem` instrClobberedRegs (targetPlatform dflags)+        -> do+                tmp <- getNewRegNat rep+                return (tmp, code `snocOL` reg2reg rep reg tmp)+        | otherwise ->+                return (reg, code)++reg2reg :: Format -> Reg -> Reg -> Instr+reg2reg format src dst = MOV format (OpReg src) (OpReg dst)+++--------------------------------------------------------------------------------+getAmode :: CmmExpr -> NatM Amode+getAmode e = do is32Bit <- is32BitPlatform+                getAmode' is32Bit e++getAmode' :: Bool -> CmmExpr -> NatM Amode+getAmode' _ (CmmRegOff r n) = do dflags <- getDynFlags+                                 getAmode $ mangleIndexTree dflags r n++getAmode' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),+                                                  CmmLit displacement])+ | not is32Bit+    = return $ Amode (ripRel (litToImm displacement)) nilOL+++-- This is all just ridiculous, since it carefully undoes+-- what mangleIndexTree has just done.+getAmode' is32Bit (CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)])+  | is32BitLit is32Bit lit+  -- ASSERT(rep == II32)???+  = do (x_reg, x_code) <- getSomeReg x+       let off = ImmInt (-(fromInteger i))+       return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)++getAmode' is32Bit (CmmMachOp (MO_Add _rep) [x, CmmLit lit])+  | is32BitLit is32Bit lit+  -- ASSERT(rep == II32)???+  = do (x_reg, x_code) <- getSomeReg x+       let off = litToImm lit+       return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)++-- Turn (lit1 << n  + lit2) into  (lit2 + lit1 << n) so it will be+-- recognised by the next rule.+getAmode' is32Bit (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _),+                                  b@(CmmLit _)])+  = getAmode' is32Bit (CmmMachOp (MO_Add rep) [b,a])++-- Matches: (x + offset) + (y << shift)+getAmode' _ (CmmMachOp (MO_Add _) [CmmRegOff x offset,+                                   CmmMachOp (MO_Shl _)+                                        [y, CmmLit (CmmInt shift _)]])+  | shift == 0 || shift == 1 || shift == 2 || shift == 3+  = x86_complex_amode (CmmReg x) y shift (fromIntegral offset)++getAmode' _ (CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _)+                                        [y, CmmLit (CmmInt shift _)]])+  | shift == 0 || shift == 1 || shift == 2 || shift == 3+  = x86_complex_amode x y shift 0++getAmode' _ (CmmMachOp (MO_Add _)+                [x, CmmMachOp (MO_Add _)+                        [CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)],+                         CmmLit (CmmInt offset _)]])+  | shift == 0 || shift == 1 || shift == 2 || shift == 3+  && is32BitInteger offset+  = x86_complex_amode x y shift offset++getAmode' _ (CmmMachOp (MO_Add _) [x,y])+  = x86_complex_amode x y 0 0++getAmode' is32Bit (CmmLit lit) | is32BitLit is32Bit lit+  = return (Amode (ImmAddr (litToImm lit) 0) nilOL)++getAmode' _ expr = do+  (reg,code) <- getSomeReg expr+  return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)++-- | Like 'getAmode', but on 32-bit use simple register addressing+-- (i.e. no index register). This stops us from running out of+-- registers on x86 when using instructions such as cmpxchg, which can+-- use up to three virtual registers and one fixed register.+getSimpleAmode :: DynFlags -> Bool -> CmmExpr -> NatM Amode+getSimpleAmode dflags is32Bit addr+    | is32Bit = do+        addr_code <- getAnyReg addr+        addr_r <- getNewRegNat (intFormat (wordWidth dflags))+        let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0)+        return $! Amode amode (addr_code addr_r)+    | otherwise = getAmode addr++x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode+x86_complex_amode base index shift offset+  = do (x_reg, x_code) <- getNonClobberedReg base+        -- x must be in a temp, because it has to stay live over y_code+        -- we could compre x_reg and y_reg and do something better here...+       (y_reg, y_code) <- getSomeReg index+       let+           code = x_code `appOL` y_code+           base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8;+                                n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")"+       return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))+               code)+++++-- -----------------------------------------------------------------------------+-- getOperand: sometimes any operand will do.++-- getNonClobberedOperand: the value of the operand will remain valid across+-- the computation of an arbitrary expression, unless the expression+-- is computed directly into a register which the operand refers to+-- (see trivialCode where this function is used for an example).++getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)+getNonClobberedOperand (CmmLit lit) = do+  if  isSuitableFloatingPointLit lit+    then do+      let CmmFloat _ w = lit+      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+      return (OpAddr addr, code)+     else do++  is32Bit <- is32BitPlatform+  dflags <- getDynFlags+  if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit))+    then return (OpImm (litToImm lit), nilOL)+    else getNonClobberedOperand_generic (CmmLit lit)++getNonClobberedOperand (CmmLoad mem pk) = do+  is32Bit <- is32BitPlatform+  -- this logic could be simplified+  -- TODO FIXME+  if   (if is32Bit then not (isWord64 pk) else True)+      -- if 32bit and pk is at float/double/simd value+      -- or if 64bit+      --  this could use some eyeballs or i'll need to stare at it more later+    then do+      dflags <- getDynFlags+      let platform = targetPlatform dflags+      Amode src mem_code <- getAmode mem+      (src',save_code) <-+        if (amodeCouldBeClobbered platform src)+                then do+                   tmp <- getNewRegNat (archWordFormat is32Bit)+                   return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),+                           unitOL (LEA (archWordFormat is32Bit)+                                       (OpAddr src)+                                       (OpReg tmp)))+                else+                   return (src, nilOL)+      return (OpAddr src', mem_code `appOL` save_code)+    else do+      -- if its a word or gcptr on 32bit?+      getNonClobberedOperand_generic (CmmLoad mem pk)++getNonClobberedOperand e = getNonClobberedOperand_generic e++getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)+getNonClobberedOperand_generic e = do+    (reg, code) <- getNonClobberedReg e+    return (OpReg reg, code)++amodeCouldBeClobbered :: Platform -> AddrMode -> Bool+amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode)++regClobbered :: Platform -> Reg -> Bool+regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr+regClobbered _ _ = False++-- getOperand: the operand is not required to remain valid across the+-- computation of an arbitrary expression.+getOperand :: CmmExpr -> NatM (Operand, InstrBlock)++getOperand (CmmLit lit) = do+  use_sse2 <- sse2Enabled+  if (use_sse2 && isSuitableFloatingPointLit lit)+    then do+      let CmmFloat _ w = lit+      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+      return (OpAddr addr, code)+    else do++  is32Bit <- is32BitPlatform+  dflags <- getDynFlags+  if is32BitLit is32Bit lit && not (isFloatType (cmmLitType dflags lit))+    then return (OpImm (litToImm lit), nilOL)+    else getOperand_generic (CmmLit lit)++getOperand (CmmLoad mem pk) = do+  is32Bit <- is32BitPlatform+  use_sse2 <- sse2Enabled+  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)+     then do+       Amode src mem_code <- getAmode mem+       return (OpAddr src, mem_code)+     else+       getOperand_generic (CmmLoad mem pk)++getOperand e = getOperand_generic e++getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)+getOperand_generic e = do+    (reg, code) <- getSomeReg e+    return (OpReg reg, code)++isOperand :: Bool -> CmmExpr -> Bool+isOperand _ (CmmLoad _ _) = True+isOperand is32Bit (CmmLit lit)  = is32BitLit is32Bit lit+                          || isSuitableFloatingPointLit lit+isOperand _ _            = False++-- | Given a 'Register', produce a new 'Register' with an instruction block+-- which will check the value for alignment. Used for @-falignment-sanitisation@.+addAlignmentCheck :: Int -> Register -> Register+addAlignmentCheck align reg =+    case reg of+      Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg)+      Any fmt f          -> Any fmt (\reg -> f reg `appOL` check fmt reg)+  where+    check :: Format -> Reg -> InstrBlock+    check fmt reg =+        ASSERT(not $ isFloatFormat fmt)+        toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)+             , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel+             ]++memConstant :: Alignment -> CmmLit -> NatM Amode+memConstant align lit = do+  lbl <- getNewLabelNat+  let rosection = Section ReadOnlyData lbl+  dflags <- getDynFlags+  (addr, addr_code) <- if target32Bit (targetPlatform dflags)+                       then do dynRef <- cmmMakeDynamicReference+                                             dflags+                                             DataReference+                                             lbl+                               Amode addr addr_code <- getAmode dynRef+                               return (addr, addr_code)+                       else return (ripRel (ImmCLbl lbl), nilOL)+  let code =+        LDATA rosection (align, Statics lbl [CmmStaticLit lit])+        `consOL` addr_code+  return (Amode addr code)+++loadFloatAmode :: Width -> AddrMode -> InstrBlock -> NatM Register+loadFloatAmode w addr addr_code = do+  let format = floatFormat w+      code dst = addr_code `snocOL`+                    MOV format (OpAddr addr) (OpReg dst)++  return (Any format code)+++-- if we want a floating-point literal as an operand, we can+-- use it directly from memory.  However, if the literal is+-- zero, we're better off generating it into a register using+-- xor.+isSuitableFloatingPointLit :: CmmLit -> Bool+isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0+isSuitableFloatingPointLit _ = False++getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)+getRegOrMem e@(CmmLoad mem pk) = do+  is32Bit <- is32BitPlatform+  use_sse2 <- sse2Enabled+  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)+     then do+       Amode src mem_code <- getAmode mem+       return (OpAddr src, mem_code)+     else do+       (reg, code) <- getNonClobberedReg e+       return (OpReg reg, code)+getRegOrMem e = do+    (reg, code) <- getNonClobberedReg e+    return (OpReg reg, code)++is32BitLit :: Bool -> CmmLit -> Bool+is32BitLit is32Bit (CmmInt i W64)+ | not is32Bit+    = -- assume that labels are in the range 0-2^31-1: this assumes the+      -- small memory model (see gcc docs, -mcmodel=small).+      is32BitInteger i+is32BitLit _ _ = True+++++-- Set up a condition code for a conditional branch.++getCondCode :: CmmExpr -> NatM CondCode++-- yes, they really do seem to want exactly the same!++getCondCode (CmmMachOp mop [x, y])+  =+    case mop of+      MO_F_Eq W32 -> condFltCode EQQ x y+      MO_F_Ne W32 -> condFltCode NE  x y+      MO_F_Gt W32 -> condFltCode GTT x y+      MO_F_Ge W32 -> condFltCode GE  x y+      -- Invert comparison condition and swap operands+      -- See Note [SSE Parity Checks]+      MO_F_Lt W32 -> condFltCode GTT  y x+      MO_F_Le W32 -> condFltCode GE   y x++      MO_F_Eq W64 -> condFltCode EQQ x y+      MO_F_Ne W64 -> condFltCode NE  x y+      MO_F_Gt W64 -> condFltCode GTT x y+      MO_F_Ge W64 -> condFltCode GE  x y+      MO_F_Lt W64 -> condFltCode GTT y x+      MO_F_Le W64 -> condFltCode GE  y x++      _ -> condIntCode (machOpToCond mop) x y++getCondCode other = pprPanic "getCondCode(2)(x86,x86_64)" (ppr other)++machOpToCond :: MachOp -> Cond+machOpToCond mo = case mo of+  MO_Eq _   -> EQQ+  MO_Ne _   -> NE+  MO_S_Gt _ -> GTT+  MO_S_Ge _ -> GE+  MO_S_Lt _ -> LTT+  MO_S_Le _ -> LE+  MO_U_Gt _ -> GU+  MO_U_Ge _ -> GEU+  MO_U_Lt _ -> LU+  MO_U_Le _ -> LEU+  _other -> pprPanic "machOpToCond" (pprMachOp mo)+++-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be+-- passed back up the tree.++condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode+condIntCode cond x y = do is32Bit <- is32BitPlatform+                          condIntCode' is32Bit cond x y++condIntCode' :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode++-- memory vs immediate+condIntCode' is32Bit cond (CmmLoad x pk) (CmmLit lit)+ | is32BitLit is32Bit lit = do+    Amode x_addr x_code <- getAmode x+    let+        imm  = litToImm lit+        code = x_code `snocOL`+                  CMP (cmmTypeFormat pk) (OpImm imm) (OpAddr x_addr)+    --+    return (CondCode False cond code)++-- anything vs zero, using a mask+-- TODO: Add some sanity checking!!!!+condIntCode' is32Bit cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk))+    | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit is32Bit lit+    = do+      (x_reg, x_code) <- getSomeReg x+      let+         code = x_code `snocOL`+                TEST (intFormat pk) (OpImm (ImmInteger mask)) (OpReg x_reg)+      --+      return (CondCode False cond code)++-- anything vs zero+condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do+    (x_reg, x_code) <- getSomeReg x+    let+        code = x_code `snocOL`+                  TEST (intFormat pk) (OpReg x_reg) (OpReg x_reg)+    --+    return (CondCode False cond code)++-- anything vs operand+condIntCode' is32Bit cond x y+ | isOperand is32Bit y = do+    dflags <- getDynFlags+    (x_reg, x_code) <- getNonClobberedReg x+    (y_op,  y_code) <- getOperand y+    let+        code = x_code `appOL` y_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType dflags x)) y_op (OpReg x_reg)+    return (CondCode False cond code)+-- operand vs. anything: invert the comparison so that we can use a+-- single comparison instruction.+ | isOperand is32Bit x+ , Just revcond <- maybeFlipCond cond = do+    dflags <- getDynFlags+    (y_reg, y_code) <- getNonClobberedReg y+    (x_op,  x_code) <- getOperand x+    let+        code = y_code `appOL` x_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType dflags x)) x_op (OpReg y_reg)+    return (CondCode False revcond code)++-- anything vs anything+condIntCode' _ cond x y = do+  dflags <- getDynFlags+  (y_reg, y_code) <- getNonClobberedReg y+  (x_op, x_code) <- getRegOrMem x+  let+        code = y_code `appOL`+               x_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType dflags x)) (OpReg y_reg) x_op+  return (CondCode False cond code)++++--------------------------------------------------------------------------------+condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode++condFltCode cond x y+  =  condFltCode_sse2+  where+++  -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be+  -- an operand, but the right must be a reg.  We can probably do better+  -- than this general case...+  condFltCode_sse2 = do+    dflags <- getDynFlags+    (x_reg, x_code) <- getNonClobberedReg x+    (y_op, y_code) <- getOperand y+    let+        code = x_code `appOL`+               y_code `snocOL`+                  CMP (floatFormat $ cmmExprWidth dflags x) y_op (OpReg x_reg)+        -- NB(1): we need to use the unsigned comparison operators on the+        -- result of this comparison.+    return (CondCode True (condToUnsigned cond) code)++-- -----------------------------------------------------------------------------+-- Generating assignments++-- Assignments are really at the heart of the whole code generation+-- business.  Almost all top-level nodes of any real importance are+-- assignments, which correspond to loads, stores, or register+-- transfers.  If we're really lucky, some of the register transfers+-- will go away, because we can use the destination register to+-- complete the code generation for the right hand side.  This only+-- fails when the right hand side is forced into a fixed register+-- (e.g. the result of a call).++assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock+++-- integer assignment to memory++-- specific case of adding/subtracting an integer to a particular address.+-- ToDo: catch other cases where we can use an operation directly on a memory+-- address.+assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _,+                                                 CmmLit (CmmInt i _)])+   | addr == addr2, pk /= II64 || is32BitInteger i,+     Just instr <- check op+   = do Amode amode code_addr <- getAmode addr+        let code = code_addr `snocOL`+                   instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)+        return code+   where+        check (MO_Add _) = Just ADD+        check (MO_Sub _) = Just SUB+        check _ = Nothing+        -- ToDo: more?++-- general case+assignMem_IntCode pk addr src = do+    is32Bit <- is32BitPlatform+    Amode addr code_addr <- getAmode addr+    (code_src, op_src)   <- get_op_RI is32Bit src+    let+        code = code_src `appOL`+               code_addr `snocOL`+                  MOV pk op_src (OpAddr addr)+        -- NOTE: op_src is stable, so it will still be valid+        -- after code_addr.  This may involve the introduction+        -- of an extra MOV to a temporary register, but we hope+        -- the register allocator will get rid of it.+    --+    return code+  where+    get_op_RI :: Bool -> CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator+    get_op_RI is32Bit (CmmLit lit) | is32BitLit is32Bit lit+      = return (nilOL, OpImm (litToImm lit))+    get_op_RI _ op+      = do (reg,code) <- getNonClobberedReg op+           return (code, OpReg reg)+++-- Assign; dst is a reg, rhs is mem+assignReg_IntCode pk reg (CmmLoad src _) = do+  load_code <- intLoadCode (MOV pk) src+  dflags <- getDynFlags+  let platform = targetPlatform dflags+  return (load_code (getRegisterReg platform reg))++-- dst is a reg, but src could be anything+assignReg_IntCode _ reg src = do+  dflags <- getDynFlags+  let platform = targetPlatform dflags+  code <- getAnyReg src+  return (code (getRegisterReg platform reg))+++-- Floating point assignment to memory+assignMem_FltCode pk addr src = do+  (src_reg, src_code) <- getNonClobberedReg src+  Amode addr addr_code <- getAmode addr+  let+        code = src_code `appOL`+               addr_code `snocOL`+               MOV pk (OpReg src_reg) (OpAddr addr)++  return code++-- Floating point assignment to a register/temporary+assignReg_FltCode _ reg src = do+  src_code <- getAnyReg src+  dflags <- getDynFlags+  let platform = targetPlatform dflags+  return (src_code (getRegisterReg platform  reg))+++genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock++genJump (CmmLoad mem _) regs = do+  Amode target code <- getAmode mem+  return (code `snocOL` JMP (OpAddr target) regs)++genJump (CmmLit lit) regs = do+  return (unitOL (JMP (OpImm (litToImm lit)) regs))++genJump expr regs = do+  (reg,code) <- getSomeReg expr+  return (code `snocOL` JMP (OpReg reg) regs)+++-- -----------------------------------------------------------------------------+--  Unconditional branches++genBranch :: BlockId -> InstrBlock+genBranch = toOL . mkJumpInstr++++-- -----------------------------------------------------------------------------+--  Conditional jumps/branches++{-+Conditional jumps are always to local labels, so we can use branch+instructions.  We peek at the arguments to decide what kind of+comparison to do.++I386: First, we have to ensure that the condition+codes are set according to the supplied comparison operation.+-}+++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)++-- -----------------------------------------------------------------------------+--  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.++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_WriteBarrier) _ _ _ = return nilOL+        -- write barrier compiles 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_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;+      --  }+      return $ 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+                ])++  | 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+                [ 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+    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+        return $ 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+  where+    bw = widthInBits width+    platform = targetPlatform dflags++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 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 <- op_code dst_r arg amode+    return $ addr_code `appOL` arg_code arg `appOL` code+  where+    -- Code for the operation+    op_code :: Reg       -- Destination reg+            -> Reg       -- Register containing argument+            -> AddrMode  -- Address of location to mutate+            -> NatM (OrdList Instr)+    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)+                                  ]+        AMO_Sub  -> return $ toOL [ NEGI format (OpReg arg)+                                  , LOCK (XADD format (OpReg arg) (OpAddr amode))+                                  , MOV format (OpReg arg) (OpReg dst_r)+                                  ]+        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)+        cmpxchg_code instrs = do+            lbl <- getBlockIdNat+            tmp <- getNewRegNat format++            --Record inserted blocks+            addImmediateSuccessorNat bid lbl+            updateCfgNat (addWeightEdge lbl lbl 0)++            return $ toOL+                [ MOV format (OpAddr amode) (OpReg eax)+                , JXX ALWAYS lbl+                , NEWBLOCK lbl+                  -- 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 lbl+                ]++    format = intFormat 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"++    _ -> 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)++      stmtToInstrs bid (CmmUnsafeForeignCall target (catMaybes [res]) args)+  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_Log   -> fsLit "logf"++              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_Log   -> fsLit "log"++              MO_F64_Asin  -> fsLit "asin"+              MO_F64_Acos  -> fsLit "acos"+              MO_F64_Atan  -> fsLit "atan"++              MO_F64_Sinh  -> fsLit "sinh"+              MO_F64_Cosh  -> fsLit "cosh"+              MO_F64_Tanh  -> fsLit "tanh"+              MO_F64_Pwr   -> fsLit "pow"++              MO_F64_Asinh  -> fsLit "asinh"+              MO_F64_Acosh  -> fsLit "acosh"+              MO_F64_Atanh  -> fsLit "atanh"++              MO_Memcpy _  -> fsLit "memcpy"+              MO_Memset _  -> fsLit "memset"+              MO_Memmove _ -> fsLit "memmove"+              MO_Memcmp _  -> fsLit "memcmp"++              MO_PopCnt _  -> fsLit "popcnt"+              MO_BSwap _   -> fsLit "bswap"+              {- Here the C implementation is used as there is no x86+              instruction to reverse a word's bit order.+              -}+              MO_BRev w    -> fsLit $ bRevLabel w+              MO_Clz w     -> fsLit $ clzLabel w+              MO_Ctz _     -> unsupported++              MO_Pdep w    -> fsLit $ pdepLabel w+              MO_Pext w    -> fsLit $ pextLabel w++              MO_AtomicRMW _ _ -> fsLit "atomicrmw"+              MO_AtomicRead _  -> fsLit "atomicread"+              MO_AtomicWrite _ -> fsLit "atomicwrite"+              MO_Cmpxchg _     -> fsLit "cmpxchg"++              MO_UF_Conv _ -> unsupported++              MO_S_QuotRem {}  -> unsupported+              MO_U_QuotRem {}  -> unsupported+              MO_U_QuotRem2 {} -> unsupported+              MO_Add2 {}       -> unsupported+              MO_AddIntC {}    -> unsupported+              MO_SubIntC {}    -> unsupported+              MO_AddWordC {}   -> unsupported+              MO_SubWordC {}   -> unsupported+              MO_U_Mul2 {}     -> unsupported+              MO_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.+invertCondBranches :: CFG -> LabelMap a -> [NatBasicBlock Instr]+                   -> [NatBasicBlock Instr]+invertCondBranches cfg keep bs =+    --trace "Foo" $+    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 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 view
@@ -0,0 +1,109 @@+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 view
@@ -0,0 +1,1053 @@+{-# 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"+#include "nativeGen/NCG.h"++import GhcPrelude++import X86.Cond+import X86.Regs+import Instruction+import Format+import RegClass+import Reg+import TargetReg++import BlockId+import Hoopl.Collections+import Hoopl.Label+import CodeGen.Platform+import Cmm+import FastString+import Outputable+import Platform++import BasicTypes       (Alignment)+import CLabel+import DynFlags+import UniqSet+import Unique+import UniqSupply+import Debug (UnwindTable)++import Control.Monad+import Data.Maybe       (fromMaybe)++-- Format of an x86/x86_64 memory address, in bytes.+--+archWordFormat :: Bool -> Format+archWordFormat is32Bit+ | is32Bit   = II32+ | otherwise = II64++-- | Instruction instance for x86 instruction set.+instance Instruction Instr where+        regUsageOfInstr         = x86_regUsageOfInstr+        patchRegsOfInstr        = x86_patchRegsOfInstr+        isJumpishInstr          = x86_isJumpishInstr+        jumpDestsOfInstr        = x86_jumpDestsOfInstr+        patchJumpInstr          = x86_patchJumpInstr+        mkSpillInstr            = x86_mkSpillInstr+        mkLoadInstr             = x86_mkLoadInstr+        takeDeltaInstr          = x86_takeDeltaInstr+        isMetaInstr             = x86_isMetaInstr+        mkRegRegMoveInstr       = x86_mkRegRegMoveInstr+        takeRegRegMoveInstr     = x86_takeRegRegMoveInstr+        mkJumpInstr             = x86_mkJumpInstr+        mkStackAllocInstr       = x86_mkStackAllocInstr+        mkStackDeallocInstr     = x86_mkStackDeallocInstr+++-- -----------------------------------------------------------------------------+-- Intel x86 instructions++{-+Intel, in their infinite wisdom, selected a stack model for floating+point registers on x86.  That might have made sense back in 1979 --+nowadays we can see it for the nonsense it really is.  A stack model+fits poorly with the existing nativeGen infrastructure, which assumes+flat integer and FP register sets.  Prior to this commit, nativeGen+could not generate correct x86 FP code -- to do so would have meant+somehow working the register-stack paradigm into the register+allocator and spiller, which sounds very difficult.++We have decided to cheat, and go for a simple fix which requires no+infrastructure modifications, at the expense of generating ropey but+correct FP code.  All notions of the x86 FP stack and its insns have+been removed.  Instead, we pretend (to the instruction selector and+register allocator) that x86 has six floating point registers, %fake0+.. %fake5, which can be used in the usual flat manner.  We further+claim that x86 has floating point instructions very similar to SPARC+and Alpha, that is, a simple 3-operand register-register arrangement.+Code generation and register allocation proceed on this basis.++When we come to print out the final assembly, our convenient fiction+is converted to dismal reality.  Each fake instruction is+independently converted to a series of real x86 instructions.+%fake0 .. %fake5 are mapped to %st(0) .. %st(5).  To do reg-reg+arithmetic operations, the two operands are pushed onto the top of the+FP stack, the operation done, and the result copied back into the+relevant register.  There are only six %fake registers because 2 are+needed for the translation, and x86 has 8 in total.++The translation is inefficient but is simple and it works.  A cleverer+translation would handle a sequence of insns, simulating the FP stack+contents, would not impose a fixed mapping from %fake to %st regs, and+hopefully could avoid most of the redundant reg-reg moves of the+current translation.++We might as well make use of whatever unique FP facilities Intel have+chosen to bless us with (let's not be churlish, after all).+Hence GLDZ and GLD1.  Bwahahahahahahaha!+-}++{-+Note [x86 Floating point precision]++Intel's internal floating point registers are by default 80 bit+extended precision.  This means that all operations done on values in+registers are done at 80 bits, and unless the intermediate values are+truncated to the appropriate size (32 or 64 bits) by storing in+memory, calculations in registers will give different results from+calculations which pass intermediate values in memory (eg. via+function calls).++One solution is to set the FPU into 64 bit precision mode.  Some OSs+do this (eg. FreeBSD) and some don't (eg. Linux).  The problem here is+that this will only affect 64-bit precision arithmetic; 32-bit+calculations will still be done at 64-bit precision in registers.  So+it doesn't solve the whole problem.++There's also the issue of what the C library is expecting in terms of+precision.  It seems to be the case that glibc on Linux expects the+FPU to be set to 80 bit precision, so setting it to 64 bit could have+unexpected effects.  Changing the default could have undesirable+effects on other 3rd-party library code too, so the right thing would+be to save/restore the FPU control word across Haskell code if we were+to do this.++gcc's -ffloat-store gives consistent results by always storing the+results of floating-point calculations in memory, which works for both+32 and 64-bit precision.  However, it only affects the values of+user-declared floating point variables in C, not intermediate results.+GHC in -fvia-C mode uses -ffloat-store (see the -fexcess-precision+flag).++Another problem is how to spill floating point registers in the+register allocator.  Should we spill the whole 80 bits, or just 64?+On an OS which is set to 64 bit precision, spilling 64 is fine.  On+Linux, spilling 64 bits will round the results of some operations.+This is what gcc does.  Spilling at 80 bits requires taking up a full+128 bit slot (so we get alignment).  We spill at 80-bits and ignore+the alignment problems.++In the future [edit: now available in GHC 7.0.1, with the -msse2+flag], we'll use the SSE registers for floating point.  This requires+a CPU that supports SSE2 (ordinary SSE only supports 32 bit precision+float ops), which means P4 or Xeon and above.  Using SSE will solve+all these problems, because the SSE registers use fixed 32 bit or 64+bit precision.++--SDM 1/2003+-}++data Instr+        -- comment pseudo-op+        = COMMENT FastString++        -- location pseudo-op (file, line, col, name)+        | LOCATION Int Int Int String++        -- some static data spat out during code+        -- generation.  Will be extracted before+        -- pretty-printing.+        | LDATA   Section (Alignment, CmmStatics)++        -- start a new basic block.  Useful during+        -- codegen, removed later.  Preceding+        -- instruction should be a jump, as per the+        -- invariants for a BasicBlock (see Cmm).+        | NEWBLOCK BlockId++        -- unwinding information+        -- See Note [Unwinding information in the NCG].+        | UNWIND CLabel UnwindTable++        -- specify current stack offset for benefit of subsequent passes.+        -- This carries a BlockId so it can be used in unwinding information.+        | DELTA  Int++        -- Moves.+        | MOV         Format Operand Operand+        | CMOV   Cond Format Operand Reg+        | MOVZxL      Format Operand Operand -- format is the size of operand 1+        | MOVSxL      Format Operand Operand -- format is the size of operand 1+        -- x86_64 note: plain mov into a 32-bit register always zero-extends+        -- into the 64-bit reg, in contrast to the 8 and 16-bit movs which+        -- don't affect the high bits of the register.++        -- Load effective address (also a very useful three-operand add instruction :-)+        | LEA         Format Operand Operand++        -- Int Arithmetic.+        | ADD         Format Operand Operand+        | ADC         Format Operand Operand+        | SUB         Format Operand Operand+        | SBB         Format Operand Operand++        | MUL         Format Operand Operand+        | MUL2        Format Operand         -- %edx:%eax = operand * %rax+        | IMUL        Format Operand Operand -- signed int mul+        | IMUL2       Format Operand         -- %edx:%eax = operand * %eax++        | DIV         Format Operand         -- eax := eax:edx/op, edx := eax:edx%op+        | IDIV        Format Operand         -- ditto, but signed++        -- Int Arithmetic, where the effects on the condition register+        -- are important. Used in specialized sequences such as MO_Add2.+        -- Do not rewrite these instructions to "equivalent" ones that+        -- have different effect on the condition register! (See #9013.)+        | ADD_CC      Format Operand Operand+        | SUB_CC      Format Operand Operand++        -- Simple bit-twiddling.+        | AND         Format Operand Operand+        | OR          Format Operand Operand+        | XOR         Format Operand Operand+        | NOT         Format Operand+        | NEGI        Format Operand         -- NEG instruction (name clash with Cond)+        | BSWAP       Format Reg++        -- Shifts (amount may be immediate or %cl only)+        | SHL         Format Operand{-amount-} Operand+        | SAR         Format Operand{-amount-} Operand+        | SHR         Format Operand{-amount-} Operand++        | BT          Format Imm Operand+        | NOP+++        -- We need to support the FSTP (x87 store and pop) instruction+        -- so that we can correctly read off the return value of an+        -- x86 CDECL C function call when its floating point.+        -- so we dont include a register argument, and just use st(0)+        -- this instruction is used ONLY for return values of C ffi calls+        -- in x86_32 abi+        | X87Store         Format  AddrMode -- st(0), dst+++        -- SSE2 floating point: we use a restricted set of the available SSE2+        -- instructions for floating-point.+        -- use MOV for moving (either movss or movsd (movlpd better?))+        | CVTSS2SD      Reg Reg            -- F32 to F64+        | CVTSD2SS      Reg Reg            -- F64 to F32+        | CVTTSS2SIQ    Format Operand Reg -- F32 to I32/I64 (with truncation)+        | CVTTSD2SIQ    Format Operand Reg -- F64 to I32/I64 (with truncation)+        | CVTSI2SS      Format Operand Reg -- I32/I64 to F32+        | CVTSI2SD      Format Operand Reg -- I32/I64 to F64++        -- use ADD, SUB, and SQRT for arithmetic.  In both cases, operands+        -- are  Operand Reg.++        -- SSE2 floating-point division:+        | FDIV          Format Operand Operand   -- divisor, dividend(dst)++        -- use CMP for comparisons.  ucomiss and ucomisd instructions+        -- compare single/double prec floating point respectively.++        | SQRT          Format Operand Reg      -- src, dst+++        -- Comparison+        | TEST          Format Operand Operand+        | CMP           Format Operand Operand+        | SETCC         Cond Operand++        -- Stack Operations.+        | PUSH          Format Operand+        | POP           Format Operand+        -- both unused (SDM):+        --  | PUSHA+        --  | POPA++        -- Jumping around.+        | JMP         Operand [Reg] -- including live Regs at the call+        | JXX         Cond BlockId  -- includes unconditional branches+        | JXX_GBL     Cond Imm      -- non-local version of JXX+        -- Table jump+        | JMP_TBL     Operand   -- Address to jump to+                      [Maybe JumpDest] -- Targets of the jump table+                      Section   -- Data section jump table should be put in+                      CLabel    -- Label of jump table+        | CALL        (Either Imm Reg) [Reg]++        -- Other things.+        | CLTD Format            -- sign extend %eax into %edx:%eax++        | FETCHGOT    Reg        -- pseudo-insn for ELF position-independent code+                                 -- pretty-prints as+                                 --       call 1f+                                 -- 1:    popl %reg+                                 --       addl __GLOBAL_OFFSET_TABLE__+.-1b, %reg+        | FETCHPC     Reg        -- pseudo-insn for Darwin position-independent code+                                 -- pretty-prints as+                                 --       call 1f+                                 -- 1:    popl %reg++    -- bit counting instructions+        | POPCNT      Format Operand Reg -- [SSE4.2] count number of bits set to 1+        | LZCNT       Format Operand Reg -- [BMI2] count number of leading zeros+        | TZCNT       Format Operand Reg -- [BMI2] count number of trailing zeros+        | BSF         Format Operand Reg -- bit scan forward+        | BSR         Format Operand Reg -- bit scan reverse++    -- bit manipulation instructions+        | PDEP        Format Operand Operand Reg -- [BMI2] deposit bits to   the specified mask+        | PEXT        Format Operand Operand Reg -- [BMI2] extract bits from the specified mask++    -- prefetch+        | PREFETCH  PrefetchVariant Format Operand -- prefetch Variant, addr size, address to prefetch+                                        -- variant can be NTA, Lvl0, Lvl1, or Lvl2++        | LOCK        Instr -- lock prefix+        | XADD        Format Operand Operand -- src (r), dst (r/m)+        | CMPXCHG     Format Operand Operand -- src (r), dst (r/m), eax implicit+        | MFENCE++data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2+++data Operand+        = OpReg  Reg            -- register+        | OpImm  Imm            -- immediate value+        | OpAddr AddrMode       -- memory reference++++-- | Returns which registers are read and written as a (read, written)+-- pair.+x86_regUsageOfInstr :: Platform -> Instr -> RegUsage+x86_regUsageOfInstr platform instr+ = case instr of+    MOV    _ src dst    -> usageRW src dst+    CMOV _ _ src dst    -> mkRU (use_R src [dst]) [dst]+    MOVZxL _ src dst    -> usageRW src dst+    MOVSxL _ src dst    -> usageRW src dst+    LEA    _ src dst    -> usageRW src dst+    ADD    _ src dst    -> usageRM src dst+    ADC    _ src dst    -> usageRM src dst+    SUB    _ src dst    -> usageRM src dst+    SBB    _ src dst    -> usageRM src dst+    IMUL   _ src dst    -> usageRM src dst++    -- Result of IMULB will be in just in %ax+    IMUL2  II8 src       -> mkRU (eax:use_R src []) [eax]+    -- Result of IMUL for wider values, will be split between %dx/%edx/%rdx and+    -- %ax/%eax/%rax.+    IMUL2  _ src        -> mkRU (eax:use_R src []) [eax,edx]++    MUL    _ src dst    -> usageRM src dst+    MUL2   _ src        -> mkRU (eax:use_R src []) [eax,edx]+    DIV    _ op -> mkRU (eax:edx:use_R op []) [eax,edx]+    IDIV   _ op -> mkRU (eax:edx:use_R op []) [eax,edx]+    ADD_CC _ src dst    -> usageRM src dst+    SUB_CC _ src dst    -> usageRM src dst+    AND    _ src dst    -> usageRM src dst+    OR     _ src dst    -> usageRM src dst++    XOR    _ (OpReg src) (OpReg dst)+        | src == dst    -> mkRU [] [dst]++    XOR    _ src dst    -> usageRM src dst+    NOT    _ op         -> usageM op+    BSWAP  _ reg        -> mkRU [reg] [reg]+    NEGI   _ op         -> usageM op+    SHL    _ imm dst    -> usageRM imm dst+    SAR    _ imm dst    -> usageRM imm dst+    SHR    _ imm dst    -> usageRM imm dst+    BT     _ _   src    -> mkRUR (use_R src [])++    PUSH   _ op         -> mkRUR (use_R op [])+    POP    _ op         -> mkRU [] (def_W op)+    TEST   _ src dst    -> mkRUR (use_R src $! use_R dst [])+    CMP    _ src dst    -> mkRUR (use_R src $! use_R dst [])+    SETCC  _ op         -> mkRU [] (def_W op)+    JXX    _ _          -> mkRU [] []+    JXX_GBL _ _         -> mkRU [] []+    JMP     op regs     -> mkRUR (use_R op regs)+    JMP_TBL op _ _ _    -> mkRUR (use_R op [])+    CALL (Left _)  params   -> mkRU params (callClobberedRegs platform)+    CALL (Right reg) params -> mkRU (reg:params) (callClobberedRegs platform)+    CLTD   _            -> mkRU [eax] [edx]+    NOP                 -> mkRU [] []++    X87Store    _  dst    -> mkRUR ( use_EA dst [])++    CVTSS2SD   src dst  -> mkRU [src] [dst]+    CVTSD2SS   src dst  -> mkRU [src] [dst]+    CVTTSS2SIQ _ src dst -> mkRU (use_R src []) [dst]+    CVTTSD2SIQ _ src dst -> mkRU (use_R src []) [dst]+    CVTSI2SS   _ src dst -> mkRU (use_R src []) [dst]+    CVTSI2SD   _ src dst -> mkRU (use_R src []) [dst]+    FDIV _     src dst  -> usageRM src dst+    SQRT _ src dst      -> mkRU (use_R src []) [dst]++    FETCHGOT reg        -> mkRU [] [reg]+    FETCHPC  reg        -> mkRU [] [reg]++    COMMENT _           -> noUsage+    LOCATION{}          -> noUsage+    UNWIND{}            -> noUsage+    DELTA   _           -> noUsage++    POPCNT _ src dst -> mkRU (use_R src []) [dst]+    LZCNT  _ src dst -> mkRU (use_R src []) [dst]+    TZCNT  _ src dst -> mkRU (use_R src []) [dst]+    BSF    _ src dst -> mkRU (use_R src []) [dst]+    BSR    _ src dst -> mkRU (use_R src []) [dst]++    PDEP   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst]+    PEXT   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst]++    -- note: might be a better way to do this+    PREFETCH _  _ src -> mkRU (use_R src []) []+    LOCK i              -> x86_regUsageOfInstr platform i+    XADD _ src dst      -> usageMM src dst+    CMPXCHG _ src dst   -> usageRMM src dst (OpReg eax)+    MFENCE -> noUsage++    _other              -> panic "regUsage: unrecognised instr"+ where+    -- # Definitions+    --+    -- Written: If the operand is a register, it's written. If it's an+    -- address, registers mentioned in the address are read.+    --+    -- Modified: If the operand is a register, it's both read and+    -- written. If it's an address, registers mentioned in the address+    -- are read.++    -- 2 operand form; first operand Read; second Written+    usageRW :: Operand -> Operand -> RegUsage+    usageRW op (OpReg reg)      = mkRU (use_R op []) [reg]+    usageRW op (OpAddr ea)      = mkRUR (use_R op $! use_EA ea [])+    usageRW _ _                 = panic "X86.RegInfo.usageRW: no match"++    -- 2 operand form; first operand Read; second Modified+    usageRM :: Operand -> Operand -> RegUsage+    usageRM op (OpReg reg)      = mkRU (use_R op [reg]) [reg]+    usageRM op (OpAddr ea)      = mkRUR (use_R op $! use_EA ea [])+    usageRM _ _                 = panic "X86.RegInfo.usageRM: no match"++    -- 2 operand form; first operand Modified; second Modified+    usageMM :: Operand -> Operand -> RegUsage+    usageMM (OpReg src) (OpReg dst) = mkRU [src, dst] [src, dst]+    usageMM (OpReg src) (OpAddr ea) = mkRU (use_EA ea [src]) [src]+    usageMM _ _                     = panic "X86.RegInfo.usageMM: no match"++    -- 3 operand form; first operand Read; second Modified; third Modified+    usageRMM :: Operand -> Operand -> Operand -> RegUsage+    usageRMM (OpReg src) (OpReg dst) (OpReg reg) = mkRU [src, dst, reg] [dst, reg]+    usageRMM (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [src, reg]) [reg]+    usageRMM _ _ _                               = panic "X86.RegInfo.usageRMM: no match"++    -- 1 operand form; operand Modified+    usageM :: Operand -> RegUsage+    usageM (OpReg reg)          = mkRU [reg] [reg]+    usageM (OpAddr ea)          = mkRUR (use_EA ea [])+    usageM _                    = panic "X86.RegInfo.usageM: no match"++    -- Registers defd when an operand is written.+    def_W (OpReg reg)           = [reg]+    def_W (OpAddr _ )           = []+    def_W _                     = panic "X86.RegInfo.def_W: no match"++    -- Registers used when an operand is read.+    use_R (OpReg reg)  tl = reg : tl+    use_R (OpImm _)    tl = tl+    use_R (OpAddr ea)  tl = use_EA ea tl++    -- Registers used to compute an effective address.+    use_EA (ImmAddr _ _) tl = tl+    use_EA (AddrBaseIndex base index _) tl =+        use_base base $! use_index index tl+        where use_base (EABaseReg r)  tl = r : tl+              use_base _              tl = tl+              use_index EAIndexNone   tl = tl+              use_index (EAIndex i _) tl = i : tl++    mkRUR src = src' `seq` RU src' []+        where src' = filter (interesting platform) src++    mkRU src dst = src' `seq` dst' `seq` RU src' dst'+        where src' = filter (interesting platform) src+              dst' = filter (interesting platform) dst++-- | Is this register interesting for the register allocator?+interesting :: Platform -> Reg -> Bool+interesting _        (RegVirtual _)              = True+interesting platform (RegReal (RealRegSingle i)) = freeReg platform i+interesting _        (RegReal (RealRegPair{}))   = panic "X86.interesting: no reg pairs on this arch"++++-- | Applies the supplied function to all registers in instructions.+-- Typically used to change virtual registers to real registers.+x86_patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr+x86_patchRegsOfInstr instr env+ = case instr of+    MOV  fmt src dst     -> patch2 (MOV  fmt) src dst+    CMOV cc fmt src dst  -> CMOV cc fmt (patchOp src) (env dst)+    MOVZxL fmt src dst   -> patch2 (MOVZxL fmt) src dst+    MOVSxL fmt src dst   -> patch2 (MOVSxL fmt) src dst+    LEA  fmt src dst     -> patch2 (LEA  fmt) src dst+    ADD  fmt src dst     -> patch2 (ADD  fmt) src dst+    ADC  fmt src dst     -> patch2 (ADC  fmt) src dst+    SUB  fmt src dst     -> patch2 (SUB  fmt) src dst+    SBB  fmt src dst     -> patch2 (SBB  fmt) src dst+    IMUL fmt src dst     -> patch2 (IMUL fmt) src dst+    IMUL2 fmt src        -> patch1 (IMUL2 fmt) src+    MUL fmt src dst      -> patch2 (MUL fmt) src dst+    MUL2 fmt src         -> patch1 (MUL2 fmt) src+    IDIV fmt op          -> patch1 (IDIV fmt) op+    DIV fmt op           -> patch1 (DIV fmt) op+    ADD_CC fmt src dst   -> patch2 (ADD_CC fmt) src dst+    SUB_CC fmt src dst   -> patch2 (SUB_CC fmt) src dst+    AND  fmt src dst     -> patch2 (AND  fmt) src dst+    OR   fmt src dst     -> patch2 (OR   fmt) src dst+    XOR  fmt src dst     -> patch2 (XOR  fmt) src dst+    NOT  fmt op          -> patch1 (NOT  fmt) op+    BSWAP fmt reg        -> BSWAP fmt (env reg)+    NEGI fmt op          -> patch1 (NEGI fmt) op+    SHL  fmt imm dst     -> patch1 (SHL fmt imm) dst+    SAR  fmt imm dst     -> patch1 (SAR fmt imm) dst+    SHR  fmt imm dst     -> patch1 (SHR fmt imm) dst+    BT   fmt imm src     -> patch1 (BT  fmt imm) src+    TEST fmt src dst     -> patch2 (TEST fmt) src dst+    CMP  fmt src dst     -> patch2 (CMP  fmt) src dst+    PUSH fmt op          -> patch1 (PUSH fmt) op+    POP  fmt op          -> patch1 (POP  fmt) op+    SETCC cond op        -> patch1 (SETCC cond) op+    JMP op regs          -> JMP (patchOp op) regs+    JMP_TBL op ids s lbl -> JMP_TBL (patchOp op) ids s lbl++    -- literally only support storing the top x87 stack value st(0)+    X87Store  fmt  dst     -> X87Store fmt  (lookupAddr dst)++    CVTSS2SD src dst    -> CVTSS2SD (env src) (env dst)+    CVTSD2SS src dst    -> CVTSD2SS (env src) (env dst)+    CVTTSS2SIQ fmt src dst -> CVTTSS2SIQ fmt (patchOp src) (env dst)+    CVTTSD2SIQ fmt src dst -> CVTTSD2SIQ fmt (patchOp src) (env dst)+    CVTSI2SS fmt src dst -> CVTSI2SS fmt (patchOp src) (env dst)+    CVTSI2SD fmt src dst -> CVTSI2SD fmt (patchOp src) (env dst)+    FDIV fmt src dst     -> FDIV fmt (patchOp src) (patchOp dst)+    SQRT fmt src dst    -> SQRT fmt (patchOp src) (env dst)++    CALL (Left _)  _    -> instr+    CALL (Right reg) p  -> CALL (Right (env reg)) p++    FETCHGOT reg        -> FETCHGOT (env reg)+    FETCHPC  reg        -> FETCHPC  (env reg)++    NOP                 -> instr+    COMMENT _           -> instr+    LOCATION {}         -> instr+    UNWIND {}           -> instr+    DELTA _             -> instr++    JXX _ _             -> instr+    JXX_GBL _ _         -> instr+    CLTD _              -> instr++    POPCNT fmt src dst -> POPCNT fmt (patchOp src) (env dst)+    LZCNT  fmt src dst -> LZCNT  fmt (patchOp src) (env dst)+    TZCNT  fmt src dst -> TZCNT  fmt (patchOp src) (env dst)+    PDEP   fmt src mask dst -> PDEP   fmt (patchOp src) (patchOp mask) (env dst)+    PEXT   fmt src mask dst -> PEXT   fmt (patchOp src) (patchOp mask) (env dst)+    BSF    fmt src dst -> BSF    fmt (patchOp src) (env dst)+    BSR    fmt src dst -> BSR    fmt (patchOp src) (env dst)++    PREFETCH lvl format src -> PREFETCH lvl format (patchOp src)++    LOCK i               -> LOCK (x86_patchRegsOfInstr i env)+    XADD fmt src dst     -> patch2 (XADD fmt) src dst+    CMPXCHG fmt src dst  -> patch2 (CMPXCHG fmt) src dst+    MFENCE               -> instr++    _other              -> panic "patchRegs: unrecognised instr"++  where+    patch1 :: (Operand -> a) -> Operand -> a+    patch1 insn op      = insn $! patchOp op+    patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a+    patch2 insn src dst = (insn $! patchOp src) $! patchOp dst++    patchOp (OpReg  reg) = OpReg $! env reg+    patchOp (OpImm  imm) = OpImm imm+    patchOp (OpAddr ea)  = OpAddr $! lookupAddr ea++    lookupAddr (ImmAddr imm off) = ImmAddr imm off+    lookupAddr (AddrBaseIndex base index disp)+      = ((AddrBaseIndex $! lookupBase base) $! lookupIndex index) disp+      where+        lookupBase EABaseNone       = EABaseNone+        lookupBase EABaseRip        = EABaseRip+        lookupBase (EABaseReg r)    = EABaseReg $! env r++        lookupIndex EAIndexNone     = EAIndexNone+        lookupIndex (EAIndex r i)   = (EAIndex $! env r) i+++--------------------------------------------------------------------------------+x86_isJumpishInstr+        :: Instr -> Bool++x86_isJumpishInstr instr+ = case instr of+        JMP{}           -> True+        JXX{}           -> True+        JXX_GBL{}       -> True+        JMP_TBL{}       -> True+        CALL{}          -> True+        _               -> False+++x86_jumpDestsOfInstr+        :: Instr+        -> [BlockId]++x86_jumpDestsOfInstr insn+  = case insn of+        JXX _ id        -> [id]+        JMP_TBL _ ids _ _ -> [id | Just (DestBlockId id) <- ids]+        _               -> []+++x86_patchJumpInstr+        :: Instr -> (BlockId -> BlockId) -> Instr++x86_patchJumpInstr insn patchF+  = case insn of+        JXX cc id       -> JXX cc (patchF id)+        JMP_TBL op ids section lbl+          -> JMP_TBL op (map (fmap (patchJumpDest patchF)) ids) section lbl+        _               -> insn+    where+        patchJumpDest f (DestBlockId id) = DestBlockId (f id)+        patchJumpDest _ dest             = dest++++++-- -----------------------------------------------------------------------------+-- | Make a spill instruction.+x86_mkSpillInstr+    :: DynFlags+    -> Reg      -- register to spill+    -> Int      -- current stack delta+    -> Int      -- spill slot to use+    -> Instr++x86_mkSpillInstr dflags reg delta slot+  = let off     = spillSlotToOffset platform slot - delta+    in+    case targetClassOfReg platform reg of+           RcInteger   -> MOV (archWordFormat is32Bit)+                              (OpReg reg) (OpAddr (spRel dflags off))+           RcDouble    -> MOV FF64 (OpReg reg) (OpAddr (spRel dflags off))+           _         -> panic "X86.mkSpillInstr: no match"+    where platform = targetPlatform dflags+          is32Bit = target32Bit platform++-- | Make a spill reload instruction.+x86_mkLoadInstr+    :: DynFlags+    -> Reg      -- register to load+    -> Int      -- current stack delta+    -> Int      -- spill slot to use+    -> Instr++x86_mkLoadInstr dflags reg delta slot+  = let off     = spillSlotToOffset platform slot - delta+    in+        case targetClassOfReg platform reg of+              RcInteger -> MOV (archWordFormat is32Bit)+                               (OpAddr (spRel dflags off)) (OpReg reg)+              RcDouble  -> MOV FF64 (OpAddr (spRel dflags off)) (OpReg reg)+              _           -> panic "X86.x86_mkLoadInstr"+    where platform = targetPlatform dflags+          is32Bit = target32Bit platform++spillSlotSize :: Platform -> Int+spillSlotSize dflags = if is32Bit then 12 else 8+    where is32Bit = target32Bit dflags++maxSpillSlots :: DynFlags -> Int+maxSpillSlots dflags+    = ((rESERVED_C_STACK_BYTES dflags - 64) `div` spillSlotSize (targetPlatform dflags)) - 1+--     = 0 -- useful for testing allocMoreStack++-- number of bytes that the stack pointer should be aligned to+stackAlign :: Int+stackAlign = 16++-- convert a spill slot number to a *byte* offset, with no sign:+-- decide on a per arch basis whether you are spilling above or below+-- the C stack pointer.+spillSlotToOffset :: Platform -> Int -> Int+spillSlotToOffset platform slot+   = 64 + spillSlotSize platform * slot++--------------------------------------------------------------------------------++-- | See if this instruction is telling us the current C stack delta+x86_takeDeltaInstr+        :: Instr+        -> Maybe Int++x86_takeDeltaInstr instr+ = case instr of+        DELTA i         -> Just i+        _               -> Nothing+++x86_isMetaInstr+        :: Instr+        -> Bool++x86_isMetaInstr instr+ = case instr of+        COMMENT{}       -> True+        LOCATION{}      -> True+        LDATA{}         -> True+        NEWBLOCK{}      -> True+        UNWIND{}        -> True+        DELTA{}         -> True+        _               -> False++++---  TODO: why is there+-- | Make a reg-reg move instruction.+--      On SPARC v8 there are no instructions to move directly between+--      floating point and integer regs. If we need to do that then we+--      have to go via memory.+--+x86_mkRegRegMoveInstr+    :: Platform+    -> Reg+    -> Reg+    -> Instr++x86_mkRegRegMoveInstr platform src dst+ = case targetClassOfReg platform src of+        RcInteger -> case platformArch platform of+                     ArchX86    -> MOV II32 (OpReg src) (OpReg dst)+                     ArchX86_64 -> MOV II64 (OpReg src) (OpReg dst)+                     _          -> panic "x86_mkRegRegMoveInstr: Bad arch"+        RcDouble    ->  MOV FF64 (OpReg src) (OpReg dst)+        -- this code is the lie we tell ourselves because both float and double+        -- use the same register class.on x86_64 and x86 32bit with SSE2,+        -- more plainly, both use the XMM registers+        _     -> panic "X86.RegInfo.mkRegRegMoveInstr: no match"++-- | Check whether an instruction represents a reg-reg move.+--      The register allocator attempts to eliminate reg->reg moves whenever it can,+--      by assigning the src and dest temporaries to the same real register.+--+x86_takeRegRegMoveInstr+        :: Instr+        -> Maybe (Reg,Reg)++x86_takeRegRegMoveInstr (MOV _ (OpReg r1) (OpReg r2))+        = Just (r1,r2)++x86_takeRegRegMoveInstr _  = Nothing+++-- | Make an unconditional branch instruction.+x86_mkJumpInstr+        :: BlockId+        -> [Instr]++x86_mkJumpInstr id+        = [JXX ALWAYS id]++-- Note [Windows stack layout]+-- | On most OSes the kernel will place a guard page after the current stack+--   page.  If you allocate larger than a page worth you may jump over this+--   guard page.  Not only is this a security issue, but on certain OSes such+--   as Windows a new page won't be allocated if you don't hit the guard.  This+--   will cause a segfault or access fault.+--+--   This function defines if the current allocation amount requires a probe.+--   On Windows (for now) we emit a call to _chkstk for this.  For other OSes+--   this is not yet implemented.+--   See https://docs.microsoft.com/en-us/windows/desktop/DevNotes/-win32-chkstk+--   The Windows stack looks like this:+--+--                         +-------------------++--                         |        SP         |+--                         +-------------------++--                         |                   |+--                         |    GUARD PAGE     |+--                         |                   |+--                         +-------------------++--                         |                   |+--                         |                   |+--                         |     UNMAPPED      |+--                         |                   |+--                         |                   |+--                         +-------------------++--+--   In essense each allocation larger than a page size needs to be chunked and+--   a probe emitted after each page allocation.  You have to hit the guard+--   page so the kernel can map in the next page, otherwise you'll segfault.+--+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 view
@@ -0,0 +1,1010 @@+{-# 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"+#include "nativeGen/NCG.h"++import GhcPrelude++import X86.Regs+import X86.Instr+import X86.Cond+import Instruction+import Format+import Reg+import PprBase+++import Hoopl.Collections+import Hoopl.Label+import BasicTypes       (Alignment, mkAlignment, alignmentBytes)+import DynFlags+import Cmm              hiding (topInfoTable)+import BlockId+import CLabel+import Unique           ( pprUniqueAlways )+import 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 view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+module X86.RegInfo (+        mkVirtualReg,+        regDotColor+)++where++#include "nativeGen/NCG.h"+#include "HsVersions.h"++import GhcPrelude++import Format+import Reg++import Outputable+import 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 view
@@ -0,0 +1,443 @@+{-# 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 "nativeGen/NCG.h"+#include "HsVersions.h"++import GhcPrelude++import CodeGen.Platform+import Reg+import RegClass++import Cmm+import CLabel           ( CLabel )+import DynFlags+import Outputable+import 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
@@ -0,0 +1,285 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++-}++{-# LANGUAGE CPP #-}++-- | The @PrelInfo@ interface to the compiler's prelude knowledge.+--+-- This module serves as the central gathering point for names which the+-- compiler knows something about. This includes functions for,+--+--  * discerning whether a 'Name' is known-key+--+--  * given a 'Unique', looking up its corresponding known-key 'Name'+--+-- See Note [Known-key names] and Note [About wired-in things] for information+-- about the two types of prelude things in GHC.+--+module PrelInfo (+        -- * Known-key names+        isKnownKeyName,+        lookupKnownKeyName,+        lookupKnownNameInfo,++        -- ** Internal use+        -- | 'knownKeyNames' is exported to seed the original name cache only;+        -- if you find yourself wanting to look at it you might consider using+        -- 'lookupKnownKeyName' or 'isKnownKeyName'.+        knownKeyNames,++        -- * Miscellaneous+        wiredInIds, ghcPrimIds,+        primOpRules, builtinRules,++        ghcPrimExports,+        primOpId,++        -- * Random other things+        maybeCharLikeCon, maybeIntLikeCon,++        -- * Class categories+        isNumericClass, isStandardClass++    ) where++#include "HsVersions.h"++import GhcPrelude++import KnownUniques+import Unique           ( isValidKnownKeyUnique )++import ConLike          ( ConLike(..) )+import THNames          ( templateHaskellNames )+import PrelNames+import PrelRules+import Avail+import PrimOp+import DataCon+import Id+import Name+import NameEnv+import MkId+import Outputable+import TysPrim+import TysWiredIn+import HscTypes+import Class+import TyCon+import UniqFM+import Util+import TcTypeNats ( typeNatTyCons )++import Control.Applicative ((<|>))+import Data.List        ( intercalate )+import Data.Array+import Data.Maybe++{-+************************************************************************+*                                                                      *+\subsection[builtinNameInfo]{Lookup built-in names}+*                                                                      *+************************************************************************++Note [About wired-in things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Wired-in things are Ids\/TyCons that are completely known to the compiler.+  They are global values in GHC, (e.g.  listTyCon :: TyCon).++* A wired in Name contains the thing itself inside the Name:+        see Name.wiredInNameTyThing_maybe+  (E.g. listTyConName contains listTyCon.++* The name cache is initialised with (the names of) all wired-in things+  (except tuples and sums; see Note [Known-])++* The type environment itself contains no wired in things. The type+  checker sees if the Name is wired in before looking up the name in+  the type environment.++* MkIface prunes out wired-in things before putting them in an interface file.+  So interface files never contain wired-in things.+-}+++-- | This list is used to ensure that when you say "Prelude.map" in your source+-- code, or in an interface file, you get a Name with the correct known key (See+-- Note [Known-key names] in PrelNames)+knownKeyNames :: [Name]+knownKeyNames+  | debugIsOn+  , Just badNamesStr <- knownKeyNamesOkay all_names+  = panic ("badAllKnownKeyNames:\n" ++ badNamesStr)+       -- NB: We can't use ppr here, because this is sometimes evaluated in a+       -- context where there are no DynFlags available, leading to a cryptic+       -- "<<details unavailable>>" error. (This seems to happen only in the+       -- stage 2 compiler, for reasons I [Richard] have no clue of.)+  | otherwise+  = all_names+  where+    all_names =+      concat [ wired_tycon_kk_names funTyCon+             , concatMap wired_tycon_kk_names primTyCons++             , concatMap wired_tycon_kk_names wiredInTyCons+               -- Does not include tuples++             , concatMap wired_tycon_kk_names typeNatTyCons++             , map idName wiredInIds+             , map (idName . primOpId) allThePrimOps+             , basicKnownKeyNames+             , templateHaskellNames+             ]+    -- All of the names associated with a wired-in TyCon.+    -- This includes the TyCon itself, its DataCons and promoted TyCons.+    wired_tycon_kk_names :: TyCon -> [Name]+    wired_tycon_kk_names tc =+        tyConName tc : (rep_names tc ++ implicits)+      where implicits = concatMap thing_kk_names (implicitTyConThings tc)++    wired_datacon_kk_names :: DataCon -> [Name]+    wired_datacon_kk_names dc =+      dataConName dc : rep_names (promoteDataCon dc)++    thing_kk_names :: TyThing -> [Name]+    thing_kk_names (ATyCon tc)                 = wired_tycon_kk_names tc+    thing_kk_names (AConLike (RealDataCon dc)) = wired_datacon_kk_names dc+    thing_kk_names thing                       = [getName thing]++    -- The TyConRepName for a known-key TyCon has a known key,+    -- but isn't itself an implicit thing.  Yurgh.+    -- NB: if any of the wired-in TyCons had record fields, the record+    --     field names would be in a similar situation.  Ditto class ops.+    --     But it happens that there aren't any+    rep_names tc = case tyConRepName_maybe tc of+                        Just n  -> [n]+                        Nothing -> []++-- | Check the known-key names list of consistency.+knownKeyNamesOkay :: [Name] -> Maybe String+knownKeyNamesOkay all_names+  | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names+  = Just $ "    Out-of-range known-key uniques: ["+        ++ intercalate ", " (map (occNameString . nameOccName) ns) +++         "]"+  | null badNamesPairs+  = Nothing+  | otherwise+  = Just badNamesStr+  where+    namesEnv      = foldl' (\m n -> extendNameEnv_Acc (:) singleton m n n)+                           emptyUFM all_names+    badNamesEnv   = filterNameEnv (\ns -> ns `lengthExceeds` 1) namesEnv+    badNamesPairs = nonDetUFMToList badNamesEnv+      -- It's OK to use nonDetUFMToList here because the ordering only affects+      -- the message when we get a panic+    badNamesStrs  = map pairToStr badNamesPairs+    badNamesStr   = unlines badNamesStrs++    pairToStr (uniq, ns) = "        " +++                           show uniq +++                           ": [" +++                           intercalate ", " (map (occNameString . nameOccName) ns) +++                           "]"++-- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a+-- known-key thing.+lookupKnownKeyName :: Unique -> Maybe Name+lookupKnownKeyName u =+    knownUniqueName u <|> lookupUFM knownKeysMap u++-- | Is a 'Name' known-key?+isKnownKeyName :: Name -> Bool+isKnownKeyName n =+    isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap++knownKeysMap :: UniqFM Name+knownKeysMap = listToUFM [ (nameUnique n, n) | n <- knownKeyNames ]++-- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by+-- GHCi's ':info' command.+lookupKnownNameInfo :: Name -> SDoc+lookupKnownNameInfo name = case lookupNameEnv knownNamesInfo name of+    -- If we do find a doc, we add comment delimeters to make the output+    -- of ':info' valid Haskell.+    Nothing  -> empty+    Just doc -> vcat [text "{-", doc, text "-}"]++-- A map from Uniques to SDocs, used in GHCi's ':info' command. (#12390)+knownNamesInfo :: NameEnv SDoc+knownNamesInfo = unitNameEnv coercibleTyConName $+    vcat [ text "Coercible is a special constraint with custom solving rules."+         , text "It is not a class."+         , text "Please see section 9.14.4 of the user's guide for details." ]++{-+We let a lot of "non-standard" values be visible, so that we can make+sense of them in interface pragmas. It's cool, though they all have+"non-standard" names, so they won't get past the parser in user code.++************************************************************************+*                                                                      *+                PrimOpIds+*                                                                      *+************************************************************************+-}++primOpIds :: Array Int Id+-- A cache of the PrimOp Ids, indexed by PrimOp tag+primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op)+                                   | op <- allThePrimOps ]++primOpId :: PrimOp -> Id+primOpId op = primOpIds ! primOpTag op++{-+************************************************************************+*                                                                      *+            Export lists for pseudo-modules (GHC.Prim)+*                                                                      *+************************************************************************++GHC.Prim "exports" all the primops and primitive types, some+wired-in Ids.+-}++ghcPrimExports :: [IfaceExport]+ghcPrimExports+ = map (avail . idName) ghcPrimIds +++   map (avail . idName . primOpId) allThePrimOps +++   [ AvailTC n [n] []+   | tc <- funTyCon : exposedPrimTyCons, let n = tyConName tc  ]++{-+************************************************************************+*                                                                      *+            Built-in keys+*                                                                      *+************************************************************************++ToDo: make it do the ``like'' part properly (as in 0.26 and before).+-}++maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool+maybeCharLikeCon con = con `hasKey` charDataConKey+maybeIntLikeCon  con = con `hasKey` intDataConKey++{-+************************************************************************+*                                                                      *+            Class predicates+*                                                                      *+************************************************************************+-}++isNumericClass, isStandardClass :: Class -> Bool++isNumericClass     clas = classKey clas `is_elem` numericClassKeys+isStandardClass    clas = classKey clas `is_elem` standardClassKeys++is_elem :: Eq a => a -> [a] -> Bool+is_elem = isIn "is_X_Class"
+ compiler/prelude/THNames.hs view
@@ -0,0 +1,1105 @@+-- %************************************************************************+-- %*                                                                   *+--              The known-key names for Template Haskell+-- %*                                                                   *+-- %************************************************************************++module THNames where++import GhcPrelude ()++import PrelNames( mk_known_key_name )+import Module( Module, mkModuleNameFS, mkModule, thUnitId )+import Name( Name )+import OccName( tcName, clsName, dataName, varName )+import RdrName( RdrName, nameRdrName )+import Unique+import FastString++-- To add a name, do three things+--+--  1) Allocate a key+--  2) Make a "Name"+--  3) Add the name to templateHaskellNames++templateHaskellNames :: [Name]+-- The names that are implicitly mentioned by ``bracket''+-- Should stay in sync with the import list of DsMeta++templateHaskellNames = [+    returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,+    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,+    mkNameSName,+    liftStringName,+    unTypeName,+    unTypeQName,+    unsafeTExpCoerceName,++    -- Lit+    charLName, stringLName, integerLName, intPrimLName, wordPrimLName,+    floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,+    charPrimLName,+    -- Pat+    litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName,+    conPName, tildePName, bangPName, infixPName,+    asPName, wildPName, recPName, listPName, sigPName, viewPName,+    -- FieldPat+    fieldPatName,+    -- Match+    matchName,+    -- Clause+    clauseName,+    -- Exp+    varEName, conEName, litEName, appEName, appTypeEName, infixEName,+    infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,+    tupEName, unboxedTupEName, unboxedSumEName,+    condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName,+    fromEName, fromThenEName, fromToEName, fromThenToEName,+    listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,+    labelEName, implicitParamVarEName,+    -- FieldExp+    fieldExpName,+    -- Body+    guardedBName, normalBName,+    -- Guard+    normalGEName, patGEName,+    -- Stmt+    bindSName, letSName, noBindSName, parSName, recSName,+    -- Dec+    funDName, valDName, dataDName, newtypeDName, tySynDName,+    classDName, instanceWithOverlapDName,+    standaloneDerivWithStrategyDName, sigDName, forImpDName,+    pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,+    pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName,+    dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,+    dataInstDName, newtypeInstDName, tySynInstDName,+    infixLDName, infixRDName, infixNDName,+    roleAnnotDName, patSynDName, patSynSigDName,+    implicitParamBindDName,+    -- Cxt+    cxtName,++    -- SourceUnpackedness+    noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName,+    -- SourceStrictness+    noSourceStrictnessName, sourceLazyName, sourceStrictName,+    -- Con+    normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName,+    -- Bang+    bangName,+    -- BangType+    bangTypeName,+    -- VarBangType+    varBangTypeName,+    -- PatSynDir (for pattern synonyms)+    unidirPatSynName, implBidirPatSynName, explBidirPatSynName,+    -- PatSynArgs (for pattern synonyms)+    prefixPatSynName, infixPatSynName, recordPatSynName,+    -- Type+    forallTName, forallVisTName, varTName, conTName, infixTName, appTName,+    appKindTName, equalityTName, tupleTName, unboxedTupleTName,+    unboxedSumTName, arrowTName, listTName, sigTName, litTName,+    promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,+    wildCardTName, implicitParamTName,+    -- TyLit+    numTyLitName, strTyLitName,+    -- TyVarBndr+    plainTVName, kindedTVName,+    -- Role+    nominalRName, representationalRName, phantomRName, inferRName,+    -- Kind+    varKName, conKName, tupleKName, arrowKName, listKName, appKName,+    starKName, constraintKName,+    -- FamilyResultSig+    noSigName, kindSigName, tyVarSigName,+    -- InjectivityAnn+    injectivityAnnName,+    -- Callconv+    cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName,+    -- Safety+    unsafeName,+    safeName,+    interruptibleName,+    -- Inline+    noInlineDataConName, inlineDataConName, inlinableDataConName,+    -- RuleMatch+    conLikeDataConName, funLikeDataConName,+    -- Phases+    allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName,+    -- Overlap+    overlappableDataConName, overlappingDataConName, overlapsDataConName,+    incoherentDataConName,+    -- DerivStrategy+    stockStrategyName, anyclassStrategyName,+    newtypeStrategyName, viaStrategyName,+    -- TExp+    tExpDataConName,+    -- RuleBndr+    ruleVarName, typedRuleVarName,+    -- FunDep+    funDepName,+    -- TySynEqn+    tySynEqnName,+    -- AnnTarget+    valueAnnotationName, typeAnnotationName, moduleAnnotationName,+    -- DerivClause+    derivClauseName,++    -- The type classes+    liftClassName,++    -- And the tycons+    qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,+    clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,+    stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName,+    varBangTypeQTyConName, typeQTyConName, expTyConName, decTyConName,+    typeTyConName, tyVarBndrQTyConName, matchTyConName, clauseTyConName,+    patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,+    predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,+    roleTyConName, tExpTyConName, injAnnTyConName, kindQTyConName,+    overlapTyConName, derivClauseQTyConName, derivStrategyQTyConName,++    -- Quasiquoting+    quoteDecName, quoteTypeName, quoteExpName, quotePatName]++thSyn, thLib, qqLib :: Module+thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")+thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal")+qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")++mkTHModule :: FastString -> Module+mkTHModule m = mkModule thUnitId (mkModuleNameFS m)++libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name+libFun = mk_known_key_name OccName.varName  thLib+libTc  = mk_known_key_name OccName.tcName   thLib+thFun  = mk_known_key_name OccName.varName  thSyn+thTc   = mk_known_key_name OccName.tcName   thSyn+thCls  = mk_known_key_name OccName.clsName  thSyn+thCon  = mk_known_key_name OccName.dataName thSyn+qqFun  = mk_known_key_name OccName.varName  qqLib++-------------------- TH.Syntax -----------------------+liftClassName :: Name+liftClassName = thCls (fsLit "Lift") liftClassKey++qTyConName, nameTyConName, fieldExpTyConName, patTyConName,+    fieldPatTyConName, expTyConName, decTyConName, typeTyConName,+    matchTyConName, clauseTyConName, funDepTyConName, predTyConName,+    tExpTyConName, injAnnTyConName, overlapTyConName :: Name+qTyConName             = thTc (fsLit "Q")              qTyConKey+nameTyConName          = thTc (fsLit "Name")           nameTyConKey+fieldExpTyConName      = thTc (fsLit "FieldExp")       fieldExpTyConKey+patTyConName           = thTc (fsLit "Pat")            patTyConKey+fieldPatTyConName      = thTc (fsLit "FieldPat")       fieldPatTyConKey+expTyConName           = thTc (fsLit "Exp")            expTyConKey+decTyConName           = thTc (fsLit "Dec")            decTyConKey+typeTyConName          = thTc (fsLit "Type")           typeTyConKey+matchTyConName         = thTc (fsLit "Match")          matchTyConKey+clauseTyConName        = thTc (fsLit "Clause")         clauseTyConKey+funDepTyConName        = thTc (fsLit "FunDep")         funDepTyConKey+predTyConName          = thTc (fsLit "Pred")           predTyConKey+tExpTyConName          = thTc (fsLit "TExp")           tExpTyConKey+injAnnTyConName        = thTc (fsLit "InjectivityAnn") injAnnTyConKey+overlapTyConName       = thTc (fsLit "Overlap")        overlapTyConKey++returnQName, bindQName, sequenceQName, newNameName, liftName,+    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,+    mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName,+    unsafeTExpCoerceName, liftTypedName :: Name+returnQName    = thFun (fsLit "returnQ")   returnQIdKey+bindQName      = thFun (fsLit "bindQ")     bindQIdKey+sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey+newNameName    = thFun (fsLit "newName")   newNameIdKey+liftName       = thFun (fsLit "lift")      liftIdKey+liftStringName = thFun (fsLit "liftString")  liftStringIdKey+mkNameName     = thFun (fsLit "mkName")     mkNameIdKey+mkNameG_vName  = thFun (fsLit "mkNameG_v")  mkNameG_vIdKey+mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey+mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey+mkNameLName    = thFun (fsLit "mkNameL")    mkNameLIdKey+mkNameSName    = thFun (fsLit "mkNameS")    mkNameSIdKey+unTypeName     = thFun (fsLit "unType")     unTypeIdKey+unTypeQName    = thFun (fsLit "unTypeQ")    unTypeQIdKey+unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey+liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey+++-------------------- TH.Lib -----------------------+-- data Lit = ...+charLName, stringLName, integerLName, intPrimLName, wordPrimLName,+    floatPrimLName, doublePrimLName, rationalLName, stringPrimLName,+    charPrimLName :: Name+charLName       = libFun (fsLit "charL")       charLIdKey+stringLName     = libFun (fsLit "stringL")     stringLIdKey+integerLName    = libFun (fsLit "integerL")    integerLIdKey+intPrimLName    = libFun (fsLit "intPrimL")    intPrimLIdKey+wordPrimLName   = libFun (fsLit "wordPrimL")   wordPrimLIdKey+floatPrimLName  = libFun (fsLit "floatPrimL")  floatPrimLIdKey+doublePrimLName = libFun (fsLit "doublePrimL") doublePrimLIdKey+rationalLName   = libFun (fsLit "rationalL")     rationalLIdKey+stringPrimLName = libFun (fsLit "stringPrimL") stringPrimLIdKey+charPrimLName   = libFun (fsLit "charPrimL")   charPrimLIdKey++-- data Pat = ...+litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName,+    infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName,+    sigPName, viewPName :: Name+litPName   = libFun (fsLit "litP")   litPIdKey+varPName   = libFun (fsLit "varP")   varPIdKey+tupPName   = libFun (fsLit "tupP")   tupPIdKey+unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey+unboxedSumPName = libFun (fsLit "unboxedSumP") unboxedSumPIdKey+conPName   = libFun (fsLit "conP")   conPIdKey+infixPName = libFun (fsLit "infixP") infixPIdKey+tildePName = libFun (fsLit "tildeP") tildePIdKey+bangPName  = libFun (fsLit "bangP")  bangPIdKey+asPName    = libFun (fsLit "asP")    asPIdKey+wildPName  = libFun (fsLit "wildP")  wildPIdKey+recPName   = libFun (fsLit "recP")   recPIdKey+listPName  = libFun (fsLit "listP")  listPIdKey+sigPName   = libFun (fsLit "sigP")   sigPIdKey+viewPName  = libFun (fsLit "viewP")  viewPIdKey++-- type FieldPat = ...+fieldPatName :: Name+fieldPatName = libFun (fsLit "fieldPat") fieldPatIdKey++-- data Match = ...+matchName :: Name+matchName = libFun (fsLit "match") matchIdKey++-- data Clause = ...+clauseName :: Name+clauseName = libFun (fsLit "clause") clauseIdKey++-- data Exp = ...+varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,+    sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,+    unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,+    caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,+    labelEName, implicitParamVarEName :: Name+varEName              = libFun (fsLit "varE")              varEIdKey+conEName              = libFun (fsLit "conE")              conEIdKey+litEName              = libFun (fsLit "litE")              litEIdKey+appEName              = libFun (fsLit "appE")              appEIdKey+appTypeEName          = libFun (fsLit "appTypeE")          appTypeEIdKey+infixEName            = libFun (fsLit "infixE")            infixEIdKey+infixAppName          = libFun (fsLit "infixApp")          infixAppIdKey+sectionLName          = libFun (fsLit "sectionL")          sectionLIdKey+sectionRName          = libFun (fsLit "sectionR")          sectionRIdKey+lamEName              = libFun (fsLit "lamE")              lamEIdKey+lamCaseEName          = libFun (fsLit "lamCaseE")          lamCaseEIdKey+tupEName              = libFun (fsLit "tupE")              tupEIdKey+unboxedTupEName       = libFun (fsLit "unboxedTupE")       unboxedTupEIdKey+unboxedSumEName       = libFun (fsLit "unboxedSumE")       unboxedSumEIdKey+condEName             = libFun (fsLit "condE")             condEIdKey+multiIfEName          = libFun (fsLit "multiIfE")          multiIfEIdKey+letEName              = libFun (fsLit "letE")              letEIdKey+caseEName             = libFun (fsLit "caseE")             caseEIdKey+doEName               = libFun (fsLit "doE")               doEIdKey+mdoEName              = libFun (fsLit "mdoE")              mdoEIdKey+compEName             = libFun (fsLit "compE")             compEIdKey+-- ArithSeq skips a level+fromEName, fromThenEName, fromToEName, fromThenToEName :: Name+fromEName             = libFun (fsLit "fromE")             fromEIdKey+fromThenEName         = libFun (fsLit "fromThenE")         fromThenEIdKey+fromToEName           = libFun (fsLit "fromToE")           fromToEIdKey+fromThenToEName       = libFun (fsLit "fromThenToE")       fromThenToEIdKey+-- end ArithSeq+listEName, sigEName, recConEName, recUpdEName :: Name+listEName             = libFun (fsLit "listE")             listEIdKey+sigEName              = libFun (fsLit "sigE")              sigEIdKey+recConEName           = libFun (fsLit "recConE")           recConEIdKey+recUpdEName           = libFun (fsLit "recUpdE")           recUpdEIdKey+staticEName           = libFun (fsLit "staticE")           staticEIdKey+unboundVarEName       = libFun (fsLit "unboundVarE")       unboundVarEIdKey+labelEName            = libFun (fsLit "labelE")            labelEIdKey+implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey++-- type FieldExp = ...+fieldExpName :: Name+fieldExpName = libFun (fsLit "fieldExp") fieldExpIdKey++-- data Body = ...+guardedBName, normalBName :: Name+guardedBName = libFun (fsLit "guardedB") guardedBIdKey+normalBName  = libFun (fsLit "normalB")  normalBIdKey++-- data Guard = ...+normalGEName, patGEName :: Name+normalGEName = libFun (fsLit "normalGE") normalGEIdKey+patGEName    = libFun (fsLit "patGE")    patGEIdKey++-- data Stmt = ...+bindSName, letSName, noBindSName, parSName, recSName :: Name+bindSName   = libFun (fsLit "bindS")   bindSIdKey+letSName    = libFun (fsLit "letS")    letSIdKey+noBindSName = libFun (fsLit "noBindS") noBindSIdKey+parSName    = libFun (fsLit "parS")    parSIdKey+recSName    = libFun (fsLit "recS")    recSIdKey++-- data Dec = ...+funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,+    instanceWithOverlapDName, sigDName, forImpDName, pragInlDName,+    pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,+    pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName,+    dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,+    openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,+    infixNDName, roleAnnotDName, patSynDName, patSynSigDName,+    pragCompleteDName, implicitParamBindDName :: Name+funDName                         = libFun (fsLit "funD")                         funDIdKey+valDName                         = libFun (fsLit "valD")                         valDIdKey+dataDName                        = libFun (fsLit "dataD")                        dataDIdKey+newtypeDName                     = libFun (fsLit "newtypeD")                     newtypeDIdKey+tySynDName                       = libFun (fsLit "tySynD")                       tySynDIdKey+classDName                       = libFun (fsLit "classD")                       classDIdKey+instanceWithOverlapDName         = libFun (fsLit "instanceWithOverlapD")         instanceWithOverlapDIdKey+standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey+sigDName                         = libFun (fsLit "sigD")                         sigDIdKey+defaultSigDName                  = libFun (fsLit "defaultSigD")                  defaultSigDIdKey+forImpDName                      = libFun (fsLit "forImpD")                      forImpDIdKey+pragInlDName                     = libFun (fsLit "pragInlD")                     pragInlDIdKey+pragSpecDName                    = libFun (fsLit "pragSpecD")                    pragSpecDIdKey+pragSpecInlDName                 = libFun (fsLit "pragSpecInlD")                 pragSpecInlDIdKey+pragSpecInstDName                = libFun (fsLit "pragSpecInstD")                pragSpecInstDIdKey+pragRuleDName                    = libFun (fsLit "pragRuleD")                    pragRuleDIdKey+pragCompleteDName                = libFun (fsLit "pragCompleteD")                pragCompleteDIdKey+pragAnnDName                     = libFun (fsLit "pragAnnD")                     pragAnnDIdKey+dataInstDName                    = libFun (fsLit "dataInstD")                    dataInstDIdKey+newtypeInstDName                 = libFun (fsLit "newtypeInstD")                 newtypeInstDIdKey+tySynInstDName                   = libFun (fsLit "tySynInstD")                   tySynInstDIdKey+openTypeFamilyDName              = libFun (fsLit "openTypeFamilyD")              openTypeFamilyDIdKey+closedTypeFamilyDName            = libFun (fsLit "closedTypeFamilyD")            closedTypeFamilyDIdKey+dataFamilyDName                  = libFun (fsLit "dataFamilyD")                  dataFamilyDIdKey+infixLDName                      = libFun (fsLit "infixLD")                      infixLDIdKey+infixRDName                      = libFun (fsLit "infixRD")                      infixRDIdKey+infixNDName                      = libFun (fsLit "infixND")                      infixNDIdKey+roleAnnotDName                   = libFun (fsLit "roleAnnotD")                   roleAnnotDIdKey+patSynDName                      = libFun (fsLit "patSynD")                      patSynDIdKey+patSynSigDName                   = libFun (fsLit "patSynSigD")                   patSynSigDIdKey+implicitParamBindDName           = libFun (fsLit "implicitParamBindD")           implicitParamBindDIdKey++-- type Ctxt = ...+cxtName :: Name+cxtName = libFun (fsLit "cxt") cxtIdKey++-- data SourceUnpackedness = ...+noSourceUnpackednessName, sourceNoUnpackName, sourceUnpackName :: Name+noSourceUnpackednessName = libFun (fsLit "noSourceUnpackedness") noSourceUnpackednessKey+sourceNoUnpackName       = libFun (fsLit "sourceNoUnpack")       sourceNoUnpackKey+sourceUnpackName         = libFun (fsLit "sourceUnpack")         sourceUnpackKey++-- data SourceStrictness = ...+noSourceStrictnessName, sourceLazyName, sourceStrictName :: Name+noSourceStrictnessName = libFun (fsLit "noSourceStrictness") noSourceStrictnessKey+sourceLazyName         = libFun (fsLit "sourceLazy")         sourceLazyKey+sourceStrictName       = libFun (fsLit "sourceStrict")       sourceStrictKey++-- data Con = ...+normalCName, recCName, infixCName, forallCName, gadtCName, recGadtCName :: Name+normalCName  = libFun (fsLit "normalC" ) normalCIdKey+recCName     = libFun (fsLit "recC"    ) recCIdKey+infixCName   = libFun (fsLit "infixC"  ) infixCIdKey+forallCName  = libFun (fsLit "forallC" ) forallCIdKey+gadtCName    = libFun (fsLit "gadtC"   ) gadtCIdKey+recGadtCName = libFun (fsLit "recGadtC") recGadtCIdKey++-- data Bang = ...+bangName :: Name+bangName = libFun (fsLit "bang") bangIdKey++-- type BangType = ...+bangTypeName :: Name+bangTypeName = libFun (fsLit "bangType") bangTKey++-- type VarBangType = ...+varBangTypeName :: Name+varBangTypeName = libFun (fsLit "varBangType") varBangTKey++-- data PatSynDir = ...+unidirPatSynName, implBidirPatSynName, explBidirPatSynName :: Name+unidirPatSynName    = libFun (fsLit "unidir")    unidirPatSynIdKey+implBidirPatSynName = libFun (fsLit "implBidir") implBidirPatSynIdKey+explBidirPatSynName = libFun (fsLit "explBidir") explBidirPatSynIdKey++-- data PatSynArgs = ...+prefixPatSynName, infixPatSynName, recordPatSynName :: Name+prefixPatSynName = libFun (fsLit "prefixPatSyn") prefixPatSynIdKey+infixPatSynName  = libFun (fsLit "infixPatSyn")  infixPatSynIdKey+recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey++-- data Type = ...+forallTName, forallVisTName, varTName, conTName, infixTName, tupleTName,+    unboxedTupleTName, unboxedSumTName, arrowTName, listTName, appTName,+    appKindTName, sigTName, equalityTName, litTName, promotedTName,+    promotedTupleTName, promotedNilTName, promotedConsTName,+    wildCardTName, implicitParamTName :: Name+forallTName         = libFun (fsLit "forallT")        forallTIdKey+forallVisTName      = libFun (fsLit "forallVisT")     forallVisTIdKey+varTName            = libFun (fsLit "varT")           varTIdKey+conTName            = libFun (fsLit "conT")           conTIdKey+tupleTName          = libFun (fsLit "tupleT")         tupleTIdKey+unboxedTupleTName   = libFun (fsLit "unboxedTupleT")  unboxedTupleTIdKey+unboxedSumTName     = libFun (fsLit "unboxedSumT")    unboxedSumTIdKey+arrowTName          = libFun (fsLit "arrowT")         arrowTIdKey+listTName           = libFun (fsLit "listT")          listTIdKey+appTName            = libFun (fsLit "appT")           appTIdKey+appKindTName        = libFun (fsLit "appKindT")       appKindTIdKey+sigTName            = libFun (fsLit "sigT")           sigTIdKey+equalityTName       = libFun (fsLit "equalityT")      equalityTIdKey+litTName            = libFun (fsLit "litT")           litTIdKey+promotedTName       = libFun (fsLit "promotedT")      promotedTIdKey+promotedTupleTName  = libFun (fsLit "promotedTupleT") promotedTupleTIdKey+promotedNilTName    = libFun (fsLit "promotedNilT")   promotedNilTIdKey+promotedConsTName   = libFun (fsLit "promotedConsT")  promotedConsTIdKey+wildCardTName       = libFun (fsLit "wildCardT")      wildCardTIdKey+infixTName          = libFun (fsLit "infixT")         infixTIdKey+implicitParamTName  = libFun (fsLit "implicitParamT") implicitParamTIdKey++-- data TyLit = ...+numTyLitName, strTyLitName :: Name+numTyLitName = libFun (fsLit "numTyLit") numTyLitIdKey+strTyLitName = libFun (fsLit "strTyLit") strTyLitIdKey++-- data TyVarBndr = ...+plainTVName, kindedTVName :: Name+plainTVName  = libFun (fsLit "plainTV")  plainTVIdKey+kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey++-- data Role = ...+nominalRName, representationalRName, phantomRName, inferRName :: Name+nominalRName          = libFun (fsLit "nominalR")          nominalRIdKey+representationalRName = libFun (fsLit "representationalR") representationalRIdKey+phantomRName          = libFun (fsLit "phantomR")          phantomRIdKey+inferRName            = libFun (fsLit "inferR")            inferRIdKey++-- data Kind = ...+varKName, conKName, tupleKName, arrowKName, listKName, appKName,+  starKName, constraintKName :: Name+varKName        = libFun (fsLit "varK")         varKIdKey+conKName        = libFun (fsLit "conK")         conKIdKey+tupleKName      = libFun (fsLit "tupleK")       tupleKIdKey+arrowKName      = libFun (fsLit "arrowK")       arrowKIdKey+listKName       = libFun (fsLit "listK")        listKIdKey+appKName        = libFun (fsLit "appK")         appKIdKey+starKName       = libFun (fsLit "starK")        starKIdKey+constraintKName = libFun (fsLit "constraintK")  constraintKIdKey++-- data FamilyResultSig = ...+noSigName, kindSigName, tyVarSigName :: Name+noSigName    = libFun (fsLit "noSig")    noSigIdKey+kindSigName  = libFun (fsLit "kindSig")  kindSigIdKey+tyVarSigName = libFun (fsLit "tyVarSig") tyVarSigIdKey++-- data InjectivityAnn = ...+injectivityAnnName :: Name+injectivityAnnName = libFun (fsLit "injectivityAnn") injectivityAnnIdKey++-- data Callconv = ...+cCallName, stdCallName, cApiCallName, primCallName, javaScriptCallName :: Name+cCallName = libFun (fsLit "cCall") cCallIdKey+stdCallName = libFun (fsLit "stdCall") stdCallIdKey+cApiCallName = libFun (fsLit "cApi") cApiCallIdKey+primCallName = libFun (fsLit "prim") primCallIdKey+javaScriptCallName = libFun (fsLit "javaScript") javaScriptCallIdKey++-- data Safety = ...+unsafeName, safeName, interruptibleName :: Name+unsafeName     = libFun (fsLit "unsafe") unsafeIdKey+safeName       = libFun (fsLit "safe") safeIdKey+interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey++-- newtype TExp a = ...+tExpDataConName :: Name+tExpDataConName = thCon (fsLit "TExp") tExpDataConKey++-- data RuleBndr = ...+ruleVarName, typedRuleVarName :: Name+ruleVarName      = libFun (fsLit ("ruleVar"))      ruleVarIdKey+typedRuleVarName = libFun (fsLit ("typedRuleVar")) typedRuleVarIdKey++-- data FunDep = ...+funDepName :: Name+funDepName     = libFun (fsLit "funDep") funDepIdKey++-- data TySynEqn = ...+tySynEqnName :: Name+tySynEqnName = libFun (fsLit "tySynEqn") tySynEqnIdKey++-- data AnnTarget = ...+valueAnnotationName, typeAnnotationName, moduleAnnotationName :: Name+valueAnnotationName  = libFun (fsLit "valueAnnotation")  valueAnnotationIdKey+typeAnnotationName   = libFun (fsLit "typeAnnotation")   typeAnnotationIdKey+moduleAnnotationName = libFun (fsLit "moduleAnnotation") moduleAnnotationIdKey++-- type DerivClause = ...+derivClauseName :: Name+derivClauseName = libFun (fsLit "derivClause") derivClauseIdKey++-- data DerivStrategy = ...+stockStrategyName, anyclassStrategyName, newtypeStrategyName,+  viaStrategyName :: Name+stockStrategyName    = libFun (fsLit "stockStrategy")    stockStrategyIdKey+anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey+newtypeStrategyName  = libFun (fsLit "newtypeStrategy")  newtypeStrategyIdKey+viaStrategyName      = libFun (fsLit "viaStrategy")      viaStrategyIdKey++matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,+    decQTyConName, conQTyConName, bangTypeQTyConName,+    varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName,+    patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,+    ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName,+    derivClauseQTyConName, kindQTyConName, tyVarBndrQTyConName,+    derivStrategyQTyConName :: Name+matchQTyConName         = libTc (fsLit "MatchQ")         matchQTyConKey+clauseQTyConName        = libTc (fsLit "ClauseQ")        clauseQTyConKey+expQTyConName           = libTc (fsLit "ExpQ")           expQTyConKey+stmtQTyConName          = libTc (fsLit "StmtQ")          stmtQTyConKey+decQTyConName           = libTc (fsLit "DecQ")           decQTyConKey+decsQTyConName          = libTc (fsLit "DecsQ")          decsQTyConKey  -- Q [Dec]+conQTyConName           = libTc (fsLit "ConQ")           conQTyConKey+bangTypeQTyConName      = libTc (fsLit "BangTypeQ")      bangTypeQTyConKey+varBangTypeQTyConName   = libTc (fsLit "VarBangTypeQ")   varBangTypeQTyConKey+typeQTyConName          = libTc (fsLit "TypeQ")          typeQTyConKey+fieldExpQTyConName      = libTc (fsLit "FieldExpQ")      fieldExpQTyConKey+patQTyConName           = libTc (fsLit "PatQ")           patQTyConKey+fieldPatQTyConName      = libTc (fsLit "FieldPatQ")      fieldPatQTyConKey+predQTyConName          = libTc (fsLit "PredQ")          predQTyConKey+ruleBndrQTyConName      = libTc (fsLit "RuleBndrQ")      ruleBndrQTyConKey+tySynEqnQTyConName      = libTc (fsLit "TySynEqnQ")      tySynEqnQTyConKey+roleTyConName           = libTc (fsLit "Role")           roleTyConKey+derivClauseQTyConName   = libTc (fsLit "DerivClauseQ")   derivClauseQTyConKey+kindQTyConName          = libTc (fsLit "KindQ")          kindQTyConKey+tyVarBndrQTyConName     = libTc (fsLit "TyVarBndrQ")     tyVarBndrQTyConKey+derivStrategyQTyConName = libTc (fsLit "DerivStrategyQ") derivStrategyQTyConKey++-- quasiquoting+quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name+quoteExpName        = qqFun (fsLit "quoteExp")  quoteExpKey+quotePatName        = qqFun (fsLit "quotePat")  quotePatKey+quoteDecName        = qqFun (fsLit "quoteDec")  quoteDecKey+quoteTypeName       = qqFun (fsLit "quoteType") quoteTypeKey++-- data Inline = ...+noInlineDataConName, inlineDataConName, inlinableDataConName :: Name+noInlineDataConName  = thCon (fsLit "NoInline")  noInlineDataConKey+inlineDataConName    = thCon (fsLit "Inline")    inlineDataConKey+inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey++-- data RuleMatch = ...+conLikeDataConName, funLikeDataConName :: Name+conLikeDataConName = thCon (fsLit "ConLike") conLikeDataConKey+funLikeDataConName = thCon (fsLit "FunLike") funLikeDataConKey++-- data Phases = ...+allPhasesDataConName, fromPhaseDataConName, beforePhaseDataConName :: Name+allPhasesDataConName   = thCon (fsLit "AllPhases")   allPhasesDataConKey+fromPhaseDataConName   = thCon (fsLit "FromPhase")   fromPhaseDataConKey+beforePhaseDataConName = thCon (fsLit "BeforePhase") beforePhaseDataConKey++-- data Overlap = ...+overlappableDataConName,+  overlappingDataConName,+  overlapsDataConName,+  incoherentDataConName :: Name+overlappableDataConName = thCon (fsLit "Overlappable") overlappableDataConKey+overlappingDataConName  = thCon (fsLit "Overlapping")  overlappingDataConKey+overlapsDataConName     = thCon (fsLit "Overlaps")     overlapsDataConKey+incoherentDataConName   = thCon (fsLit "Incoherent")   incoherentDataConKey++{- *********************************************************************+*                                                                      *+                     Class keys+*                                                                      *+********************************************************************* -}++-- ClassUniques available: 200-299+-- Check in PrelNames if you want to change this++liftClassKey :: Unique+liftClassKey = mkPreludeClassUnique 200++{- *********************************************************************+*                                                                      *+                     TyCon keys+*                                                                      *+********************************************************************* -}++-- TyConUniques available: 200-299+-- Check in PrelNames if you want to change this++expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,+    decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,+    stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey,+    tyVarBndrQTyConKey, decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey,+    fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,+    fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,+    predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,+    roleTyConKey, tExpTyConKey, injAnnTyConKey, kindQTyConKey,+    overlapTyConKey, derivClauseQTyConKey, derivStrategyQTyConKey :: Unique+expTyConKey             = mkPreludeTyConUnique 200+matchTyConKey           = mkPreludeTyConUnique 201+clauseTyConKey          = mkPreludeTyConUnique 202+qTyConKey               = mkPreludeTyConUnique 203+expQTyConKey            = mkPreludeTyConUnique 204+decQTyConKey            = mkPreludeTyConUnique 205+patTyConKey             = mkPreludeTyConUnique 206+matchQTyConKey          = mkPreludeTyConUnique 207+clauseQTyConKey         = mkPreludeTyConUnique 208+stmtQTyConKey           = mkPreludeTyConUnique 209+conQTyConKey            = mkPreludeTyConUnique 210+typeQTyConKey           = mkPreludeTyConUnique 211+typeTyConKey            = mkPreludeTyConUnique 212+decTyConKey             = mkPreludeTyConUnique 213+bangTypeQTyConKey       = mkPreludeTyConUnique 214+varBangTypeQTyConKey    = mkPreludeTyConUnique 215+fieldExpTyConKey        = mkPreludeTyConUnique 216+fieldPatTyConKey        = mkPreludeTyConUnique 217+nameTyConKey            = mkPreludeTyConUnique 218+patQTyConKey            = mkPreludeTyConUnique 219+fieldPatQTyConKey       = mkPreludeTyConUnique 220+fieldExpQTyConKey       = mkPreludeTyConUnique 221+funDepTyConKey          = mkPreludeTyConUnique 222+predTyConKey            = mkPreludeTyConUnique 223+predQTyConKey           = mkPreludeTyConUnique 224+tyVarBndrQTyConKey      = mkPreludeTyConUnique 225+decsQTyConKey           = mkPreludeTyConUnique 226+ruleBndrQTyConKey       = mkPreludeTyConUnique 227+tySynEqnQTyConKey       = mkPreludeTyConUnique 228+roleTyConKey            = mkPreludeTyConUnique 229+tExpTyConKey            = mkPreludeTyConUnique 230+injAnnTyConKey          = mkPreludeTyConUnique 231+kindQTyConKey           = mkPreludeTyConUnique 232+overlapTyConKey         = mkPreludeTyConUnique 233+derivClauseQTyConKey    = mkPreludeTyConUnique 234+derivStrategyQTyConKey  = mkPreludeTyConUnique 235++{- *********************************************************************+*                                                                      *+                     DataCon keys+*                                                                      *+********************************************************************* -}++-- DataConUniques available: 100-150+-- If you want to change this, make sure you check in PrelNames++-- data Inline = ...+noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique+noInlineDataConKey  = mkPreludeDataConUnique 200+inlineDataConKey    = mkPreludeDataConUnique 201+inlinableDataConKey = mkPreludeDataConUnique 202++-- data RuleMatch = ...+conLikeDataConKey, funLikeDataConKey :: Unique+conLikeDataConKey = mkPreludeDataConUnique 203+funLikeDataConKey = mkPreludeDataConUnique 204++-- data Phases = ...+allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique+allPhasesDataConKey   = mkPreludeDataConUnique 205+fromPhaseDataConKey   = mkPreludeDataConUnique 206+beforePhaseDataConKey = mkPreludeDataConUnique 207++-- newtype TExp a = ...+tExpDataConKey :: Unique+tExpDataConKey = mkPreludeDataConUnique 208++-- data Overlap = ..+overlappableDataConKey,+  overlappingDataConKey,+  overlapsDataConKey,+  incoherentDataConKey :: Unique+overlappableDataConKey = mkPreludeDataConUnique 209+overlappingDataConKey  = mkPreludeDataConUnique 210+overlapsDataConKey     = mkPreludeDataConUnique 211+incoherentDataConKey   = mkPreludeDataConUnique 212++{- *********************************************************************+*                                                                      *+                     Id keys+*                                                                      *+********************************************************************* -}++-- IdUniques available: 200-499+-- If you want to change this, make sure you check in PrelNames++returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,+    mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,+    mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey,+    unsafeTExpCoerceIdKey, liftTypedIdKey :: Unique+returnQIdKey        = mkPreludeMiscIdUnique 200+bindQIdKey          = mkPreludeMiscIdUnique 201+sequenceQIdKey      = mkPreludeMiscIdUnique 202+liftIdKey           = mkPreludeMiscIdUnique 203+newNameIdKey         = mkPreludeMiscIdUnique 204+mkNameIdKey          = mkPreludeMiscIdUnique 205+mkNameG_vIdKey       = mkPreludeMiscIdUnique 206+mkNameG_dIdKey       = mkPreludeMiscIdUnique 207+mkNameG_tcIdKey      = mkPreludeMiscIdUnique 208+mkNameLIdKey         = mkPreludeMiscIdUnique 209+mkNameSIdKey         = mkPreludeMiscIdUnique 210+unTypeIdKey          = mkPreludeMiscIdUnique 211+unTypeQIdKey         = mkPreludeMiscIdUnique 212+unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213+liftTypedIdKey        = mkPreludeMiscIdUnique 214+++-- data Lit = ...+charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey,+    floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey, stringPrimLIdKey,+    charPrimLIdKey:: Unique+charLIdKey        = mkPreludeMiscIdUnique 220+stringLIdKey      = mkPreludeMiscIdUnique 221+integerLIdKey     = mkPreludeMiscIdUnique 222+intPrimLIdKey     = mkPreludeMiscIdUnique 223+wordPrimLIdKey    = mkPreludeMiscIdUnique 224+floatPrimLIdKey   = mkPreludeMiscIdUnique 225+doublePrimLIdKey  = mkPreludeMiscIdUnique 226+rationalLIdKey    = mkPreludeMiscIdUnique 227+stringPrimLIdKey  = mkPreludeMiscIdUnique 228+charPrimLIdKey    = mkPreludeMiscIdUnique 229++liftStringIdKey :: Unique+liftStringIdKey     = mkPreludeMiscIdUnique 230++-- data Pat = ...+litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey,+  infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey,+  listPIdKey, sigPIdKey, viewPIdKey :: Unique+litPIdKey         = mkPreludeMiscIdUnique 240+varPIdKey         = mkPreludeMiscIdUnique 241+tupPIdKey         = mkPreludeMiscIdUnique 242+unboxedTupPIdKey  = mkPreludeMiscIdUnique 243+unboxedSumPIdKey  = mkPreludeMiscIdUnique 244+conPIdKey         = mkPreludeMiscIdUnique 245+infixPIdKey       = mkPreludeMiscIdUnique 246+tildePIdKey       = mkPreludeMiscIdUnique 247+bangPIdKey        = mkPreludeMiscIdUnique 248+asPIdKey          = mkPreludeMiscIdUnique 249+wildPIdKey        = mkPreludeMiscIdUnique 250+recPIdKey         = mkPreludeMiscIdUnique 251+listPIdKey        = mkPreludeMiscIdUnique 252+sigPIdKey         = mkPreludeMiscIdUnique 253+viewPIdKey        = mkPreludeMiscIdUnique 254++-- type FieldPat = ...+fieldPatIdKey :: Unique+fieldPatIdKey       = mkPreludeMiscIdUnique 260++-- data Match = ...+matchIdKey :: Unique+matchIdKey          = mkPreludeMiscIdUnique 261++-- data Clause = ...+clauseIdKey :: Unique+clauseIdKey         = mkPreludeMiscIdUnique 262+++-- data Exp = ...+varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,+    infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey,+    tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey,+    letEIdKey, caseEIdKey, doEIdKey, compEIdKey,+    fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,+    listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,+    unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey :: Unique+varEIdKey              = mkPreludeMiscIdUnique 270+conEIdKey              = mkPreludeMiscIdUnique 271+litEIdKey              = mkPreludeMiscIdUnique 272+appEIdKey              = mkPreludeMiscIdUnique 273+appTypeEIdKey          = mkPreludeMiscIdUnique 274+infixEIdKey            = mkPreludeMiscIdUnique 275+infixAppIdKey          = mkPreludeMiscIdUnique 276+sectionLIdKey          = mkPreludeMiscIdUnique 277+sectionRIdKey          = mkPreludeMiscIdUnique 278+lamEIdKey              = mkPreludeMiscIdUnique 279+lamCaseEIdKey          = mkPreludeMiscIdUnique 280+tupEIdKey              = mkPreludeMiscIdUnique 281+unboxedTupEIdKey       = mkPreludeMiscIdUnique 282+unboxedSumEIdKey       = mkPreludeMiscIdUnique 283+condEIdKey             = mkPreludeMiscIdUnique 284+multiIfEIdKey          = mkPreludeMiscIdUnique 285+letEIdKey              = mkPreludeMiscIdUnique 286+caseEIdKey             = mkPreludeMiscIdUnique 287+doEIdKey               = mkPreludeMiscIdUnique 288+compEIdKey             = mkPreludeMiscIdUnique 289+fromEIdKey             = mkPreludeMiscIdUnique 290+fromThenEIdKey         = mkPreludeMiscIdUnique 291+fromToEIdKey           = mkPreludeMiscIdUnique 292+fromThenToEIdKey       = mkPreludeMiscIdUnique 293+listEIdKey             = mkPreludeMiscIdUnique 294+sigEIdKey              = mkPreludeMiscIdUnique 295+recConEIdKey           = mkPreludeMiscIdUnique 296+recUpdEIdKey           = mkPreludeMiscIdUnique 297+staticEIdKey           = mkPreludeMiscIdUnique 298+unboundVarEIdKey       = mkPreludeMiscIdUnique 299+labelEIdKey            = mkPreludeMiscIdUnique 300+implicitParamVarEIdKey = mkPreludeMiscIdUnique 301+mdoEIdKey              = mkPreludeMiscIdUnique 302++-- type FieldExp = ...+fieldExpIdKey :: Unique+fieldExpIdKey       = mkPreludeMiscIdUnique 305++-- data Body = ...+guardedBIdKey, normalBIdKey :: Unique+guardedBIdKey     = mkPreludeMiscIdUnique 306+normalBIdKey      = mkPreludeMiscIdUnique 307++-- data Guard = ...+normalGEIdKey, patGEIdKey :: Unique+normalGEIdKey     = mkPreludeMiscIdUnique 308+patGEIdKey        = mkPreludeMiscIdUnique 309++-- data Stmt = ...+bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique+bindSIdKey       = mkPreludeMiscIdUnique 310+letSIdKey        = mkPreludeMiscIdUnique 311+noBindSIdKey     = mkPreludeMiscIdUnique 312+parSIdKey        = mkPreludeMiscIdUnique 313+recSIdKey        = mkPreludeMiscIdUnique 314++-- data Dec = ...+funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,+    instanceWithOverlapDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey,+    pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, pragSpecInstDIdKey,+    pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey,+    openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,+    newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,+    infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,+    patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey :: Unique+funDIdKey                         = mkPreludeMiscIdUnique 320+valDIdKey                         = mkPreludeMiscIdUnique 321+dataDIdKey                        = mkPreludeMiscIdUnique 322+newtypeDIdKey                     = mkPreludeMiscIdUnique 323+tySynDIdKey                       = mkPreludeMiscIdUnique 324+classDIdKey                       = mkPreludeMiscIdUnique 325+instanceWithOverlapDIdKey         = mkPreludeMiscIdUnique 326+instanceDIdKey                    = mkPreludeMiscIdUnique 327+sigDIdKey                         = mkPreludeMiscIdUnique 328+forImpDIdKey                      = mkPreludeMiscIdUnique 329+pragInlDIdKey                     = mkPreludeMiscIdUnique 330+pragSpecDIdKey                    = mkPreludeMiscIdUnique 331+pragSpecInlDIdKey                 = mkPreludeMiscIdUnique 332+pragSpecInstDIdKey                = mkPreludeMiscIdUnique 333+pragRuleDIdKey                    = mkPreludeMiscIdUnique 334+pragAnnDIdKey                     = mkPreludeMiscIdUnique 335+dataFamilyDIdKey                  = mkPreludeMiscIdUnique 336+openTypeFamilyDIdKey              = mkPreludeMiscIdUnique 337+dataInstDIdKey                    = mkPreludeMiscIdUnique 338+newtypeInstDIdKey                 = mkPreludeMiscIdUnique 339+tySynInstDIdKey                   = mkPreludeMiscIdUnique 340+closedTypeFamilyDIdKey            = mkPreludeMiscIdUnique 341+infixLDIdKey                      = mkPreludeMiscIdUnique 342+infixRDIdKey                      = mkPreludeMiscIdUnique 343+infixNDIdKey                      = mkPreludeMiscIdUnique 344+roleAnnotDIdKey                   = mkPreludeMiscIdUnique 345+standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346+defaultSigDIdKey                  = mkPreludeMiscIdUnique 347+patSynDIdKey                      = mkPreludeMiscIdUnique 348+patSynSigDIdKey                   = mkPreludeMiscIdUnique 349+pragCompleteDIdKey                = mkPreludeMiscIdUnique 350+implicitParamBindDIdKey           = mkPreludeMiscIdUnique 351++-- type Cxt = ...+cxtIdKey :: Unique+cxtIdKey               = mkPreludeMiscIdUnique 361++-- data SourceUnpackedness = ...+noSourceUnpackednessKey, sourceNoUnpackKey, sourceUnpackKey :: Unique+noSourceUnpackednessKey = mkPreludeMiscIdUnique 362+sourceNoUnpackKey       = mkPreludeMiscIdUnique 363+sourceUnpackKey         = mkPreludeMiscIdUnique 364++-- data SourceStrictness = ...+noSourceStrictnessKey, sourceLazyKey, sourceStrictKey :: Unique+noSourceStrictnessKey   = mkPreludeMiscIdUnique 365+sourceLazyKey           = mkPreludeMiscIdUnique 366+sourceStrictKey         = mkPreludeMiscIdUnique 367++-- data Con = ...+normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey, gadtCIdKey,+  recGadtCIdKey :: Unique+normalCIdKey      = mkPreludeMiscIdUnique 368+recCIdKey         = mkPreludeMiscIdUnique 369+infixCIdKey       = mkPreludeMiscIdUnique 370+forallCIdKey      = mkPreludeMiscIdUnique 371+gadtCIdKey        = mkPreludeMiscIdUnique 372+recGadtCIdKey     = mkPreludeMiscIdUnique 373++-- data Bang = ...+bangIdKey :: Unique+bangIdKey         = mkPreludeMiscIdUnique 374++-- type BangType = ...+bangTKey :: Unique+bangTKey          = mkPreludeMiscIdUnique 375++-- type VarBangType = ...+varBangTKey :: Unique+varBangTKey       = mkPreludeMiscIdUnique 376++-- data PatSynDir = ...+unidirPatSynIdKey, implBidirPatSynIdKey, explBidirPatSynIdKey :: Unique+unidirPatSynIdKey    = mkPreludeMiscIdUnique 377+implBidirPatSynIdKey = mkPreludeMiscIdUnique 378+explBidirPatSynIdKey = mkPreludeMiscIdUnique 379++-- data PatSynArgs = ...+prefixPatSynIdKey, infixPatSynIdKey, recordPatSynIdKey :: Unique+prefixPatSynIdKey = mkPreludeMiscIdUnique 380+infixPatSynIdKey  = mkPreludeMiscIdUnique 381+recordPatSynIdKey = mkPreludeMiscIdUnique 382++-- data Type = ...+forallTIdKey, forallVisTIdKey, varTIdKey, conTIdKey, tupleTIdKey,+    unboxedTupleTIdKey, unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey,+    appKindTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey,+    promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey,+    wildCardTIdKey, implicitParamTIdKey, infixTIdKey :: Unique+forallTIdKey        = mkPreludeMiscIdUnique 390+forallVisTIdKey     = mkPreludeMiscIdUnique 391+varTIdKey           = mkPreludeMiscIdUnique 392+conTIdKey           = mkPreludeMiscIdUnique 393+tupleTIdKey         = mkPreludeMiscIdUnique 394+unboxedTupleTIdKey  = mkPreludeMiscIdUnique 395+unboxedSumTIdKey    = mkPreludeMiscIdUnique 396+arrowTIdKey         = mkPreludeMiscIdUnique 397+listTIdKey          = mkPreludeMiscIdUnique 398+appTIdKey           = mkPreludeMiscIdUnique 399+appKindTIdKey       = mkPreludeMiscIdUnique 400+sigTIdKey           = mkPreludeMiscIdUnique 401+equalityTIdKey      = mkPreludeMiscIdUnique 402+litTIdKey           = mkPreludeMiscIdUnique 403+promotedTIdKey      = mkPreludeMiscIdUnique 404+promotedTupleTIdKey = mkPreludeMiscIdUnique 405+promotedNilTIdKey   = mkPreludeMiscIdUnique 406+promotedConsTIdKey  = mkPreludeMiscIdUnique 407+wildCardTIdKey      = mkPreludeMiscIdUnique 408+implicitParamTIdKey = mkPreludeMiscIdUnique 409+infixTIdKey         = mkPreludeMiscIdUnique 410++-- data TyLit = ...+numTyLitIdKey, strTyLitIdKey :: Unique+numTyLitIdKey = mkPreludeMiscIdUnique 411+strTyLitIdKey = mkPreludeMiscIdUnique 412++-- data TyVarBndr = ...+plainTVIdKey, kindedTVIdKey :: Unique+plainTVIdKey       = mkPreludeMiscIdUnique 413+kindedTVIdKey      = mkPreludeMiscIdUnique 414++-- data Role = ...+nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique+nominalRIdKey          = mkPreludeMiscIdUnique 415+representationalRIdKey = mkPreludeMiscIdUnique 416+phantomRIdKey          = mkPreludeMiscIdUnique 417+inferRIdKey            = mkPreludeMiscIdUnique 418++-- data Kind = ...+varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey,+  starKIdKey, constraintKIdKey :: Unique+varKIdKey         = mkPreludeMiscIdUnique 419+conKIdKey         = mkPreludeMiscIdUnique 420+tupleKIdKey       = mkPreludeMiscIdUnique 421+arrowKIdKey       = mkPreludeMiscIdUnique 422+listKIdKey        = mkPreludeMiscIdUnique 423+appKIdKey         = mkPreludeMiscIdUnique 424+starKIdKey        = mkPreludeMiscIdUnique 425+constraintKIdKey  = mkPreludeMiscIdUnique 426++-- data FamilyResultSig = ...+noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique+noSigIdKey        = mkPreludeMiscIdUnique 427+kindSigIdKey      = mkPreludeMiscIdUnique 428+tyVarSigIdKey     = mkPreludeMiscIdUnique 429++-- data InjectivityAnn = ...+injectivityAnnIdKey :: Unique+injectivityAnnIdKey = mkPreludeMiscIdUnique 430++-- data Callconv = ...+cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey,+  javaScriptCallIdKey :: Unique+cCallIdKey          = mkPreludeMiscIdUnique 431+stdCallIdKey        = mkPreludeMiscIdUnique 432+cApiCallIdKey       = mkPreludeMiscIdUnique 433+primCallIdKey       = mkPreludeMiscIdUnique 434+javaScriptCallIdKey = mkPreludeMiscIdUnique 435++-- data Safety = ...+unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique+unsafeIdKey        = mkPreludeMiscIdUnique 440+safeIdKey          = mkPreludeMiscIdUnique 441+interruptibleIdKey = mkPreludeMiscIdUnique 442++-- data FunDep = ...+funDepIdKey :: Unique+funDepIdKey = mkPreludeMiscIdUnique 445++-- data TySynEqn = ...+tySynEqnIdKey :: Unique+tySynEqnIdKey = mkPreludeMiscIdUnique 460++-- quasiquoting+quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique+quoteExpKey  = mkPreludeMiscIdUnique 470+quotePatKey  = mkPreludeMiscIdUnique 471+quoteDecKey  = mkPreludeMiscIdUnique 472+quoteTypeKey = mkPreludeMiscIdUnique 473++-- data RuleBndr = ...+ruleVarIdKey, typedRuleVarIdKey :: Unique+ruleVarIdKey      = mkPreludeMiscIdUnique 480+typedRuleVarIdKey = mkPreludeMiscIdUnique 481++-- data AnnTarget = ...+valueAnnotationIdKey, typeAnnotationIdKey, moduleAnnotationIdKey :: Unique+valueAnnotationIdKey  = mkPreludeMiscIdUnique 490+typeAnnotationIdKey   = mkPreludeMiscIdUnique 491+moduleAnnotationIdKey = mkPreludeMiscIdUnique 492++-- type DerivPred = ...+derivClauseIdKey :: Unique+derivClauseIdKey = mkPreludeMiscIdUnique 493++-- data DerivStrategy = ...+stockStrategyIdKey, anyclassStrategyIdKey, newtypeStrategyIdKey,+  viaStrategyIdKey :: Unique+stockStrategyIdKey    = mkPreludeDataConUnique 494+anyclassStrategyIdKey = mkPreludeDataConUnique 495+newtypeStrategyIdKey  = mkPreludeDataConUnique 496+viaStrategyIdKey      = mkPreludeDataConUnique 497++{-+************************************************************************+*                                                                      *+                        RdrNames+*                                                                      *+************************************************************************+-}++lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName+lift_RDR     = nameRdrName liftName+liftTyped_RDR = nameRdrName liftTypedName+mkNameG_dRDR = nameRdrName mkNameG_dName+mkNameG_vRDR = nameRdrName mkNameG_vName++-- data Exp = ...+conE_RDR, litE_RDR, appE_RDR, infixApp_RDR :: RdrName+conE_RDR     = nameRdrName conEName+litE_RDR     = nameRdrName litEName+appE_RDR     = nameRdrName appEName+infixApp_RDR = nameRdrName infixAppName++-- data Lit = ...+stringL_RDR, intPrimL_RDR, wordPrimL_RDR, floatPrimL_RDR,+    doublePrimL_RDR, stringPrimL_RDR, charPrimL_RDR :: RdrName+stringL_RDR     = nameRdrName stringLName+intPrimL_RDR    = nameRdrName intPrimLName+wordPrimL_RDR   = nameRdrName wordPrimLName+floatPrimL_RDR  = nameRdrName floatPrimLName+doublePrimL_RDR = nameRdrName doublePrimLName+stringPrimL_RDR = nameRdrName stringPrimLName+charPrimL_RDR   = nameRdrName charPrimLName
+ compiler/profiling/ProfInit.hs view
@@ -0,0 +1,64 @@+-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2011+--+-- Generate code to initialise cost centres+--+-- -----------------------------------------------------------------------------++module ProfInit (profilingInitCode) where++import GhcPrelude++import CLabel+import CostCentre+import DynFlags+import Outputable+import Module++-- -----------------------------------------------------------------------------+-- Initialising cost centres++-- We must produce declarations for the cost-centres defined in this+-- module;++profilingInitCode :: Module -> CollectedCCs -> SDoc+profilingInitCode this_mod (local_CCs, singleton_CCSs)+ = sdocWithDynFlags $ \dflags ->+   if not (gopt Opt_SccProfilingOn dflags)+   then empty+   else vcat+    $  map emit_cc_decl local_CCs+    ++ map emit_ccs_decl singleton_CCSs+    ++ [emit_cc_list local_CCs]+    ++ [emit_ccs_list singleton_CCSs]+    ++ [ text "static void prof_init_" <> ppr this_mod+            <> text "(void) __attribute__((constructor));"+       , text "static void prof_init_" <> ppr this_mod <> text "(void)"+       , braces (vcat+                 [ text "registerCcList" <> parens local_cc_list_label <> semi+                 , text "registerCcsList" <> parens singleton_cc_list_label <> semi+                 ])+       ]+ where+   emit_cc_decl cc =+       text "extern CostCentre" <+> cc_lbl <> text "[];"+     where cc_lbl = ppr (mkCCLabel cc)+   local_cc_list_label = text "local_cc_" <> ppr this_mod+   emit_cc_list ccs =+      text "static CostCentre *" <> local_cc_list_label <> text "[] ="+      <+> braces (vcat $ [ ppr (mkCCLabel cc) <> comma+                         | cc <- ccs+                         ] ++ [text "NULL"])+      <> semi++   emit_ccs_decl ccs =+       text "extern CostCentreStack" <+> ccs_lbl <> text "[];"+     where ccs_lbl = ppr (mkCCSLabel ccs)+   singleton_cc_list_label = text "singleton_cc_" <> ppr this_mod+   emit_ccs_list ccs =+      text "static CostCentreStack *" <> singleton_cc_list_label <> text "[] ="+      <+> braces (vcat $ [ ppr (mkCCSLabel cc) <> comma+                         | cc <- ccs+                         ] ++ [text "NULL"])+      <> semi
+ compiler/rename/RnBinds.hs view
@@ -0,0 +1,1333 @@+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}++{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[RnBinds]{Renaming and dependency analysis of bindings}++This module does renaming and dependency analysis on value bindings in+the abstract syntax.  It does {\em not} do cycle-checks on class or+type-synonym declarations; those cannot be done at this stage because+they may be affected by renaming (which isn't fully worked out yet).+-}++module RnBinds (+   -- Renaming top-level bindings+   rnTopBindsLHS, rnTopBindsBoot, rnValBindsRHS,++   -- Renaming local bindings+   rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,++   -- Other bindings+   rnMethodBinds, renameSigs,+   rnMatchGroup, rnGRHSs, rnGRHS, rnSrcFixityDecl,+   makeMiniFixityEnv, MiniFixityEnv,+   HsSigCtxt(..)+   ) where++import GhcPrelude++import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )++import HsSyn+import TcRnMonad+import RnTypes+import RnPat+import RnNames+import RnEnv+import RnFixity+import RnUtils          ( HsDocContext(..), mapFvRn, extendTyVarEnvFVRn+                        , checkDupRdrNames, warnUnusedLocalBinds,+                        checkUnusedRecordWildcard+                        , checkDupAndShadowedNames, bindLocalNamesFV )+import DynFlags+import Module+import Name+import NameEnv+import NameSet+import RdrName          ( RdrName, rdrNameOcc )+import SrcLoc+import ListSetOps       ( findDupsEq )+import BasicTypes       ( RecFlag(..) )+import Digraph          ( SCC(..) )+import Bag+import Util+import Outputable+import UniqSet+import Maybes           ( orElse )+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.Foldable      ( toList )+import Data.List          ( partition, sort )+import Data.List.NonEmpty ( NonEmpty(..) )++{-+-- ToDo: Put the annotations into the monad, so that they arrive in the proper+-- place and can be used when complaining.++The code tree received by the function @rnBinds@ contains definitions+in where-clauses which are all apparently mutually recursive, but which may+not really depend upon each other. For example, in the top level program+\begin{verbatim}+f x = y where a = x+              y = x+\end{verbatim}+the definitions of @a@ and @y@ do not depend on each other at all.+Unfortunately, the typechecker cannot always check such definitions.+\footnote{Mycroft, A. 1984. Polymorphic type schemes and recursive+definitions. In Proceedings of the International Symposium on Programming,+Toulouse, pp. 217-39. LNCS 167. Springer Verlag.}+However, the typechecker usually can check definitions in which only the+strongly connected components have been collected into recursive bindings.+This is precisely what the function @rnBinds@ does.++ToDo: deal with case where a single monobinds binds the same variable+twice.++The vertag tag is a unique @Int@; the tags only need to be unique+within one @MonoBinds@, so that unique-Int plumbing is done explicitly+(heavy monad machinery not needed).+++************************************************************************+*                                                                      *+* naming conventions                                                   *+*                                                                      *+************************************************************************++\subsection[name-conventions]{Name conventions}++The basic algorithm involves walking over the tree and returning a tuple+containing the new tree plus its free variables. Some functions, such+as those walking polymorphic bindings (HsBinds) and qualifier lists in+list comprehensions (@Quals@), return the variables bound in local+environments. These are then used to calculate the free variables of the+expression evaluated in these environments.++Conventions for variable names are as follows:+\begin{itemize}+\item+new code is given a prime to distinguish it from the old.++\item+a set of variables defined in @Exp@ is written @dvExp@++\item+a set of variables free in @Exp@ is written @fvExp@+\end{itemize}++************************************************************************+*                                                                      *+* analysing polymorphic bindings (HsBindGroup, HsBind)+*                                                                      *+************************************************************************++\subsubsection[dep-HsBinds]{Polymorphic bindings}++Non-recursive expressions are reconstructed without any changes at top+level, although their component expressions may have to be altered.+However, non-recursive expressions are currently not expected as+\Haskell{} programs, and this code should not be executed.++Monomorphic bindings contain information that is returned in a tuple+(a @FlatMonoBinds@) containing:++\begin{enumerate}+\item+a unique @Int@ that serves as the ``vertex tag'' for this binding.++\item+the name of a function or the names in a pattern. These are a set+referred to as @dvLhs@, the defined variables of the left hand side.++\item+the free variables of the body. These are referred to as @fvBody@.++\item+the definition's actual code. This is referred to as just @code@.+\end{enumerate}++The function @nonRecDvFv@ returns two sets of variables. The first is+the set of variables defined in the set of monomorphic bindings, while the+second is the set of free variables in those bindings.++The set of variables defined in a non-recursive binding is just the+union of all of them, as @union@ removes duplicates. However, the+free variables in each successive set of cumulative bindings is the+union of those in the previous set plus those of the newest binding after+the defined variables of the previous set have been removed.++@rnMethodBinds@ deals only with the declarations in class and+instance declarations.  It expects only to see @FunMonoBind@s, and+it expects the global environment to contain bindings for the binders+(which are all class operations).++************************************************************************+*                                                                      *+\subsubsection{ Top-level bindings}+*                                                                      *+************************************************************************+-}++-- for top-level bindings, we need to make top-level names,+-- so we have a different entry point than for local bindings+rnTopBindsLHS :: MiniFixityEnv+              -> HsValBinds GhcPs+              -> RnM (HsValBindsLR GhcRn GhcPs)+rnTopBindsLHS fix_env binds+  = rnValBindsLHS (topRecNameMaker fix_env) binds++rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs+               -> RnM (HsValBinds GhcRn, DefUses)+-- A hs-boot file has no bindings.+-- Return a single HsBindGroup with empty binds and renamed signatures+rnTopBindsBoot bound_names (ValBinds _ mbinds sigs)+  = do  { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)+        ; (sigs', fvs) <- renameSigs (HsBootCtxt bound_names) sigs+        ; return (XValBindsLR (NValBinds [] sigs'), usesOnly fvs) }+rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b)++{-+*********************************************************+*                                                      *+                HsLocalBinds+*                                                      *+*********************************************************+-}++rnLocalBindsAndThen :: HsLocalBinds GhcPs+                   -> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars))+                   -> RnM (result, FreeVars)+-- This version (a) assumes that the binding vars are *not* already in scope+--               (b) removes the binders from the free vars of the thing inside+-- The parser doesn't produce ThenBinds+rnLocalBindsAndThen (EmptyLocalBinds x) thing_inside =+  thing_inside (EmptyLocalBinds x) emptyNameSet++rnLocalBindsAndThen (HsValBinds x val_binds) thing_inside+  = rnLocalValBindsAndThen val_binds $ \ val_binds' ->+      thing_inside (HsValBinds x val_binds')++rnLocalBindsAndThen (HsIPBinds x binds) thing_inside = do+    (binds',fv_binds) <- rnIPBinds binds+    (thing, fvs_thing) <- thing_inside (HsIPBinds x binds') fv_binds+    return (thing, fvs_thing `plusFV` fv_binds)++rnLocalBindsAndThen (XHsLocalBindsLR _) _ = panic "rnLocalBindsAndThen"++rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars)+rnIPBinds (IPBinds _ ip_binds ) = do+    (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds+    return (IPBinds noExt ip_binds', plusFVs fvs_s)+rnIPBinds (XHsIPBinds _) = panic "rnIPBinds"++rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars)+rnIPBind (IPBind _ ~(Left n) expr) = do+    (expr',fvExpr) <- rnLExpr expr+    return (IPBind noExt (Left n) expr', fvExpr)+rnIPBind (XIPBind _) = panic "rnIPBind"++{-+************************************************************************+*                                                                      *+                ValBinds+*                                                                      *+************************************************************************+-}++-- Renaming local binding groups+-- Does duplicate/shadow check+rnLocalValBindsLHS :: MiniFixityEnv+                   -> HsValBinds GhcPs+                   -> RnM ([Name], HsValBindsLR GhcRn GhcPs)+rnLocalValBindsLHS fix_env binds+  = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds++         -- Check for duplicates and shadowing+         -- Must do this *after* renaming the patterns+         -- See Note [Collect binders only after renaming] in HsUtils++         -- We need to check for dups here because we+         -- don't don't bind all of the variables from the ValBinds at once+         -- with bindLocatedLocals any more.+         --+         -- Note that we don't want to do this at the top level, since+         -- sorting out duplicates and shadowing there happens elsewhere.+         -- The behavior is even different. For example,+         --   import A(f)+         --   f = ...+         -- should not produce a shadowing warning (but it will produce+         -- an ambiguity warning if you use f), but+         --   import A(f)+         --   g = let f = ... in f+         -- should.+       ; let bound_names = collectHsValBinders binds'+             -- There should be only Ids, but if there are any bogus+             -- pattern synonyms, we'll collect them anyway, so that+             -- we don't generate subsequent out-of-scope messages+       ; envs <- getRdrEnvs+       ; checkDupAndShadowedNames envs bound_names++       ; return (bound_names, binds') }++-- renames the left-hand sides+-- generic version used both at the top level and for local binds+-- does some error checking, but not what gets done elsewhere at the top level+rnValBindsLHS :: NameMaker+              -> HsValBinds GhcPs+              -> RnM (HsValBindsLR GhcRn GhcPs)+rnValBindsLHS topP (ValBinds x mbinds sigs)+  = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds+       ; return $ ValBinds x mbinds' sigs }+  where+    bndrs = collectHsBindsBinders mbinds+    doc   = text "In the binding group for:" <+> pprWithCommas ppr bndrs++rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)++-- General version used both from the top-level and for local things+-- Assumes the LHS vars are in scope+--+-- Does not bind the local fixity declarations+rnValBindsRHS :: HsSigCtxt+              -> HsValBindsLR GhcRn GhcPs+              -> RnM (HsValBinds GhcRn, DefUses)++rnValBindsRHS ctxt (ValBinds _ mbinds sigs)+  = do { (sigs', sig_fvs) <- renameSigs ctxt sigs+       ; binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn sigs')) mbinds+       ; let !(anal_binds, anal_dus) = depAnalBinds binds_w_dus++       ; let patsyn_fvs = foldr (unionNameSet . psb_ext) emptyNameSet $+                          getPatSynBinds anal_binds+                -- The uses in binds_w_dus for PatSynBinds do not include+                -- variables used in the patsyn builders; see+                -- Note [Pattern synonym builders don't yield dependencies]+                -- But psb_fvs /does/ include those builder fvs.  So we+                -- add them back in here to avoid bogus warnings about+                -- unused variables (#12548)++             valbind'_dus = anal_dus `plusDU` usesOnly sig_fvs+                                     `plusDU` usesOnly patsyn_fvs+                            -- Put the sig uses *after* the bindings+                            -- so that the binders are removed from+                            -- the uses in the sigs++        ; return (XValBindsLR (NValBinds anal_binds sigs'), valbind'_dus) }++rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b)++-- Wrapper for local binds+--+-- The *client* of this function is responsible for checking for unused binders;+-- it doesn't (and can't: we don't have the thing inside the binds) happen here+--+-- The client is also responsible for bringing the fixities into scope+rnLocalValBindsRHS :: NameSet  -- names bound by the LHSes+                   -> HsValBindsLR GhcRn GhcPs+                   -> RnM (HsValBinds GhcRn, DefUses)+rnLocalValBindsRHS bound_names binds+  = rnValBindsRHS (LocalBindCtxt bound_names) binds++-- for local binds+-- wrapper that does both the left- and right-hand sides+--+-- here there are no local fixity decls passed in;+-- the local fixity decls come from the ValBinds sigs+rnLocalValBindsAndThen+  :: HsValBinds GhcPs+  -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars))+  -> RnM (result, FreeVars)+rnLocalValBindsAndThen binds@(ValBinds _ _ sigs) thing_inside+ = do   {     -- (A) Create the local fixity environment+          new_fixities <- makeMiniFixityEnv [ L loc sig+                                            | L loc (FixSig _ sig) <- sigs]++              -- (B) Rename the LHSes+        ; (bound_names, new_lhs) <- rnLocalValBindsLHS new_fixities binds++              --     ...and bring them (and their fixities) into scope+        ; bindLocalNamesFV bound_names              $+          addLocalFixities new_fixities bound_names $ do++        {      -- (C) Do the RHS and thing inside+          (binds', dus) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs+        ; (result, result_fvs) <- thing_inside binds' (allUses dus)++                -- Report unused bindings based on the (accurate)+                -- findUses.  E.g.+                --      let x = x in 3+                -- should report 'x' unused+        ; let real_uses = findUses dus result_fvs+              -- Insert fake uses for variables introduced implicitly by+              -- wildcards (#4404)+              rec_uses = hsValBindsImplicits binds'+              implicit_uses = mkNameSet $ concatMap snd+                                        $ rec_uses+        ; mapM_ (\(loc, ns) ->+                    checkUnusedRecordWildcard loc real_uses (Just ns))+                rec_uses+        ; warnUnusedLocalBinds bound_names+                                      (real_uses `unionNameSet` implicit_uses)++        ; let+            -- The variables "used" in the val binds are:+            --   (1) the uses of the binds (allUses)+            --   (2) the FVs of the thing-inside+            all_uses = allUses dus `plusFV` result_fvs+                -- Note [Unused binding hack]+                -- ~~~~~~~~~~~~~~~~~~~~~~~~~~+                -- Note that *in contrast* to the above reporting of+                -- unused bindings, (1) above uses duUses to return *all*+                -- the uses, even if the binding is unused.  Otherwise consider:+                --      x = 3+                --      y = let p = x in 'x'    -- NB: p not used+                -- If we don't "see" the dependency of 'y' on 'x', we may put the+                -- bindings in the wrong order, and the type checker will complain+                -- that x isn't in scope+                --+                -- But note that this means we won't report 'x' as unused,+                -- whereas we would if we had { x = 3; p = x; y = 'x' }++        ; return (result, all_uses) }}+                -- The bound names are pruned out of all_uses+                -- by the bindLocalNamesFV call above++rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs)+++---------------------++-- renaming a single bind++rnBindLHS :: NameMaker+          -> SDoc+          -> HsBind GhcPs+          -- returns the renamed left-hand side,+          -- and the FreeVars *of the LHS*+          -- (i.e., any free variables of the pattern)+          -> RnM (HsBindLR GhcRn GhcPs)++rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat })+  = do+      -- we don't actually use the FV processing of rnPatsAndThen here+      (pat',pat'_fvs) <- rnBindPat name_maker pat+      return (bind { pat_lhs = pat', pat_ext = pat'_fvs })+                -- We temporarily store the pat's FVs in bind_fvs;+                -- gets updated to the FVs of the whole bind+                -- when doing the RHS below++rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })+  = do { name <- applyNameMaker name_maker rdr_name+       ; return (bind { fun_id = name+                      , fun_ext = noExt }) }++rnBindLHS name_maker _ (PatSynBind x psb@PSB{ psb_id = rdrname })+  | isTopRecNameMaker name_maker+  = do { addLocM checkConName rdrname+       ; name <- lookupLocatedTopBndrRn rdrname   -- Should be in scope already+       ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }++  | otherwise  -- Pattern synonym, not at top level+  = do { addErr localPatternSynonymErr  -- Complain, but make up a fake+                                        -- name so that we can carry on+       ; name <- applyNameMaker name_maker rdrname+       ; return (PatSynBind x psb{ psb_ext = noExt, psb_id = name }) }+  where+    localPatternSynonymErr :: SDoc+    localPatternSynonymErr+      = hang (text "Illegal pattern synonym declaration for" <+> quotes (ppr rdrname))+           2 (text "Pattern synonym declarations are only valid at top level")++rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)++rnLBind :: (Name -> [Name])      -- Signature tyvar function+        -> LHsBindLR GhcRn GhcPs+        -> RnM (LHsBind GhcRn, [Name], Uses)+rnLBind sig_fn (L loc bind)+  = setSrcSpan loc $+    do { (bind', bndrs, dus) <- rnBind sig_fn bind+       ; return (L loc bind', bndrs, dus) }++-- assumes the left-hands-side vars are in scope+rnBind :: (Name -> [Name])        -- Signature tyvar function+       -> HsBindLR GhcRn GhcPs+       -> RnM (HsBind GhcRn, [Name], Uses)+rnBind _ bind@(PatBind { pat_lhs = pat+                       , pat_rhs = grhss+                                   -- pat fvs were stored in bind_fvs+                                   -- after processing the LHS+                       , pat_ext = pat_fvs })+  = do  { mod <- getModule+        ; (grhss', rhs_fvs) <- rnGRHSs PatBindRhs rnLExpr grhss++                -- No scoped type variables for pattern bindings+        ; let all_fvs = pat_fvs `plusFV` rhs_fvs+              fvs'    = filterNameSet (nameIsLocalOrFrom mod) all_fvs+                -- Keep locally-defined Names+                -- As well as dependency analysis, we need these for the+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan+              bndrs = collectPatBinders pat+              bind' = bind { pat_rhs  = grhss'+                           , pat_ext = fvs' }++              ok_nobind_pat+                  = -- See Note [Pattern bindings that bind no variables]+                    case unLoc pat of+                       WildPat {}   -> True+                       BangPat {}   -> True -- #9127, #13646+                       SplicePat {} -> True+                       _            -> False++        -- Warn if the pattern binds no variables+        -- See Note [Pattern bindings that bind no variables]+        ; whenWOptM Opt_WarnUnusedPatternBinds $+          when (null bndrs && not ok_nobind_pat) $+          addWarn (Reason Opt_WarnUnusedPatternBinds) $+          unusedPatBindWarn bind'++        ; fvs' `seq` -- See Note [Free-variable space leak]+          return (bind', bndrs, all_fvs) }++rnBind sig_fn bind@(FunBind { fun_id = name+                            , fun_matches = matches })+       -- invariant: no free vars here when it's a FunBind+  = do  { let plain_name = unLoc name++        ; (matches', rhs_fvs) <- bindSigTyVarsFV (sig_fn plain_name) $+                                -- bindSigTyVars tests for LangExt.ScopedTyVars+                                 rnMatchGroup (mkPrefixFunRhs name)+                                              rnLExpr matches+        ; let is_infix = isInfixFunBind bind+        ; when is_infix $ checkPrecMatch plain_name matches'++        ; mod <- getModule+        ; let fvs' = filterNameSet (nameIsLocalOrFrom mod) rhs_fvs+                -- Keep locally-defined Names+                -- As well as dependency analysis, we need these for the+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan++        ; fvs' `seq` -- See Note [Free-variable space leak]+          return (bind { fun_matches = matches'+                       , fun_ext     = fvs' },+                  [plain_name], rhs_fvs)+      }++rnBind sig_fn (PatSynBind x bind)+  = do  { (bind', name, fvs) <- rnPatSynBind sig_fn bind+        ; return (PatSynBind x bind', name, fvs) }++rnBind _ b = pprPanic "rnBind" (ppr b)++{- Note [Pattern bindings that bind no variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally, we want to warn about pattern bindings like+  Just _ = e+because they don't do anything!  But we have three exceptions:++* A wildcard pattern+       _ = rhs+  which (a) is not that different from  _v = rhs+        (b) is sometimes used to give a type sig for,+            or an occurrence of, a variable on the RHS++* A strict pattern binding; that is, one with an outermost bang+     !Just _ = e+  This can fail, so unlike the lazy variant, it is not a no-op.+  Moreover, #13646 argues that even for single constructor+  types, you might want to write the constructor.  See also #9127.++* A splice pattern+      $(th-lhs) = rhs+   It is impossible to determine whether or not th-lhs really+   binds any variable. We should disable the warning for any pattern+   which contain splices, but that is a more expensive check.++Note [Free-variable space leak]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have+    fvs' = trim fvs+and we seq fvs' before turning it as part of a record.++The reason is that trim is sometimes something like+    \xs -> intersectNameSet (mkNameSet bound_names) xs+and we don't want to retain the list bound_names. This showed up in+trac ticket #1136.+-}++{- *********************************************************************+*                                                                      *+          Dependency analysis and other support functions+*                                                                      *+********************************************************************* -}++depAnalBinds :: Bag (LHsBind GhcRn, [Name], Uses)+             -> ([(RecFlag, LHsBinds GhcRn)], DefUses)+-- Dependency analysis; this is important so that+-- unused-binding reporting is accurate+depAnalBinds binds_w_dus+  = (map get_binds sccs, map get_du sccs)+  where+    sccs = depAnal (\(_, defs, _) -> defs)+                   (\(_, _, uses) -> nonDetEltsUniqSet uses)+                   -- It's OK to use nonDetEltsUniqSet here as explained in+                   -- Note [depAnal determinism] in NameEnv.+                   (bagToList binds_w_dus)++    get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)+    get_binds (CyclicSCC  binds_w_dus)  = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus])++    get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses)+    get_du (CyclicSCC  binds_w_dus)      = (Just defs, uses)+        where+          defs = mkNameSet [b | (_,bs,_) <- binds_w_dus, b <- bs]+          uses = unionNameSets [u | (_,_,u) <- binds_w_dus]++---------------------+-- Bind the top-level forall'd type variables in the sigs.+-- E.g  f :: forall a. a -> a+--      f = rhs+--      The 'a' scopes over the rhs+--+-- NB: there'll usually be just one (for a function binding)+--     but if there are many, one may shadow the rest; too bad!+--      e.g  x :: forall a. [a] -> [a]+--           y :: forall a. [(a,a)] -> a+--           (x,y) = e+--      In e, 'a' will be in scope, and it'll be the one from 'y'!++mkScopedTvFn :: [LSig GhcRn] -> (Name -> [Name])+-- Return a lookup function that maps an Id Name to the names+-- of the type variables that should scope over its body.+mkScopedTvFn sigs = \n -> lookupNameEnv env n `orElse` []+  where+    env = mkHsSigEnv get_scoped_tvs sigs++    get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name])+    -- Returns (binders, scoped tvs for those binders)+    get_scoped_tvs (L _ (ClassOpSig _ _ names sig_ty))+      = Just (names, hsScopedTvs sig_ty)+    get_scoped_tvs (L _ (TypeSig _ names sig_ty))+      = Just (names, hsWcScopedTvs sig_ty)+    get_scoped_tvs (L _ (PatSynSig _ names sig_ty))+      = Just (names, hsScopedTvs sig_ty)+    get_scoped_tvs _ = Nothing++-- Process the fixity declarations, making a FastString -> (Located Fixity) map+-- (We keep the location around for reporting duplicate fixity declarations.)+--+-- Checks for duplicates, but not that only locally defined things are fixed.+-- Note: for local fixity declarations, duplicates would also be checked in+--       check_sigs below.  But we also use this function at the top level.++makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv++makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls+ where+   add_one_sig env (L loc (FixitySig _ names fixity)) =+     foldlM add_one env [ (loc,name_loc,name,fixity)+                        | L name_loc name <- names ]+   add_one_sig _ (L _ (XFixitySig _)) = panic "makeMiniFixityEnv"++   add_one env (loc, name_loc, name,fixity) = do+     { -- this fixity decl is a duplicate iff+       -- the ReaderName's OccName's FastString is already in the env+       -- (we only need to check the local fix_env because+       --  definitions of non-local will be caught elsewhere)+       let { fs = occNameFS (rdrNameOcc name)+           ; fix_item = L loc fixity };++       case lookupFsEnv env fs of+         Nothing -> return $ extendFsEnv env fs fix_item+         Just (L loc' _) -> do+           { setSrcSpan loc $+             addErrAt name_loc (dupFixityDecl loc' name)+           ; return env}+     }++dupFixityDecl :: SrcSpan -> RdrName -> SDoc+dupFixityDecl loc rdr_name+  = vcat [text "Multiple fixity declarations for" <+> quotes (ppr rdr_name),+          text "also at " <+> ppr loc]+++{- *********************************************************************+*                                                                      *+                Pattern synonym bindings+*                                                                      *+********************************************************************* -}++rnPatSynBind :: (Name -> [Name])           -- Signature tyvar function+             -> PatSynBind GhcRn GhcPs+             -> RnM (PatSynBind GhcRn GhcRn, [Name], Uses)+rnPatSynBind sig_fn bind@(PSB { psb_id = L l name+                              , psb_args = details+                              , psb_def = pat+                              , psb_dir = dir })+       -- invariant: no free vars here when it's a FunBind+  = do  { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms+        ; unless pattern_synonym_ok (addErr patternSynonymErr)+        ; let scoped_tvs = sig_fn name++        ; ((pat', details'), fvs1) <- bindSigTyVarsFV scoped_tvs $+                                      rnPat PatSyn pat $ \pat' ->+         -- We check the 'RdrName's instead of the 'Name's+         -- so that the binding locations are reported+         -- from the left-hand side+            case details of+               PrefixCon vars ->+                   do { checkDupRdrNames vars+                      ; names <- mapM lookupPatSynBndr vars+                      ; return ( (pat', PrefixCon names)+                               , mkFVs (map unLoc names)) }+               InfixCon var1 var2 ->+                   do { checkDupRdrNames [var1, var2]+                      ; name1 <- lookupPatSynBndr var1+                      ; name2 <- lookupPatSynBndr var2+                      -- ; checkPrecMatch -- TODO+                      ; return ( (pat', InfixCon name1 name2)+                               , mkFVs (map unLoc [name1, name2])) }+               RecCon vars ->+                   do { checkDupRdrNames (map recordPatSynSelectorId vars)+                      ; let rnRecordPatSynField+                              (RecordPatSynField { recordPatSynSelectorId = visible+                                                 , recordPatSynPatVar = hidden })+                              = do { visible' <- lookupLocatedTopBndrRn visible+                                   ; hidden'  <- lookupPatSynBndr hidden+                                   ; return $ RecordPatSynField { recordPatSynSelectorId = visible'+                                                                , recordPatSynPatVar = hidden' } }+                      ; names <- mapM rnRecordPatSynField  vars+                      ; return ( (pat', RecCon names)+                               , mkFVs (map (unLoc . recordPatSynPatVar) names)) }++        ; (dir', fvs2) <- case dir of+            Unidirectional -> return (Unidirectional, emptyFVs)+            ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs)+            ExplicitBidirectional mg ->+                do { (mg', fvs) <- bindSigTyVarsFV scoped_tvs $+                                   rnMatchGroup (mkPrefixFunRhs (L l name))+                                                rnLExpr mg+                   ; return (ExplicitBidirectional mg', fvs) }++        ; mod <- getModule+        ; let fvs = fvs1 `plusFV` fvs2+              fvs' = filterNameSet (nameIsLocalOrFrom mod) fvs+                -- Keep locally-defined Names+                -- As well as dependency analysis, we need these for the+                -- MonoLocalBinds test in TcBinds.decideGeneralisationPlan++              bind' = bind{ psb_args = details'+                          , psb_def = pat'+                          , psb_dir = dir'+                          , psb_ext = fvs' }+              selector_names = case details' of+                                 RecCon names ->+                                  map (unLoc . recordPatSynSelectorId) names+                                 _ -> []++        ; fvs' `seq` -- See Note [Free-variable space leak]+          return (bind', name : selector_names , fvs1)+          -- Why fvs1?  See Note [Pattern synonym builders don't yield dependencies]+      }+  where+    -- See Note [Renaming pattern synonym variables]+    lookupPatSynBndr = wrapLocM lookupLocalOccRn++    patternSynonymErr :: SDoc+    patternSynonymErr+      = hang (text "Illegal pattern synonym declaration")+           2 (text "Use -XPatternSynonyms to enable this extension")++rnPatSynBind _ (XPatSynBind _) = panic "rnPatSynBind"++{-+Note [Renaming pattern synonym variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We rename pattern synonym declaractions backwards to normal to reuse+the logic already implemented for renaming patterns.++We first rename the RHS of a declaration which brings into+scope the variables bound by the pattern (as they would be+in normal function definitions). We then lookup the variables+which we want to bind in this local environment.++It is crucial that we then only lookup in the *local* environment which+only contains the variables brought into scope by the pattern and nothing+else. Amazingly no-one encountered this bug for 3 GHC versions but+it was possible to define a pattern synonym which referenced global+identifiers and worked correctly.++```+x = 5++pattern P :: Int -> ()+pattern P x <- _++f (P x) = x++> f () = 5+```++See #13470 for the original report.++Note [Pattern synonym builders don't yield dependencies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When renaming a pattern synonym that has an explicit builder,+references in the builder definition should not be used when+calculating dependencies. For example, consider the following pattern+synonym definition:++pattern P x <- C1 x where+  P x = f (C1 x)++f (P x) = C2 x++In this case, 'P' needs to be typechecked in two passes:++1. Typecheck the pattern definition of 'P', which fully determines the+   type of 'P'. This step doesn't require knowing anything about 'f',+   since the builder definition is not looked at.++2. Typecheck the builder definition, which needs the typechecked+   definition of 'f' to be in scope; done by calls oo tcPatSynBuilderBind+   in TcBinds.tcValBinds.++This behaviour is implemented in 'tcValBinds', but it crucially+depends on 'P' not being put in a recursive group with 'f' (which+would make it look like a recursive pattern synonym a la 'pattern P =+P' which is unsound and rejected).++So:+ * We do not include builder fvs in the Uses returned by rnPatSynBind+   (which is then used for dependency analysis)+ * But we /do/ include them in the psb_fvs for the PatSynBind+ * In rnValBinds we record these builder uses, to avoid bogus+   unused-variable warnings (#12548)+-}++{- *********************************************************************+*                                                                      *+                Class/instance method bindings+*                                                                      *+********************************************************************* -}++{- @rnMethodBinds@ is used for the method bindings of a class and an instance+declaration.   Like @rnBinds@ but without dependency analysis.++NOTA BENE: we record each {\em binder} of a method-bind group as a free variable.+That's crucial when dealing with an instance decl:+\begin{verbatim}+        instance Foo (T a) where+           op x = ...+\end{verbatim}+This might be the {\em sole} occurrence of @op@ for an imported class @Foo@,+and unless @op@ occurs we won't treat the type signature of @op@ in the class+decl for @Foo@ as a source of instance-decl gates.  But we should!  Indeed,+in many ways the @op@ in an instance decl is just like an occurrence, not+a binder.+-}++rnMethodBinds :: Bool                   -- True <=> is a class declaration+              -> Name                   -- Class name+              -> [Name]                 -- Type variables from the class/instance header+              -> LHsBinds GhcPs         -- Binds+              -> [LSig GhcPs]           -- and signatures/pragmas+              -> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars)+-- Used for+--   * the default method bindings in a class decl+--   * the method bindings in an instance decl+rnMethodBinds is_cls_decl cls ktv_names binds sigs+  = do { checkDupRdrNames (collectMethodBinders binds)+             -- Check that the same method is not given twice in the+             -- same instance decl      instance C T where+             --                       f x = ...+             --                       g y = ...+             --                       f x = ...+             -- We must use checkDupRdrNames because the Name of the+             -- method is the Name of the class selector, whose SrcSpan+             -- points to the class declaration; and we use rnMethodBinds+             -- for instance decls too++       -- Rename the bindings LHSs+       ; binds' <- foldrBagM (rnMethodBindLHS is_cls_decl cls) emptyBag binds++       -- Rename the pragmas and signatures+       -- Annoyingly the type variables /are/ in scope for signatures, but+       -- /are not/ in scope in the SPECIALISE instance pramas; e.g.+       --    instance Eq a => Eq (T a) where+       --       (==) :: a -> a -> a+       --       {-# SPECIALISE instance Eq a => Eq (T [a]) #-}+       ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs+             bound_nms = mkNameSet (collectHsBindsBinders binds')+             sig_ctxt | is_cls_decl = ClsDeclCtxt cls+                      | otherwise   = InstDeclCtxt bound_nms+       ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags+       ; (other_sigs',      sig_fvs) <- extendTyVarEnvFVRn ktv_names $+                                        renameSigs sig_ctxt other_sigs++       -- Rename the bindings RHSs.  Again there's an issue about whether the+       -- type variables from the class/instance head are in scope.+       -- Answer no in Haskell 2010, but yes if you have -XScopedTypeVariables+       ; scoped_tvs  <- xoptM LangExt.ScopedTypeVariables+       ; (binds'', bind_fvs) <- maybe_extend_tyvar_env scoped_tvs $+              do { binds_w_dus <- mapBagM (rnLBind (mkScopedTvFn other_sigs')) binds'+                 ; let bind_fvs = foldrBag (\(_,_,fv1) fv2 -> fv1 `plusFV` fv2)+                                           emptyFVs binds_w_dus+                 ; return (mapBag fstOf3 binds_w_dus, bind_fvs) }++       ; return ( binds'', spec_inst_prags' ++ other_sigs'+                , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) }+  where+    -- For the method bindings in class and instance decls, we extend+    -- the type variable environment iff -XScopedTypeVariables+    maybe_extend_tyvar_env scoped_tvs thing_inside+       | scoped_tvs = extendTyVarEnvFVRn ktv_names thing_inside+       | otherwise  = thing_inside++rnMethodBindLHS :: Bool -> Name+                -> LHsBindLR GhcPs GhcPs+                -> LHsBindsLR GhcRn GhcPs+                -> RnM (LHsBindsLR GhcRn GhcPs)+rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest+  = setSrcSpan loc $ do+    do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name+                     -- We use the selector name as the binder+       ; let bind' = bind { fun_id = sel_name, fun_ext = noExt }+       ; return (L loc bind' `consBag` rest ) }++-- Report error for all other forms of bindings+-- This is why we use a fold rather than map+rnMethodBindLHS is_cls_decl _ (L loc bind) rest+  = do { addErrAt loc $+         vcat [ what <+> text "not allowed in" <+> decl_sort+              , nest 2 (ppr bind) ]+       ; return rest }+  where+    decl_sort | is_cls_decl = text "class declaration:"+              | otherwise   = text "instance declaration:"+    what = case bind of+              PatBind {}    -> text "Pattern bindings (except simple variables)"+              PatSynBind {} -> text "Pattern synonyms"+                               -- Associated pattern synonyms are not implemented yet+              _ -> pprPanic "rnMethodBind" (ppr bind)++{-+************************************************************************+*                                                                      *+\subsubsection[dep-Sigs]{Signatures (and user-pragmas for values)}+*                                                                      *+************************************************************************++@renameSigs@ checks for:+\begin{enumerate}+\item more than one sig for one thing;+\item signatures given for things not bound here;+\end{enumerate}++At the moment we don't gather free-var info from the types in+signatures.  We'd only need this if we wanted to report unused tyvars.+-}++renameSigs :: HsSigCtxt+           -> [LSig GhcPs]+           -> RnM ([LSig GhcRn], FreeVars)+-- Renames the signatures and performs error checks+renameSigs ctxt sigs+  = do  { mapM_ dupSigDeclErr (findDupSigs sigs)++        ; checkDupMinimalSigs sigs++        ; (sigs', sig_fvs) <- mapFvRn (wrapLocFstM (renameSig ctxt)) sigs++        ; let (good_sigs, bad_sigs) = partition (okHsSig ctxt) sigs'+        ; mapM_ misplacedSigErr bad_sigs                 -- Misplaced++        ; return (good_sigs, sig_fvs) }++----------------------+-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory+-- because this won't work for:+--      instance Foo T where+--        {-# INLINE op #-}+--        Baz.op = ...+-- We'll just rename the INLINE prag to refer to whatever other 'op'+-- is in scope.  (I'm assuming that Baz.op isn't in scope unqualified.)+-- Doesn't seem worth much trouble to sort this.++renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars)+renameSig _ (IdSig _ x)+  = return (IdSig noExt x, emptyFVs)    -- Actually this never occurs++renameSig ctxt sig@(TypeSig _ vs ty)+  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs+        ; let doc = TypeSigCtx (ppr_sig_bndrs vs)+        ; (new_ty, fvs) <- rnHsSigWcType BindUnlessForall doc ty+        ; return (TypeSig noExt new_vs new_ty, fvs) }++renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty)+  = do  { defaultSigs_on <- xoptM LangExt.DefaultSignatures+        ; when (is_deflt && not defaultSigs_on) $+          addErr (defaultSigErr sig)+        ; new_v <- mapM (lookupSigOccRn ctxt sig) vs+        ; (new_ty, fvs) <- rnHsSigType ty_ctxt ty+        ; return (ClassOpSig noExt is_deflt new_v new_ty, fvs) }+  where+    (v1:_) = vs+    ty_ctxt = GenericCtx (text "a class method signature for"+                          <+> quotes (ppr v1))++renameSig _ (SpecInstSig _ src ty)+  = do  { (new_ty, fvs) <- rnHsSigType SpecInstSigCtx ty+        ; return (SpecInstSig noExt src new_ty,fvs) }++-- {-# SPECIALISE #-} pragmas can refer to imported Ids+-- so, in the top-level case (when mb_names is Nothing)+-- we use lookupOccRn.  If there's both an imported and a local 'f'+-- then the SPECIALISE pragma is ambiguous, unlike all other signatures+renameSig ctxt sig@(SpecSig _ v tys inl)+  = do  { new_v <- case ctxt of+                     TopSigCtxt {} -> lookupLocatedOccRn v+                     _             -> lookupSigOccRn ctxt sig v+        ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys+        ; return (SpecSig noExt new_v new_ty inl, fvs) }+  where+    ty_ctxt = GenericCtx (text "a SPECIALISE signature for"+                          <+> quotes (ppr v))+    do_one (tys,fvs) ty+      = do { (new_ty, fvs_ty) <- rnHsSigType ty_ctxt ty+           ; return ( new_ty:tys, fvs_ty `plusFV` fvs) }++renameSig ctxt sig@(InlineSig _ v s)+  = do  { new_v <- lookupSigOccRn ctxt sig v+        ; return (InlineSig noExt new_v s, emptyFVs) }++renameSig ctxt (FixSig _ fsig)+  = do  { new_fsig <- rnSrcFixityDecl ctxt fsig+        ; return (FixSig noExt new_fsig, emptyFVs) }++renameSig ctxt sig@(MinimalSig _ s (L l bf))+  = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf+       return (MinimalSig noExt s (L l new_bf), emptyFVs)++renameSig ctxt sig@(PatSynSig _ vs ty)+  = do  { new_vs <- mapM (lookupSigOccRn ctxt sig) vs+        ; (ty', fvs) <- rnHsSigType ty_ctxt ty+        ; return (PatSynSig noExt new_vs ty', fvs) }+  where+    ty_ctxt = GenericCtx (text "a pattern synonym signature for"+                          <+> ppr_sig_bndrs vs)++renameSig ctxt sig@(SCCFunSig _ st v s)+  = do  { new_v <- lookupSigOccRn ctxt sig v+        ; return (SCCFunSig noExt st new_v s, emptyFVs) }++-- COMPLETE Sigs can refer to imported IDs which is why we use+-- lookupLocatedOccRn rather than lookupSigOccRn+renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty)+  = do new_bf <- traverse lookupLocatedOccRn bf+       new_mty  <- traverse lookupLocatedOccRn mty++       this_mod <- fmap tcg_mod getGblEnv+       unless (any (nameIsLocalOrFrom this_mod . unLoc) new_bf) $ do+         -- Why 'any'? See Note [Orphan COMPLETE pragmas]+         addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError++       return (CompleteMatchSig noExt s (L l new_bf) new_mty, emptyFVs)+  where+    orphanError :: SDoc+    orphanError =+      text "Orphan COMPLETE pragmas not supported" $$+      text "A COMPLETE pragma must mention at least one data constructor" $$+      text "or pattern synonym defined in the same module."++renameSig _ (XSig _) = panic "renameSig"++{-+Note [Orphan COMPLETE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We define a COMPLETE pragma to be a non-orphan if it includes at least+one conlike defined in the current module. Why is this sufficient?+Well if you have a pattern match++  case expr of+    P1 -> ...+    P2 -> ...+    P3 -> ...++any COMPLETE pragma which mentions a conlike other than P1, P2 or P3+will not be of any use in verifying that the pattern match is+exhaustive. So as we have certainly read the interface files that+define P1, P2 and P3, we will have loaded all non-orphan COMPLETE+pragmas that could be relevant to this pattern match.++For now we simply disallow orphan COMPLETE pragmas, as the added+complexity of supporting them properly doesn't seem worthwhile.+-}++ppr_sig_bndrs :: [Located RdrName] -> SDoc+ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)++okHsSig :: HsSigCtxt -> LSig a -> Bool+okHsSig ctxt (L _ sig)+  = case (sig, ctxt) of+     (ClassOpSig {}, ClsDeclCtxt {})  -> True+     (ClassOpSig {}, InstDeclCtxt {}) -> True+     (ClassOpSig {}, _)               -> False++     (TypeSig {}, ClsDeclCtxt {})  -> False+     (TypeSig {}, InstDeclCtxt {}) -> False+     (TypeSig {}, _)               -> True++     (PatSynSig {}, TopSigCtxt{}) -> True+     (PatSynSig {}, _)            -> False++     (FixSig {}, InstDeclCtxt {}) -> False+     (FixSig {}, _)               -> True++     (IdSig {}, TopSigCtxt {})   -> True+     (IdSig {}, InstDeclCtxt {}) -> True+     (IdSig {}, _)               -> False++     (InlineSig {}, HsBootCtxt {}) -> False+     (InlineSig {}, _)             -> True++     (SpecSig {}, TopSigCtxt {})    -> True+     (SpecSig {}, LocalBindCtxt {}) -> True+     (SpecSig {}, InstDeclCtxt {})  -> True+     (SpecSig {}, _)                -> False++     (SpecInstSig {}, InstDeclCtxt {}) -> True+     (SpecInstSig {}, _)               -> False++     (MinimalSig {}, ClsDeclCtxt {}) -> True+     (MinimalSig {}, _)              -> False++     (SCCFunSig {}, HsBootCtxt {}) -> False+     (SCCFunSig {}, _)             -> True++     (CompleteMatchSig {}, TopSigCtxt {} ) -> True+     (CompleteMatchSig {}, _)              -> False++     (XSig _, _) -> panic "okHsSig"++-------------------+findDupSigs :: [LSig GhcPs] -> [NonEmpty (Located RdrName, Sig GhcPs)]+-- Check for duplicates on RdrName version,+-- because renamed version has unboundName for+-- not-in-scope binders, which gives bogus dup-sig errors+-- NB: in a class decl, a 'generic' sig is not considered+--     equal to an ordinary sig, so we allow, say+--           class C a where+--             op :: a -> a+--             default op :: Eq a => a -> a+findDupSigs sigs+  = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs)+  where+    expand_sig sig@(FixSig _ (FixitySig _ ns _)) = zip ns (repeat sig)+    expand_sig sig@(InlineSig _ n _)             = [(n,sig)]+    expand_sig sig@(TypeSig _ ns _)              = [(n,sig) | n <- ns]+    expand_sig sig@(ClassOpSig _ _ ns _)         = [(n,sig) | n <- ns]+    expand_sig sig@(PatSynSig _ ns  _ )          = [(n,sig) | n <- ns]+    expand_sig sig@(SCCFunSig _ _ n _)           = [(n,sig)]+    expand_sig _ = []++    matching_sig (L _ n1,sig1) (L _ n2,sig2)       = n1 == n2 && mtch sig1 sig2+    mtch (FixSig {})           (FixSig {})         = True+    mtch (InlineSig {})        (InlineSig {})      = True+    mtch (TypeSig {})          (TypeSig {})        = True+    mtch (ClassOpSig _ d1 _ _) (ClassOpSig _ d2 _ _) = d1 == d2+    mtch (PatSynSig _ _ _)     (PatSynSig _ _ _)   = True+    mtch (SCCFunSig{})         (SCCFunSig{})       = True+    mtch _ _ = False++-- Warn about multiple MINIMAL signatures+checkDupMinimalSigs :: [LSig GhcPs] -> RnM ()+checkDupMinimalSigs sigs+  = case filter isMinimalLSig sigs of+      minSigs@(_:_:_) -> dupMinimalSigErr minSigs+      _ -> return ()++{-+************************************************************************+*                                                                      *+\subsection{Match}+*                                                                      *+************************************************************************+-}++rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext Name+             -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+             -> MatchGroup GhcPs (Located (body GhcPs))+             -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars)+rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin })+  = do { empty_case_ok <- xoptM LangExt.EmptyCase+       ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))+       ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms+       ; return (mkMatchGroup origin new_ms, ms_fvs) }+rnMatchGroup _ _ (XMatchGroup {}) = panic "rnMatchGroup"++rnMatch :: Outputable (body GhcPs) => HsMatchContext Name+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+        -> LMatch GhcPs (Located (body GhcPs))+        -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars)+rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody)++rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name+         -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+         -> Match GhcPs (Located (body GhcPs))+         -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars)+rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })+  = do  { -- Note that there are no local fixity decls for matches+        ; rnPats ctxt pats      $ \ pats' -> do+        { (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss+        ; let mf' = case (ctxt, mf) of+                      (FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ })+                                            -> mf { mc_fun = L lf funid }+                      _                     -> ctxt+        ; return (Match { m_ext = noExt, m_ctxt = mf', m_pats = pats'+                        , m_grhss = grhss'}, grhss_fvs ) }}+rnMatch' _ _ (XMatch _) = panic "rnMatch'"++emptyCaseErr :: HsMatchContext Name -> SDoc+emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt)+                       2 (text "Use EmptyCase to allow this")+  where+    pp_ctxt = case ctxt of+                CaseAlt    -> text "case expression"+                LambdaExpr -> text "\\case expression"+                _ -> text "(unexpected)" <+> pprMatchContextNoun ctxt++{-+************************************************************************+*                                                                      *+\subsubsection{Guarded right-hand sides (GRHSs)}+*                                                                      *+************************************************************************+-}++rnGRHSs :: HsMatchContext Name+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+        -> GRHSs GhcPs (Located (body GhcPs))+        -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars)+rnGRHSs ctxt rnBody (GRHSs _ grhss (L l binds))+  = rnLocalBindsAndThen binds   $ \ binds' _ -> do+    (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss+    return (GRHSs noExt grhss' (L l binds'), fvGRHSs)+rnGRHSs _ _ (XGRHSs _) = panic "rnGRHSs"++rnGRHS :: HsMatchContext Name+       -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+       -> LGRHS GhcPs (Located (body GhcPs))+       -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars)+rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody)++rnGRHS' :: HsMatchContext Name+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+        -> GRHS GhcPs (Located (body GhcPs))+        -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars)+rnGRHS' ctxt rnBody (GRHS _ guards rhs)+  = do  { pattern_guards_allowed <- xoptM LangExt.PatternGuards+        ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ ->+                                    rnBody rhs++        ; unless (pattern_guards_allowed || is_standard_guard guards')+                 (addWarn NoReason (nonStdGuardErr guards'))++        ; return (GRHS noExt guards' rhs', fvs) }+  where+        -- Standard Haskell 1.4 guards are just a single boolean+        -- expression, rather than a list of qualifiers as in the+        -- Glasgow extension+    is_standard_guard []                  = True+    is_standard_guard [L _ (BodyStmt {})] = True+    is_standard_guard _                   = False+rnGRHS' _ _ (XGRHS _) = panic "rnGRHS'"++{-+*********************************************************+*                                                       *+        Source-code fixity declarations+*                                                       *+*********************************************************+-}++rnSrcFixityDecl :: HsSigCtxt -> FixitySig GhcPs -> RnM (FixitySig GhcRn)+-- Rename a fixity decl, so we can put+-- the renamed decl in the renamed syntax tree+-- Errors if the thing being fixed is not defined locally.+rnSrcFixityDecl sig_ctxt = rn_decl+  where+    rn_decl :: FixitySig GhcPs -> RnM (FixitySig GhcRn)+        -- GHC extension: look up both the tycon and data con+        -- for con-like things; hence returning a list+        -- If neither are in scope, report an error; otherwise+        -- return a fixity sig for each (slightly odd)+    rn_decl (FixitySig _ fnames fixity)+      = do names <- concatMapM lookup_one fnames+           return (FixitySig noExt names fixity)+    rn_decl (XFixitySig _) = panic "rnSrcFixityDecl"++    lookup_one :: Located RdrName -> RnM [Located Name]+    lookup_one (L name_loc rdr_name)+      = setSrcSpan name_loc $+                    -- This lookup will fail if the name is not defined in the+                    -- same binding group as this fixity declaration.+        do names <- lookupLocalTcNames sig_ctxt what rdr_name+           return [ L name_loc name | (_, name) <- names ]+    what = text "fixity signature"++{-+************************************************************************+*                                                                      *+\subsection{Error messages}+*                                                                      *+************************************************************************+-}++dupSigDeclErr :: NonEmpty (Located RdrName, Sig GhcPs) -> RnM ()+dupSigDeclErr pairs@((L loc name, sig) :| _)+  = addErrAt loc $+    vcat [ text "Duplicate" <+> what_it_is+           <> text "s for" <+> quotes (ppr name)+         , text "at" <+> vcat (map ppr $ sort+                                       $ map (getLoc . fst)+                                       $ toList pairs)+         ]+  where+    what_it_is = hsSigDoc sig++misplacedSigErr :: LSig GhcRn -> RnM ()+misplacedSigErr (L loc sig)+  = addErrAt loc $+    sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig]++defaultSigErr :: Sig GhcPs -> SDoc+defaultSigErr sig = vcat [ hang (text "Unexpected default signature:")+                              2 (ppr sig)+                         , text "Use DefaultSignatures to enable default signatures" ]++bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc+bindsInHsBootFile mbinds+  = hang (text "Bindings in hs-boot files are not allowed")+       2 (ppr mbinds)++nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc+nonStdGuardErr guards+  = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)")+       4 (interpp'SP guards)++unusedPatBindWarn :: HsBind GhcRn -> SDoc+unusedPatBindWarn bind+  = hang (text "This pattern-binding binds no variables:")+       2 (ppr bind)++dupMinimalSigErr :: [LSig GhcPs] -> RnM ()+dupMinimalSigErr sigs@(L loc _ : _)+  = addErrAt loc $+    vcat [ text "Multiple minimal complete definitions"+         , text "at" <+> vcat (map ppr $ sort $ map getLoc sigs)+         , text "Combine alternative minimal complete definitions with `|'" ]+dupMinimalSigErr [] = panic "dupMinimalSigErr"
+ compiler/rename/RnEnv.hs view
@@ -0,0 +1,1686 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-2006++RnEnv contains functions which convert RdrNames into Names.++-}++{-# LANGUAGE CPP, MultiWayIf, NamedFieldPuns #-}++module RnEnv (+        newTopSrcBinder,+        lookupLocatedTopBndrRn, lookupTopBndrRn,+        lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe,+        lookupLocalOccRn_maybe, lookupInfoOccRn,+        lookupLocalOccThLvl_maybe, lookupLocalOccRn,+        lookupTypeOccRn,+        lookupGlobalOccRn, lookupGlobalOccRn_maybe,+        lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc,++        ChildLookupResult(..),+        lookupSubBndrOcc_helper,+        combineChildLookupResult, -- Called by lookupChildrenExport++        HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,+        lookupSigCtxtOccRn,++        lookupInstDeclBndr, lookupRecFieldOcc, lookupFamInstName,+        lookupConstructorFields,++        lookupGreAvailRn,++        -- Rebindable Syntax+        lookupSyntaxName, lookupSyntaxName', lookupSyntaxNames,+        lookupIfThenElse,++        -- Constructing usage information+        addUsedGRE, addUsedGREs, addUsedDataCons,++++        dataTcOccs, --TODO: Move this somewhere, into utils?++    ) where++#include "HsVersions.h"++import GhcPrelude++import LoadIface        ( loadInterfaceForName, loadSrcInterface_maybe )+import IfaceEnv+import HsSyn+import RdrName+import HscTypes+import TcEnv+import TcRnMonad+import RdrHsSyn         ( filterCTuple, setRdrNameSpace )+import TysWiredIn+import Name+import NameSet+import NameEnv+import Avail+import Module+import ConLike+import DataCon+import TyCon+import ErrUtils         ( MsgDoc )+import PrelNames        ( rOOT_MAIN )+import BasicTypes       ( pprWarningTxtForMsg, TopLevelFlag(..))+import SrcLoc+import Outputable+import Util+import Maybes+import DynFlags+import FastString+import Control.Monad+import ListSetOps       ( minusList )+import qualified GHC.LanguageExtensions as LangExt+import RnUnbound+import RnUtils+import qualified Data.Semigroup as Semi+import Data.Either      ( partitionEithers )+import Data.List        (find)++{-+*********************************************************+*                                                      *+                Source-code binders+*                                                      *+*********************************************************++Note [Signature lazy interface loading]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++GHC's lazy interface loading can be a bit confusing, so this Note is an+empirical description of what happens in one interesting case. When+compiling a signature module against an its implementation, we do NOT+load interface files associated with its names until after the type+checking phase.  For example:++    module ASig where+        data T+        f :: T -> T++Suppose we compile this with -sig-of "A is ASig":++    module B where+        data T = T+        f T = T++    module A(module B) where+        import B++During type checking, we'll load A.hi because we need to know what the+RdrEnv for the module is, but we DO NOT load the interface for B.hi!+It's wholly unnecessary: our local definition 'data T' in ASig is all+the information we need to finish type checking.  This is contrast to+type checking of ordinary Haskell files, in which we would not have the+local definition "data T" and would need to consult B.hi immediately.+(Also, this situation never occurs for hs-boot files, since you're not+allowed to reexport from another module.)++After type checking, we then check that the types we provided are+consistent with the backing implementation (in checkHiBootOrHsigIface).+At this point, B.hi is loaded, because we need something to compare+against.++I discovered this behavior when trying to figure out why type class+instances for Data.Map weren't in the EPS when I was type checking a+test very much like ASig (sigof02dm): the associated interface hadn't+been loaded yet!  (The larger issue is a moot point, since an instance+declared in a signature can never be a duplicate.)++This behavior might change in the future.  Consider this+alternate module B:++    module B where+        {-# DEPRECATED T, f "Don't use" #-}+        data T = T+        f T = T++One might conceivably want to report deprecation warnings when compiling+ASig with -sig-of B, in which case we need to look at B.hi to find the+deprecation warnings during renaming.  At the moment, you don't get any+warning until you use the identifier further downstream.  This would+require adjusting addUsedGRE so that during signature compilation,+we do not report deprecation warnings for LocalDef.  See also+Note [Handling of deprecations]+-}++newTopSrcBinder :: Located RdrName -> RnM Name+newTopSrcBinder (L loc rdr_name)+  | Just name <- isExact_maybe rdr_name+  =     -- This is here to catch+        --   (a) Exact-name binders created by Template Haskell+        --   (b) The PrelBase defn of (say) [] and similar, for which+        --       the parser reads the special syntax and returns an Exact RdrName+        -- We are at a binding site for the name, so check first that it+        -- the current module is the correct one; otherwise GHC can get+        -- very confused indeed. This test rejects code like+        --      data T = (,) Int Int+        -- unless we are in GHC.Tup+    if isExternalName name then+      do { this_mod <- getModule+         ; unless (this_mod == nameModule name)+                  (addErrAt loc (badOrigBinding rdr_name))+         ; return name }+    else   -- See Note [Binders in Template Haskell] in Convert.hs+      do { this_mod <- getModule+         ; externaliseName this_mod name }++  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name+  = do  { this_mod <- getModule+        ; unless (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)+                 (addErrAt loc (badOrigBinding rdr_name))+        -- When reading External Core we get Orig names as binders,+        -- but they should agree with the module gotten from the monad+        --+        -- We can get built-in syntax showing up here too, sadly.  If you type+        --      data T = (,,,)+        -- the constructor is parsed as a type, and then RdrHsSyn.tyConToDataCon+        -- uses setRdrNameSpace to make it into a data constructors.  At that point+        -- the nice Exact name for the TyCon gets swizzled to an Orig name.+        -- Hence the badOrigBinding error message.+        --+        -- Except for the ":Main.main = ..." definition inserted into+        -- the Main module; ugh!++        -- Because of this latter case, we call newGlobalBinder with a module from+        -- the RdrName, not from the environment.  In principle, it'd be fine to+        -- have an arbitrary mixture of external core definitions in a single module,+        -- (apart from module-initialisation issues, perhaps).+        ; newGlobalBinder rdr_mod rdr_occ loc }++  | otherwise+  = do  { when (isQual rdr_name)+                 (addErrAt loc (badQualBndrErr rdr_name))+                -- Binders should not be qualified; if they are, and with a different+                -- module name, we get a confusing "M.T is not in scope" error later++        ; stage <- getStage+        ; if isBrackStage stage then+                -- We are inside a TH bracket, so make an *Internal* name+                -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames+             do { uniq <- newUnique+                ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }+          else+             do { this_mod <- getModule+                ; traceRn "newTopSrcBinder" (ppr this_mod $$ ppr rdr_name $$ ppr loc)+                ; newGlobalBinder this_mod (rdrNameOcc rdr_name) loc }+        }++{-+*********************************************************+*                                                      *+        Source code occurrences+*                                                      *+*********************************************************++Looking up a name in the RnEnv.++Note [Type and class operator definitions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to reject all of these unless we have -XTypeOperators (#3265)+   data a :*: b  = ...+   class a :*: b where ...+   data (:*:) a b  = ....+   class (:*:) a b where ...+The latter two mean that we are not just looking for a+*syntactically-infix* declaration, but one that uses an operator+OccName.  We use OccName.isSymOcc to detect that case, which isn't+terribly efficient, but there seems to be no better way.+-}++-- Can be made to not be exposed+-- Only used unwrapped in rnAnnProvenance+lookupTopBndrRn :: RdrName -> RnM Name+lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n+                       case nopt of+                         Just n' -> return n'+                         Nothing -> do traceRn "lookupTopBndrRn fail" (ppr n)+                                       unboundName WL_LocalTop n++lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)+lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn++lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name)+-- Look up a top-level source-code binder.   We may be looking up an unqualified 'f',+-- and there may be several imported 'f's too, which must not confuse us.+-- For example, this is OK:+--      import Foo( f )+--      infix 9 f       -- The 'f' here does not need to be qualified+--      f x = x         -- Nor here, of course+-- So we have to filter out the non-local ones.+--+-- A separate function (importsFromLocalDecls) reports duplicate top level+-- decls, so here it's safe just to choose an arbitrary one.+--+-- There should never be a qualified name in a binding position in Haskell,+-- but there can be if we have read in an external-Core file.+-- The Haskell parser checks for the illegal qualified name in Haskell+-- source files, so we don't need to do so here.++lookupTopBndrRn_maybe rdr_name =+  lookupExactOrOrig rdr_name Just $+    do  {  -- Check for operators in type or class declarations+           -- See Note [Type and class operator definitions]+          let occ = rdrNameOcc rdr_name+        ; when (isTcOcc occ && isSymOcc occ)+               (do { op_ok <- xoptM LangExt.TypeOperators+                   ; unless op_ok (addErr (opDeclErr rdr_name)) })++        ; env <- getGlobalRdrEnv+        ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of+            [gre] -> return (Just (gre_name gre))+            _     -> return Nothing  -- Ambiguous (can't happen) or unbound+    }++-----------------------------------------------+-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].+-- This adds an error if the name cannot be found.+lookupExactOcc :: Name -> RnM Name+lookupExactOcc name+  = do { result <- lookupExactOcc_either name+       ; case result of+           Left err -> do { addErr err+                          ; return name }+           Right name' -> return name' }++-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].+-- This never adds an error, but it may return one.+lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name)+-- See Note [Looking up Exact RdrNames]+lookupExactOcc_either name+  | Just thing <- wiredInNameTyThing_maybe name+  , Just tycon <- case thing of+                    ATyCon tc                 -> Just tc+                    AConLike (RealDataCon dc) -> Just (dataConTyCon dc)+                    _                         -> Nothing+  , isTupleTyCon tycon+  = do { checkTupSize (tyConArity tycon)+       ; return (Right name) }++  | isExternalName name+  = return (Right name)++  | otherwise+  = do { env <- getGlobalRdrEnv+       ; let -- See Note [Splicing Exact names]+             main_occ =  nameOccName name+             demoted_occs = case demoteOccName main_occ of+                              Just occ -> [occ]+                              Nothing  -> []+             gres = [ gre | occ <- main_occ : demoted_occs+                          , gre <- lookupGlobalRdrEnv env occ+                          , gre_name gre == name ]+       ; case gres of+           [gre] -> return (Right (gre_name gre))++           []    -> -- See Note [Splicing Exact names]+                    do { lcl_env <- getLocalRdrEnv+                       ; if name `inLocalRdrEnvScope` lcl_env+                         then return (Right name)+                         else+                         do { th_topnames_var <- fmap tcg_th_topnames getGblEnv+                            ; th_topnames <- readTcRef th_topnames_var+                            ; if name `elemNameSet` th_topnames+                              then return (Right name)+                              else return (Left exact_nm_err)+                            }+                       }+           gres -> return (Left (sameNameErr gres))   -- Ugh!  See Note [Template Haskell ambiguity]+       }+  where+    exact_nm_err = hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))+                      2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), "+                              , text "perhaps via newName, but did not bind it"+                              , text "If that's it, then -ddump-splices might be useful" ])++sameNameErr :: [GlobalRdrElt] -> MsgDoc+sameNameErr [] = panic "addSameNameErr: empty list"+sameNameErr gres@(_ : _)+  = hang (text "Same exact name in multiple name-spaces:")+       2 (vcat (map pp_one sorted_names) $$ th_hint)+  where+    sorted_names = sortWith nameSrcLoc (map gre_name gres)+    pp_one name+      = hang (pprNameSpace (occNameSpace (getOccName name))+              <+> quotes (ppr name) <> comma)+           2 (text "declared at:" <+> ppr (nameSrcLoc name))++    th_hint = vcat [ text "Probable cause: you bound a unique Template Haskell name (NameU),"+                   , text "perhaps via newName, in different name-spaces."+                   , text "If that's it, then -ddump-splices might be useful" ]+++-----------------------------------------------+lookupInstDeclBndr :: Name -> SDoc -> RdrName -> RnM Name+-- This is called on the method name on the left-hand side of an+-- instance declaration binding. eg.  instance Functor T where+--                                       fmap = ...+--                                       ^^^^ called on this+-- Regardless of how many unqualified fmaps are in scope, we want+-- the one that comes from the Functor class.+--+-- Furthermore, note that we take no account of whether the+-- name is only in scope qualified.  I.e. even if method op is+-- in scope as M.op, we still allow plain 'op' on the LHS of+-- an instance decl+--+-- The "what" parameter says "method" or "associated type",+-- depending on what we are looking up+lookupInstDeclBndr cls what rdr+  = do { when (isQual rdr)+              (addErr (badQualBndrErr rdr))+                -- In an instance decl you aren't allowed+                -- to use a qualified name for the method+                -- (Although it'd make perfect sense.)+       ; mb_name <- lookupSubBndrOcc+                          False -- False => we don't give deprecated+                                -- warnings when a deprecated class+                                -- method is defined. We only warn+                                -- when it's used+                          cls doc rdr+       ; case mb_name of+           Left err -> do { addErr err; return (mkUnboundNameRdr rdr) }+           Right nm -> return nm }+  where+    doc = what <+> text "of class" <+> quotes (ppr cls)++-----------------------------------------------+lookupFamInstName :: Maybe Name -> Located RdrName+                  -> RnM (Located Name)+-- Used for TyData and TySynonym family instances only,+-- See Note [Family instance binders]+lookupFamInstName (Just cls) tc_rdr  -- Associated type; c.f RnBinds.rnMethodBind+  = wrapLocM (lookupInstDeclBndr cls (text "associated type")) tc_rdr+lookupFamInstName Nothing tc_rdr     -- Family instance; tc_rdr is an *occurrence*+  = lookupLocatedOccRn tc_rdr++-----------------------------------------------+lookupConstructorFields :: Name -> RnM [FieldLabel]+-- Look up the fields of a given constructor+--   *  For constructors from this module, use the record field env,+--      which is itself gathered from the (as yet un-typechecked)+--      data type decls+--+--    * For constructors from imported modules, use the *type* environment+--      since imported modles are already compiled, the info is conveniently+--      right there++lookupConstructorFields con_name+  = do  { this_mod <- getModule+        ; if nameIsLocalOrFrom this_mod con_name then+          do { field_env <- getRecFieldEnv+             ; traceTc "lookupCF" (ppr con_name $$ ppr (lookupNameEnv field_env con_name) $$ ppr field_env)+             ; return (lookupNameEnv field_env con_name `orElse` []) }+          else+          do { con <- tcLookupConLike con_name+             ; traceTc "lookupCF 2" (ppr con)+             ; return (conLikeFieldLabels con) } }+++-- In CPS style as `RnM r` is monadic+lookupExactOrOrig :: RdrName -> (Name -> r) -> RnM r -> RnM r+lookupExactOrOrig rdr_name res k+  | Just n <- isExact_maybe rdr_name   -- This happens in derived code+  = res <$> lookupExactOcc n+  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name+  = res <$> lookupOrig rdr_mod rdr_occ+  | otherwise = k++++-----------------------------------------------+-- | Look up an occurrence of a field in record construction or pattern+-- matching (but not update).  When the -XDisambiguateRecordFields+-- flag is on, take account of the data constructor name to+-- disambiguate which field to use.+--+-- See Note [DisambiguateRecordFields].+lookupRecFieldOcc :: Maybe Name -- Nothing  => just look it up as usual+                                -- Just con => use data con to disambiguate+                  -> RdrName+                  -> RnM Name+lookupRecFieldOcc mb_con rdr_name+  | Just con <- mb_con+  , isUnboundName con  -- Avoid error cascade+  = return (mkUnboundNameRdr rdr_name)+  | Just con <- mb_con+  = do { flds <- lookupConstructorFields con+       ; env <- getGlobalRdrEnv+       ; let lbl      = occNameFS (rdrNameOcc rdr_name)+             mb_field = do fl <- find ((== lbl) . flLabel) flds+                           -- We have the label, now check it is in+                           -- scope (with the correct qualifier if+                           -- there is one, hence calling pickGREs).+                           gre <- lookupGRE_FieldLabel env fl+                           guard (not (isQual rdr_name+                                         && null (pickGREs rdr_name [gre])))+                           return (fl, gre)+       ; case mb_field of+           Just (fl, gre) -> do { addUsedGRE True gre+                                ; return (flSelector fl) }+           Nothing        -> lookupGlobalOccRn rdr_name }+             -- See Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]+  | otherwise+  -- This use of Global is right as we are looking up a selector which+  -- can only be defined at the top level.+  = lookupGlobalOccRn rdr_name++{- Note [DisambiguateRecordFields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we are looking up record fields in record construction or pattern+matching, we can take advantage of the data constructor name to+resolve fields that would otherwise be ambiguous (provided the+-XDisambiguateRecordFields flag is on).++For example, consider:++   data S = MkS { x :: Int }+   data T = MkT { x :: Int }++   e = MkS { x = 3 }++When we are renaming the occurrence of `x` in `e`, instead of looking+`x` up directly (and finding both fields), lookupRecFieldOcc will+search the fields of `MkS` to find the only possible `x` the user can+mean.++Of course, we still have to check the field is in scope, using+lookupGRE_FieldLabel.  The handling of qualified imports is slightly+subtle: the occurrence may be unqualified even if the field is+imported only qualified (but if the occurrence is qualified, the+qualifier must be correct). For example:++   module A where+     data S = MkS { x :: Int }+     data T = MkT { x :: Int }++   module B where+     import qualified A (S(..))+     import A (T(MkT))++     e1 = MkT   { x = 3 }   -- x not in scope, so fail+     e2 = A.MkS { B.x = 3 } -- module qualifier is wrong, so fail+     e3 = A.MkS { x = 3 }   -- x in scope (lack of module qualifier permitted)++In case `e1`, lookupGRE_FieldLabel will return Nothing.  In case `e2`,+lookupGRE_FieldLabel will return the GRE for `A.x`, but then the guard+will fail because the field RdrName `B.x` is qualified and pickGREs+rejects the GRE.  In case `e3`, lookupGRE_FieldLabel will return the+GRE for `A.x` and the guard will succeed because the field RdrName `x`+is unqualified.+++Note [Fall back on lookupGlobalOccRn in lookupRecFieldOcc]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Whenever we fail to find the field or it is not in scope, mb_field+will be False, and we fall back on looking it up normally using+lookupGlobalOccRn.  We don't report an error immediately because the+actual problem might be located elsewhere.  For example (#9975):++   data Test = Test { x :: Int }+   pattern Test wat = Test { x = wat }++Here there are multiple declarations of Test (as a data constructor+and as a pattern synonym), which will be reported as an error.  We+shouldn't also report an error about the occurrence of `x` in the+pattern synonym RHS.  However, if the pattern synonym gets added to+the environment first, we will try and fail to find `x` amongst the+(nonexistent) fields of the pattern synonym.++Alternatively, the scope check can fail due to Template Haskell.+Consider (#12130):++   module Foo where+     import M+     b = $(funny)++   module M(funny) where+     data T = MkT { x :: Int }+     funny :: Q Exp+     funny = [| MkT { x = 3 } |]++When we splice, `MkT` is not lexically in scope, so+lookupGRE_FieldLabel will fail.  But there is no need for+disambiguation anyway, because `x` is an original name, and+lookupGlobalOccRn will find it.+-}++++-- | Used in export lists to lookup the children.+lookupSubBndrOcc_helper :: Bool -> Bool -> Name -> RdrName+                        -> RnM ChildLookupResult+lookupSubBndrOcc_helper must_have_parent warn_if_deprec parent rdr_name+  | isUnboundName parent+    -- Avoid an error cascade+  = return (FoundName NoParent (mkUnboundNameRdr rdr_name))++  | otherwise = do+  gre_env <- getGlobalRdrEnv++  let original_gres = lookupGlobalRdrEnv gre_env (rdrNameOcc rdr_name)+  -- Disambiguate the lookup based on the parent information.+  -- The remaining GREs are things that we *could* export here, note that+  -- this includes things which have `NoParent`. Those are sorted in+  -- `checkPatSynParent`.+  traceRn "parent" (ppr parent)+  traceRn "lookupExportChild original_gres:" (ppr original_gres)+  traceRn "lookupExportChild picked_gres:" (ppr $ picked_gres original_gres)+  case picked_gres original_gres of+    NoOccurrence ->+      noMatchingParentErr original_gres+    UniqueOccurrence g ->+      if must_have_parent then noMatchingParentErr original_gres+                          else checkFld g+    DisambiguatedOccurrence g ->+      checkFld g+    AmbiguousOccurrence gres ->+      mkNameClashErr gres+    where+        -- Convert into FieldLabel if necessary+        checkFld :: GlobalRdrElt -> RnM ChildLookupResult+        checkFld g@GRE{gre_name, gre_par} = do+          addUsedGRE warn_if_deprec g+          return $ case gre_par of+            FldParent _ mfs ->+              FoundFL  (fldParentToFieldLabel gre_name mfs)+            _ -> FoundName gre_par gre_name++        fldParentToFieldLabel :: Name -> Maybe FastString -> FieldLabel+        fldParentToFieldLabel name mfs =+          case mfs of+            Nothing ->+              let fs = occNameFS (nameOccName name)+              in FieldLabel fs False name+            Just fs -> FieldLabel fs True name++        -- Called when we find no matching GREs after disambiguation but+        -- there are three situations where this happens.+        -- 1. There were none to begin with.+        -- 2. None of the matching ones were the parent but+        --  a. They were from an overloaded record field so we can report+        --     a better error+        --  b. The original lookup was actually ambiguous.+        --     For example, the case where overloading is off and two+        --     record fields are in scope from different record+        --     constructors, neither of which is the parent.+        noMatchingParentErr :: [GlobalRdrElt] -> RnM ChildLookupResult+        noMatchingParentErr original_gres = do+          overload_ok <- xoptM LangExt.DuplicateRecordFields+          case original_gres of+            [] ->  return NameNotFound+            [g] -> return $ IncorrectParent parent+                              (gre_name g) (ppr $ gre_name g)+                              [p | Just p <- [getParent g]]+            gss@(g:_:_) ->+              if all isRecFldGRE gss && overload_ok+                then return $+                      IncorrectParent parent+                        (gre_name g)+                        (ppr $ expectJust "noMatchingParentErr" (greLabel g))+                        [p | x <- gss, Just p <- [getParent x]]+                else mkNameClashErr gss++        mkNameClashErr :: [GlobalRdrElt] -> RnM ChildLookupResult+        mkNameClashErr gres = do+          addNameClashErrRn rdr_name gres+          return (FoundName (gre_par (head gres)) (gre_name (head gres)))++        getParent :: GlobalRdrElt -> Maybe Name+        getParent (GRE { gre_par = p } ) =+          case p of+            ParentIs cur_parent -> Just cur_parent+            FldParent { par_is = cur_parent } -> Just cur_parent+            NoParent -> Nothing++        picked_gres :: [GlobalRdrElt] -> DisambigInfo+        -- For Unqual, find GREs that are in scope qualified or unqualified+        -- For Qual,   find GREs that are in scope with that qualification+        picked_gres gres+          | isUnqual rdr_name+          = mconcat (map right_parent gres)+          | otherwise+          = mconcat (map right_parent (pickGREs rdr_name gres))++        right_parent :: GlobalRdrElt -> DisambigInfo+        right_parent p+          = case getParent p of+               Just cur_parent+                  | parent == cur_parent -> DisambiguatedOccurrence p+                  | otherwise            -> NoOccurrence+               Nothing                   -> UniqueOccurrence p+++-- This domain specific datatype is used to record why we decided it was+-- possible that a GRE could be exported with a parent.+data DisambigInfo+       = NoOccurrence+          -- The GRE could never be exported. It has the wrong parent.+       | UniqueOccurrence GlobalRdrElt+          -- The GRE has no parent. It could be a pattern synonym.+       | DisambiguatedOccurrence GlobalRdrElt+          -- The parent of the GRE is the correct parent+       | AmbiguousOccurrence [GlobalRdrElt]+          -- For example, two normal identifiers with the same name are in+          -- scope. They will both be resolved to "UniqueOccurrence" and the+          -- monoid will combine them to this failing case.++instance Outputable DisambigInfo where+  ppr NoOccurrence = text "NoOccurence"+  ppr (UniqueOccurrence gre) = text "UniqueOccurrence:" <+> ppr gre+  ppr (DisambiguatedOccurrence gre) = text "DiambiguatedOccurrence:" <+> ppr gre+  ppr (AmbiguousOccurrence gres)    = text "Ambiguous:" <+> ppr gres++instance Semi.Semigroup DisambigInfo where+  -- This is the key line: We prefer disambiguated occurrences to other+  -- names.+  _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g'+  DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g'++  NoOccurrence <> m = m+  m <> NoOccurrence = m+  UniqueOccurrence g <> UniqueOccurrence g'+    = AmbiguousOccurrence [g, g']+  UniqueOccurrence g <> AmbiguousOccurrence gs+    = AmbiguousOccurrence (g:gs)+  AmbiguousOccurrence gs <> UniqueOccurrence g'+    = AmbiguousOccurrence (g':gs)+  AmbiguousOccurrence gs <> AmbiguousOccurrence gs'+    = AmbiguousOccurrence (gs ++ gs')++instance Monoid DisambigInfo where+  mempty = NoOccurrence+  mappend = (Semi.<>)++-- Lookup SubBndrOcc can never be ambiguous+--+-- Records the result of looking up a child.+data ChildLookupResult+      = NameNotFound                --  We couldn't find a suitable name+      | IncorrectParent Name        -- Parent+                        Name        -- Name of thing we were looking for+                        SDoc        -- How to print the name+                        [Name]      -- List of possible parents+      | FoundName Parent Name       --  We resolved to a normal name+      | FoundFL FieldLabel          --  We resolved to a FL++-- | Specialised version of msum for RnM ChildLookupResult+combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult+combineChildLookupResult [] = return NameNotFound+combineChildLookupResult (x:xs) = do+  res <- x+  case res of+    NameNotFound -> combineChildLookupResult xs+    _ -> return res++instance Outputable ChildLookupResult where+  ppr NameNotFound = text "NameNotFound"+  ppr (FoundName p n) = text "Found:" <+> ppr p <+> ppr n+  ppr (FoundFL fls) = text "FoundFL:" <+> ppr fls+  ppr (IncorrectParent p n td ns) = text "IncorrectParent"+                                  <+> hsep [ppr p, ppr n, td, ppr ns]++lookupSubBndrOcc :: Bool+                 -> Name     -- Parent+                 -> SDoc+                 -> RdrName+                 -> RnM (Either MsgDoc Name)+-- Find all the things the rdr-name maps to+-- and pick the one with the right parent namep+lookupSubBndrOcc warn_if_deprec the_parent doc rdr_name = do+  res <-+    lookupExactOrOrig rdr_name (FoundName NoParent) $+      -- This happens for built-in classes, see mod052 for example+      lookupSubBndrOcc_helper True warn_if_deprec the_parent rdr_name+  case res of+    NameNotFound -> return (Left (unknownSubordinateErr doc rdr_name))+    FoundName _p n -> return (Right n)+    FoundFL fl  ->  return (Right (flSelector fl))+    IncorrectParent {}+         -- See [Mismatched class methods and associated type families]+         -- in TcInstDecls.+      -> return $ Left (unknownSubordinateErr doc rdr_name)++{-+Note [Family instance binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data family F a+  data instance F T = X1 | X2++The 'data instance' decl has an *occurrence* of F (and T), and *binds*+X1 and X2.  (This is unlike a normal data type declaration which would+bind F too.)  So we want an AvailTC F [X1,X2].++Now consider a similar pair:+  class C a where+    data G a+  instance C S where+    data G S = Y1 | Y2++The 'data G S' *binds* Y1 and Y2, and has an *occurrence* of G.++But there is a small complication: in an instance decl, we don't use+qualified names on the LHS; instead we use the class to disambiguate.+Thus:+  module M where+    import Blib( G )+    class C a where+      data G a+    instance C S where+      data G S = Y1 | Y2+Even though there are two G's in scope (M.G and Blib.G), the occurrence+of 'G' in the 'instance C S' decl is unambiguous, because C has only+one associated type called G. This is exactly what happens for methods,+and it is only consistent to do the same thing for types. That's the+role of the function lookupTcdName; the (Maybe Name) give the class of+the encloseing instance decl, if any.++Note [Looking up Exact RdrNames]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Exact RdrNames are generated by Template Haskell.  See Note [Binders+in Template Haskell] in Convert.++For data types and classes have Exact system Names in the binding+positions for constructors, TyCons etc.  For example+    [d| data T = MkT Int |]+when we splice in and Convert to HsSyn RdrName, we'll get+    data (Exact (system Name "T")) = (Exact (system Name "MkT")) ...+These System names are generated by Convert.thRdrName++But, constructors and the like need External Names, not System Names!+So we do the following++ * In RnEnv.newTopSrcBinder we spot Exact RdrNames that wrap a+   non-External Name, and make an External name for it. This is+   the name that goes in the GlobalRdrEnv++ * When looking up an occurrence of an Exact name, done in+   RnEnv.lookupExactOcc, we find the Name with the right unique in the+   GlobalRdrEnv, and use the one from the envt -- it will be an+   External Name in the case of the data type/constructor above.++ * Exact names are also use for purely local binders generated+   by TH, such as    \x_33. x_33+   Both binder and occurrence are Exact RdrNames.  The occurrence+   gets looked up in the LocalRdrEnv by RnEnv.lookupOccRn, and+   misses, because lookupLocalRdrEnv always returns Nothing for+   an Exact Name.  Now we fall through to lookupExactOcc, which+   will find the Name is not in the GlobalRdrEnv, so we just use+   the Exact supplied Name.++Note [Splicing Exact names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the splice $(do { x <- newName "x"; return (VarE x) })+This will generate a (HsExpr RdrName) term that mentions the+Exact RdrName "x_56" (or whatever), but does not bind it.  So+when looking such Exact names we want to check that it's in scope,+otherwise the type checker will get confused.  To do this we need to+keep track of all the Names in scope, and the LocalRdrEnv does just that;+we consult it with RdrName.inLocalRdrEnvScope.++There is another wrinkle.  With TH and -XDataKinds, consider+   $( [d| data Nat = Zero+          data T = MkT (Proxy 'Zero)  |] )+After splicing, but before renaming we get this:+   data Nat_77{tc} = Zero_78{d}+   data T_79{tc} = MkT_80{d} (Proxy 'Zero_78{tc})  |] )+The occurrence of 'Zero in the data type for T has the right unique,+but it has a TcClsName name-space in its OccName.  (This is set by+the ctxt_ns argument of Convert.thRdrName.)  When we check that is+in scope in the GlobalRdrEnv, we need to look up the DataName namespace+too.  (An alternative would be to make the GlobalRdrEnv also have+a Name -> GRE mapping.)++Note [Template Haskell ambiguity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The GlobalRdrEnv invariant says that if+  occ -> [gre1, ..., gren]+then the gres have distinct Names (INVARIANT 1 of GlobalRdrEnv).+This is guaranteed by extendGlobalRdrEnvRn (the dups check in add_gre).++So how can we get multiple gres in lookupExactOcc_maybe?  Because in+TH we might use the same TH NameU in two different name spaces.+eg (#7241):+   $(newName "Foo" >>= \o -> return [DataD [] o [] [RecC o []] [''Show]])+Here we generate a type constructor and data constructor with the same+unique, but different name spaces.++It'd be nicer to rule this out in extendGlobalRdrEnvRn, but that would+mean looking up the OccName in every name-space, just in case, and that+seems a bit brutal.  So it's just done here on lookup.  But we might+need to revisit that choice.++Note [Usage for sub-bndrs]+~~~~~~~~~~~~~~~~~~~~~~~~~~+If you have this+   import qualified M( C( f ) )+   instance M.C T where+     f x = x+then is the qualified import M.f used?  Obviously yes.+But the RdrName used in the instance decl is unqualified.  In effect,+we fill in the qualification by looking for f's whose class is M.C+But when adding to the UsedRdrNames we must make that qualification+explicit (saying "used  M.f"), otherwise we get "Redundant import of M.f".++So we make up a suitable (fake) RdrName.  But be careful+   import qualified M+   import M( C(f) )+   instance C T where+     f x = x+Here we want to record a use of 'f', not of 'M.f', otherwise+we'll miss the fact that the qualified import is redundant.++--------------------------------------------------+--              Occurrences+--------------------------------------------------+-}+++lookupLocatedOccRn :: Located RdrName -> RnM (Located Name)+lookupLocatedOccRn = wrapLocM lookupOccRn++lookupLocalOccRn_maybe :: RdrName -> RnM (Maybe Name)+-- Just look in the local environment+lookupLocalOccRn_maybe rdr_name+  = do { local_env <- getLocalRdrEnv+       ; return (lookupLocalRdrEnv local_env rdr_name) }++lookupLocalOccThLvl_maybe :: Name -> RnM (Maybe (TopLevelFlag, ThLevel))+-- Just look in the local environment+lookupLocalOccThLvl_maybe name+  = do { lcl_env <- getLclEnv+       ; return (lookupNameEnv (tcl_th_bndrs lcl_env) name) }++-- lookupOccRn looks up an occurrence of a RdrName+lookupOccRn :: RdrName -> RnM Name+lookupOccRn rdr_name+  = do { mb_name <- lookupOccRn_maybe rdr_name+       ; case mb_name of+           Just name -> return name+           Nothing   -> reportUnboundName rdr_name }++-- Only used in one place, to rename pattern synonym binders.+-- See Note [Renaming pattern synonym variables] in RnBinds+lookupLocalOccRn :: RdrName -> RnM Name+lookupLocalOccRn rdr_name+  = do { mb_name <- lookupLocalOccRn_maybe rdr_name+       ; case mb_name of+           Just name -> return name+           Nothing   -> unboundName WL_LocalOnly rdr_name }++-- lookupPromotedOccRn looks up an optionally promoted RdrName.+lookupTypeOccRn :: RdrName -> RnM Name+-- see Note [Demotion]+lookupTypeOccRn rdr_name+  | isVarOcc (rdrNameOcc rdr_name)  -- See Note [Promoted variables in types]+  = badVarInType rdr_name+  | otherwise+  = do { mb_name <- lookupOccRn_maybe rdr_name+       ; case mb_name of+             Just name -> return name+             Nothing   -> lookup_demoted rdr_name }++lookup_demoted :: RdrName -> RnM Name+lookup_demoted rdr_name+  | Just demoted_rdr <- demoteRdrName rdr_name+    -- Maybe it's the name of a *data* constructor+  = do { data_kinds <- xoptM LangExt.DataKinds+       ; star_is_type <- xoptM LangExt.StarIsType+       ; let star_info = starInfo star_is_type rdr_name+       ; if data_kinds+            then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr+                    ; case mb_demoted_name of+                        Nothing -> unboundNameX WL_Any rdr_name star_info+                        Just demoted_name ->+                          do { whenWOptM Opt_WarnUntickedPromotedConstructors $+                               addWarn+                                 (Reason Opt_WarnUntickedPromotedConstructors)+                                 (untickedPromConstrWarn demoted_name)+                             ; return demoted_name } }+            else do { -- We need to check if a data constructor of this name is+                      -- in scope to give good error messages. However, we do+                      -- not want to give an additional error if the data+                      -- constructor happens to be out of scope! See #13947.+                      mb_demoted_name <- discardErrs $+                                         lookupOccRn_maybe demoted_rdr+                    ; let suggestion | isJust mb_demoted_name = suggest_dk+                                     | otherwise = star_info+                    ; unboundNameX WL_Any rdr_name suggestion } }++  | otherwise+  = reportUnboundName rdr_name++  where+    suggest_dk = text "A data constructor of that name is in scope; did you mean DataKinds?"+    untickedPromConstrWarn name =+      text "Unticked promoted constructor" <> colon <+> quotes (ppr name) <> dot+      $$+      hsep [ text "Use"+           , quotes (char '\'' <> ppr name)+           , text "instead of"+           , quotes (ppr name) <> dot ]++badVarInType :: RdrName -> RnM Name+badVarInType rdr_name+  = do { addErr (text "Illegal promoted term variable in a type:"+                 <+> ppr rdr_name)+       ; return (mkUnboundNameRdr rdr_name) }++{- Note [Promoted variables in types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#12686):+   x = True+   data Bad = Bad 'x++The parser treats the quote in 'x as saying "use the term+namespace", so we'll get (Bad x{v}), with 'x' in the+VarName namespace.  If we don't test for this, the renamer+will happily rename it to the x bound at top level, and then+the typecheck falls over because it doesn't have 'x' in scope+when kind-checking.++Note [Demotion]+~~~~~~~~~~~~~~~+When the user writes:+  data Nat = Zero | Succ Nat+  foo :: f Zero -> Int++'Zero' in the type signature of 'foo' is parsed as:+  HsTyVar ("Zero", TcClsName)++When the renamer hits this occurrence of 'Zero' it's going to realise+that it's not in scope. But because it is renaming a type, it knows+that 'Zero' might be a promoted data constructor, so it will demote+its namespace to DataName and do a second lookup.++The final result (after the renamer) will be:+  HsTyVar ("Zero", DataName)+-}++lookupOccRnX_maybe :: (RdrName -> RnM (Maybe r)) -> (Name -> r) -> RdrName+                   -> RnM (Maybe r)+lookupOccRnX_maybe globalLookup wrapper rdr_name+  = runMaybeT . msum . map MaybeT $+      [ fmap wrapper <$> lookupLocalOccRn_maybe rdr_name+      , globalLookup rdr_name ]++lookupOccRn_maybe :: RdrName -> RnM (Maybe Name)+lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id++lookupOccRn_overloaded :: Bool -> RdrName+                       -> RnM (Maybe (Either Name [Name]))+lookupOccRn_overloaded overload_ok+  = lookupOccRnX_maybe global_lookup Left+      where+        global_lookup :: RdrName -> RnM (Maybe (Either Name [Name]))+        global_lookup n =+          runMaybeT . msum . map MaybeT $+            [ lookupGlobalOccRn_overloaded overload_ok n+            , fmap Left . listToMaybe <$> lookupQualifiedNameGHCi n ]++++lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name)+-- Looks up a RdrName occurrence in the top-level+--   environment, including using lookupQualifiedNameGHCi+--   for the GHCi case+-- No filter function; does not report an error on failure+-- Uses addUsedRdrName to record use and deprecations+lookupGlobalOccRn_maybe rdr_name =+  lookupExactOrOrig rdr_name Just $+    runMaybeT . msum . map MaybeT $+      [ fmap gre_name <$> lookupGreRn_maybe rdr_name+      , listToMaybe <$> lookupQualifiedNameGHCi rdr_name ]+                      -- This test is not expensive,+                      -- and only happens for failed lookups++lookupGlobalOccRn :: RdrName -> RnM Name+-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global+-- environment.  Adds an error message if the RdrName is not in scope.+-- You usually want to use "lookupOccRn" which also looks in the local+-- environment.+lookupGlobalOccRn rdr_name+  = do { mb_name <- lookupGlobalOccRn_maybe rdr_name+       ; case mb_name of+           Just n  -> return n+           Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)+                         ; unboundName WL_Global rdr_name } }++lookupInfoOccRn :: RdrName -> RnM [Name]+-- lookupInfoOccRn is intended for use in GHCi's ":info" command+-- It finds all the GREs that RdrName could mean, not complaining+-- about ambiguity, but rather returning them all+-- C.f. #9881+lookupInfoOccRn rdr_name =+  lookupExactOrOrig rdr_name (:[]) $+    do { rdr_env <- getGlobalRdrEnv+       ; let ns = map gre_name (lookupGRE_RdrName rdr_name rdr_env)+       ; qual_ns <- lookupQualifiedNameGHCi rdr_name+       ; return (ns ++ (qual_ns `minusList` ns)) }++-- | Like 'lookupOccRn_maybe', but with a more informative result if+-- the 'RdrName' happens to be a record selector:+--+--   * Nothing         -> name not in scope (no error reported)+--   * Just (Left x)   -> name uniquely refers to x,+--                        or there is a name clash (reported)+--   * Just (Right xs) -> name refers to one or more record selectors;+--                        if overload_ok was False, this list will be+--                        a singleton.++lookupGlobalOccRn_overloaded :: Bool -> RdrName+                             -> RnM (Maybe (Either Name [Name]))+lookupGlobalOccRn_overloaded overload_ok rdr_name =+  lookupExactOrOrig rdr_name (Just . Left) $+     do  { res <- lookupGreRn_helper rdr_name+         ; case res of+                GreNotFound  -> return Nothing+                OneNameMatch gre -> do+                  let wrapper = if isRecFldGRE gre then Right . (:[]) else Left+                  return $ Just (wrapper (gre_name gre))+                MultipleNames gres  | all isRecFldGRE gres && overload_ok ->+                  -- Don't record usage for ambiguous selectors+                  -- until we know which is meant+                  return $ Just (Right (map gre_name gres))+                MultipleNames gres  -> do+                  addNameClashErrRn rdr_name gres+                  return (Just (Left (gre_name (head gres)))) }+++--------------------------------------------------+--      Lookup in the Global RdrEnv of the module+--------------------------------------------------++data GreLookupResult = GreNotFound+                     | OneNameMatch GlobalRdrElt+                     | MultipleNames [GlobalRdrElt]++lookupGreRn_maybe :: RdrName -> RnM (Maybe GlobalRdrElt)+-- Look up the RdrName in the GlobalRdrEnv+--   Exactly one binding: records it as "used", return (Just gre)+--   No bindings:         return Nothing+--   Many bindings:       report "ambiguous", return an arbitrary (Just gre)+-- Uses addUsedRdrName to record use and deprecations+lookupGreRn_maybe rdr_name+  = do+      res <- lookupGreRn_helper rdr_name+      case res of+        OneNameMatch gre ->  return $ Just gre+        MultipleNames gres -> do+          traceRn "lookupGreRn_maybe:NameClash" (ppr gres)+          addNameClashErrRn rdr_name gres+          return $ Just (head gres)+        GreNotFound -> return Nothing++{-++Note [ Unbound vs Ambiguous Names ]++lookupGreRn_maybe deals with failures in two different ways. If a name+is unbound then we return a `Nothing` but if the name is ambiguous+then we raise an error and return a dummy name.++The reason for this is that when we call `lookupGreRn_maybe` we are+speculatively looking for whatever we are looking up. If we don't find it,+then we might have been looking for the wrong thing and can keep trying.+On the other hand, if we find a clash then there is no way to recover as+we found the thing we were looking for but can no longer resolve which+the correct one is.++One example of this is in `lookupTypeOccRn` which first looks in the type+constructor namespace before looking in the data constructor namespace to+deal with `DataKinds`.++There is however, as always, one exception to this scheme. If we find+an ambiguous occurence of a record selector and DuplicateRecordFields+is enabled then we defer the selection until the typechecker.++-}+++++-- Internal Function+lookupGreRn_helper :: RdrName -> RnM GreLookupResult+lookupGreRn_helper rdr_name+  = do  { env <- getGlobalRdrEnv+        ; case lookupGRE_RdrName rdr_name env of+            []    -> return GreNotFound+            [gre] -> do { addUsedGRE True gre+                        ; return (OneNameMatch gre) }+            gres  -> return (MultipleNames gres) }++lookupGreAvailRn :: RdrName -> RnM (Name, AvailInfo)+-- Used in export lists+-- If not found or ambiguous, add error message, and fake with UnboundName+-- Uses addUsedRdrName to record use and deprecations+lookupGreAvailRn rdr_name+  = do+      mb_gre <- lookupGreRn_helper rdr_name+      case mb_gre of+        GreNotFound ->+          do+            traceRn "lookupGreAvailRn" (ppr rdr_name)+            name <- unboundName WL_Global rdr_name+            return (name, avail name)+        MultipleNames gres ->+          do+            addNameClashErrRn rdr_name gres+            let unbound_name = mkUnboundNameRdr rdr_name+            return (unbound_name, avail unbound_name)+                        -- Returning an unbound name here prevents an error+                        -- cascade+        OneNameMatch gre ->+          return (gre_name gre, availFromGRE gre)+++{-+*********************************************************+*                                                      *+                Deprecations+*                                                      *+*********************************************************++Note [Handling of deprecations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* We report deprecations at each *occurrence* of the deprecated thing+  (see #5867)++* We do not report deprecations for locally-defined names. For a+  start, we may be exporting a deprecated thing. Also we may use a+  deprecated thing in the defn of another deprecated things.  We may+  even use a deprecated thing in the defn of a non-deprecated thing,+  when changing a module's interface.++* addUsedGREs: we do not report deprecations for sub-binders:+     - the ".." completion for records+     - the ".." in an export item 'T(..)'+     - the things exported by a module export 'module M'+-}++addUsedDataCons :: GlobalRdrEnv -> TyCon -> RnM ()+-- Remember use of in-scope data constructors (#7969)+addUsedDataCons rdr_env tycon+  = addUsedGREs [ gre+                | dc <- tyConDataCons tycon+                , Just gre <- [lookupGRE_Name rdr_env (dataConName dc)] ]++addUsedGRE :: Bool -> GlobalRdrElt -> RnM ()+-- Called for both local and imported things+-- Add usage *and* warn if deprecated+addUsedGRE warn_if_deprec gre+  = do { when warn_if_deprec (warnIfDeprecated gre)+       ; unless (isLocalGRE gre) $+         do { env <- getGblEnv+            ; traceRn "addUsedGRE" (ppr gre)+            ; updMutVar (tcg_used_gres env) (gre :) } }++addUsedGREs :: [GlobalRdrElt] -> RnM ()+-- Record uses of any *imported* GREs+-- Used for recording used sub-bndrs+-- NB: no call to warnIfDeprecated; see Note [Handling of deprecations]+addUsedGREs gres+  | null imp_gres = return ()+  | otherwise     = do { env <- getGblEnv+                       ; traceRn "addUsedGREs" (ppr imp_gres)+                       ; updMutVar (tcg_used_gres env) (imp_gres ++) }+  where+    imp_gres = filterOut isLocalGRE gres++warnIfDeprecated :: GlobalRdrElt -> RnM ()+warnIfDeprecated gre@(GRE { gre_name = name, gre_imp = iss })+  | (imp_spec : _) <- iss+  = do { dflags <- getDynFlags+       ; this_mod <- getModule+       ; when (wopt Opt_WarnWarningsDeprecations dflags &&+               not (nameIsLocalOrFrom this_mod name)) $+                   -- See Note [Handling of deprecations]+         do { iface <- loadInterfaceForName doc name+            ; case lookupImpDeprec iface gre of+                Just txt -> addWarn (Reason Opt_WarnWarningsDeprecations)+                                   (mk_msg imp_spec txt)+                Nothing  -> return () } }+  | otherwise+  = return ()+  where+    occ = greOccName gre+    name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name+    doc = text "The name" <+> quotes (ppr occ) <+> ptext (sLit "is mentioned explicitly")++    mk_msg imp_spec txt+      = sep [ sep [ text "In the use of"+                    <+> pprNonVarNameSpace (occNameSpace occ)+                    <+> quotes (ppr occ)+                  , parens imp_msg <> colon ]+            , pprWarningTxtForMsg txt ]+      where+        imp_mod  = importSpecModule imp_spec+        imp_msg  = text "imported from" <+> ppr imp_mod <> extra+        extra | imp_mod == moduleName name_mod = Outputable.empty+              | otherwise = text ", but defined in" <+> ppr name_mod++lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt+lookupImpDeprec iface gre+  = mi_warn_fn iface (greOccName gre) `mplus`  -- Bleat if the thing,+    case gre_par gre of                      -- or its parent, is warn'd+       ParentIs  p              -> mi_warn_fn iface (nameOccName p)+       FldParent { par_is = p } -> mi_warn_fn iface (nameOccName p)+       NoParent                 -> Nothing++{-+Note [Used names with interface not loaded]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's (just) possible to find a used+Name whose interface hasn't been loaded:++a) It might be a WiredInName; in that case we may not load+   its interface (although we could).++b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger+   These are seen as "used" by the renamer (if -XRebindableSyntax)+   is on), but the typechecker may discard their uses+   if in fact the in-scope fromRational is GHC.Read.fromRational,+   (see tcPat.tcOverloadedLit), and the typechecker sees that the type+   is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst).+   In that obscure case it won't force the interface in.++In both cases we simply don't permit deprecations;+this is, after all, wired-in stuff.+++*********************************************************+*                                                      *+                GHCi support+*                                                      *+*********************************************************++A qualified name on the command line can refer to any module at+all: we try to load the interface if we don't already have it, just+as if there was an "import qualified M" declaration for every+module.++For example, writing `Data.List.sort` will load the interface file for+`Data.List` as if the user had written `import qualified Data.List`.++If we fail we just return Nothing, rather than bleating+about "attempting to use module ‘D’ (./D.hs) which is not loaded"+which is what loadSrcInterface does.++It is enabled by default and disabled by the flag+`-fno-implicit-import-qualified`.++Note [Safe Haskell and GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We DON'T do this Safe Haskell as we need to check imports. We can+and should instead check the qualified import but at the moment+this requires some refactoring so leave as a TODO+-}++++lookupQualifiedNameGHCi :: RdrName -> RnM [Name]+lookupQualifiedNameGHCi rdr_name+  = -- We want to behave as we would for a source file import here,+    -- and respect hiddenness of modules/packages, hence loadSrcInterface.+    do { dflags  <- getDynFlags+       ; is_ghci <- getIsGHCi+       ; go_for_it dflags is_ghci }++  where+    go_for_it dflags is_ghci+      | Just (mod,occ) <- isQual_maybe rdr_name+      , is_ghci+      , gopt Opt_ImplicitImportQualified dflags   -- Enables this GHCi behaviour+      , not (safeDirectImpsReq dflags)            -- See Note [Safe Haskell and GHCi]+      = do { res <- loadSrcInterface_maybe doc mod False Nothing+           ; case res of+                Succeeded iface+                  -> return [ name+                            | avail <- mi_exports iface+                            , name  <- availNames avail+                            , nameOccName name == occ ]++                _ -> -- Either we couldn't load the interface, or+                     -- we could but we didn't find the name in it+                     do { traceRn "lookupQualifiedNameGHCi" (ppr rdr_name)+                        ; return [] } }++      | otherwise+      = do { traceRn "lookupQualifiedNameGHCi: off" (ppr rdr_name)+           ; return [] }++    doc = text "Need to find" <+> ppr rdr_name++{-+Note [Looking up signature names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+lookupSigOccRn is used for type signatures and pragmas+Is this valid?+  module A+        import M( f )+        f :: Int -> Int+        f x = x+It's clear that the 'f' in the signature must refer to A.f+The Haskell98 report does not stipulate this, but it will!+So we must treat the 'f' in the signature in the same way+as the binding occurrence of 'f', using lookupBndrRn++However, consider this case:+        import M( f )+        f :: Int -> Int+        g x = x+We don't want to say 'f' is out of scope; instead, we want to+return the imported 'f', so that later on the renamer will+correctly report "misplaced type sig".++Note [Signatures for top level things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+data HsSigCtxt = ... | TopSigCtxt NameSet | ....++* The NameSet says what is bound in this group of bindings.+  We can't use isLocalGRE from the GlobalRdrEnv, because of this:+       f x = x+       $( ...some TH splice... )+       f :: Int -> Int+  When we encounter the signature for 'f', the binding for 'f'+  will be in the GlobalRdrEnv, and will be a LocalDef. Yet the+  signature is mis-placed++* For type signatures the NameSet should be the names bound by the+  value bindings; for fixity declarations, the NameSet should also+  include class sigs and record selectors++      infix 3 `f`          -- Yes, ok+      f :: C a => a -> a   -- No, not ok+      class C a where+        f :: a -> a+-}++data HsSigCtxt+  = TopSigCtxt NameSet       -- At top level, binding these names+                             -- See Note [Signatures for top level things]+  | LocalBindCtxt NameSet    -- In a local binding, binding these names+  | ClsDeclCtxt   Name       -- Class decl for this class+  | InstDeclCtxt  NameSet    -- Instance decl whose user-written method+                             -- bindings are for these methods+  | HsBootCtxt NameSet       -- Top level of a hs-boot file, binding these names+  | RoleAnnotCtxt NameSet    -- A role annotation, with the names of all types+                             -- in the group++instance Outputable HsSigCtxt where+    ppr (TopSigCtxt ns) = text "TopSigCtxt" <+> ppr ns+    ppr (LocalBindCtxt ns) = text "LocalBindCtxt" <+> ppr ns+    ppr (ClsDeclCtxt n) = text "ClsDeclCtxt" <+> ppr n+    ppr (InstDeclCtxt ns) = text "InstDeclCtxt" <+> ppr ns+    ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns+    ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns++lookupSigOccRn :: HsSigCtxt+               -> Sig GhcPs+               -> Located RdrName -> RnM (Located Name)+lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig)++-- | Lookup a name in relation to the names in a 'HsSigCtxt'+lookupSigCtxtOccRn :: HsSigCtxt+                   -> SDoc         -- ^ description of thing we're looking up,+                                   -- like "type family"+                   -> Located RdrName -> RnM (Located Name)+lookupSigCtxtOccRn ctxt what+  = wrapLocM $ \ rdr_name ->+    do { mb_name <- lookupBindGroupOcc ctxt what rdr_name+       ; case mb_name of+           Left err   -> do { addErr err; return (mkUnboundNameRdr rdr_name) }+           Right name -> return name }++lookupBindGroupOcc :: HsSigCtxt+                   -> SDoc+                   -> RdrName -> RnM (Either MsgDoc Name)+-- Looks up the RdrName, expecting it to resolve to one of the+-- bound names passed in.  If not, return an appropriate error message+--+-- See Note [Looking up signature names]+lookupBindGroupOcc ctxt what rdr_name+  | Just n <- isExact_maybe rdr_name+  = lookupExactOcc_either n   -- allow for the possibility of missing Exacts;+                              -- see Note [dataTcOccs and Exact Names]+      -- Maybe we should check the side conditions+      -- but it's a pain, and Exact things only show+      -- up when you know what you are doing++  | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name+  = do { n' <- lookupOrig rdr_mod rdr_occ+       ; return (Right n') }++  | otherwise+  = case ctxt of+      HsBootCtxt ns    -> lookup_top (`elemNameSet` ns)+      TopSigCtxt ns    -> lookup_top (`elemNameSet` ns)+      RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns)+      LocalBindCtxt ns -> lookup_group ns+      ClsDeclCtxt  cls -> lookup_cls_op cls+      InstDeclCtxt ns  -> lookup_top (`elemNameSet` ns)+  where+    lookup_cls_op cls+      = lookupSubBndrOcc True cls doc rdr_name+      where+        doc = text "method of class" <+> quotes (ppr cls)++    lookup_top keep_me+      = do { env <- getGlobalRdrEnv+           ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)+           ; let candidates_msg = candidates $ map gre_name+                                             $ filter isLocalGRE+                                             $ globalRdrEnvElts env+           ; case filter (keep_me . gre_name) all_gres of+               [] | null all_gres -> bale_out_with candidates_msg+                  | otherwise     -> bale_out_with local_msg+               (gre:_)            -> return (Right (gre_name gre)) }++    lookup_group bound_names  -- Look in the local envt (not top level)+      = do { mname <- lookupLocalOccRn_maybe rdr_name+           ; env <- getLocalRdrEnv+           ; let candidates_msg = candidates $ localRdrEnvElts env+           ; case mname of+               Just n+                 | n `elemNameSet` bound_names -> return (Right n)+                 | otherwise                   -> bale_out_with local_msg+               Nothing                         -> bale_out_with candidates_msg }++    bale_out_with msg+        = return (Left (sep [ text "The" <+> what+                                <+> text "for" <+> quotes (ppr rdr_name)+                           , nest 2 $ text "lacks an accompanying binding"]+                       $$ nest 2 msg))++    local_msg = parens $ text "The"  <+> what <+> ptext (sLit "must be given where")+                           <+> quotes (ppr rdr_name) <+> text "is declared"++    -- Identify all similar names and produce a message listing them+    candidates :: [Name] -> MsgDoc+    candidates names_in_scope+      = case similar_names of+          []  -> Outputable.empty+          [n] -> text "Perhaps you meant" <+> pp_item n+          _   -> sep [ text "Perhaps you meant one of these:"+                     , nest 2 (pprWithCommas pp_item similar_names) ]+      where+        similar_names+          = fuzzyLookup (unpackFS $ occNameFS $ rdrNameOcc rdr_name)+                        $ map (\x -> ((unpackFS $ occNameFS $ nameOccName x), x))+                              names_in_scope++        pp_item x = quotes (ppr x) <+> parens (pprDefinedAt x)+++---------------+lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [(RdrName, Name)]+-- GHC extension: look up both the tycon and data con or variable.+-- Used for top-level fixity signatures and deprecations.+-- Complain if neither is in scope.+-- See Note [Fixity signature lookup]+lookupLocalTcNames ctxt what rdr_name+  = do { mb_gres <- mapM lookup (dataTcOccs rdr_name)+       ; let (errs, names) = partitionEithers mb_gres+       ; when (null names) $ addErr (head errs) -- Bleat about one only+       ; return names }+  where+    lookup rdr = do { this_mod <- getModule+                    ; nameEither <- lookupBindGroupOcc ctxt what rdr+                    ; return (guard_builtin_syntax this_mod rdr nameEither) }++    -- Guard against the built-in syntax (ex: `infixl 6 :`), see #15233+    guard_builtin_syntax this_mod rdr (Right name)+      | Just _ <- isBuiltInOcc_maybe (occName rdr)+      , this_mod /= nameModule name+      = Left (hsep [text "Illegal", what, text "of built-in syntax:", ppr rdr])+      | otherwise+      = Right (rdr, name)+    guard_builtin_syntax _ _ (Left err) = Left err++dataTcOccs :: RdrName -> [RdrName]+-- Return both the given name and the same name promoted to the TcClsName+-- namespace.  This is useful when we aren't sure which we are looking at.+-- See also Note [dataTcOccs and Exact Names]+dataTcOccs rdr_name+  | isDataOcc occ || isVarOcc occ+  = [rdr_name, rdr_name_tc]+  | otherwise+  = [rdr_name]+  where+    occ = rdrNameOcc rdr_name+    rdr_name_tc = setRdrNameSpace rdr_name tcName++{-+Note [dataTcOccs and Exact Names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Exact RdrNames can occur in code generated by Template Haskell, and generally+those references are, well, exact. However, the TH `Name` type isn't expressive+enough to always track the correct namespace information, so we sometimes get+the right Unique but wrong namespace. Thus, we still have to do the double-lookup+for Exact RdrNames.++There is also an awkward situation for built-in syntax. Example in GHCi+   :info []+This parses as the Exact RdrName for nilDataCon, but we also want+the list type constructor.++Note that setRdrNameSpace on an Exact name requires the Name to be External,+which it always is for built in syntax.+-}++++{-+************************************************************************+*                                                                      *+                        Rebindable names+        Dealing with rebindable syntax is driven by the+        Opt_RebindableSyntax dynamic flag.++        In "deriving" code we don't want to use rebindable syntax+        so we switch off the flag locally++*                                                                      *+************************************************************************++Haskell 98 says that when you say "3" you get the "fromInteger" from the+Standard Prelude, regardless of what is in scope.   However, to experiment+with having a language that is less coupled to the standard prelude, we're+trying a non-standard extension that instead gives you whatever "Prelude.fromInteger"+happens to be in scope.  Then you can+        import Prelude ()+        import MyPrelude as Prelude+to get the desired effect.++At the moment this just happens for+  * fromInteger, fromRational on literals (in expressions and patterns)+  * negate (in expressions)+  * minus  (arising from n+k patterns)+  * "do" notation++We store the relevant Name in the HsSyn tree, in+  * HsIntegral/HsFractional/HsIsString+  * NegApp+  * NPlusKPat+  * HsDo+respectively.  Initially, we just store the "standard" name (PrelNames.fromIntegralName,+fromRationalName etc), but the renamer changes this to the appropriate user+name if Opt_NoImplicitPrelude is on.  That is what lookupSyntaxName does.++We treat the original (standard) names as free-vars too, because the type checker+checks the type of the user thing against the type of the standard thing.+-}++lookupIfThenElse :: RnM (Maybe (SyntaxExpr GhcRn), FreeVars)+-- Different to lookupSyntaxName because in the non-rebindable+-- case we desugar directly rather than calling an existing function+-- Hence the (Maybe (SyntaxExpr GhcRn)) return type+lookupIfThenElse+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if not rebindable_on+         then return (Nothing, emptyFVs)+         else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))+                 ; return ( Just (mkRnSyntaxExpr ite)+                          , unitFV ite ) } }++lookupSyntaxName' :: Name          -- ^ The standard name+                  -> RnM Name      -- ^ Possibly a non-standard name+lookupSyntaxName' std_name+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if not rebindable_on then+           return std_name+         else+            -- Get the similarly named thing from the local environment+           lookupOccRn (mkRdrUnqual (nameOccName std_name)) }++lookupSyntaxName :: Name                             -- The standard name+                 -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard+                                                     -- name+lookupSyntaxName std_name+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if not rebindable_on then+           return (mkRnSyntaxExpr std_name, emptyFVs)+         else+            -- Get the similarly named thing from the local environment+           do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name))+              ; return (mkRnSyntaxExpr usr_name, unitFV usr_name) } }++lookupSyntaxNames :: [Name]                         -- Standard names+     -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames+   -- this works with CmdTop, which wants HsExprs, not SyntaxExprs+lookupSyntaxNames std_names+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if not rebindable_on then+             return (map (HsVar noExt . noLoc) std_names, emptyFVs)+        else+          do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names+             ; return (map (HsVar noExt . noLoc) usr_names, mkFVs usr_names) } }++-- Error messages+++opDeclErr :: RdrName -> SDoc+opDeclErr n+  = hang (text "Illegal declaration of a type or class operator" <+> quotes (ppr n))+       2 (text "Use TypeOperators to declare operators in type and declarations")++badOrigBinding :: RdrName -> SDoc+badOrigBinding name+  | Just _ <- isBuiltInOcc_maybe occ+  = text "Illegal binding of built-in syntax:" <+> ppr occ+    -- Use an OccName here because we don't want to print Prelude.(,)+  | otherwise+  = text "Cannot redefine a Name retrieved by a Template Haskell quote:"+    <+> ppr name+    -- This can happen when one tries to use a Template Haskell splice to+    -- define a top-level identifier with an already existing name, e.g.,+    --+    --   $(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []])+    --+    -- (See #13968.)+  where+    occ = rdrNameOcc $ filterCTuple name
+ compiler/rename/RnExpr.hs view
@@ -0,0 +1,2141 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[RnExpr]{Renaming of expressions}++Basically dependency analysis.++Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In+general, all of these functions return a renamed thing, and a set of+free variables.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module RnExpr (+        rnLExpr, rnExpr, rnStmts+   ) where++#include "HsVersions.h"++import GhcPrelude++import RnBinds   ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,+                   rnMatchGroup, rnGRHS, makeMiniFixityEnv)+import HsSyn+import TcEnv            ( isBrackStage )+import TcRnMonad+import Module           ( getModule )+import RnEnv+import RnFixity+import RnUtils          ( HsDocContext(..), bindLocalNamesFV, checkDupNames+                        , bindLocalNames+                        , mapMaybeFvRn, mapFvRn+                        , warnUnusedLocalBinds, typeAppErr+                        , checkUnusedRecordWildcard )+import RnUnbound        ( reportUnboundName )+import RnSplice         ( rnBracket, rnSpliceExpr, checkThLocalName )+import RnTypes+import RnPat+import DynFlags+import PrelNames++import BasicTypes+import Name+import NameSet+import RdrName+import UniqSet+import Data.List+import Util+import ListSetOps       ( removeDups )+import ErrUtils+import Outputable+import SrcLoc+import FastString+import Control.Monad+import TysWiredIn       ( nilDataConName )+import qualified GHC.LanguageExtensions as LangExt++import Data.Ord+import Data.Array+import qualified Data.List.NonEmpty as NE++import Unique           ( mkVarOccUnique )++{-+************************************************************************+*                                                                      *+\subsubsection{Expressions}+*                                                                      *+************************************************************************+-}++rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars)+rnExprs ls = rnExprs' ls emptyUniqSet+ where+  rnExprs' [] acc = return ([], acc)+  rnExprs' (expr:exprs) acc =+   do { (expr', fvExpr) <- rnLExpr expr+        -- Now we do a "seq" on the free vars because typically it's small+        -- or empty, especially in very long lists of constants+      ; let  acc' = acc `plusFV` fvExpr+      ; (exprs', fvExprs) <- acc' `seq` rnExprs' exprs acc'+      ; return (expr':exprs', fvExprs) }++-- Variables. We look up the variable and return the resulting name.++rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars)+rnLExpr = wrapLocFstM rnExpr++rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)++finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars)+-- Separated from rnExpr because it's also used+-- when renaming infix expressions+finishHsVar (L l name)+ = do { this_mod <- getModule+      ; when (nameIsLocalOrFrom this_mod name) $+        checkThLocalName name+      ; return (HsVar noExt (L l name), unitFV name) }++rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars)+rnUnboundVar v+ = do { if isUnqual v+        then -- Treat this as a "hole"+             -- Do not fail right now; instead, return HsUnboundVar+             -- and let the type checker report the error+             do { let occ = rdrNameOcc v+                ; uv <- if startsWithUnderscore occ+                        then return (TrueExprHole occ)+                        else OutOfScope occ <$> getGlobalRdrEnv+                ; return (HsUnboundVar noExt uv, emptyFVs) }++        else -- Fail immediately (qualified name)+             do { n <- reportUnboundName v+                ; return (HsVar noExt (noLoc n), emptyFVs) } }++rnExpr (HsVar _ (L l v))+  = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields+       ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v+       ; case mb_name of {+           Nothing -> rnUnboundVar v ;+           Just (Left name)+              | name == nilDataConName -- Treat [] as an ExplicitList, so that+                                       -- OverloadedLists works correctly+              -> rnExpr (ExplicitList noExt Nothing [])++              | otherwise+              -> finishHsVar (L l name) ;+            Just (Right [s]) ->+              return ( HsRecFld noExt (Unambiguous s (L l v) ), unitFV s) ;+           Just (Right fs@(_:_:_)) ->+              return ( HsRecFld noExt (Ambiguous noExt (L l v))+                     , mkFVs fs);+           Just (Right [])         -> panic "runExpr/HsVar" } }++rnExpr (HsIPVar x v)+  = return (HsIPVar x v, emptyFVs)++rnExpr (HsUnboundVar x v)+  = return (HsUnboundVar x v, emptyFVs)++rnExpr (HsOverLabel x _ v)+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if rebindable_on+         then do { fromLabel <- lookupOccRn (mkVarUnqual (fsLit "fromLabel"))+                 ; return (HsOverLabel x (Just fromLabel) v, unitFV fromLabel) }+         else return (HsOverLabel x Nothing v, emptyFVs) }++rnExpr (HsLit x lit@(HsString src s))+  = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings+       ; if opt_OverloadedStrings then+            rnExpr (HsOverLit x (mkHsIsString src s))+         else do {+            ; rnLit lit+            ; return (HsLit x (convertLit lit), emptyFVs) } }++rnExpr (HsLit x lit)+  = do { rnLit lit+       ; return (HsLit x(convertLit lit), emptyFVs) }++rnExpr (HsOverLit x lit)+  = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero]+       ; case mb_neg of+              Nothing -> return (HsOverLit x lit', fvs)+              Just neg -> return (HsApp x (noLoc neg) (noLoc (HsOverLit x lit'))+                                 , fvs ) }++rnExpr (HsApp x fun arg)+  = do { (fun',fvFun) <- rnLExpr fun+       ; (arg',fvArg) <- rnLExpr arg+       ; return (HsApp x fun' arg', fvFun `plusFV` fvArg) }++rnExpr (HsAppType x fun arg)+  = do { type_app <- xoptM LangExt.TypeApplications+       ; unless type_app $ addErr $ typeAppErr "type" $ hswc_body arg+       ; (fun',fvFun) <- rnLExpr fun+       ; (arg',fvArg) <- rnHsWcType HsTypeCtx arg+       ; return (HsAppType x fun' arg', fvFun `plusFV` fvArg) }++rnExpr (OpApp _ e1 op e2)+  = do  { (e1', fv_e1) <- rnLExpr e1+        ; (e2', fv_e2) <- rnLExpr e2+        ; (op', fv_op) <- rnLExpr op++        -- Deal with fixity+        -- When renaming code synthesised from "deriving" declarations+        -- we used to avoid fixity stuff, but we can't easily tell any+        -- more, so I've removed the test.  Adding HsPars in TcGenDeriv+        -- should prevent bad things happening.+        ; fixity <- case op' of+              L _ (HsVar _ (L _ n)) -> lookupFixityRn n+              L _ (HsRecFld _ f)    -> lookupFieldFixityRn f+              _ -> return (Fixity NoSourceText minPrecedence InfixL)+                   -- c.f. lookupFixity for unbound++        ; final_e <- mkOpAppRn e1' op' fixity e2'+        ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }++rnExpr (NegApp _ e _)+  = do { (e', fv_e)         <- rnLExpr e+       ; (neg_name, fv_neg) <- lookupSyntaxName negateName+       ; final_e            <- mkNegAppRn e' neg_name+       ; return (final_e, fv_e `plusFV` fv_neg) }++------------------------------------------+-- Template Haskell extensions+-- Don't ifdef-GHCI them because we want to fail gracefully+-- (not with an rnExpr crash) in a stage-1 compiler.+rnExpr e@(HsBracket _ br_body) = rnBracket e br_body++rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice++---------------------------------------------+--      Sections+-- See Note [Parsing sections] in Parser.y+rnExpr (HsPar x (L loc (section@(SectionL {}))))+  = do  { (section', fvs) <- rnSection section+        ; return (HsPar x (L loc section'), fvs) }++rnExpr (HsPar x (L loc (section@(SectionR {}))))+  = do  { (section', fvs) <- rnSection section+        ; return (HsPar x (L loc section'), fvs) }++rnExpr (HsPar x e)+  = do  { (e', fvs_e) <- rnLExpr e+        ; return (HsPar x e', fvs_e) }++rnExpr expr@(SectionL {})+  = do  { addErr (sectionErr expr); rnSection expr }+rnExpr expr@(SectionR {})+  = do  { addErr (sectionErr expr); rnSection expr }++---------------------------------------------+rnExpr (HsCoreAnn x src ann expr)+  = do { (expr', fvs_expr) <- rnLExpr expr+       ; return (HsCoreAnn x src ann expr', fvs_expr) }++rnExpr (HsSCC x src lbl expr)+  = do { (expr', fvs_expr) <- rnLExpr expr+       ; return (HsSCC x src lbl expr', fvs_expr) }+rnExpr (HsTickPragma x src info srcInfo expr)+  = do { (expr', fvs_expr) <- rnLExpr expr+       ; return (HsTickPragma x src info srcInfo expr', fvs_expr) }++rnExpr (HsLam x matches)+  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches+       ; return (HsLam x matches', fvMatch) }++rnExpr (HsLamCase x matches)+  = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches+       ; return (HsLamCase x matches', fvs_ms) }++rnExpr (HsCase x expr matches)+  = do { (new_expr, e_fvs) <- rnLExpr expr+       ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLExpr matches+       ; return (HsCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }++rnExpr (HsLet x (L l binds) expr)+  = rnLocalBindsAndThen binds $ \binds' _ -> do+      { (expr',fvExpr) <- rnLExpr expr+      ; return (HsLet x (L l binds') expr', fvExpr) }++rnExpr (HsDo x do_or_lc (L l stmts))+  = do  { ((stmts', _), fvs) <-+           rnStmtsWithPostProcessing do_or_lc rnLExpr+             postProcessStmtsForApplicativeDo stmts+             (\ _ -> return ((), emptyFVs))+        ; return ( HsDo x do_or_lc (L l stmts'), fvs ) }++rnExpr (ExplicitList x _  exps)+  = do  { opt_OverloadedLists <- xoptM LangExt.OverloadedLists+        ; (exps', fvs) <- rnExprs exps+        ; if opt_OverloadedLists+           then do {+            ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName+            ; return (ExplicitList x (Just from_list_n_name) exps'+                     , fvs `plusFV` fvs') }+           else+            return  (ExplicitList x Nothing exps', fvs) }++rnExpr (ExplicitTuple x tup_args boxity)+  = do { checkTupleSection tup_args+       ; checkTupSize (length tup_args)+       ; (tup_args', fvs) <- mapAndUnzipM rnTupArg tup_args+       ; return (ExplicitTuple x tup_args' boxity, plusFVs fvs) }+  where+    rnTupArg (L l (Present x e)) = do { (e',fvs) <- rnLExpr e+                                      ; return (L l (Present x e'), fvs) }+    rnTupArg (L l (Missing _)) = return (L l (Missing noExt)+                                        , emptyFVs)+    rnTupArg (L _ (XTupArg {})) = panic "rnExpr.XTupArg"++rnExpr (ExplicitSum x alt arity expr)+  = do { (expr', fvs) <- rnLExpr expr+       ; return (ExplicitSum x alt arity expr', fvs) }++rnExpr (RecordCon { rcon_con_name = con_id+                  , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })+  = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id+       ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds+       ; (flds', fvss) <- mapAndUnzipM rn_field flds+       ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }+       ; return (RecordCon { rcon_ext = noExt+                           , rcon_con_name = con_lname, rcon_flds = rec_binds' }+                , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }+  where+    mk_hs_var l n = HsVar noExt (L l n)+    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)+                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }++rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })+  = do  { (expr', fvExpr) <- rnLExpr expr+        ; (rbinds', fvRbinds) <- rnHsRecUpdFields rbinds+        ; return (RecordUpd { rupd_ext = noExt, rupd_expr = expr'+                            , rupd_flds = rbinds' }+                 , fvExpr `plusFV` fvRbinds) }++rnExpr (ExprWithTySig _ expr pty)+  = do  { (pty', fvTy)    <- rnHsSigWcType BindUnlessForall ExprWithTySigCtx pty+        ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $+                             rnLExpr expr+        ; return (ExprWithTySig noExt expr' pty', fvExpr `plusFV` fvTy) }++rnExpr (HsIf x _ p b1 b2)+  = do { (p', fvP) <- rnLExpr p+       ; (b1', fvB1) <- rnLExpr b1+       ; (b2', fvB2) <- rnLExpr b2+       ; (mb_ite, fvITE) <- lookupIfThenElse+       ; return (HsIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) }++rnExpr (HsMultiIf x alts)+  = do { (alts', fvs) <- mapFvRn (rnGRHS IfAlt rnLExpr) alts+       -- ; return (HsMultiIf ty alts', fvs) }+       ; return (HsMultiIf x alts', fvs) }++rnExpr (ArithSeq x _ seq)+  = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists+       ; (new_seq, fvs) <- rnArithSeq seq+       ; if opt_OverloadedLists+           then do {+            ; (from_list_name, fvs') <- lookupSyntaxName fromListName+            ; return (ArithSeq x (Just from_list_name) new_seq+                     , fvs `plusFV` fvs') }+           else+            return (ArithSeq x Nothing new_seq, fvs) }++{-+************************************************************************+*                                                                      *+        Static values+*                                                                      *+************************************************************************++For the static form we check that it is not used in splices.+We also collect the free variables of the term which come from+this module. See Note [Grand plan for static forms] in StaticPtrTable.+-}++rnExpr e@(HsStatic _ expr) = do+    -- Normally, you wouldn't be able to construct a static expression without+    -- first enabling -XStaticPointers in the first place, since that extension+    -- is what makes the parser treat `static` as a keyword. But this is not a+    -- sufficient safeguard, as one can construct static expressions by another+    -- mechanism: Template Haskell (see #14204). To ensure that GHC is+    -- absolutely prepared to cope with static forms, we check for+    -- -XStaticPointers here as well.+    unlessXOptM LangExt.StaticPointers $+      addErr $ hang (text "Illegal static expression:" <+> ppr e)+                  2 (text "Use StaticPointers to enable this extension")+    (expr',fvExpr) <- rnLExpr expr+    stage <- getStage+    case stage of+      Splice _ -> addErr $ sep+             [ text "static forms cannot be used in splices:"+             , nest 2 $ ppr e+             ]+      _ -> return ()+    mod <- getModule+    let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr+    return (HsStatic fvExpr' expr', fvExpr)++{-+************************************************************************+*                                                                      *+        Arrow notation+*                                                                      *+************************************************************************+-}++rnExpr (HsProc x pat body)+  = newArrowScope $+    rnPat ProcExpr pat $ \ pat' -> do+      { (body',fvBody) <- rnCmdTop body+      ; return (HsProc x pat' body', fvBody) }++rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)+        -- HsWrap++----------------------+-- See Note [Parsing sections] in Parser.y+rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)+rnSection section@(SectionR x op expr)+  = do  { (op', fvs_op)     <- rnLExpr op+        ; (expr', fvs_expr) <- rnLExpr expr+        ; checkSectionPrec InfixR section op' expr'+        ; return (SectionR x op' expr', fvs_op `plusFV` fvs_expr) }++rnSection section@(SectionL x expr op)+  = do  { (expr', fvs_expr) <- rnLExpr expr+        ; (op', fvs_op)     <- rnLExpr op+        ; checkSectionPrec InfixL section op' expr'+        ; return (SectionL x expr' op', fvs_op `plusFV` fvs_expr) }++rnSection other = pprPanic "rnSection" (ppr other)++{-+************************************************************************+*                                                                      *+        Arrow commands+*                                                                      *+************************************************************************+-}++rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars)+rnCmdArgs [] = return ([], emptyFVs)+rnCmdArgs (arg:args)+  = do { (arg',fvArg) <- rnCmdTop arg+       ; (args',fvArgs) <- rnCmdArgs args+       ; return (arg':args', fvArg `plusFV` fvArgs) }++rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars)+rnCmdTop = wrapLocFstM rnCmdTop'+ where+  rnCmdTop' (HsCmdTop _ cmd)+   = do { (cmd', fvCmd) <- rnLCmd cmd+        ; let cmd_names = [arrAName, composeAName, firstAName] +++                          nameSetElemsStable (methodNamesCmd (unLoc cmd'))+        -- Generate the rebindable syntax for the monad+        ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names++        ; return (HsCmdTop (cmd_names `zip` cmd_names') cmd',+                  fvCmd `plusFV` cmd_fvs) }+  rnCmdTop' (XCmdTop{}) = panic "rnCmdTop"++rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars)+rnLCmd = wrapLocFstM rnCmd++rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars)++rnCmd (HsCmdArrApp x arrow arg ho rtl)+  = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow)+       ; (arg',fvArg) <- rnLExpr arg+       ; return (HsCmdArrApp x arrow' arg' ho rtl,+                 fvArrow `plusFV` fvArg) }+  where+    select_arrow_scope tc = case ho of+        HsHigherOrderApp -> tc+        HsFirstOrderApp  -> escapeArrowScope tc+        -- See Note [Escaping the arrow scope] in TcRnTypes+        -- Before renaming 'arrow', use the environment of the enclosing+        -- proc for the (-<) case.+        -- Local bindings, inside the enclosing proc, are not in scope+        -- inside 'arrow'.  In the higher-order case (-<<), they are.++-- infix form+rnCmd (HsCmdArrForm _ op _ (Just _) [arg1, arg2])+  = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)+       ; let L _ (HsVar _ (L _ op_name)) = op'+       ; (arg1',fv_arg1) <- rnCmdTop arg1+       ; (arg2',fv_arg2) <- rnCmdTop arg2+        -- Deal with fixity+       ; fixity <- lookupFixityRn op_name+       ; final_e <- mkOpFormRn arg1' op' fixity arg2'+       ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) }++rnCmd (HsCmdArrForm x op f fixity cmds)+  = do { (op',fvOp) <- escapeArrowScope (rnLExpr op)+       ; (cmds',fvCmds) <- rnCmdArgs cmds+       ; return (HsCmdArrForm x op' f fixity cmds', fvOp `plusFV` fvCmds) }++rnCmd (HsCmdApp x fun arg)+  = do { (fun',fvFun) <- rnLCmd  fun+       ; (arg',fvArg) <- rnLExpr arg+       ; return (HsCmdApp x fun' arg', fvFun `plusFV` fvArg) }++rnCmd (HsCmdLam x matches)+  = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLCmd matches+       ; return (HsCmdLam x matches', fvMatch) }++rnCmd (HsCmdPar x e)+  = do  { (e', fvs_e) <- rnLCmd e+        ; return (HsCmdPar x e', fvs_e) }++rnCmd (HsCmdCase x expr matches)+  = do { (new_expr, e_fvs) <- rnLExpr expr+       ; (new_matches, ms_fvs) <- rnMatchGroup CaseAlt rnLCmd matches+       ; return (HsCmdCase x new_expr new_matches, e_fvs `plusFV` ms_fvs) }++rnCmd (HsCmdIf x _ p b1 b2)+  = do { (p', fvP) <- rnLExpr p+       ; (b1', fvB1) <- rnLCmd b1+       ; (b2', fvB2) <- rnLCmd b2+       ; (mb_ite, fvITE) <- lookupIfThenElse+       ; return (HsCmdIf x mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}++rnCmd (HsCmdLet x (L l binds) cmd)+  = rnLocalBindsAndThen binds $ \ binds' _ -> do+      { (cmd',fvExpr) <- rnLCmd cmd+      ; return (HsCmdLet x (L l binds') cmd', fvExpr) }++rnCmd (HsCmdDo x (L l stmts))+  = do  { ((stmts', _), fvs) <-+            rnStmts ArrowExpr rnLCmd stmts (\ _ -> return ((), emptyFVs))+        ; return ( HsCmdDo x (L l stmts'), fvs ) }++rnCmd cmd@(HsCmdWrap {}) = pprPanic "rnCmd" (ppr cmd)+rnCmd cmd@(XCmd {})      = pprPanic "rnCmd" (ppr cmd)++---------------------------------------------------+type CmdNeeds = FreeVars        -- Only inhabitants are+                                --      appAName, choiceAName, loopAName++-- find what methods the Cmd needs (loop, choice, apply)+methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds+methodNamesLCmd = methodNamesCmd . unLoc++methodNamesCmd :: HsCmd GhcRn -> CmdNeeds++methodNamesCmd (HsCmdArrApp _ _arrow _arg HsFirstOrderApp _rtl)+  = emptyFVs+methodNamesCmd (HsCmdArrApp _ _arrow _arg HsHigherOrderApp _rtl)+  = unitFV appAName+methodNamesCmd (HsCmdArrForm {}) = emptyFVs+methodNamesCmd (HsCmdWrap _ _ cmd) = methodNamesCmd cmd++methodNamesCmd (HsCmdPar _ c) = methodNamesLCmd c++methodNamesCmd (HsCmdIf _ _ _ c1 c2)+  = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName++methodNamesCmd (HsCmdLet _ _ c)          = methodNamesLCmd c+methodNamesCmd (HsCmdDo _ (L _ stmts))   = methodNamesStmts stmts+methodNamesCmd (HsCmdApp _ c _)          = methodNamesLCmd c+methodNamesCmd (HsCmdLam _ match)        = methodNamesMatch match++methodNamesCmd (HsCmdCase _ _ matches)+  = methodNamesMatch matches `addOneFV` choiceAName++methodNamesCmd (XCmd {}) = panic "methodNamesCmd"++--methodNamesCmd _ = emptyFVs+   -- Other forms can't occur in commands, but it's not convenient+   -- to error here so we just do what's convenient.+   -- The type checker will complain later++---------------------------------------------------+methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars+methodNamesMatch (MG { mg_alts = L _ ms })+  = plusFVs (map do_one ms)+ where+    do_one (L _ (Match { m_grhss = grhss })) = methodNamesGRHSs grhss+    do_one (L _ (XMatch _)) = panic "methodNamesMatch.XMatch"+methodNamesMatch (XMatchGroup _) = panic "methodNamesMatch"++-------------------------------------------------+-- gaw 2004+methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars+methodNamesGRHSs (GRHSs _ grhss _) = plusFVs (map methodNamesGRHS grhss)+methodNamesGRHSs (XGRHSs _) = panic "methodNamesGRHSs"++-------------------------------------------------++methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds+methodNamesGRHS (L _ (GRHS _ _ rhs)) = methodNamesLCmd rhs+methodNamesGRHS (L _ (XGRHS _)) = panic "methodNamesGRHS"++---------------------------------------------------+methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars+methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts)++---------------------------------------------------+methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars+methodNamesLStmt = methodNamesStmt . unLoc++methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars+methodNamesStmt (LastStmt _ cmd _ _)           = methodNamesLCmd cmd+methodNamesStmt (BodyStmt _ cmd _ _)           = methodNamesLCmd cmd+methodNamesStmt (BindStmt _ _ cmd _ _)         = methodNamesLCmd cmd+methodNamesStmt (RecStmt { recS_stmts = stmts }) =+  methodNamesStmts stmts `addOneFV` loopAName+methodNamesStmt (LetStmt {})                   = emptyFVs+methodNamesStmt (ParStmt {})                   = emptyFVs+methodNamesStmt (TransStmt {})                 = emptyFVs+methodNamesStmt ApplicativeStmt{}              = emptyFVs+   -- ParStmt and TransStmt can't occur in commands, but it's not+   -- convenient to error here so we just do what's convenient+methodNamesStmt (XStmtLR {}) = panic "methodNamesStmt"++{-+************************************************************************+*                                                                      *+        Arithmetic sequences+*                                                                      *+************************************************************************+-}++rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars)+rnArithSeq (From expr)+ = do { (expr', fvExpr) <- rnLExpr expr+      ; return (From expr', fvExpr) }++rnArithSeq (FromThen expr1 expr2)+ = do { (expr1', fvExpr1) <- rnLExpr expr1+      ; (expr2', fvExpr2) <- rnLExpr expr2+      ; return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) }++rnArithSeq (FromTo expr1 expr2)+ = do { (expr1', fvExpr1) <- rnLExpr expr1+      ; (expr2', fvExpr2) <- rnLExpr expr2+      ; return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) }++rnArithSeq (FromThenTo expr1 expr2 expr3)+ = do { (expr1', fvExpr1) <- rnLExpr expr1+      ; (expr2', fvExpr2) <- rnLExpr expr2+      ; (expr3', fvExpr3) <- rnLExpr expr3+      ; return (FromThenTo expr1' expr2' expr3',+                plusFVs [fvExpr1, fvExpr2, fvExpr3]) }++{-+************************************************************************+*                                                                      *+\subsubsection{@Stmt@s: in @do@ expressions}+*                                                                      *+************************************************************************+-}++{-+Note [Deterministic ApplicativeDo and RecursiveDo desugaring]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Both ApplicativeDo and RecursiveDo need to create tuples not+present in the source text.++For ApplicativeDo we create:++  (a,b,c) <- (\c b a -> (a,b,c)) <$>++For RecursiveDo we create:++  mfix (\ ~(a,b,c) -> do ...; return (a',b',c'))++The order of the components in those tuples needs to be stable+across recompilations, otherwise they can get optimized differently+and we end up with incompatible binaries.+To get a stable order we use nameSetElemsStable.+See Note [Deterministic UniqFM] to learn more about nondeterminism.+-}++-- | Rename some Stmts+rnStmts :: Outputable (body GhcPs)+        => HsStmtContext Name+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+           -- ^ How to rename the body of each statement (e.g. rnLExpr)+        -> [LStmt GhcPs (Located (body GhcPs))]+           -- ^ Statements+        -> ([Name] -> RnM (thing, FreeVars))+           -- ^ if these statements scope over something, this renames it+           -- and returns the result.+        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)+rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts++-- | like 'rnStmts' but applies a post-processing step to the renamed Stmts+rnStmtsWithPostProcessing+        :: Outputable (body GhcPs)+        => HsStmtContext Name+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+           -- ^ How to rename the body of each statement (e.g. rnLExpr)+        -> (HsStmtContext Name+              -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]+              -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars))+           -- ^ postprocess the statements+        -> [LStmt GhcPs (Located (body GhcPs))]+           -- ^ Statements+        -> ([Name] -> RnM (thing, FreeVars))+           -- ^ if these statements scope over something, this renames it+           -- and returns the result.+        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)+rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside+ = do { ((stmts', thing), fvs) <-+          rnStmtsWithFreeVars ctxt rnBody stmts thing_inside+      ; (pp_stmts, fvs') <- ppStmts ctxt stmts'+      ; return ((pp_stmts, thing), fvs `plusFV` fvs')+      }++-- | maybe rearrange statements according to the ApplicativeDo transformation+postProcessStmtsForApplicativeDo+  :: HsStmtContext Name+  -> [(ExprLStmt GhcRn, FreeVars)]+  -> RnM ([ExprLStmt GhcRn], FreeVars)+postProcessStmtsForApplicativeDo ctxt stmts+  = do {+       -- rearrange the statements using ApplicativeStmt if+       -- -XApplicativeDo is on.  Also strip out the FreeVars attached+       -- to each Stmt body.+         ado_is_on <- xoptM LangExt.ApplicativeDo+       ; let is_do_expr | DoExpr <- ctxt = True+                        | otherwise = False+       -- don't apply the transformation inside TH brackets, because+       -- DsMeta does not handle ApplicativeDo.+       ; in_th_bracket <- isBrackStage <$> getStage+       ; if ado_is_on && is_do_expr && not in_th_bracket+            then do { traceRn "ppsfa" (ppr stmts)+                    ; rearrangeForApplicativeDo ctxt stmts }+            else noPostProcessStmts ctxt stmts }++-- | strip the FreeVars annotations from statements+noPostProcessStmts+  :: HsStmtContext Name+  -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]+  -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)+noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet)+++rnStmtsWithFreeVars :: Outputable (body GhcPs)+        => HsStmtContext Name+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+        -> [LStmt GhcPs (Located (body GhcPs))]+        -> ([Name] -> RnM (thing, FreeVars))+        -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)+               , FreeVars)+-- Each Stmt body is annotated with its FreeVars, so that+-- we can rearrange statements for ApplicativeDo.+--+-- Variables bound by the Stmts, and mentioned in thing_inside,+-- do not appear in the result FreeVars++rnStmtsWithFreeVars ctxt _ [] thing_inside+  = do { checkEmptyStmts ctxt+       ; (thing, fvs) <- thing_inside []+       ; return (([], thing), fvs) }++rnStmtsWithFreeVars MDoExpr rnBody stmts thing_inside    -- Deal with mdo+  = -- Behave like do { rec { ...all but last... }; last }+    do { ((stmts1, (stmts2, thing)), fvs)+           <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ ->+              do { last_stmt' <- checkLastStmt MDoExpr last_stmt+                 ; rnStmt MDoExpr rnBody last_stmt' thing_inside }+        ; return (((stmts1 ++ stmts2), thing), fvs) }+  where+    Just (all_but_last, last_stmt) = snocView stmts++rnStmtsWithFreeVars ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside+  | null lstmts+  = setSrcSpan loc $+    do { lstmt' <- checkLastStmt ctxt lstmt+       ; rnStmt ctxt rnBody lstmt' thing_inside }++  | otherwise+  = do { ((stmts1, (stmts2, thing)), fvs)+            <- setSrcSpan loc                         $+               do { checkStmt ctxt lstmt+                  ; rnStmt ctxt rnBody lstmt    $ \ bndrs1 ->+                    rnStmtsWithFreeVars ctxt rnBody lstmts  $ \ bndrs2 ->+                    thing_inside (bndrs1 ++ bndrs2) }+        ; return (((stmts1 ++ stmts2), thing), fvs) }++----------------------++{-+Note [Failing pattern matches in Stmts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Many things desugar to HsStmts including monadic things like `do` and `mdo`+statements, pattern guards, and list comprehensions (see 'HsStmtContext' for an+exhaustive list). How we deal with pattern match failure is context-dependent.++ * In the case of list comprehensions and pattern guards we don't need any 'fail'+   function; the desugarer ignores the fail function field of 'BindStmt' entirely.+ * In the case of monadic contexts (e.g. monad comprehensions, do, and mdo+   expressions) we want pattern match failure to be desugared to the appropriate+   'fail' function (either that of Monad or MonadFail, depending on whether+   -XMonadFailDesugaring is enabled.)++At one point we failed to make this distinction, leading to #11216.+-}++rnStmt :: Outputable (body GhcPs)+       => HsStmtContext Name+       -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+          -- ^ How to rename the body of the statement+       -> LStmt GhcPs (Located (body GhcPs))+          -- ^ The statement+       -> ([Name] -> RnM (thing, FreeVars))+          -- ^ Rename the stuff that this statement scopes over+       -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing)+              , FreeVars)+-- Variables bound by the Stmt, and mentioned in thing_inside,+-- do not appear in the result FreeVars++rnStmt ctxt rnBody (L loc (LastStmt _ body noret _)) thing_inside+  = do  { (body', fv_expr) <- rnBody body+        ; (ret_op, fvs1) <- if isMonadCompContext ctxt+                            then lookupStmtName ctxt returnMName+                            else return (noSyntaxExpr, emptyFVs)+                            -- The 'return' in a LastStmt is used only+                            -- for MonadComp; and we don't want to report+                            -- "non in scope: return" in other cases+                            -- #15607++        ; (thing,  fvs3) <- thing_inside []+        ; return (([(L loc (LastStmt noExt body' noret ret_op), fv_expr)]+                  , thing), fv_expr `plusFV` fvs1 `plusFV` fvs3) }++rnStmt ctxt rnBody (L loc (BodyStmt _ body _ _)) thing_inside+  = do  { (body', fv_expr) <- rnBody body+        ; (then_op, fvs1)  <- lookupStmtName ctxt thenMName++        ; (guard_op, fvs2) <- if isComprehensionContext ctxt+                              then lookupStmtName ctxt guardMName+                              else return (noSyntaxExpr, emptyFVs)+                              -- Only list/monad comprehensions use 'guard'+                              -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ]+                              -- Here "gd" is a guard++        ; (thing, fvs3)    <- thing_inside []+        ; return ( ([(L loc (BodyStmt noExt body' then_op guard_op), fv_expr)]+                  , thing), fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }++rnStmt ctxt rnBody (L loc (BindStmt _ pat body _ _)) thing_inside+  = do  { (body', fv_expr) <- rnBody body+                -- The binders do not scope over the expression+        ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName++        ; (fail_op, fvs2) <- monadFailOp pat ctxt++        ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do+        { (thing, fvs3) <- thing_inside (collectPatBinders pat')+        ; return (( [( L loc (BindStmt noExt pat' body' bind_op fail_op)+                     , fv_expr )]+                  , thing),+                  fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }}+       -- fv_expr shouldn't really be filtered by the rnPatsAndThen+        -- but it does not matter because the names are unique++rnStmt _ _ (L loc (LetStmt _ (L l binds))) thing_inside+  = do  { rnLocalBindsAndThen binds $ \binds' bind_fvs -> do+        { (thing, fvs) <- thing_inside (collectLocalBinders binds')+        ; return ( ([(L loc (LetStmt noExt (L l binds')), bind_fvs)], thing)+                 , fvs) }  }++rnStmt ctxt rnBody (L loc (RecStmt { recS_stmts = rec_stmts })) thing_inside+  = do  { (return_op, fvs1)  <- lookupStmtName ctxt returnMName+        ; (mfix_op,   fvs2)  <- lookupStmtName ctxt mfixName+        ; (bind_op,   fvs3)  <- lookupStmtName ctxt bindMName+        ; let empty_rec_stmt = emptyRecStmtName { recS_ret_fn  = return_op+                                                , recS_mfix_fn = mfix_op+                                                , recS_bind_fn = bind_op }++        -- Step1: Bring all the binders of the mdo into scope+        -- (Remember that this also removes the binders from the+        -- finally-returned free-vars.)+        -- And rename each individual stmt, making a+        -- singleton segment.  At this stage the FwdRefs field+        -- isn't finished: it's empty for all except a BindStmt+        -- for which it's the fwd refs within the bind itself+        -- (This set may not be empty, because we're in a recursive+        -- context.)+        ; rnRecStmtsAndThen rnBody rec_stmts   $ \ segs -> do+        { let bndrs = nameSetElemsStable $+                        foldr (unionNameSet . (\(ds,_,_,_) -> ds))+                              emptyNameSet+                              segs+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]+        ; (thing, fvs_later) <- thing_inside bndrs+        ; let (rec_stmts', fvs) = segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later+        -- We aren't going to try to group RecStmts with+        -- ApplicativeDo, so attaching empty FVs is fine.+        ; return ( ((zip rec_stmts' (repeat emptyNameSet)), thing)+                 , fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } }++rnStmt ctxt _ (L loc (ParStmt _ segs _ _)) thing_inside+  = do  { (mzip_op, fvs1)   <- lookupStmtNamePoly ctxt mzipName+        ; (bind_op, fvs2)   <- lookupStmtName ctxt bindMName+        ; (return_op, fvs3) <- lookupStmtName ctxt returnMName+        ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside+        ; return (([(L loc (ParStmt noExt segs' mzip_op bind_op), fvs4)], thing)+                 , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }++rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form+                              , trS_using = using })) thing_inside+  = do { -- Rename the 'using' expression in the context before the transform is begun+         (using', fvs1) <- rnLExpr using++         -- Rename the stmts and the 'by' expression+         -- Keep track of the variables mentioned in the 'by' expression+       ; ((stmts', (by', used_bndrs, thing)), fvs2)+             <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs ->+                do { (by',   fvs_by) <- mapMaybeFvRn rnLExpr by+                   ; (thing, fvs_thing) <- thing_inside bndrs+                   ; let fvs = fvs_by `plusFV` fvs_thing+                         used_bndrs = filter (`elemNameSet` fvs) bndrs+                         -- The paper (Fig 5) has a bug here; we must treat any free variable+                         -- of the "thing inside", **or of the by-expression**, as used+                   ; return ((by', used_bndrs, thing), fvs) }++       -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions+       ; (return_op, fvs3) <- lookupStmtName ctxt returnMName+       ; (bind_op,   fvs4) <- lookupStmtName ctxt bindMName+       ; (fmap_op,   fvs5) <- case form of+                                ThenForm -> return (noExpr, emptyFVs)+                                _        -> lookupStmtNamePoly ctxt fmapName++       ; let all_fvs  = fvs1 `plusFV` fvs2 `plusFV` fvs3+                             `plusFV` fvs4 `plusFV` fvs5+             bndr_map = used_bndrs `zip` used_bndrs+             -- See Note [TransStmt binder map] in HsExpr++       ; traceRn "rnStmt: implicitly rebound these used binders:" (ppr bndr_map)+       ; return (([(L loc (TransStmt { trS_ext = noExt+                                    , trS_stmts = stmts', trS_bndrs = bndr_map+                                    , trS_by = by', trS_using = using', trS_form = form+                                    , trS_ret = return_op, trS_bind = bind_op+                                    , trS_fmap = fmap_op }), fvs2)], thing), all_fvs) }++rnStmt _ _ (L _ ApplicativeStmt{}) _ =+  panic "rnStmt: ApplicativeStmt"++rnStmt _ _ (L _ XStmtLR{}) _ =+  panic "rnStmt: XStmtLR"++rnParallelStmts :: forall thing. HsStmtContext Name+                -> SyntaxExpr GhcRn+                -> [ParStmtBlock GhcPs GhcPs]+                -> ([Name] -> RnM (thing, FreeVars))+                -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)+-- Note [Renaming parallel Stmts]+rnParallelStmts ctxt return_op segs thing_inside+  = do { orig_lcl_env <- getLocalRdrEnv+       ; rn_segs orig_lcl_env [] segs }+  where+    rn_segs :: LocalRdrEnv+            -> [Name] -> [ParStmtBlock GhcPs GhcPs]+            -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars)+    rn_segs _ bndrs_so_far []+      = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far+           ; mapM_ dupErr dups+           ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs')+           ; return (([], thing), fvs) }++    rn_segs env bndrs_so_far (ParStmtBlock x stmts _ _ : segs)+      = do { ((stmts', (used_bndrs, segs', thing)), fvs)+                    <- rnStmts ctxt rnLExpr stmts $ \ bndrs ->+                       setLocalRdrEnv env       $ do+                       { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs+                       ; let used_bndrs = filter (`elemNameSet` fvs) bndrs+                       ; return ((used_bndrs, segs', thing), fvs) }++           ; let seg' = ParStmtBlock x stmts' used_bndrs return_op+           ; return ((seg':segs', thing), fvs) }+    rn_segs _ _ (XParStmtBlock{}:_) = panic "rnParallelStmts"++    cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2+    dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:"+                    <+> quotes (ppr (NE.head vs)))++lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars)+-- Like lookupSyntaxName, but respects contexts+lookupStmtName ctxt n+  | rebindableContext ctxt+  = lookupSyntaxName n+  | otherwise+  = return (mkRnSyntaxExpr n, emptyFVs)++lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars)+lookupStmtNamePoly ctxt name+  | rebindableContext ctxt+  = do { rebindable_on <- xoptM LangExt.RebindableSyntax+       ; if rebindable_on+         then do { fm <- lookupOccRn (nameRdrName name)+                 ; return (HsVar noExt (noLoc fm), unitFV fm) }+         else not_rebindable }+  | otherwise+  = not_rebindable+  where+    not_rebindable = return (HsVar noExt (noLoc name), emptyFVs)++-- | Is this a context where we respect RebindableSyntax?+-- but ListComp are never rebindable+-- Neither is ArrowExpr, which has its own desugarer in DsArrows+rebindableContext :: HsStmtContext Name -> Bool+rebindableContext ctxt = case ctxt of+  ListComp        -> False+  ArrowExpr       -> False+  PatGuard {}     -> False++  DoExpr          -> True+  MDoExpr         -> True+  MonadComp       -> True+  GhciStmtCtxt    -> True   -- I suppose?++  ParStmtCtxt   c -> rebindableContext c     -- Look inside to+  TransStmtCtxt c -> rebindableContext c     -- the parent context++{-+Note [Renaming parallel Stmts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Renaming parallel statements is painful.  Given, say+     [ a+c | a <- as, bs <- bss+           | c <- bs, a <- ds ]+Note that+  (a) In order to report "Defined but not used" about 'bs', we must+      rename each group of Stmts with a thing_inside whose FreeVars+      include at least {a,c}++  (b) We want to report that 'a' is illegally bound in both branches++  (c) The 'bs' in the second group must obviously not be captured by+      the binding in the first group++To satisfy (a) we nest the segements.+To satisfy (b) we check for duplicates just before thing_inside.+To satisfy (c) we reset the LocalRdrEnv each time.++************************************************************************+*                                                                      *+\subsubsection{mdo expressions}+*                                                                      *+************************************************************************+-}++type FwdRefs = NameSet+type Segment stmts = (Defs,+                      Uses,     -- May include defs+                      FwdRefs,  -- A subset of uses that are+                                --   (a) used before they are bound in this segment, or+                                --   (b) used here, and bound in subsequent segments+                      stmts)    -- Either Stmt or [Stmt]+++-- wrapper that does both the left- and right-hand sides+rnRecStmtsAndThen :: Outputable (body GhcPs) =>+                     (Located (body GhcPs)+                  -> RnM (Located (body GhcRn), FreeVars))+                  -> [LStmt GhcPs (Located (body GhcPs))]+                         -- assumes that the FreeVars returned includes+                         -- the FreeVars of the Segments+                  -> ([Segment (LStmt GhcRn (Located (body GhcRn)))]+                      -> RnM (a, FreeVars))+                  -> RnM (a, FreeVars)+rnRecStmtsAndThen rnBody s cont+  = do  { -- (A) Make the mini fixity env for all of the stmts+          fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s)++          -- (B) Do the LHSes+        ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s++          --    ...bring them and their fixities into scope+        ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv)+              -- Fake uses of variables introduced implicitly (warning suppression, see #4404)+              rec_uses = lStmtsImplicits (map fst new_lhs_and_fv)+              implicit_uses = mkNameSet $ concatMap snd $ rec_uses+        ; bindLocalNamesFV bound_names $+          addLocalFixities fix_env bound_names $ do++          -- (C) do the right-hand-sides and thing-inside+        { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv+        ; (res, fvs) <- cont segs+        ; mapM_ (\(loc, ns) -> checkUnusedRecordWildcard loc fvs (Just ns))+                rec_uses+        ; warnUnusedLocalBinds bound_names (fvs `unionNameSet` implicit_uses)+        ; return (res, fvs) }}++-- get all the fixity decls in any Let stmt+collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs]+collectRecStmtsFixities l =+    foldr (\ s -> \acc -> case s of+            (L _ (LetStmt _ (L _ (HsValBinds _ (ValBinds _ _ sigs))))) ->+              foldr (\ sig -> \ acc -> case sig of+                                         (L loc (FixSig _ s)) -> (L loc s) : acc+                                         _ -> acc) acc sigs+            _ -> acc) [] l++-- left-hand sides++rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv+                -> LStmt GhcPs body+                   -- rename LHS, and return its FVs+                   -- Warning: we will only need the FreeVars below in the case of a BindStmt,+                   -- so we don't bother to compute it accurately in the other cases+                -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]++rn_rec_stmt_lhs _ (L loc (BodyStmt _ body a b))+  = return [(L loc (BodyStmt noExt body a b), emptyFVs)]++rn_rec_stmt_lhs _ (L loc (LastStmt _ body noret a))+  = return [(L loc (LastStmt noExt body noret a), emptyFVs)]++rn_rec_stmt_lhs fix_env (L loc (BindStmt _ pat body a b))+  = do+      -- should the ctxt be MDo instead?+      (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat+      return [(L loc (BindStmt noExt pat' body a b), fv_pat)]++rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))))+  = failWith (badIpBinds (text "an mdo expression") binds)++rn_rec_stmt_lhs fix_env (L loc (LetStmt _ (L l (HsValBinds x binds))))+    = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds+         return [(L loc (LetStmt noExt (L l (HsValBinds x binds'))),+                 -- Warning: this is bogus; see function invariant+                 emptyFVs+                 )]++-- XXX Do we need to do something with the return and mfix names?+rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts }))  -- Flatten Rec inside Rec+    = rn_rec_stmts_lhs fix_env stmts++rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {}))       -- Syntactically illegal in mdo+  = pprPanic "rn_rec_stmt" (ppr stmt)++rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {}))     -- Syntactically illegal in mdo+  = pprPanic "rn_rec_stmt" (ppr stmt)++rn_rec_stmt_lhs _ stmt@(L _ (ApplicativeStmt {})) -- Shouldn't appear yet+  = pprPanic "rn_rec_stmt" (ppr stmt)++rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))))+  = panic "rn_rec_stmt LetStmt EmptyLocalBinds"+rn_rec_stmt_lhs _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))))+  = panic "rn_rec_stmt LetStmt XHsLocalBindsLR"+rn_rec_stmt_lhs _ (L _ (XStmtLR _))+  = panic "rn_rec_stmt XStmtLR"++rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv+                 -> [LStmt GhcPs body]+                 -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)]+rn_rec_stmts_lhs fix_env stmts+  = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts+       ; let boundNames = collectLStmtsBinders (map fst ls)+            -- First do error checking: we need to check for dups here because we+            -- don't bind all of the variables from the Stmt at once+            -- with bindLocatedLocals.+       ; checkDupNames boundNames+       ; return ls }+++-- right-hand-sides++rn_rec_stmt :: (Outputable (body GhcPs)) =>+               (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+            -> [Name]+            -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)+            -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]+        -- Rename a Stmt that is inside a RecStmt (or mdo)+        -- Assumes all binders are already in scope+        -- Turns each stmt into a singleton Stmt+rn_rec_stmt rnBody _ (L loc (LastStmt _ body noret _), _)+  = do  { (body', fv_expr) <- rnBody body+        ; (ret_op, fvs1)   <- lookupSyntaxName returnMName+        ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet,+                   L loc (LastStmt noExt body' noret ret_op))] }++rn_rec_stmt rnBody _ (L loc (BodyStmt _ body _ _), _)+  = do { (body', fvs) <- rnBody body+       ; (then_op, fvs1) <- lookupSyntaxName thenMName+       ; return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet,+                 L loc (BodyStmt noExt body' then_op noSyntaxExpr))] }++rn_rec_stmt rnBody _ (L loc (BindStmt _ pat' body _ _), fv_pat)+  = do { (body', fv_expr) <- rnBody body+       ; (bind_op, fvs1) <- lookupSyntaxName bindMName++       ; (fail_op, fvs2) <- getMonadFailOp++       ; let bndrs = mkNameSet (collectPatBinders pat')+             fvs   = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2+       ; return [(bndrs, fvs, bndrs `intersectNameSet` fvs,+                  L loc (BindStmt noExt pat' body' bind_op fail_op))] }++rn_rec_stmt _ _ (L _ (LetStmt _ (L _ binds@(HsIPBinds {}))), _)+  = failWith (badIpBinds (text "an mdo expression") binds)++rn_rec_stmt _ all_bndrs (L loc (LetStmt _ (L l (HsValBinds x binds'))), _)+  = do { (binds', du_binds) <- rnLocalValBindsRHS (mkNameSet all_bndrs) binds'+           -- fixities and unused are handled above in rnRecStmtsAndThen+       ; let fvs = allUses du_binds+       ; return [(duDefs du_binds, fvs, emptyNameSet,+                 L loc (LetStmt noExt (L l (HsValBinds x binds'))))] }++-- no RecStmt case because they get flattened above when doing the LHSes+rn_rec_stmt _ _ stmt@(L _ (RecStmt {}), _)+  = pprPanic "rn_rec_stmt: RecStmt" (ppr stmt)++rn_rec_stmt _ _ stmt@(L _ (ParStmt {}), _)       -- Syntactically illegal in mdo+  = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt)++rn_rec_stmt _ _ stmt@(L _ (TransStmt {}), _)     -- Syntactically illegal in mdo+  = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt)++rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (XHsLocalBindsLR _))), _)+  = panic "rn_rec_stmt: LetStmt XHsLocalBindsLR"++rn_rec_stmt _ _ (L _ (LetStmt _ (L _ (EmptyLocalBinds _))), _)+  = panic "rn_rec_stmt: LetStmt EmptyLocalBinds"++rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _)+  = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt)++rn_rec_stmt _ _ stmt@(L _ (XStmtLR {}), _)+  = pprPanic "rn_rec_stmt: XStmtLR" (ppr stmt)++rn_rec_stmts :: Outputable (body GhcPs) =>+                (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+             -> [Name]+             -> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)]+             -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))]+rn_rec_stmts rnBody bndrs stmts+  = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts+       ; return (concat segs_s) }++---------------------------------------------+segmentRecStmts :: SrcSpan -> HsStmtContext Name+                -> Stmt GhcRn body+                -> [Segment (LStmt GhcRn body)] -> FreeVars+                -> ([LStmt GhcRn body], FreeVars)++segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later+  | null segs+  = ([], fvs_later)++  | MDoExpr <- ctxt+  = segsToStmts empty_rec_stmt grouped_segs fvs_later+               -- Step 4: Turn the segments into Stmts+                --         Use RecStmt when and only when there are fwd refs+                --         Also gather up the uses from the end towards the+                --         start, so we can tell the RecStmt which things are+                --         used 'after' the RecStmt++  | otherwise+  = ([ L loc $+       empty_rec_stmt { recS_stmts = ss+                      , recS_later_ids = nameSetElemsStable+                                           (defs `intersectNameSet` fvs_later)+                      , recS_rec_ids   = nameSetElemsStable+                                           (defs `intersectNameSet` uses) }]+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]+    , uses `plusFV` fvs_later)++  where+    (defs_s, uses_s, _, ss) = unzip4 segs+    defs = plusFVs defs_s+    uses = plusFVs uses_s++                -- Step 2: Fill in the fwd refs.+                --         The segments are all singletons, but their fwd-ref+                --         field mentions all the things used by the segment+                --         that are bound after their use+    segs_w_fwd_refs = addFwdRefs segs++                -- Step 3: Group together the segments to make bigger segments+                --         Invariant: in the result, no segment uses a variable+                --                    bound in a later segment+    grouped_segs = glomSegments ctxt segs_w_fwd_refs++----------------------------+addFwdRefs :: [Segment a] -> [Segment a]+-- So far the segments only have forward refs *within* the Stmt+--      (which happens for bind:  x <- ...x...)+-- This function adds the cross-seg fwd ref info++addFwdRefs segs+  = fst (foldr mk_seg ([], emptyNameSet) segs)+  where+    mk_seg (defs, uses, fwds, stmts) (segs, later_defs)+        = (new_seg : segs, all_defs)+        where+          new_seg = (defs, uses, new_fwds, stmts)+          all_defs = later_defs `unionNameSet` defs+          new_fwds = fwds `unionNameSet` (uses `intersectNameSet` later_defs)+                -- Add the downstream fwd refs here++{-+Note [Segmenting mdo]+~~~~~~~~~~~~~~~~~~~~~+NB. June 7 2012: We only glom segments that appear in an explicit mdo;+and leave those found in "do rec"'s intact.  See+https://gitlab.haskell.org/ghc/ghc/issues/4148 for the discussion+leading to this design choice.  Hence the test in segmentRecStmts.++Note [Glomming segments]+~~~~~~~~~~~~~~~~~~~~~~~~+Glomming the singleton segments of an mdo into minimal recursive groups.++At first I thought this was just strongly connected components, but+there's an important constraint: the order of the stmts must not change.++Consider+     mdo { x <- ...y...+           p <- z+           y <- ...x...+           q <- x+           z <- y+           r <- x }++Here, the first stmt mention 'y', which is bound in the third.+But that means that the innocent second stmt (p <- z) gets caught+up in the recursion.  And that in turn means that the binding for+'z' has to be included... and so on.++Start at the tail { r <- x }+Now add the next one { z <- y ; r <- x }+Now add one more     { q <- x ; z <- y ; r <- x }+Now one more... but this time we have to group a bunch into rec+     { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x }+Now one more, which we can add on without a rec+     { p <- z ;+       rec { y <- ...x... ; q <- x ; z <- y } ;+       r <- x }+Finally we add the last one; since it mentions y we have to+glom it together with the first two groups+     { rec { x <- ...y...; p <- z ; y <- ...x... ;+             q <- x ; z <- y } ;+       r <- x }+-}++glomSegments :: HsStmtContext Name+             -> [Segment (LStmt GhcRn body)]+             -> [Segment [LStmt GhcRn body]]+                                  -- Each segment has a non-empty list of Stmts+-- See Note [Glomming segments]++glomSegments _ [] = []+glomSegments ctxt ((defs,uses,fwds,stmt) : segs)+        -- Actually stmts will always be a singleton+  = (seg_defs, seg_uses, seg_fwds, seg_stmts)  : others+  where+    segs'            = glomSegments ctxt segs+    (extras, others) = grab uses segs'+    (ds, us, fs, ss) = unzip4 extras++    seg_defs  = plusFVs ds `plusFV` defs+    seg_uses  = plusFVs us `plusFV` uses+    seg_fwds  = plusFVs fs `plusFV` fwds+    seg_stmts = stmt : concat ss++    grab :: NameSet             -- The client+         -> [Segment a]+         -> ([Segment a],       -- Needed by the 'client'+             [Segment a])       -- Not needed by the client+        -- The result is simply a split of the input+    grab uses dus+        = (reverse yeses, reverse noes)+        where+          (noes, yeses)           = span not_needed (reverse dus)+          not_needed (defs,_,_,_) = not (intersectsNameSet defs uses)++----------------------------------------------------+segsToStmts :: Stmt GhcRn body+                                  -- A RecStmt with the SyntaxOps filled in+            -> [Segment [LStmt GhcRn body]]+                                  -- Each Segment has a non-empty list of Stmts+            -> FreeVars           -- Free vars used 'later'+            -> ([LStmt GhcRn body], FreeVars)++segsToStmts _ [] fvs_later = ([], fvs_later)+segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later+  = ASSERT( not (null ss) )+    (new_stmt : later_stmts, later_uses `plusFV` uses)+  where+    (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later+    new_stmt | non_rec   = head ss+             | otherwise = cL (getLoc (head ss)) rec_stmt+    rec_stmt = empty_rec_stmt { recS_stmts     = ss+                              , recS_later_ids = nameSetElemsStable used_later+                              , recS_rec_ids   = nameSetElemsStable fwds }+          -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]+    non_rec    = isSingleton ss && isEmptyNameSet fwds+    used_later = defs `intersectNameSet` later_uses+                                -- The ones needed after the RecStmt++{-+************************************************************************+*                                                                      *+ApplicativeDo+*                                                                      *+************************************************************************++Note [ApplicativeDo]++= Example =++For a sequence of statements++ do+     x <- A+     y <- B x+     z <- C+     return (f x y z)++We want to transform this to++  (\(x,y) z -> f x y z) <$> (do x <- A; y <- B x; return (x,y)) <*> C++It would be easy to notice that "y <- B x" and "z <- C" are+independent and do something like this:++ do+     x <- A+     (y,z) <- (,) <$> B x <*> C+     return (f x y z)++But this isn't enough! A and C were also independent, and this+transformation loses the ability to do A and C in parallel.++The algorithm works by first splitting the sequence of statements into+independent "segments", and a separate "tail" (the final statement). In+our example above, the segements would be++     [ x <- A+     , y <- B x ]++     [ z <- C ]++and the tail is:++     return (f x y z)++Then we take these segments and make an Applicative expression from them:++     (\(x,y) z -> return (f x y z))+       <$> do { x <- A; y <- B x; return (x,y) }+       <*> C++Finally, we recursively apply the transformation to each segment, to+discover any nested parallelism.++= Syntax & spec =++  expr ::= ... | do {stmt_1; ..; stmt_n} expr | ...++  stmt ::= pat <- expr+         | (arg_1 | ... | arg_n)  -- applicative composition, n>=1+         | ...                    -- other kinds of statement (e.g. let)++  arg ::= pat <- expr+        | {stmt_1; ..; stmt_n} {var_1..var_n}++(note that in the actual implementation,the expr in a do statement is+represented by a LastStmt as the final stmt, this is just a+representational issue and may change later.)++== Transformation to introduce applicative stmts ==++ado {} tail = tail+ado {pat <- expr} {return expr'} = (mkArg(pat <- expr)); return expr'+ado {one} tail = one : tail+ado stmts tail+  | n == 1 = ado before (ado after tail)+    where (before,after) = split(stmts_1)+  | n > 1  = (mkArg(stmts_1) | ... | mkArg(stmts_n)); tail+  where+    {stmts_1 .. stmts_n} = segments(stmts)++segments(stmts) =+  -- divide stmts into segments with no interdependencies++mkArg({pat <- expr}) = (pat <- expr)+mkArg({stmt_1; ...; stmt_n}) =+  {stmt_1; ...; stmt_n} {vars(stmt_1) u .. u vars(stmt_n)}++split({stmt_1; ..; stmt_n) =+  ({stmt_1; ..; stmt_i}, {stmt_i+1; ..; stmt_n})+  -- 1 <= i <= n+  -- i is a good place to insert a bind++== Desugaring for do ==++dsDo {} expr = expr++dsDo {pat <- rhs; stmts} expr =+   rhs >>= \pat -> dsDo stmts expr++dsDo {(arg_1 | ... | arg_n)} (return expr) =+  (\argpat (arg_1) .. argpat(arg_n) -> expr)+     <$> argexpr(arg_1)+     <*> ...+     <*> argexpr(arg_n)++dsDo {(arg_1 | ... | arg_n); stmts} expr =+  join (\argpat (arg_1) .. argpat(arg_n) -> dsDo stmts expr)+     <$> argexpr(arg_1)+     <*> ...+     <*> argexpr(arg_n)++-}++-- | The 'Name's of @return@ and @pure@. These may not be 'returnName' and+-- 'pureName' due to @RebindableSyntax@.+data MonadNames = MonadNames { return_name, pure_name :: Name }++-- | rearrange a list of statements using ApplicativeDoStmt.  See+-- Note [ApplicativeDo].+rearrangeForApplicativeDo+  :: HsStmtContext Name+  -> [(ExprLStmt GhcRn, FreeVars)]+  -> RnM ([ExprLStmt GhcRn], FreeVars)++rearrangeForApplicativeDo _ [] = return ([], emptyNameSet)+rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet)+rearrangeForApplicativeDo ctxt stmts0 = do+  optimal_ado <- goptM Opt_OptimalApplicativeDo+  let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts+                | otherwise = mkStmtTreeHeuristic stmts+  traceRn "rearrangeForADo" (ppr stmt_tree)+  return_name <- lookupSyntaxName' returnMName+  pure_name   <- lookupSyntaxName' pureAName+  let monad_names = MonadNames { return_name = return_name+                               , pure_name   = pure_name }+  stmtTreeToStmts monad_names ctxt stmt_tree [last] last_fvs+  where+    (stmts,(last,last_fvs)) = findLast stmts0+    findLast [] = error "findLast"+    findLast [last] = ([],last)+    findLast (x:xs) = (x:rest,last) where (rest,last) = findLast xs++-- | A tree of statements using a mixture of applicative and bind constructs.+data StmtTree a+  = StmtTreeOne a+  | StmtTreeBind (StmtTree a) (StmtTree a)+  | StmtTreeApplicative [StmtTree a]++instance Outputable a => Outputable (StmtTree a) where+  ppr (StmtTreeOne x)          = parens (text "StmtTreeOne" <+> ppr x)+  ppr (StmtTreeBind x y)       = parens (hang (text "StmtTreeBind")+                                            2 (sep [ppr x, ppr y]))+  ppr (StmtTreeApplicative xs) = parens (hang (text "StmtTreeApplicative")+                                            2 (vcat (map ppr xs)))++flattenStmtTree :: StmtTree a -> [a]+flattenStmtTree t = go t []+ where+  go (StmtTreeOne a) as = a : as+  go (StmtTreeBind l r) as = go l (go r as)+  go (StmtTreeApplicative ts) as = foldr go as ts++type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars)+type Cost = Int++-- | Turn a sequence of statements into an ExprStmtTree using a+-- heuristic algorithm.  /O(n^2)/+mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree+mkStmtTreeHeuristic [one] = StmtTreeOne one+mkStmtTreeHeuristic stmts =+  case segments stmts of+    [one] -> split one+    segs -> StmtTreeApplicative (map split segs)+ where+  split [one] = StmtTreeOne one+  split stmts =+    StmtTreeBind (mkStmtTreeHeuristic before) (mkStmtTreeHeuristic after)+    where (before, after) = splitSegment stmts++-- | Turn a sequence of statements into an ExprStmtTree optimally,+-- using dynamic programming.  /O(n^3)/+mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree+mkStmtTreeOptimal stmts =+  ASSERT(not (null stmts)) -- the empty case is handled by the caller;+                           -- we don't support empty StmtTrees.+  fst (arr ! (0,n))+  where+    n = length stmts - 1+    stmt_arr = listArray (0,n) stmts++    -- lazy cache of optimal trees for subsequences of the input+    arr :: Array (Int,Int) (ExprStmtTree, Cost)+    arr = array ((0,0),(n,n))+             [ ((lo,hi), tree lo hi)+             | lo <- [0..n]+             , hi <- [lo..n] ]++    -- compute the optimal tree for the sequence [lo..hi]+    tree lo hi+      | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)+      | otherwise =+         case segments [ stmt_arr ! i | i <- [lo..hi] ] of+           [] -> panic "mkStmtTree"+           [_one] -> split lo hi+           segs -> (StmtTreeApplicative trees, maximum costs)+             where+               bounds = scanl (\(_,hi) a -> (hi+1, hi + length a)) (0,lo-1) segs+               (trees,costs) = unzip (map (uncurry split) (tail bounds))++    -- find the best place to split the segment [lo..hi]+    split :: Int -> Int -> (ExprStmtTree, Cost)+    split lo hi+      | hi == lo = (StmtTreeOne (stmt_arr ! lo), 1)+      | otherwise = (StmtTreeBind before after, c1+c2)+        where+         -- As per the paper, for a sequence s1...sn, we want to find+         -- the split with the minimum cost, where the cost is the+         -- sum of the cost of the left and right subsequences.+         --+         -- As an optimisation (also in the paper) if the cost of+         -- s1..s(n-1) is different from the cost of s2..sn, we know+         -- that the optimal solution is the lower of the two.  Only+         -- in the case that these two have the same cost do we need+         -- to do the exhaustive search.+         --+         ((before,c1),(after,c2))+           | hi - lo == 1+           = ((StmtTreeOne (stmt_arr ! lo), 1),+              (StmtTreeOne (stmt_arr ! hi), 1))+           | left_cost < right_cost+           = ((left,left_cost), (StmtTreeOne (stmt_arr ! hi), 1))+           | left_cost > right_cost+           = ((StmtTreeOne (stmt_arr ! lo), 1), (right,right_cost))+           | otherwise = minimumBy (comparing cost) alternatives+           where+             (left, left_cost) = arr ! (lo,hi-1)+             (right, right_cost) = arr ! (lo+1,hi)+             cost ((_,c1),(_,c2)) = c1 + c2+             alternatives = [ (arr ! (lo,k), arr ! (k+1,hi))+                            | k <- [lo .. hi-1] ]+++-- | Turn the ExprStmtTree back into a sequence of statements, using+-- ApplicativeStmt where necessary.+stmtTreeToStmts+  :: MonadNames+  -> HsStmtContext Name+  -> ExprStmtTree+  -> [ExprLStmt GhcRn]             -- ^ the "tail"+  -> FreeVars                     -- ^ free variables of the tail+  -> RnM ( [ExprLStmt GhcRn]       -- ( output statements,+         , FreeVars )             -- , things we needed++-- If we have a single bind, and we can do it without a join, transform+-- to an ApplicativeStmt.  This corresponds to the rule+--   dsBlock [pat <- rhs] (return expr) = expr <$> rhs+-- In the spec, but we do it here rather than in the desugarer,+-- because we need the typechecker to typecheck the <$> form rather than+-- the bind form, which would give rise to a Monad constraint.+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BindStmt _ pat rhs _ _), _))+                tail _tail_fvs+  | not (isStrictPattern pat), (False,tail') <- needJoin monad_names tail+  -- See Note [ApplicativeDo and strict patterns]+  = mkApplicativeStmt ctxt [ApplicativeArgOne noExt pat rhs False] False tail'+stmtTreeToStmts monad_names ctxt (StmtTreeOne (L _ (BodyStmt _ rhs _ _),_))+                tail _tail_fvs+  | (False,tail') <- needJoin monad_names tail+  = mkApplicativeStmt ctxt+      [ApplicativeArgOne noExt nlWildPatName rhs True] False tail'++stmtTreeToStmts _monad_names _ctxt (StmtTreeOne (s,_)) tail _tail_fvs =+  return (s : tail, emptyNameSet)++stmtTreeToStmts monad_names ctxt (StmtTreeBind before after) tail tail_fvs = do+  (stmts1, fvs1) <- stmtTreeToStmts monad_names ctxt after tail tail_fvs+  let tail1_fvs = unionNameSets (tail_fvs : map snd (flattenStmtTree after))+  (stmts2, fvs2) <- stmtTreeToStmts monad_names ctxt before stmts1 tail1_fvs+  return (stmts2, fvs1 `plusFV` fvs2)++stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do+   pairs <- mapM (stmtTreeArg ctxt tail_fvs) trees+   let (stmts', fvss) = unzip pairs+   let (need_join, tail') = needJoin monad_names tail+   (stmts, fvs) <- mkApplicativeStmt ctxt stmts' need_join tail'+   return (stmts, unionNameSets (fvs:fvss))+ where+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BindStmt _ pat exp _ _), _))+     = return (ApplicativeArgOne noExt pat exp False, emptyFVs)+   stmtTreeArg _ctxt _tail_fvs (StmtTreeOne (L _ (BodyStmt _ exp _ _), _)) =+     return (ApplicativeArgOne noExt nlWildPatName exp True, emptyFVs)+   stmtTreeArg ctxt tail_fvs tree = do+     let stmts = flattenStmtTree tree+         pvarset = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)+                     `intersectNameSet` tail_fvs+         pvars = nameSetElemsStable pvarset+           -- See Note [Deterministic ApplicativeDo and RecursiveDo desugaring]+         pat = mkBigLHsVarPatTup pvars+         tup = mkBigLHsVarTup pvars+     (stmts',fvs2) <- stmtTreeToStmts monad_names ctxt tree [] pvarset+     (mb_ret, fvs1) <-+        if | L _ ApplicativeStmt{} <- last stmts' ->+             return (unLoc tup, emptyNameSet)+           | otherwise -> do+             (ret,fvs) <- lookupStmtNamePoly ctxt returnMName+             return (HsApp noExt (noLoc ret) tup, fvs)+     return ( ApplicativeArgMany noExt stmts' mb_ret pat+            , fvs1 `plusFV` fvs2)+++-- | Divide a sequence of statements into segments, where no segment+-- depends on any variables defined by a statement in another segment.+segments+  :: [(ExprLStmt GhcRn, FreeVars)]+  -> [[(ExprLStmt GhcRn, FreeVars)]]+segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts)+  where+    allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts)++    -- We would rather not have a segment that just has LetStmts in+    -- it, so combine those with an adjacent segment where possible.+    merge [] = []+    merge (seg : segs)+       = case rest of+          [] -> [(seg,all_lets)]+          ((s,s_lets):ss) | all_lets || s_lets+               -> (seg ++ s, all_lets && s_lets) : ss+          _otherwise -> (seg,all_lets) : rest+      where+        rest = merge segs+        all_lets = all (isLetStmt . fst) seg++    -- walk splits the statement sequence into segments, traversing+    -- the sequence from the back to the front, and keeping track of+    -- the set of free variables of the current segment.  Whenever+    -- this set of free variables is empty, we have a complete segment.+    walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]]+    walk [] = []+    walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest+      where (seg,rest) = chunter fvs' stmts+            (_, fvs') = stmtRefs stmt fvs++    chunter _ [] = ([], [])+    chunter vars ((stmt,fvs) : rest)+       | not (isEmptyNameSet vars)+       || isStrictPatternBind stmt+           -- See Note [ApplicativeDo and strict patterns]+       = ((stmt,fvs) : chunk, rest')+       where (chunk,rest') = chunter vars' rest+             (pvars, evars) = stmtRefs stmt fvs+             vars' = (vars `minusNameSet` pvars) `unionNameSet` evars+    chunter _ rest = ([], rest)++    stmtRefs stmt fvs+      | isLetStmt stmt = (pvars, fvs' `minusNameSet` pvars)+      | otherwise      = (pvars, fvs')+      where fvs' = fvs `intersectNameSet` allvars+            pvars = mkNameSet (collectStmtBinders (unLoc stmt))++    isStrictPatternBind :: ExprLStmt GhcRn -> Bool+    isStrictPatternBind (L _ (BindStmt _ pat _ _ _)) = isStrictPattern pat+    isStrictPatternBind _ = False++{-+Note [ApplicativeDo and strict patterns]++A strict pattern match is really a dependency.  For example,++do+  (x,y) <- A+  z <- B+  return C++The pattern (_,_) must be matched strictly before we do B.  If we+allowed this to be transformed into++  (\(x,y) -> \z -> C) <$> A <*> B++then it could be lazier than the standard desuraging using >>=.  See #13875+for more examples.++Thus, whenever we have a strict pattern match, we treat it as a+dependency between that statement and the following one.  The+dependency prevents those two statements from being performed "in+parallel" in an ApplicativeStmt, but doesn't otherwise affect what we+can do with the rest of the statements in the same "do" expression.+-}++isStrictPattern :: LPat (GhcPass p) -> Bool+isStrictPattern lpat =+  case unLoc lpat of+    WildPat{}       -> False+    VarPat{}        -> False+    LazyPat{}       -> False+    AsPat _ _ p     -> isStrictPattern p+    ParPat _ p      -> isStrictPattern p+    ViewPat _ _ p   -> isStrictPattern p+    SigPat _ p _    -> isStrictPattern p+    BangPat{}       -> True+    ListPat{}       -> True+    TuplePat{}      -> True+    SumPat{}        -> True+    ConPatIn{}      -> True+    ConPatOut{}     -> True+    LitPat{}        -> True+    NPat{}          -> True+    NPlusKPat{}     -> True+    SplicePat{}     -> True+    _otherwise -> panic "isStrictPattern"++isLetStmt :: LStmt a b -> Bool+isLetStmt (L _ LetStmt{}) = True+isLetStmt _ = False++-- | Find a "good" place to insert a bind in an indivisible segment.+-- This is the only place where we use heuristics.  The current+-- heuristic is to peel off the first group of independent statements+-- and put the bind after those.+splitSegment+  :: [(ExprLStmt GhcRn, FreeVars)]+  -> ( [(ExprLStmt GhcRn, FreeVars)]+     , [(ExprLStmt GhcRn, FreeVars)] )+splitSegment [one,two] = ([one],[two])+  -- there is no choice when there are only two statements; this just saves+  -- some work in a common case.+splitSegment stmts+  | Just (lets,binds,rest) <- slurpIndependentStmts stmts+  =  if not (null lets)+       then (lets, binds++rest)+       else (lets++binds, rest)+  | otherwise+  = case stmts of+      (x:xs) -> ([x],xs)+      _other -> (stmts,[])++slurpIndependentStmts+   :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)]+   -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts+            , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts+            , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] )+slurpIndependentStmts stmts = go [] [] emptyNameSet stmts+ where+  -- If we encounter a BindStmt that doesn't depend on a previous BindStmt+  -- in this group, then add it to the group. We have to be careful about+  -- strict patterns though; splitSegments expects that if we return Just+  -- then we have actually done some splitting. Otherwise it will go into+  -- an infinite loop (#14163).+  go lets indep bndrs ((L loc (BindStmt _ pat body bind_op fail_op), fvs): rest)+    | isEmptyNameSet (bndrs `intersectNameSet` fvs) && not (isStrictPattern pat)+    = go lets ((L loc (BindStmt noExt pat body bind_op fail_op), fvs) : indep)+         bndrs' rest+    where bndrs' = bndrs `unionNameSet` mkNameSet (collectPatBinders pat)+  -- If we encounter a LetStmt that doesn't depend on a BindStmt in this+  -- group, then move it to the beginning, so that it doesn't interfere with+  -- grouping more BindStmts.+  -- TODO: perhaps we shouldn't do this if there are any strict bindings,+  -- because we might be moving evaluation earlier.+  go lets indep bndrs ((L loc (LetStmt noExt binds), fvs) : rest)+    | isEmptyNameSet (bndrs `intersectNameSet` fvs)+    = go ((L loc (LetStmt noExt binds), fvs) : lets) indep bndrs rest+  go _ []  _ _ = Nothing+  go _ [_] _ _ = Nothing+  go lets indep _ stmts = Just (reverse lets, reverse indep, stmts)++-- | Build an ApplicativeStmt, and strip the "return" from the tail+-- if necessary.+--+-- For example, if we start with+--   do x <- E1; y <- E2; return (f x y)+-- then we get+--   do (E1[x] | E2[y]); f x y+--+-- the LastStmt in this case has the return removed, but we set the+-- flag on the LastStmt to indicate this, so that we can print out the+-- original statement correctly in error messages.  It is easier to do+-- it this way rather than try to ignore the return later in both the+-- typechecker and the desugarer (I tried it that way first!).+mkApplicativeStmt+  :: HsStmtContext Name+  -> [ApplicativeArg GhcRn]             -- ^ The args+  -> Bool                               -- ^ True <=> need a join+  -> [ExprLStmt GhcRn]        -- ^ The body statements+  -> RnM ([ExprLStmt GhcRn], FreeVars)+mkApplicativeStmt ctxt args need_join body_stmts+  = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName+       ; (ap_op, fvs2) <- lookupStmtName ctxt apAName+       ; (mb_join, fvs3) <-+           if need_join then+             do { (join_op, fvs) <- lookupStmtName ctxt joinMName+                ; return (Just join_op, fvs) }+           else+             return (Nothing, emptyNameSet)+       ; let applicative_stmt = noLoc $ ApplicativeStmt noExt+               (zip (fmap_op : repeat ap_op) args)+               mb_join+       ; return ( applicative_stmt : body_stmts+                , fvs1 `plusFV` fvs2 `plusFV` fvs3) }++-- | Given the statements following an ApplicativeStmt, determine whether+-- we need a @join@ or not, and remove the @return@ if necessary.+needJoin :: MonadNames+         -> [ExprLStmt GhcRn]+         -> (Bool, [ExprLStmt GhcRn])+needJoin _monad_names [] = (False, [])  -- we're in an ApplicativeArg+needJoin monad_names  [L loc (LastStmt _ e _ t)]+ | Just arg <- isReturnApp monad_names e =+       (False, [L loc (LastStmt noExt arg True t)])+needJoin _monad_names stmts = (True, stmts)++-- | @Just e@, if the expression is @return e@ or @return $ e@,+-- otherwise @Nothing@+isReturnApp :: MonadNames+            -> LHsExpr GhcRn+            -> Maybe (LHsExpr GhcRn)+isReturnApp monad_names (L _ (HsPar _ expr)) = isReturnApp monad_names expr+isReturnApp monad_names (L _ e) = case e of+  OpApp _ l op r | is_return l, is_dollar op -> Just r+  HsApp _ f arg  | is_return f               -> Just arg+  _otherwise -> Nothing+ where+  is_var f (L _ (HsPar _ e)) = is_var f e+  is_var f (L _ (HsAppType _ e _)) = is_var f e+  is_var f (L _ (HsVar _ (L _ r))) = f r+       -- TODO: I don't know how to get this right for rebindable syntax+  is_var _ _ = False++  is_return = is_var (\n -> n == return_name monad_names+                         || n == pure_name monad_names)+  is_dollar = is_var (`hasKey` dollarIdKey)++{-+************************************************************************+*                                                                      *+\subsubsection{Errors}+*                                                                      *+************************************************************************+-}++checkEmptyStmts :: HsStmtContext Name -> RnM ()+-- We've seen an empty sequence of Stmts... is that ok?+checkEmptyStmts ctxt+  = unless (okEmpty ctxt) (addErr (emptyErr ctxt))++okEmpty :: HsStmtContext a -> Bool+okEmpty (PatGuard {}) = True+okEmpty _             = False++emptyErr :: HsStmtContext Name -> SDoc+emptyErr (ParStmtCtxt {})   = text "Empty statement group in parallel comprehension"+emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or 'then'"+emptyErr ctxt               = text "Empty" <+> pprStmtContext ctxt++----------------------+checkLastStmt :: Outputable (body GhcPs) => HsStmtContext Name+              -> LStmt GhcPs (Located (body GhcPs))+              -> RnM (LStmt GhcPs (Located (body GhcPs)))+checkLastStmt ctxt lstmt@(L loc stmt)+  = case ctxt of+      ListComp  -> check_comp+      MonadComp -> check_comp+      ArrowExpr -> check_do+      DoExpr    -> check_do+      MDoExpr   -> check_do+      _         -> check_other+  where+    check_do    -- Expect BodyStmt, and change it to LastStmt+      = case stmt of+          BodyStmt _ e _ _ -> return (L loc (mkLastStmt e))+          LastStmt {}      -> return lstmt   -- "Deriving" clauses may generate a+                                             -- LastStmt directly (unlike the parser)+          _                -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt }+    last_error = (text "The last statement in" <+> pprAStmtContext ctxt+                  <+> text "must be an expression")++    check_comp  -- Expect LastStmt; this should be enforced by the parser!+      = case stmt of+          LastStmt {} -> return lstmt+          _           -> pprPanic "checkLastStmt" (ppr lstmt)++    check_other -- Behave just as if this wasn't the last stmt+      = do { checkStmt ctxt lstmt; return lstmt }++-- Checking when a particular Stmt is ok+checkStmt :: HsStmtContext Name+          -> LStmt GhcPs (Located (body GhcPs))+          -> RnM ()+checkStmt ctxt (L _ stmt)+  = do { dflags <- getDynFlags+       ; case okStmt dflags ctxt stmt of+           IsValid        -> return ()+           NotValid extra -> addErr (msg $$ extra) }+  where+   msg = sep [ text "Unexpected" <+> pprStmtCat stmt <+> ptext (sLit "statement")+             , text "in" <+> pprAStmtContext ctxt ]++pprStmtCat :: Stmt a body -> SDoc+pprStmtCat (TransStmt {})     = text "transform"+pprStmtCat (LastStmt {})      = text "return expression"+pprStmtCat (BodyStmt {})      = text "body"+pprStmtCat (BindStmt {})      = text "binding"+pprStmtCat (LetStmt {})       = text "let"+pprStmtCat (RecStmt {})       = text "rec"+pprStmtCat (ParStmt {})       = text "parallel"+pprStmtCat (ApplicativeStmt {}) = panic "pprStmtCat: ApplicativeStmt"+pprStmtCat (XStmtLR {})         = panic "pprStmtCat: XStmtLR"++------------+emptyInvalid :: Validity  -- Payload is the empty document+emptyInvalid = NotValid Outputable.empty++okStmt, okDoStmt, okCompStmt, okParStmt+   :: DynFlags -> HsStmtContext Name+   -> Stmt GhcPs (Located (body GhcPs)) -> Validity+-- Return Nothing if OK, (Just extra) if not ok+-- The "extra" is an SDoc that is appended to a generic error message++okStmt dflags ctxt stmt+  = case ctxt of+      PatGuard {}        -> okPatGuardStmt stmt+      ParStmtCtxt ctxt   -> okParStmt  dflags ctxt stmt+      DoExpr             -> okDoStmt   dflags ctxt stmt+      MDoExpr            -> okDoStmt   dflags ctxt stmt+      ArrowExpr          -> okDoStmt   dflags ctxt stmt+      GhciStmtCtxt       -> okDoStmt   dflags ctxt stmt+      ListComp           -> okCompStmt dflags ctxt stmt+      MonadComp          -> okCompStmt dflags ctxt stmt+      TransStmtCtxt ctxt -> okStmt dflags ctxt stmt++-------------+okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity+okPatGuardStmt stmt+  = case stmt of+      BodyStmt {} -> IsValid+      BindStmt {} -> IsValid+      LetStmt {}  -> IsValid+      _           -> emptyInvalid++-------------+okParStmt dflags ctxt stmt+  = case stmt of+      LetStmt _ (L _ (HsIPBinds {})) -> emptyInvalid+      _                              -> okStmt dflags ctxt stmt++----------------+okDoStmt dflags ctxt stmt+  = case stmt of+       RecStmt {}+         | LangExt.RecursiveDo `xopt` dflags -> IsValid+         | ArrowExpr <- ctxt -> IsValid    -- Arrows allows 'rec'+         | otherwise         -> NotValid (text "Use RecursiveDo")+       BindStmt {} -> IsValid+       LetStmt {}  -> IsValid+       BodyStmt {} -> IsValid+       _           -> emptyInvalid++----------------+okCompStmt dflags _ stmt+  = case stmt of+       BindStmt {} -> IsValid+       LetStmt {}  -> IsValid+       BodyStmt {} -> IsValid+       ParStmt {}+         | LangExt.ParallelListComp `xopt` dflags -> IsValid+         | otherwise -> NotValid (text "Use ParallelListComp")+       TransStmt {}+         | LangExt.TransformListComp `xopt` dflags -> IsValid+         | otherwise -> NotValid (text "Use TransformListComp")+       RecStmt {}  -> emptyInvalid+       LastStmt {} -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)+       ApplicativeStmt {} -> emptyInvalid+       XStmtLR{} -> panic "okCompStmt"++---------+checkTupleSection :: [LHsTupArg GhcPs] -> RnM ()+checkTupleSection args+  = do  { tuple_section <- xoptM LangExt.TupleSections+        ; checkErr (all tupArgPresent args || tuple_section) msg }+  where+    msg = text "Illegal tuple section: use TupleSections"++---------+sectionErr :: HsExpr GhcPs -> SDoc+sectionErr expr+  = hang (text "A section must be enclosed in parentheses")+       2 (text "thus:" <+> (parens (ppr expr)))++badIpBinds :: Outputable a => SDoc -> a -> SDoc+badIpBinds what binds+  = hang (text "Implicit-parameter bindings illegal in" <+> what)+         2 (ppr binds)++---------++monadFailOp :: LPat GhcPs+            -> HsStmtContext Name+            -> RnM (SyntaxExpr GhcRn, FreeVars)+monadFailOp pat ctxt+  -- If the pattern is irrefutable (e.g.: wildcard, tuple, ~pat, etc.)+  -- we should not need to fail.+  | isIrrefutableHsPat pat = return (noSyntaxExpr, emptyFVs)++  -- For non-monadic contexts (e.g. guard patterns, list+  -- comprehensions, etc.) we should not need to fail.  See Note+  -- [Failing pattern matches in Stmts]+  | not (isMonadFailStmtContext ctxt) = return (noSyntaxExpr, emptyFVs)++  | otherwise = getMonadFailOp++{-+Note [Monad fail : Rebindable syntax, overloaded strings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Given the code+  foo x = do { Just y <- x; return y }++we expect it to desugar as+  foo x = x >>= \r -> case r of+                        Just y  -> return y+                        Nothing -> fail "Pattern match error"++But with RebindableSyntax and OverloadedStrings, we really want+it to desugar thus:+  foo x = x >>= \r -> case r of+                        Just y  -> return y+                        Nothing -> fail (fromString "Patterm match error")++So, in this case, we synthesize the function+  \x -> fail (fromString x)++(rather than plain 'fail') for the 'fail' operation. This is done in+'getMonadFailOp'.+-}+getMonadFailOp :: RnM (SyntaxExpr GhcRn, FreeVars) -- Syntax expr fail op+getMonadFailOp+ = do { xOverloadedStrings <- fmap (xopt LangExt.OverloadedStrings) getDynFlags+      ; xRebindableSyntax <- fmap (xopt LangExt.RebindableSyntax) getDynFlags+      ; reallyGetMonadFailOp xRebindableSyntax xOverloadedStrings+      }+  where+    reallyGetMonadFailOp rebindableSyntax overloadedStrings+      | rebindableSyntax && overloadedStrings = do+        (failExpr, failFvs) <- lookupSyntaxName failMName+        (fromStringExpr, fromStringFvs) <- lookupSyntaxName fromStringName+        let arg_lit = fsLit "arg"+            arg_name = mkSystemVarName (mkVarOccUnique arg_lit) arg_lit+            arg_syn_expr = mkRnSyntaxExpr arg_name+        let body :: LHsExpr GhcRn =+              nlHsApp (noLoc $ syn_expr failExpr)+                      (nlHsApp (noLoc $ syn_expr fromStringExpr)+                                (noLoc $ syn_expr arg_syn_expr))+        let failAfterFromStringExpr :: HsExpr GhcRn =+              unLoc $ mkHsLam [noLoc $ VarPat noExt $ noLoc arg_name] body+        let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =+              mkSyntaxExpr failAfterFromStringExpr+        return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)+      | otherwise = lookupSyntaxName failMName
+ compiler/rename/RnExpr.hs-boot view
@@ -0,0 +1,17 @@+module RnExpr where+import Name+import HsSyn+import NameSet     ( FreeVars )+import TcRnTypes+import SrcLoc      ( Located )+import Outputable  ( Outputable )++rnLExpr :: LHsExpr GhcPs+        -> RnM (LHsExpr GhcRn, FreeVars)++rnStmts :: --forall thing body.+           Outputable (body GhcPs) => HsStmtContext Name+        -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars))+        -> [LStmt GhcPs (Located (body GhcPs))]+        -> ([Name] -> RnM (thing, FreeVars))+        -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars)
+ compiler/rename/RnFixity.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE ViewPatterns #-}++{-++This module contains code which maintains and manipulates the+fixity environment during renaming.++-}+module RnFixity ( MiniFixityEnv,+                  addLocalFixities,+  lookupFixityRn, lookupFixityRn_help,+  lookupFieldFixityRn, lookupTyFixityRn ) where++import GhcPrelude++import LoadIface+import HsSyn+import RdrName+import HscTypes+import TcRnMonad+import Name+import NameEnv+import Module+import BasicTypes       ( Fixity(..), FixityDirection(..), minPrecedence,+                          defaultFixity, SourceText(..) )+import SrcLoc+import Outputable+import Maybes+import Data.List+import Data.Function    ( on )+import RnUnbound++{-+*********************************************************+*                                                      *+                Fixities+*                                                      *+*********************************************************++Note [Fixity signature lookup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A fixity declaration like++    infixr 2 ?++can refer to a value-level operator, e.g.:++    (?) :: String -> String -> String++or a type-level operator, like:++    data (?) a b = A a | B b++so we extend the lookup of the reader name '?' to the TcClsName namespace, as+well as the original namespace.++The extended lookup is also used in other places, like resolution of+deprecation declarations, and lookup of names in GHCi.+-}++--------------------------------+type MiniFixityEnv = FastStringEnv (Located Fixity)+        -- Mini fixity env for the names we're about+        -- to bind, in a single binding group+        --+        -- It is keyed by the *FastString*, not the *OccName*, because+        -- the single fixity decl       infix 3 T+        -- affects both the data constructor T and the type constrctor T+        --+        -- We keep the location so that if we find+        -- a duplicate, we can report it sensibly++--------------------------------+-- Used for nested fixity decls to bind names along with their fixities.+-- the fixities are given as a UFM from an OccName's FastString to a fixity decl++addLocalFixities :: MiniFixityEnv -> [Name] -> RnM a -> RnM a+addLocalFixities mini_fix_env names thing_inside+  = extendFixityEnv (mapMaybe find_fixity names) thing_inside+  where+    find_fixity name+      = case lookupFsEnv mini_fix_env (occNameFS occ) of+          Just lfix -> Just (name, FixItem occ (unLoc lfix))+          Nothing   -> Nothing+      where+        occ = nameOccName name++{-+--------------------------------+lookupFixity is a bit strange.++* Nested local fixity decls are put in the local fixity env, which we+  find with getFixtyEnv++* Imported fixities are found in the PIT++* Top-level fixity decls in this module may be for Names that are+    either  Global         (constructors, class operations)+    or      Local/Exported (everything else)+  (See notes with RnNames.getLocalDeclBinders for why we have this split.)+  We put them all in the local fixity environment+-}++lookupFixityRn :: Name -> RnM Fixity+lookupFixityRn name = lookupFixityRn' name (nameOccName name)++lookupFixityRn' :: Name -> OccName -> RnM Fixity+lookupFixityRn' name = fmap snd . lookupFixityRn_help' name++-- | 'lookupFixityRn_help' returns @(True, fixity)@ if it finds a 'Fixity'+-- in a local environment or from an interface file. Otherwise, it returns+-- @(False, fixity)@ (e.g., for unbound 'Name's or 'Name's without+-- user-supplied fixity declarations).+lookupFixityRn_help :: Name+                    -> RnM (Bool, Fixity)+lookupFixityRn_help name =+    lookupFixityRn_help' name (nameOccName name)++lookupFixityRn_help' :: Name+                     -> OccName+                     -> RnM (Bool, Fixity)+lookupFixityRn_help' name occ+  | isUnboundName name+  = return (False, Fixity NoSourceText minPrecedence InfixL)+    -- Minimise errors from ubound names; eg+    --    a>0 `foo` b>0+    -- where 'foo' is not in scope, should not give an error (#7937)++  | otherwise+  = do { local_fix_env <- getFixityEnv+       ; case lookupNameEnv local_fix_env name of {+           Just (FixItem _ fix) -> return (True, fix) ;+           Nothing ->++    do { this_mod <- getModule+       ; if nameIsLocalOrFrom this_mod name+               -- Local (and interactive) names are all in the+               -- fixity env, and don't have entries in the HPT+         then return (False, defaultFixity)+         else lookup_imported } } }+  where+    lookup_imported+      -- For imported names, we have to get their fixities by doing a+      -- loadInterfaceForName, and consulting the Ifaces that comes back+      -- from that, because the interface file for the Name might not+      -- have been loaded yet.  Why not?  Suppose you import module A,+      -- which exports a function 'f', thus;+      --        module CurrentModule where+      --          import A( f )+      --        module A( f ) where+      --          import B( f )+      -- Then B isn't loaded right away (after all, it's possible that+      -- nothing from B will be used).  When we come across a use of+      -- 'f', we need to know its fixity, and it's then, and only+      -- then, that we load B.hi.  That is what's happening here.+      --+      -- loadInterfaceForName will find B.hi even if B is a hidden module,+      -- and that's what we want.+      = do { iface <- loadInterfaceForName doc name+           ; let mb_fix = mi_fix_fn iface occ+           ; let msg = case mb_fix of+                            Nothing ->+                                  text "looking up name" <+> ppr name+                              <+> text "in iface, but found no fixity for it."+                              <+> text "Using default fixity instead."+                            Just f ->+                                  text "looking up name in iface and found:"+                              <+> vcat [ppr name, ppr f]+           ; traceRn "lookupFixityRn_either:" msg+           ; return (maybe (False, defaultFixity) (\f -> (True, f)) mb_fix)  }++    doc = text "Checking fixity for" <+> ppr name++---------------+lookupTyFixityRn :: Located Name -> RnM Fixity+lookupTyFixityRn = lookupFixityRn . unLoc++-- | Look up the fixity of a (possibly ambiguous) occurrence of a record field+-- selector.  We use 'lookupFixityRn'' so that we can specifiy the 'OccName' as+-- the field label, which might be different to the 'OccName' of the selector+-- 'Name' if @DuplicateRecordFields@ is in use (#1173). If there are+-- multiple possible selectors with different fixities, generate an error.+lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity+lookupFieldFixityRn (Unambiguous n lrdr)+  = lookupFixityRn' n (rdrNameOcc (unLoc lrdr))+lookupFieldFixityRn (Ambiguous _ lrdr) = get_ambiguous_fixity (unLoc lrdr)+  where+    get_ambiguous_fixity :: RdrName -> RnM Fixity+    get_ambiguous_fixity rdr_name = do+      traceRn "get_ambiguous_fixity" (ppr rdr_name)+      rdr_env <- getGlobalRdrEnv+      let elts =  lookupGRE_RdrName rdr_name rdr_env++      fixities <- groupBy ((==) `on` snd) . zip elts+                  <$> mapM lookup_gre_fixity elts++      case fixities of+        -- There should always be at least one fixity.+        -- Something's very wrong if there are no fixity candidates, so panic+        [] -> panic "get_ambiguous_fixity: no candidates for a given RdrName"+        [ (_, fix):_ ] -> return fix+        ambigs -> addErr (ambiguous_fixity_err rdr_name ambigs)+                  >> return (Fixity NoSourceText minPrecedence InfixL)++    lookup_gre_fixity gre = lookupFixityRn' (gre_name gre) (greOccName gre)++    ambiguous_fixity_err rn ambigs+      = vcat [ text "Ambiguous fixity for record field" <+> quotes (ppr rn)+             , hang (text "Conflicts: ") 2 . vcat .+               map format_ambig $ concat ambigs ]++    format_ambig (elt, fix) = hang (ppr fix)+                                 2 (pprNameProvenance elt)+lookupFieldFixityRn (XAmbiguousFieldOcc{}) = panic "lookupFieldFixityRn"
+ compiler/rename/RnHsDoc.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE ViewPatterns #-}++module RnHsDoc ( rnHsDoc, rnLHsDoc, rnMbLHsDoc ) where++import GhcPrelude++import TcRnTypes+import HsSyn+import SrcLoc+++rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString)+rnMbLHsDoc mb_doc = case mb_doc of+  Just doc -> do+    doc' <- rnLHsDoc doc+    return (Just doc')+  Nothing -> return Nothing++rnLHsDoc :: LHsDocString -> RnM LHsDocString+rnLHsDoc (dL->L pos doc) = do+  doc' <- rnHsDoc doc+  return (cL pos doc')++rnHsDoc :: HsDocString -> RnM HsDocString+rnHsDoc = pure
+ compiler/rename/RnNames.hs view
@@ -0,0 +1,1781 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[RnNames]{Extracting imported and top-level names in scope}+-}++{-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module RnNames (+        rnImports, getLocalNonValBinders, newRecordSelector,+        extendGlobalRdrEnvRn,+        gresFromAvails,+        calculateAvails,+        reportUnusedNames,+        checkConName,+        mkChildEnv,+        findChildren,+        dodgyMsg,+        dodgyMsgInsert,+        findImportUsage,+        getMinimalImports,+        printMinimalImports,+        ImportDeclUsage+    ) where++#include "HsVersions.h"++import GhcPrelude++import DynFlags+import HsSyn+import TcEnv+import RnEnv+import RnFixity+import RnUtils          ( warnUnusedTopBinds, mkFieldEnv )+import LoadIface        ( loadSrcInterface )+import TcRnMonad+import PrelNames+import Module+import Name+import NameEnv+import NameSet+import Avail+import FieldLabel+import HscTypes+import RdrName+import RdrHsSyn        ( setRdrNameSpace )+import Outputable+import Maybes+import SrcLoc+import BasicTypes      ( TopLevelFlag(..), StringLiteral(..) )+import Util+import FastString+import FastStringEnv+import Id+import Type+import PatSyn+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.Either      ( partitionEithers, isRight, rights )+import Data.Map         ( Map )+import qualified Data.Map as Map+import Data.Ord         ( comparing )+import Data.List        ( partition, (\\), find, sortBy )+import qualified Data.Set as S+import System.FilePath  ((</>))++import System.IO++{-+************************************************************************+*                                                                      *+\subsection{rnImports}+*                                                                      *+************************************************************************++Note [Tracking Trust Transitively]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we import a package as well as checking that the direct imports are safe+according to the rules outlined in the Note [HscMain . Safe Haskell Trust Check]+we must also check that these rules hold transitively for all dependent modules+and packages. Doing this without caching any trust information would be very+slow as we would need to touch all packages and interface files a module depends+on. To avoid this we make use of the property that if a modules Safe Haskell+mode changes, this triggers a recompilation from that module in the dependcy+graph. So we can just worry mostly about direct imports.++There is one trust property that can change for a package though without+recompliation being triggered: package trust. So we must check that all+packages a module tranitively depends on to be trusted are still trusted when+we are compiling this module (as due to recompilation avoidance some modules+below may not be considered trusted any more without recompilation being+triggered).++We handle this by augmenting the existing transitive list of packages a module M+depends on with a bool for each package that says if it must be trusted when the+module M is being checked for trust. This list of trust required packages for a+single import is gathered in the rnImportDecl function and stored in an+ImportAvails data structure. The union of these trust required packages for all+imports is done by the rnImports function using the combine function which calls+the plusImportAvails function that is a union operation for the ImportAvails+type. This gives us in an ImportAvails structure all packages required to be+trusted for the module we are currently compiling. Checking that these packages+are still trusted (and that direct imports are trusted) is done in+HscMain.checkSafeImports.++See the note below, [Trust Own Package] for a corner case in this method and+how its handled.+++Note [Trust Own Package]+~~~~~~~~~~~~~~~~~~~~~~~~+There is a corner case of package trust checking that the usual transitive check+doesn't cover. (For how the usual check operates see the Note [Tracking Trust+Transitively] below). The case is when you import a -XSafe module M and M+imports a -XTrustworthy module N. If N resides in a different package than M,+then the usual check works as M will record a package dependency on N's package+and mark it as required to be trusted. If N resides in the same package as M+though, then importing M should require its own package be trusted due to N+(since M is -XSafe so doesn't create this requirement by itself). The usual+check fails as a module doesn't record a package dependency of its own package.+So instead we now have a bool field in a modules interface file that simply+states if the module requires its own package to be trusted. This field avoids+us having to load all interface files that the module depends on to see if one+is trustworthy.+++Note [Trust Transitive Property]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+So there is an interesting design question in regards to transitive trust+checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch+of modules and packages, some packages it requires to be trusted as its using+-XTrustworthy modules from them. Now if I have a module A that doesn't use safe+haskell at all and simply imports B, should A inherit all the trust+requirements from B? Should A now also require that a package p is trusted since+B required it?++We currently say no but saying yes also makes sense. The difference is, if a+module M that doesn't use Safe Haskell imports a module N that does, should all+the trusted package requirements be dropped since M didn't declare that it cares+about Safe Haskell (so -XSafe is more strongly associated with the module doing+the importing) or should it be done still since the author of the module N that+uses Safe Haskell said they cared (so -XSafe is more strongly associated with+the module that was compiled that used it).++Going with yes is a simpler semantics we think and harder for the user to stuff+up but it does mean that Safe Haskell will affect users who don't care about+Safe Haskell as they might grab a package from Cabal which uses safe haskell (say+network) and that packages imports -XTrustworthy modules from another package+(say bytestring), so requires that package is trusted. The user may now get+compilation errors in code that doesn't do anything with Safe Haskell simply+because they are using the network package. They will have to call 'ghc-pkg+trust network' to get everything working. Due to this invasive nature of going+with yes we have gone with no for now.+-}++-- | Process Import Decls.  See 'rnImportDecl' for a description of what+-- the return types represent.+-- Note: Do the non SOURCE ones first, so that we get a helpful warning+-- for SOURCE ones that are unnecessary+rnImports :: [LImportDecl GhcPs]+          -> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)+rnImports imports = do+    tcg_env <- getGblEnv+    -- NB: want an identity module here, because it's OK for a signature+    -- module to import from its implementor+    let this_mod = tcg_mod tcg_env+    let (source, ordinary) = partition is_source_import imports+        is_source_import d = ideclSource (unLoc d)+    stuff1 <- mapAndReportM (rnImportDecl this_mod) ordinary+    stuff2 <- mapAndReportM (rnImportDecl this_mod) source+    -- Safe Haskell: See Note [Tracking Trust Transitively]+    let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2)+    return (decls, rdr_env, imp_avails, hpc_usage)++  where+    -- See Note [Combining ImportAvails]+    combine :: [(LImportDecl GhcRn,  GlobalRdrEnv, ImportAvails, AnyHpcUsage)]+            -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage)+    combine ss =+      let (decls, rdr_env, imp_avails, hpc_usage, finsts) = foldr+            plus+            ([], emptyGlobalRdrEnv, emptyImportAvails, False, emptyModuleSet)+            ss+      in (decls, rdr_env, imp_avails { imp_finsts = moduleSetElts finsts },+            hpc_usage)++    plus (decl,  gbl_env1, imp_avails1, hpc_usage1)+         (decls, gbl_env2, imp_avails2, hpc_usage2, finsts_set)+      = ( decl:decls,+          gbl_env1 `plusGlobalRdrEnv` gbl_env2,+          imp_avails1' `plusImportAvails` imp_avails2,+          hpc_usage1 || hpc_usage2,+          extendModuleSetList finsts_set new_finsts )+      where+      imp_avails1' = imp_avails1 { imp_finsts = [] }+      new_finsts = imp_finsts imp_avails1++{-+Note [Combining ImportAvails]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+imp_finsts in ImportAvails is a list of family instance modules+transitively depended on by an import. imp_finsts for a currently+compiled module is a union of all the imp_finsts of imports.+Computing the union of two lists of size N is O(N^2) and if we+do it to M imports we end up with O(M*N^2). That can get very+expensive for bigger module hierarchies.++Union can be optimized to O(N log N) if we use a Set.+imp_finsts is converted back and forth between dep_finsts, so+changing a type of imp_finsts means either paying for the conversions+or changing the type of dep_finsts as well.++I've measured that the conversions would cost 20% of allocations on my+test case, so that can be ruled out.++Changing the type of dep_finsts forces checkFamInsts to+get the module lists in non-deterministic order. If we wanted to restore+the deterministic order, we'd have to sort there, which is an additional+cost. As far as I can tell, using a non-deterministic order is fine there,+but that's a brittle nonlocal property which I'd like to avoid.++Additionally, dep_finsts is read from an interface file, so its "natural"+type is a list. Which makes it a natural type for imp_finsts.++Since rnImports.combine is really the only place that would benefit from+it being a Set, it makes sense to optimize the hot loop in rnImports.combine+without changing the representation.++So here's what we do: instead of naively merging ImportAvails with+plusImportAvails in a loop, we make plusImportAvails merge empty imp_finsts+and compute the union on the side using Sets. When we're done, we can+convert it back to a list. One nice side effect of this approach is that+if there's a lot of overlap in the imp_finsts of imports, the+Set doesn't really need to grow and we don't need to allocate.++Running generateModules from #14693 with DEPTH=16, WIDTH=30 finishes in+23s before, and 11s after.+-}++++-- | Given a located import declaration @decl@ from @this_mod@,+-- calculate the following pieces of information:+--+--  1. An updated 'LImportDecl', where all unresolved 'RdrName' in+--     the entity lists have been resolved into 'Name's,+--+--  2. A 'GlobalRdrEnv' representing the new identifiers that were+--     brought into scope (taking into account module qualification+--     and hiding),+--+--  3. 'ImportAvails' summarizing the identifiers that were imported+--     by this declaration, and+--+--  4. A boolean 'AnyHpcUsage' which is true if the imported module+--     used HPC.+rnImportDecl  :: Module -> LImportDecl GhcPs+             -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)+rnImportDecl this_mod+             (L loc decl@(ImportDecl { ideclExt = noExt+                                     , ideclName = loc_imp_mod_name+                                     , ideclPkgQual = mb_pkg+                                     , ideclSource = want_boot, ideclSafe = mod_safe+                                     , ideclQualified = qual_style, ideclImplicit = implicit+                                     , ideclAs = as_mod, ideclHiding = imp_details }))+  = setSrcSpan loc $ do++    when (isJust mb_pkg) $ do+        pkg_imports <- xoptM LangExt.PackageImports+        when (not pkg_imports) $ addErr packageImportErr++    let qual_only = isImportDeclQualified qual_style++    -- If there's an error in loadInterface, (e.g. interface+    -- file not found) we get lots of spurious errors from 'filterImports'+    let imp_mod_name = unLoc loc_imp_mod_name+        doc = ppr imp_mod_name <+> text "is directly imported"++    -- Check for self-import, which confuses the typechecker (#9032)+    -- ghc --make rejects self-import cycles already, but batch-mode may not+    -- at least not until TcIface.tcHiBootIface, which is too late to avoid+    -- typechecker crashes.  (Indirect self imports are not caught until+    -- TcIface, see #10337 tracking how to make this error better.)+    --+    -- Originally, we also allowed 'import {-# SOURCE #-} M', but this+    -- caused bug #10182: in one-shot mode, we should never load an hs-boot+    -- file for the module we are compiling into the EPS.  In principle,+    -- it should be possible to support this mode of use, but we would have to+    -- extend Provenance to support a local definition in a qualified location.+    -- For now, we don't support it, but see #10336+    when (imp_mod_name == moduleName this_mod &&+          (case mb_pkg of  -- If we have import "<pkg>" M, then we should+                           -- check that "<pkg>" is "this" (which is magic)+                           -- or the name of this_mod's package.  Yurgh!+                           -- c.f. GHC.findModule, and #9997+             Nothing         -> True+             Just (StringLiteral _ pkg_fs) -> pkg_fs == fsLit "this" ||+                            fsToUnitId pkg_fs == moduleUnitId this_mod))+         (addErr (text "A module cannot import itself:" <+> ppr imp_mod_name))++    -- Check for a missing import list (Opt_WarnMissingImportList also+    -- checks for T(..) items but that is done in checkDodgyImport below)+    case imp_details of+        Just (False, _) -> return () -- Explicit import list+        _  | implicit   -> return () -- Do not bleat for implicit imports+           | qual_only  -> return ()+           | otherwise  -> whenWOptM Opt_WarnMissingImportList $+                           addWarn (Reason Opt_WarnMissingImportList)+                                   (missingImportListWarn imp_mod_name)++    iface <- loadSrcInterface doc imp_mod_name want_boot (fmap sl_fs mb_pkg)++    -- Compiler sanity check: if the import didn't say+    -- {-# SOURCE #-} we should not get a hi-boot file+    WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) do++    -- Issue a user warning for a redundant {- SOURCE -} import+    -- NB that we arrange to read all the ordinary imports before+    -- any of the {- SOURCE -} imports.+    --+    -- in --make and GHCi, the compilation manager checks for this,+    -- and indeed we shouldn't do it here because the existence of+    -- the non-boot module depends on the compilation order, which+    -- is not deterministic.  The hs-boot test can show this up.+    dflags <- getDynFlags+    warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags))+           (warnRedundantSourceImport imp_mod_name)+    when (mod_safe && not (safeImportsOn dflags)) $+        addErr (text "safe import can't be used as Safe Haskell isn't on!"+                $+$ ptext (sLit $ "please enable Safe Haskell through either "+                                   ++ "Safe, Trustworthy or Unsafe"))++    let+        qual_mod_name = fmap unLoc as_mod `orElse` imp_mod_name+        imp_spec  = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only,+                                  is_dloc = loc, is_as = qual_mod_name }++    -- filter the imports according to the import declaration+    (new_imp_details, gres) <- filterImports iface imp_spec imp_details++    -- for certain error messages, we’d like to know what could be imported+    -- here, if everything were imported+    potential_gres <- mkGlobalRdrEnv . snd <$> filterImports iface imp_spec Nothing++    let gbl_env = mkGlobalRdrEnv gres++        is_hiding | Just (True,_) <- imp_details = True+                  | otherwise                    = False++        -- should the import be safe?+        mod_safe' = mod_safe+                    || (not implicit && safeDirectImpsReq dflags)+                    || (implicit && safeImplicitImpsReq dflags)++    let imv = ImportedModsVal+            { imv_name        = qual_mod_name+            , imv_span        = loc+            , imv_is_safe     = mod_safe'+            , imv_is_hiding   = is_hiding+            , imv_all_exports = potential_gres+            , imv_qualified   = qual_only+            }+        imports = calculateAvails dflags iface mod_safe' want_boot (ImportedByUser imv)++    -- Complain if we import a deprecated module+    whenWOptM Opt_WarnWarningsDeprecations (+       case (mi_warns iface) of+          WarnAll txt -> addWarn (Reason Opt_WarnWarningsDeprecations)+                                (moduleWarn imp_mod_name txt)+          _           -> return ()+     )++    let new_imp_decl = L loc (decl { ideclExt = noExt, ideclSafe = mod_safe'+                                   , ideclHiding = new_imp_details })++    return (new_imp_decl, gbl_env, imports, mi_hpc iface)+rnImportDecl _ (L _ (XImportDecl _)) = panic "rnImportDecl"++-- | Calculate the 'ImportAvails' induced by an import of a particular+-- interface, but without 'imp_mods'.+calculateAvails :: DynFlags+                -> ModIface+                -> IsSafeImport+                -> IsBootInterface+                -> ImportedBy+                -> ImportAvails+calculateAvails dflags iface mod_safe' want_boot imported_by =+  let imp_mod    = mi_module iface+      imp_sem_mod= mi_semantic_module iface+      orph_iface = mi_orphan iface+      has_finsts = mi_finsts iface+      deps       = mi_deps iface+      trust      = getSafeMode $ mi_trust iface+      trust_pkg  = mi_trust_pkg iface++      -- If the module exports anything defined in this module, just+      -- ignore it.  Reason: otherwise it looks as if there are two+      -- local definition sites for the thing, and an error gets+      -- reported.  Easiest thing is just to filter them out up+      -- front. This situation only arises if a module imports+      -- itself, or another module that imported it.  (Necessarily,+      -- this invoves a loop.)+      --+      -- We do this *after* filterImports, so that if you say+      --      module A where+      --         import B( AType )+      --         type AType = ...+      --+      --      module B( AType ) where+      --         import {-# SOURCE #-} A( AType )+      --+      -- then you won't get a 'B does not export AType' message.+++      -- Compute new transitive dependencies+      --+      -- 'dep_orphs' and 'dep_finsts' do NOT include the imported module+      -- itself, but we DO need to include this module in 'imp_orphs' and+      -- 'imp_finsts' if it defines an orphan or instance family; thus the+      -- orph_iface/has_iface tests.++      orphans | orph_iface = ASSERT2( not (imp_sem_mod `elem` dep_orphs deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )+                             imp_sem_mod : dep_orphs deps+              | otherwise  = dep_orphs deps++      finsts | has_finsts = ASSERT2( not (imp_sem_mod `elem` dep_finsts deps), ppr imp_sem_mod <+> ppr (dep_orphs deps) )+                            imp_sem_mod : dep_finsts deps+             | otherwise  = dep_finsts deps++      pkg = moduleUnitId (mi_module iface)+      ipkg = toInstalledUnitId pkg++      -- Does this import mean we now require our own pkg+      -- to be trusted? See Note [Trust Own Package]+      ptrust = trust == Sf_Trustworthy || trust_pkg++      (dependent_mods, dependent_pkgs, pkg_trust_req)+         | pkg == thisPackage dflags =+            -- Imported module is from the home package+            -- Take its dependent modules and add imp_mod itself+            -- Take its dependent packages unchanged+            --+            -- NB: (dep_mods deps) might include a hi-boot file+            -- for the module being compiled, CM. Do *not* filter+            -- this out (as we used to), because when we've+            -- finished dealing with the direct imports we want to+            -- know if any of them depended on CM.hi-boot, in+            -- which case we should do the hi-boot consistency+            -- check.  See LoadIface.loadHiBootInterface+            ((moduleName imp_mod,want_boot):dep_mods deps,dep_pkgs deps,ptrust)++         | otherwise =+            -- Imported module is from another package+            -- Dump the dependent modules+            -- Add the package imp_mod comes from to the dependent packages+            ASSERT2( not (ipkg `elem` (map fst $ dep_pkgs deps))+                   , ppr ipkg <+> ppr (dep_pkgs deps) )+            ([], (ipkg, False) : dep_pkgs deps, False)++  in ImportAvails {+          imp_mods       = unitModuleEnv (mi_module iface) [imported_by],+          imp_orphs      = orphans,+          imp_finsts     = finsts,+          imp_dep_mods   = mkModDeps dependent_mods,+          imp_dep_pkgs   = S.fromList . map fst $ dependent_pkgs,+          -- Add in the imported modules trusted package+          -- requirements. ONLY do this though if we import the+          -- module as a safe import.+          -- See Note [Tracking Trust Transitively]+          -- and Note [Trust Transitive Property]+          imp_trust_pkgs = if mod_safe'+                               then S.fromList . map fst $ filter snd dependent_pkgs+                               else S.empty,+          -- Do we require our own pkg to be trusted?+          -- See Note [Trust Own Package]+          imp_trust_own_pkg = pkg_trust_req+     }+++warnRedundantSourceImport :: ModuleName -> SDoc+warnRedundantSourceImport mod_name+  = text "Unnecessary {-# SOURCE #-} in the import of module"+          <+> quotes (ppr mod_name)++{-+************************************************************************+*                                                                      *+\subsection{importsFromLocalDecls}+*                                                                      *+************************************************************************++From the top-level declarations of this module produce+        * the lexical environment+        * the ImportAvails+created by its bindings.++Note [Top-level Names in Template Haskell decl quotes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also: Note [Interactively-bound Ids in GHCi] in HscTypes+          Note [Looking up Exact RdrNames] in RnEnv++Consider a Template Haskell declaration quotation like this:+      module M where+        f x = h [d| f = 3 |]+When renaming the declarations inside [d| ...|], we treat the+top level binders specially in two ways++1.  We give them an Internal Name, not (as usual) an External one.+    This is done by RnEnv.newTopSrcBinder.++2.  We make them *shadow* the outer bindings.+    See Note [GlobalRdrEnv shadowing]++3. We find out whether we are inside a [d| ... |] by testing the TH+   stage. This is a slight hack, because the stage field was really+   meant for the type checker, and here we are not interested in the+   fields of Brack, hence the error thunks in thRnBrack.+-}++extendGlobalRdrEnvRn :: [AvailInfo]+                     -> MiniFixityEnv+                     -> RnM (TcGblEnv, TcLclEnv)+-- Updates both the GlobalRdrEnv and the FixityEnv+-- We return a new TcLclEnv only because we might have to+-- delete some bindings from it;+-- see Note [Top-level Names in Template Haskell decl quotes]++extendGlobalRdrEnvRn avails new_fixities+  = do  { (gbl_env, lcl_env) <- getEnvs+        ; stage <- getStage+        ; isGHCi <- getIsGHCi+        ; let rdr_env  = tcg_rdr_env gbl_env+              fix_env  = tcg_fix_env gbl_env+              th_bndrs = tcl_th_bndrs lcl_env+              th_lvl   = thLevel stage++              -- Delete new_occs from global and local envs+              -- If we are in a TemplateHaskell decl bracket,+              --    we are going to shadow them+              -- See Note [GlobalRdrEnv shadowing]+              inBracket = isBrackStage stage++              lcl_env_TH = lcl_env { tcl_rdr = delLocalRdrEnvList (tcl_rdr lcl_env) new_occs }+                           -- See Note [GlobalRdrEnv shadowing]++              lcl_env2 | inBracket = lcl_env_TH+                       | otherwise = lcl_env++              -- Deal with shadowing: see Note [GlobalRdrEnv shadowing]+              want_shadowing = isGHCi || inBracket+              rdr_env1 | want_shadowing = shadowNames rdr_env new_names+                       | otherwise      = rdr_env++              lcl_env3 = lcl_env2 { tcl_th_bndrs = extendNameEnvList th_bndrs+                                                       [ (n, (TopLevel, th_lvl))+                                                       | n <- new_names ] }++        ; rdr_env2 <- foldlM add_gre rdr_env1 new_gres++        ; let fix_env' = foldl' extend_fix_env fix_env new_gres+              gbl_env' = gbl_env { tcg_rdr_env = rdr_env2, tcg_fix_env = fix_env' }++        ; traceRn "extendGlobalRdrEnvRn 2" (pprGlobalRdrEnv True rdr_env2)+        ; return (gbl_env', lcl_env3) }+  where+    new_names = concatMap availNames avails+    new_occs  = map nameOccName new_names++    -- If there is a fixity decl for the gre, add it to the fixity env+    extend_fix_env fix_env gre+      | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ)+      = extendNameEnv fix_env name (FixItem occ fi)+      | otherwise+      = fix_env+      where+        name = gre_name gre+        occ  = greOccName gre++    new_gres :: [GlobalRdrElt]  -- New LocalDef GREs, derived from avails+    new_gres = concatMap localGREsFromAvail avails++    add_gre :: GlobalRdrEnv -> GlobalRdrElt -> RnM GlobalRdrEnv+    -- Extend the GlobalRdrEnv with a LocalDef GRE+    -- If there is already a LocalDef GRE with the same OccName,+    --    report an error and discard the new GRE+    -- This establishes INVARIANT 1 of GlobalRdrEnvs+    add_gre env gre+      | not (null dups)    -- Same OccName defined twice+      = do { addDupDeclErr (gre : dups); return env }++      | otherwise+      = return (extendGlobalRdrEnv env gre)+      where+        name = gre_name gre+        occ  = nameOccName name+        dups = filter isLocalGRE (lookupGlobalRdrEnv env occ)+++{- *********************************************************************+*                                                                      *+    getLocalDeclBindersd@ returns the names for an HsDecl+             It's used for source code.++        *** See Note [The Naming story] in HsDecls ****+*                                                                      *+********************************************************************* -}++getLocalNonValBinders :: MiniFixityEnv -> HsGroup GhcPs+    -> RnM ((TcGblEnv, TcLclEnv), NameSet)+-- Get all the top-level binders bound the group *except*+-- for value bindings, which are treated separately+-- Specifically we return AvailInfo for+--      * type decls (incl constructors and record selectors)+--      * class decls (including class ops)+--      * associated types+--      * foreign imports+--      * value signatures (in hs-boot files only)++getLocalNonValBinders fixity_env+     (HsGroup { hs_valds  = binds,+                hs_tyclds = tycl_decls,+                hs_fords  = foreign_decls })+  = do  { -- Process all type/class decls *except* family instances+        ; let inst_decls = tycl_decls >>= group_instds+        ; overload_ok <- xoptM LangExt.DuplicateRecordFields+        ; (tc_avails, tc_fldss)+            <- fmap unzip $ mapM (new_tc overload_ok)+                                 (tyClGroupTyClDecls tycl_decls)+        ; traceRn "getLocalNonValBinders 1" (ppr tc_avails)+        ; envs <- extendGlobalRdrEnvRn tc_avails fixity_env+        ; setEnvs envs $ do {+            -- Bring these things into scope first+            -- See Note [Looking up family names in family instances]++          -- Process all family instances+          -- to bring new data constructors into scope+        ; (nti_availss, nti_fldss) <- mapAndUnzipM (new_assoc overload_ok)+                                                   inst_decls++          -- Finish off with value binders:+          --    foreign decls and pattern synonyms for an ordinary module+          --    type sigs in case of a hs-boot file only+        ; is_boot <- tcIsHsBootOrSig+        ; let val_bndrs | is_boot   = hs_boot_sig_bndrs+                        | otherwise = for_hs_bndrs+        ; val_avails <- mapM new_simple val_bndrs++        ; let avails    = concat nti_availss ++ val_avails+              new_bndrs = availsToNameSetWithSelectors avails `unionNameSet`+                          availsToNameSetWithSelectors tc_avails+              flds      = concat nti_fldss ++ concat tc_fldss+        ; traceRn "getLocalNonValBinders 2" (ppr avails)+        ; (tcg_env, tcl_env) <- extendGlobalRdrEnvRn avails fixity_env++        -- Extend tcg_field_env with new fields (this used to be the+        -- work of extendRecordFieldEnv)+        ; let field_env = extendNameEnvList (tcg_field_env tcg_env) flds+              envs      = (tcg_env { tcg_field_env = field_env }, tcl_env)++        ; traceRn "getLocalNonValBinders 3" (vcat [ppr flds, ppr field_env])+        ; return (envs, new_bndrs) } }+  where+    ValBinds _ _val_binds val_sigs = binds++    for_hs_bndrs :: [Located RdrName]+    for_hs_bndrs = hsForeignDeclsBinders foreign_decls++    -- In a hs-boot file, the value binders come from the+    --  *signatures*, and there should be no foreign binders+    hs_boot_sig_bndrs = [ L decl_loc (unLoc n)+                        | L decl_loc (TypeSig _ ns _) <- val_sigs, n <- ns]++      -- the SrcSpan attached to the input should be the span of the+      -- declaration, not just the name+    new_simple :: Located RdrName -> RnM AvailInfo+    new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name+                            ; return (avail nm) }++    new_tc :: Bool -> LTyClDecl GhcPs+           -> RnM (AvailInfo, [(Name, [FieldLabel])])+    new_tc overload_ok tc_decl -- NOT for type/data instances+        = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl+             ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs+             ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds+             ; let fld_env = case unLoc tc_decl of+                     DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds'+                     _                            -> []+             ; return (AvailTC main_name names flds', fld_env) }+++    -- Calculate the mapping from constructor names to fields, which+    -- will go in tcg_field_env. It's convenient to do this here where+    -- we are working with a single datatype definition.+    mk_fld_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel]+               -> [(Name, [FieldLabel])]+    mk_fld_env d names flds = concatMap find_con_flds (dd_cons d)+      where+        find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr+                                       , con_args = RecCon cdflds }))+            = [( find_con_name rdr+               , concatMap find_con_decl_flds (unLoc cdflds) )]+        find_con_flds (L _ (ConDeclGADT { con_names = rdrs+                                        , con_args = RecCon flds }))+            = [ ( find_con_name rdr+                 , concatMap find_con_decl_flds (unLoc flds))+              | L _ rdr <- rdrs ]++        find_con_flds _ = []++        find_con_name rdr+          = expectJust "getLocalNonValBinders/find_con_name" $+              find (\ n -> nameOccName n == rdrNameOcc rdr) names+        find_con_decl_flds (L _ x)+          = map find_con_decl_fld (cd_fld_names x)++        find_con_decl_fld  (L _ (FieldOcc _ (L _ rdr)))+          = expectJust "getLocalNonValBinders/find_con_decl_fld" $+              find (\ fl -> flLabel fl == lbl) flds+          where lbl = occNameFS (rdrNameOcc rdr)+        find_con_decl_fld (L _ (XFieldOcc _)) = panic "getLocalNonValBinders"++    new_assoc :: Bool -> LInstDecl GhcPs+              -> RnM ([AvailInfo], [(Name, [FieldLabel])])+    new_assoc _ (L _ (TyFamInstD {})) = return ([], [])+      -- type instances don't bind new names++    new_assoc overload_ok (L _ (DataFamInstD _ d))+      = do { (avail, flds) <- new_di overload_ok Nothing d+           ; return ([avail], flds) }+    new_assoc overload_ok (L _ (ClsInstD _ (ClsInstDecl { cid_poly_ty = inst_ty+                                                      , cid_datafam_insts = adts })))+      = do -- First, attempt to grab the name of the class from the instance.+           -- This step could fail if the instance is not headed by a class,+           -- such as in the following examples:+           --+           -- (1) The class is headed by a bang pattern, such as in+           --     `instance !Show Int` (#3811c)+           -- (2) The class is headed by a type variable, such as in+           --     `instance c` (#16385)+           --+           -- If looking up the class name fails, then mb_cls_nm will+           -- be Nothing.+           mb_cls_nm <- runMaybeT $ do+             -- See (1) above+             L loc cls_rdr <- MaybeT $ pure $ getLHsInstDeclClass_maybe inst_ty+             -- See (2) above+             MaybeT $ setSrcSpan loc $ lookupGlobalOccRn_maybe cls_rdr+           -- Assuming the previous step succeeded, process any associated data+           -- family instances. If the previous step failed, bail out.+           case mb_cls_nm of+             Nothing -> pure ([], [])+             Just cls_nm -> do+               (avails, fldss)+                 <- mapAndUnzipM (new_loc_di overload_ok (Just cls_nm)) adts+               pure (avails, concat fldss)+    new_assoc _ (L _ (ClsInstD _ (XClsInstDecl _))) = panic "new_assoc"+    new_assoc _ (L _ (XInstDecl _))                 = panic "new_assoc"++    new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs+                   -> RnM (AvailInfo, [(Name, [FieldLabel])])+    new_di overload_ok mb_cls dfid@(DataFamInstDecl { dfid_eqn =+                                     HsIB { hsib_body = ti_decl }})+        = do { main_name <- lookupFamInstName mb_cls (feqn_tycon ti_decl)+             ; let (bndrs, flds) = hsDataFamInstBinders dfid+             ; sub_names <- mapM newTopSrcBinder bndrs+             ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds+             ; let avail    = AvailTC (unLoc main_name) sub_names flds'+                                  -- main_name is not bound here!+                   fld_env  = mk_fld_env (feqn_rhs ti_decl) sub_names flds'+             ; return (avail, fld_env) }+    new_di _ _ (DataFamInstDecl (XHsImplicitBndrs _)) = panic "new_di"++    new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs+                   -> RnM (AvailInfo, [(Name, [FieldLabel])])+    new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d+getLocalNonValBinders _ (XHsGroup _) = panic "getLocalNonValBinders"++newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel+newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!"+newRecordSelector _ _ (L _ (XFieldOcc _)) = panic "newRecordSelector"+newRecordSelector overload_ok (dc:_) (L loc (FieldOcc _ (L _ fld)))+  = do { selName <- newTopSrcBinder $ L loc $ field+       ; return $ qualFieldLbl { flSelector = selName } }+  where+    fieldOccName = occNameFS $ rdrNameOcc fld+    qualFieldLbl = mkFieldLabelOccs fieldOccName (nameOccName dc) overload_ok+    field | isExact fld = fld+              -- use an Exact RdrName as is to preserve the bindings+              -- of an already renamer-resolved field and its use+              -- sites. This is needed to correctly support record+              -- selectors in Template Haskell. See Note [Binders in+              -- Template Haskell] in Convert.hs and Note [Looking up+              -- Exact RdrNames] in RnEnv.hs.+          | otherwise   = mkRdrUnqual (flSelector qualFieldLbl)++{-+Note [Looking up family names in family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  module M where+    type family T a :: *+    type instance M.T Int = Bool++We might think that we can simply use 'lookupOccRn' when processing the type+instance to look up 'M.T'.  Alas, we can't!  The type family declaration is in+the *same* HsGroup as the type instance declaration.  Hence, as we are+currently collecting the binders declared in that HsGroup, these binders will+not have been added to the global environment yet.++Solution is simple: process the type family declarations first, extend+the environment, and then process the type instances.+++************************************************************************+*                                                                      *+\subsection{Filtering imports}+*                                                                      *+************************************************************************++@filterImports@ takes the @ExportEnv@ telling what the imported module makes+available, and filters it through the import spec (if any).++Note [Dealing with imports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+For import M( ies ), we take the mi_exports of M, and make+   imp_occ_env :: OccEnv (Name, AvailInfo, Maybe Name)+One entry for each Name that M exports; the AvailInfo is the+AvailInfo exported from M that exports that Name.++The situation is made more complicated by associated types. E.g.+   module M where+     class    C a    where { data T a }+     instance C Int  where { data T Int = T1 | T2 }+     instance C Bool where { data T Int = T3 }+Then M's export_avails are (recall the AvailTC invariant from Avails.hs)+  C(C,T), T(T,T1,T2,T3)+Notice that T appears *twice*, once as a child and once as a parent. From+this list we construct a raw list including+   T -> (T, T( T1, T2, T3 ), Nothing)+   T -> (C, C( C, T ),       Nothing)+and we combine these (in function 'combine' in 'imp_occ_env' in+'filterImports') to get+   T  -> (T,  T(T,T1,T2,T3), Just C)++So the overall imp_occ_env is+   C  -> (C,  C(C,T),        Nothing)+   T  -> (T,  T(T,T1,T2,T3), Just C)+   T1 -> (T1, T(T,T1,T2,T3), Nothing)   -- similarly T2,T3++If we say+   import M( T(T1,T2) )+then we get *two* Avails:  C(T), T(T1,T2)++Note that the imp_occ_env will have entries for data constructors too,+although we never look up data constructors.+-}++filterImports+    :: ModIface+    -> ImpDeclSpec                     -- The span for the entire import decl+    -> Maybe (Bool, Located [LIE GhcPs])    -- Import spec; True => hiding+    -> RnM (Maybe (Bool, Located [LIE GhcRn]), -- Import spec w/ Names+            [GlobalRdrElt])                   -- Same again, but in GRE form+filterImports iface decl_spec Nothing+  = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface))+  where+    imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }+++filterImports iface decl_spec (Just (want_hiding, L l import_items))+  = do  -- check for errors, convert RdrNames to Names+        items1 <- mapM lookup_lie import_items++        let items2 :: [(LIE GhcRn, AvailInfo)]+            items2 = concat items1+                -- NB the AvailInfo may have duplicates, and several items+                --    for the same parent; e.g N(x) and N(y)++            names  = availsToNameSetWithSelectors (map snd items2)+            keep n = not (n `elemNameSet` names)+            pruned_avails = filterAvails keep all_avails+            hiding_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll }++            gres | want_hiding = gresFromAvails (Just hiding_spec) pruned_avails+                 | otherwise   = concatMap (gresFromIE decl_spec) items2++        return (Just (want_hiding, L l (map fst items2)), gres)+  where+    all_avails = mi_exports iface++        -- See Note [Dealing with imports]+    imp_occ_env :: OccEnv (Name,    -- the name+                           AvailInfo,   -- the export item providing the name+                           Maybe Name)  -- the parent of associated types+    imp_occ_env = mkOccEnv_C combine [ (occ, (n, a, Nothing))+                                     | a <- all_avails+                                     , (n, occ) <- availNamesWithOccs a]+      where+        -- See Note [Dealing with imports]+        -- 'combine' is only called for associated data types which appear+        -- twice in the all_avails. In the example, we combine+        --    T(T,T1,T2,T3) and C(C,T)  to give   (T, T(T,T1,T2,T3), Just C)+        -- NB: the AvailTC can have fields as well as data constructors (#12127)+        combine (name1, a1@(AvailTC p1 _ _), mp1)+                (name2, a2@(AvailTC p2 _ _), mp2)+          = ASSERT2( name1 == name2 && isNothing mp1 && isNothing mp2+                   , ppr name1 <+> ppr name2 <+> ppr mp1 <+> ppr mp2 )+            if p1 == name1 then (name1, a1, Just p2)+                           else (name1, a2, Just p1)+        combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y)++    lookup_name :: IE GhcPs -> RdrName -> IELookupM (Name, AvailInfo, Maybe Name)+    lookup_name ie rdr+       | isQual rdr              = failLookupWith (QualImportError rdr)+       | Just succ <- mb_success = return succ+       | otherwise               = failLookupWith (BadImport ie)+      where+        mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr)++    lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)]+    lookup_lie (L loc ieRdr)+        = do (stuff, warns) <- setSrcSpan loc $+                               liftM (fromMaybe ([],[])) $+                               run_lookup (lookup_ie ieRdr)+             mapM_ emit_warning warns+             return [ (L loc ie, avail) | (ie,avail) <- stuff ]+        where+            -- Warn when importing T(..) if T was exported abstractly+            emit_warning (DodgyImport n) = whenWOptM Opt_WarnDodgyImports $+              addWarn (Reason Opt_WarnDodgyImports) (dodgyImportWarn n)+            emit_warning MissingImportList = whenWOptM Opt_WarnMissingImportList $+              addWarn (Reason Opt_WarnMissingImportList) (missingImportListItem ieRdr)+            emit_warning (BadImportW ie) = whenWOptM Opt_WarnDodgyImports $+              addWarn (Reason Opt_WarnDodgyImports) (lookup_err_msg (BadImport ie))++            run_lookup :: IELookupM a -> TcRn (Maybe a)+            run_lookup m = case m of+              Failed err -> addErr (lookup_err_msg err) >> return Nothing+              Succeeded a -> return (Just a)++            lookup_err_msg err = case err of+              BadImport ie  -> badImportItemErr iface decl_spec ie all_avails+              IllegalImport -> illegalImportItemErr+              QualImportError rdr -> qualImportItemErr rdr++        -- For each import item, we convert its RdrNames to Names,+        -- and at the same time construct an AvailInfo corresponding+        -- to what is actually imported by this item.+        -- Returns Nothing on error.+        -- We return a list here, because in the case of an import+        -- item like C, if we are hiding, then C refers to *both* a+        -- type/class and a data constructor.  Moreover, when we import+        -- data constructors of an associated family, we need separate+        -- AvailInfos for the data constructors and the family (as they have+        -- different parents).  See Note [Dealing with imports]+    lookup_ie :: IE GhcPs+              -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning])+    lookup_ie ie = handle_bad_import $ do+      case ie of+        IEVar _ (L l n) -> do+            (name, avail, _) <- lookup_name ie $ ieWrappedName n+            return ([(IEVar noExt (L l (replaceWrappedName n name)),+                                                  trimAvail avail name)], [])++        IEThingAll _ (L l tc) -> do+            (name, avail, mb_parent) <- lookup_name ie $ ieWrappedName tc+            let warns = case avail of+                          Avail {}                     -- e.g. f(..)+                            -> [DodgyImport $ ieWrappedName tc]++                          AvailTC _ subs fs+                            | null (drop 1 subs) && null fs -- e.g. T(..) where T is a synonym+                            -> [DodgyImport $ ieWrappedName tc]++                            | not (is_qual decl_spec)  -- e.g. import M( T(..) )+                            -> [MissingImportList]++                            | otherwise+                            -> []++                renamed_ie = IEThingAll noExt (L l (replaceWrappedName tc name))+                sub_avails = case avail of+                               Avail {}              -> []+                               AvailTC name2 subs fs -> [(renamed_ie, AvailTC name2 (subs \\ [name]) fs)]+            case mb_parent of+              Nothing     -> return ([(renamed_ie, avail)], warns)+                             -- non-associated ty/cls+              Just parent -> return ((renamed_ie, AvailTC parent [name] []) : sub_avails, warns)+                             -- associated type++        IEThingAbs _ (L l tc')+            | want_hiding   -- hiding ( C )+                       -- Here the 'C' can be a data constructor+                       --  *or* a type/class, or even both+            -> let tc = ieWrappedName tc'+                   tc_name = lookup_name ie tc+                   dc_name = lookup_name ie (setRdrNameSpace tc srcDataName)+               in+               case catIELookupM [ tc_name, dc_name ] of+                 []    -> failLookupWith (BadImport ie)+                 names -> return ([mkIEThingAbs tc' l name | name <- names], [])+            | otherwise+            -> do nameAvail <- lookup_name ie (ieWrappedName tc')+                  return ([mkIEThingAbs tc' l nameAvail]+                         , [])++        IEThingWith xt ltc@(L l rdr_tc) wc rdr_ns rdr_fs ->+          ASSERT2(null rdr_fs, ppr rdr_fs) do+           (name, avail, mb_parent)+               <- lookup_name (IEThingAbs noExt ltc) (ieWrappedName rdr_tc)++           let (ns,subflds) = case avail of+                                AvailTC _ ns' subflds' -> (ns',subflds')+                                Avail _                -> panic "filterImports"++           -- Look up the children in the sub-names of the parent+           let subnames = case ns of   -- The tc is first in ns,+                            [] -> []   -- if it is there at all+                                       -- See the AvailTC Invariant in Avail.hs+                            (n1:ns1) | n1 == name -> ns1+                                     | otherwise  -> ns+           case lookupChildren (map Left subnames ++ map Right subflds) rdr_ns of++             Failed rdrs -> failLookupWith (BadImport (IEThingWith xt ltc wc rdrs []))+                                -- We are trying to import T( a,b,c,d ), and failed+                                -- to find 'b' and 'd'.  So we make up an import item+                                -- to report as failing, namely T( b, d ).+                                -- c.f. #15412++             Succeeded (childnames, childflds) ->+               case mb_parent of+                 -- non-associated ty/cls+                 Nothing+                   -> return ([(IEThingWith noExt (L l name') wc childnames'+                                                                 childflds,+                               AvailTC name (name:map unLoc childnames) (map unLoc childflds))],+                              [])+                   where name' = replaceWrappedName rdr_tc name+                         childnames' = map to_ie_post_rn childnames+                         -- childnames' = postrn_ies childnames+                 -- associated ty+                 Just parent+                   -> return ([(IEThingWith noExt (L l name') wc childnames'+                                                           childflds,+                                AvailTC name (map unLoc childnames) (map unLoc childflds)),+                               (IEThingWith noExt (L l name') wc childnames'+                                                           childflds,+                                AvailTC parent [name] [])],+                              [])+                   where name' = replaceWrappedName rdr_tc name+                         childnames' = map to_ie_post_rn childnames++        _other -> failLookupWith IllegalImport+        -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed+        -- all errors.++      where+        mkIEThingAbs tc l (n, av, Nothing    )+          = (IEThingAbs noExt (L l (replaceWrappedName tc n)), trimAvail av n)+        mkIEThingAbs tc l (n, _,  Just parent)+          = (IEThingAbs noExt (L l (replaceWrappedName tc n))+             , AvailTC parent [n] [])++        handle_bad_import m = catchIELookup m $ \err -> case err of+          BadImport ie | want_hiding -> return ([], [BadImportW ie])+          _                          -> failLookupWith err++type IELookupM = MaybeErr IELookupError++data IELookupWarning+  = BadImportW (IE GhcPs)+  | MissingImportList+  | DodgyImport RdrName+  -- NB. use the RdrName for reporting a "dodgy" import++data IELookupError+  = QualImportError RdrName+  | BadImport (IE GhcPs)+  | IllegalImport++failLookupWith :: IELookupError -> IELookupM a+failLookupWith err = Failed err++catchIELookup :: IELookupM a -> (IELookupError -> IELookupM a) -> IELookupM a+catchIELookup m h = case m of+  Succeeded r -> return r+  Failed err  -> h err++catIELookupM :: [IELookupM a] -> [a]+catIELookupM ms = [ a | Succeeded a <- ms ]++{-+************************************************************************+*                                                                      *+\subsection{Import/Export Utils}+*                                                                      *+************************************************************************+-}++-- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's.+gresFromIE :: ImpDeclSpec -> (LIE GhcRn, AvailInfo) -> [GlobalRdrElt]+gresFromIE decl_spec (L loc ie, avail)+  = gresFromAvail prov_fn avail+  where+    is_explicit = case ie of+                    IEThingAll _ name -> \n -> n == lieWrappedName name+                    _                 -> \_ -> True+    prov_fn name+      = Just (ImpSpec { is_decl = decl_spec, is_item = item_spec })+      where+        item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc }+++{-+Note [Children for duplicate record fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the module++    {-# LANGUAGE DuplicateRecordFields #-}+    module M (F(foo, MkFInt, MkFBool)) where+      data family F a+      data instance F Int = MkFInt { foo :: Int }+      data instance F Bool = MkFBool { foo :: Bool }++The `foo` in the export list refers to *both* selectors! For this+reason, lookupChildren builds an environment that maps the FastString+to a list of items, rather than a single item.+-}++mkChildEnv :: [GlobalRdrElt] -> NameEnv [GlobalRdrElt]+mkChildEnv gres = foldr add emptyNameEnv gres+  where+    add gre env = case gre_par gre of+        FldParent p _  -> extendNameEnv_Acc (:) singleton env p gre+        ParentIs  p    -> extendNameEnv_Acc (:) singleton env p gre+        NoParent       -> env++findChildren :: NameEnv [a] -> Name -> [a]+findChildren env n = lookupNameEnv env n `orElse` []++lookupChildren :: [Either Name FieldLabel] -> [LIEWrappedName RdrName]+               -> MaybeErr [LIEWrappedName RdrName]   -- The ones for which the lookup failed+                           ([Located Name], [Located FieldLabel])+-- (lookupChildren all_kids rdr_items) maps each rdr_item to its+-- corresponding Name all_kids, if the former exists+-- The matching is done by FastString, not OccName, so that+--    Cls( meth, AssocTy )+-- will correctly find AssocTy among the all_kids of Cls, even though+-- the RdrName for AssocTy may have a (bogus) DataName namespace+-- (Really the rdr_items should be FastStrings in the first place.)+lookupChildren all_kids rdr_items+  | null fails+  = Succeeded (fmap concat (partitionEithers oks))+       -- This 'fmap concat' trickily applies concat to the /second/ component+       -- of the pair, whose type is ([Located Name], [[Located FieldLabel]])+  | otherwise+  = Failed fails+  where+    mb_xs = map doOne rdr_items+    fails = [ bad_rdr | Failed bad_rdr <- mb_xs ]+    oks   = [ ok      | Succeeded ok   <- mb_xs ]+    oks :: [Either (Located Name) [Located FieldLabel]]++    doOne item@(L l r)+       = case (lookupFsEnv kid_env . occNameFS . rdrNameOcc . ieWrappedName) r of+           Just [Left n]            -> Succeeded (Left (L l n))+           Just rs | all isRight rs -> Succeeded (Right (map (L l) (rights rs)))+           _                        -> Failed    item++    -- See Note [Children for duplicate record fields]+    kid_env = extendFsEnvList_C (++) emptyFsEnv+              [(either (occNameFS . nameOccName) flLabel x, [x]) | x <- all_kids]++++-------------------------------++{-+*********************************************************+*                                                       *+\subsection{Unused names}+*                                                       *+*********************************************************+-}++reportUnusedNames :: Maybe (Located [LIE GhcPs])  -- Export list+                  -> TcGblEnv -> RnM ()+reportUnusedNames _export_decls gbl_env+  = do  { traceRn "RUN" (ppr (tcg_dus gbl_env))+        ; warnUnusedImportDecls gbl_env+        ; warnUnusedTopBinds unused_locals+        ; warnMissingSignatures gbl_env }+  where+    used_names :: NameSet+    used_names = findUses (tcg_dus gbl_env) emptyNameSet+    -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used+    -- Hence findUses++    -- Collect the defined names from the in-scope environment+    defined_names :: [GlobalRdrElt]+    defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env)++    -- Note that defined_and_used, defined_but_not_used+    -- are both [GRE]; that's why we need defined_and_used+    -- rather than just used_names+    _defined_and_used, defined_but_not_used :: [GlobalRdrElt]+    (_defined_and_used, defined_but_not_used)+        = partition (gre_is_used used_names) defined_names++    kids_env = mkChildEnv defined_names+    -- This is done in mkExports too; duplicated work++    gre_is_used :: NameSet -> GlobalRdrElt -> Bool+    gre_is_used used_names (GRE {gre_name = name})+        = name `elemNameSet` used_names+          || any (\ gre -> gre_name gre `elemNameSet` used_names) (findChildren kids_env name)+                -- A use of C implies a use of T,+                -- if C was brought into scope by T(..) or T(C)++    -- Filter out the ones that are+    --  (a) defined in this module, and+    --  (b) not defined by a 'deriving' clause+    -- The latter have an Internal Name, so we can filter them out easily+    unused_locals :: [GlobalRdrElt]+    unused_locals = filter is_unused_local defined_but_not_used+    is_unused_local :: GlobalRdrElt -> Bool+    is_unused_local gre = isLocalGRE gre && isExternalName (gre_name gre)++{- *********************************************************************+*                                                                      *+              Missing signatures+*                                                                      *+********************************************************************* -}++-- | Warn the user about top level binders that lack type signatures.+-- Called /after/ type inference, so that we can report the+-- inferred type of the function+warnMissingSignatures :: TcGblEnv -> RnM ()+warnMissingSignatures gbl_env+  = do { let exports = availsToNameSet (tcg_exports gbl_env)+             sig_ns  = tcg_sigs gbl_env+               -- We use sig_ns to exclude top-level bindings that are generated by GHC+             binds    = collectHsBindsBinders $ tcg_binds gbl_env+             pat_syns = tcg_patsyns gbl_env++         -- Warn about missing signatures+         -- Do this only when we have a type to offer+       ; warn_missing_sigs  <- woptM Opt_WarnMissingSignatures+       ; warn_only_exported <- woptM Opt_WarnMissingExportedSignatures+       ; warn_pat_syns      <- woptM Opt_WarnMissingPatternSynonymSignatures++       ; let add_sig_warns+               | warn_only_exported = add_warns Opt_WarnMissingExportedSignatures+               | warn_missing_sigs  = add_warns Opt_WarnMissingSignatures+               | warn_pat_syns      = add_warns Opt_WarnMissingPatternSynonymSignatures+               | otherwise          = return ()++             add_warns flag+                = when warn_pat_syns+                       (mapM_ add_pat_syn_warn pat_syns) >>+                  when (warn_missing_sigs || warn_only_exported)+                       (mapM_ add_bind_warn binds)+                where+                  add_pat_syn_warn p+                    = add_warn name $+                      hang (text "Pattern synonym with no type signature:")+                         2 (text "pattern" <+> pprPrefixName name <+> dcolon <+> pp_ty)+                    where+                      name  = patSynName p+                      pp_ty = pprPatSynType p++                  add_bind_warn :: Id -> IOEnv (Env TcGblEnv TcLclEnv) ()+                  add_bind_warn id+                    = do { env <- tcInitTidyEnv     -- Why not use emptyTidyEnv?+                         ; let name    = idName id+                               (_, ty) = tidyOpenType env (idType id)+                               ty_msg  = pprSigmaType ty+                         ; add_warn name $+                           hang (text "Top-level binding with no type signature:")+                              2 (pprPrefixName name <+> dcolon <+> ty_msg) }++                  add_warn name msg+                    = when (name `elemNameSet` sig_ns && export_check name)+                           (addWarnAt (Reason flag) (getSrcSpan name) msg)++                  export_check name+                    = not warn_only_exported || name `elemNameSet` exports++       ; add_sig_warns }+++{-+*********************************************************+*                                                       *+\subsection{Unused imports}+*                                                       *+*********************************************************++This code finds which import declarations are unused.  The+specification and implementation notes are here:+  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/unused-imports++See also Note [Choosing the best import declaration] in RdrName+-}++type ImportDeclUsage+   = ( LImportDecl GhcRn   -- The import declaration+     , [GlobalRdrElt]      -- What *is* used (normalised)+     , [Name] )            -- What is imported but *not* used++warnUnusedImportDecls :: TcGblEnv -> RnM ()+warnUnusedImportDecls gbl_env+  = do { uses <- readMutVar (tcg_used_gres gbl_env)+       ; let user_imports = filterOut+                              (ideclImplicit . unLoc)+                              (tcg_rn_imports gbl_env)+                -- This whole function deals only with *user* imports+                -- both for warning about unnecessary ones, and for+                -- deciding the minimal ones+             rdr_env = tcg_rdr_env gbl_env+             fld_env = mkFieldEnv rdr_env++       ; let usage :: [ImportDeclUsage]+             usage = findImportUsage user_imports uses++       ; traceRn "warnUnusedImportDecls" $+                       (vcat [ text "Uses:" <+> ppr uses+                             , text "Import usage" <+> ppr usage])++       ; whenWOptM Opt_WarnUnusedImports $+         mapM_ (warnUnusedImport Opt_WarnUnusedImports fld_env) usage++       ; whenGOptM Opt_D_dump_minimal_imports $+         printMinimalImports usage }++findImportUsage :: [LImportDecl GhcRn]+                -> [GlobalRdrElt]+                -> [ImportDeclUsage]++findImportUsage imports used_gres+  = map unused_decl imports+  where+    import_usage :: ImportMap+    import_usage = mkImportMap used_gres++    unused_decl decl@(L loc (ImportDecl { ideclHiding = imps }))+      = (decl, used_gres, nameSetElemsStable unused_imps)+      where+        used_gres = Map.lookup (srcSpanEnd loc) import_usage+                               -- srcSpanEnd: see Note [The ImportMap]+                    `orElse` []++        used_names   = mkNameSet (map      gre_name        used_gres)+        used_parents = mkNameSet (mapMaybe greParent_maybe used_gres)++        unused_imps   -- Not trivial; see eg #7454+          = case imps of+              Just (False, L _ imp_ies) ->+                                 foldr (add_unused . unLoc) emptyNameSet imp_ies+              _other -> emptyNameSet -- No explicit import list => no unused-name list++        add_unused :: IE GhcRn -> NameSet -> NameSet+        add_unused (IEVar _ n)      acc = add_unused_name (lieWrappedName n) acc+        add_unused (IEThingAbs _ n) acc = add_unused_name (lieWrappedName n) acc+        add_unused (IEThingAll _ n) acc = add_unused_all  (lieWrappedName n) acc+        add_unused (IEThingWith _ p wc ns fs) acc =+          add_wc_all (add_unused_with pn xs acc)+          where pn = lieWrappedName p+                xs = map lieWrappedName ns ++ map (flSelector . unLoc) fs+                add_wc_all = case wc of+                            NoIEWildcard -> id+                            IEWildcard _ -> add_unused_all pn+        add_unused _ acc = acc++        add_unused_name n acc+          | n `elemNameSet` used_names = acc+          | otherwise                  = acc `extendNameSet` n+        add_unused_all n acc+          | n `elemNameSet` used_names   = acc+          | n `elemNameSet` used_parents = acc+          | otherwise                    = acc `extendNameSet` n+        add_unused_with p ns acc+          | all (`elemNameSet` acc1) ns = add_unused_name p acc1+          | otherwise = acc1+          where+            acc1 = foldr add_unused_name acc ns+       -- If you use 'signum' from Num, then the user may well have+       -- imported Num(signum).  We don't want to complain that+       -- Num is not itself mentioned.  Hence the two cases in add_unused_with.+    unused_decl (L _ (XImportDecl _)) = panic "unused_decl"+++{- Note [The ImportMap]+~~~~~~~~~~~~~~~~~~~~~~~+The ImportMap is a short-lived intermediate data structure records, for+each import declaration, what stuff brought into scope by that+declaration is actually used in the module.++The SrcLoc is the location of the END of a particular 'import'+declaration.  Why *END*?  Because we don't want to get confused+by the implicit Prelude import. Consider (#7476) the module+    import Foo( foo )+    main = print foo+There is an implicit 'import Prelude(print)', and it gets a SrcSpan+of line 1:1 (just the point, not a span). If we use the *START* of+the SrcSpan to identify the import decl, we'll confuse the implicit+import Prelude with the explicit 'import Foo'.  So we use the END.+It's just a cheap hack; we could equally well use the Span too.++The [GlobalRdrElt] are the things imported from that decl.+-}++type ImportMap = Map SrcLoc [GlobalRdrElt]  -- See [The ImportMap]+     -- If loc :-> gres, then+     --   'loc' = the end loc of the bestImport of each GRE in 'gres'++mkImportMap :: [GlobalRdrElt] -> ImportMap+-- For each of a list of used GREs, find all the import decls that brought+-- it into scope; choose one of them (bestImport), and record+-- the RdrName in that import decl's entry in the ImportMap+mkImportMap gres+  = foldr add_one Map.empty gres+  where+    add_one gre@(GRE { gre_imp = imp_specs }) imp_map+       = Map.insertWith add decl_loc [gre] imp_map+       where+          best_imp_spec = bestImport imp_specs+          decl_loc      = srcSpanEnd (is_dloc (is_decl best_imp_spec))+                        -- For srcSpanEnd see Note [The ImportMap]+          add _ gres = gre : gres++warnUnusedImport :: WarningFlag -> NameEnv (FieldLabelString, Name)+                 -> ImportDeclUsage -> RnM ()+warnUnusedImport flag fld_env (L loc decl, used, unused)++  -- Do not warn for 'import M()'+  | Just (False,L _ []) <- ideclHiding decl+  = return ()++  -- Note [Do not warn about Prelude hiding]+  | Just (True, L _ hides) <- ideclHiding decl+  , not (null hides)+  , pRELUDE_NAME == unLoc (ideclName decl)+  = return ()++  -- Nothing used; drop entire declaration+  | null used+  = addWarnAt (Reason flag) loc msg1++  -- Everything imported is used; nop+  | null unused+  = return ()++  -- Some imports are unused+  | otherwise+  = addWarnAt (Reason flag) loc  msg2++  where+    msg1 = vcat [ pp_herald <+> quotes pp_mod <+> is_redundant+                , nest 2 (text "except perhaps to import instances from"+                                   <+> quotes pp_mod)+                , text "To import instances alone, use:"+                                   <+> text "import" <+> pp_mod <> parens Outputable.empty ]+    msg2 = sep [ pp_herald <+> quotes sort_unused+               , text "from module" <+> quotes pp_mod <+> is_redundant]+    pp_herald  = text "The" <+> pp_qual <+> text "import of"+    pp_qual+      | isImportDeclQualified (ideclQualified decl)= text "qualified"+      | otherwise                                  = Outputable.empty+    pp_mod       = ppr (unLoc (ideclName decl))+    is_redundant = text "is redundant"++    -- In warning message, pretty-print identifiers unqualified unconditionally+    -- to improve the consistent for ambiguous/unambiguous identifiers.+    -- See trac#14881.+    ppr_possible_field n = case lookupNameEnv fld_env n of+                               Just (fld, p) -> pprNameUnqualified p <> parens (ppr fld)+                               Nothing  -> pprNameUnqualified n++    -- Print unused names in a deterministic (lexicographic) order+    sort_unused :: SDoc+    sort_unused = pprWithCommas ppr_possible_field $+                  sortBy (comparing nameOccName) unused++{-+Note [Do not warn about Prelude hiding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not warn about+   import Prelude hiding( x, y )+because even if nothing else from Prelude is used, it may be essential to hide+x,y to avoid name-shadowing warnings.  Example (#9061)+   import Prelude hiding( log )+   f x = log where log = ()++++Note [Printing minimal imports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To print the minimal imports we walk over the user-supplied import+decls, and simply trim their import lists.  NB that++  * We do *not* change the 'qualified' or 'as' parts!++  * We do not disard a decl altogether; we might need instances+    from it.  Instead we just trim to an empty import list+-}++getMinimalImports :: [ImportDeclUsage] -> RnM [LImportDecl GhcRn]+getMinimalImports = mapM mk_minimal+  where+    mk_minimal (L l decl, used_gres, unused)+      | null unused+      , Just (False, _) <- ideclHiding decl+      = return (L l decl)+      | otherwise+      = do { let ImportDecl { ideclName    = L _ mod_name+                            , ideclSource  = is_boot+                            , ideclPkgQual = mb_pkg } = decl+           ; iface <- loadSrcInterface doc mod_name is_boot (fmap sl_fs mb_pkg)+           ; let used_avails = gresToAvailInfo used_gres+                 lies = map (L l) (concatMap (to_ie iface) used_avails)+           ; return (L l (decl { ideclHiding = Just (False, L l lies) })) }+      where+        doc = text "Compute minimal imports for" <+> ppr decl++    to_ie :: ModIface -> AvailInfo -> [IE GhcRn]+    -- The main trick here is that if we're importing all the constructors+    -- we want to say "T(..)", but if we're importing only a subset we want+    -- to say "T(A,B,C)".  So we have to find out what the module exports.+    to_ie _ (Avail n)+       = [IEVar noExt (to_ie_post_rn $ noLoc n)]+    to_ie _ (AvailTC n [m] [])+       | n==m = [IEThingAbs noExt (to_ie_post_rn $ noLoc n)]+    to_ie iface (AvailTC n ns fs)+      = case [(xs,gs) |  AvailTC x xs gs <- mi_exports iface+                 , x == n+                 , x `elem` xs    -- Note [Partial export]+                 ] of+           [xs] | all_used xs -> [IEThingAll noExt (to_ie_post_rn $ noLoc n)]+                | otherwise   ->+                   [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard+                                (map (to_ie_post_rn . noLoc) (filter (/= n) ns))+                                (map noLoc fs)]+                                          -- Note [Overloaded field import]+           _other | all_non_overloaded fs+                           -> map (IEVar noExt . to_ie_post_rn_var . noLoc) $ ns+                                 ++ map flSelector fs+                  | otherwise ->+                      [IEThingWith noExt (to_ie_post_rn $ noLoc n) NoIEWildcard+                                (map (to_ie_post_rn . noLoc) (filter (/= n) ns))+                                (map noLoc fs)]+        where++          fld_lbls = map flLabel fs++          all_used (avail_occs, avail_flds)+              = all (`elem` ns) avail_occs+                    && all (`elem` fld_lbls) (map flLabel avail_flds)++          all_non_overloaded = all (not . flIsOverloaded)++printMinimalImports :: [ImportDeclUsage] -> RnM ()+-- See Note [Printing minimal imports]+printMinimalImports imports_w_usage+  = do { imports' <- getMinimalImports imports_w_usage+       ; this_mod <- getModule+       ; dflags   <- getDynFlags+       ; liftIO $+         do { h <- openFile (mkFilename dflags this_mod) WriteMode+            ; printForUser dflags h neverQualify (vcat (map ppr imports')) }+              -- The neverQualify is important.  We are printing Names+              -- but they are in the context of an 'import' decl, and+              -- we never qualify things inside there+              -- E.g.   import Blag( f, b )+              -- not    import Blag( Blag.f, Blag.g )!+       }+  where+    mkFilename dflags this_mod+      | Just d <- dumpDir dflags = d </> basefn+      | otherwise                = basefn+      where+        basefn = moduleNameString (moduleName this_mod) ++ ".imports"+++to_ie_post_rn_var :: (HasOccName name) => Located name -> LIEWrappedName name+to_ie_post_rn_var (L l n)+  | isDataOcc $ occName n = L l (IEPattern (L l n))+  | otherwise             = L l (IEName    (L l n))+++to_ie_post_rn :: (HasOccName name) => Located name -> LIEWrappedName name+to_ie_post_rn (L l n)+  | isTcOcc occ && isSymOcc occ = L l (IEType (L l n))+  | otherwise                   = L l (IEName (L l n))+  where occ = occName n++{-+Note [Partial export]+~~~~~~~~~~~~~~~~~~~~~+Suppose we have++   module A( op ) where+     class C a where+       op :: a -> a++   module B where+   import A+   f = ..op...++Then the minimal import for module B is+   import A( op )+not+   import A( C( op ) )+which we would usually generate if C was exported from B.  Hence+the (x `elem` xs) test when deciding what to generate.+++Note [Overloaded field import]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On the other hand, if we have++    {-# LANGUAGE DuplicateRecordFields #-}+    module A where+      data T = MkT { foo :: Int }++    module B where+      import A+      f = ...foo...++then the minimal import for module B must be+    import A ( T(foo) )+because when DuplicateRecordFields is enabled, field selectors are+not in scope without their enclosing datatype.+++************************************************************************+*                                                                      *+\subsection{Errors}+*                                                                      *+************************************************************************+-}++qualImportItemErr :: RdrName -> SDoc+qualImportItemErr rdr+  = hang (text "Illegal qualified name in import item:")+       2 (ppr rdr)++badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc+badImportItemErrStd iface decl_spec ie+  = sep [text "Module", quotes (ppr (is_mod decl_spec)), source_import,+         text "does not export", quotes (ppr ie)]+  where+    source_import | mi_boot iface = text "(hi-boot interface)"+                  | otherwise     = Outputable.empty++badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE GhcPs+                        -> SDoc+badImportItemErrDataCon dataType_occ iface decl_spec ie+  = vcat [ text "In module"+             <+> quotes (ppr (is_mod decl_spec))+             <+> source_import <> colon+         , nest 2 $ quotes datacon+             <+> text "is a data constructor of"+             <+> quotes dataType+         , text "To import it use"+         , nest 2 $ text "import"+             <+> ppr (is_mod decl_spec)+             <> parens_sp (dataType <> parens_sp datacon)+         , text "or"+         , nest 2 $ text "import"+             <+> ppr (is_mod decl_spec)+             <> parens_sp (dataType <> text "(..)")+         ]+  where+    datacon_occ = rdrNameOcc $ ieName ie+    datacon = parenSymOcc datacon_occ (ppr datacon_occ)+    dataType = parenSymOcc dataType_occ (ppr dataType_occ)+    source_import | mi_boot iface = text "(hi-boot interface)"+                  | otherwise     = Outputable.empty+    parens_sp d = parens (space <> d <> space)  -- T( f,g )++badImportItemErr :: ModIface -> ImpDeclSpec -> IE GhcPs -> [AvailInfo] -> SDoc+badImportItemErr iface decl_spec ie avails+  = case find checkIfDataCon avails of+      Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie+      Nothing  -> badImportItemErrStd iface decl_spec ie+  where+    checkIfDataCon (AvailTC _ ns _) =+      case find (\n -> importedFS == nameOccNameFS n) ns of+        Just n  -> isDataConName n+        Nothing -> False+    checkIfDataCon _ = False+    availOccName = nameOccName . availName+    nameOccNameFS = occNameFS . nameOccName+    importedFS = occNameFS . rdrNameOcc $ ieName ie++illegalImportItemErr :: SDoc+illegalImportItemErr = text "Illegal import item"++dodgyImportWarn :: RdrName -> SDoc+dodgyImportWarn item+  = dodgyMsg (text "import") item (dodgyMsgInsert item :: IE GhcPs)++dodgyMsg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc+dodgyMsg kind tc ie+  = sep [ text "The" <+> kind <+> ptext (sLit "item")+                    -- <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc))))+                     <+> quotes (ppr ie)+                <+> text "suggests that",+          quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,",+          text "but it has none" ]++dodgyMsgInsert :: forall p . IdP (GhcPass p) -> IE (GhcPass p)+dodgyMsgInsert tc = IEThingAll noExt ii+  where+    ii :: LIEWrappedName (IdP (GhcPass p))+    ii = noLoc (IEName $ noLoc tc)+++addDupDeclErr :: [GlobalRdrElt] -> TcRn ()+addDupDeclErr [] = panic "addDupDeclErr: empty list"+addDupDeclErr gres@(gre : _)+  = addErrAt (getSrcSpan (last sorted_names)) $+    -- Report the error at the later location+    vcat [text "Multiple declarations of" <+>+             quotes (ppr (nameOccName name)),+             -- NB. print the OccName, not the Name, because the+             -- latter might not be in scope in the RdrEnv and so will+             -- be printed qualified.+          text "Declared at:" <+>+                   vcat (map (ppr . nameSrcLoc) sorted_names)]+  where+    name = gre_name gre+    sorted_names = sortWith nameSrcLoc (map gre_name gres)++++missingImportListWarn :: ModuleName -> SDoc+missingImportListWarn mod+  = text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list")++missingImportListItem :: IE GhcPs -> SDoc+missingImportListItem ie+  = text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list")++moduleWarn :: ModuleName -> WarningTxt -> SDoc+moduleWarn mod (WarningTxt _ txt)+  = sep [ text "Module" <+> quotes (ppr mod) <> ptext (sLit ":"),+          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]+moduleWarn mod (DeprecatedTxt _ txt)+  = sep [ text "Module" <+> quotes (ppr mod)+                                <+> text "is deprecated:",+          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]++packageImportErr :: SDoc+packageImportErr+  = text "Package-qualified imports are not enabled; use PackageImports"++-- This data decl will parse OK+--      data T = a Int+-- treating "a" as the constructor.+-- It is really hard to make the parser spot this malformation.+-- So the renamer has to check that the constructor is legal+--+-- We can get an operator as the constructor, even in the prefix form:+--      data T = :% Int Int+-- from interface files, which always print in prefix form++checkConName :: RdrName -> TcRn ()+checkConName name = checkErr (isRdrDataCon name) (badDataCon name)++badDataCon :: RdrName -> SDoc+badDataCon name+   = hsep [text "Illegal data constructor name", quotes (ppr name)]
+ compiler/rename/RnPat.hs view
@@ -0,0 +1,901 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[RnPat]{Renaming of patterns}++Basically dependency analysis.++Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In+general, all of these functions return a renamed thing, and a set of+free variables.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++module RnPat (-- main entry points+              rnPat, rnPats, rnBindPat, rnPatAndThen,++              NameMaker, applyNameMaker,     -- a utility for making names:+              localRecNameMaker, topRecNameMaker,  --   sometimes we want to make local names,+                                             --   sometimes we want to make top (qualified) names.+              isTopRecNameMaker,++              rnHsRecFields, HsRecFieldContext(..),+              rnHsRecUpdFields,++              -- CpsRn monad+              CpsRn, liftCps,++              -- Literals+              rnLit, rnOverLit,++             -- Pattern Error messages that are also used elsewhere+             checkTupSize, patSigErr+             ) where++-- ENH: thin imports to only what is necessary for patterns++import GhcPrelude++import {-# SOURCE #-} RnExpr ( rnLExpr )+import {-# SOURCE #-} RnSplice ( rnSplicePat )++#include "HsVersions.h"++import HsSyn+import TcRnMonad+import TcHsSyn             ( hsOverLitName )+import RnEnv+import RnFixity+import RnUtils             ( HsDocContext(..), newLocalBndrRn, bindLocalNames+                           , warnUnusedMatches, newLocalBndrRn+                           , checkUnusedRecordWildcard+                           , checkDupNames, checkDupAndShadowedNames+                           , checkTupSize , unknownSubordinateErr )+import RnTypes+import PrelNames+import Name+import NameSet+import RdrName+import BasicTypes+import Util+import ListSetOps          ( removeDups )+import Outputable+import SrcLoc+import Literal             ( inCharRange )+import TysWiredIn          ( nilDataCon )+import DataCon+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad       ( when, liftM, ap, guard )+import qualified Data.List.NonEmpty as NE+import Data.Ratio++{-+*********************************************************+*                                                      *+        The CpsRn Monad+*                                                      *+*********************************************************++Note [CpsRn monad]+~~~~~~~~~~~~~~~~~~+The CpsRn monad uses continuation-passing style to support this+style of programming:++        do { ...+           ; ns <- bindNames rs+           ; ...blah... }++   where rs::[RdrName], ns::[Name]++The idea is that '...blah...'+  a) sees the bindings of ns+  b) returns the free variables it mentions+     so that bindNames can report unused ones++In particular,+    mapM rnPatAndThen [p1, p2, p3]+has a *left-to-right* scoping: it makes the binders in+p1 scope over p2,p3.+-}++newtype CpsRn b = CpsRn { unCpsRn :: forall r. (b -> RnM (r, FreeVars))+                                            -> RnM (r, FreeVars) }+        -- See Note [CpsRn monad]++instance Functor CpsRn where+    fmap = liftM++instance Applicative CpsRn where+    pure x = CpsRn (\k -> k x)+    (<*>) = ap++instance Monad CpsRn where+  (CpsRn m) >>= mk = CpsRn (\k -> m (\v -> unCpsRn (mk v) k))++runCps :: CpsRn a -> RnM (a, FreeVars)+runCps (CpsRn m) = m (\r -> return (r, emptyFVs))++liftCps :: RnM a -> CpsRn a+liftCps rn_thing = CpsRn (\k -> rn_thing >>= k)++liftCpsFV :: RnM (a, FreeVars) -> CpsRn a+liftCpsFV rn_thing = CpsRn (\k -> do { (v,fvs1) <- rn_thing+                                     ; (r,fvs2) <- k v+                                     ; return (r, fvs1 `plusFV` fvs2) })++wrapSrcSpanCps :: (HasSrcSpan a, HasSrcSpan b) =>+                  (SrcSpanLess a -> CpsRn (SrcSpanLess b)) -> a -> CpsRn b+-- Set the location, and also wrap it around the value returned+wrapSrcSpanCps fn (dL->L loc a)+  = CpsRn (\k -> setSrcSpan loc $+                 unCpsRn (fn a) $ \v ->+                 k (cL loc v))++lookupConCps :: Located RdrName -> CpsRn (Located Name)+lookupConCps con_rdr+  = CpsRn (\k -> do { con_name <- lookupLocatedOccRn con_rdr+                    ; (r, fvs) <- k con_name+                    ; return (r, addOneFV fvs (unLoc con_name)) })+    -- We add the constructor name to the free vars+    -- See Note [Patterns are uses]++{-+Note [Patterns are uses]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  module Foo( f, g ) where+  data T = T1 | T2++  f T1 = True+  f T2 = False++  g _ = T1++Arguably we should report T2 as unused, even though it appears in a+pattern, because it never occurs in a constructed position.  See+#7336.+However, implementing this in the face of pattern synonyms would be+less straightforward, since given two pattern synonyms++  pattern P1 <- P2+  pattern P2 <- ()++we need to observe the dependency between P1 and P2 so that type+checking can be done in the correct order (just like for value+bindings). Dependencies between bindings is analyzed in the renamer,+where we don't know yet whether P2 is a constructor or a pattern+synonym. So for now, we do report conid occurrences in patterns as+uses.++*********************************************************+*                                                      *+        Name makers+*                                                      *+*********************************************************++Externally abstract type of name makers,+which is how you go from a RdrName to a Name+-}++data NameMaker+  = LamMk       -- Lambdas+      Bool      -- True <=> report unused bindings+                --   (even if True, the warning only comes out+                --    if -Wunused-matches is on)++  | LetMk       -- Let bindings, incl top level+                -- Do *not* check for unused bindings+      TopLevelFlag+      MiniFixityEnv++topRecNameMaker :: MiniFixityEnv -> NameMaker+topRecNameMaker fix_env = LetMk TopLevel fix_env++isTopRecNameMaker :: NameMaker -> Bool+isTopRecNameMaker (LetMk TopLevel _) = True+isTopRecNameMaker _ = False++localRecNameMaker :: MiniFixityEnv -> NameMaker+localRecNameMaker fix_env = LetMk NotTopLevel fix_env++matchNameMaker :: HsMatchContext a -> NameMaker+matchNameMaker ctxt = LamMk report_unused+  where+    -- Do not report unused names in interactive contexts+    -- i.e. when you type 'x <- e' at the GHCi prompt+    report_unused = case ctxt of+                      StmtCtxt GhciStmtCtxt -> False+                      -- also, don't warn in pattern quotes, as there+                      -- is no RHS where the variables can be used!+                      ThPatQuote            -> False+                      _                     -> True++rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn)+rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped AlwaysBind PatCtx sig)++newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)+newPatLName name_maker rdr_name@(dL->L loc _)+  = do { name <- newPatName name_maker rdr_name+       ; return (cL loc name) }++newPatName :: NameMaker -> Located RdrName -> CpsRn Name+newPatName (LamMk report_unused) rdr_name+  = CpsRn (\ thing_inside ->+        do { name <- newLocalBndrRn rdr_name+           ; (res, fvs) <- bindLocalNames [name] (thing_inside name)+           ; when report_unused $ warnUnusedMatches [name] fvs+           ; return (res, name `delFV` fvs) })++newPatName (LetMk is_top fix_env) rdr_name+  = CpsRn (\ thing_inside ->+        do { name <- case is_top of+                       NotTopLevel -> newLocalBndrRn rdr_name+                       TopLevel    -> newTopSrcBinder rdr_name+           ; bindLocalNames [name] $       -- Do *not* use bindLocalNameFV here+                                        -- See Note [View pattern usage]+             addLocalFixities fix_env [name] $+             thing_inside name })++    -- Note: the bindLocalNames is somewhat suspicious+    --       because it binds a top-level name as a local name.+    --       however, this binding seems to work, and it only exists for+    --       the duration of the patterns and the continuation;+    --       then the top-level name is added to the global env+    --       before going on to the RHSes (see RnSource.hs).++{-+Note [View pattern usage]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  let (r, (r -> x)) = x in ...+Here the pattern binds 'r', and then uses it *only* in the view pattern.+We want to "see" this use, and in let-bindings we collect all uses and+report unused variables at the binding level. So we must use bindLocalNames+here, *not* bindLocalNameFV.  #3943.+++Note [Don't report shadowing for pattern synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is one special context where a pattern doesn't introduce any new binders -+pattern synonym declarations. Therefore we don't check to see if pattern+variables shadow existing identifiers as they are never bound to anything+and have no scope.++Without this check, there would be quite a cryptic warning that the `x`+in the RHS of the pattern synonym declaration shadowed the top level `x`.++```+x :: ()+x = ()++pattern P x = Just x+```++See #12615 for some more examples.++*********************************************************+*                                                      *+        External entry points+*                                                      *+*********************************************************++There are various entry points to renaming patterns, depending on+ (1) whether the names created should be top-level names or local names+ (2) whether the scope of the names is entirely given in a continuation+     (e.g., in a case or lambda, but not in a let or at the top-level,+      because of the way mutually recursive bindings are handled)+ (3) whether the a type signature in the pattern can bind+        lexically-scoped type variables (for unpacking existential+        type vars in data constructors)+ (4) whether we do duplicate and unused variable checking+ (5) whether there are fixity declarations associated with the names+     bound by the patterns that need to be brought into scope with them.++ Rather than burdening the clients of this module with all of these choices,+ we export the three points in this design space that we actually need:+-}++-- ----------- Entry point 1: rnPats -------------------+-- Binds local names; the scope of the bindings is entirely in the thing_inside+--   * allows type sigs to bind type vars+--   * local namemaker+--   * unused and duplicate checking+--   * no fixities+rnPats :: HsMatchContext Name -- for error messages+       -> [LPat GhcPs]+       -> ([LPat GhcRn] -> RnM (a, FreeVars))+       -> RnM (a, FreeVars)+rnPats ctxt pats thing_inside+  = do  { envs_before <- getRdrEnvs++          -- (1) rename the patterns, bringing into scope all of the term variables+          -- (2) then do the thing inside.+        ; unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do+        { -- Check for duplicated and shadowed names+          -- Must do this *after* renaming the patterns+          -- See Note [Collect binders only after renaming] in HsUtils+          -- Because we don't bind the vars all at once, we can't+          --    check incrementally for duplicates;+          -- Nor can we check incrementally for shadowing, else we'll+          --    complain *twice* about duplicates e.g. f (x,x) = ...+          --+          -- See note [Don't report shadowing for pattern synonyms]+        ; let bndrs = collectPatsBinders pats'+        ; addErrCtxt doc_pat $+          if isPatSynCtxt ctxt+             then checkDupNames bndrs+             else checkDupAndShadowedNames envs_before bndrs+        ; thing_inside pats' } }+  where+    doc_pat = text "In" <+> pprMatchContext ctxt++rnPat :: HsMatchContext Name -- for error messages+      -> LPat GhcPs+      -> (LPat GhcRn -> RnM (a, FreeVars))+      -> RnM (a, FreeVars)     -- Variables bound by pattern do not+                               -- appear in the result FreeVars+rnPat ctxt pat thing_inside+  = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat')++applyNameMaker :: NameMaker -> Located RdrName -> RnM (Located Name)+applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr)+                           ; return n }++-- ----------- Entry point 2: rnBindPat -------------------+-- Binds local names; in a recursive scope that involves other bound vars+--      e.g let { (x, Just y) = e1; ... } in ...+--   * does NOT allows type sig to bind type vars+--   * local namemaker+--   * no unused and duplicate checking+--   * fixities might be coming in+rnBindPat :: NameMaker+          -> LPat GhcPs+          -> RnM (LPat GhcRn, FreeVars)+   -- Returned FreeVars are the free variables of the pattern,+   -- of course excluding variables bound by this pattern++rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat)++{-+*********************************************************+*                                                      *+        The main event+*                                                      *+*********************************************************+-}++-- ----------- Entry point 3: rnLPatAndThen -------------------+-- General version: parametrized by how you make new names++rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn]+rnLPatsAndThen mk = mapM (rnLPatAndThen mk)+  -- Despite the map, the monad ensures that each pattern binds+  -- variables that may be mentioned in subsequent patterns in the list++--------------------+-- The workhorse+rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn)+rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat++rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn)+rnPatAndThen _  (WildPat _)   = return (WildPat noExt)+rnPatAndThen mk (ParPat x pat)  = do { pat' <- rnLPatAndThen mk pat+                                     ; return (ParPat x pat') }+rnPatAndThen mk (LazyPat x pat) = do { pat' <- rnLPatAndThen mk pat+                                     ; return (LazyPat x pat') }+rnPatAndThen mk (BangPat x pat) = do { pat' <- rnLPatAndThen mk pat+                                     ; return (BangPat x pat') }+rnPatAndThen mk (VarPat x (dL->L l rdr))+    = do { loc <- liftCps getSrcSpanM+         ; name <- newPatName mk (cL loc rdr)+         ; return (VarPat x (cL l name)) }+     -- we need to bind pattern variables for view pattern expressions+     -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)++rnPatAndThen mk (SigPat x pat sig)+  -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is+  -- important to rename its type signature _before_ renaming the rest of the+  -- pattern, so that type variables are first bound by the _outermost_ pattern+  -- type signature they occur in. This keeps the type checker happy when+  -- pattern type signatures happen to be nested (#7827)+  --+  -- f ((Just (x :: a) :: Maybe a)+  -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^       `a' is first bound here+  -- ~~~~~~~~~~~~~~~^                   the same `a' then used here+  = do { sig' <- rnHsSigCps sig+       ; pat' <- rnLPatAndThen mk pat+       ; return (SigPat x pat' sig' ) }++rnPatAndThen mk (LitPat x lit)+  | HsString src s <- lit+  = do { ovlStr <- liftCps (xoptM LangExt.OverloadedStrings)+       ; if ovlStr+         then rnPatAndThen mk+                           (mkNPat (noLoc (mkHsIsString src s))+                                      Nothing)+         else normal_lit }+  | otherwise = normal_lit+  where+    normal_lit = do { liftCps (rnLit lit); return (LitPat x (convertLit lit)) }++rnPatAndThen _ (NPat x (dL->L l lit) mb_neg _eq)+  = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit+       ; mb_neg' -- See Note [Negative zero]+           <- let negative = do { (neg, fvs) <- lookupSyntaxName negateName+                                ; return (Just neg, fvs) }+                  positive = return (Nothing, emptyFVs)+              in liftCpsFV $ case (mb_neg , mb_neg') of+                                  (Nothing, Just _ ) -> negative+                                  (Just _ , Nothing) -> negative+                                  (Nothing, Nothing) -> positive+                                  (Just _ , Just _ ) -> positive+       ; eq' <- liftCpsFV $ lookupSyntaxName eqName+       ; return (NPat x (cL l lit') mb_neg' eq') }++rnPatAndThen mk (NPlusKPat x rdr (dL->L l lit) _ _ _ )+  = do { new_name <- newPatName mk rdr+       ; (lit', _) <- liftCpsFV $ rnOverLit lit -- See Note [Negative zero]+                                                -- We skip negateName as+                                                -- negative zero doesn't make+                                                -- sense in n + k patterns+       ; minus <- liftCpsFV $ lookupSyntaxName minusName+       ; ge    <- liftCpsFV $ lookupSyntaxName geName+       ; return (NPlusKPat x (cL (nameSrcSpan new_name) new_name)+                             (cL l lit') lit' ge minus) }+                -- The Report says that n+k patterns must be in Integral++rnPatAndThen mk (AsPat x rdr pat)+  = do { new_name <- newPatLName mk rdr+       ; pat' <- rnLPatAndThen mk pat+       ; return (AsPat x new_name pat') }++rnPatAndThen mk p@(ViewPat x expr pat)+  = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns+                      ; checkErr vp_flag (badViewPat p) }+         -- Because of the way we're arranging the recursive calls,+         -- this will be in the right context+       ; expr' <- liftCpsFV $ rnLExpr expr+       ; pat' <- rnLPatAndThen mk pat+       -- Note: at this point the PreTcType in ty can only be a placeHolder+       -- ; return (ViewPat expr' pat' ty) }+       ; return (ViewPat x expr' pat') }++rnPatAndThen mk (ConPatIn con stuff)+   -- rnConPatAndThen takes care of reconstructing the pattern+   -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.+  = case unLoc con == nameRdrName (dataConName nilDataCon) of+      True    -> do { ol_flag <- liftCps $ xoptM LangExt.OverloadedLists+                    ; if ol_flag then rnPatAndThen mk (ListPat noExt [])+                                 else rnConPatAndThen mk con stuff}+      False   -> rnConPatAndThen mk con stuff++rnPatAndThen mk (ListPat _ pats)+  = do { opt_OverloadedLists <- liftCps $ xoptM LangExt.OverloadedLists+       ; pats' <- rnLPatsAndThen mk pats+       ; case opt_OverloadedLists of+          True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName+                     ; return (ListPat (Just to_list_name) pats')}+          False -> return (ListPat Nothing pats') }++rnPatAndThen mk (TuplePat x pats boxed)+  = do { liftCps $ checkTupSize (length pats)+       ; pats' <- rnLPatsAndThen mk pats+       ; return (TuplePat x pats' boxed) }++rnPatAndThen mk (SumPat x pat alt arity)+  = do { pat <- rnLPatAndThen mk pat+       ; return (SumPat x pat alt arity)+       }++-- If a splice has been run already, just rename the result.+rnPatAndThen mk (SplicePat x (HsSpliced x2 mfs (HsSplicedPat pat)))+  = SplicePat x . HsSpliced x2 mfs . HsSplicedPat <$> rnPatAndThen mk pat++rnPatAndThen mk (SplicePat _ splice)+  = do { eith <- liftCpsFV $ rnSplicePat splice+       ; case eith of   -- See Note [rnSplicePat] in RnSplice+           Left  not_yet_renamed -> rnPatAndThen mk not_yet_renamed+           Right already_renamed -> return already_renamed }++rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat)+++--------------------+rnConPatAndThen :: NameMaker+                -> Located RdrName    -- the constructor+                -> HsConPatDetails GhcPs+                -> CpsRn (Pat GhcRn)++rnConPatAndThen mk con (PrefixCon pats)+  = do  { con' <- lookupConCps con+        ; pats' <- rnLPatsAndThen mk pats+        ; return (ConPatIn con' (PrefixCon pats')) }++rnConPatAndThen mk con (InfixCon pat1 pat2)+  = do  { con' <- lookupConCps con+        ; pat1' <- rnLPatAndThen mk pat1+        ; pat2' <- rnLPatAndThen mk pat2+        ; fixity <- liftCps $ lookupFixityRn (unLoc con')+        ; liftCps $ mkConOpPatRn con' fixity pat1' pat2' }++rnConPatAndThen mk con (RecCon rpats)+  = do  { con' <- lookupConCps con+        ; rpats' <- rnHsRecPatsAndThen mk con' rpats+        ; return (ConPatIn con' (RecCon rpats')) }++checkUnusedRecordWildcardCps :: SrcSpan -> Maybe [Name] -> CpsRn ()+checkUnusedRecordWildcardCps loc dotdot_names =+  CpsRn (\thing -> do+                    (r, fvs) <- thing ()+                    checkUnusedRecordWildcard loc fvs dotdot_names+                    return (r, fvs) )+--------------------+rnHsRecPatsAndThen :: NameMaker+                   -> Located Name      -- Constructor+                   -> HsRecFields GhcPs (LPat GhcPs)+                   -> CpsRn (HsRecFields GhcRn (LPat GhcRn))+rnHsRecPatsAndThen mk (dL->L _ con)+     hs_rec_fields@(HsRecFields { rec_dotdot = dd })+  = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat+                                            hs_rec_fields+       ; flds' <- mapM rn_field (flds `zip` [1..])+       ; check_unused_wildcard (implicit_binders flds' <$> dd)+       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }) }+  where+    mkVarPat l n = VarPat noExt (cL l n)+    rn_field (dL->L l fld, n') =+      do { arg' <- rnLPatAndThen (nested_mk dd mk n') (hsRecFieldArg fld)+         ; return (cL l (fld { hsRecFieldArg = arg' })) }++    loc = maybe noSrcSpan getLoc dd++    -- Get the arguments of the implicit binders+    implicit_binders fs (unLoc -> n) = collectPatsBinders implicit_pats+      where+        implicit_pats = map (hsRecFieldArg . unLoc) (drop n fs)++    -- Don't warn for let P{..} = ... in ...+    check_unused_wildcard = case mk of+                              LetMk{} -> const (return ())+                              LamMk{} -> checkUnusedRecordWildcardCps loc++        -- Suppress unused-match reporting for fields introduced by ".."+    nested_mk Nothing  mk                    _  = mk+    nested_mk (Just _) mk@(LetMk {})         _  = mk+    nested_mk (Just (unLoc -> n)) (LamMk report_unused) n'+      = LamMk (report_unused && (n' <= n))++{-+************************************************************************+*                                                                      *+        Record fields+*                                                                      *+************************************************************************+-}++data HsRecFieldContext+  = HsRecFieldCon Name+  | HsRecFieldPat Name+  | HsRecFieldUpd++rnHsRecFields+    :: forall arg. HasSrcSpan arg =>+       HsRecFieldContext+    -> (SrcSpan -> RdrName -> SrcSpanLess arg)+         -- When punning, use this to build a new field+    -> HsRecFields GhcPs arg+    -> RnM ([LHsRecField GhcRn arg], FreeVars)++-- This surprisingly complicated pass+--   a) looks up the field name (possibly using disambiguation)+--   b) fills in puns and dot-dot stuff+-- When we've finished, we've renamed the LHS, but not the RHS,+-- of each x=e binding+--+-- This is used for record construction and pattern-matching, but not updates.++rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot })+  = do { pun_ok      <- xoptM LangExt.RecordPuns+       ; disambig_ok <- xoptM LangExt.DisambiguateRecordFields+       ; let parent = guard disambig_ok >> mb_con+       ; flds1  <- mapM (rn_fld pun_ok parent) flds+       ; mapM_ (addErr . dupFieldErr ctxt) dup_flds+       ; dotdot_flds <- rn_dotdot dotdot mb_con flds1+       ; let all_flds | null dotdot_flds = flds1+                      | otherwise        = flds1 ++ dotdot_flds+       ; return (all_flds, mkFVs (getFieldIds all_flds)) }+  where+    mb_con = case ctxt of+                HsRecFieldCon con  -> Just con+                HsRecFieldPat con  -> Just con+                _ {- update -}     -> Nothing++    rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs arg+           -> RnM (LHsRecField GhcRn arg)+    rn_fld pun_ok parent (dL->L l+                           (HsRecField+                              { hsRecFieldLbl =+                                  (dL->L loc (FieldOcc _ (dL->L ll lbl)))+                              , hsRecFieldArg = arg+                              , hsRecPun      = pun }))+      = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent lbl+           ; arg' <- if pun+                     then do { checkErr pun_ok (badPun (cL loc lbl))+                               -- Discard any module qualifier (#11662)+                             ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)+                             ; return (cL loc (mk_arg loc arg_rdr)) }+                     else return arg+           ; return (cL l (HsRecField+                             { hsRecFieldLbl = (cL loc (FieldOcc+                                                          sel (cL ll lbl)))+                             , hsRecFieldArg = arg'+                             , hsRecPun      = pun })) }+    rn_fld _ _ (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _))+      = panic "rnHsRecFields"+    rn_fld _ _ _ = panic "rn_fld: Impossible Match"+                                -- due to #15884+++    rn_dotdot :: Maybe (Located Int)      -- See Note [DotDot fields] in HsPat+              -> Maybe Name -- The constructor (Nothing for an+                                --    out of scope constructor)+              -> [LHsRecField GhcRn arg] -- Explicit fields+              -> RnM ([LHsRecField GhcRn arg])   -- Field Labels we need to fill in+    rn_dotdot (Just (dL -> L loc n)) (Just con) flds -- ".." on record construction / pat match+      | not (isUnboundName con) -- This test is because if the constructor+                                -- isn't in scope the constructor lookup will add+                                -- an error but still return an unbound name. We+                                -- don't want that to screw up the dot-dot fill-in stuff.+      = ASSERT( flds `lengthIs` n )+        do { dd_flag <- xoptM LangExt.RecordWildCards+           ; checkErr dd_flag (needFlagDotDot ctxt)+           ; (rdr_env, lcl_env) <- getRdrEnvs+           ; con_fields <- lookupConstructorFields con+           ; when (null con_fields) (addErr (badDotDotCon con))+           ; let present_flds = mkOccSet $ map rdrNameOcc (getFieldLbls flds)++                   -- For constructor uses (but not patterns)+                   -- the arg should be in scope locally;+                   -- i.e. not top level or imported+                   -- Eg.  data R = R { x,y :: Int }+                   --      f x = R { .. }   -- Should expand to R {x=x}, not R{x=x,y=y}+                 arg_in_scope lbl = mkRdrUnqual lbl `elemLocalRdrEnv` lcl_env++                 (dot_dot_fields, dot_dot_gres)+                        = unzip [ (fl, gre)+                                | fl <- con_fields+                                , let lbl = mkVarOccFS (flLabel fl)+                                , not (lbl `elemOccSet` present_flds)+                                , Just gre <- [lookupGRE_FieldLabel rdr_env fl]+                                              -- Check selector is in scope+                                , case ctxt of+                                    HsRecFieldCon {} -> arg_in_scope lbl+                                    _other           -> True ]++           ; addUsedGREs dot_dot_gres+           ; return [ cL loc (HsRecField+                        { hsRecFieldLbl = cL loc (FieldOcc sel (cL loc arg_rdr))+                        , hsRecFieldArg = cL loc (mk_arg loc arg_rdr)+                        , hsRecPun      = False })+                    | fl <- dot_dot_fields+                    , let sel     = flSelector fl+                    , let arg_rdr = mkVarUnqual (flLabel fl) ] }++    rn_dotdot _dotdot _mb_con _flds+      = return []+      -- _dotdot = Nothing => No ".." at all+      -- _mb_con = Nothing => Record update+      -- _mb_con = Just unbound => Out of scope data constructor++    dup_flds :: [NE.NonEmpty RdrName]+        -- Each list represents a RdrName that occurred more than once+        -- (the list contains all occurrences)+        -- Each list in dup_fields is non-empty+    (_, dup_flds) = removeDups compare (getFieldLbls flds)+++-- NB: Consider this:+--      module Foo where { data R = R { fld :: Int } }+--      module Odd where { import Foo; fld x = x { fld = 3 } }+-- Arguably this should work, because the reference to 'fld' is+-- unambiguous because there is only one field id 'fld' in scope.+-- But currently it's rejected.++rnHsRecUpdFields+    :: [LHsRecUpdField GhcPs]+    -> RnM ([LHsRecUpdField GhcRn], FreeVars)+rnHsRecUpdFields flds+  = do { pun_ok        <- xoptM LangExt.RecordPuns+       ; overload_ok   <- xoptM LangExt.DuplicateRecordFields+       ; (flds1, fvss) <- mapAndUnzipM (rn_fld pun_ok overload_ok) flds+       ; mapM_ (addErr . dupFieldErr HsRecFieldUpd) dup_flds++       -- Check for an empty record update  e {}+       -- NB: don't complain about e { .. }, because rn_dotdot has done that already+       ; when (null flds) $ addErr emptyUpdateErr++       ; return (flds1, plusFVs fvss) }+  where+    doc = text "constructor field name"++    rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs+           -> RnM (LHsRecUpdField GhcRn, FreeVars)+    rn_fld pun_ok overload_ok (dL->L l (HsRecField { hsRecFieldLbl = dL->L loc f+                                                   , hsRecFieldArg = arg+                                                   , hsRecPun      = pun }))+      = do { let lbl = rdrNameAmbiguousFieldOcc f+           ; sel <- setSrcSpan loc $+                      -- Defer renaming of overloaded fields to the typechecker+                      -- See Note [Disambiguating record fields] in TcExpr+                      if overload_ok+                          then do { mb <- lookupGlobalOccRn_overloaded+                                            overload_ok lbl+                                  ; case mb of+                                      Nothing ->+                                        do { addErr+                                               (unknownSubordinateErr doc lbl)+                                           ; return (Right []) }+                                      Just r  -> return r }+                          else fmap Left $ lookupGlobalOccRn lbl+           ; arg' <- if pun+                     then do { checkErr pun_ok (badPun (cL loc lbl))+                               -- Discard any module qualifier (#11662)+                             ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl)+                             ; return (cL loc (HsVar noExt (cL loc arg_rdr))) }+                     else return arg+           ; (arg'', fvs) <- rnLExpr arg'++           ; let fvs' = case sel of+                          Left sel_name -> fvs `addOneFV` sel_name+                          Right [sel_name] -> fvs `addOneFV` sel_name+                          Right _       -> fvs+                 lbl' = case sel of+                          Left sel_name ->+                                     cL loc (Unambiguous sel_name  (cL loc lbl))+                          Right [sel_name] ->+                                     cL loc (Unambiguous sel_name  (cL loc lbl))+                          Right _ -> cL loc (Ambiguous   noExt     (cL loc lbl))++           ; return (cL l (HsRecField { hsRecFieldLbl = lbl'+                                      , hsRecFieldArg = arg''+                                      , hsRecPun      = pun }), fvs') }++    dup_flds :: [NE.NonEmpty RdrName]+        -- Each list represents a RdrName that occurred more than once+        -- (the list contains all occurrences)+        -- Each list in dup_fields is non-empty+    (_, dup_flds) = removeDups compare (getFieldUpdLbls flds)++++getFieldIds :: [LHsRecField GhcRn arg] -> [Name]+getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds++getFieldLbls :: [LHsRecField id arg] -> [RdrName]+getFieldLbls flds+  = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds++getFieldUpdLbls :: [LHsRecUpdField GhcPs] -> [RdrName]+getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds++needFlagDotDot :: HsRecFieldContext -> SDoc+needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt,+                            text "Use RecordWildCards to permit this"]++badDotDotCon :: Name -> SDoc+badDotDotCon con+  = vcat [ text "Illegal `..' notation for constructor" <+> quotes (ppr con)+         , nest 2 (text "The constructor has no labelled fields") ]++emptyUpdateErr :: SDoc+emptyUpdateErr = text "Empty record update"++badPun :: Located RdrName -> SDoc+badPun fld = vcat [text "Illegal use of punning for field" <+> quotes (ppr fld),+                   text "Use NamedFieldPuns to permit this"]++dupFieldErr :: HsRecFieldContext -> NE.NonEmpty RdrName -> SDoc+dupFieldErr ctxt dups+  = hsep [text "duplicate field name",+          quotes (ppr (NE.head dups)),+          text "in record", pprRFC ctxt]++pprRFC :: HsRecFieldContext -> SDoc+pprRFC (HsRecFieldCon {}) = text "construction"+pprRFC (HsRecFieldPat {}) = text "pattern"+pprRFC (HsRecFieldUpd {}) = text "update"++{-+************************************************************************+*                                                                      *+\subsubsection{Literals}+*                                                                      *+************************************************************************++When literals occur we have to make sure+that the types and classes they involve+are made available.+-}++rnLit :: HsLit p -> RnM ()+rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c)+rnLit _ = return ()++-- Turn a Fractional-looking literal which happens to be an integer into an+-- Integer-looking literal.+generalizeOverLitVal :: OverLitVal -> OverLitVal+generalizeOverLitVal (HsFractional (FL {fl_text=src,fl_neg=neg,fl_value=val}))+    | denominator val == 1 = HsIntegral (IL { il_text=src+                                            , il_neg=neg+                                            , il_value=numerator val})+generalizeOverLitVal lit = lit++isNegativeZeroOverLit :: HsOverLit t -> Bool+isNegativeZeroOverLit lit+ = case ol_val lit of+        HsIntegral i   -> 0 == il_value i && il_neg i+        HsFractional f -> 0 == fl_value f && fl_neg f+        _              -> False++{-+Note [Negative zero]+~~~~~~~~~~~~~~~~~~~~~~~~~+There were problems with negative zero in conjunction with Negative Literals+extension. Numeric literal value is contained in Integer and Rational types+inside IntegralLit and FractionalLit. These types cannot represent negative+zero value. So we had to add explicit field 'neg' which would hold information+about literal sign. Here in rnOverLit we use it to detect negative zeroes and+in this case return not only literal itself but also negateName so that users+can apply it explicitly. In this case it stays negative zero.  #13211+-}++rnOverLit :: HsOverLit t ->+             RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars)+rnOverLit origLit+  = do  { opt_NumDecimals <- xoptM LangExt.NumDecimals+        ; let { lit@(OverLit {ol_val=val})+            | opt_NumDecimals = origLit {ol_val = generalizeOverLitVal (ol_val origLit)}+            | otherwise       = origLit+          }+        ; let std_name = hsOverLitName val+        ; (SyntaxExpr { syn_expr = from_thing_name }, fvs1)+            <- lookupSyntaxName std_name+        ; let rebindable = case from_thing_name of+                                HsVar _ lv -> (unLoc lv) /= std_name+                                _          -> panic "rnOverLit"+        ; let lit' = lit { ol_witness = from_thing_name+                         , ol_ext = rebindable }+        ; if isNegativeZeroOverLit lit'+          then do { (SyntaxExpr { syn_expr = negate_name }, fvs2)+                      <- lookupSyntaxName negateName+                  ; return ((lit' { ol_val = negateOverLitVal val }, Just negate_name)+                                  , fvs1 `plusFV` fvs2) }+          else return ((lit', Nothing), fvs1) }++{-+************************************************************************+*                                                                      *+\subsubsection{Errors}+*                                                                      *+************************************************************************+-}++patSigErr :: Outputable a => a -> SDoc+patSigErr ty+  =  (text "Illegal signature in pattern:" <+> ppr ty)+        $$ nest 4 (text "Use ScopedTypeVariables to permit it")++bogusCharError :: Char -> SDoc+bogusCharError c+  = text "character literal out of range: '\\" <> char c  <> char '\''++badViewPat :: Pat GhcPs -> SDoc+badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat,+                       text "Use ViewPatterns to enable view patterns"]
+ compiler/rename/RnSource.hs view
@@ -0,0 +1,2374 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[RnSource]{Main pass of renamer}+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module RnSource (+        rnSrcDecls, addTcgDUs, findSplice+    ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-} RnExpr( rnLExpr )+import {-# SOURCE #-} RnSplice ( rnSpliceDecl, rnTopSpliceDecls )++import HsSyn+import FieldLabel+import RdrName+import RnTypes+import RnBinds+import RnEnv+import RnUtils          ( HsDocContext(..), mapFvRn, bindLocalNames+                        , checkDupRdrNames, inHsDocContext, bindLocalNamesFV+                        , checkShadowedRdrNames, warnUnusedTypePatterns+                        , extendTyVarEnvFVRn, newLocalBndrsRn+                        , withHsDocContext )+import RnUnbound        ( mkUnboundName, notInScopeErr )+import RnNames+import RnHsDoc          ( rnHsDoc, rnMbLHsDoc )+import TcAnnotations    ( annCtxt )+import TcRnMonad++import ForeignCall      ( CCallTarget(..) )+import Module+import HscTypes         ( Warnings(..), plusWarns )+import PrelNames        ( applicativeClassName, pureAName, thenAName+                        , monadClassName, returnMName, thenMName+                        , semigroupClassName, sappendName+                        , monoidClassName, mappendName+                        )+import Name+import NameSet+import NameEnv+import Avail+import Outputable+import Bag+import BasicTypes       ( pprRuleName )+import FastString+import SrcLoc+import DynFlags+import Util             ( debugIsOn, filterOut, lengthExceeds, partitionWith )+import HscTypes         ( HscEnv, hsc_dflags )+import ListSetOps       ( findDupsEq, removeDups, equivClasses )+import Digraph          ( SCC, flattenSCC, flattenSCCs, Node(..)+                        , stronglyConnCompFromEdgedVerticesUniq )+import UniqSet+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Control.Arrow ( first )+import Data.List ( mapAccumL )+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty ( NonEmpty(..) )+import Data.Maybe ( isNothing, fromMaybe )+import qualified Data.Set as Set ( difference, fromList, toList, null )++{- | @rnSourceDecl@ "renames" declarations.+It simultaneously performs dependency analysis and precedence parsing.+It also does the following error checks:++* Checks that tyvars are used properly. This includes checking+  for undefined tyvars, and tyvars in contexts that are ambiguous.+  (Some of this checking has now been moved to module @TcMonoType@,+  since we don't have functional dependency information at this point.)++* Checks that all variable occurrences are defined.++* Checks the @(..)@ etc constraints in the export list.++Brings the binders of the group into scope in the appropriate places;+does NOT assume that anything is in scope already+-}+rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn)+-- Rename a top-level HsGroup; used for normal source files *and* hs-boot files+rnSrcDecls group@(HsGroup { hs_valds   = val_decls,+                            hs_splcds  = splice_decls,+                            hs_tyclds  = tycl_decls,+                            hs_derivds = deriv_decls,+                            hs_fixds   = fix_decls,+                            hs_warnds  = warn_decls,+                            hs_annds   = ann_decls,+                            hs_fords   = foreign_decls,+                            hs_defds   = default_decls,+                            hs_ruleds  = rule_decls,+                            hs_docs    = docs })+ = do {+   -- (A) Process the fixity declarations, creating a mapping from+   --     FastStrings to FixItems.+   --     Also checks for duplicates.+   local_fix_env <- makeMiniFixityEnv fix_decls ;++   -- (B) Bring top level binders (and their fixities) into scope,+   --     *except* for the value bindings, which get done in step (D)+   --     with collectHsIdBinders. However *do* include+   --+   --        * Class ops, data constructors, and record fields,+   --          because they do not have value declarations.+   --+   --        * For hs-boot files, include the value signatures+   --          Again, they have no value declarations+   --+   (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;+++   setEnvs tc_envs $ do {++   failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations++   -- (D1) Bring pattern synonyms into scope.+   --      Need to do this before (D2) because rnTopBindsLHS+   --      looks up those pattern synonyms (#9889)++   extendPatSynEnv val_decls local_fix_env $ \pat_syn_bndrs -> do {++   -- (D2) Rename the left-hand sides of the value bindings.+   --     This depends on everything from (B) being in scope.+   --     It uses the fixity env from (A) to bind fixities for view patterns.+   new_lhs <- rnTopBindsLHS local_fix_env val_decls ;++   -- Bind the LHSes (and their fixities) in the global rdr environment+   let { id_bndrs = collectHsIdBinders new_lhs } ;  -- Excludes pattern-synonym binders+                                                    -- They are already in scope+   traceRn "rnSrcDecls" (ppr id_bndrs) ;+   tc_envs <- extendGlobalRdrEnvRn (map avail id_bndrs) local_fix_env ;+   setEnvs tc_envs $ do {++   --  Now everything is in scope, as the remaining renaming assumes.++   -- (E) Rename type and class decls+   --     (note that value LHSes need to be in scope for default methods)+   --+   -- You might think that we could build proper def/use information+   -- for type and class declarations, but they can be involved+   -- in mutual recursion across modules, and we only do the SCC+   -- analysis for them in the type checker.+   -- So we content ourselves with gathering uses only; that+   -- means we'll only report a declaration as unused if it isn't+   -- mentioned at all.  Ah well.+   traceRn "Start rnTyClDecls" (ppr tycl_decls) ;+   (rn_tycl_decls, src_fvs1) <- rnTyClDecls tycl_decls ;++   -- (F) Rename Value declarations right-hand sides+   traceRn "Start rnmono" empty ;+   let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;+   is_boot <- tcIsHsBootOrSig ;+   (rn_val_decls, bind_dus) <- if is_boot+    -- For an hs-boot, use tc_bndrs (which collects how we're renamed+    -- signatures), since val_bndr_set is empty (there are no x = ...+    -- bindings in an hs-boot.)+    then rnTopBindsBoot tc_bndrs new_lhs+    else rnValBindsRHS (TopSigCtxt val_bndr_set) new_lhs ;+   traceRn "finish rnmono" (ppr rn_val_decls) ;++   -- (G) Rename Fixity and deprecations++   -- Rename fixity declarations and error if we try to+   -- fix something from another module (duplicates were checked in (A))+   let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;+   rn_fix_decls <- mapM (mapM (rnSrcFixityDecl (TopSigCtxt all_bndrs)))+                        fix_decls ;++   -- Rename deprec decls;+   -- check for duplicates and ensure that deprecated things are defined locally+   -- at the moment, we don't keep these around past renaming+   rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;++   -- (H) Rename Everything else++   (rn_rule_decls,    src_fvs2) <- setXOptM LangExt.ScopedTypeVariables $+                                   rnList rnHsRuleDecls rule_decls ;+                           -- Inside RULES, scoped type variables are on+   (rn_foreign_decls, src_fvs3) <- rnList rnHsForeignDecl foreign_decls ;+   (rn_ann_decls,     src_fvs4) <- rnList rnAnnDecl       ann_decls ;+   (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl   default_decls ;+   (rn_deriv_decls,   src_fvs6) <- rnList rnSrcDerivDecl  deriv_decls ;+   (rn_splice_decls,  src_fvs7) <- rnList rnSpliceDecl    splice_decls ;+      -- Haddock docs; no free vars+   rn_docs <- mapM (wrapLocM rnDocDecl) docs ;++   last_tcg_env <- getGblEnv ;+   -- (I) Compute the results and return+   let {rn_group = HsGroup { hs_ext     = noExt,+                             hs_valds   = rn_val_decls,+                             hs_splcds  = rn_splice_decls,+                             hs_tyclds  = rn_tycl_decls,+                             hs_derivds = rn_deriv_decls,+                             hs_fixds   = rn_fix_decls,+                             hs_warnds  = [], -- warns are returned in the tcg_env+                                             -- (see below) not in the HsGroup+                             hs_fords  = rn_foreign_decls,+                             hs_annds  = rn_ann_decls,+                             hs_defds  = rn_default_decls,+                             hs_ruleds = rn_rule_decls,+                             hs_docs   = rn_docs } ;++        tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;+        other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;+        other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,+                              src_fvs5, src_fvs6, src_fvs7] ;+                -- It is tiresome to gather the binders from type and class decls++        src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ;+                -- Instance decls may have occurrences of things bound in bind_dus+                -- so we must put other_fvs last++        final_tcg_env = let tcg_env' = (last_tcg_env `addTcgDUs` src_dus)+                        in -- we return the deprecs in the env, not in the HsGroup above+                        tcg_env' { tcg_warns = tcg_warns tcg_env' `plusWarns` rn_warns };+       } ;+   traceRn "finish rnSrc" (ppr rn_group) ;+   traceRn "finish Dus" (ppr src_dus ) ;+   return (final_tcg_env, rn_group)+                    }}}}+rnSrcDecls (XHsGroup _) = panic "rnSrcDecls"++addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv+-- This function could be defined lower down in the module hierarchy,+-- but there doesn't seem anywhere very logical to put it.+addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus }++rnList :: (a -> RnM (b, FreeVars)) -> [Located a] -> RnM ([Located b], FreeVars)+rnList f xs = mapFvRn (wrapLocFstM f) xs++{-+*********************************************************+*                                                       *+        HsDoc stuff+*                                                       *+*********************************************************+-}++rnDocDecl :: DocDecl -> RnM DocDecl+rnDocDecl (DocCommentNext doc) = do+  rn_doc <- rnHsDoc doc+  return (DocCommentNext rn_doc)+rnDocDecl (DocCommentPrev doc) = do+  rn_doc <- rnHsDoc doc+  return (DocCommentPrev rn_doc)+rnDocDecl (DocCommentNamed str doc) = do+  rn_doc <- rnHsDoc doc+  return (DocCommentNamed str rn_doc)+rnDocDecl (DocGroup lev doc) = do+  rn_doc <- rnHsDoc doc+  return (DocGroup lev rn_doc)++{-+*********************************************************+*                                                       *+        Source-code deprecations declarations+*                                                       *+*********************************************************++Check that the deprecated names are defined, are defined locally, and+that there are no duplicate deprecations.++It's only imported deprecations, dealt with in RnIfaces, that we+gather them together.+-}++-- checks that the deprecations are defined locally, and that there are no duplicates+rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings+rnSrcWarnDecls _ []+  = return NoWarnings++rnSrcWarnDecls bndr_set decls'+  = do { -- check for duplicates+       ; mapM_ (\ dups -> let ((dL->L loc rdr) :| (lrdr':_)) = dups+                          in addErrAt loc (dupWarnDecl lrdr' rdr))+               warn_rdr_dups+       ; pairs_s <- mapM (addLocM rn_deprec) decls+       ; return (WarnSome ((concat pairs_s))) }+ where+   decls = concatMap (wd_warnings . unLoc) decls'++   sig_ctxt = TopSigCtxt bndr_set++   rn_deprec (Warning _ rdr_names txt)+       -- ensures that the names are defined locally+     = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)+                                rdr_names+          ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }+   rn_deprec (XWarnDecl _) = panic "rnSrcWarnDecls"++   what = text "deprecation"++   warn_rdr_dups = findDupRdrNames+                   $ concatMap (\(dL->L _ (Warning _ ns _)) -> ns) decls++findDupRdrNames :: [Located RdrName] -> [NonEmpty (Located RdrName)]+findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y))++-- look for duplicates among the OccNames;+-- we check that the names are defined above+-- invt: the lists returned by findDupsEq always have at least two elements++dupWarnDecl :: Located RdrName -> RdrName -> SDoc+-- Located RdrName -> DeprecDecl RdrName -> SDoc+dupWarnDecl d rdr_name+  = vcat [text "Multiple warning declarations for" <+> quotes (ppr rdr_name),+          text "also at " <+> ppr (getLoc d)]++{-+*********************************************************+*                                                      *+\subsection{Annotation declarations}+*                                                      *+*********************************************************+-}++rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars)+rnAnnDecl ann@(HsAnnotation _ s provenance expr)+  = addErrCtxt (annCtxt ann) $+    do { (provenance', provenance_fvs) <- rnAnnProvenance provenance+       ; (expr', expr_fvs) <- setStage (Splice Untyped) $+                              rnLExpr expr+       ; return (HsAnnotation noExt s provenance' expr',+                 provenance_fvs `plusFV` expr_fvs) }+rnAnnDecl (XAnnDecl _) = panic "rnAnnDecl"++rnAnnProvenance :: AnnProvenance RdrName+                -> RnM (AnnProvenance Name, FreeVars)+rnAnnProvenance provenance = do+    provenance' <- traverse lookupTopBndrRn provenance+    return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))++{-+*********************************************************+*                                                      *+\subsection{Default declarations}+*                                                      *+*********************************************************+-}++rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars)+rnDefaultDecl (DefaultDecl _ tys)+  = do { (tys', fvs) <- rnLHsTypes doc_str tys+       ; return (DefaultDecl noExt tys', fvs) }+  where+    doc_str = DefaultDeclCtx+rnDefaultDecl (XDefaultDecl _) = panic "rnDefaultDecl"++{-+*********************************************************+*                                                      *+\subsection{Foreign declarations}+*                                                      *+*********************************************************+-}++rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars)+rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec })+  = do { topEnv :: HscEnv <- getTopEnv+       ; name' <- lookupLocatedTopBndrRn name+       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty++        -- Mark any PackageTarget style imports as coming from the current package+       ; let unitId = thisPackage $ hsc_dflags topEnv+             spec'      = patchForeignImport unitId spec++       ; return (ForeignImport { fd_i_ext = noExt+                               , fd_name = name', fd_sig_ty = ty'+                               , fd_fi = spec' }, fvs) }++rnHsForeignDecl (ForeignExport { fd_name = name, fd_sig_ty = ty, fd_fe = spec })+  = do { name' <- lookupLocatedOccRn name+       ; (ty', fvs) <- rnHsSigType (ForeignDeclCtx name) ty+       ; return (ForeignExport { fd_e_ext = noExt+                               , fd_name = name', fd_sig_ty = ty'+                               , fd_fe = spec }+                , fvs `addOneFV` unLoc name') }+        -- NB: a foreign export is an *occurrence site* for name, so+        --     we add it to the free-variable list.  It might, for example,+        --     be imported from another module++rnHsForeignDecl (XForeignDecl _) = panic "rnHsForeignDecl"++-- | For Windows DLLs we need to know what packages imported symbols are from+--      to generate correct calls. Imported symbols are tagged with the current+--      package, so if they get inlined across a package boundary we'll still+--      know where they're from.+--+patchForeignImport :: UnitId -> ForeignImport -> ForeignImport+patchForeignImport unitId (CImport cconv safety fs spec src)+        = CImport cconv safety fs (patchCImportSpec unitId spec) src++patchCImportSpec :: UnitId -> CImportSpec -> CImportSpec+patchCImportSpec unitId spec+ = case spec of+        CFunction callTarget    -> CFunction $ patchCCallTarget unitId callTarget+        _                       -> spec++patchCCallTarget :: UnitId -> CCallTarget -> CCallTarget+patchCCallTarget unitId callTarget =+  case callTarget of+  StaticTarget src label Nothing isFun+                              -> StaticTarget src label (Just unitId) isFun+  _                           -> callTarget++{-+*********************************************************+*                                                      *+\subsection{Instance declarations}+*                                                      *+*********************************************************+-}++rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars)+rnSrcInstDecl (TyFamInstD { tfid_inst = tfi })+  = do { (tfi', fvs) <- rnTyFamInstDecl NonAssocTyFamEqn tfi+       ; return (TyFamInstD { tfid_ext = noExt, tfid_inst = tfi' }, fvs) }++rnSrcInstDecl (DataFamInstD { dfid_inst = dfi })+  = do { (dfi', fvs) <- rnDataFamInstDecl NonAssocTyFamEqn dfi+       ; return (DataFamInstD { dfid_ext = noExt, dfid_inst = dfi' }, fvs) }++rnSrcInstDecl (ClsInstD { cid_inst = cid })+  = do { traceRn "rnSrcIstDecl {" (ppr cid)+       ; (cid', fvs) <- rnClsInstDecl cid+       ; traceRn "rnSrcIstDecl end }" empty+       ; return (ClsInstD { cid_d_ext = noExt, cid_inst = cid' }, fvs) }++rnSrcInstDecl (XInstDecl _) = panic "rnSrcInstDecl"++-- | Warn about non-canonical typeclass instance declarations+--+-- A "non-canonical" instance definition can occur for instances of a+-- class which redundantly defines an operation its superclass+-- provides as well (c.f. `return`/`pure`). In such cases, a canonical+-- instance is one where the subclass inherits its method+-- implementation from its superclass instance (usually the subclass+-- has a default method implementation to that effect). Consequently,+-- a non-canonical instance occurs when this is not the case.+--+-- See also descriptions of 'checkCanonicalMonadInstances' and+-- 'checkCanonicalMonoidInstances'+checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM ()+checkCanonicalInstances cls poly_ty mbinds = do+    whenWOptM Opt_WarnNonCanonicalMonadInstances+        checkCanonicalMonadInstances++    whenWOptM Opt_WarnNonCanonicalMonoidInstances+        checkCanonicalMonoidInstances++  where+    -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance+    -- declarations. Specifically, the following conditions are verified:+    --+    -- In 'Monad' instances declarations:+    --+    --  * If 'return' is overridden it must be canonical (i.e. @return = pure@)+    --  * If '(>>)' is overridden it must be canonical (i.e. @(>>) = (*>)@)+    --+    -- In 'Applicative' instance declarations:+    --+    --  * Warn if 'pure' is defined backwards (i.e. @pure = return@).+    --  * Warn if '(*>)' is defined backwards (i.e. @(*>) = (>>)@).+    --+    checkCanonicalMonadInstances+      | cls == applicativeClassName  = do+          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do+              case mbind of+                  FunBind { fun_id = (dL->L _ name)+                          , fun_matches = mg }+                      | name == pureAName, isAliasMG mg == Just returnMName+                      -> addWarnNonCanonicalMethod1+                            Opt_WarnNonCanonicalMonadInstances "pure" "return"++                      | name == thenAName, isAliasMG mg == Just thenMName+                      -> addWarnNonCanonicalMethod1+                            Opt_WarnNonCanonicalMonadInstances "(*>)" "(>>)"++                  _ -> return ()++      | cls == monadClassName  = do+          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do+              case mbind of+                  FunBind { fun_id = (dL->L _ name)+                          , fun_matches = mg }+                      | name == returnMName, isAliasMG mg /= Just pureAName+                      -> addWarnNonCanonicalMethod2+                            Opt_WarnNonCanonicalMonadInstances "return" "pure"++                      | name == thenMName, isAliasMG mg /= Just thenAName+                      -> addWarnNonCanonicalMethod2+                            Opt_WarnNonCanonicalMonadInstances "(>>)" "(*>)"++                  _ -> return ()++      | otherwise = return ()++    -- | Check whether Monoid(mappend) is defined in terms of+    -- Semigroup((<>)) (and not the other way round). Specifically,+    -- the following conditions are verified:+    --+    -- In 'Monoid' instances declarations:+    --+    --  * If 'mappend' is overridden it must be canonical+    --    (i.e. @mappend = (<>)@)+    --+    -- In 'Semigroup' instance declarations:+    --+    --  * Warn if '(<>)' is defined backwards (i.e. @(<>) = mappend@).+    --+    checkCanonicalMonoidInstances+      | cls == semigroupClassName  = do+          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do+              case mbind of+                  FunBind { fun_id      = (dL->L _ name)+                          , fun_matches = mg }+                      | name == sappendName, isAliasMG mg == Just mappendName+                      -> addWarnNonCanonicalMethod1+                            Opt_WarnNonCanonicalMonoidInstances "(<>)" "mappend"++                  _ -> return ()++      | cls == monoidClassName  = do+          forM_ (bagToList mbinds) $ \(dL->L loc mbind) -> setSrcSpan loc $ do+              case mbind of+                  FunBind { fun_id = (dL->L _ name)+                          , fun_matches = mg }+                      | name == mappendName, isAliasMG mg /= Just sappendName+                      -> addWarnNonCanonicalMethod2NoDefault+                            Opt_WarnNonCanonicalMonoidInstances "mappend" "(<>)"++                  _ -> return ()++      | otherwise = return ()++    -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"+    -- binding, and return @Just rhsName@ if this is the case+    isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name+    isAliasMG MG {mg_alts = (dL->L _+                             [dL->L _ (Match { m_pats = []+                                             , m_grhss = grhss })])}+        | GRHSs _ [dL->L _ (GRHS _ [] body)] lbinds <- grhss+        , EmptyLocalBinds _ <- unLoc lbinds+        , HsVar _ lrhsName  <- unLoc body  = Just (unLoc lrhsName)+    isAliasMG _ = Nothing++    -- got "lhs = rhs" but expected something different+    addWarnNonCanonicalMethod1 flag lhs rhs = do+        addWarn (Reason flag) $ vcat+                       [ text "Noncanonical" <+>+                         quotes (text (lhs ++ " = " ++ rhs)) <+>+                         text "definition detected"+                       , instDeclCtxt1 poly_ty+                       , text "Move definition from" <+>+                         quotes (text rhs) <+>+                         text "to" <+> quotes (text lhs)+                       ]++    -- expected "lhs = rhs" but got something else+    addWarnNonCanonicalMethod2 flag lhs rhs = do+        addWarn (Reason flag) $ vcat+                       [ text "Noncanonical" <+>+                         quotes (text lhs) <+>+                         text "definition detected"+                       , instDeclCtxt1 poly_ty+                       , text "Either remove definition for" <+>+                         quotes (text lhs) <+> text "or define as" <+>+                         quotes (text (lhs ++ " = " ++ rhs))+                       ]++    -- like above, but method has no default impl+    addWarnNonCanonicalMethod2NoDefault flag lhs rhs = do+        addWarn (Reason flag) $ vcat+                       [ text "Noncanonical" <+>+                         quotes (text lhs) <+>+                         text "definition detected"+                       , instDeclCtxt1 poly_ty+                       , text "Define as" <+>+                         quotes (text (lhs ++ " = " ++ rhs))+                       ]++    -- stolen from TcInstDcls+    instDeclCtxt1 :: LHsSigType GhcRn -> SDoc+    instDeclCtxt1 hs_inst_ty+      = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))++    inst_decl_ctxt :: SDoc -> SDoc+    inst_decl_ctxt doc = hang (text "in the instance declaration for")+                         2 (quotes doc <> text ".")+++rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars)+rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds+                           , cid_sigs = uprags, cid_tyfam_insts = ats+                           , cid_overlap_mode = oflag+                           , cid_datafam_insts = adts })+  = do { (inst_ty', inst_fvs)+           <- rnHsSigType (GenericCtx $ text "an instance declaration") inst_ty+       ; let (ktv_names, _, head_ty') = splitLHsInstDeclTy inst_ty'+       ; cls <-+           case hsTyGetAppHead_maybe head_ty' of+             Just (dL->L _ cls) -> pure cls+             Nothing -> do+               -- The instance is malformed. We'd still like+               -- to make *some* progress (rather than failing outright), so+               -- we report an error and continue for as long as we can.+               -- Importantly, this error should be thrown before we reach the+               -- typechecker, lest we encounter different errors that are+               -- hopelessly confusing (such as the one in #16114).+               addErrAt (getLoc (hsSigType inst_ty)) $+                 hang (text "Illegal class instance:" <+> quotes (ppr inst_ty))+                    2 (vcat [ text "Class instances must be of the form"+                            , nest 2 $ text "context => C ty_1 ... ty_n"+                            , text "where" <+> quotes (char 'C')+                              <+> text "is a class"+                            ])+               pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))++          -- Rename the bindings+          -- The typechecker (not the renamer) checks that all+          -- the bindings are for the right class+          -- (Slightly strangely) when scoped type variables are on, the+          -- forall-d tyvars scope over the method bindings too+       ; (mbinds', uprags', meth_fvs) <- rnMethodBinds False cls ktv_names mbinds uprags++       ; checkCanonicalInstances cls inst_ty' mbinds'++       -- Rename the associated types, and type signatures+       -- Both need to have the instance type variables in scope+       ; traceRn "rnSrcInstDecl" (ppr inst_ty' $$ ppr ktv_names)+       ; ((ats', adts'), more_fvs)+             <- extendTyVarEnvFVRn ktv_names $+                do { (ats',  at_fvs)  <- rnATInstDecls rnTyFamInstDecl cls ktv_names ats+                   ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts+                   ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) }++       ; let all_fvs = meth_fvs `plusFV` more_fvs+                                `plusFV` inst_fvs+       ; return (ClsInstDecl { cid_ext = noExt+                             , cid_poly_ty = inst_ty', cid_binds = mbinds'+                             , cid_sigs = uprags', cid_tyfam_insts = ats'+                             , cid_overlap_mode = oflag+                             , cid_datafam_insts = adts' },+                 all_fvs) }+             -- We return the renamed associated data type declarations so+             -- that they can be entered into the list of type declarations+             -- for the binding group, but we also keep a copy in the instance.+             -- The latter is needed for well-formedness checks in the type+             -- checker (eg, to ensure that all ATs of the instance actually+             -- receive a declaration).+             -- NB: Even the copies in the instance declaration carry copies of+             --     the instance context after renaming.  This is a bit+             --     strange, but should not matter (and it would be more work+             --     to remove the context).+rnClsInstDecl (XClsInstDecl _) = panic "rnClsInstDecl"++rnFamInstEqn :: HsDocContext+             -> AssocTyFamInfo+             -> [Located RdrName]    -- Kind variables from the equation's RHS+             -> FamInstEqn GhcPs rhs+             -> (HsDocContext -> rhs -> RnM (rhs', FreeVars))+             -> RnM (FamInstEqn GhcRn rhs', FreeVars)+rnFamInstEqn doc atfi rhs_kvars+    (HsIB { hsib_body = FamEqn { feqn_tycon  = tycon+                               , feqn_bndrs  = mb_bndrs+                               , feqn_pats   = pats+                               , feqn_fixity = fixity+                               , feqn_rhs    = payload }}) rn_payload+  = do { let mb_cls = case atfi of+                        NonAssocTyFamEqn     -> Nothing+                        AssocTyFamDeflt cls  -> Just cls+                        AssocTyFamInst cls _ -> Just cls+       ; tycon'   <- lookupFamInstName mb_cls tycon+       ; let pat_kity_vars_with_dups = extractHsTyArgRdrKiTyVarsDup pats+             -- Use the "...Dups" form because it's needed+             -- below to report unsed binder on the LHS++         -- Implicitly bound variables, empty if we have an explicit 'forall' according+         -- to the "forall-or-nothing" rule.+       ; let imp_vars | isNothing mb_bndrs = nubL pat_kity_vars_with_dups+                      | otherwise = []+       ; imp_var_names <- mapM (newTyVarNameRn mb_cls) imp_vars++       ; let bndrs = fromMaybe [] mb_bndrs+             bnd_vars = map hsLTyVarLocName bndrs+             payload_kvars = filterOut (`elemRdr` (bnd_vars ++ imp_vars)) rhs_kvars+             -- Make sure to filter out the kind variables that were explicitly+             -- bound in the type patterns.+       ; payload_kvar_names <- mapM (newTyVarNameRn mb_cls) payload_kvars++         -- all names not bound in an explict forall+       ; let all_imp_var_names = imp_var_names ++ payload_kvar_names++             -- All the free vars of the family patterns+             -- with a sensible binding location+       ; ((bndrs', pats', payload'), fvs)+              <- bindLocalNamesFV all_imp_var_names $+                 bindLHsTyVarBndrs doc (Just $ inHsDocContext doc)+                                   Nothing bndrs $ \bndrs' ->+                 -- Note: If we pass mb_cls instead of Nothing here,+                 --  bindLHsTyVarBndrs will use class variables for any names+                 --  the user meant to bring in scope here. This is an explicit+                 --  forall, so we want fresh names, not class variables.+                 --  Thus: always pass Nothing+                 do { (pats', pat_fvs) <- rnLHsTypeArgs (FamPatCtx tycon) pats+                    ; (payload', rhs_fvs) <- rn_payload doc payload++                       -- Report unused binders on the LHS+                       -- See Note [Unused type variables in family instances]+                    ; let groups :: [NonEmpty (Located RdrName)]+                          groups = equivClasses cmpLocated $+                                   pat_kity_vars_with_dups+                    ; nms_dups <- mapM (lookupOccRn . unLoc) $+                                     [ tv | (tv :| (_:_)) <- groups ]+                          -- Add to the used variables+                          --  a) any variables that appear *more than once* on the LHS+                          --     e.g.   F a Int a = Bool+                          --  b) for associated instances, the variables+                          --     of the instance decl.  See+                          --     Note [Unused type variables in family instances]+                    ; let nms_used = extendNameSetList rhs_fvs $+                                        inst_tvs ++ nms_dups+                          inst_tvs = case atfi of+                                       NonAssocTyFamEqn          -> []+                                       AssocTyFamDeflt _         -> []+                                       AssocTyFamInst _ inst_tvs -> inst_tvs+                          all_nms = all_imp_var_names ++ hsLTyVarNames bndrs'+                    ; warnUnusedTypePatterns all_nms nms_used++                    ; return ((bndrs', pats', payload'), rhs_fvs `plusFV` pat_fvs) }++       ; let all_fvs  = fvs `addOneFV` unLoc tycon'+            -- type instance => use, hence addOneFV++       ; return (HsIB { hsib_ext = all_imp_var_names -- Note [Wildcards in family instances]+                      , hsib_body+                          = FamEqn { feqn_ext    = noExt+                                   , feqn_tycon  = tycon'+                                   , feqn_bndrs  = bndrs' <$ mb_bndrs+                                   , feqn_pats   = pats'+                                   , feqn_fixity = fixity+                                   , feqn_rhs    = payload' } },+                 all_fvs) }+rnFamInstEqn _ _ _ (HsIB _ (XFamEqn _)) _ = panic "rnFamInstEqn"+rnFamInstEqn _ _ _ (XHsImplicitBndrs _) _ = panic "rnFamInstEqn"++rnTyFamInstDecl :: AssocTyFamInfo+                -> TyFamInstDecl GhcPs+                -> RnM (TyFamInstDecl GhcRn, FreeVars)+rnTyFamInstDecl atfi (TyFamInstDecl { tfid_eqn = eqn })+  = do { (eqn', fvs) <- rnTyFamInstEqn atfi NotClosedTyFam eqn+       ; return (TyFamInstDecl { tfid_eqn = eqn' }, fvs) }++-- | Tracks whether we are renaming:+--+-- 1. A type family equation that is not associated+--    with a parent type class ('NonAssocTyFamEqn')+--+-- 2. An associated type family default delcaration ('AssocTyFamDeflt')+--+-- 3. An associated type family instance declaration ('AssocTyFamInst')+data AssocTyFamInfo+  = NonAssocTyFamEqn+  | AssocTyFamDeflt Name   -- Name of the parent class+  | AssocTyFamInst  Name   -- Name of the parent class+                    [Name] -- Names of the tyvars of the parent instance decl++-- | Tracks whether we are renaming an equation in a closed type family+-- equation ('ClosedTyFam') or not ('NotClosedTyFam').+data ClosedTyFamInfo+  = NotClosedTyFam+  | ClosedTyFam (Located RdrName) Name+                -- The names (RdrName and Name) of the closed type family++rnTyFamInstEqn :: AssocTyFamInfo+               -> ClosedTyFamInfo+               -> TyFamInstEqn GhcPs+               -> RnM (TyFamInstEqn GhcRn, FreeVars)+rnTyFamInstEqn atfi ctf_info+    eqn@(HsIB { hsib_body = FamEqn { feqn_tycon = tycon+                                   , feqn_rhs   = rhs }})+  = do { let rhs_kvs = extractHsTyRdrTyVarsKindVars rhs+       ; (eqn'@(HsIB { hsib_body =+                       FamEqn { feqn_tycon = dL -> L _ tycon' }}), fvs)+           <- rnFamInstEqn (TySynCtx tycon) atfi rhs_kvs eqn rnTySyn+       ; case ctf_info of+           NotClosedTyFam -> pure ()+           ClosedTyFam fam_rdr_name fam_name ->+             checkTc (fam_name == tycon') $+             withHsDocContext (TyFamilyCtx fam_rdr_name) $+             wrongTyFamName fam_name tycon'+       ; pure (eqn', fvs) }+rnTyFamInstEqn _ _ (HsIB _ (XFamEqn _)) = panic "rnTyFamInstEqn"+rnTyFamInstEqn _ _ (XHsImplicitBndrs _) = panic "rnTyFamInstEqn"++rnTyFamDefltDecl :: Name+                 -> TyFamDefltDecl GhcPs+                 -> RnM (TyFamDefltDecl GhcRn, FreeVars)+rnTyFamDefltDecl cls = rnTyFamInstDecl (AssocTyFamDeflt cls)++rnDataFamInstDecl :: AssocTyFamInfo+                  -> DataFamInstDecl GhcPs+                  -> RnM (DataFamInstDecl GhcRn, FreeVars)+rnDataFamInstDecl atfi (DataFamInstDecl { dfid_eqn = eqn@(HsIB { hsib_body =+                         FamEqn { feqn_tycon = tycon+                                , feqn_rhs   = rhs }})})+  = do { let rhs_kvs = extractDataDefnKindVars rhs+       ; (eqn', fvs) <-+           rnFamInstEqn (TyDataCtx tycon) atfi rhs_kvs eqn rnDataDefn+       ; return (DataFamInstDecl { dfid_eqn = eqn' }, fvs) }+rnDataFamInstDecl _ (DataFamInstDecl (HsIB _ (XFamEqn _)))+  = panic "rnDataFamInstDecl"+rnDataFamInstDecl _ (DataFamInstDecl (XHsImplicitBndrs _))+  = panic "rnDataFamInstDecl"++-- Renaming of the associated types in instances.++-- Rename associated type family decl in class+rnATDecls :: Name      -- Class+          -> [LFamilyDecl GhcPs]+          -> RnM ([LFamilyDecl GhcRn], FreeVars)+rnATDecls cls at_decls+  = rnList (rnFamDecl (Just cls)) at_decls++rnATInstDecls :: (AssocTyFamInfo ->           -- The function that renames+                  decl GhcPs ->               -- an instance. rnTyFamInstDecl+                  RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl+              -> Name      -- Class+              -> [Name]+              -> [Located (decl GhcPs)]+              -> RnM ([Located (decl GhcRn)], FreeVars)+-- Used for data and type family defaults in a class decl+-- and the family instance declarations in an instance+--+-- NB: We allow duplicate associated-type decls;+--     See Note [Associated type instances] in TcInstDcls+rnATInstDecls rnFun cls tv_ns at_insts+  = rnList (rnFun (AssocTyFamInst cls tv_ns)) at_insts+    -- See Note [Renaming associated types]++{- Note [Wildcards in family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Wild cards can be used in type/data family instance declarations to indicate+that the name of a type variable doesn't matter. Each wild card will be+replaced with a new unique type variable. For instance:++    type family F a b :: *+    type instance F Int _ = Int++is the same as++    type family F a b :: *+    type instance F Int b = Int++This is implemented as follows: Unnamed wildcards remain unchanged after+the renamer, and then given fresh meta-variables during typechecking, and+it is handled pretty much the same way as the ones in partial type signatures.+We however don't want to emit hole constraints on wildcards in family+instances, so we turn on PartialTypeSignatures and turn off warning flag to+let typechecker know this.+See related Note [Wildcards in visible kind application] in TcHsType.hs++Note [Unused type variables in family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the flag -fwarn-unused-type-patterns is on, the compiler reports+warnings about unused type variables in type-family instances. A+tpye variable is considered used (i.e. cannot be turned into a wildcard)+when++ * it occurs on the RHS of the family instance+   e.g.   type instance F a b = a    -- a is used on the RHS++ * it occurs multiple times in the patterns on the LHS+   e.g.   type instance F a a = Int  -- a appears more than once on LHS++ * it is one of the instance-decl variables, for associated types+   e.g.   instance C (a,b) where+            type T (a,b) = a+   Here the type pattern in the type instance must be the same as that+   for the class instance, so+            type T (a,_) = a+   would be rejected.  So we should not complain about an unused variable b++As usual, the warnings are not reported for type variables with names+beginning with an underscore.++Extra-constraints wild cards are not supported in type/data family+instance declarations.++Relevant tickets: #3699, #10586, #10982 and #11451.++Note [Renaming associated types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Check that the RHS of the decl mentions only type variables that are explicitly+bound on the LHS.  For example, this is not ok+   class C a b where+      type F a x :: *+   instance C (p,q) r where+      type F (p,q) x = (x, r)   -- BAD: mentions 'r'+c.f. #5515++Kind variables, on the other hand, are allowed to be implicitly or explicitly+bound. As examples, this (#9574) is acceptable:+   class Funct f where+      type Codomain f :: *+   instance Funct ('KProxy :: KProxy o) where+      -- o is implicitly bound by the kind signature+      -- of the LHS type pattern ('KProxy)+      type Codomain 'KProxy = NatTr (Proxy :: o -> *)+And this (#14131) is also acceptable:+    data family Nat :: k -> k -> *+    -- k is implicitly bound by an invisible kind pattern+    newtype instance Nat :: (k -> *) -> (k -> *) -> * where+      Nat :: (forall xx. f xx -> g xx) -> Nat f g+We could choose to disallow this, but then associated type families would not+be able to be as expressive as top-level type synonyms. For example, this type+synonym definition is allowed:+    type T = (Nothing :: Maybe a)+So for parity with type synonyms, we also allow:+    type family   T :: Maybe a+    type instance T = (Nothing :: Maybe a)++All this applies only for *instance* declarations.  In *class*+declarations there is no RHS to worry about, and the class variables+can all be in scope (#5862):+    class Category (x :: k -> k -> *) where+      type Ob x :: k -> Constraint+      id :: Ob x a => x a a+      (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c+Here 'k' is in scope in the kind signature, just like 'x'.++Although type family equations can bind type variables with explicit foralls,+it need not be the case that all variables that appear on the RHS must be bound+by a forall. For instance, the following is acceptable:++   class C a where+     type T a b+   instance C (Maybe a) where+     type forall b. T (Maybe a) b = Either a b++Even though `a` is not bound by the forall, this is still accepted because `a`+was previously bound by the `instance C (Maybe a)` part. (see #16116).++In each case, the function which detects improperly bound variables on the RHS+is TcValidity.checkValidFamPats.+-}+++{-+*********************************************************+*                                                      *+\subsection{Stand-alone deriving declarations}+*                                                      *+*********************************************************+-}++rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars)+rnSrcDerivDecl (DerivDecl _ ty mds overlap)+  = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving+       ; unless standalone_deriv_ok (addErr standaloneDerivErr)+       ; (mds', ty', fvs)+           <- rnLDerivStrategy DerivDeclCtx mds $ \strat_tvs ppr_via_ty ->+              rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "instance" $+              rnHsSigWcType BindUnlessForall DerivDeclCtx ty+       ; warnNoDerivStrat mds' loc+       ; return (DerivDecl noExt ty' mds' overlap, fvs) }+  where+    loc = getLoc $ hsib_body $ hswc_body ty+rnSrcDerivDecl (XDerivDecl _) = panic "rnSrcDerivDecl"++standaloneDerivErr :: SDoc+standaloneDerivErr+  = hang (text "Illegal standalone deriving declaration")+       2 (text "Use StandaloneDeriving to enable this extension")++{-+*********************************************************+*                                                      *+\subsection{Rules}+*                                                      *+*********************************************************+-}++rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars)+rnHsRuleDecls (HsRules { rds_src = src+                       , rds_rules = rules })+  = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules+       ; return (HsRules { rds_ext = noExt+                         , rds_src = src+                         , rds_rules = rn_rules }, fvs) }+rnHsRuleDecls (XRuleDecls _) = panic "rnHsRuleDecls"++rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars)+rnHsRuleDecl (HsRule { rd_name = rule_name+                     , rd_act  = act+                     , rd_tyvs = tyvs+                     , rd_tmvs = tmvs+                     , rd_lhs  = lhs+                     , rd_rhs  = rhs })+  = do { let rdr_names_w_loc = map (get_var . unLoc) tmvs+       ; checkDupRdrNames rdr_names_w_loc+       ; checkShadowedRdrNames rdr_names_w_loc+       ; names <- newLocalBndrsRn rdr_names_w_loc+       ; let doc = RuleCtx (snd $ unLoc rule_name)+       ; bindRuleTyVars doc in_rule tyvs $ \ tyvs' ->+         bindRuleTmVars doc tyvs' tmvs names $ \ tmvs' ->+    do { (lhs', fv_lhs') <- rnLExpr lhs+       ; (rhs', fv_rhs') <- rnLExpr rhs+       ; checkValidRule (snd $ unLoc rule_name) names lhs' fv_lhs'+       ; return (HsRule { rd_ext  = HsRuleRn fv_lhs' fv_rhs'+                        , rd_name = rule_name+                        , rd_act  = act+                        , rd_tyvs = tyvs'+                        , rd_tmvs = tmvs'+                        , rd_lhs  = lhs'+                        , rd_rhs  = rhs' }, fv_lhs' `plusFV` fv_rhs') } }+  where+    get_var (RuleBndrSig _ v _) = v+    get_var (RuleBndr _ v)      = v+    get_var (XRuleBndr _)       = panic "rnHsRuleDecl"+    in_rule = text "in the rule" <+> pprFullRuleName rule_name+rnHsRuleDecl (XRuleDecl _) = panic "rnHsRuleDecl"++bindRuleTmVars :: HsDocContext -> Maybe ty_bndrs+               -> [LRuleBndr GhcPs] -> [Name]+               -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars))+               -> RnM (a, FreeVars)+bindRuleTmVars doc tyvs vars names thing_inside+  = go vars names $ \ vars' ->+    bindLocalNamesFV names (thing_inside vars')+  where+    go ((dL->L l (RuleBndr _ (dL->L loc _))) : vars) (n : ns) thing_inside+      = go vars ns $ \ vars' ->+        thing_inside (cL l (RuleBndr noExt (cL loc n)) : vars')++    go ((dL->L l (RuleBndrSig _ (dL->L loc _) bsig)) : vars)+       (n : ns) thing_inside+      = rnHsSigWcTypeScoped bind_free_tvs doc bsig $ \ bsig' ->+        go vars ns $ \ vars' ->+        thing_inside (cL l (RuleBndrSig noExt (cL loc n) bsig') : vars')++    go [] [] thing_inside = thing_inside []+    go vars names _ = pprPanic "bindRuleVars" (ppr vars $$ ppr names)++    bind_free_tvs = case tyvs of Nothing -> AlwaysBind+                                 Just _  -> NeverBind++bindRuleTyVars :: HsDocContext -> SDoc -> Maybe [LHsTyVarBndr GhcPs]+               -> (Maybe [LHsTyVarBndr GhcRn]  -> RnM (b, FreeVars))+               -> RnM (b, FreeVars)+bindRuleTyVars doc in_doc (Just bndrs) thing_inside+  = bindLHsTyVarBndrs doc (Just in_doc) Nothing bndrs (thing_inside . Just)+bindRuleTyVars _ _ _ thing_inside = thing_inside Nothing++{-+Note [Rule LHS validity checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Check the shape of a transformation rule LHS.  Currently we only allow+LHSs of the form @(f e1 .. en)@, where @f@ is not one of the+@forall@'d variables.++We used restrict the form of the 'ei' to prevent you writing rules+with LHSs with a complicated desugaring (and hence unlikely to match);+(e.g. a case expression is not allowed: too elaborate.)++But there are legitimate non-trivial args ei, like sections and+lambdas.  So it seems simmpler not to check at all, and that is why+check_e is commented out.+-}++checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()+checkValidRule rule_name ids lhs' fv_lhs'+  = do  {       -- Check for the form of the LHS+          case (validRuleLhs ids lhs') of+                Nothing  -> return ()+                Just bad -> failWithTc (badRuleLhsErr rule_name lhs' bad)++                -- Check that LHS vars are all bound+        ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')]+        ; mapM_ (addErr . badRuleVar rule_name) bad_vars }++validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn)+-- Nothing => OK+-- Just e  => Not ok, and e is the offending sub-expression+validRuleLhs foralls lhs+  = checkl lhs+  where+    checkl = check . unLoc++    check (OpApp _ e1 op e2)              = checkl op `mplus` checkl_e e1+                                                      `mplus` checkl_e e2+    check (HsApp _ e1 e2)                 = checkl e1 `mplus` checkl_e e2+    check (HsAppType _ e _)               = checkl e+    check (HsVar _ lv)+      | (unLoc lv) `notElem` foralls      = Nothing+    check other                           = Just other  -- Failure++        -- Check an argument+    checkl_e _ = Nothing+    -- Was (check_e e); see Note [Rule LHS validity checking]++{-      Commented out; see Note [Rule LHS validity checking] above+    check_e (HsVar v)     = Nothing+    check_e (HsPar e)     = checkl_e e+    check_e (HsLit e)     = Nothing+    check_e (HsOverLit e) = Nothing++    check_e (OpApp e1 op _ e2)   = checkl_e e1 `mplus` checkl_e op `mplus` checkl_e e2+    check_e (HsApp e1 e2)        = checkl_e e1 `mplus` checkl_e e2+    check_e (NegApp e _)         = checkl_e e+    check_e (ExplicitList _ es)  = checkl_es es+    check_e other                = Just other   -- Fails++    checkl_es es = foldr (mplus . checkl_e) Nothing es+-}++badRuleVar :: FastString -> Name -> SDoc+badRuleVar name var+  = sep [text "Rule" <+> doubleQuotes (ftext name) <> colon,+         text "Forall'd variable" <+> quotes (ppr var) <+>+                text "does not appear on left hand side"]++badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc+badRuleLhsErr name lhs bad_e+  = sep [text "Rule" <+> pprRuleName name <> colon,+         nest 2 (vcat [err,+                       text "in left-hand side:" <+> ppr lhs])]+    $$+    text "LHS must be of form (f e1 .. en) where f is not forall'd"+  where+    err = case bad_e of+            HsUnboundVar _ uv -> notInScopeErr (mkRdrUnqual (unboundVarOcc uv))+            _                 -> text "Illegal expression:" <+> ppr bad_e++{- **************************************************************+         *                                                      *+      Renaming type, class, instance and role declarations+*                                                               *+*****************************************************************++@rnTyDecl@ uses the `global name function' to create a new type+declaration in which local names have been replaced by their original+names, reporting any unknown names.++Renaming type variables is a pain. Because they now contain uniques,+it is necessary to pass in an association list which maps a parsed+tyvar to its @Name@ representation.+In some cases (type signatures of values),+it is even necessary to go over the type first+in order to get the set of tyvars used by it, make an assoc list,+and then go over it again to rename the tyvars!+However, we can also do some scoping checks at the same time.++Note [Dependency analysis of type, class, and instance decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A TyClGroup represents a strongly connected components of+type/class/instance decls, together with the role annotations for the+type/class declarations.  The renamer uses strongly connected+comoponent analysis to build these groups.  We do this for a number of+reasons:++* Improve kind error messages. Consider++     data T f a = MkT f a+     data S f a = MkS f (T f a)++  This has a kind error, but the error message is better if you+  check T first, (fixing its kind) and *then* S.  If you do kind+  inference together, you might get an error reported in S, which+  is jolly confusing.  See #4875+++* Increase kind polymorphism.  See TcTyClsDecls+  Note [Grouping of type and class declarations]++Why do the instance declarations participate?  At least two reasons++* Consider (#11348)++     type family F a+     type instance F Int = Bool++     data R = MkR (F Int)++     type Foo = 'MkR 'True++  For Foo to kind-check we need to know that (F Int) ~ Bool.  But we won't+  know that unless we've looked at the type instance declaration for F+  before kind-checking Foo.++* Another example is this (#3990).++     data family Complex a+     data instance Complex Double = CD {-# UNPACK #-} !Double+                                       {-# UNPACK #-} !Double++     data T = T {-# UNPACK #-} !(Complex Double)++  Here, to generate the right kind of unpacked implementation for T,+  we must have access to the 'data instance' declaration.++* Things become more complicated when we introduce transitive+  dependencies through imported definitions, like in this scenario:++      A.hs+        type family Closed (t :: Type) :: Type where+          Closed t = Open t++        type family Open (t :: Type) :: Type++      B.hs+        data Q where+          Q :: Closed Bool -> Q++        type instance Open Int = Bool++        type S = 'Q 'True++  Somehow, we must ensure that the instance Open Int = Bool is checked before+  the type synonym S. While we know that S depends upon 'Q depends upon Closed,+  we have no idea that Closed depends upon Open!++  To accomodate for these situations, we ensure that an instance is checked+  before every @TyClDecl@ on which it does not depend. That's to say, instances+  are checked as early as possible in @tcTyAndClassDecls@.++------------------------------------+So much for WHY.  What about HOW?  It's pretty easy:++(1) Rename the type/class, instance, and role declarations+    individually++(2) Do strongly-connected component analysis of the type/class decls,+    We'll make a TyClGroup for each SCC++    In this step we treat a reference to a (promoted) data constructor+    K as a dependency on its parent type.  Thus+        data T = K1 | K2+        data S = MkS (Proxy 'K1)+    Here S depends on 'K1 and hence on its parent T.++    In this step we ignore instances; see+    Note [No dependencies on data instances]++(3) Attach roles to the appropriate SCC++(4) Attach instances to the appropriate SCC.+    We add an instance decl to SCC when:+      all its free types/classes are bound in this SCC or earlier ones++(5) We make an initial TyClGroup, with empty group_tyclds, for any+    (orphan) instances that affect only imported types/classes++Steps (3) and (4) are done by the (mapAccumL mk_group) call.++Note [No dependencies on data instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   data family D a+   data instance D Int = D1+   data S = MkS (Proxy 'D1)++Here the declaration of S depends on the /data instance/ declaration+for 'D Int'.  That makes things a lot more complicated, especially+if the data instance is an associated type of an enclosing class instance.+(And the class instance might have several associated type instances+with different dependency structure!)++Ugh.  For now we simply don't allow promotion of data constructors for+data instances.  See Note [AFamDataCon: not promoting data family+constructors] in TcEnv+-}+++rnTyClDecls :: [TyClGroup GhcPs]+            -> RnM ([TyClGroup GhcRn], FreeVars)+-- Rename the declarations and do dependency analysis on them+rnTyClDecls tycl_ds+  = do { -- Rename the type/class, instance, and role declaraations+         tycls_w_fvs <- mapM (wrapLocFstM rnTyClDecl)+                             (tyClGroupTyClDecls tycl_ds)+       ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)++       ; instds_w_fvs <- mapM (wrapLocFstM rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)+       ; role_annots  <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)++       -- Do SCC analysis on the type/class decls+       ; rdr_env <- getGlobalRdrEnv+       ; let tycl_sccs = depAnalTyClDecls rdr_env tycls_w_fvs+             role_annot_env = mkRoleAnnotEnv role_annots++             inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs+             (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map++             first_group+               | null init_inst_ds = []+               | otherwise = [TyClGroup { group_ext    = noExt+                                        , group_tyclds = []+                                        , group_roles  = []+                                        , group_instds = init_inst_ds }]++             ((final_inst_ds, orphan_roles), groups)+                = mapAccumL mk_group (rest_inst_ds, role_annot_env) tycl_sccs+++             all_fvs = plusFV (foldr (plusFV . snd) emptyFVs tycls_w_fvs)+                              (foldr (plusFV . snd) emptyFVs instds_w_fvs)++             all_groups = first_group ++ groups++       ; ASSERT2( null final_inst_ds,  ppr instds_w_fvs $$ ppr inst_ds_map+                                       $$ ppr (flattenSCCs tycl_sccs) $$ ppr final_inst_ds  )+         mapM_ orphanRoleAnnotErr (nameEnvElts orphan_roles)++       ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)+       ; return (all_groups, all_fvs) }+  where+    mk_group :: (InstDeclFreeVarsMap, RoleAnnotEnv)+             -> SCC (LTyClDecl GhcRn)+             -> ( (InstDeclFreeVarsMap, RoleAnnotEnv)+                , TyClGroup GhcRn )+    mk_group (inst_map, role_env) scc+      = ((inst_map', role_env'), group)+      where+        tycl_ds              = flattenSCC scc+        bndrs                = map (tcdName . unLoc) tycl_ds+        (inst_ds, inst_map') = getInsts      bndrs inst_map+        (roles,   role_env') = getRoleAnnots bndrs role_env+        group = TyClGroup { group_ext    = noExt+                          , group_tyclds = tycl_ds+                          , group_roles  = roles+                          , group_instds = inst_ds }+++depAnalTyClDecls :: GlobalRdrEnv+                 -> [(LTyClDecl GhcRn, FreeVars)]+                 -> [SCC (LTyClDecl GhcRn)]+-- See Note [Dependency analysis of type, class, and instance decls]+depAnalTyClDecls rdr_env ds_w_fvs+  = stronglyConnCompFromEdgedVerticesUniq edges+  where+    edges :: [ Node Name (LTyClDecl GhcRn) ]+    edges = [ DigraphNode d (tcdName (unLoc d)) (map (getParent rdr_env) (nonDetEltsUniqSet fvs))+            | (d, fvs) <- ds_w_fvs ]+            -- It's OK to use nonDetEltsUFM here as+            -- stronglyConnCompFromEdgedVertices is still deterministic+            -- even if the edges are in nondeterministic order as explained+            -- in Note [Deterministic SCC] in Digraph.++toParents :: GlobalRdrEnv -> NameSet -> NameSet+toParents rdr_env ns+  = nonDetFoldUniqSet add emptyNameSet ns+  -- It's OK to use nonDetFoldUFM because we immediately forget the+  -- ordering by creating a set+  where+    add n s = extendNameSet s (getParent rdr_env n)++getParent :: GlobalRdrEnv -> Name -> Name+getParent rdr_env n+  = case lookupGRE_Name rdr_env n of+      Just gre -> case gre_par gre of+                    ParentIs  { par_is = p } -> p+                    FldParent { par_is = p } -> p+                    _                        -> n+      Nothing -> n+++{- ******************************************************+*                                                       *+       Role annotations+*                                                       *+****************************************************** -}++-- | Renames role annotations, returning them as the values in a NameEnv+-- and checks for duplicate role annotations.+-- It is quite convenient to do both of these in the same place.+-- See also Note [Role annotations in the renamer]+rnRoleAnnots :: NameSet+             -> [LRoleAnnotDecl GhcPs]+             -> RnM [LRoleAnnotDecl GhcRn]+rnRoleAnnots tc_names role_annots+  = do {  -- Check for duplicates *before* renaming, to avoid+          -- lumping together all the unboundNames+         let (no_dups, dup_annots) = removeDups role_annots_cmp role_annots+             role_annots_cmp (dL->L _ annot1) (dL->L _ annot2)+               = roleAnnotDeclName annot1 `compare` roleAnnotDeclName annot2+       ; mapM_ dupRoleAnnotErr dup_annots+       ; mapM (wrapLocM rn_role_annot1) no_dups }+  where+    rn_role_annot1 (RoleAnnotDecl _ tycon roles)+      = do {  -- the name is an *occurrence*, but look it up only in the+              -- decls defined in this group (see #10263)+             tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names)+                                          (text "role annotation")+                                          tycon+           ; return $ RoleAnnotDecl noExt tycon' roles }+    rn_role_annot1 (XRoleAnnotDecl _) = panic "rnRoleAnnots"++dupRoleAnnotErr :: NonEmpty (LRoleAnnotDecl GhcPs) -> RnM ()+dupRoleAnnotErr list+  = addErrAt loc $+    hang (text "Duplicate role annotations for" <+>+          quotes (ppr $ roleAnnotDeclName first_decl) <> colon)+       2 (vcat $ map pp_role_annot $ NE.toList sorted_list)+    where+      sorted_list = NE.sortBy cmp_annot list+      ((dL->L loc first_decl) :| _) = sorted_list++      pp_role_annot (dL->L loc decl) = hang (ppr decl)+                                      4 (text "-- written at" <+> ppr loc)++      cmp_annot (dL->L loc1 _) (dL->L loc2 _) = loc1 `compare` loc2++orphanRoleAnnotErr :: LRoleAnnotDecl GhcRn -> RnM ()+orphanRoleAnnotErr (dL->L loc decl)+  = addErrAt loc $+    hang (text "Role annotation for a type previously declared:")+       2 (ppr decl) $$+    parens (text "The role annotation must be given where" <+>+            quotes (ppr $ roleAnnotDeclName decl) <+>+            text "is declared.")+++{- Note [Role annotations in the renamer]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must ensure that a type's role annotation is put in the same group as the+proper type declaration. This is because role annotations are needed during+type-checking when creating the type's TyCon. So, rnRoleAnnots builds a+NameEnv (LRoleAnnotDecl Name) that maps a name to a role annotation for that+type, if any. Then, this map can be used to add the role annotations to the+groups after dependency analysis.++This process checks for duplicate role annotations, where we must be careful+to do the check *before* renaming to avoid calling all unbound names duplicates+of one another.++The renaming process, as usual, might identify and report errors for unbound+names. We exclude the annotations for unbound names in the annotation+environment to avoid spurious errors for orphaned annotations.++We then (in rnTyClDecls) do a check for orphan role annotations (role+annotations without an accompanying type decl). The check works by folding+over components (of type [[Either (TyClDecl Name) (InstDecl Name)]]), selecting+out the relevant role declarations for each group, as well as diminishing the+annotation environment. After the fold is complete, anything left over in the+name environment must be an orphan, and errors are generated.++An earlier version of this algorithm short-cut the orphan check by renaming+only with names declared in this module. But, this check is insufficient in+the case of staged module compilation (Template Haskell, GHCi).+See #8485. With the new lookup process (which includes types declared in other+modules), we get better error messages, too.+-}+++{- ******************************************************+*                                                       *+       Dependency info for instances+*                                                       *+****************************************************** -}++----------------------------------------------------------+-- | 'InstDeclFreeVarsMap is an association of an+--   @InstDecl@ with @FreeVars@. The @FreeVars@ are+--   the tycon names that are both+--     a) free in the instance declaration+--     b) bound by this group of type/class/instance decls+type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)]++-- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the+--   @FreeVars@ which are *not* the binders of a @TyClDecl@.+mkInstDeclFreeVarsMap :: GlobalRdrEnv+                      -> NameSet+                      -> [(LInstDecl GhcRn, FreeVars)]+                      -> InstDeclFreeVarsMap+mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs+  = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs)+    | (inst_decl, fvs) <- inst_ds_fvs ]++-- | Get the @LInstDecl@s which have empty @FreeVars@ sets, and the+--   @InstDeclFreeVarsMap@ with these entries removed.+-- We call (getInsts tcs instd_map) when we've completed the declarations+-- for 'tcs'.  The call returns (inst_decls, instd_map'), where+--   inst_decls are the instance declarations all of+--              whose free vars are now defined+--   instd_map' is the inst-decl map with 'tcs' removed from+--               the free-var set+getInsts :: [Name] -> InstDeclFreeVarsMap+         -> ([LInstDecl GhcRn], InstDeclFreeVarsMap)+getInsts bndrs inst_decl_map+  = partitionWith pick_me inst_decl_map+  where+    pick_me :: (LInstDecl GhcRn, FreeVars)+            -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars)+    pick_me (decl, fvs)+      | isEmptyNameSet depleted_fvs = Left decl+      | otherwise                   = Right (decl, depleted_fvs)+      where+        depleted_fvs = delFVs bndrs fvs++{- ******************************************************+*                                                       *+         Renaming a type or class declaration+*                                                       *+****************************************************** -}++rnTyClDecl :: TyClDecl GhcPs+           -> RnM (TyClDecl GhcRn, FreeVars)++-- All flavours of type family declarations ("type family", "newtype family",+-- and "data family"), both top level and (for an associated type)+-- in a class decl+rnTyClDecl (FamDecl { tcdFam = decl })+  = do { (decl', fvs) <- rnFamDecl Nothing decl+       ; return (FamDecl noExt decl', fvs) }++rnTyClDecl (SynDecl { tcdLName = tycon, tcdTyVars = tyvars,+                      tcdFixity = fixity, tcdRhs = rhs })+  = do { tycon' <- lookupLocatedTopBndrRn tycon+       ; let kvs = extractHsTyRdrTyVarsKindVars rhs+             doc = TySynCtx tycon+       ; traceRn "rntycl-ty" (ppr tycon <+> ppr kvs)+       ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' _ ->+    do { (rhs', fvs) <- rnTySyn doc rhs+       ; return (SynDecl { tcdLName = tycon', tcdTyVars = tyvars'+                         , tcdFixity = fixity+                         , tcdRhs = rhs', tcdSExt = fvs }, fvs) } }++-- "data", "newtype" declarations+-- both top level and (for an associated type) in an instance decl+rnTyClDecl (DataDecl { tcdLName = tycon, tcdTyVars = tyvars,+                       tcdFixity = fixity, tcdDataDefn = defn })+  = do { tycon' <- lookupLocatedTopBndrRn tycon+       ; let kvs = extractDataDefnKindVars defn+             doc = TyDataCtx tycon+       ; traceRn "rntycl-data" (ppr tycon <+> ppr kvs)+       ; bindHsQTyVars doc Nothing Nothing kvs tyvars $ \ tyvars' no_rhs_kvs ->+    do { (defn', fvs) <- rnDataDefn doc defn+          -- See Note [Complete user-supplied kind signatures] in HsDecls+       ; cusks_enabled <- xoptM LangExt.CUSKs+       ; let cusk = cusks_enabled && hsTvbAllKinded tyvars' && no_rhs_kvs+             rn_info = DataDeclRn { tcdDataCusk = cusk+                                  , tcdFVs      = fvs }+       ; traceRn "rndata" (ppr tycon <+> ppr cusk <+> ppr no_rhs_kvs)+       ; return (DataDecl { tcdLName    = tycon'+                          , tcdTyVars   = tyvars'+                          , tcdFixity   = fixity+                          , tcdDataDefn = defn'+                          , tcdDExt     = rn_info }, fvs) } }++rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,+                        tcdTyVars = tyvars, tcdFixity = fixity,+                        tcdFDs = fds, tcdSigs = sigs,+                        tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,+                        tcdDocs = docs})+  = do  { lcls' <- lookupLocatedTopBndrRn lcls+        ; let cls' = unLoc lcls'+              kvs = []  -- No scoped kind vars except those in+                        -- kind signatures on the tyvars++        -- Tyvars scope over superclass context and method signatures+        ; ((tyvars', context', fds', ats'), stuff_fvs)+            <- bindHsQTyVars cls_doc Nothing Nothing kvs tyvars $ \ tyvars' _ -> do+                  -- Checks for distinct tyvars+             { (context', cxt_fvs) <- rnContext cls_doc context+             ; fds'  <- rnFds fds+                         -- The fundeps have no free variables+             ; (ats', fv_ats) <- rnATDecls cls' ats+             ; let fvs = cxt_fvs     `plusFV`+                         fv_ats+             ; return ((tyvars', context', fds', ats'), fvs) }++        ; (at_defs', fv_at_defs) <- rnList (rnTyFamDefltDecl cls') at_defs++        -- No need to check for duplicate associated type decls+        -- since that is done by RnNames.extendGlobalRdrEnvRn++        -- Check the signatures+        -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs).+        ; let sig_rdr_names_w_locs =+                [op | (dL->L _ (ClassOpSig _ False ops _)) <- sigs+                    , op <- ops]+        ; checkDupRdrNames sig_rdr_names_w_locs+                -- Typechecker is responsible for checking that we only+                -- give default-method bindings for things in this class.+                -- The renamer *could* check this for class decls, but can't+                -- for instance decls.++        -- The newLocals call is tiresome: given a generic class decl+        --      class C a where+        --        op :: a -> a+        --        op {| x+y |} (Inl a) = ...+        --        op {| x+y |} (Inr b) = ...+        --        op {| a*b |} (a*b)   = ...+        -- we want to name both "x" tyvars with the same unique, so that they are+        -- easy to group together in the typechecker.+        ; (mbinds', sigs', meth_fvs)+            <- rnMethodBinds True cls' (hsAllLTyVarNames tyvars') mbinds sigs+                -- No need to check for duplicate method signatures+                -- since that is done by RnNames.extendGlobalRdrEnvRn+                -- and the methods are already in scope++  -- Haddock docs+        ; docs' <- mapM (wrapLocM rnDocDecl) docs++        ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs+        ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',+                              tcdTyVars = tyvars', tcdFixity = fixity,+                              tcdFDs = fds', tcdSigs = sigs',+                              tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',+                              tcdDocs = docs', tcdCExt = all_fvs },+                  all_fvs ) }+  where+    cls_doc  = ClassDeclCtx lcls++rnTyClDecl (XTyClDecl _) = panic "rnTyClDecl"++-- "type" and "type instance" declarations+rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)+rnTySyn doc rhs = rnLHsType doc rhs++rnDataDefn :: HsDocContext -> HsDataDefn GhcPs+           -> RnM (HsDataDefn GhcRn, FreeVars)+rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType+                           , dd_ctxt = context, dd_cons = condecls+                           , dd_kindSig = m_sig, dd_derivs = derivs })+  = do  { checkTc (h98_style || null (unLoc context))+                  (badGadtStupidTheta doc)++        ; (m_sig', sig_fvs) <- case m_sig of+             Just sig -> first Just <$> rnLHsKind doc sig+             Nothing  -> return (Nothing, emptyFVs)+        ; (context', fvs1) <- rnContext doc context+        ; (derivs',  fvs3) <- rn_derivs derivs++        -- For the constructor declarations, drop the LocalRdrEnv+        -- in the GADT case, where the type variables in the declaration+        -- do not scope over the constructor signatures+        -- data T a where { T1 :: forall b. b-> b }+        ; let { zap_lcl_env | h98_style = \ thing -> thing+                            | otherwise = setLocalRdrEnv emptyLocalRdrEnv }+        ; (condecls', con_fvs) <- zap_lcl_env $ rnConDecls condecls+           -- No need to check for duplicate constructor decls+           -- since that is done by RnNames.extendGlobalRdrEnvRn++        ; let all_fvs = fvs1 `plusFV` fvs3 `plusFV`+                        con_fvs `plusFV` sig_fvs+        ; return ( HsDataDefn { dd_ext = noExt+                              , dd_ND = new_or_data, dd_cType = cType+                              , dd_ctxt = context', dd_kindSig = m_sig'+                              , dd_cons = condecls'+                              , dd_derivs = derivs' }+                 , all_fvs )+        }+  where+    h98_style = case condecls of  -- Note [Stupid theta]+                     (dL->L _ (ConDeclGADT {})) : _  -> False+                     _                               -> True++    rn_derivs (dL->L loc ds)+      = do { deriv_strats_ok <- xoptM LangExt.DerivingStrategies+           ; failIfTc (lengthExceeds ds 1 && not deriv_strats_ok)+               multipleDerivClausesErr+           ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause doc) ds+           ; return (cL loc ds', fvs) }+rnDataDefn _ (XHsDataDefn _) = panic "rnDataDefn"++warnNoDerivStrat :: Maybe (LDerivStrategy GhcRn)+                 -> SrcSpan+                 -> RnM ()+warnNoDerivStrat mds loc+  = do { dyn_flags <- getDynFlags+       ; when (wopt Opt_WarnMissingDerivingStrategies dyn_flags) $+           case mds of+             Nothing -> addWarnAt+               (Reason Opt_WarnMissingDerivingStrategies)+               loc+               (if xopt LangExt.DerivingStrategies dyn_flags+                 then no_strat_warning+                 else no_strat_warning $+$ deriv_strat_nenabled+               )+             _ -> pure ()+       }+  where+    no_strat_warning :: SDoc+    no_strat_warning = text "No deriving strategy specified. Did you want stock"+                       <> text ", newtype, or anyclass?"+    deriv_strat_nenabled :: SDoc+    deriv_strat_nenabled = text "Use DerivingStrategies to specify a strategy."++rnLHsDerivingClause :: HsDocContext -> LHsDerivingClause GhcPs+                    -> RnM (LHsDerivingClause GhcRn, FreeVars)+rnLHsDerivingClause doc+                (dL->L loc (HsDerivingClause+                              { deriv_clause_ext = noExt+                              , deriv_clause_strategy = dcs+                              , deriv_clause_tys = (dL->L loc' dct) }))+  = do { (dcs', dct', fvs)+           <- rnLDerivStrategy doc dcs $ \strat_tvs ppr_via_ty ->+              mapFvRn (rn_deriv_ty strat_tvs ppr_via_ty) dct+       ; warnNoDerivStrat dcs' loc+       ; pure ( cL loc (HsDerivingClause { deriv_clause_ext = noExt+                                         , deriv_clause_strategy = dcs'+                                         , deriv_clause_tys = cL loc' dct' })+              , fvs ) }+  where+    rn_deriv_ty :: [Name] -> SDoc -> LHsSigType GhcPs+                -> RnM (LHsSigType GhcRn, FreeVars)+    rn_deriv_ty strat_tvs ppr_via_ty deriv_ty@(HsIB {hsib_body = dL->L loc _}) =+      rnAndReportFloatingViaTvs strat_tvs loc ppr_via_ty "class" $+      rnHsSigType doc deriv_ty+    rn_deriv_ty _ _ (XHsImplicitBndrs _) = panic "rn_deriv_ty"+rnLHsDerivingClause _ (dL->L _ (XHsDerivingClause _))+  = panic "rnLHsDerivingClause"+rnLHsDerivingClause _ _ = panic "rnLHsDerivingClause: Impossible Match"+                                -- due to #15884++rnLDerivStrategy :: forall a.+                    HsDocContext+                 -> Maybe (LDerivStrategy GhcPs)+                 -> ([Name]   -- The tyvars bound by the via type+                      -> SDoc -- The pretty-printed via type (used for+                              -- error message reporting)+                      -> RnM (a, FreeVars))+                 -> RnM (Maybe (LDerivStrategy GhcRn), a, FreeVars)+rnLDerivStrategy doc mds thing_inside+  = case mds of+      Nothing -> boring_case Nothing+      Just ds -> do (ds', thing, fvs) <- rn_deriv_strat ds+                    pure (Just ds', thing, fvs)+  where+    rn_deriv_strat :: LDerivStrategy GhcPs+                   -> RnM (LDerivStrategy GhcRn, a, FreeVars)+    rn_deriv_strat (dL->L loc ds) = do+      let extNeeded :: LangExt.Extension+          extNeeded+            | ViaStrategy{} <- ds+            = LangExt.DerivingVia+            | otherwise+            = LangExt.DerivingStrategies++      unlessXOptM extNeeded $+        failWith $ illegalDerivStrategyErr ds++      case ds of+        StockStrategy    -> boring_case (cL loc StockStrategy)+        AnyclassStrategy -> boring_case (cL loc AnyclassStrategy)+        NewtypeStrategy  -> boring_case (cL loc NewtypeStrategy)+        ViaStrategy via_ty ->+          do (via_ty', fvs1) <- rnHsSigType doc via_ty+             let HsIB { hsib_ext  = via_imp_tvs+                      , hsib_body = via_body } = via_ty'+                 (via_exp_tv_bndrs, _, _) = splitLHsSigmaTy via_body+                 via_exp_tvs = hsLTyVarNames via_exp_tv_bndrs+                 via_tvs = via_imp_tvs ++ via_exp_tvs+             (thing, fvs2) <- extendTyVarEnvFVRn via_tvs $+                              thing_inside via_tvs (ppr via_ty')+             pure (cL loc (ViaStrategy via_ty'), thing, fvs1 `plusFV` fvs2)++    boring_case :: mds+                -> RnM (mds, a, FreeVars)+    boring_case mds = do+      (thing, fvs) <- thing_inside [] empty+      pure (mds, thing, fvs)++-- | Errors if a @via@ type binds any floating type variables.+-- See @Note [Floating `via` type variables]@+rnAndReportFloatingViaTvs+  :: forall a. Outputable a+  => [Name]  -- ^ The bound type variables from a @via@ type.+  -> SrcSpan -- ^ The source span (for error reporting only).+  -> SDoc    -- ^ The pretty-printed @via@ type (for error reporting only).+  -> String  -- ^ A description of what the @via@ type scopes over+             --   (for error reporting only).+  -> RnM (a, FreeVars) -- ^ The thing the @via@ type scopes over.+  -> RnM (a, FreeVars)+rnAndReportFloatingViaTvs tv_names loc ppr_via_ty via_scope_desc thing_inside+  = do (thing, thing_fvs) <- thing_inside+       setSrcSpan loc $ mapM_ (report_floating_via_tv thing thing_fvs) tv_names+       pure (thing, thing_fvs)+  where+    report_floating_via_tv :: a -> FreeVars -> Name -> RnM ()+    report_floating_via_tv thing used_names tv_name+      = unless (tv_name `elemNameSet` used_names) $ addErr $ vcat+          [ text "Type variable" <+> quotes (ppr tv_name) <+>+            text "is bound in the" <+> quotes (text "via") <+>+            text "type" <+> quotes ppr_via_ty+          , text "but is not mentioned in the derived" <+>+            text via_scope_desc <+> quotes (ppr thing) <>+            text ", which is illegal" ]++{-+Note [Floating `via` type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Imagine the following `deriving via` clause:++    data Quux+      deriving Eq via (Const a Quux)++This should be rejected. Why? Because it would generate the following instance:++    instance Eq Quux where+      (==) = coerce @(Quux         -> Quux         -> Bool)+                    @(Const a Quux -> Const a Quux -> Bool)+                    (==) :: Const a Quux -> Const a Quux -> Bool++This instance is ill-formed, as the `a` in `Const a Quux` is unbound. The+problem is that `a` is never used anywhere in the derived class `Eq`. Since+`a` is bound but has no use sites, we refer to it as "floating".++We use the rnAndReportFloatingViaTvs function to check that any type renamed+within the context of the `via` deriving strategy actually uses all bound+`via` type variables, and if it doesn't, it throws an error.+-}++badGadtStupidTheta :: HsDocContext -> SDoc+badGadtStupidTheta _+  = vcat [text "No context is allowed on a GADT-style data declaration",+          text "(You can put a context on each constructor, though.)"]++illegalDerivStrategyErr :: DerivStrategy GhcPs -> SDoc+illegalDerivStrategyErr ds+  = vcat [ text "Illegal deriving strategy" <> colon <+> derivStrategyName ds+         , text enableStrategy ]++  where+    enableStrategy :: String+    enableStrategy+      | ViaStrategy{} <- ds+      = "Use DerivingVia to enable this extension"+      | otherwise+      = "Use DerivingStrategies to enable this extension"++multipleDerivClausesErr :: SDoc+multipleDerivClausesErr+  = vcat [ text "Illegal use of multiple, consecutive deriving clauses"+         , text "Use DerivingStrategies to allow this" ]++rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested+                        --             inside an *class decl* for cls+                        --             used for associated types+          -> FamilyDecl GhcPs+          -> RnM (FamilyDecl GhcRn, FreeVars)+rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars+                             , fdFixity = fixity+                             , fdInfo = info, fdResultSig = res_sig+                             , fdInjectivityAnn = injectivity })+  = do { tycon' <- lookupLocatedTopBndrRn tycon+       ; ((tyvars', res_sig', injectivity'), fv1) <-+            bindHsQTyVars doc Nothing mb_cls kvs tyvars $ \ tyvars' _ ->+            do { let rn_sig = rnFamResultSig doc+               ; (res_sig', fv_kind) <- wrapLocFstM rn_sig res_sig+               ; injectivity' <- traverse (rnInjectivityAnn tyvars' res_sig')+                                          injectivity+               ; return ( (tyvars', res_sig', injectivity') , fv_kind ) }+       ; (info', fv2) <- rn_info tycon' info+       ; return (FamilyDecl { fdExt = noExt+                            , fdLName = tycon', fdTyVars = tyvars'+                            , fdFixity = fixity+                            , fdInfo = info', fdResultSig = res_sig'+                            , fdInjectivityAnn = injectivity' }+                , fv1 `plusFV` fv2) }+  where+     doc = TyFamilyCtx tycon+     kvs = extractRdrKindSigVars res_sig++     ----------------------+     rn_info :: Located Name+             -> FamilyInfo GhcPs -> RnM (FamilyInfo GhcRn, FreeVars)+     rn_info (dL->L _ fam_name) (ClosedTypeFamily (Just eqns))+       = do { (eqns', fvs)+                <- rnList (rnTyFamInstEqn NonAssocTyFamEqn (ClosedTyFam tycon fam_name))+                                          -- no class context+                          eqns+            ; return (ClosedTypeFamily (Just eqns'), fvs) }+     rn_info _ (ClosedTypeFamily Nothing)+       = return (ClosedTypeFamily Nothing, emptyFVs)+     rn_info _ OpenTypeFamily = return (OpenTypeFamily, emptyFVs)+     rn_info _ DataFamily     = return (DataFamily, emptyFVs)+rnFamDecl _ (XFamilyDecl _) = panic "rnFamDecl"++rnFamResultSig :: HsDocContext+               -> FamilyResultSig GhcPs+               -> RnM (FamilyResultSig GhcRn, FreeVars)+rnFamResultSig _ (NoSig _)+   = return (NoSig noExt, emptyFVs)+rnFamResultSig doc (KindSig _ kind)+   = do { (rndKind, ftvs) <- rnLHsKind doc kind+        ;  return (KindSig noExt rndKind, ftvs) }+rnFamResultSig doc (TyVarSig _ tvbndr)+   = do { -- `TyVarSig` tells us that user named the result of a type family by+          -- writing `= tyvar` or `= (tyvar :: kind)`. In such case we want to+          -- be sure that the supplied result name is not identical to an+          -- already in-scope type variable from an enclosing class.+          --+          --  Example of disallowed declaration:+          --         class C a b where+          --            type F b = a | a -> b+          rdr_env <- getLocalRdrEnv+       ;  let resName = hsLTyVarName tvbndr+       ;  when (resName `elemLocalRdrEnv` rdr_env) $+          addErrAt (getLoc tvbndr) $+                     (hsep [ text "Type variable", quotes (ppr resName) <> comma+                           , text "naming a type family result,"+                           ] $$+                      text "shadows an already bound type variable")++       ; bindLHsTyVarBndr doc Nothing -- This might be a lie, but it's used for+                                      -- scoping checks that are irrelevant here+                          tvbndr $ \ tvbndr' ->+         return (TyVarSig noExt tvbndr', unitFV (hsLTyVarName tvbndr')) }+rnFamResultSig _ (XFamilyResultSig _) = panic "rnFamResultSig"++-- Note [Renaming injectivity annotation]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- During renaming of injectivity annotation we have to make several checks to+-- make sure that it is well-formed.  At the moment injectivity annotation+-- consists of a single injectivity condition, so the terms "injectivity+-- annotation" and "injectivity condition" might be used interchangeably.  See+-- Note [Injectivity annotation] for a detailed discussion of currently allowed+-- injectivity annotations.+--+-- Checking LHS is simple because the only type variable allowed on the LHS of+-- injectivity condition is the variable naming the result in type family head.+-- Example of disallowed annotation:+--+--     type family Foo a b = r | b -> a+--+-- Verifying RHS of injectivity consists of checking that:+--+--  1. only variables defined in type family head appear on the RHS (kind+--     variables are also allowed).  Example of disallowed annotation:+--+--        type family Foo a = r | r -> b+--+--  2. for associated types the result variable does not shadow any of type+--     class variables. Example of disallowed annotation:+--+--        class Foo a b where+--           type F a = b | b -> a+--+-- Breaking any of these assumptions results in an error.++-- | Rename injectivity annotation. Note that injectivity annotation is just the+-- part after the "|".  Everything that appears before it is renamed in+-- rnFamDecl.+rnInjectivityAnn :: LHsQTyVars GhcRn           -- ^ Type variables declared in+                                               --   type family head+                 -> LFamilyResultSig GhcRn     -- ^ Result signature+                 -> LInjectivityAnn GhcPs      -- ^ Injectivity annotation+                 -> RnM (LInjectivityAnn GhcRn)+rnInjectivityAnn tvBndrs (dL->L _ (TyVarSig _ resTv))+                 (dL->L srcSpan (InjectivityAnn injFrom injTo))+ = do+   { (injDecl'@(dL->L _ (InjectivityAnn injFrom' injTo')), noRnErrors)+          <- askNoErrs $+             bindLocalNames [hsLTyVarName resTv] $+             -- The return type variable scopes over the injectivity annotation+             -- e.g.   type family F a = (r::*) | r -> a+             do { injFrom' <- rnLTyVar injFrom+                ; injTo'   <- mapM rnLTyVar injTo+                ; return $ cL srcSpan (InjectivityAnn injFrom' injTo') }++   ; let tvNames  = Set.fromList $ hsAllLTyVarNames tvBndrs+         resName  = hsLTyVarName resTv+         -- See Note [Renaming injectivity annotation]+         lhsValid = EQ == (stableNameCmp resName (unLoc injFrom'))+         rhsValid = Set.fromList (map unLoc injTo') `Set.difference` tvNames++   -- if renaming of type variables ended with errors (eg. there were+   -- not-in-scope variables) don't check the validity of injectivity+   -- annotation. This gives better error messages.+   ; when (noRnErrors && not lhsValid) $+        addErrAt (getLoc injFrom)+              ( vcat [ text $ "Incorrect type variable on the LHS of "+                           ++ "injectivity condition"+              , nest 5+              ( vcat [ text "Expected :" <+> ppr resName+                     , text "Actual   :" <+> ppr injFrom ])])++   ; when (noRnErrors && not (Set.null rhsValid)) $+      do { let errorVars = Set.toList rhsValid+         ; addErrAt srcSpan $ ( hsep+                        [ text "Unknown type variable" <> plural errorVars+                        , text "on the RHS of injectivity condition:"+                        , interpp'SP errorVars ] ) }++   ; return injDecl' }++-- We can only hit this case when the user writes injectivity annotation without+-- naming the result:+--+--   type family F a | result -> a+--   type family F a :: * | result -> a+--+-- So we rename injectivity annotation like we normally would except that+-- this time we expect "result" to be reported not in scope by rnLTyVar.+rnInjectivityAnn _ _ (dL->L srcSpan (InjectivityAnn injFrom injTo)) =+   setSrcSpan srcSpan $ do+   (injDecl', _) <- askNoErrs $ do+     injFrom' <- rnLTyVar injFrom+     injTo'   <- mapM rnLTyVar injTo+     return $ cL srcSpan (InjectivityAnn injFrom' injTo')+   return $ injDecl'++{-+Note [Stupid theta]+~~~~~~~~~~~~~~~~~~~+#3850 complains about a regression wrt 6.10 for+     data Show a => T a+There is no reason not to allow the stupid theta if there are no data+constructors.  It's still stupid, but does no harm, and I don't want+to cause programs to break unnecessarily (notably HList).  So if there+are no data constructors we allow h98_style = True+-}+++{- *****************************************************+*                                                      *+     Support code for type/data declarations+*                                                      *+***************************************************** -}++---------------+wrongTyFamName :: Name -> Name -> SDoc+wrongTyFamName fam_tc_name eqn_tc_name+  = hang (text "Mismatched type name in type family instance.")+       2 (vcat [ text "Expected:" <+> ppr fam_tc_name+               , text "  Actual:" <+> ppr eqn_tc_name ])++-----------------+rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars)+rnConDecls = mapFvRn (wrapLocFstM rnConDecl)++rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars)+rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs+                           , con_mb_cxt = mcxt, con_args = args+                           , con_doc = mb_doc })+  = do  { _        <- addLocM checkConName name+        ; new_name <- lookupLocatedTopBndrRn name+        ; mb_doc'  <- rnMbLHsDoc mb_doc++        -- We bind no implicit binders here; this is just like+        -- a nested HsForAllTy.  E.g. consider+        --         data T a = forall (b::k). MkT (...)+        -- The 'k' will already be in scope from the bindHsQTyVars+        -- for the data decl itself. So we'll get+        --         data T {k} a = ...+        -- And indeed we may later discover (a::k).  But that's the+        -- scoping we get.  So no implicit binders at the existential forall++        ; let ctxt = ConDeclCtx [new_name]+        ; bindLHsTyVarBndrs ctxt (Just (inHsDocContext ctxt))+                            Nothing ex_tvs $ \ new_ex_tvs ->+    do  { (new_context, fvs1) <- rnMbContext ctxt mcxt+        ; (new_args,    fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args+        ; let all_fvs  = fvs1 `plusFV` fvs2+        ; traceRn "rnConDecl" (ppr name <+> vcat+             [ text "ex_tvs:" <+> ppr ex_tvs+             , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ])++        ; return (decl { con_ext = noExt+                       , con_name = new_name, con_ex_tvs = new_ex_tvs+                       , con_mb_cxt = new_context, con_args = new_args+                       , con_doc = mb_doc' },+                  all_fvs) }}++rnConDecl decl@(ConDeclGADT { con_names   = names+                            , con_forall  = (dL->L _ explicit_forall)+                            , con_qvars   = qtvs+                            , con_mb_cxt  = mcxt+                            , con_args    = args+                            , con_res_ty  = res_ty+                            , con_doc = mb_doc })+  = do  { mapM_ (addLocM checkConName) names+        ; new_names <- mapM lookupLocatedTopBndrRn names+        ; mb_doc'   <- rnMbLHsDoc mb_doc++        ; let explicit_tkvs = hsQTvExplicit qtvs+              theta         = hsConDeclTheta mcxt+              arg_tys       = hsConDeclArgTys args++          -- We must ensure that we extract the free tkvs in left-to-right+          -- order of their appearance in the constructor type.+          -- That order governs the order the implicitly-quantified type+          -- variable, and hence the order needed for visible type application+          -- See #14808.+              free_tkvs = extractHsTvBndrs explicit_tkvs $+                          extractHsTysRdrTyVarsDups (theta ++ arg_tys ++ [res_ty])++              ctxt    = ConDeclCtx new_names+              mb_ctxt = Just (inHsDocContext ctxt)++        ; traceRn "rnConDecl" (ppr names $$ ppr free_tkvs $$ ppr explicit_forall )+        ; rnImplicitBndrs (not explicit_forall) free_tkvs $ \ implicit_tkvs ->+          bindLHsTyVarBndrs ctxt mb_ctxt Nothing explicit_tkvs $ \ explicit_tkvs ->+    do  { (new_cxt, fvs1)    <- rnMbContext ctxt mcxt+        ; (new_args, fvs2)   <- rnConDeclDetails (unLoc (head new_names)) ctxt args+        ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty++        ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3+              (args', res_ty')+                  = case args of+                      InfixCon {}  -> pprPanic "rnConDecl" (ppr names)+                      RecCon {}    -> (new_args, new_res_ty)+                      PrefixCon as | (arg_tys, final_res_ty) <- splitHsFunType new_res_ty+                                   -> ASSERT( null as )+                                      -- See Note [GADT abstract syntax] in HsDecls+                                      (PrefixCon arg_tys, final_res_ty)++              new_qtvs =  HsQTvs { hsq_ext = implicit_tkvs+                                 , hsq_explicit  = explicit_tkvs }++        ; traceRn "rnConDecl2" (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs)+        ; return (decl { con_g_ext = noExt, con_names = new_names+                       , con_qvars = new_qtvs, con_mb_cxt = new_cxt+                       , con_args = args', con_res_ty = res_ty'+                       , con_doc = mb_doc' },+                  all_fvs) } }++rnConDecl (XConDecl _) = panic "rnConDecl"+++rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)+            -> RnM (Maybe (LHsContext GhcRn), FreeVars)+rnMbContext _    Nothing    = return (Nothing, emptyFVs)+rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt+                                ; return (Just ctx',fvs) }++rnConDeclDetails+   :: Name+   -> HsDocContext+   -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs])+   -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]),+           FreeVars)+rnConDeclDetails _ doc (PrefixCon tys)+  = do { (new_tys, fvs) <- rnLHsTypes doc tys+       ; return (PrefixCon new_tys, fvs) }++rnConDeclDetails _ doc (InfixCon ty1 ty2)+  = do { (new_ty1, fvs1) <- rnLHsType doc ty1+       ; (new_ty2, fvs2) <- rnLHsType doc ty2+       ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) }++rnConDeclDetails con doc (RecCon (dL->L l fields))+  = do  { fls <- lookupConstructorFields con+        ; (new_fields, fvs) <- rnConDeclFields doc fls fields+                -- No need to check for duplicate fields+                -- since that is done by RnNames.extendGlobalRdrEnvRn+        ; return (RecCon (cL l new_fields), fvs) }++-------------------------------------------------++-- | Brings pattern synonym names and also pattern synonym selectors+-- from record pattern synonyms into scope.+extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv+                -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a+extendPatSynEnv val_decls local_fix_env thing = do {+     names_with_fls <- new_ps val_decls+   ; let pat_syn_bndrs = concat [ name: map flSelector fields+                                | (name, fields) <- names_with_fls ]+   ; let avails = map avail pat_syn_bndrs+   ; (gbl_env, lcl_env) <- extendGlobalRdrEnvRn avails local_fix_env++   ; let field_env' = extendNameEnvList (tcg_field_env gbl_env) names_with_fls+         final_gbl_env = gbl_env { tcg_field_env = field_env' }+   ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) }+  where+    new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])]+    new_ps (ValBinds _ binds _) = foldrBagM new_ps' [] binds+    new_ps _ = panic "new_ps"++    new_ps' :: LHsBindLR GhcPs GhcPs+            -> [(Name, [FieldLabel])]+            -> TcM [(Name, [FieldLabel])]+    new_ps' bind names+      | (dL->L bind_loc (PatSynBind _ (PSB { psb_id = (dL->L _ n)+                                           , psb_args = RecCon as }))) <- bind+      = do+          bnd_name <- newTopSrcBinder (cL bind_loc n)+          let rnames = map recordPatSynSelectorId as+              mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs+              mkFieldOcc (dL->L l name) = cL l (FieldOcc noExt (cL l name))+              field_occs =  map mkFieldOcc rnames+          flds     <- mapM (newRecordSelector False [bnd_name]) field_occs+          return ((bnd_name, flds): names)+      | (dL->L bind_loc (PatSynBind _+                          (PSB { psb_id = (dL->L _ n)}))) <- bind+      = do+        bnd_name <- newTopSrcBinder (cL bind_loc n)+        return ((bnd_name, []): names)+      | otherwise+      = return names++{-+*********************************************************+*                                                      *+\subsection{Support code to rename types}+*                                                      *+*********************************************************+-}++rnFds :: [LHsFunDep GhcPs] -> RnM [LHsFunDep GhcRn]+rnFds fds+  = mapM (wrapLocM rn_fds) fds+  where+    rn_fds (tys1, tys2)+      = do { tys1' <- rnHsTyVars tys1+           ; tys2' <- rnHsTyVars tys2+           ; return (tys1', tys2') }++rnHsTyVars :: [Located RdrName] -> RnM [Located Name]+rnHsTyVars tvs  = mapM rnHsTyVar tvs++rnHsTyVar :: Located RdrName -> RnM (Located Name)+rnHsTyVar (dL->L l tyvar) = do+  tyvar' <- lookupOccRn tyvar+  return (cL l tyvar')++{-+*********************************************************+*                                                      *+        findSplice+*                                                      *+*********************************************************++This code marches down the declarations, looking for the first+Template Haskell splice.  As it does so it+        a) groups the declarations into a HsGroup+        b) runs any top-level quasi-quotes+-}++findSplice :: [LHsDecl GhcPs]+           -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))+findSplice ds = addl emptyRdrGroup ds++addl :: HsGroup GhcPs -> [LHsDecl GhcPs]+     -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))+-- This stuff reverses the declarations (again) but it doesn't matter+addl gp []           = return (gp, Nothing)+addl gp ((dL->L l d) : ds) = add gp l d ds+++add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs]+    -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs]))++-- #10047: Declaration QuasiQuoters are expanded immediately, without+--         causing a group split+add gp _ (SpliceD _ (SpliceDecl _ (dL->L _ qq@HsQuasiQuote{}) _)) ds+  = do { (ds', _) <- rnTopSpliceDecls qq+       ; addl gp (ds' ++ ds)+       }++add gp loc (SpliceD _ splice@(SpliceDecl _ _ flag)) ds+  = do { -- We've found a top-level splice.  If it is an *implicit* one+         -- (i.e. a naked top level expression)+         case flag of+           ExplicitSplice -> return ()+           ImplicitSplice -> do { th_on <- xoptM LangExt.TemplateHaskell+                                ; unless th_on $ setSrcSpan loc $+                                  failWith badImplicitSplice }++       ; return (gp, Just (splice, ds)) }+  where+    badImplicitSplice = text "Parse error: module header, import declaration"+                     $$ text "or top-level declaration expected."+                     -- The compiler should suggest the above, and not using+                     -- TemplateHaskell since the former suggestion is more+                     -- relevant to the larger base of users.+                     -- See #12146 for discussion.++-- Class declarations: pull out the fixity signatures to the top+add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD _ d) ds+  | isClassDecl d+  = let fsigs = [ cL l f+                | (dL->L l (FixSig _ f)) <- tcdSigs d ] in+    addl (gp { hs_tyclds = add_tycld (cL l d) ts, hs_fixds = fsigs ++ fs}) ds+  | otherwise+  = addl (gp { hs_tyclds = add_tycld (cL l d) ts }) ds++-- Signatures: fixity sigs go a different place than all others+add gp@(HsGroup {hs_fixds = ts}) l (SigD _ (FixSig _ f)) ds+  = addl (gp {hs_fixds = cL l f : ts}) ds+add gp@(HsGroup {hs_valds = ts}) l (SigD _ d) ds+  = addl (gp {hs_valds = add_sig (cL l d) ts}) ds++-- Value declarations: use add_bind+add gp@(HsGroup {hs_valds  = ts}) l (ValD _ d) ds+  = addl (gp { hs_valds = add_bind (cL l d) ts }) ds++-- Role annotations: added to the TyClGroup+add gp@(HsGroup {hs_tyclds = ts}) l (RoleAnnotD _ d) ds+  = addl (gp { hs_tyclds = add_role_annot (cL l d) ts }) ds++-- NB instance declarations go into TyClGroups. We throw them into the first+-- group, just as we do for the TyClD case. The renamer will go on to group+-- and order them later.+add gp@(HsGroup {hs_tyclds = ts})  l (InstD _ d) ds+  = addl (gp { hs_tyclds = add_instd (cL l d) ts }) ds++-- The rest are routine+add gp@(HsGroup {hs_derivds = ts})  l (DerivD _ d) ds+  = addl (gp { hs_derivds = cL l d : ts }) ds+add gp@(HsGroup {hs_defds  = ts})  l (DefD _ d) ds+  = addl (gp { hs_defds = cL l d : ts }) ds+add gp@(HsGroup {hs_fords  = ts}) l (ForD _ d) ds+  = addl (gp { hs_fords = cL l d : ts }) ds+add gp@(HsGroup {hs_warnds  = ts})  l (WarningD _ d) ds+  = addl (gp { hs_warnds = cL l d : ts }) ds+add gp@(HsGroup {hs_annds  = ts}) l (AnnD _ d) ds+  = addl (gp { hs_annds = cL l d : ts }) ds+add gp@(HsGroup {hs_ruleds  = ts}) l (RuleD _ d) ds+  = addl (gp { hs_ruleds = cL l d : ts }) ds+add gp l (DocD _ d) ds+  = addl (gp { hs_docs = (cL l d) : (hs_docs gp) })  ds+add (HsGroup {}) _ (SpliceD _ (XSpliceDecl _)) _ = panic "RnSource.add"+add (HsGroup {}) _ (XHsDecl _)                 _ = panic "RnSource.add"+add (XHsGroup _) _ _                           _ = panic "RnSource.add"++add_tycld :: LTyClDecl (GhcPass p) -> [TyClGroup (GhcPass p)]+          -> [TyClGroup (GhcPass p)]+add_tycld d []       = [TyClGroup { group_ext    = noExt+                                  , group_tyclds = [d]+                                  , group_roles  = []+                                  , group_instds = []+                                  }+                       ]+add_tycld d (ds@(TyClGroup { group_tyclds = tyclds }):dss)+  = ds { group_tyclds = d : tyclds } : dss+add_tycld _ (XTyClGroup _: _) = panic "add_tycld"++add_instd :: LInstDecl (GhcPass p) -> [TyClGroup (GhcPass p)]+          -> [TyClGroup (GhcPass p)]+add_instd d []       = [TyClGroup { group_ext    = noExt+                                  , group_tyclds = []+                                  , group_roles  = []+                                  , group_instds = [d]+                                  }+                       ]+add_instd d (ds@(TyClGroup { group_instds = instds }):dss)+  = ds { group_instds = d : instds } : dss+add_instd _ (XTyClGroup _: _) = panic "add_instd"++add_role_annot :: LRoleAnnotDecl (GhcPass p) -> [TyClGroup (GhcPass p)]+               -> [TyClGroup (GhcPass p)]+add_role_annot d [] = [TyClGroup { group_ext    = noExt+                                 , group_tyclds = []+                                 , group_roles  = [d]+                                 , group_instds = []+                                 }+                      ]+add_role_annot d (tycls@(TyClGroup { group_roles = roles }) : rest)+  = tycls { group_roles = d : roles } : rest+add_role_annot _ (XTyClGroup _: _) = panic "add_role_annot"++add_bind :: LHsBind a -> HsValBinds a -> HsValBinds a+add_bind b (ValBinds x bs sigs) = ValBinds x (bs `snocBag` b) sigs+add_bind _ (XValBindsLR {})     = panic "RdrHsSyn:add_bind"++add_sig :: LSig (GhcPass a) -> HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)+add_sig s (ValBinds x bs sigs) = ValBinds x bs (s:sigs)+add_sig _ (XValBindsLR {})     = panic "RdrHsSyn:add_sig"
+ compiler/rename/RnSplice.hs view
@@ -0,0 +1,904 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module RnSplice (+        rnTopSpliceDecls,+        rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,+        rnBracket,+        checkThLocalName+        , traceSplice, SpliceInfo(..)+  ) where++#include "HsVersions.h"++import GhcPrelude++import Name+import NameSet+import HsSyn+import RdrName+import TcRnMonad++import RnEnv+import RnUtils          ( HsDocContext(..), newLocalBndrRn )+import RnUnbound        ( isUnboundName )+import RnSource         ( rnSrcDecls, findSplice )+import RnPat            ( rnPat )+import BasicTypes       ( TopLevelFlag, isTopLevel, SourceText(..) )+import Outputable+import Module+import SrcLoc+import RnTypes          ( rnLHsType )++import Control.Monad    ( unless, when )++import {-# SOURCE #-} RnExpr   ( rnLExpr )++import TcEnv            ( checkWellStaged )+import THNames          ( liftName )++import DynFlags+import FastString+import ErrUtils         ( dumpIfSet_dyn_printer )+import TcEnv            ( tcMetaTy )+import Hooks+import THNames          ( quoteExpName, quotePatName, quoteDecName, quoteTypeName+                        , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, )++import {-# SOURCE #-} TcExpr   ( tcPolyExpr )+import {-# SOURCE #-} TcSplice+    ( runMetaD+    , runMetaE+    , runMetaP+    , runMetaT+    , tcTopSpliceExpr+    )++import TcHsSyn++import GHCi.RemoteTypes ( ForeignRef )+import qualified Language.Haskell.TH as TH (Q)++import qualified GHC.LanguageExtensions as LangExt++{-+************************************************************************+*                                                                      *+        Template Haskell brackets+*                                                                      *+************************************************************************+-}++rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars)+rnBracket e br_body+  = addErrCtxt (quotationCtxtDoc br_body) $+    do { -- Check that -XTemplateHaskellQuotes is enabled and available+         thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes+       ; unless thQuotesEnabled $+           failWith ( vcat+                      [ text "Syntax error on" <+> ppr e+                      , text ("Perhaps you intended to use TemplateHaskell"+                              ++ " or TemplateHaskellQuotes") ] )++         -- Check for nested brackets+       ; cur_stage <- getStage+       ; case cur_stage of+           { Splice Typed   -> checkTc (isTypedBracket br_body)+                                       illegalUntypedBracket+           ; Splice Untyped -> checkTc (not (isTypedBracket br_body))+                                       illegalTypedBracket+           ; RunSplice _    ->+               -- See Note [RunSplice ThLevel] in "TcRnTypes".+               pprPanic "rnBracket: Renaming bracket when running a splice"+                        (ppr e)+           ; Comp           -> return ()+           ; Brack {}       -> failWithTc illegalBracket+           }++         -- Brackets are desugared to code that mentions the TH package+       ; recordThUse++       ; case isTypedBracket br_body of+            True  -> do { traceRn "Renaming typed TH bracket" empty+                        ; (body', fvs_e) <-+                          setStage (Brack cur_stage RnPendingTyped) $+                                   rn_bracket cur_stage br_body+                        ; return (HsBracket noExt body', fvs_e) }++            False -> do { traceRn "Renaming untyped TH bracket" empty+                        ; ps_var <- newMutVar []+                        ; (body', fvs_e) <-+                          setStage (Brack cur_stage (RnPendingUntyped ps_var)) $+                                   rn_bracket cur_stage br_body+                        ; pendings <- readMutVar ps_var+                        ; return (HsRnBracketOut noExt body' pendings, fvs_e) }+       }++rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)+rn_bracket outer_stage br@(VarBr x flg rdr_name)+  = do { name <- lookupOccRn rdr_name+       ; this_mod <- getModule++       ; when (flg && nameIsLocalOrFrom this_mod name) $+             -- Type variables can be quoted in TH. See #5721.+                 do { mb_bind_lvl <- lookupLocalOccThLvl_maybe name+                    ; case mb_bind_lvl of+                        { Nothing -> return ()      -- Can happen for data constructors,+                                                    -- but nothing needs to be done for them++                        ; Just (top_lvl, bind_lvl)  -- See Note [Quoting names]+                             | isTopLevel top_lvl+                             -> when (isExternalName name) (keepAlive name)+                             | otherwise+                             -> do { traceRn "rn_bracket VarBr"+                                      (ppr name <+> ppr bind_lvl+                                                <+> ppr outer_stage)+                                   ; checkTc (thLevel outer_stage + 1 == bind_lvl)+                                             (quotedNameStageErr br) }+                        }+                    }+       ; return (VarBr x flg name, unitFV name) }++rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e+                            ; return (ExpBr x e', fvs) }++rn_bracket _ (PatBr x p)+  = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs)++rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t+                              ; return (TypBr x t', fvs) }++rn_bracket _ (DecBrL x decls)+  = do { group <- groupDecls decls+       ; gbl_env  <- getGblEnv+       ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }+                          -- The emptyDUs is so that we just collect uses for this+                          -- group alone in the call to rnSrcDecls below+       ; (tcg_env, group') <- setGblEnv new_gbl_env $+                              rnSrcDecls group++              -- Discard the tcg_env; it contains only extra info about fixity+        ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$+                   ppr (duUses (tcg_dus tcg_env)))+        ; return (DecBrG x group', duUses (tcg_dus tcg_env)) }+  where+    groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs)+    groupDecls decls+      = do { (group, mb_splice) <- findSplice decls+           ; case mb_splice of+           { Nothing -> return group+           ; Just (splice, rest) ->+               do { group' <- groupDecls rest+                  ; let group'' = appendGroups group group'+                  ; return group'' { hs_splcds = noLoc splice : hs_splcds group' }+                  }+           }}++rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG"++rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e+                               ; return (TExpBr x e', fvs) }++rn_bracket _ (XBracket {}) = panic "rn_bracket: unexpected XBracket"++quotationCtxtDoc :: HsBracket GhcPs -> SDoc+quotationCtxtDoc br_body+  = hang (text "In the Template Haskell quotation")+         2 (ppr br_body)++illegalBracket :: SDoc+illegalBracket =+    text "Template Haskell brackets cannot be nested" <+>+    text "(without intervening splices)"++illegalTypedBracket :: SDoc+illegalTypedBracket =+    text "Typed brackets may only appear in typed splices."++illegalUntypedBracket :: SDoc+illegalUntypedBracket =+    text "Untyped brackets may only appear in untyped splices."++quotedNameStageErr :: HsBracket GhcPs -> SDoc+quotedNameStageErr br+  = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br+        , text "must be used at the same stage at which it is bound" ]+++{-+*********************************************************+*                                                      *+                Splices+*                                                      *+*********************************************************++Note [Free variables of typed splices]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider renaming this:+        f = ...+        h = ...$(thing "f")...++where the splice is a *typed* splice.  The splice can expand into+literally anything, so when we do dependency analysis we must assume+that it might mention 'f'.  So we simply treat all locally-defined+names as mentioned by any splice.  This is terribly brutal, but I+don't see what else to do.  For example, it'll mean that every+locally-defined thing will appear to be used, so no unused-binding+warnings.  But if we miss the dependency, then we might typecheck 'h'+before 'f', and that will crash the type checker because 'f' isn't in+scope.++Currently, I'm not treating a splice as also mentioning every import,+which is a bit inconsistent -- but there are a lot of them.  We might+thereby get some bogus unused-import warnings, but we won't crash the+type checker.  Not very satisfactory really.++Note [Renamer errors]+~~~~~~~~~~~~~~~~~~~~~+It's important to wrap renamer calls in checkNoErrs, because the+renamer does not fail for out of scope variables etc. Instead it+returns a bogus term/type, so that it can report more than one error.+We don't want the type checker to see these bogus unbound variables.+-}++rnSpliceGen :: (HsSplice GhcRn -> RnM (a, FreeVars))+                                            -- Outside brackets, run splice+            -> (HsSplice GhcRn -> (PendingRnSplice, a))+                                            -- Inside brackets, make it pending+            -> HsSplice GhcPs+            -> RnM (a, FreeVars)+rnSpliceGen run_splice pend_splice splice+  = addErrCtxt (spliceCtxt splice) $ do+    { stage <- getStage+    ; case stage of+        Brack pop_stage RnPendingTyped+          -> do { checkTc is_typed_splice illegalUntypedSplice+                ; (splice', fvs) <- setStage pop_stage $+                                    rnSplice splice+                ; let (_pending_splice, result) = pend_splice splice'+                ; return (result, fvs) }++        Brack pop_stage (RnPendingUntyped ps_var)+          -> do { checkTc (not is_typed_splice) illegalTypedSplice+                ; (splice', fvs) <- setStage pop_stage $+                                    rnSplice splice+                ; let (pending_splice, result) = pend_splice splice'+                ; ps <- readMutVar ps_var+                ; writeMutVar ps_var (pending_splice : ps)+                ; return (result, fvs) }++        _ ->  do { (splice', fvs1) <- checkNoErrs $+                                      setStage (Splice splice_type) $+                                      rnSplice splice+                   -- checkNoErrs: don't attempt to run the splice if+                   -- renaming it failed; otherwise we get a cascade of+                   -- errors from e.g. unbound variables+                 ; (result, fvs2) <- run_splice splice'+                 ; return (result, fvs1 `plusFV` fvs2) } }+   where+     is_typed_splice = isTypedSplice splice+     splice_type = if is_typed_splice+                   then Typed+                   else Untyped++------------------++-- | Returns the result of running a splice and the modFinalizers collected+-- during the execution.+--+-- See Note [Delaying modFinalizers in untyped splices].+runRnSplice :: UntypedSpliceFlavour+            -> (LHsExpr GhcTc -> TcRn res)+            -> (res -> SDoc)    -- How to pretty-print res+                                -- Usually just ppr, but not for [Decl]+            -> HsSplice GhcRn   -- Always untyped+            -> TcRn (res, [ForeignRef (TH.Q ())])+runRnSplice flavour run_meta ppr_res splice+  = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice)++       ; let the_expr = case splice' of+                HsUntypedSplice _ _ _ e   ->  e+                HsQuasiQuote _ _ q qs str -> mkQuasiQuoteExpr flavour q qs str+                HsTypedSplice {}          -> pprPanic "runRnSplice" (ppr splice)+                HsSpliced {}              -> pprPanic "runRnSplice" (ppr splice)+                HsSplicedT {}             -> pprPanic "runRnSplice" (ppr splice)+                XSplice {}                -> pprPanic "runRnSplice" (ppr splice)++             -- Typecheck the expression+       ; meta_exp_ty   <- tcMetaTy meta_ty_name+       ; zonked_q_expr <- zonkTopLExpr =<<+                            tcTopSpliceExpr Untyped+                              (tcPolyExpr the_expr meta_exp_ty)++             -- Run the expression+       ; mod_finalizers_ref <- newTcRef []+       ; result <- setStage (RunSplice mod_finalizers_ref) $+                     run_meta zonked_q_expr+       ; mod_finalizers <- readTcRef mod_finalizers_ref+       ; traceSplice (SpliceInfo { spliceDescription = what+                                 , spliceIsDecl      = is_decl+                                 , spliceSource      = Just the_expr+                                 , spliceGenerated   = ppr_res result })++       ; return (result, mod_finalizers) }++  where+    meta_ty_name = case flavour of+                       UntypedExpSplice  -> expQTyConName+                       UntypedPatSplice  -> patQTyConName+                       UntypedTypeSplice -> typeQTyConName+                       UntypedDeclSplice -> decsQTyConName+    what = case flavour of+                  UntypedExpSplice  -> "expression"+                  UntypedPatSplice  -> "pattern"+                  UntypedTypeSplice -> "type"+                  UntypedDeclSplice -> "declarations"+    is_decl = case flavour of+                 UntypedDeclSplice -> True+                 _                 -> False++------------------+makePending :: UntypedSpliceFlavour+            -> HsSplice GhcRn+            -> PendingRnSplice+makePending flavour (HsUntypedSplice _ _ n e)+  = PendingRnSplice flavour n e+makePending flavour (HsQuasiQuote _ n quoter q_span quote)+  = PendingRnSplice flavour n (mkQuasiQuoteExpr flavour quoter q_span quote)+makePending _ splice@(HsTypedSplice {})+  = pprPanic "makePending" (ppr splice)+makePending _ splice@(HsSpliced {})+  = pprPanic "makePending" (ppr splice)+makePending _ splice@(HsSplicedT {})+  = pprPanic "makePending" (ppr splice)+makePending _ splice@(XSplice {})+  = pprPanic "makePending" (ppr splice)++------------------+mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString+                 -> LHsExpr GhcRn+-- Return the expression (quoter "...quote...")+-- which is what we must run in a quasi-quote+mkQuasiQuoteExpr flavour quoter q_span quote+  = cL q_span $ HsApp noExt (cL q_span+              $ HsApp noExt (cL q_span (HsVar noExt (cL q_span quote_selector)))+                            quoterExpr)+                     quoteExpr+  where+    quoterExpr = cL q_span $! HsVar noExt $! (cL q_span quoter)+    quoteExpr  = cL q_span $! HsLit noExt $! HsString NoSourceText quote+    quote_selector = case flavour of+                       UntypedExpSplice  -> quoteExpName+                       UntypedPatSplice  -> quotePatName+                       UntypedTypeSplice -> quoteTypeName+                       UntypedDeclSplice -> quoteDecName++---------------------+rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars)+-- Not exported...used for all+rnSplice (HsTypedSplice x hasParen splice_name expr)+  = do  { checkTH expr "Template Haskell typed splice"+        ; loc  <- getSrcSpanM+        ; n' <- newLocalBndrRn (cL loc splice_name)+        ; (expr', fvs) <- rnLExpr expr+        ; return (HsTypedSplice x hasParen n' expr', fvs) }++rnSplice (HsUntypedSplice x hasParen splice_name expr)+  = do  { checkTH expr "Template Haskell untyped splice"+        ; loc  <- getSrcSpanM+        ; n' <- newLocalBndrRn (cL loc splice_name)+        ; (expr', fvs) <- rnLExpr expr+        ; return (HsUntypedSplice x hasParen n' expr', fvs) }++rnSplice (HsQuasiQuote x splice_name quoter q_loc quote)+  = do  { checkTH quoter "Template Haskell quasi-quote"+        ; loc  <- getSrcSpanM+        ; splice_name' <- newLocalBndrRn (cL loc splice_name)++          -- Rename the quoter; akin to the HsVar case of rnExpr+        ; quoter' <- lookupOccRn quoter+        ; this_mod <- getModule+        ; when (nameIsLocalOrFrom this_mod quoter') $+          checkThLocalName quoter'++        ; return (HsQuasiQuote x splice_name' quoter' q_loc quote+                                                             , unitFV quoter') }++rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice)+rnSplice splice@(HsSplicedT {}) = pprPanic "rnSplice" (ppr splice)+rnSplice splice@(XSplice {})   = pprPanic "rnSplice" (ppr splice)++---------------------+rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars)+rnSpliceExpr splice+  = rnSpliceGen run_expr_splice pend_expr_splice splice+  where+    pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn)+    pend_expr_splice rn_splice+        = (makePending UntypedExpSplice rn_splice, HsSpliceE noExt rn_splice)++    run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars)+    run_expr_splice rn_splice+      | isTypedSplice rn_splice   -- Run it later, in the type checker+      = do {  -- Ugh!  See Note [Splices] above+             traceRn "rnSpliceExpr: typed expression splice" empty+           ; lcl_rdr <- getLocalRdrEnv+           ; gbl_rdr <- getGlobalRdrEnv+           ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr+                                                     , isLocalGRE gre]+                 lcl_names = mkNameSet (localRdrEnvElts lcl_rdr)++           ; return (HsSpliceE noExt rn_splice, lcl_names `plusFV` gbl_names) }++      | otherwise  -- Run it here, see Note [Running splices in the Renamer]+      = do { traceRn "rnSpliceExpr: untyped expression splice" empty+           ; (rn_expr, mod_finalizers) <-+                runRnSplice UntypedExpSplice runMetaE ppr rn_splice+           ; (lexpr3, fvs) <- checkNoErrs (rnLExpr rn_expr)+             -- See Note [Delaying modFinalizers in untyped splices].+           ; return ( HsPar noExt $ HsSpliceE noExt+                            . HsSpliced noExt (ThModFinalizers mod_finalizers)+                            . HsSplicedExpr <$>+                            lexpr3+                    , fvs)+           }++{- Note [Running splices in the Renamer]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Splices used to be run in the typechecker, which led to (#4364). Since the+renamer must decide which expressions depend on which others, and it cannot+reliably do this for arbitrary splices, we used to conservatively say that+splices depend on all other expressions in scope. Unfortunately, this led to+the problem of cyclic type declarations seen in (#4364). Instead, by+running splices in the renamer, we side-step the problem of determining+dependencies: by the time the dependency analysis happens, any splices have+already been run, and expression dependencies can be determined as usual.++However, see (#9813), for an example where we would like to run splices+*after* performing dependency analysis (that is, after renaming). It would be+desirable to typecheck "non-splicy" expressions (those expressions that do not+contain splices directly or via dependence on an expression that does) before+"splicy" expressions, such that types/expressions within the same declaration+group would be available to `reify` calls, for example consider the following:++> module M where+>   data D = C+>   f = 1+>   g = $(mapM reify ['f, 'D, ''C] ...)++Compilation of this example fails since D/C/f are not in the type environment+and thus cannot be reified as they have not been typechecked by the time the+splice is renamed and thus run.++These requirements are at odds: we do not want to run splices in the renamer as+we wish to first determine dependencies and typecheck certain expressions,+making them available to reify, but cannot accurately determine dependencies+without running splices in the renamer!++Indeed, the conclusion of (#9813) was that it is not worth the complexity+to try and+ a) implement and maintain the code for renaming/typechecking non-splicy+    expressions before splicy expressions,+ b) explain to TH users which expressions are/not available to reify at any+    given point.++-}++{- Note [Delaying modFinalizers in untyped splices]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When splices run in the renamer, 'reify' does not have access to the local+type environment (#11832, [1]).++For instance, in++> let x = e in $(reify (mkName "x") >>= runIO . print >> [| return () |])++'reify' cannot find @x@, because the local type environment is not yet+populated. To address this, we allow 'reify' execution to be deferred with+'addModFinalizer'.++> let x = e in $(do addModFinalizer (reify (mkName "x") >>= runIO . print)+                    [| return () |]+                )++The finalizer is run with the local type environment when type checking is+complete.++Since the local type environment is not available in the renamer, we annotate+the tree at the splice point [2] with @HsSpliceE (HsSpliced finalizers e)@ where+@e@ is the result of splicing and @finalizers@ are the finalizers that have been+collected during evaluation of the splice [3]. In our example,++> HsLet+>   (x = e)+>   (HsSpliceE $ HsSpliced [reify (mkName "x") >>= runIO . print]+>                          (HsSplicedExpr $ return ())+>   )++When the typechecker finds the annotation, it inserts the finalizers in the+global environment and exposes the current local environment to them [4, 5, 6].++> addModFinalizersWithLclEnv [reify (mkName "x") >>= runIO . print]++References:++[1] https://gitlab.haskell.org/ghc/ghc/wikis/template-haskell/reify+[2] 'rnSpliceExpr'+[3] 'TcSplice.qAddModFinalizer'+[4] 'TcExpr.tcExpr' ('HsSpliceE' ('HsSpliced' ...))+[5] 'TcHsType.tc_hs_type' ('HsSpliceTy' ('HsSpliced' ...))+[6] 'TcPat.tc_pat' ('SplicePat' ('HsSpliced' ...))++-}++----------------------+rnSpliceType :: HsSplice GhcPs -> RnM (HsType GhcRn, FreeVars)+rnSpliceType splice+  = rnSpliceGen run_type_splice pend_type_splice splice+  where+    pend_type_splice rn_splice+       = ( makePending UntypedTypeSplice rn_splice+         , HsSpliceTy noExt rn_splice)++    run_type_splice rn_splice+      = do { traceRn "rnSpliceType: untyped type splice" empty+           ; (hs_ty2, mod_finalizers) <-+                runRnSplice UntypedTypeSplice runMetaT ppr rn_splice+           ; (hs_ty3, fvs) <- do { let doc = SpliceTypeCtx hs_ty2+                                 ; checkNoErrs $ rnLHsType doc hs_ty2 }+                                    -- checkNoErrs: see Note [Renamer errors]+             -- See Note [Delaying modFinalizers in untyped splices].+           ; return ( HsParTy noExt $ HsSpliceTy noExt+                              . HsSpliced noExt (ThModFinalizers mod_finalizers)+                              . HsSplicedTy <$>+                              hs_ty3+                    , fvs+                    ) }+              -- Wrap the result of the splice in parens so that we don't+              -- lose the outermost location set by runQuasiQuote (#7918)++{- Note [Partial Type Splices]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Partial Type Signatures are partially supported in TH type splices: only+anonymous wild cards are allowed.++  -- ToDo: SLPJ says: I don't understand all this++Normally, named wild cards are collected before renaming a (partial) type+signature. However, TH type splices are run during renaming, i.e. after the+initial traversal, leading to out of scope errors for named wild cards. We+can't just extend the initial traversal to collect the named wild cards in TH+type splices, as we'd need to expand them, which is supposed to happen only+once, during renaming.++Similarly, the extra-constraints wild card is handled right before renaming+too, and is therefore also not supported in a TH type splice. Another reason+to forbid extra-constraints wild cards in TH type splices is that a single+signature can contain many TH type splices, whereas it mustn't contain more+than one extra-constraints wild card. Enforcing would this be hard the way+things are currently organised.++Anonymous wild cards pose no problem, because they start out without names and+are given names during renaming. These names are collected right after+renaming. The names generated for anonymous wild cards in TH type splices will+thus be collected as well.++For more details about renaming wild cards, see RnTypes.rnHsSigWcType++Note that partial type signatures are fully supported in TH declaration+splices, e.g.:++     [d| foo :: _ => _+         foo x y = x == y |]++This is because in this case, the partial type signature can be treated as a+whole signature, instead of as an arbitrary type.++-}+++----------------------+-- | Rename a splice pattern. See Note [rnSplicePat]+rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn)+                                       , FreeVars)+rnSplicePat splice+  = rnSpliceGen run_pat_splice pend_pat_splice splice+  where+    pend_pat_splice :: HsSplice GhcRn ->+                       (PendingRnSplice, Either b (Pat GhcRn))+    pend_pat_splice rn_splice+      = (makePending UntypedPatSplice rn_splice+        , Right (SplicePat noExt rn_splice))++    run_pat_splice :: HsSplice GhcRn ->+                      RnM (Either (Pat GhcPs) (Pat GhcRn), FreeVars)+    run_pat_splice rn_splice+      = do { traceRn "rnSplicePat: untyped pattern splice" empty+           ; (pat, mod_finalizers) <-+                runRnSplice UntypedPatSplice runMetaP ppr rn_splice+             -- See Note [Delaying modFinalizers in untyped splices].+           ; return ( Left $ ParPat noExt $ ((SplicePat noExt)+                              . HsSpliced noExt (ThModFinalizers mod_finalizers)+                              . HsSplicedPat)  `onHasSrcSpan`+                              pat+                    , emptyFVs+                    ) }+              -- Wrap the result of the quasi-quoter in parens so that we don't+              -- lose the outermost location set by runQuasiQuote (#7918)++----------------------+rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)+rnSpliceDecl (SpliceDecl _ (dL->L loc splice) flg)+  = rnSpliceGen run_decl_splice pend_decl_splice splice+  where+    pend_decl_splice rn_splice+       = ( makePending UntypedDeclSplice rn_splice+         , SpliceDecl noExt (cL loc rn_splice) flg)++    run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice)+rnSpliceDecl (XSpliceDecl _) = panic "rnSpliceDecl"++rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)+-- Declaration splice at the very top level of the module+rnTopSpliceDecls splice+   = do  { (rn_splice, fvs) <- checkNoErrs $+                               setStage (Splice Untyped) $+                               rnSplice splice+           -- As always, be sure to checkNoErrs above lest we end up with+           -- holes making it to typechecking, hence #12584.+           --+           -- Note that we cannot call checkNoErrs for the whole duration+           -- of rnTopSpliceDecls. The reason is that checkNoErrs changes+           -- the local environment to temporarily contain a new+           -- reference to store errors, and add_mod_finalizers would+           -- cause this reference to be stored after checkNoErrs finishes.+           -- This is checked by test TH_finalizer.+         ; traceRn "rnTopSpliceDecls: untyped declaration splice" empty+         ; (decls, mod_finalizers) <- checkNoErrs $+               runRnSplice UntypedDeclSplice runMetaD ppr_decls rn_splice+         ; add_mod_finalizers_now mod_finalizers+         ; return (decls,fvs) }+   where+     ppr_decls :: [LHsDecl GhcPs] -> SDoc+     ppr_decls ds = vcat (map ppr ds)++     -- Adds finalizers to the global environment instead of delaying them+     -- to the type checker.+     --+     -- Declaration splices do not have an interesting local environment so+     -- there is no point in delaying them.+     --+     -- See Note [Delaying modFinalizers in untyped splices].+     add_mod_finalizers_now :: [ForeignRef (TH.Q ())] -> TcRn ()+     add_mod_finalizers_now []             = return ()+     add_mod_finalizers_now mod_finalizers = do+       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv+       env <- getLclEnv+       updTcRef th_modfinalizers_var $ \fins ->+         (env, ThModFinalizers mod_finalizers) : fins+++{-+Note [rnSplicePat]+~~~~~~~~~~~~~~~~~~+Renaming a pattern splice is a bit tricky, because we need the variables+bound in the pattern to be in scope in the RHS of the pattern. This scope+management is effectively done by using continuation-passing style in+RnPat, through the CpsRn monad. We don't wish to be in that monad here+(it would create import cycles and generally conflict with renaming other+splices), so we really want to return a (Pat RdrName) -- the result of+running the splice -- which can then be further renamed in RnPat, in+the CpsRn monad.++The problem is that if we're renaming a splice within a bracket, we+*don't* want to run the splice now. We really do just want to rename+it to an HsSplice Name. Of course, then we can't know what variables+are bound within the splice. So we accept any unbound variables and+rename them again when the bracket is spliced in.  If a variable is brought+into scope by a pattern splice all is fine.  If it is not then an error is+reported.++In any case, when we're done in rnSplicePat, we'll either have a+Pat RdrName (the result of running a top-level splice) or a Pat Name+(the renamed nested splice). Thus, the awkward return type of+rnSplicePat.+-}++spliceCtxt :: HsSplice GhcPs -> SDoc+spliceCtxt splice+  = hang (text "In the" <+> what) 2 (ppr splice)+  where+    what = case splice of+             HsUntypedSplice {} -> text "untyped splice:"+             HsTypedSplice   {} -> text "typed splice:"+             HsQuasiQuote    {} -> text "quasi-quotation:"+             HsSpliced       {} -> text "spliced expression:"+             HsSplicedT      {} -> text "spliced expression:"+             XSplice         {} -> text "spliced expression:"++-- | The splice data to be logged+data SpliceInfo+  = SpliceInfo+    { spliceDescription  :: String+    , spliceSource       :: Maybe (LHsExpr GhcRn) -- Nothing <=> top-level decls+                                                  --        added by addTopDecls+    , spliceIsDecl       :: Bool    -- True <=> put the generate code in a file+                                    --          when -dth-dec-file is on+    , spliceGenerated    :: SDoc+    }+        -- Note that 'spliceSource' is *renamed* but not *typechecked*+        -- Reason (a) less typechecking crap+        --        (b) data constructors after type checking have been+        --            changed to their *wrappers*, and that makes them+        --            print always fully qualified++-- | outputs splice information for 2 flags which have different output formats:+-- `-ddump-splices` and `-dth-dec-file`+traceSplice :: SpliceInfo -> TcM ()+traceSplice (SpliceInfo { spliceDescription = sd, spliceSource = mb_src+                        , spliceGenerated = gen, spliceIsDecl = is_decl })+  = do { loc <- case mb_src of+                   Nothing           -> getSrcSpanM+                   Just (dL->L loc _) -> return loc+       ; traceOptTcRn Opt_D_dump_splices (spliceDebugDoc loc)++       ; when is_decl $  -- Raw material for -dth-dec-file+         do { dflags <- getDynFlags+            ; liftIO $ dumpIfSet_dyn_printer alwaysQualify dflags Opt_D_th_dec_file+                                             (spliceCodeDoc loc) } }+  where+    -- `-ddump-splices`+    spliceDebugDoc :: SrcSpan -> SDoc+    spliceDebugDoc loc+      = let code = case mb_src of+                     Nothing -> ending+                     Just e  -> nest 2 (ppr e) : ending+            ending = [ text "======>", nest 2 gen ]+        in  hang (ppr loc <> colon <+> text "Splicing" <+> text sd)+               2 (sep code)++    -- `-dth-dec-file`+    spliceCodeDoc :: SrcSpan -> SDoc+    spliceCodeDoc loc+      = vcat [ text "--" <+> ppr loc <> colon <+> text "Splicing" <+> text sd+             , gen ]++illegalTypedSplice :: SDoc+illegalTypedSplice = text "Typed splices may not appear in untyped brackets"++illegalUntypedSplice :: SDoc+illegalUntypedSplice = text "Untyped splices may not appear in typed brackets"++checkThLocalName :: Name -> RnM ()+checkThLocalName name+  | isUnboundName name   -- Do not report two errors for+  = return ()            --   $(not_in_scope args)++  | otherwise+  = do  { traceRn "checkThLocalName" (ppr name)+        ; mb_local_use <- getStageAndBindLevel name+        ; case mb_local_use of {+             Nothing -> return () ;  -- Not a locally-bound thing+             Just (top_lvl, bind_lvl, use_stage) ->+    do  { let use_lvl = thLevel use_stage+        ; checkWellStaged (quotes (ppr name)) bind_lvl use_lvl+        ; traceRn "checkThLocalName" (ppr name <+> ppr bind_lvl+                                               <+> ppr use_stage+                                               <+> ppr use_lvl)+        ; checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name } } }++--------------------------------------+checkCrossStageLifting :: TopLevelFlag -> ThLevel -> ThStage -> ThLevel+                       -> Name -> TcM ()+-- We are inside brackets, and (use_lvl > bind_lvl)+-- Now we must check whether there's a cross-stage lift to do+-- Examples   \x -> [| x |]+--            [| map |]+--+-- This code is similar to checkCrossStageLifting in TcExpr, but+-- this is only run on *untyped* brackets.++checkCrossStageLifting top_lvl bind_lvl use_stage use_lvl name+  | Brack _ (RnPendingUntyped ps_var) <- use_stage   -- Only for untyped brackets+  , use_lvl > bind_lvl                               -- Cross-stage condition+  = check_cross_stage_lifting top_lvl name ps_var+  | otherwise+  = return ()++check_cross_stage_lifting :: TopLevelFlag -> Name -> TcRef [PendingRnSplice] -> TcM ()+check_cross_stage_lifting top_lvl name ps_var+  | isTopLevel top_lvl+        -- Top-level identifiers in this module,+        -- (which have External Names)+        -- are just like the imported case:+        -- no need for the 'lifting' treatment+        -- E.g.  this is fine:+        --   f x = x+        --   g y = [| f 3 |]+  = when (isExternalName name) (keepAlive name)+    -- See Note [Keeping things alive for Template Haskell]++  | otherwise+  =     -- Nested identifiers, such as 'x' in+        -- E.g. \x -> [| h x |]+        -- We must behave as if the reference to x was+        --      h $(lift x)+        -- We use 'x' itself as the SplicePointName, used by+        -- the desugarer to stitch it all back together.+        -- If 'x' occurs many times we may get many identical+        -- bindings of the same SplicePointName, but that doesn't+        -- matter, although it's a mite untidy.+    do  { traceRn "checkCrossStageLifting" (ppr name)++          -- Construct the (lift x) expression+        ; let lift_expr   = nlHsApp (nlHsVar liftName) (nlHsVar name)+              pend_splice = PendingRnSplice UntypedExpSplice name lift_expr++          -- Update the pending splices+        ; ps <- readMutVar ps_var+        ; writeMutVar ps_var (pend_splice : ps) }++{-+Note [Keeping things alive for Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f x = x+1+  g y = [| f 3 |]++Here 'f' is referred to from inside the bracket, which turns into data+and mentions only f's *name*, not 'f' itself. So we need some other+way to keep 'f' alive, lest it get dropped as dead code.  That's what+keepAlive does. It puts it in the keep-alive set, which subsequently+ensures that 'f' stays as a top level binding.++This must be done by the renamer, not the type checker (as of old),+because the type checker doesn't typecheck the body of untyped+brackets (#8540).++A thing can have a bind_lvl of outerLevel, but have an internal name:+   foo = [d| op = 3+             bop = op + 1 |]+Here the bind_lvl of 'op' is (bogusly) outerLevel, even though it is+bound inside a bracket.  That is because we don't even even record+binding levels for top-level things; the binding levels are in the+LocalRdrEnv.++So the occurrence of 'op' in the rhs of 'bop' looks a bit like a+cross-stage thing, but it isn't really.  And in fact we never need+to do anything here for top-level bound things, so all is fine, if+a bit hacky.++For these chaps (which have Internal Names) we don't want to put+them in the keep-alive set.++Note [Quoting names]+~~~~~~~~~~~~~~~~~~~~+A quoted name 'n is a bit like a quoted expression [| n |], except that we+have no cross-stage lifting (c.f. TcExpr.thBrackId).  So, after incrementing+the use-level to account for the brackets, the cases are:++        bind > use                      Error+        bind = use+1                    OK+        bind < use+                Imported things         OK+                Top-level things        OK+                Non-top-level           Error++where 'use' is the binding level of the 'n quote. (So inside the implied+bracket the level would be use+1.)++Examples:++  f 'map        -- OK; also for top-level defns of this module++  \x. f 'x      -- Not ok (bind = 1, use = 1)+                -- (whereas \x. f [| x |] might have been ok, by+                --                               cross-stage lifting++  \y. [| \x. $(f 'y) |] -- Not ok (bind =1, use = 1)++  [| \x. $(f 'x) |]     -- OK (bind = 2, use = 1)+-}
+ compiler/rename/RnSplice.hs-boot view
@@ -0,0 +1,14 @@+module RnSplice where++import GhcPrelude+import HsSyn+import TcRnMonad+import NameSet+++rnSpliceType :: HsSplice GhcPs   -> RnM (HsType GhcRn, FreeVars)+rnSplicePat  :: HsSplice GhcPs   -> RnM ( Either (Pat GhcPs) (Pat GhcRn)+                                          , FreeVars )+rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars)++rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars)
+ compiler/rename/RnTypes.hs view
@@ -0,0 +1,1779 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[RnSource]{Main pass of renamer}+-}++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}++module RnTypes (+        -- Type related stuff+        rnHsType, rnLHsType, rnLHsTypes, rnContext,+        rnHsKind, rnLHsKind, rnLHsTypeArgs,+        rnHsSigType, rnHsWcType,+        HsSigWcTypeScoping(..), rnHsSigWcType, rnHsSigWcTypeScoped,+        newTyVarNameRn,+        rnConDeclFields,+        rnLTyVar,++        -- Precence related stuff+        mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,+        checkPrecMatch, checkSectionPrec,++        -- Binding related stuff+        bindLHsTyVarBndr, bindLHsTyVarBndrs, rnImplicitBndrs,+        bindSigTyVarsFV, bindHsQTyVars, bindLRdrNames,+        extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,+        extractHsTysRdrTyVarsDups,+        extractRdrKindSigVars, extractDataDefnKindVars,+        extractHsTvBndrs, extractHsTyArgRdrKiTyVarsDup,+        nubL, elemRdr+  ) where++import GhcPrelude++import {-# SOURCE #-} RnSplice( rnSpliceType )++import DynFlags+import HsSyn+import RnHsDoc          ( rnLHsDoc, rnMbLHsDoc )+import RnEnv+import RnUtils          ( HsDocContext(..), withHsDocContext, mapFvRn+                        , pprHsDocContext, bindLocalNamesFV, typeAppErr+                        , newLocalBndrRn, checkDupRdrNames, checkShadowedRdrNames )+import RnFixity         ( lookupFieldFixityRn, lookupFixityRn+                        , lookupTyFixityRn )+import TcRnMonad+import RdrName+import PrelNames+import TysPrim          ( funTyConName )+import Name+import SrcLoc+import NameSet+import FieldLabel++import Util+import ListSetOps       ( deleteBys )+import BasicTypes       ( compareFixity, funTyFixity, negateFixity,+                          Fixity(..), FixityDirection(..), LexicalFixity(..) )+import Outputable+import FastString+import Maybes+import qualified GHC.LanguageExtensions as LangExt++import Data.List          ( nubBy, partition, (\\) )+import Control.Monad      ( unless, when )++#include "HsVersions.h"++{-+These type renamers are in a separate module, rather than in (say) RnSource,+to break several loop.++*********************************************************+*                                                       *+           HsSigWcType (i.e with wildcards)+*                                                       *+*********************************************************+-}++data HsSigWcTypeScoping = AlwaysBind+                          -- ^ Always bind any free tyvars of the given type,+                          --   regardless of whether we have a forall at the top+                        | BindUnlessForall+                          -- ^ Unless there's forall at the top, do the same+                          --   thing as 'AlwaysBind'+                        | NeverBind+                          -- ^ Never bind any free tyvars++rnHsSigWcType :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs+              -> RnM (LHsSigWcType GhcRn, FreeVars)+rnHsSigWcType scoping doc sig_ty+  = rn_hs_sig_wc_type scoping doc sig_ty $ \sig_ty' ->+    return (sig_ty', emptyFVs)++rnHsSigWcTypeScoped :: HsSigWcTypeScoping+                       -- AlwaysBind: for pattern type sigs and rules we /do/ want+                       --             to bring those type variables into scope, even+                       --             if there's a forall at the top which usually+                       --             stops that happening+                       -- e.g  \ (x :: forall a. a-> b) -> e+                       -- Here we do bring 'b' into scope+                    -> HsDocContext -> LHsSigWcType GhcPs+                    -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))+                    -> RnM (a, FreeVars)+-- Used for+--   - Signatures on binders in a RULE+--   - Pattern type signatures+-- Wildcards are allowed+-- type signatures on binders only allowed with ScopedTypeVariables+rnHsSigWcTypeScoped scoping ctx sig_ty thing_inside+  = do { ty_sig_okay <- xoptM LangExt.ScopedTypeVariables+       ; checkErr ty_sig_okay (unexpectedTypeSigErr sig_ty)+       ; rn_hs_sig_wc_type scoping ctx sig_ty thing_inside+       }++rn_hs_sig_wc_type :: HsSigWcTypeScoping -> HsDocContext -> LHsSigWcType GhcPs+                  -> (LHsSigWcType GhcRn -> RnM (a, FreeVars))+                  -> RnM (a, FreeVars)+-- rn_hs_sig_wc_type is used for source-language type signatures+rn_hs_sig_wc_type scoping ctxt+                  (HsWC { hswc_body = HsIB { hsib_body = hs_ty }})+                  thing_inside+  = do { free_vars <- extractFilteredRdrTyVarsDups hs_ty+       ; (nwc_rdrs', tv_rdrs) <- partition_nwcs free_vars+       ; let nwc_rdrs = nubL nwc_rdrs'+             bind_free_tvs = case scoping of+                               AlwaysBind       -> True+                               BindUnlessForall -> not (isLHsForAllTy hs_ty)+                               NeverBind        -> False+       ; rnImplicitBndrs bind_free_tvs tv_rdrs $ \ vars ->+    do { (wcs, hs_ty', fvs1) <- rnWcBody ctxt nwc_rdrs hs_ty+       ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = ib_ty' }+             ib_ty'  = HsIB { hsib_ext = vars+                            , hsib_body = hs_ty' }+       ; (res, fvs2) <- thing_inside sig_ty'+       ; return (res, fvs1 `plusFV` fvs2) } }+rn_hs_sig_wc_type _ _ (HsWC _ (XHsImplicitBndrs _)) _+  = panic "rn_hs_sig_wc_type"+rn_hs_sig_wc_type _ _ (XHsWildCardBndrs _) _+  = panic "rn_hs_sig_wc_type"++rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars)+rnHsWcType ctxt (HsWC { hswc_body = hs_ty })+  = do { free_vars <- extractFilteredRdrTyVars hs_ty+       ; (nwc_rdrs, _) <- partition_nwcs free_vars+       ; (wcs, hs_ty', fvs) <- rnWcBody ctxt nwc_rdrs hs_ty+       ; let sig_ty' = HsWC { hswc_ext = wcs, hswc_body = hs_ty' }+       ; return (sig_ty', fvs) }+rnHsWcType _ (XHsWildCardBndrs _) = panic "rnHsWcType"++rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs+         -> RnM ([Name], LHsType GhcRn, FreeVars)+rnWcBody ctxt nwc_rdrs hs_ty+  = do { nwcs <- mapM newLocalBndrRn nwc_rdrs+       ; let env = RTKE { rtke_level = TypeLevel+                        , rtke_what  = RnTypeBody+                        , rtke_nwcs  = mkNameSet nwcs+                        , rtke_ctxt  = ctxt }+       ; (hs_ty', fvs) <- bindLocalNamesFV nwcs $+                          rn_lty env hs_ty+       ; return (nwcs, hs_ty', fvs) }+  where+    rn_lty env (dL->L loc hs_ty)+      = setSrcSpan loc $+        do { (hs_ty', fvs) <- rn_ty env hs_ty+           ; return (cL loc hs_ty', fvs) }++    rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)+    -- A lot of faff just to allow the extra-constraints wildcard to appear+    rn_ty env hs_ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tvs+                                , hst_body = hs_body })+      = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) Nothing tvs $ \ tvs' ->+        do { (hs_body', fvs) <- rn_lty env hs_body+           ; return (HsForAllTy { hst_fvf = fvf, hst_xforall = noExt+                                , hst_bndrs = tvs', hst_body = hs_body' }+                    , fvs) }++    rn_ty env (HsQualTy { hst_ctxt = dL->L cx hs_ctxt+                        , hst_body = hs_ty })+      | Just (hs_ctxt1, hs_ctxt_last) <- snocView hs_ctxt+      , (dL->L lx (HsWildCardTy _))  <- ignoreParens hs_ctxt_last+      = do { (hs_ctxt1', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt1+           ; setSrcSpan lx $ checkExtraConstraintWildCard env hs_ctxt1+           ; let hs_ctxt' = hs_ctxt1' ++ [cL lx (HsWildCardTy noExt)]+           ; (hs_ty', fvs2) <- rnLHsTyKi env hs_ty+           ; return (HsQualTy { hst_xqual = noExt+                              , hst_ctxt = cL cx hs_ctxt', hst_body = hs_ty' }+                    , fvs1 `plusFV` fvs2) }++      | otherwise+      = do { (hs_ctxt', fvs1) <- mapFvRn (rn_top_constraint env) hs_ctxt+           ; (hs_ty', fvs2)   <- rnLHsTyKi env hs_ty+           ; return (HsQualTy { hst_xqual = noExt+                              , hst_ctxt = cL cx hs_ctxt'+                              , hst_body = hs_ty' }+                    , fvs1 `plusFV` fvs2) }++    rn_ty env hs_ty = rnHsTyKi env hs_ty++    rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint })+++checkExtraConstraintWildCard :: RnTyKiEnv -> HsContext GhcPs -> RnM ()+-- Rename the extra-constraint spot in a type signature+--    (blah, _) => type+-- Check that extra-constraints are allowed at all, and+-- if so that it's an anonymous wildcard+checkExtraConstraintWildCard env hs_ctxt+  = checkWildCard env mb_bad+  where+    mb_bad | not (extraConstraintWildCardsAllowed env)+           = Just base_msg+             -- Currently, we do not allow wildcards in their full glory in+             -- standalone deriving declarations. We only allow a single+             -- extra-constraints wildcard à la:+             --+             --   deriving instance _ => Eq (Foo a)+             --+             -- i.e., we don't support things like+             --+             --   deriving instance (Eq a, _) => Eq (Foo a)+           | DerivDeclCtx {} <- rtke_ctxt env+           , not (null hs_ctxt)+           = Just deriv_decl_msg+           | otherwise+           = Nothing++    base_msg = text "Extra-constraint wildcard" <+> quotes pprAnonWildCard+                   <+> text "not allowed"++    deriv_decl_msg+      = hang base_msg+           2 (vcat [ text "except as the sole constraint"+                   , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ])++extraConstraintWildCardsAllowed :: RnTyKiEnv -> Bool+extraConstraintWildCardsAllowed env+  = case rtke_ctxt env of+      TypeSigCtx {}       -> True+      ExprWithTySigCtx {} -> True+      DerivDeclCtx {}     -> True+      _                   -> False++-- | Finds free type and kind variables in a type,+--     without duplicates, and+--     without variables that are already in scope in LocalRdrEnv+--   NB: this includes named wildcards, which look like perfectly+--       ordinary type variables at this point+extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVarsNoDups+extractFilteredRdrTyVars hs_ty = filterInScopeM (extractHsTyRdrTyVars hs_ty)++-- | Finds free type and kind variables in a type,+--     with duplicates, but+--     without variables that are already in scope in LocalRdrEnv+--   NB: this includes named wildcards, which look like perfectly+--       ordinary type variables at this point+extractFilteredRdrTyVarsDups :: LHsType GhcPs -> RnM FreeKiTyVarsWithDups+extractFilteredRdrTyVarsDups hs_ty = filterInScopeM (extractHsTyRdrTyVarsDups hs_ty)++-- | When the NamedWildCards extension is enabled, partition_nwcs+-- removes type variables that start with an underscore from the+-- FreeKiTyVars in the argument and returns them in a separate list.+-- When the extension is disabled, the function returns the argument+-- and empty list.  See Note [Renaming named wild cards]+partition_nwcs :: FreeKiTyVars -> RnM ([Located RdrName], FreeKiTyVars)+partition_nwcs free_vars+  = do { wildcards_enabled <- xoptM LangExt.NamedWildCards+       ; return $+           if wildcards_enabled+           then partition is_wildcard free_vars+           else ([], free_vars) }+  where+     is_wildcard :: Located RdrName -> Bool+     is_wildcard rdr = startsWithUnderscore (rdrNameOcc (unLoc rdr))++{- Note [Renaming named wild cards]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Identifiers starting with an underscore are always parsed as type variables.+It is only here in the renamer that we give the special treatment.+See Note [The wildcard story for types] in HsTypes.++It's easy!  When we collect the implicitly bound type variables, ready+to bring them into scope, and NamedWildCards is on, we partition the+variables into the ones that start with an underscore (the named+wildcards) and the rest. Then we just add them to the hswc_wcs field+of the HsWildCardBndrs structure, and we are done.+++*********************************************************+*                                                       *+           HsSigtype (i.e. no wildcards)+*                                                       *+****************************************************** -}++rnHsSigType :: HsDocContext -> LHsSigType GhcPs+            -> RnM (LHsSigType GhcRn, FreeVars)+-- Used for source-language type signatures+-- that cannot have wildcards+rnHsSigType ctx (HsIB { hsib_body = hs_ty })+  = do { traceRn "rnHsSigType" (ppr hs_ty)+       ; vars <- extractFilteredRdrTyVarsDups hs_ty+       ; rnImplicitBndrs (not (isLHsForAllTy hs_ty)) vars $ \ vars ->+    do { (body', fvs) <- rnLHsType ctx hs_ty+       ; return ( HsIB { hsib_ext = vars+                       , hsib_body = body' }+                , fvs ) } }+rnHsSigType _ (XHsImplicitBndrs _) = panic "rnHsSigType"++rnImplicitBndrs :: Bool    -- True <=> bring into scope any free type variables+                           -- E.g.  f :: forall a. a->b+                           --  we do not want to bring 'b' into scope, hence False+                           -- But   f :: a -> b+                           --  we want to bring both 'a' and 'b' into scope+                -> FreeKiTyVarsWithDups+                                   -- Free vars of hs_ty (excluding wildcards)+                                   -- May have duplicates, which is+                                   -- checked here+                -> ([Name] -> RnM (a, FreeVars))+                -> RnM (a, FreeVars)+rnImplicitBndrs bind_free_tvs+                fvs_with_dups+                thing_inside+  = do { let fvs = nubL fvs_with_dups+             real_fvs | bind_free_tvs = fvs+                      | otherwise     = []++       ; traceRn "rnImplicitBndrs" $+         vcat [ ppr fvs_with_dups, ppr fvs, ppr real_fvs ]++       ; loc <- getSrcSpanM+       ; vars <- mapM (newLocalBndrRn . cL loc . unLoc) real_fvs++       ; bindLocalNamesFV vars $+         thing_inside vars }++{- ******************************************************+*                                                       *+           LHsType and HsType+*                                                       *+****************************************************** -}++{-+rnHsType is here because we call it from loadInstDecl, and I didn't+want a gratuitous knot.++Note [Context quantification]+-----------------------------+Variables in type signatures are implicitly quantified+when (1) they are in a type signature not beginning+with "forall" or (2) in any qualified type T => R.+We are phasing out (2) since it leads to inconsistencies+(#4426):++data A = A (a -> a)           is an error+data A = A (Eq a => a -> a)   binds "a"+data A = A (Eq a => a -> b)   binds "a" and "b"+data A = A (() => a -> b)     binds "a" and "b"+f :: forall a. a -> b         is an error+f :: forall a. () => a -> b   is an error+f :: forall a. a -> (() => b) binds "a" and "b"++This situation is now considered to be an error. See rnHsTyKi for case+HsForAllTy Qualified.++Note [QualTy in kinds]+~~~~~~~~~~~~~~~~~~~~~~+I was wondering whether QualTy could occur only at TypeLevel.  But no,+we can have a qualified type in a kind too. Here is an example:++  type family F a where+    F Bool = Nat+    F Nat  = Type++  type family G a where+    G Type = Type -> Type+    G ()   = Nat++  data X :: forall k1 k2. (F k1 ~ G k2) => k1 -> k2 -> Type where+    MkX :: X 'True '()++See that k1 becomes Bool and k2 becomes (), so the equality is+satisfied. If I write MkX :: X 'True 'False, compilation fails with a+suitable message:++  MkX :: X 'True '()+    • Couldn't match kind ‘G Bool’ with ‘Nat’+      Expected kind: G Bool+        Actual kind: F Bool++However: in a kind, the constraints in the QualTy must all be+equalities; or at least, any kinds with a class constraint are+uninhabited.+-}++data RnTyKiEnv+  = RTKE { rtke_ctxt  :: HsDocContext+         , rtke_level :: TypeOrKind  -- Am I renaming a type or a kind?+         , rtke_what  :: RnTyKiWhat  -- And within that what am I renaming?+         , rtke_nwcs  :: NameSet     -- These are the in-scope named wildcards+    }++data RnTyKiWhat = RnTypeBody+                | RnTopConstraint   -- Top-level context of HsSigWcTypes+                | RnConstraint      -- All other constraints++instance Outputable RnTyKiEnv where+  ppr (RTKE { rtke_level = lev, rtke_what = what+            , rtke_nwcs = wcs, rtke_ctxt = ctxt })+    = text "RTKE"+      <+> braces (sep [ ppr lev, ppr what, ppr wcs+                      , pprHsDocContext ctxt ])++instance Outputable RnTyKiWhat where+  ppr RnTypeBody      = text "RnTypeBody"+  ppr RnTopConstraint = text "RnTopConstraint"+  ppr RnConstraint    = text "RnConstraint"++mkTyKiEnv :: HsDocContext -> TypeOrKind -> RnTyKiWhat -> RnTyKiEnv+mkTyKiEnv cxt level what+ = RTKE { rtke_level = level, rtke_nwcs = emptyNameSet+        , rtke_what = what, rtke_ctxt = cxt }++isRnKindLevel :: RnTyKiEnv -> Bool+isRnKindLevel (RTKE { rtke_level = KindLevel }) = True+isRnKindLevel _                                 = False++--------------+rnLHsType  :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)+rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty++rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars)+rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys++rnHsType  :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)+rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty++rnLHsKind  :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars)+rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind++rnHsKind  :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars)+rnHsKind ctxt kind = rnHsTyKi  (mkTyKiEnv ctxt KindLevel RnTypeBody) kind++-- renaming a type only, not a kind+rnLHsTypeArg :: HsDocContext -> LHsTypeArg GhcPs+                -> RnM (LHsTypeArg GhcRn, FreeVars)+rnLHsTypeArg ctxt (HsValArg ty)+   = do { (tys_rn, fvs) <- rnLHsType ctxt ty+        ; return (HsValArg tys_rn, fvs) }+rnLHsTypeArg ctxt (HsTypeArg l ki)+   = do { (kis_rn, fvs) <- rnLHsKind ctxt ki+        ; return (HsTypeArg l kis_rn, fvs) }+rnLHsTypeArg _ (HsArgPar sp)+   = return (HsArgPar sp, emptyFVs)++rnLHsTypeArgs :: HsDocContext -> [LHsTypeArg GhcPs]+                 -> RnM ([LHsTypeArg GhcRn], FreeVars)+rnLHsTypeArgs doc args = mapFvRn (rnLHsTypeArg doc) args++--------------+rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs+              -> RnM (LHsContext GhcRn, FreeVars)+rnTyKiContext env (dL->L loc cxt)+  = do { traceRn "rncontext" (ppr cxt)+       ; let env' = env { rtke_what = RnConstraint }+       ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt+       ; return (cL loc cxt', fvs) }++rnContext :: HsDocContext -> LHsContext GhcPs+          -> RnM (LHsContext GhcRn, FreeVars)+rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta++--------------+rnLHsTyKi  :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars)+rnLHsTyKi env (dL->L loc ty)+  = setSrcSpan loc $+    do { (ty', fvs) <- rnHsTyKi env ty+       ; return (cL loc ty', fvs) }++rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars)++rnHsTyKi env ty@(HsForAllTy { hst_fvf = fvf, hst_bndrs = tyvars+                            , hst_body = tau })+  = do { checkPolyKinds env ty+       ; bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc ty)+                           Nothing tyvars $ \ tyvars' ->+    do { (tau',  fvs) <- rnLHsTyKi env tau+       ; return ( HsForAllTy { hst_fvf = fvf, hst_xforall = noExt+                             , hst_bndrs = tyvars' , hst_body =  tau' }+                , fvs) } }++rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau })+  = do { checkPolyKinds env ty  -- See Note [QualTy in kinds]+       ; (ctxt', fvs1) <- rnTyKiContext env lctxt+       ; (tau',  fvs2) <- rnLHsTyKi env tau+       ; return (HsQualTy { hst_xqual = noExt, hst_ctxt = ctxt'+                          , hst_body =  tau' }+                , fvs1 `plusFV` fvs2) }++rnHsTyKi env (HsTyVar _ ip (dL->L loc rdr_name))+  = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $+         unlessXOptM LangExt.PolyKinds $ addErr $+         withHsDocContext (rtke_ctxt env) $+         vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name)+              , text "Perhaps you intended to use PolyKinds" ]+           -- Any type variable at the kind level is illegal without the use+           -- of PolyKinds (see #14710)+       ; name <- rnTyVar env rdr_name+       ; return (HsTyVar noExt ip (cL loc name), unitFV name) }++rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)+  = setSrcSpan (getLoc l_op) $+    do  { (l_op', fvs1) <- rnHsTyOp env ty l_op+        ; fix   <- lookupTyFixityRn l_op'+        ; (ty1', fvs2) <- rnLHsTyKi env ty1+        ; (ty2', fvs3) <- rnLHsTyKi env ty2+        ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy noExt t1 l_op' t2)+                               (unLoc l_op') fix ty1' ty2'+        ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }++rnHsTyKi env (HsParTy _ ty)+  = do { (ty', fvs) <- rnLHsTyKi env ty+       ; return (HsParTy noExt ty', fvs) }++rnHsTyKi env (HsBangTy _ b ty)+  = do { (ty', fvs) <- rnLHsTyKi env ty+       ; return (HsBangTy noExt b ty', fvs) }++rnHsTyKi env ty@(HsRecTy _ flds)+  = do { let ctxt = rtke_ctxt env+       ; fls          <- get_fields ctxt+       ; (flds', fvs) <- rnConDeclFields ctxt fls flds+       ; return (HsRecTy noExt flds', fvs) }+  where+    get_fields (ConDeclCtx names)+      = concatMapM (lookupConstructorFields . unLoc) names+    get_fields _+      = do { addErr (hang (text "Record syntax is illegal here:")+                                   2 (ppr ty))+           ; return [] }++rnHsTyKi env (HsFunTy _ ty1 ty2)+  = do { (ty1', fvs1) <- rnLHsTyKi env ty1+        -- Might find a for-all as the arg of a function type+       ; (ty2', fvs2) <- rnLHsTyKi env ty2+        -- Or as the result.  This happens when reading Prelude.hi+        -- when we find return :: forall m. Monad m -> forall a. a -> m a++        -- Check for fixity rearrangements+       ; res_ty <- mkHsOpTyRn (HsFunTy noExt) funTyConName funTyFixity ty1' ty2'+       ; return (res_ty, fvs1 `plusFV` fvs2) }++rnHsTyKi env listTy@(HsListTy _ ty)+  = do { data_kinds <- xoptM LangExt.DataKinds+       ; when (not data_kinds && isRnKindLevel env)+              (addErr (dataKindsErr env listTy))+       ; (ty', fvs) <- rnLHsTyKi env ty+       ; return (HsListTy noExt ty', fvs) }++rnHsTyKi env t@(HsKindSig _ ty k)+  = do { checkPolyKinds env t+       ; kind_sigs_ok <- xoptM LangExt.KindSignatures+       ; unless kind_sigs_ok (badKindSigErr (rtke_ctxt env) ty)+       ; (ty', fvs1) <- rnLHsTyKi env ty+       ; (k', fvs2)  <- rnLHsTyKi (env { rtke_level = KindLevel }) k+       ; return (HsKindSig noExt ty' k', fvs1 `plusFV` fvs2) }++-- Unboxed tuples are allowed to have poly-typed arguments.  These+-- sometimes crop up as a result of CPR worker-wrappering dictionaries.+rnHsTyKi env tupleTy@(HsTupleTy _ tup_con tys)+  = do { data_kinds <- xoptM LangExt.DataKinds+       ; when (not data_kinds && isRnKindLevel env)+              (addErr (dataKindsErr env tupleTy))+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys+       ; return (HsTupleTy noExt tup_con tys', fvs) }++rnHsTyKi env sumTy@(HsSumTy _ tys)+  = do { data_kinds <- xoptM LangExt.DataKinds+       ; when (not data_kinds && isRnKindLevel env)+              (addErr (dataKindsErr env sumTy))+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys+       ; return (HsSumTy noExt tys', fvs) }++-- Ensure that a type-level integer is nonnegative (#8306, #8412)+rnHsTyKi env tyLit@(HsTyLit _ t)+  = do { data_kinds <- xoptM LangExt.DataKinds+       ; unless data_kinds (addErr (dataKindsErr env tyLit))+       ; when (negLit t) (addErr negLitErr)+       ; checkPolyKinds env tyLit+       ; return (HsTyLit noExt t, emptyFVs) }+  where+    negLit (HsStrTy _ _) = False+    negLit (HsNumTy _ i) = i < 0+    negLitErr = text "Illegal literal in type (type literals must not be negative):" <+> ppr tyLit++rnHsTyKi env (HsAppTy _ ty1 ty2)+  = do { (ty1', fvs1) <- rnLHsTyKi env ty1+       ; (ty2', fvs2) <- rnLHsTyKi env ty2+       ; return (HsAppTy noExt ty1' ty2', fvs1 `plusFV` fvs2) }++rnHsTyKi env (HsAppKindTy l ty k)+  = do { kind_app <- xoptM LangExt.TypeApplications+       ; unless kind_app (addErr (typeAppErr "kind" k))+       ; (ty', fvs1) <- rnLHsTyKi env ty+       ; (k', fvs2) <- rnLHsTyKi (env {rtke_level = KindLevel }) k+       ; return (HsAppKindTy l ty' k', fvs1 `plusFV` fvs2) }++rnHsTyKi env t@(HsIParamTy _ n ty)+  = do { notInKinds env t+       ; (ty', fvs) <- rnLHsTyKi env ty+       ; return (HsIParamTy noExt n ty', fvs) }++rnHsTyKi _ (HsStarTy _ isUni)+  = return (HsStarTy noExt isUni, emptyFVs)++rnHsTyKi _ (HsSpliceTy _ sp)+  = rnSpliceType sp++rnHsTyKi env (HsDocTy _ ty haddock_doc)+  = do { (ty', fvs) <- rnLHsTyKi env ty+       ; haddock_doc' <- rnLHsDoc haddock_doc+       ; return (HsDocTy noExt ty' haddock_doc', fvs) }++rnHsTyKi _ (XHsType (NHsCoreTy ty))+  = return (XHsType (NHsCoreTy ty), emptyFVs)+    -- The emptyFVs probably isn't quite right+    -- but I don't think it matters++rnHsTyKi env ty@(HsExplicitListTy _ ip tys)+  = do { checkPolyKinds env ty+       ; data_kinds <- xoptM LangExt.DataKinds+       ; unless data_kinds (addErr (dataKindsErr env ty))+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys+       ; return (HsExplicitListTy noExt ip tys', fvs) }++rnHsTyKi env ty@(HsExplicitTupleTy _ tys)+  = do { checkPolyKinds env ty+       ; data_kinds <- xoptM LangExt.DataKinds+       ; unless data_kinds (addErr (dataKindsErr env ty))+       ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys+       ; return (HsExplicitTupleTy noExt tys', fvs) }++rnHsTyKi env (HsWildCardTy _)+  = do { checkAnonWildCard env+       ; return (HsWildCardTy noExt, emptyFVs) }++--------------+rnTyVar :: RnTyKiEnv -> RdrName -> RnM Name+rnTyVar env rdr_name+  = do { name <- lookupTypeOccRn rdr_name+       ; checkNamedWildCard env name+       ; return name }++rnLTyVar :: Located RdrName -> RnM (Located Name)+-- Called externally; does not deal with wildards+rnLTyVar (dL->L loc rdr_name)+  = do { tyvar <- lookupTypeOccRn rdr_name+       ; return (cL loc tyvar) }++--------------+rnHsTyOp :: Outputable a+         => RnTyKiEnv -> a -> Located RdrName+         -> RnM (Located Name, FreeVars)+rnHsTyOp env overall_ty (dL->L loc op)+  = do { ops_ok <- xoptM LangExt.TypeOperators+       ; op' <- rnTyVar env op+       ; unless (ops_ok || op' `hasKey` eqTyConKey) $+           addErr (opTyErr op overall_ty)+       ; let l_op' = cL loc op'+       ; return (l_op', unitFV op') }++--------------+notAllowed :: SDoc -> SDoc+notAllowed doc+  = text "Wildcard" <+> quotes doc <+> ptext (sLit "not allowed")++checkWildCard :: RnTyKiEnv -> Maybe SDoc -> RnM ()+checkWildCard env (Just doc)+  = addErr $ vcat [doc, nest 2 (text "in" <+> pprHsDocContext (rtke_ctxt env))]+checkWildCard _ Nothing+  = return ()++checkAnonWildCard :: RnTyKiEnv -> RnM ()+-- Report an error if an anonymous wildcard is illegal here+checkAnonWildCard env+  = checkWildCard env mb_bad+  where+    mb_bad :: Maybe SDoc+    mb_bad | not (wildCardsAllowed env)+           = Just (notAllowed pprAnonWildCard)+           | otherwise+           = case rtke_what env of+               RnTypeBody      -> Nothing+               RnConstraint    -> Just constraint_msg+               RnTopConstraint -> Just constraint_msg++    constraint_msg = hang+                         (notAllowed pprAnonWildCard <+> text "in a constraint")+                        2 hint_msg+    hint_msg = vcat [ text "except as the last top-level constraint of a type signature"+                    , nest 2 (text "e.g  f :: (Eq a, _) => blah") ]++checkNamedWildCard :: RnTyKiEnv -> Name -> RnM ()+-- Report an error if a named wildcard is illegal here+checkNamedWildCard env name+  = checkWildCard env mb_bad+  where+    mb_bad | not (name `elemNameSet` rtke_nwcs env)+           = Nothing  -- Not a wildcard+           | not (wildCardsAllowed env)+           = Just (notAllowed (ppr name))+           | otherwise+           = case rtke_what env of+               RnTypeBody      -> Nothing   -- Allowed+               RnTopConstraint -> Nothing   -- Allowed+               RnConstraint    -> Just constraint_msg+    constraint_msg = notAllowed (ppr name) <+> text "in a constraint"++wildCardsAllowed :: RnTyKiEnv -> Bool+-- ^ In what contexts are wildcards permitted+wildCardsAllowed env+   = case rtke_ctxt env of+       TypeSigCtx {}       -> True+       TypBrCtx {}         -> True   -- Template Haskell quoted type+       SpliceTypeCtx {}    -> True   -- Result of a Template Haskell splice+       ExprWithTySigCtx {} -> True+       PatCtx {}           -> True+       RuleCtx {}          -> True+       FamPatCtx {}        -> True   -- Not named wildcards though+       GHCiCtx {}          -> True+       HsTypeCtx {}        -> True+       _                   -> False++++---------------+-- | Ensures either that we're in a type or that -XPolyKinds is set+checkPolyKinds :: Outputable ty+                => RnTyKiEnv+                -> ty      -- ^ type+                -> RnM ()+checkPolyKinds env ty+  | isRnKindLevel env+  = do { polykinds <- xoptM LangExt.PolyKinds+       ; unless polykinds $+         addErr (text "Illegal kind:" <+> ppr ty $$+                 text "Did you mean to enable PolyKinds?") }+checkPolyKinds _ _ = return ()++notInKinds :: Outputable ty+           => RnTyKiEnv+           -> ty+           -> RnM ()+notInKinds env ty+  | isRnKindLevel env+  = addErr (text "Illegal kind:" <+> ppr ty)+notInKinds _ _ = return ()++{- *****************************************************+*                                                      *+          Binding type variables+*                                                      *+***************************************************** -}++bindSigTyVarsFV :: [Name]+                -> RnM (a, FreeVars)+                -> RnM (a, FreeVars)+-- Used just before renaming the defn of a function+-- with a separate type signature, to bring its tyvars into scope+-- With no -XScopedTypeVariables, this is a no-op+bindSigTyVarsFV tvs thing_inside+  = do  { scoped_tyvars <- xoptM LangExt.ScopedTypeVariables+        ; if not scoped_tyvars then+                thing_inside+          else+                bindLocalNamesFV tvs thing_inside }++-- | Simply bring a bunch of RdrNames into scope. No checking for+-- validity, at all. The binding location is taken from the location+-- on each name.+bindLRdrNames :: [Located RdrName]+              -> ([Name] -> RnM (a, FreeVars))+              -> RnM (a, FreeVars)+bindLRdrNames rdrs thing_inside+  = do { var_names <- mapM (newTyVarNameRn Nothing) rdrs+       ; bindLocalNamesFV var_names $+         thing_inside var_names }++---------------+bindHsQTyVars :: forall a b.+                 HsDocContext+              -> Maybe SDoc         -- Just d => check for unused tvs+                                    --   d is a phrase like "in the type ..."+              -> Maybe a            -- Just _  => an associated type decl+              -> [Located RdrName]  -- Kind variables from scope, no dups+              -> (LHsQTyVars GhcPs)+              -> (LHsQTyVars GhcRn -> Bool -> RnM (b, FreeVars))+                  -- The Bool is True <=> all kind variables used in the+                  -- kind signature are bound on the left.  Reason:+                  -- the last clause of Note [CUSKs: Complete user-supplied+                  -- kind signatures] in HsDecls+              -> RnM (b, FreeVars)++-- See Note [bindHsQTyVars examples]+-- (a) Bring kind variables into scope+--     both (i)  passed in body_kv_occs+--     and  (ii) mentioned in the kinds of hsq_bndrs+-- (b) Bring type variables into scope+--+bindHsQTyVars doc mb_in_doc mb_assoc body_kv_occs hsq_bndrs thing_inside+  = do { let hs_tv_bndrs = hsQTvExplicit hsq_bndrs+             bndr_kv_occs = extractHsTyVarBndrsKVs hs_tv_bndrs++       ; let -- See Note [bindHsQTyVars examples] for what+             -- all these various things are doing+             bndrs, kv_occs, implicit_kvs :: [Located RdrName]+             bndrs        = map hsLTyVarLocName hs_tv_bndrs+             kv_occs      = nubL (bndr_kv_occs ++ body_kv_occs)+                                 -- Make sure to list the binder kvs before the+                                 -- body kvs, as mandated by+                                 -- Note [Ordering of implicit variables]+             implicit_kvs = filter_occs bndrs kv_occs+             del          = deleteBys eqLocated+             all_bound_on_lhs = null ((body_kv_occs `del` bndrs) `del` bndr_kv_occs)++       ; traceRn "checkMixedVars3" $+           vcat [ text "kv_occs" <+> ppr kv_occs+                , text "bndrs"   <+> ppr hs_tv_bndrs+                , text "bndr_kv_occs"   <+> ppr bndr_kv_occs+                , text "wubble" <+> ppr ((kv_occs \\ bndrs) \\ bndr_kv_occs)+                ]++       ; implicit_kv_nms <- mapM (newTyVarNameRn mb_assoc) implicit_kvs++       ; bindLocalNamesFV implicit_kv_nms                     $+         bindLHsTyVarBndrs doc mb_in_doc mb_assoc hs_tv_bndrs $ \ rn_bndrs ->+    do { traceRn "bindHsQTyVars" (ppr hsq_bndrs $$ ppr implicit_kv_nms $$ ppr rn_bndrs)+       ; thing_inside (HsQTvs { hsq_ext = implicit_kv_nms+                              , hsq_explicit  = rn_bndrs })+                      all_bound_on_lhs } }++  where+    filter_occs :: [Located RdrName]   -- Bound here+                -> [Located RdrName]   -- Potential implicit binders+                -> [Located RdrName]   -- Final implicit binders+    -- Filter out any potential implicit binders that are either+    -- already in scope, or are explicitly bound in the same HsQTyVars+    filter_occs bndrs occs+      = filterOut is_in_scope occs+      where+        is_in_scope locc = locc `elemRdr` bndrs++{- Note [bindHsQTyVars examples]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   data T k (a::k1) (b::k) :: k2 -> k1 -> *++Then:+  hs_tv_bndrs = [k, a::k1, b::k], the explicitly-bound variables+  bndrs       = [k,a,b]++  bndr_kv_occs = [k,k1], kind variables free in kind signatures+                         of hs_tv_bndrs++  body_kv_occs = [k2,k1], kind variables free in the+                          result kind signature++  implicit_kvs = [k1,k2], kind variables free in kind signatures+                          of hs_tv_bndrs, and not bound by bndrs++* We want to quantify add implicit bindings for implicit_kvs++* If implicit_body_kvs is non-empty, then there is a kind variable+  mentioned in the kind signature that is not bound "on the left".+  That's one of the rules for a CUSK, so we pass that info on+  as the second argument to thing_inside.++* Order is not important in these lists.  All we are doing is+  bring Names into scope.++Finally, you may wonder why filter_occs removes in-scope variables+from bndr/body_kv_occs.  How can anything be in scope?  Answer:+HsQTyVars is /also/ used (slightly oddly) for Haskell-98 syntax+ConDecls+   data T a = forall (b::k). MkT a b+The ConDecl has a LHsQTyVars in it; but 'a' scopes over the entire+ConDecl.  Hence the local RdrEnv may be non-empty and we must filter+out 'a' from the free vars.  (Mind you, in this situation all the+implicit kind variables are bound at the data type level, so there+are none to bind in the ConDecl, so there are no implicitly bound+variables at all.++Note [Kind variable scoping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+  data T (a :: k) k = ...+we report "k is out of scope" for (a::k).  Reason: k is not brought+into scope until the explicit k-binding that follows.  It would be+terribly confusing to bring into scope an /implicit/ k for a's kind+and a distinct, shadowing explicit k that follows, something like+  data T {k1} (a :: k1) k = ...++So the rule is:++   the implicit binders never include any+   of the explicit binders in the group++Note that in the denerate case+  data T (a :: a) = blah+we get a complaint the second 'a' is not in scope.++That applies to foralls too: e.g.+   forall (a :: k) k . blah++But if the foralls are split, we treat the two groups separately:+   forall (a :: k). forall k. blah+Here we bring into scope an implicit k, which is later shadowed+by the explicit k.++In implementation terms++* In bindHsQTyVars 'k' is free in bndr_kv_occs; then we delete+  the binders {a,k}, and so end with no implicit binders.  Then we+  rename the binders left-to-right, and hence see that 'k' is out of+  scope in the kind of 'a'.++* Similarly in extract_hs_tv_bndrs++Note [Variables used as both types and kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We bind the type variables tvs, and kvs is the set of free variables of the+kinds in the scope of the binding. Here is one typical example:++   forall a b. a -> (b::k) -> (c::a)++Here, tvs will be {a,b}, and kvs {k,a}.++We must make sure that kvs includes all of variables in the kinds of type+variable bindings. For instance:++   forall k (a :: k). Proxy a++If we only look in the body of the `forall` type, we will mistakenly conclude+that kvs is {}. But in fact, the type variable `k` is also used as a kind+variable in (a :: k), later in the binding. (This mistake lead to #14710.)+So tvs is {k,a} and kvs is {k}.++NB: we do this only at the binding site of 'tvs'.+-}++bindLHsTyVarBndrs :: HsDocContext+                  -> Maybe SDoc            -- Just d => check for unused tvs+                                           --   d is a phrase like "in the type ..."+                  -> Maybe a               -- Just _  => an associated type decl+                  -> [LHsTyVarBndr GhcPs]  -- User-written tyvars+                  -> ([LHsTyVarBndr GhcRn] -> RnM (b, FreeVars))+                  -> RnM (b, FreeVars)+bindLHsTyVarBndrs doc mb_in_doc mb_assoc tv_bndrs thing_inside+  = do { when (isNothing mb_assoc) (checkShadowedRdrNames tv_names_w_loc)+       ; checkDupRdrNames tv_names_w_loc+       ; go tv_bndrs thing_inside }+  where+    tv_names_w_loc = map hsLTyVarLocName tv_bndrs++    go []     thing_inside = thing_inside []+    go (b:bs) thing_inside = bindLHsTyVarBndr doc mb_assoc b $ \ b' ->+                             do { (res, fvs) <- go bs $ \ bs' ->+                                                thing_inside (b' : bs')+                                ; warn_unused b' fvs+                                ; return (res, fvs) }++    warn_unused tv_bndr fvs = case mb_in_doc of+      Just in_doc -> warnUnusedForAll in_doc tv_bndr fvs+      Nothing     -> return ()++bindLHsTyVarBndr :: HsDocContext+                 -> Maybe a   -- associated class+                 -> LHsTyVarBndr GhcPs+                 -> (LHsTyVarBndr GhcRn -> RnM (b, FreeVars))+                 -> RnM (b, FreeVars)+bindLHsTyVarBndr _doc mb_assoc (dL->L loc+                                 (UserTyVar x+                                    lrdr@(dL->L lv _))) thing_inside+  = do { nm <- newTyVarNameRn mb_assoc lrdr+       ; bindLocalNamesFV [nm] $+         thing_inside (cL loc (UserTyVar x (cL lv nm))) }++bindLHsTyVarBndr doc mb_assoc (dL->L loc (KindedTyVar x lrdr@(dL->L lv _) kind))+                 thing_inside+  = do { sig_ok <- xoptM LangExt.KindSignatures+           ; unless sig_ok (badKindSigErr doc kind)+           ; (kind', fvs1) <- rnLHsKind doc kind+           ; tv_nm  <- newTyVarNameRn mb_assoc lrdr+           ; (b, fvs2) <- bindLocalNamesFV [tv_nm]+               $ thing_inside (cL loc (KindedTyVar x (cL lv tv_nm) kind'))+           ; return (b, fvs1 `plusFV` fvs2) }++bindLHsTyVarBndr _ _ (dL->L _ (XTyVarBndr{})) _ = panic "bindLHsTyVarBndr"+bindLHsTyVarBndr _ _ _ _ = panic "bindLHsTyVarBndr: Impossible Match"+                             -- due to #15884++newTyVarNameRn :: Maybe a -> Located RdrName -> RnM Name+newTyVarNameRn mb_assoc (dL->L loc rdr)+  = do { rdr_env <- getLocalRdrEnv+       ; case (mb_assoc, lookupLocalRdrEnv rdr_env rdr) of+           (Just _, Just n) -> return n+              -- Use the same Name as the parent class decl++           _                -> newLocalBndrRn (cL loc rdr) }+{-+*********************************************************+*                                                       *+        ConDeclField+*                                                       *+*********************************************************++When renaming a ConDeclField, we have to find the FieldLabel+associated with each field.  But we already have all the FieldLabels+available (since they were brought into scope by+RnNames.getLocalNonValBinders), so we just take the list as an+argument, build a map and look them up.+-}++rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs]+                -> RnM ([LConDeclField GhcRn], FreeVars)+-- Also called from RnSource+-- No wildcards can appear in record fields+rnConDeclFields ctxt fls fields+   = mapFvRn (rnField fl_env env) fields+  where+    env    = mkTyKiEnv ctxt TypeLevel RnTypeBody+    fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ]++rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs+        -> RnM (LConDeclField GhcRn, FreeVars)+rnField fl_env env (dL->L l (ConDeclField _ names ty haddock_doc))+  = do { let new_names = map (fmap lookupField) names+       ; (new_ty, fvs) <- rnLHsTyKi env ty+       ; new_haddock_doc <- rnMbLHsDoc haddock_doc+       ; return (cL l (ConDeclField noExt new_names new_ty new_haddock_doc)+                , fvs) }+  where+    lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn+    lookupField (FieldOcc _ (dL->L lr rdr)) =+        FieldOcc (flSelector fl) (cL lr rdr)+      where+        lbl = occNameFS $ rdrNameOcc rdr+        fl  = expectJust "rnField" $ lookupFsEnv fl_env lbl+    lookupField (XFieldOcc{}) = panic "rnField"+rnField _ _ (dL->L _ (XConDeclField _)) = panic "rnField"+rnField _ _ _ = panic "rnField: Impossible Match"+                             -- due to #15884++{-+************************************************************************+*                                                                      *+        Fixities and precedence parsing+*                                                                      *+************************************************************************++@mkOpAppRn@ deals with operator fixities.  The argument expressions+are assumed to be already correctly arranged.  It needs the fixities+recorded in the OpApp nodes, because fixity info applies to the things+the programmer actually wrote, so you can't find it out from the Name.++Furthermore, the second argument is guaranteed not to be another+operator application.  Why? Because the parser parses all+operator applications left-associatively, EXCEPT negation, which+we need to handle specially.+Infix types are read in a *right-associative* way, so that+        a `op` b `op` c+is always read in as+        a `op` (b `op` c)++mkHsOpTyRn rearranges where necessary.  The two arguments+have already been renamed and rearranged.  It's made rather tiresome+by the presence of ->, which is a separate syntactic construct.+-}++---------------+-- Building (ty1 `op1` (ty21 `op2` ty22))+mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)+           -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn+           -> RnM (HsType GhcRn)++mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsOpTy noExt ty21 op2 ty22))+  = do  { fix2 <- lookupTyFixityRn op2+        ; mk_hs_op_ty mk1 pp_op1 fix1 ty1+                      (\t1 t2 -> HsOpTy noExt t1 op2 t2)+                      (unLoc op2) fix2 ty21 ty22 loc2 }++mkHsOpTyRn mk1 pp_op1 fix1 ty1 (dL->L loc2 (HsFunTy _ ty21 ty22))+  = mk_hs_op_ty mk1 pp_op1 fix1 ty1+                (HsFunTy noExt) funTyConName funTyFixity ty21 ty22 loc2++mkHsOpTyRn mk1 _ _ ty1 ty2              -- Default case, no rearrangment+  = return (mk1 ty1 ty2)++---------------+mk_hs_op_ty :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)+            -> Name -> Fixity -> LHsType GhcRn+            -> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn)+            -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan+            -> RnM (HsType GhcRn)+mk_hs_op_ty mk1 op1 fix1 ty1+            mk2 op2 fix2 ty21 ty22 loc2+  | nofix_error     = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2)+                         ; return (mk1 ty1 (cL loc2 (mk2 ty21 ty22))) }+  | associate_right = return (mk1 ty1 (cL loc2 (mk2 ty21 ty22)))+  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)+                           new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21+                         ; return (mk2 (noLoc new_ty) ty22) }+  where+    (nofix_error, associate_right) = compareFixity fix1 fix2+++---------------------------+mkOpAppRn :: LHsExpr GhcRn             -- Left operand; already rearranged+          -> LHsExpr GhcRn -> Fixity   -- Operator and fixity+          -> LHsExpr GhcRn             -- Right operand (not an OpApp, but might+                                       -- be a NegApp)+          -> RnM (HsExpr GhcRn)++-- (e11 `op1` e12) `op2` e2+mkOpAppRn e1@(dL->L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2+  | nofix_error+  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)+       return (OpApp fix2 e1 op2 e2)++  | associate_right = do+    new_e <- mkOpAppRn e12 op2 fix2 e2+    return (OpApp fix1 e11 op1 (cL loc' new_e))+  where+    loc'= combineLocs e12 e2+    (nofix_error, associate_right) = compareFixity fix1 fix2++---------------------------+--      (- neg_arg) `op` e2+mkOpAppRn e1@(dL->L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2+  | nofix_error+  = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2)+       return (OpApp fix2 e1 op2 e2)++  | associate_right+  = do new_e <- mkOpAppRn neg_arg op2 fix2 e2+       return (NegApp noExt (cL loc' new_e) neg_name)+  where+    loc' = combineLocs neg_arg e2+    (nofix_error, associate_right) = compareFixity negateFixity fix2++---------------------------+--      e1 `op` - neg_arg+mkOpAppRn e1 op1 fix1 e2@(dL->L _ (NegApp {})) -- NegApp can occur on the right+  | not associate_right                        -- We *want* right association+  = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity)+       return (OpApp fix1 e1 op1 e2)+  where+    (_, associate_right) = compareFixity fix1 negateFixity++---------------------------+--      Default case+mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment+  = ASSERT2( right_op_ok fix (unLoc e2),+             ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2+    )+    return (OpApp fix e1 op e2)++----------------------------++-- | Name of an operator in an operator application or section+data OpName = NormalOp Name         -- ^ A normal identifier+            | NegateOp              -- ^ Prefix negation+            | UnboundOp UnboundVar  -- ^ An unbound indentifier+            | RecFldOp (AmbiguousFieldOcc GhcRn)+              -- ^ A (possibly ambiguous) record field occurrence++instance Outputable OpName where+  ppr (NormalOp n)   = ppr n+  ppr NegateOp       = ppr negateName+  ppr (UnboundOp uv) = ppr uv+  ppr (RecFldOp fld) = ppr fld++get_op :: LHsExpr GhcRn -> OpName+-- An unbound name could be either HsVar or HsUnboundVar+-- See RnExpr.rnUnboundVar+get_op (dL->L _ (HsVar _ n))         = NormalOp (unLoc n)+get_op (dL->L _ (HsUnboundVar _ uv)) = UnboundOp uv+get_op (dL->L _ (HsRecFld _ fld))    = RecFldOp fld+get_op other                         = pprPanic "get_op" (ppr other)++-- Parser left-associates everything, but+-- derived instances may have correctly-associated things to+-- in the right operand.  So we just check that the right operand is OK+right_op_ok :: Fixity -> HsExpr GhcRn -> Bool+right_op_ok fix1 (OpApp fix2 _ _ _)+  = not error_please && associate_right+  where+    (error_please, associate_right) = compareFixity fix1 fix2+right_op_ok _ _+  = True++-- Parser initially makes negation bind more tightly than any other operator+-- And "deriving" code should respect this (use HsPar if not)+mkNegAppRn :: LHsExpr (GhcPass id) -> SyntaxExpr (GhcPass id)+           -> RnM (HsExpr (GhcPass id))+mkNegAppRn neg_arg neg_name+  = ASSERT( not_op_app (unLoc neg_arg) )+    return (NegApp noExt neg_arg neg_name)++not_op_app :: HsExpr id -> Bool+not_op_app (OpApp {}) = False+not_op_app _          = True++---------------------------+mkOpFormRn :: LHsCmdTop GhcRn            -- Left operand; already rearranged+          -> LHsExpr GhcRn -> Fixity     -- Operator and fixity+          -> LHsCmdTop GhcRn             -- Right operand (not an infix)+          -> RnM (HsCmd GhcRn)++-- (e11 `op1` e12) `op2` e2+mkOpFormRn a1@(dL->L loc+                    (HsCmdTop _+                     (dL->L _ (HsCmdArrForm x op1 f (Just fix1)+                        [a11,a12]))))+        op2 fix2 a2+  | nofix_error+  = do precParseErr (get_op op1,fix1) (get_op op2,fix2)+       return (HsCmdArrForm x op2 f (Just fix2) [a1, a2])++  | associate_right+  = do new_c <- mkOpFormRn a12 op2 fix2 a2+       return (HsCmdArrForm noExt op1 f (Just fix1)+               [a11, cL loc (HsCmdTop [] (cL loc new_c))])+        -- TODO: locs are wrong+  where+    (nofix_error, associate_right) = compareFixity fix1 fix2++--      Default case+mkOpFormRn arg1 op fix arg2                     -- Default case, no rearrangment+  = return (HsCmdArrForm noExt op Infix (Just fix) [arg1, arg2])+++--------------------------------------+mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn+             -> RnM (Pat GhcRn)++mkConOpPatRn op2 fix2 p1@(dL->L loc (ConPatIn op1 (InfixCon p11 p12))) p2+  = do  { fix1 <- lookupFixityRn (unLoc op1)+        ; let (nofix_error, associate_right) = compareFixity fix1 fix2++        ; if nofix_error then do+                { precParseErr (NormalOp (unLoc op1),fix1)+                               (NormalOp (unLoc op2),fix2)+                ; return (ConPatIn op2 (InfixCon p1 p2)) }++          else if associate_right then do+                { new_p <- mkConOpPatRn op2 fix2 p12 p2+                ; return (ConPatIn op1 (InfixCon p11 (cL loc new_p))) }+                -- XXX loc right?+          else return (ConPatIn op2 (InfixCon p1 p2)) }++mkConOpPatRn op _ p1 p2                         -- Default case, no rearrangment+  = ASSERT( not_op_pat (unLoc p2) )+    return (ConPatIn op (InfixCon p1 p2))++not_op_pat :: Pat GhcRn -> Bool+not_op_pat (ConPatIn _ (InfixCon _ _)) = False+not_op_pat _                           = True++--------------------------------------+checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM ()+  -- Check precedence of a function binding written infix+  --   eg  a `op` b `C` c = ...+  -- See comments with rnExpr (OpApp ...) about "deriving"++checkPrecMatch op (MG { mg_alts = (dL->L _ ms) })+  = mapM_ check ms+  where+    check (dL->L _ (Match { m_pats = (dL->L l1 p1)+                                   : (dL->L l2 p2)+                                   : _ }))+      = setSrcSpan (combineSrcSpans l1 l2) $+        do checkPrec op p1 False+           checkPrec op p2 True++    check _ = return ()+        -- This can happen.  Consider+        --      a `op` True = ...+        --      op          = ...+        -- The infix flag comes from the first binding of the group+        -- but the second eqn has no args (an error, but not discovered+        -- until the type checker).  So we don't want to crash on the+        -- second eqn.+checkPrecMatch _ (XMatchGroup {}) = panic "checkPrecMatch"++checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()+checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do+    op_fix@(Fixity _ op_prec  op_dir) <- lookupFixityRn op+    op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1)+    let+        inf_ok = op1_prec > op_prec ||+                 (op1_prec == op_prec &&+                  (op1_dir == InfixR && op_dir == InfixR && right ||+                   op1_dir == InfixL && op_dir == InfixL && not right))++        info  = (NormalOp op,          op_fix)+        info1 = (NormalOp (unLoc op1), op1_fix)+        (infol, infor) = if right then (info, info1) else (info1, info)+    unless inf_ok (precParseErr infol infor)++checkPrec _ _ _+  = return ()++-- Check precedence of (arg op) or (op arg) respectively+-- If arg is itself an operator application, then either+--   (a) its precedence must be higher than that of op+--   (b) its precedency & associativity must be the same as that of op+checkSectionPrec :: FixityDirection -> HsExpr GhcPs+        -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM ()+checkSectionPrec direction section op arg+  = case unLoc arg of+        OpApp fix _ op' _ -> go_for_it (get_op op') fix+        NegApp _ _ _      -> go_for_it NegateOp     negateFixity+        _                 -> return ()+  where+    op_name = get_op op+    go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do+          op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name+          unless (op_prec < arg_prec+                  || (op_prec == arg_prec && direction == assoc))+                 (sectionPrecErr (get_op op, op_fix)+                                 (arg_op, arg_fix) section)++-- | Look up the fixity for an operator name.  Be careful to use+-- 'lookupFieldFixityRn' for (possibly ambiguous) record fields+-- (see #13132).+lookupFixityOp :: OpName -> RnM Fixity+lookupFixityOp (NormalOp n)  = lookupFixityRn n+lookupFixityOp NegateOp      = lookupFixityRn negateName+lookupFixityOp (UnboundOp u) = lookupFixityRn (mkUnboundName (unboundVarOcc u))+lookupFixityOp (RecFldOp f)  = lookupFieldFixityRn f+++-- Precedence-related error messages++precParseErr :: (OpName,Fixity) -> (OpName,Fixity) -> RnM ()+precParseErr op1@(n1,_) op2@(n2,_)+  | is_unbound n1 || is_unbound n2+  = return ()     -- Avoid error cascade+  | otherwise+  = addErr $ hang (text "Precedence parsing error")+      4 (hsep [text "cannot mix", ppr_opfix op1, ptext (sLit "and"),+               ppr_opfix op2,+               text "in the same infix expression"])++sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM ()+sectionPrecErr op@(n1,_) arg_op@(n2,_) section+  | is_unbound n1 || is_unbound n2+  = return ()     -- Avoid error cascade+  | otherwise+  = addErr $ vcat [text "The operator" <+> ppr_opfix op <+> ptext (sLit "of a section"),+         nest 4 (sep [text "must have lower precedence than that of the operand,",+                      nest 2 (text "namely" <+> ppr_opfix arg_op)]),+         nest 4 (text "in the section:" <+> quotes (ppr section))]++is_unbound :: OpName -> Bool+is_unbound (NormalOp n) = isUnboundName n+is_unbound UnboundOp{}  = True+is_unbound _            = False++ppr_opfix :: (OpName, Fixity) -> SDoc+ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity)+   where+     pp_op | NegateOp <- op = text "prefix `-'"+           | otherwise      = quotes (ppr op)+++{- *****************************************************+*                                                      *+                 Errors+*                                                      *+***************************************************** -}++unexpectedTypeSigErr :: LHsSigWcType GhcPs -> SDoc+unexpectedTypeSigErr ty+  = hang (text "Illegal type signature:" <+> quotes (ppr ty))+       2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables")++badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM ()+badKindSigErr doc (dL->L loc ty)+  = setSrcSpan loc $ addErr $+    withHsDocContext doc $+    hang (text "Illegal kind signature:" <+> quotes (ppr ty))+       2 (text "Perhaps you intended to use KindSignatures")++dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc+dataKindsErr env thing+  = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing))+       2 (text "Perhaps you intended to use DataKinds")+  where+    pp_what | isRnKindLevel env = text "kind"+            | otherwise          = text "type"++inTypeDoc :: HsType GhcPs -> SDoc+inTypeDoc ty = text "In the type" <+> quotes (ppr ty)++warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM ()+warnUnusedForAll in_doc (dL->L loc tv) used_names+  = whenWOptM Opt_WarnUnusedForalls $+    unless (hsTyVarName tv `elemNameSet` used_names) $+    addWarnAt (Reason Opt_WarnUnusedForalls) loc $+    vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)+         , in_doc ]++opTyErr :: Outputable a => RdrName -> a -> SDoc+opTyErr op overall_ty+  = hang (text "Illegal operator" <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr overall_ty))+         2 (text "Use TypeOperators to allow operators in types")++{-+************************************************************************+*                                                                      *+      Finding the free type variables of a (HsType RdrName)+*                                                                      *+************************************************************************+++Note [Kind and type-variable binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a type signature we may implicitly bind type/kind variables. For example:+  *   f :: a -> a+      f = ...+    Here we need to find the free type variables of (a -> a),+    so that we know what to quantify++  *   class C (a :: k) where ...+    This binds 'k' in ..., as well as 'a'++  *   f (x :: a -> [a]) = ....+    Here we bind 'a' in ....++  *   f (x :: T a -> T (b :: k)) = ...+    Here we bind both 'a' and the kind variable 'k'++  *   type instance F (T (a :: Maybe k)) = ...a...k...+    Here we want to constrain the kind of 'a', and bind 'k'.++To do that, we need to walk over a type and find its free type/kind variables.+We preserve the left-to-right order of each variable occurrence.+See Note [Ordering of implicit variables].++Clients of this code can remove duplicates with nubL.++Note [Ordering of implicit variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since the advent of -XTypeApplications, GHC makes promises about the ordering+of implicit variable quantification. Specifically, we offer that implicitly+quantified variables (such as those in const :: a -> b -> a, without a `forall`)+will occur in left-to-right order of first occurrence. Here are a few examples:++  const :: a -> b -> a       -- forall a b. ...+  f :: Eq a => b -> a -> a   -- forall a b. ...  contexts are included++  type a <-< b = b -> a+  g :: a <-< b               -- forall a b. ...  type synonyms matter++  class Functor f where+    fmap :: (a -> b) -> f a -> f b   -- forall f a b. ...+    -- The f is quantified by the class, so only a and b are considered in fmap++This simple story is complicated by the possibility of dependency: all variables+must come after any variables mentioned in their kinds.++  typeRep :: Typeable a => TypeRep (a :: k)   -- forall k a. ...++The k comes first because a depends on k, even though the k appears later than+the a in the code. Thus, GHC does ScopedSort on the variables.+See Note [ScopedSort] in Type.++Implicitly bound variables are collected by any function which returns a+FreeKiTyVars, FreeKiTyVarsWithDups, or FreeKiTyVarsNoDups, which notably+includes the `extract-` family of functions (extractHsTysRdrTyVarsDups,+extractHsTyVarBndrsKVs, etc.).+These functions thus promise to keep left-to-right ordering.++Note [Implicit quantification in type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We typically bind type/kind variables implicitly when they are in a kind+annotation on the LHS, for example:++  data Proxy (a :: k) = Proxy+  type KindOf (a :: k) = k++Here 'k' is in the kind annotation of a type variable binding, KindedTyVar, and+we want to implicitly quantify over it.  This is easy: just extract all free+variables from the kind signature. That's what we do in extract_hs_tv_bndrs_kvs++By contrast, on the RHS we can't simply collect *all* free variables. Which of+the following are allowed?++  type TySyn1 = a :: Type+  type TySyn2 = 'Nothing :: Maybe a+  type TySyn3 = 'Just ('Nothing :: Maybe a)+  type TySyn4 = 'Left a :: Either Type a++After some design deliberations (see non-taken alternatives below), the answer+is to reject TySyn1 and TySyn3, but allow TySyn2 and TySyn4, at least for now.+We implicitly quantify over free variables of the outermost kind signature, if+one exists:++  * In TySyn1, the outermost kind signature is (:: Type), and it does not have+    any free variables.+  * In TySyn2, the outermost kind signature is (:: Maybe a), it contains a+    free variable 'a', which we implicitly quantify over.+  * In TySyn3, there is no outermost kind signature. The (:: Maybe a) signature+    is hidden inside 'Just.+  * In TySyn4, the outermost kind signature is (:: Either Type a), it contains+    a free variable 'a', which we implicitly quantify over. That is why we can+    also use it to the left of the double colon: 'Left a++The logic resides in extractHsTyRdrTyVarsKindVars. We use it both for type+synonyms and type family instances.++This is something of a stopgap solution until we can explicitly bind invisible+type/kind variables:++  type TySyn3 :: forall a. Maybe a+  type TySyn3 @a = 'Just ('Nothing :: Maybe a)++Note [Implicit quantification in type synonyms: non-taken alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Alternative I: No quantification+--------------------------------+We could offer no implicit quantification on the RHS, accepting none of the+TySyn<N> examples. The user would have to bind the variables explicitly:++  type TySyn1 a = a :: Type+  type TySyn2 a = 'Nothing :: Maybe a+  type TySyn3 a = 'Just ('Nothing :: Maybe a)+  type TySyn4 a = 'Left a :: Either Type a++However, this would mean that one would have to specify 'a' at call sites every+time, which could be undesired.++Alternative II: Indiscriminate quantification+---------------------------------------------+We could implicitly quantify over all free variables on the RHS just like we do+on the LHS. Then we would infer the following kinds:++  TySyn1 :: forall {a}. Type+  TySyn2 :: forall {a}. Maybe a+  TySyn3 :: forall {a}. Maybe (Maybe a)+  TySyn4 :: forall {a}. Either Type a++This would work fine for TySyn<2,3,4>, but TySyn1 is clearly bogus: the variable+is free-floating, not fixed by anything.++Alternative III: reportFloatingKvs+----------------------------------+We could augment Alternative II by hunting down free-floating variables during+type checking. While viable, this would mean we'd end up accepting this:++  data Prox k (a :: k)+  type T = Prox k++-}++-- See Note [Kind and type-variable binders]+-- These lists are guaranteed to preserve left-to-right ordering of+-- the types the variables were extracted from. See also+-- Note [Ordering of implicit variables].+type FreeKiTyVars = [Located RdrName]++-- | A 'FreeKiTyVars' list that is allowed to have duplicate variables.+type FreeKiTyVarsWithDups = FreeKiTyVars++-- | A 'FreeKiTyVars' list that contains no duplicate variables.+type FreeKiTyVarsNoDups   = FreeKiTyVars++filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars+filterInScope rdr_env = filterOut (inScope rdr_env . unLoc)++filterInScopeM :: FreeKiTyVars -> RnM FreeKiTyVars+filterInScopeM vars+  = do { rdr_env <- getLocalRdrEnv+       ; return (filterInScope rdr_env vars) }++inScope :: LocalRdrEnv -> RdrName -> Bool+inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env++extract_tyarg :: LHsTypeArg GhcPs -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups+extract_tyarg (HsValArg ty) acc = extract_lty ty acc+extract_tyarg (HsTypeArg _ ki) acc = extract_lty ki acc+extract_tyarg (HsArgPar _) acc = acc++extract_tyargs :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups+extract_tyargs args acc = foldr extract_tyarg acc args++extractHsTyArgRdrKiTyVarsDup :: [LHsTypeArg GhcPs] -> FreeKiTyVarsWithDups+extractHsTyArgRdrKiTyVarsDup args+  = extract_tyargs args []++-- | 'extractHsTyRdrTyVars' finds the type/kind variables+--                          of a HsType/HsKind.+-- It's used when making the @forall@s explicit.+-- When the same name occurs multiple times in the types, only the first+-- occurrence is returned.+-- See Note [Kind and type-variable binders]+extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVarsNoDups+extractHsTyRdrTyVars ty+  = nubL (extractHsTyRdrTyVarsDups ty)++-- | 'extractHsTyRdrTyVarsDups' finds the type/kind variables+--                              of a HsType/HsKind.+-- It's used when making the @forall@s explicit.+-- When the same name occurs multiple times in the types, all occurrences+-- are returned.+extractHsTyRdrTyVarsDups :: LHsType GhcPs -> FreeKiTyVarsWithDups+extractHsTyRdrTyVarsDups ty+  = extract_lty ty []++-- | Extracts the free type/kind variables from the kind signature of a HsType.+--   This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k@.+-- When the same name occurs multiple times in the type, only the first+-- occurrence is returned, and the left-to-right order of variables is+-- preserved.+-- See Note [Kind and type-variable binders] and+--     Note [Ordering of implicit variables] and+--     Note [Implicit quantification in type synonyms].+extractHsTyRdrTyVarsKindVars :: LHsType GhcPs -> FreeKiTyVarsNoDups+extractHsTyRdrTyVarsKindVars (unLoc -> ty) =+  case ty of+    HsParTy _ ty -> extractHsTyRdrTyVarsKindVars ty+    HsKindSig _ _ ki -> extractHsTyRdrTyVars ki+    _ -> []++-- | Extracts free type and kind variables from types in a list.+-- When the same name occurs multiple times in the types, all occurrences+-- are returned.+extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> FreeKiTyVarsWithDups+extractHsTysRdrTyVarsDups tys+  = extract_ltys tys []++-- Returns the free kind variables of any explictly-kinded binders, returning+-- variable occurrences in left-to-right order.+-- See Note [Ordering of implicit variables].+-- NB: Does /not/ delete the binders themselves.+--     However duplicates are removed+--     E.g. given  [k1, a:k1, b:k2]+--          the function returns [k1,k2], even though k1 is bound here+extractHsTyVarBndrsKVs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVarsNoDups+extractHsTyVarBndrsKVs tv_bndrs+  = nubL (extract_hs_tv_bndrs_kvs tv_bndrs)++-- Returns the free kind variables in a type family result signature, returning+-- variable occurrences in left-to-right order.+-- See Note [Ordering of implicit variables].+extractRdrKindSigVars :: LFamilyResultSig GhcPs -> [Located RdrName]+extractRdrKindSigVars (dL->L _ resultSig)+  | KindSig _ k                              <- resultSig = extractHsTyRdrTyVars k+  | TyVarSig _ (dL->L _ (KindedTyVar _ _ k)) <- resultSig = extractHsTyRdrTyVars k+  | otherwise =  []++-- Get type/kind variables mentioned in the kind signature, preserving+-- left-to-right order and without duplicates:+--+--  * data T a (b :: k1) :: k2 -> k1 -> k2 -> Type   -- result: [k2,k1]+--  * data T a (b :: k1)                             -- result: []+--+-- See Note [Ordering of implicit variables].+extractDataDefnKindVars :: HsDataDefn GhcPs ->  FreeKiTyVarsNoDups+extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig })+  = maybe [] extractHsTyRdrTyVars ksig+extractDataDefnKindVars (XHsDataDefn _) = panic "extractDataDefnKindVars"++extract_lctxt :: LHsContext GhcPs+              -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups+extract_lctxt ctxt = extract_ltys (unLoc ctxt)++extract_ltys :: [LHsType GhcPs]+             -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups+extract_ltys tys acc = foldr extract_lty acc tys++extract_lty :: LHsType GhcPs+            -> FreeKiTyVarsWithDups -> FreeKiTyVarsWithDups+extract_lty (dL->L _ ty) acc+  = case ty of+      HsTyVar _ _  ltv            -> extract_tv ltv acc+      HsBangTy _ _ ty             -> extract_lty ty acc+      HsRecTy _ flds              -> foldr (extract_lty+                                            . cd_fld_type . unLoc) acc+                                           flds+      HsAppTy _ ty1 ty2           -> extract_lty ty1 $+                                     extract_lty ty2 acc+      HsAppKindTy _ ty k          -> extract_lty ty $+                                     extract_lty k acc+      HsListTy _ ty               -> extract_lty ty acc+      HsTupleTy _ _ tys           -> extract_ltys tys acc+      HsSumTy _ tys               -> extract_ltys tys acc+      HsFunTy _ ty1 ty2           -> extract_lty ty1 $+                                     extract_lty ty2 acc+      HsIParamTy _ _ ty           -> extract_lty ty acc+      HsOpTy _ ty1 tv ty2         -> extract_tv tv $+                                     extract_lty ty1 $+                                     extract_lty ty2 acc+      HsParTy _ ty                -> extract_lty ty acc+      HsSpliceTy {}               -> acc  -- Type splices mention no tvs+      HsDocTy _ ty _              -> extract_lty ty acc+      HsExplicitListTy _ _ tys    -> extract_ltys tys acc+      HsExplicitTupleTy _ tys     -> extract_ltys tys acc+      HsTyLit _ _                 -> acc+      HsStarTy _ _                -> acc+      HsKindSig _ ty ki           -> extract_lty ty $+                                     extract_lty ki acc+      HsForAllTy { hst_bndrs = tvs, hst_body = ty }+                                  -> extract_hs_tv_bndrs tvs acc $+                                     extract_lty ty []+      HsQualTy { hst_ctxt = ctxt, hst_body = ty }+                                  -> extract_lctxt ctxt $+                                     extract_lty ty acc+      XHsType {}                  -> acc+      -- We deal with these separately in rnLHsTypeWithWildCards+      HsWildCardTy {}             -> acc++extractHsTvBndrs :: [LHsTyVarBndr GhcPs]+                 -> FreeKiTyVarsWithDups           -- Free in body+                 -> FreeKiTyVarsWithDups       -- Free in result+extractHsTvBndrs tv_bndrs body_fvs+  = extract_hs_tv_bndrs tv_bndrs [] body_fvs++extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs]+                    -> FreeKiTyVarsWithDups  -- Accumulator+                    -> FreeKiTyVarsWithDups  -- Free in body+                    -> FreeKiTyVarsWithDups+-- In (forall (a :: Maybe e). a -> b) we have+--     'a' is bound by the forall+--     'b' is a free type variable+--     'e' is a free kind variable+extract_hs_tv_bndrs tv_bndrs acc_vars body_vars+  | null tv_bndrs = body_vars ++ acc_vars+  | otherwise = filterOut (`elemRdr` tv_bndr_rdrs) (bndr_vars ++ body_vars) ++ acc_vars+    -- NB: delete all tv_bndr_rdrs from bndr_vars as well as body_vars.+    -- See Note [Kind variable scoping]+  where+    bndr_vars = extract_hs_tv_bndrs_kvs tv_bndrs+    tv_bndr_rdrs = map hsLTyVarLocName tv_bndrs++extract_hs_tv_bndrs_kvs :: [LHsTyVarBndr GhcPs] -> [Located RdrName]+-- Returns the free kind variables of any explictly-kinded binders, returning+-- variable occurrences in left-to-right order.+-- See Note [Ordering of implicit variables].+-- NB: Does /not/ delete the binders themselves.+--     Duplicates are /not/ removed+--     E.g. given  [k1, a:k1, b:k2]+--          the function returns [k1,k2], even though k1 is bound here+extract_hs_tv_bndrs_kvs tv_bndrs =+    foldr extract_lty []+          [k | (dL->L _ (KindedTyVar _ _ k)) <- tv_bndrs]++extract_tv :: Located RdrName+           -> [Located RdrName] -> [Located RdrName]+extract_tv tv acc =+  if isRdrTyVar (unLoc tv) then tv:acc else acc++-- Deletes duplicates in a list of Located things.+--+-- Importantly, this function is stable with respect to the original ordering+-- of things in the list. This is important, as it is a property that GHC+-- relies on to maintain the left-to-right ordering of implicitly quantified+-- type variables.+-- See Note [Ordering of implicit variables].+nubL :: Eq a => [Located a] -> [Located a]+nubL = nubBy eqLocated++elemRdr :: Located RdrName -> [Located RdrName] -> Bool+elemRdr x = any (eqLocated x)
+ compiler/rename/RnUnbound.hs view
@@ -0,0 +1,381 @@+{-++This module contains helper functions for reporting and creating+unbound variables.++-}+module RnUnbound ( mkUnboundName+                 , mkUnboundNameRdr+                 , isUnboundName+                 , reportUnboundName+                 , unknownNameSuggestions+                 , WhereLooking(..)+                 , unboundName+                 , unboundNameX+                 , notInScopeErr ) where++import GhcPrelude++import RdrName+import HscTypes+import TcRnMonad+import Name+import Module+import SrcLoc+import Outputable+import PrelNames ( mkUnboundName, isUnboundName, getUnique)+import Util+import Maybes+import DynFlags+import FastString+import Data.List+import Data.Function ( on )+import UniqDFM (udfmToList)++{-+************************************************************************+*                                                                      *+               What to do when a lookup fails+*                                                                      *+************************************************************************+-}++data WhereLooking = WL_Any        -- Any binding+                  | WL_Global     -- Any top-level binding (local or imported)+                  | WL_LocalTop   -- Any top-level binding in this module+                  | WL_LocalOnly+                        -- Only local bindings+                        -- (pattern synonyms declaractions,+                        -- see Note [Renaming pattern synonym variables])++mkUnboundNameRdr :: RdrName -> Name+mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr)++reportUnboundName :: RdrName -> RnM Name+reportUnboundName rdr = unboundName WL_Any rdr++unboundName :: WhereLooking -> RdrName -> RnM Name+unboundName wl rdr = unboundNameX wl rdr Outputable.empty++unboundNameX :: WhereLooking -> RdrName -> SDoc -> RnM Name+unboundNameX where_look rdr_name extra+  = do  { dflags <- getDynFlags+        ; let show_helpful_errors = gopt Opt_HelpfulErrors dflags+              err = notInScopeErr rdr_name $$ extra+        ; if not show_helpful_errors+          then addErr err+          else do { local_env  <- getLocalRdrEnv+                  ; global_env <- getGlobalRdrEnv+                  ; impInfo <- getImports+                  ; currmod <- getModule+                  ; hpt <- getHpt+                  ; let suggestions = unknownNameSuggestions_ where_look+                          dflags hpt currmod global_env local_env impInfo+                          rdr_name+                  ; addErr (err $$ suggestions) }+        ; return (mkUnboundNameRdr rdr_name) }++notInScopeErr :: RdrName -> SDoc+notInScopeErr rdr_name+  = hang (text "Not in scope:")+       2 (what <+> quotes (ppr rdr_name))+  where+    what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))++type HowInScope = Either SrcSpan ImpDeclSpec+     -- Left loc    =>  locally bound at loc+     -- Right ispec =>  imported as specified by ispec+++-- | Called from the typechecker (TcErrors) when we find an unbound variable+unknownNameSuggestions :: DynFlags+                       -> HomePackageTable -> Module+                       -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails+                       -> RdrName -> SDoc+unknownNameSuggestions = unknownNameSuggestions_ WL_Any++unknownNameSuggestions_ :: WhereLooking -> DynFlags+                       -> HomePackageTable -> Module+                       -> GlobalRdrEnv -> LocalRdrEnv -> ImportAvails+                       -> RdrName -> SDoc+unknownNameSuggestions_ where_look dflags hpt curr_mod global_env local_env+                          imports tried_rdr_name =+    similarNameSuggestions where_look dflags global_env local_env tried_rdr_name $$+    importSuggestions where_look global_env hpt+                      curr_mod imports tried_rdr_name $$+    extensionSuggestions tried_rdr_name+++similarNameSuggestions :: WhereLooking -> DynFlags+                        -> GlobalRdrEnv -> LocalRdrEnv+                        -> RdrName -> SDoc+similarNameSuggestions where_look dflags global_env+                        local_env tried_rdr_name+  = case suggest of+      []  -> Outputable.empty+      [p] -> perhaps <+> pp_item p+      ps  -> sep [ perhaps <+> text "one of these:"+                 , nest 2 (pprWithCommas pp_item ps) ]+  where+    all_possibilities :: [(String, (RdrName, HowInScope))]+    all_possibilities+       =  [ (showPpr dflags r, (r, Left loc))+          | (r,loc) <- local_possibilities local_env ]+       ++ [ (showPpr dflags r, rp) | (r, rp) <- global_possibilities global_env ]++    suggest = fuzzyLookup (showPpr dflags tried_rdr_name) all_possibilities+    perhaps = text "Perhaps you meant"++    pp_item :: (RdrName, HowInScope) -> SDoc+    pp_item (rdr, Left loc) = pp_ns rdr <+> quotes (ppr rdr) <+> loc' -- Locally defined+        where loc' = case loc of+                     UnhelpfulSpan l -> parens (ppr l)+                     RealSrcSpan l -> parens (text "line" <+> int (srcSpanStartLine l))+    pp_item (rdr, Right is) = pp_ns rdr <+> quotes (ppr rdr) <+>   -- Imported+                              parens (text "imported from" <+> ppr (is_mod is))++    pp_ns :: RdrName -> SDoc+    pp_ns rdr | ns /= tried_ns = pprNameSpace ns+              | otherwise      = Outputable.empty+      where ns = rdrNameSpace rdr++    tried_occ     = rdrNameOcc tried_rdr_name+    tried_is_sym  = isSymOcc tried_occ+    tried_ns      = occNameSpace tried_occ+    tried_is_qual = isQual tried_rdr_name++    correct_name_space occ =  nameSpacesRelated (occNameSpace occ) tried_ns+                           && isSymOcc occ == tried_is_sym+        -- Treat operator and non-operators as non-matching+        -- This heuristic avoids things like+        --      Not in scope 'f'; perhaps you meant '+' (from Prelude)++    local_ok = case where_look of { WL_Any -> True+                                  ; WL_LocalOnly -> True+                                  ; _ -> False }+    local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)]+    local_possibilities env+      | tried_is_qual = []+      | not local_ok  = []+      | otherwise     = [ (mkRdrUnqual occ, nameSrcSpan name)+                        | name <- localRdrEnvElts env+                        , let occ = nameOccName name+                        , correct_name_space occ]++    global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))]+    global_possibilities global_env+      | tried_is_qual = [ (rdr_qual, (rdr_qual, how))+                        | gre <- globalRdrEnvElts global_env+                        , isGreOk where_look gre+                        , let name = gre_name gre+                              occ  = nameOccName name+                        , correct_name_space occ+                        , (mod, how) <- qualsInScope gre+                        , let rdr_qual = mkRdrQual mod occ ]++      | otherwise = [ (rdr_unqual, pair)+                    | gre <- globalRdrEnvElts global_env+                    , isGreOk where_look gre+                    , let name = gre_name gre+                          occ  = nameOccName name+                          rdr_unqual = mkRdrUnqual occ+                    , correct_name_space occ+                    , pair <- case (unquals_in_scope gre, quals_only gre) of+                                (how:_, _)    -> [ (rdr_unqual, how) ]+                                ([],    pr:_) -> [ pr ]  -- See Note [Only-quals]+                                ([],    [])   -> [] ]++              -- Note [Only-quals]+              -- The second alternative returns those names with the same+              -- OccName as the one we tried, but live in *qualified* imports+              -- e.g. if you have:+              --+              -- > import qualified Data.Map as Map+              -- > foo :: Map+              --+              -- then we suggest @Map.Map@.++    --------------------+    unquals_in_scope :: GlobalRdrElt -> [HowInScope]+    unquals_in_scope (GRE { gre_name = n, gre_lcl = lcl, gre_imp = is })+      | lcl       = [ Left (nameSrcSpan n) ]+      | otherwise = [ Right ispec+                    | i <- is, let ispec = is_decl i+                    , not (is_qual ispec) ]+++    --------------------+    quals_only :: GlobalRdrElt -> [(RdrName, HowInScope)]+    -- Ones for which *only* the qualified version is in scope+    quals_only (GRE { gre_name = n, gre_imp = is })+      = [ (mkRdrQual (is_as ispec) (nameOccName n), Right ispec)+        | i <- is, let ispec = is_decl i, is_qual ispec ]++-- | Generate helpful suggestions if a qualified name Mod.foo is not in scope.+importSuggestions :: WhereLooking+                  -> GlobalRdrEnv+                  -> HomePackageTable -> Module+                  -> ImportAvails -> RdrName -> SDoc+importSuggestions where_look global_env hpt currMod imports rdr_name+  | WL_LocalOnly <- where_look                 = Outputable.empty+  | not (isQual rdr_name || isUnqual rdr_name) = Outputable.empty+  | null interesting_imports+  , Just name <- mod_name+  , show_not_imported_line name+  = hsep+      [ text "No module named"+      , quotes (ppr name)+      , text "is imported."+      ]+  | is_qualified+  , null helpful_imports+  , [(mod,_)] <- interesting_imports+  = hsep+      [ text "Module"+      , quotes (ppr mod)+      , text "does not export"+      , quotes (ppr occ_name) <> dot+      ]+  | is_qualified+  , null helpful_imports+  , not (null interesting_imports)+  , mods <- map fst interesting_imports+  = hsep+      [ text "Neither"+      , quotedListWithNor (map ppr mods)+      , text "exports"+      , quotes (ppr occ_name) <> dot+      ]+  | [(mod,imv)] <- helpful_imports_non_hiding+  = fsep+      [ text "Perhaps you want to add"+      , quotes (ppr occ_name)+      , text "to the import list"+      , text "in the import of"+      , quotes (ppr mod)+      , parens (ppr (imv_span imv)) <> dot+      ]+  | not (null helpful_imports_non_hiding)+  = fsep+      [ text "Perhaps you want to add"+      , quotes (ppr occ_name)+      , text "to one of these import lists:"+      ]+    $$+    nest 2 (vcat+        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))+        | (mod,imv) <- helpful_imports_non_hiding+        ])+  | [(mod,imv)] <- helpful_imports_hiding+  = fsep+      [ text "Perhaps you want to remove"+      , quotes (ppr occ_name)+      , text "from the explicit hiding list"+      , text "in the import of"+      , quotes (ppr mod)+      , parens (ppr (imv_span imv)) <> dot+      ]+  | not (null helpful_imports_hiding)+  = fsep+      [ text "Perhaps you want to remove"+      , quotes (ppr occ_name)+      , text "from the hiding clauses"+      , text "in one of these imports:"+      ]+    $$+    nest 2 (vcat+        [ quotes (ppr mod) <+> parens (ppr (imv_span imv))+        | (mod,imv) <- helpful_imports_hiding+        ])+  | otherwise+  = Outputable.empty+ where+  is_qualified = isQual rdr_name+  (mod_name, occ_name) = case rdr_name of+    Unqual occ_name        -> (Nothing, occ_name)+    Qual mod_name occ_name -> (Just mod_name, occ_name)+    _                      -> error "importSuggestions: dead code"+++  -- What import statements provide "Mod" at all+  -- or, if this is an unqualified name, are not qualified imports+  interesting_imports = [ (mod, imp)+    | (mod, mod_imports) <- moduleEnvToList (imp_mods imports)+    , Just imp <- return $ pick (importedByUser mod_imports)+    ]++  -- We want to keep only one for each original module; preferably one with an+  -- explicit import list (for no particularly good reason)+  pick :: [ImportedModsVal] -> Maybe ImportedModsVal+  pick = listToMaybe . sortBy (compare `on` prefer) . filter select+    where select imv = case mod_name of Just name -> imv_name imv == name+                                        Nothing   -> not (imv_qualified imv)+          prefer imv = (imv_is_hiding imv, imv_span imv)++  -- Which of these would export a 'foo'+  -- (all of these are restricted imports, because if they were not, we+  -- wouldn't have an out-of-scope error in the first place)+  helpful_imports = filter helpful interesting_imports+    where helpful (_,imv)+            = not . null $ lookupGlobalRdrEnv (imv_all_exports imv) occ_name++  -- Which of these do that because of an explicit hiding list resp. an+  -- explicit import list+  (helpful_imports_hiding, helpful_imports_non_hiding)+    = partition (imv_is_hiding . snd) helpful_imports++  -- See note [When to show/hide the module-not-imported line]+  show_not_imported_line :: ModuleName -> Bool                    -- #15611+  show_not_imported_line modnam+      | modnam `elem` globMods                = False    -- #14225     -- 1+      | moduleName currMod == modnam          = False                  -- 2.1+      | is_last_loaded_mod modnam hpt_uniques = False                  -- 2.2+      | otherwise                             = True+    where+      hpt_uniques = map fst (udfmToList hpt)+      is_last_loaded_mod _ []         = False+      is_last_loaded_mod modnam uniqs = last uniqs == getUnique modnam+      globMods = nub [ mod+                     | gre <- globalRdrEnvElts global_env+                     , isGreOk where_look gre+                     , (mod, _) <- qualsInScope gre+                     ]++extensionSuggestions :: RdrName -> SDoc+extensionSuggestions rdrName+  | rdrName == mkUnqual varName (fsLit "mdo") ||+    rdrName == mkUnqual varName (fsLit "rec")+      = text "Perhaps you meant to use RecursiveDo"+  | otherwise = Outputable.empty++qualsInScope :: GlobalRdrElt -> [(ModuleName, HowInScope)]+-- Ones for which the qualified version is in scope+qualsInScope GRE { gre_name = n, gre_lcl = lcl, gre_imp = is }+      | lcl = case nameModule_maybe n of+                Nothing -> []+                Just m  -> [(moduleName m, Left (nameSrcSpan n))]+      | otherwise = [ (is_as ispec, Right ispec)+                    | i <- is, let ispec = is_decl i ]++isGreOk :: WhereLooking -> GlobalRdrElt -> Bool+isGreOk where_look = case where_look of+                         WL_LocalTop  -> isLocalGRE+                         WL_LocalOnly -> const False+                         _            -> const True++{- Note [When to show/hide the module-not-imported line]           -- #15611+For the error message:+    Not in scope X.Y+    Module X does not export Y+    No module named ‘X’ is imported:+there are 2 cases, where we hide the last "no module is imported" line:+1. If the module X has been imported.+2. If the module X is the current module. There are 2 subcases:+   2.1 If the unknown module name is in a input source file,+       then we can use the getModule function to get the current module name.+       (See test T15611a)+   2.2 If the unknown module name has been entered by the user in GHCi,+       then the getModule function returns something like "interactive:Ghci1",+       and we have to check the current module in the last added entry of+       the HomePackageTable. (See test T15611b)+-}
+ compiler/rename/RnUtils.hs view
@@ -0,0 +1,512 @@+{-++This module contains miscellaneous functions related to renaming.++-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}++module RnUtils (+        checkDupRdrNames, checkShadowedRdrNames,+        checkDupNames, checkDupAndShadowedNames, dupNamesErr,+        checkTupSize,+        addFvRn, mapFvRn, mapMaybeFvRn,+        warnUnusedMatches, warnUnusedTypePatterns,+        warnUnusedTopBinds, warnUnusedLocalBinds,+        checkUnusedRecordWildcard,+        mkFieldEnv,+        unknownSubordinateErr, badQualBndrErr, typeAppErr,+        HsDocContext(..), pprHsDocContext,+        inHsDocContext, withHsDocContext,++        newLocalBndrRn, newLocalBndrsRn,++        bindLocalNames, bindLocalNamesFV,++        addNameClashErrRn, extendTyVarEnvFVRn++)++where+++import GhcPrelude++import HsSyn+import RdrName+import HscTypes+import TcEnv+import TcRnMonad+import Name+import NameSet+import NameEnv+import DataCon+import SrcLoc+import Outputable+import Util+import BasicTypes       ( TopLevelFlag(..) )+import ListSetOps       ( removeDups )+import DynFlags+import FastString+import Control.Monad+import Data.List+import Constants        ( mAX_TUPLE_SIZE )+import qualified Data.List.NonEmpty as NE+import qualified GHC.LanguageExtensions as LangExt++{-+*********************************************************+*                                                      *+\subsection{Binding}+*                                                      *+*********************************************************+-}++newLocalBndrRn :: Located RdrName -> RnM Name+-- Used for non-top-level binders.  These should+-- never be qualified.+newLocalBndrRn (dL->L loc rdr_name)+  | Just name <- isExact_maybe rdr_name+  = return name -- This happens in code generated by Template Haskell+                -- See Note [Binders in Template Haskell] in Convert.hs+  | otherwise+  = do { unless (isUnqual rdr_name)+                (addErrAt loc (badQualBndrErr rdr_name))+       ; uniq <- newUnique+       ; return (mkInternalName uniq (rdrNameOcc rdr_name) loc) }++newLocalBndrsRn :: [Located RdrName] -> RnM [Name]+newLocalBndrsRn = mapM newLocalBndrRn++bindLocalNames :: [Name] -> RnM a -> RnM a+bindLocalNames names enclosed_scope+  = do { lcl_env <- getLclEnv+       ; let th_level  = thLevel (tcl_th_ctxt lcl_env)+             th_bndrs' = extendNameEnvList (tcl_th_bndrs lcl_env)+                           [ (n, (NotTopLevel, th_level)) | n <- names ]+             rdr_env'  = extendLocalRdrEnvList (tcl_rdr lcl_env) names+       ; setLclEnv (lcl_env { tcl_th_bndrs = th_bndrs'+                            , tcl_rdr      = rdr_env' })+                    enclosed_scope }++bindLocalNamesFV :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)+bindLocalNamesFV names enclosed_scope+  = do  { (result, fvs) <- bindLocalNames names enclosed_scope+        ; return (result, delFVs names fvs) }++-------------------------------------++extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars)+extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside++-------------------------------------+checkDupRdrNames :: [Located RdrName] -> RnM ()+-- Check for duplicated names in a binding group+checkDupRdrNames rdr_names_w_loc+  = mapM_ (dupNamesErr getLoc) dups+  where+    (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc++checkDupNames :: [Name] -> RnM ()+-- Check for duplicated names in a binding group+checkDupNames names = check_dup_names (filterOut isSystemName names)+                -- See Note [Binders in Template Haskell] in Convert++check_dup_names :: [Name] -> RnM ()+check_dup_names names+  = mapM_ (dupNamesErr nameSrcSpan) dups+  where+    (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names++---------------------+checkShadowedRdrNames :: [Located RdrName] -> RnM ()+checkShadowedRdrNames loc_rdr_names+  = do { envs <- getRdrEnvs+       ; checkShadowedOccs envs get_loc_occ filtered_rdrs }+  where+    filtered_rdrs = filterOut (isExact . unLoc) loc_rdr_names+                -- See Note [Binders in Template Haskell] in Convert+    get_loc_occ (dL->L loc rdr) = (loc,rdrNameOcc rdr)++checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM ()+checkDupAndShadowedNames envs names+  = do { check_dup_names filtered_names+       ; checkShadowedOccs envs get_loc_occ filtered_names }+  where+    filtered_names = filterOut isSystemName names+                -- See Note [Binders in Template Haskell] in Convert+    get_loc_occ name = (nameSrcSpan name, nameOccName name)++-------------------------------------+checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv)+                  -> (a -> (SrcSpan, OccName))+                  -> [a] -> RnM ()+checkShadowedOccs (global_env,local_env) get_loc_occ ns+  = whenWOptM Opt_WarnNameShadowing $+    do  { traceRn "checkShadowedOccs:shadow" (ppr (map get_loc_occ ns))+        ; mapM_ check_shadow ns }+  where+    check_shadow n+        | startsWithUnderscore occ = return ()  -- Do not report shadowing for "_x"+                                                -- See #3262+        | Just n <- mb_local = complain [text "bound at" <+> ppr (nameSrcLoc n)]+        | otherwise = do { gres' <- filterM is_shadowed_gre gres+                         ; complain (map pprNameProvenance gres') }+        where+          (loc,occ) = get_loc_occ n+          mb_local  = lookupLocalRdrOcc local_env occ+          gres      = lookupGRE_RdrName (mkRdrUnqual occ) global_env+                -- Make an Unqualified RdrName and look that up, so that+                -- we don't find any GREs that are in scope qualified-only++          complain []      = return ()+          complain pp_locs = addWarnAt (Reason Opt_WarnNameShadowing)+                                       loc+                                       (shadowedNameWarn occ pp_locs)++    is_shadowed_gre :: GlobalRdrElt -> RnM Bool+        -- Returns False for record selectors that are shadowed, when+        -- punning or wild-cards are on (cf #2723)+    is_shadowed_gre gre | isRecFldGRE gre+        = do { dflags <- getDynFlags+             ; return $ not (xopt LangExt.RecordPuns dflags+                             || xopt LangExt.RecordWildCards dflags) }+    is_shadowed_gre _other = return True+++{-+************************************************************************+*                                                                      *+\subsection{Free variable manipulation}+*                                                                      *+************************************************************************+-}++-- A useful utility+addFvRn :: FreeVars -> RnM (thing, FreeVars) -> RnM (thing, FreeVars)+addFvRn fvs1 thing_inside = do { (res, fvs2) <- thing_inside+                               ; return (res, fvs1 `plusFV` fvs2) }++mapFvRn :: (a -> RnM (b, FreeVars)) -> [a] -> RnM ([b], FreeVars)+mapFvRn f xs = do stuff <- mapM f xs+                  case unzip stuff of+                      (ys, fvs_s) -> return (ys, plusFVs fvs_s)++mapMaybeFvRn :: (a -> RnM (b, FreeVars)) -> Maybe a -> RnM (Maybe b, FreeVars)+mapMaybeFvRn _ Nothing = return (Nothing, emptyFVs)+mapMaybeFvRn f (Just x) = do { (y, fvs) <- f x; return (Just y, fvs) }++{-+************************************************************************+*                                                                      *+\subsection{Envt utility functions}+*                                                                      *+************************************************************************+-}++warnUnusedTopBinds :: [GlobalRdrElt] -> RnM ()+warnUnusedTopBinds gres+    = whenWOptM Opt_WarnUnusedTopBinds+    $ do env <- getGblEnv+         let isBoot = tcg_src env == HsBootFile+         let noParent gre = case gre_par gre of+                            NoParent -> True+                            _        -> False+             -- Don't warn about unused bindings with parents in+             -- .hs-boot files, as you are sometimes required to give+             -- unused bindings (trac #3449).+             -- HOWEVER, in a signature file, you are never obligated to put a+             -- definition in the main text.  Thus, if you define something+             -- and forget to export it, we really DO want to warn.+             gres' = if isBoot then filter noParent gres+                               else                 gres+         warnUnusedGREs gres'+++-- | Checks to see if we need to warn for -Wunused-record-wildcards or+-- -Wredundant-record-wildcards+checkUnusedRecordWildcard :: SrcSpan+                          -> FreeVars+                          -> Maybe [Name]+                          -> RnM ()+checkUnusedRecordWildcard _ _ Nothing    = return ()+checkUnusedRecordWildcard loc _ (Just [])  = do+  -- Add a new warning if the .. pattern binds no variables+  setSrcSpan loc $ warnRedundantRecordWildcard+checkUnusedRecordWildcard loc fvs (Just dotdot_names) =+  setSrcSpan loc $ warnUnusedRecordWildcard dotdot_names fvs+++-- | Produce a warning when the `..` pattern binds no new+-- variables.+--+-- @+--   data P = P { x :: Int }+--+--   foo (P{x, ..}) = x+-- @+--+-- The `..` here doesn't bind any variables as `x` is already bound.+warnRedundantRecordWildcard :: RnM ()+warnRedundantRecordWildcard =+  whenWOptM Opt_WarnRedundantRecordWildcards+            (addWarn (Reason Opt_WarnRedundantRecordWildcards)+                     redundantWildcardWarning)+++-- | Produce a warning when no variables bound by a `..` pattern are used.+--+-- @+--   data P = P { x :: Int }+--+--   foo (P{..}) = ()+-- @+--+-- The `..` pattern binds `x` but it is not used in the RHS so we issue+-- a warning.+warnUnusedRecordWildcard :: [Name] -> FreeVars -> RnM ()+warnUnusedRecordWildcard ns used_names = do+  let used = filter (`elemNameSet` used_names) ns+  traceRn "warnUnused" (ppr ns $$ ppr used_names $$ ppr used)+  warnIfFlag Opt_WarnUnusedRecordWildcards (null used)+    unusedRecordWildcardWarning++++warnUnusedLocalBinds, warnUnusedMatches, warnUnusedTypePatterns+  :: [Name] -> FreeVars -> RnM ()+warnUnusedLocalBinds   = check_unused Opt_WarnUnusedLocalBinds+warnUnusedMatches      = check_unused Opt_WarnUnusedMatches+warnUnusedTypePatterns = check_unused Opt_WarnUnusedTypePatterns++check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM ()+check_unused flag bound_names used_names+  = whenWOptM flag (warnUnused flag (filterOut (`elemNameSet` used_names)+                                               bound_names))++-------------------------+--      Helpers+warnUnusedGREs :: [GlobalRdrElt] -> RnM ()+warnUnusedGREs gres = mapM_ warnUnusedGRE gres++warnUnused :: WarningFlag -> [Name] -> RnM ()+warnUnused flag names = do+    fld_env <- mkFieldEnv <$> getGlobalRdrEnv+    mapM_ (warnUnused1 flag fld_env) names++warnUnused1 :: WarningFlag -> NameEnv (FieldLabelString, Name) -> Name -> RnM ()+warnUnused1 flag fld_env name+  = when (reportable name occ) $+    addUnusedWarning flag+                     occ (nameSrcSpan name)+                     (text $ "Defined but not used" ++ opt_str)+  where+    occ = case lookupNameEnv fld_env name of+              Just (fl, _) -> mkVarOccFS fl+              Nothing      -> nameOccName name+    opt_str = case flag of+                Opt_WarnUnusedTypePatterns -> " on the right hand side"+                _ -> ""++warnUnusedGRE :: GlobalRdrElt -> RnM ()+warnUnusedGRE gre@(GRE { gre_name = name, gre_lcl = lcl, gre_imp = is })+  | lcl       = do fld_env <- mkFieldEnv <$> getGlobalRdrEnv+                   warnUnused1 Opt_WarnUnusedTopBinds fld_env name+  | otherwise = when (reportable name occ) (mapM_ warn is)+  where+    occ = greOccName gre+    warn spec = addUnusedWarning Opt_WarnUnusedTopBinds occ span msg+        where+           span = importSpecLoc spec+           pp_mod = quotes (ppr (importSpecModule spec))+           msg = text "Imported from" <+> pp_mod <+> ptext (sLit "but not used")++-- | Make a map from selector names to field labels and parent tycon+-- names, to be used when reporting unused record fields.+mkFieldEnv :: GlobalRdrEnv -> NameEnv (FieldLabelString, Name)+mkFieldEnv rdr_env = mkNameEnv [ (gre_name gre, (lbl, par_is (gre_par gre)))+                               | gres <- occEnvElts rdr_env+                               , gre <- gres+                               , Just lbl <- [greLabel gre]+                               ]++-- | Should we report the fact that this 'Name' is unused? The+-- 'OccName' may differ from 'nameOccName' due to+-- DuplicateRecordFields.+reportable :: Name -> OccName -> Bool+reportable name occ+  | isWiredInName name = False    -- Don't report unused wired-in names+                                  -- Otherwise we get a zillion warnings+                                  -- from Data.Tuple+  | otherwise = not (startsWithUnderscore occ)++addUnusedWarning :: WarningFlag -> OccName -> SrcSpan -> SDoc -> RnM ()+addUnusedWarning flag occ span msg+  = addWarnAt (Reason flag) span $+    sep [msg <> colon,+         nest 2 $ pprNonVarNameSpace (occNameSpace occ)+                        <+> quotes (ppr occ)]++unusedRecordWildcardWarning :: SDoc+unusedRecordWildcardWarning =+  wildcardDoc $ text "No variables bound in the record wildcard match are used"++redundantWildcardWarning :: SDoc+redundantWildcardWarning =+  wildcardDoc $ text "Record wildcard does not bind any new variables"++wildcardDoc :: SDoc -> SDoc+wildcardDoc herald =+  herald+    $$ nest 2 (text "Possible fix" <> colon <+> text "omit the"+                                            <+> quotes (text ".."))++addNameClashErrRn :: RdrName -> [GlobalRdrElt] -> RnM ()+addNameClashErrRn rdr_name gres+  | all isLocalGRE gres && not (all isRecFldGRE gres)+               -- If there are two or more *local* defns, we'll have reported+  = return ()  -- that already, and we don't want an error cascade+  | otherwise+  = addErr (vcat [ text "Ambiguous occurrence" <+> quotes (ppr rdr_name)+                 , text "It could refer to"+                 , nest 3 (vcat (msg1 : msgs)) ])+  where+    (np1:nps) = gres+    msg1 =  text "either" <+> ppr_gre np1+    msgs = [text "    or" <+> ppr_gre np | np <- nps]+    ppr_gre gre = sep [ pp_gre_name gre <> comma+                      , pprNameProvenance gre]++    -- When printing the name, take care to qualify it in the same+    -- way as the provenance reported by pprNameProvenance, namely+    -- the head of 'gre_imp'.  Otherwise we get confusing reports like+    --   Ambiguous occurrence ‘null’+    --   It could refer to either ‘T15487a.null’,+    --                            imported from ‘Prelude’ at T15487.hs:1:8-13+    --                     or ...+    -- See #15487+    pp_gre_name gre@(GRE { gre_name = name, gre_par = parent+                         , gre_lcl = lcl, gre_imp = iss })+      | FldParent { par_lbl = Just lbl } <- parent+      = text "the field" <+> quotes (ppr lbl)+      | otherwise+      = quotes (pp_qual <> dot <> ppr (nameOccName name))+      where+        pp_qual | lcl+                = ppr (nameModule name)+                | imp : _ <- iss  -- This 'imp' is the one that+                                  -- pprNameProvenance chooses+                , ImpDeclSpec { is_as = mod } <- is_decl imp+                = ppr mod+                | otherwise+                = pprPanic "addNameClassErrRn" (ppr gre $$ ppr iss)+                  -- Invariant: either 'lcl' is True or 'iss' is non-empty++shadowedNameWarn :: OccName -> [SDoc] -> SDoc+shadowedNameWarn occ shadowed_locs+  = sep [text "This binding for" <+> quotes (ppr occ)+            <+> text "shadows the existing binding" <> plural shadowed_locs,+         nest 2 (vcat shadowed_locs)]+++unknownSubordinateErr :: SDoc -> RdrName -> SDoc+unknownSubordinateErr doc op    -- Doc is "method of class" or+                                -- "field of constructor"+  = quotes (ppr op) <+> text "is not a (visible)" <+> doc+++dupNamesErr :: Outputable n => (n -> SrcSpan) -> NE.NonEmpty n -> RnM ()+dupNamesErr get_loc names+  = addErrAt big_loc $+    vcat [text "Conflicting definitions for" <+> quotes (ppr (NE.head names)),+          locations]+  where+    locs      = map get_loc (NE.toList names)+    big_loc   = foldr1 combineSrcSpans locs+    locations = text "Bound at:" <+> vcat (map ppr (sort locs))++badQualBndrErr :: RdrName -> SDoc+badQualBndrErr rdr_name+  = text "Qualified name in binding position:" <+> ppr rdr_name++typeAppErr :: String -> LHsType GhcPs -> SDoc+typeAppErr what (L _ k)+  = hang (text "Illegal visible" <+> text what <+> text "application"+            <+> quotes (char '@' <> ppr k))+       2 (text "Perhaps you intended to use TypeApplications")++checkTupSize :: Int -> RnM ()+checkTupSize tup_size+  | tup_size <= mAX_TUPLE_SIZE+  = return ()+  | otherwise+  = addErr (sep [text "A" <+> int tup_size <> ptext (sLit "-tuple is too large for GHC"),+                 nest 2 (parens (text "max size is" <+> int mAX_TUPLE_SIZE)),+                 nest 2 (text "Workaround: use nested tuples or define a data type")])+++{-+************************************************************************+*                                                                      *+\subsection{Contexts for renaming errors}+*                                                                      *+************************************************************************+-}++-- AZ:TODO: Change these all to be Name instead of RdrName.+--          Merge TcType.UserTypeContext in to it.+data HsDocContext+  = TypeSigCtx SDoc+  | PatCtx+  | SpecInstSigCtx+  | DefaultDeclCtx+  | ForeignDeclCtx (Located RdrName)+  | DerivDeclCtx+  | RuleCtx FastString+  | TyDataCtx (Located RdrName)+  | TySynCtx (Located RdrName)+  | TyFamilyCtx (Located RdrName)+  | FamPatCtx (Located RdrName)    -- The patterns of a type/data family instance+  | ConDeclCtx [Located Name]+  | ClassDeclCtx (Located RdrName)+  | ExprWithTySigCtx+  | TypBrCtx+  | HsTypeCtx+  | GHCiCtx+  | SpliceTypeCtx (LHsType GhcPs)+  | ClassInstanceCtx+  | GenericCtx SDoc   -- Maybe we want to use this more!++withHsDocContext :: HsDocContext -> SDoc -> SDoc+withHsDocContext ctxt doc = doc $$ inHsDocContext ctxt++inHsDocContext :: HsDocContext -> SDoc+inHsDocContext ctxt = text "In" <+> pprHsDocContext ctxt++pprHsDocContext :: HsDocContext -> SDoc+pprHsDocContext (GenericCtx doc)      = doc+pprHsDocContext (TypeSigCtx doc)      = text "the type signature for" <+> doc+pprHsDocContext PatCtx                = text "a pattern type-signature"+pprHsDocContext SpecInstSigCtx        = text "a SPECIALISE instance pragma"+pprHsDocContext DefaultDeclCtx        = text "a `default' declaration"+pprHsDocContext DerivDeclCtx          = text "a deriving declaration"+pprHsDocContext (RuleCtx name)        = text "the transformation rule" <+> ftext name+pprHsDocContext (TyDataCtx tycon)     = text "the data type declaration for" <+> quotes (ppr tycon)+pprHsDocContext (FamPatCtx tycon)     = text "a type pattern of family instance for" <+> quotes (ppr tycon)+pprHsDocContext (TySynCtx name)       = text "the declaration for type synonym" <+> quotes (ppr name)+pprHsDocContext (TyFamilyCtx name)    = text "the declaration for type family" <+> quotes (ppr name)+pprHsDocContext (ClassDeclCtx name)   = text "the declaration for class" <+> quotes (ppr name)+pprHsDocContext ExprWithTySigCtx      = text "an expression type signature"+pprHsDocContext TypBrCtx              = text "a Template-Haskell quoted type"+pprHsDocContext HsTypeCtx             = text "a type argument"+pprHsDocContext GHCiCtx               = text "GHCi input"+pprHsDocContext (SpliceTypeCtx hs_ty) = text "the spliced type" <+> quotes (ppr hs_ty)+pprHsDocContext ClassInstanceCtx      = text "TcSplice.reifyInstances"++pprHsDocContext (ForeignDeclCtx name)+   = text "the foreign declaration for" <+> quotes (ppr name)+pprHsDocContext (ConDeclCtx [name])+   = text "the definition of data constructor" <+> quotes (ppr name)+pprHsDocContext (ConDeclCtx names)+   = text "the definition of data constructors" <+> interpp'SP names
+ compiler/simplCore/CSE.hs view
@@ -0,0 +1,701 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section{Common subexpression}+-}++{-# LANGUAGE CPP #-}++module CSE (cseProgram, cseOneExpr) where++#include "HsVersions.h"++import GhcPrelude++import CoreSubst+import Var              ( Var )+import VarEnv           ( elemInScopeSet, mkInScopeSet )+import Id               ( Id, idType, isDeadBinder+                        , idInlineActivation, setInlineActivation+                        , zapIdOccInfo, zapIdUsageInfo, idInlinePragma+                        , isJoinId, isJoinId_maybe )+import CoreUtils        ( mkAltExpr, eqExpr+                        , exprIsTickedString+                        , stripTicksE, stripTicksT, mkTicks )+import CoreFVs          ( exprFreeVars )+import Type             ( tyConAppArgs )+import CoreSyn+import Outputable+import BasicTypes+import CoreMap+import Util             ( filterOut )+import Data.List        ( mapAccumL )++{-+                        Simple common sub-expression+                        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we see+        x1 = C a b+        x2 = C x1 b+we build up a reverse mapping:   C a b  -> x1+                                 C x1 b -> x2+and apply that to the rest of the program.++When we then see+        y1 = C a b+        y2 = C y1 b+we replace the C a b with x1.  But then we *dont* want to+add   x1 -> y1  to the mapping.  Rather, we want the reverse, y1 -> x1+so that a subsequent binding+        y2 = C y1 b+will get transformed to C x1 b, and then to x2.++So we carry an extra var->var substitution which we apply *before* looking up in the+reverse mapping.+++Note [Shadowing]+~~~~~~~~~~~~~~~~+We have to be careful about shadowing.+For example, consider+        f = \x -> let y = x+x in+                      h = \x -> x+x+                  in ...++Here we must *not* do CSE on the inner x+x!  The simplifier used to guarantee no+shadowing, but it doesn't any more (it proved too hard), so we clone as we go.+We can simply add clones to the substitution already described.+++Note [CSE for bindings]+~~~~~~~~~~~~~~~~~~~~~~~+Let-bindings have two cases, implemented by addBinding.++* SUBSTITUTE: applies when the RHS is a variable++     let x = y in ...(h x)....++  Here we want to extend the /substitution/ with x -> y, so that the+  (h x) in the body might CSE with an enclosing (let v = h y in ...).+  NB: the substitution maps InIds, so we extend the substitution with+      a binding for the original InId 'x'++  How can we have a variable on the RHS? Doesn't the simplifier inline them?++    - First, the original RHS might have been (g z) which has CSE'd+      with an enclosing (let y = g z in ...).  This is super-important.+      See #5996:+         x1 = C a b+         x2 = C x1 b+         y1 = C a b+         y2 = C y1 b+      Here we CSE y1's rhs to 'x1', and then we must add (y1->x1) to+      the substitution so that we can CSE the binding for y2.++    - Second, we use addBinding for case expression scrutinees too;+      see Note [CSE for case expressions]++* EXTEND THE REVERSE MAPPING: applies in all other cases++     let x = h y in ...(h y)...++  Here we want to extend the /reverse mapping (cs_map)/ so that+  we CSE the (h y) call to x.++  Note that we use EXTEND even for a trivial expression, provided it+  is not a variable or literal. In particular this /includes/ type+  applications. This can be important (#13156); e.g.+     case f @ Int of { r1 ->+     case f @ Int of { r2 -> ...+  Here we want to common-up the two uses of (f @ Int) so we can+  remove one of the case expressions.++  See also Note [Corner case for case expressions] for another+  reason not to use SUBSTITUTE for all trivial expressions.++Notice that+  - The SUBSTITUTE situation extends the substitution (cs_subst)+  - The EXTEND situation extends the reverse mapping (cs_map)++Notice also that in the SUBSTITUTE case we leave behind a binding+  x = y+even though we /also/ carry a substitution x -> y.  Can we just drop+the binding instead?  Well, not at top level! See SimplUtils+Note [Top level and postInlineUnconditionally]; and in any case CSE+applies only to the /bindings/ of the program, and we leave it to the+simplifier to propate effects to the RULES.  Finally, it doesn't seem+worth the effort to discard the nested bindings because the simplifier+will do it next.++Note [CSE for case expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  case scrut_expr of x { ...alts... }+This is very like a strict let-binding+  let !x = scrut_expr in ...+So we use (addBinding x scrut_expr) to process scrut_expr and x, and as a+result all the stuff under Note [CSE for bindings] applies directly.++For example:++* Trivial scrutinee+     f = \x -> case x of wild {+                 (a:as) -> case a of wild1 {+                             (p,q) -> ...(wild1:as)...++  Here, (wild1:as) is morally the same as (a:as) and hence equal to+  wild. But that's not quite obvious.  In the rest of the compiler we+  want to keep it as (wild1:as), but for CSE purpose that's a bad+  idea.++  By using addBinding we add the binding (wild1 -> a) to the substitution,+  which does exactly the right thing.++  (Notice this is exactly backwards to what the simplifier does, which+  is to try to replaces uses of 'a' with uses of 'wild1'.)++  This is the main reason that addBinding is called with a trivial rhs.++* Non-trivial scrutinee+     case (f x) of y { pat -> ...let z = f x in ... }++  By using addBinding we'll add (f x :-> y) to the cs_map, and+  thereby CSE the inner (f x) to y.++Note [CSE for INLINE and NOINLINE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are some subtle interactions of CSE with functions that the user+has marked as INLINE or NOINLINE. (Examples from Roman Leshchinskiy.)+Consider++        yes :: Int  {-# NOINLINE yes #-}+        yes = undefined++        no :: Int   {-# NOINLINE no #-}+        no = undefined++        foo :: Int -> Int -> Int  {-# NOINLINE foo #-}+        foo m n = n++        {-# RULES "foo/no" foo no = id #-}++        bar :: Int -> Int+        bar = foo yes++We do not expect the rule to fire.  But if we do CSE, then we risk+getting yes=no, and the rule does fire.  Actually, it won't because+NOINLINE means that 'yes' will never be inlined, not even if we have+yes=no.  So that's fine (now; perhaps in the olden days, yes=no would+have substituted even if 'yes' was NOINLINE).++But we do need to take care.  Consider++        {-# NOINLINE bar #-}+        bar = <rhs>     -- Same rhs as foo++        foo = <rhs>++If CSE produces+        foo = bar+then foo will never be inlined to <rhs> (when it should be, if <rhs>+is small).  The conclusion here is this:++   We should not add+       <rhs> :-> bar+  to the CSEnv if 'bar' has any constraints on when it can inline;+  that is, if its 'activation' not always active.  Otherwise we+  might replace <rhs> by 'bar', and then later be unable to see that it+  really was <rhs>.++An except to the rule is when the INLINE pragma is not from the user, e.g. from+WorkWrap (see Note [Wrapper activation]). We can tell because noUserInlineSpec+is then true.++Note that we do not (currently) do CSE on the unfolding stored inside+an Id, even if it is a 'stable' unfolding.  That means that when an+unfolding happens, it is always faithful to what the stable unfolding+originally was.++Note [CSE for stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   {-# Unf = Stable (\pq. build blah) #-}+   foo = x++Here 'foo' has a stable unfolding, but its (optimised) RHS is trivial.+(Turns out that this actually happens for the enumFromTo method of+the Integer instance of Enum in GHC.Enum.)  Suppose moreover that foo's+stable unfolding originates from an INLINE or INLINEABLE pragma on foo.+Then we obviously do NOT want to extend the substitution with (foo->x),+because we promised to inline foo as what the user wrote.  See similar+SimplUtils Note [Stable unfoldings and postInlineUnconditionally].++Nor do we want to change the reverse mapping. Suppose we have++   {-# Unf = Stable (\pq. build blah) #-}+   foo = <expr>+   bar = <expr>++There could conceivably be merit in rewriting the RHS of bar:+   bar = foo+but now bar's inlining behaviour will change, and importing+modules might see that.  So it seems dodgy and we don't do it.++Stable unfoldings are also created during worker/wrapper when we decide+that a function's definition is so small that it should always inline.+In this case we still want to do CSE (#13340). Hence the use of+isAnyInlinePragma rather than isStableUnfolding.++Note [Corner case for case expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is another reason that we do not use SUBSTITUTE for+all trivial expressions. Consider+   case x |> co of (y::Array# Int) { ... }++We do not want to extend the substitution with (y -> x |> co); since y+is of unlifted type, this would destroy the let/app invariant if (x |>+co) was not ok-for-speculation.++But surely (x |> co) is ok-for-speculation, becasue it's a trivial+expression, and x's type is also unlifted, presumably.  Well, maybe+not if you are using unsafe casts.  I actually found a case where we+had+   (x :: HValue) |> (UnsafeCo :: HValue ~ Array# Int)++Note [CSE for join points?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must not be naive about join points in CSE:+   join j = e in+   if b then jump j else 1 + e+The expression (1 + jump j) is not good (see Note [Invariants on join points] in+CoreSyn). This seems to come up quite seldom, but it happens (first seen+compiling ppHtml in Haddock.Backends.Xhtml).++We could try and be careful by tracking which join points are still valid at+each subexpression, but since join points aren't allocated or shared, there's+less to gain by trying to CSE them. (#13219)++Note [Look inside join-point binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Another way how CSE for joint points is tricky is++  let join foo x = (x, 42)+      join bar x = (x, 42)+  in … jump foo 1 … jump bar 2 …++naively, CSE would turn this into++  let join foo x = (x, 42)+      join bar = foo+  in … jump foo 1 … jump bar 2 …++but now bar is a join point that claims arity one, but its right-hand side+is not a lambda, breaking the join-point invariant (this was #15002).++So `cse_bind` must zoom past the lambdas of a join point (using+`collectNBinders`) and resume searching for CSE opportunities only in+the body of the join point.++Note [CSE for recursive bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f = \x ... f....+  g = \y ... g ...+where the "..." are identical.  Could we CSE them?  In full generality+with mutual recursion it's quite hard; but for self-recursive bindings+(which are very common) it's rather easy:++* Maintain a separate cs_rec_map, that maps+      (\f. (\x. ...f...) ) -> f+  Note the \f in the domain of the mapping!++* When we come across the binding for 'g', look up (\g. (\y. ...g...))+  Bingo we get a hit.  So we can replace the 'g' binding with+     g = f++We can't use cs_map for this, because the key isn't an expression of+the program; it's a kind of synthetic key for recursive bindings.+++************************************************************************+*                                                                      *+\section{Common subexpression}+*                                                                      *+************************************************************************+-}++cseProgram :: CoreProgram -> CoreProgram+cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds)++cseBind :: TopLevelFlag -> CSEnv -> CoreBind -> (CSEnv, CoreBind)+cseBind toplevel env (NonRec b e)+  = (env2, NonRec b2 e2)+  where+    (env1, b1)       = addBinder env b+    (env2, (b2, e2)) = cse_bind toplevel env1 (b,e) b1++cseBind toplevel env (Rec [(in_id, rhs)])+  | noCSE in_id+  = (env1, Rec [(out_id, rhs')])++  -- See Note [CSE for recursive bindings]+  | Just previous <- lookupCSRecEnv env out_id rhs''+  , let previous' = mkTicks ticks previous+        out_id'   = delayInlining toplevel out_id+  = -- We have a hit in the recursive-binding cache+    (extendCSSubst env1 in_id previous', NonRec out_id' previous')++  | otherwise+  = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')])++  where+    (env1, [out_id]) = addRecBinders env [in_id]+    rhs'  = cseExpr env1 rhs+    rhs'' = stripTicksE tickishFloatable rhs'+    ticks = stripTicksT tickishFloatable rhs'+    id_expr'  = varToCoreExpr out_id+    zapped_id = zapIdUsageInfo out_id++cseBind toplevel env (Rec pairs)+  = (env2, Rec pairs')+  where+    (env1, bndrs1) = addRecBinders env (map fst pairs)+    (env2, pairs') = mapAccumL do_one env1 (zip pairs bndrs1)++    do_one env (pr, b1) = cse_bind toplevel env pr b1++-- | Given a binding of @in_id@ to @in_rhs@, and a fresh name to refer+-- to @in_id@ (@out_id@, created from addBinder or addRecBinders),+-- first try to CSE @in_rhs@, and then add the resulting (possibly CSE'd)+-- binding to the 'CSEnv', so that we attempt to CSE any expressions+-- which are equal to @out_rhs@.+cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr))+cse_bind toplevel env (in_id, in_rhs) out_id+  | isTopLevel toplevel, exprIsTickedString in_rhs+      -- See Note [Take care with literal strings]+  = (env', (out_id', in_rhs))++  | Just arity <- isJoinId_maybe in_id+      -- See Note [Look inside join-point binders]+  = let (params, in_body) = collectNBinders arity in_rhs+        (env', params') = addBinders env params+        out_body = tryForCSE env' in_body+    in (env, (out_id, mkLams params' out_body))++  | otherwise+  = (env', (out_id'', out_rhs))+  where+    (env', out_id') = addBinding env in_id out_id out_rhs+    (cse_done, out_rhs) = try_for_cse env in_rhs+    out_id'' | cse_done  = delayInlining toplevel out_id'+             | otherwise = out_id'++delayInlining :: TopLevelFlag -> Id -> Id+-- Add a NOINLINE[2] if the Id doesn't have an INLNE pragma already+delayInlining top_lvl bndr+  | isTopLevel top_lvl+  , isAlwaysActive (idInlineActivation bndr)+  = bndr `setInlineActivation` activeAfterInitial+  | otherwise+  = bndr++addBinding :: CSEnv                      -- Includes InId->OutId cloning+           -> InVar                      -- Could be a let-bound type+           -> OutId -> OutExpr           -- Processed binding+           -> (CSEnv, OutId)             -- Final env, final bndr+-- Extend the CSE env with a mapping [rhs -> out-id]+-- unless we can instead just substitute [in-id -> rhs]+--+-- It's possible for the binder to be a type variable (see+-- Note [Type-let] in CoreSyn), in which case we can just substitute.+addBinding env in_id out_id rhs'+  | not (isId in_id) = (extendCSSubst env in_id rhs',     out_id)+  | noCSE in_id      = (env,                              out_id)+  | use_subst        = (extendCSSubst env in_id rhs',     out_id)+  | otherwise        = (extendCSEnv env rhs' id_expr', zapped_id)+  where+    id_expr'  = varToCoreExpr out_id+    zapped_id = zapIdUsageInfo out_id+       -- Putting the Id into the cs_map makes it possible that+       -- it'll become shared more than it is now, which would+       -- invalidate (the usage part of) its demand info.+       --    This caused #100218.+       -- Easiest thing is to zap the usage info; subsequently+       -- performing late demand-analysis will restore it.  Don't zap+       -- the strictness info; it's not necessary to do so, and losing+       -- it is bad for performance if you don't do late demand+       -- analysis++    -- Should we use SUBSTITUTE or EXTEND?+    -- See Note [CSE for bindings]+    use_subst = case rhs' of+                   Var {} -> True+                   _      -> False++-- | Given a binder `let x = e`, this function+-- determines whether we should add `e -> x` to the cs_map+noCSE :: InId -> Bool+noCSE id =  not (isAlwaysActive (idInlineActivation id)) &&+            not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma id)))+             -- See Note [CSE for INLINE and NOINLINE]+         || isAnyInlinePragma (idInlinePragma id)+             -- See Note [CSE for stable unfoldings]+         || isJoinId id+             -- See Note [CSE for join points?]+++{- Note [Take care with literal strings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this example:++  x = "foo"#+  y = "foo"#+  ...x...y...x...y....++We would normally turn this into:++  x = "foo"#+  y = x+  ...x...x...x...x....++But this breaks an invariant of Core, namely that the RHS of a top-level binding+of type Addr# must be a string literal, not another variable. See Note+[CoreSyn top-level string literals] in CoreSyn.++For this reason, we special case top-level bindings to literal strings and leave+the original RHS unmodified. This produces:++  x = "foo"#+  y = "foo"#+  ...x...x...x...x....++Now 'y' will be discarded as dead code, and we are done.++The net effect is that for the y-binding we want to+  - Use SUBSTITUTE, by extending the substitution with  y :-> x+  - but leave the original binding for y undisturbed++This is done by cse_bind.  I got it wrong the first time (#13367).++Note [Delay inlining after CSE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose (#15445) we have+   f,g :: Num a => a -> a+   f x = ...f (x-1).....+   g y = ...g (y-1) ....++and we make some specialisations of 'g', either automatically, or via+a SPECIALISE pragma.  Then CSE kicks in and notices that the RHSs of+'f' and 'g' are identical, so we get+   f x = ...f (x-1)...+   g = f+   {-# RULES g @Int _ = $sg #-}++Now there is terrible danger that, in an importing module, we'll inline+'g' before we have a chance to run its specialisation!++Solution: during CSE, when adding a top-level+  g = f+binding after a "hit" in the CSE cache, add a NOINLINE[2] activation+to it, to ensure it's not inlined right away.++Why top level only?  Because for nested bindings we are already past+phase 2 and will never return there.+-}++tryForCSE :: CSEnv -> InExpr -> OutExpr+tryForCSE env expr = snd (try_for_cse env expr)++try_for_cse :: CSEnv -> InExpr -> (Bool, OutExpr)+-- (False, e') => We did not CSE the entire expression,+--                but we might have CSE'd some sub-expressions,+--                yielding e'+--+-- (True, te') => We CSE'd the entire expression,+--                yielding the trivial expression te'+try_for_cse env expr+  | Just e <- lookupCSEnv env expr'' = (True,  mkTicks ticks e)+  | otherwise                        = (False, expr')+    -- The varToCoreExpr is needed if we have+    --   case e of xco { ...case e of yco { ... } ... }+    -- Then CSE will substitute yco -> xco;+    -- but these are /coercion/ variables+  where+    expr'  = cseExpr env expr+    expr'' = stripTicksE tickishFloatable expr'+    ticks  = stripTicksT tickishFloatable expr'+    -- We don't want to lose the source notes when a common sub+    -- expression gets eliminated. Hence we push all (!) of them on+    -- top of the replaced sub-expression. This is probably not too+    -- useful in practice, but upholds our semantics.++-- | Runs CSE on a single expression.+--+-- This entry point is not used in the compiler itself, but is provided+-- as a convenient entry point for users of the GHC API.+cseOneExpr :: InExpr -> OutExpr+cseOneExpr e = cseExpr env e+  where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) }++cseExpr :: CSEnv -> InExpr -> OutExpr+cseExpr env (Type t)              = Type (substTy (csEnvSubst env) t)+cseExpr env (Coercion c)          = Coercion (substCo (csEnvSubst env) c)+cseExpr _   (Lit lit)             = Lit lit+cseExpr env (Var v)               = lookupSubst env v+cseExpr env (App f a)             = App (cseExpr env f) (tryForCSE env a)+cseExpr env (Tick t e)            = Tick t (cseExpr env e)+cseExpr env (Cast e co)           = Cast (tryForCSE env e) (substCo (csEnvSubst env) co)+cseExpr env (Lam b e)             = let (env', b') = addBinder env b+                                    in Lam b' (cseExpr env' e)+cseExpr env (Let bind e)          = let (env', bind') = cseBind NotTopLevel env bind+                                    in Let bind' (cseExpr env' e)+cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts++cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr+cseCase env scrut bndr ty alts+  = Case scrut1 bndr3 ty' $+    combineAlts alt_env (map cse_alt alts)+  where+    ty' = substTy (csEnvSubst env) ty+    scrut1 = tryForCSE env scrut++    bndr1 = zapIdOccInfo bndr+      -- Zapping the OccInfo is needed because the extendCSEnv+      -- in cse_alt may mean that a dead case binder+      -- becomes alive, and Lint rejects that+    (env1, bndr2)    = addBinder env bndr1+    (alt_env, bndr3) = addBinding env1 bndr bndr2 scrut1+         -- addBinding: see Note [CSE for case expressions]++    con_target :: OutExpr+    con_target = lookupSubst alt_env bndr++    arg_tys :: [OutType]+    arg_tys = tyConAppArgs (idType bndr3)++    -- Given case x of { K y z -> ...K y z... }+    -- CSE K y z into x...+    cse_alt (DataAlt con, args, rhs)+        | not (null args)+                -- ... but don't try CSE if there are no args; it just increases the number+                -- of live vars.  E.g.+                --      case x of { True -> ....True.... }+                -- Don't replace True by x!+                -- Hence the 'null args', which also deal with literals and DEFAULT+        = (DataAlt con, args', tryForCSE new_env rhs)+        where+          (env', args') = addBinders alt_env args+          new_env       = extendCSEnv env' con_expr con_target+          con_expr      = mkAltExpr (DataAlt con) args' arg_tys++    cse_alt (con, args, rhs)+        = (con, args', tryForCSE env' rhs)+        where+          (env', args') = addBinders alt_env args++combineAlts :: CSEnv -> [InAlt] -> [InAlt]+-- See Note [Combine case alternatives]+combineAlts env ((_,bndrs1,rhs1) : rest_alts)+  | all isDeadBinder bndrs1+  = (DEFAULT, [], rhs1) : filtered_alts+  where+    in_scope = substInScope (csEnvSubst env)+    filtered_alts = filterOut identical rest_alts+    identical (_con, bndrs, rhs) = all ok bndrs && eqExpr in_scope rhs1 rhs+    ok bndr = isDeadBinder bndr || not (bndr `elemInScopeSet` in_scope)++combineAlts _ alts = alts  -- Default case++{- Note [Combine case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+combineAlts is just a more heavyweight version of the use of+combineIdenticalAlts in SimplUtils.prepareAlts.  The basic idea is+to transform++    DEFAULT -> e1+    K x     -> e1+    W y z   -> e2+===>+   DEFAULT -> e1+   W y z   -> e2++In the simplifier we use cheapEqExpr, because it is called a lot.+But here in CSE we use the full eqExpr.  After all, two alternatives usually+differ near the root, so it probably isn't expensive to compare the full+alternative.  It seems like the same kind of thing that CSE is supposed+to be doing, which is why I put it here.++I acutally saw some examples in the wild, where some inlining made e1 too+big for cheapEqExpr to catch it.+++************************************************************************+*                                                                      *+\section{The CSE envt}+*                                                                      *+************************************************************************+-}++data CSEnv+  = CS { cs_subst :: Subst  -- Maps InBndrs to OutExprs+            -- The substitution variables to+            -- /trivial/ OutExprs, not arbitrary expressions++       , cs_map   :: CoreMap OutExpr   -- The reverse mapping+            -- Maps a OutExpr to a /trivial/ OutExpr+            -- The key of cs_map is stripped of all Ticks++       , cs_rec_map :: CoreMap OutExpr+            -- See Note [CSE for recursive bindings]+       }++emptyCSEnv :: CSEnv+emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap+                , cs_subst = emptySubst }++lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr+lookupCSEnv (CS { cs_map = csmap }) expr+  = lookupCoreMap csmap expr++extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv+extendCSEnv cse expr triv_expr+  = cse { cs_map = extendCoreMap (cs_map cse) sexpr triv_expr }+  where+    sexpr = stripTicksE tickishFloatable expr++extendCSRecEnv :: CSEnv -> OutId -> OutExpr -> OutExpr -> CSEnv+-- See Note [CSE for recursive bindings]+extendCSRecEnv cse bndr expr triv_expr+  = cse { cs_rec_map = extendCoreMap (cs_rec_map cse) (Lam bndr expr) triv_expr }++lookupCSRecEnv :: CSEnv -> OutId -> OutExpr -> Maybe OutExpr+-- See Note [CSE for recursive bindings]+lookupCSRecEnv (CS { cs_rec_map = csmap }) bndr expr+  = lookupCoreMap csmap (Lam bndr expr)++csEnvSubst :: CSEnv -> Subst+csEnvSubst = cs_subst++lookupSubst :: CSEnv -> Id -> OutExpr+lookupSubst (CS { cs_subst = sub}) x = lookupIdSubst (text "CSE.lookupSubst") sub x++extendCSSubst :: CSEnv -> Id  -> CoreExpr -> CSEnv+extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs }++-- | Add clones to the substitution to deal with shadowing.  See+-- Note [Shadowing] for more details.  You should call this whenever+-- you go under a binder.+addBinder :: CSEnv -> Var -> (CSEnv, Var)+addBinder cse v = (cse { cs_subst = sub' }, v')+                where+                  (sub', v') = substBndr (cs_subst cse) v++addBinders :: CSEnv -> [Var] -> (CSEnv, [Var])+addBinders cse vs = (cse { cs_subst = sub' }, vs')+                where+                  (sub', vs') = substBndrs (cs_subst cse) vs++addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id])+addRecBinders cse vs = (cse { cs_subst = sub' }, vs')+                where+                  (sub', vs') = substRecBndrs (cs_subst cse) vs
+ compiler/simplCore/CallArity.hs view
@@ -0,0 +1,763 @@+--+-- Copyright (c) 2014 Joachim Breitner+--++module CallArity+    ( callArityAnalProgram+    , callArityRHS -- for testing+    ) where++import GhcPrelude++import VarSet+import VarEnv+import DynFlags ( DynFlags )++import BasicTypes+import CoreSyn+import Id+import CoreArity ( typeArity )+import CoreUtils ( exprIsCheap, exprIsTrivial )+import UnVarGraph+import Demand+import Util++import Control.Arrow ( first, second )+++{-+%************************************************************************+%*                                                                      *+              Call Arity Analysis+%*                                                                      *+%************************************************************************++Note [Call Arity: The goal]+~~~~~~~~~~~~~~~~~~~~~~~~~~~++The goal of this analysis is to find out if we can eta-expand a local function,+based on how it is being called. The motivating example is this code,+which comes up when we implement foldl using foldr, and do list fusion:++    let go = \x -> let d = case ... of+                              False -> go (x+1)+                              True  -> id+                   in \z -> d (x + z)+    in go 1 0++If we do not eta-expand `go` to have arity 2, we are going to allocate a lot of+partial function applications, which would be bad.++The function `go` has a type of arity two, but only one lambda is manifest.+Furthermore, an analysis that only looks at the RHS of go cannot be sufficient+to eta-expand go: If `go` is ever called with one argument (and the result used+multiple times), we would be doing the work in `...` multiple times.++So `callArityAnalProgram` looks at the whole let expression to figure out if+all calls are nice, i.e. have a high enough arity. It then stores the result in+the `calledArity` field of the `IdInfo` of `go`, which the next simplifier+phase will eta-expand.++The specification of the `calledArity` field is:++    No work will be lost if you eta-expand me to the arity in `calledArity`.++What we want to know for a variable+-----------------------------------++For every let-bound variable we'd like to know:+  1. A lower bound on the arity of all calls to the variable, and+  2. whether the variable is being called at most once or possible multiple+     times.++It is always ok to lower the arity, or pretend that there are multiple calls.+In particular, "Minimum arity 0 and possible called multiple times" is always+correct.+++What we want to know from an expression+---------------------------------------++In order to obtain that information for variables, we analyze expression and+obtain bits of information:++ I.  The arity analysis:+     For every variable, whether it is absent, or called,+     and if called, which what arity.++ II. The Co-Called analysis:+     For every two variables, whether there is a possibility that both are being+     called.+     We obtain as a special case: For every variables, whether there is a+     possibility that it is being called twice.++For efficiency reasons, we gather this information only for a set of+*interesting variables*, to avoid spending time on, e.g., variables from pattern matches.++The two analysis are not completely independent, as a higher arity can improve+the information about what variables are being called once or multiple times.++Note [Analysis I: The arity analysis]+------------------------------------++The arity analysis is quite straight forward: The information about an+expression is an+    VarEnv Arity+where absent variables are bound to Nothing and otherwise to a lower bound to+their arity.++When we analyze an expression, we analyze it with a given context arity.+Lambdas decrease and applications increase the incoming arity. Analysizing a+variable will put that arity in the environment. In lets or cases all the+results from the various subexpressions are lubed, which takes the point-wise+minimum (considering Nothing an infinity).+++Note [Analysis II: The Co-Called analysis]+------------------------------------------++The second part is more sophisticated. For reasons explained below, it is not+sufficient to simply know how often an expression evaluates a variable. Instead+we need to know which variables are possibly called together.++The data structure here is an undirected graph of variables, which is provided+by the abstract+    UnVarGraph++It is safe to return a larger graph, i.e. one with more edges. The worst case+(i.e. the least useful and always correct result) is the complete graph on all+free variables, which means that anything can be called together with anything+(including itself).++Notation for the following:+C(e)  is the co-called result for e.+G₁∪G₂ is the union of two graphs+fv    is the set of free variables (conveniently the domain of the arity analysis result)+S₁×S₂ is the complete bipartite graph { {a,b} | a ∈ S₁, b ∈ S₂ }+S²    is the complete graph on the set of variables S, S² = S×S+C'(e) is a variant for bound expression:+      If e is called at most once, or it is and stays a thunk (after the analysis),+      it is simply C(e). Otherwise, the expression can be called multiple times+      and we return (fv e)²++The interesting cases of the analysis:+ * Var v:+   No other variables are being called.+   Return {} (the empty graph)+ * Lambda v e, under arity 0:+   This means that e can be evaluated many times and we cannot get+   any useful co-call information.+   Return (fv e)²+ * Case alternatives alt₁,alt₂,...:+   Only one can be execuded, so+   Return (alt₁ ∪ alt₂ ∪...)+ * App e₁ e₂ (and analogously Case scrut alts), with non-trivial e₂:+   We get the results from both sides, with the argument evaluated at most once.+   Additionally, anything called by e₁ can possibly be called with anything+   from e₂.+   Return: C(e₁) ∪ C(e₂) ∪ (fv e₁) × (fv e₂)+ * App e₁ x:+   As this is already in A-normal form, CorePrep will not separately lambda+   bind (and hence share) x. So we conservatively assume multiple calls to x here+   Return: C(e₁) ∪ (fv e₁) × {x} ∪ {(x,x)}+ * Let v = rhs in body:+   In addition to the results from the subexpressions, add all co-calls from+   everything that the body calls together with v to everthing that is called+   by v.+   Return: C'(rhs) ∪ C(body) ∪ (fv rhs) × {v'| {v,v'} ∈ C(body)}+ * Letrec v₁ = rhs₁ ... vₙ = rhsₙ in body+   Tricky.+   We assume that it is really mutually recursive, i.e. that every variable+   calls one of the others, and that this is strongly connected (otherwise we+   return an over-approximation, so that's ok), see note [Recursion and fixpointing].++   Let V = {v₁,...vₙ}.+   Assume that the vs have been analysed with an incoming demand and+   cardinality consistent with the final result (this is the fixed-pointing).+   Again we can use the results from all subexpressions.+   In addition, for every variable vᵢ, we need to find out what it is called+   with (call this set Sᵢ). There are two cases:+    * If vᵢ is a function, we need to go through all right-hand-sides and bodies,+      and collect every variable that is called together with any variable from V:+      Sᵢ = {v' | j ∈ {1,...,n},      {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) }+    * If vᵢ is a thunk, then its rhs is evaluated only once, so we need to+      exclude it from this set:+      Sᵢ = {v' | j ∈ {1,...,n}, j≠i, {v',vⱼ} ∈ C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪ C(body) }+   Finally, combine all this:+   Return: C(body) ∪+           C'(rhs₁) ∪ ... ∪ C'(rhsₙ) ∪+           (fv rhs₁) × S₁) ∪ ... ∪ (fv rhsₙ) × Sₙ)++Using the result: Eta-Expansion+-------------------------------++We use the result of these two analyses to decide whether we can eta-expand the+rhs of a let-bound variable.++If the variable is already a function (exprIsCheap), and all calls to the+variables have a higher arity than the current manifest arity (i.e. the number+of lambdas), expand.++If the variable is a thunk we must be careful: Eta-Expansion will prevent+sharing of work, so this is only safe if there is at most one call to the+function. Therefore, we check whether {v,v} ∈ G.++    Example:++        let n = case .. of .. -- A thunk!+        in n 0 + n 1++    vs.++        let n = case .. of ..+        in case .. of T -> n 0+                      F -> n 1++    We are only allowed to eta-expand `n` if it is going to be called at most+    once in the body of the outer let. So we need to know, for each variable+    individually, that it is going to be called at most once.+++Why the co-call graph?+----------------------++Why is it not sufficient to simply remember which variables are called once and+which are called multiple times? It would be in the previous example, but consider++        let n = case .. of ..+        in case .. of+            True -> let go = \y -> case .. of+                                     True -> go (y + n 1)+                                     False > n+                    in go 1+            False -> n++vs.++        let n = case .. of ..+        in case .. of+            True -> let go = \y -> case .. of+                                     True -> go (y+1)+                                     False > n+                    in go 1+            False -> n++In both cases, the body and the rhs of the inner let call n at most once.+But only in the second case that holds for the whole expression! The+crucial difference is that in the first case, the rhs of `go` can call+*both* `go` and `n`, and hence can call `n` multiple times as it recurses,+while in the second case find out that `go` and `n` are not called together.+++Why co-call information for functions?+--------------------------------------++Although for eta-expansion we need the information only for thunks, we still+need to know whether functions are being called once or multiple times, and+together with what other functions.++    Example:++        let n = case .. of ..+            f x = n (x+1)+        in f 1 + f 2++    vs.++        let n = case .. of ..+            f x = n (x+1)+        in case .. of T -> f 0+                      F -> f 1++    Here, the body of f calls n exactly once, but f itself is being called+    multiple times, so eta-expansion is not allowed.+++Note [Analysis type signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The work-hourse of the analysis is the function `callArityAnal`, with the+following type:++    type CallArityRes = (UnVarGraph, VarEnv Arity)+    callArityAnal ::+        Arity ->  -- The arity this expression is called with+        VarSet -> -- The set of interesting variables+        CoreExpr ->  -- The expression to analyse+        (CallArityRes, CoreExpr)++and the following specification:++  ((coCalls, callArityEnv), expr') = callArityEnv arity interestingIds expr++                            <=>++  Assume the expression `expr` is being passed `arity` arguments. Then it holds that+    * The domain of `callArityEnv` is a subset of `interestingIds`.+    * Any variable from `interestingIds` that is not mentioned in the `callArityEnv`+      is absent, i.e. not called at all.+    * Every call from `expr` to a variable bound to n in `callArityEnv` has at+      least n value arguments.+    * For two interesting variables `v1` and `v2`, they are not adjacent in `coCalls`,+      then in no execution of `expr` both are being called.+  Furthermore, expr' is expr with the callArity field of the `IdInfo` updated.+++Note [Which variables are interesting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The analysis would quickly become prohibitive expensive if we would analyse all+variables; for most variables we simply do not care about how often they are+called, i.e. variables bound in a pattern match. So interesting are variables that are+ * top-level or let bound+ * and possibly functions (typeArity > 0)++Note [Taking boring variables into account]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++If we decide that the variable bound in `let x = e1 in e2` is not interesting,+the analysis of `e2` will not report anything about `x`. To ensure that+`callArityBind` does still do the right thing we have to take that into account+everytime we would be lookup up `x` in the analysis result of `e2`.+  * Instead of calling lookupCallArityRes, we return (0, True), indicating+    that this variable might be called many times with no arguments.+  * Instead of checking `calledWith x`, we assume that everything can be called+    with it.+  * In the recursive case, when calclulating the `cross_calls`, if there is+    any boring variable in the recursive group, we ignore all co-call-results+    and directly go to a very conservative assumption.++The last point has the nice side effect that the relatively expensive+integration of co-call results in a recursive groups is often skipped. This+helped to avoid the compile time blowup in some real-world code with large+recursive groups (#10293).++Note [Recursion and fixpointing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++For a mutually recursive let, we begin by+ 1. analysing the body, using the same incoming arity as for the whole expression.+ 2. Then we iterate, memoizing for each of the bound variables the last+    analysis call, i.e. incoming arity, whether it is called once, and the CallArityRes.+ 3. We combine the analysis result from the body and the memoized results for+    the arguments (if already present).+ 4. For each variable, we find out the incoming arity and whether it is called+    once, based on the current analysis result. If this differs from the+    memoized results, we re-analyse the rhs and update the memoized table.+ 5. If nothing had to be reanalyzed, we are done.+    Otherwise, repeat from step 3.+++Note [Thunks in recursive groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We never eta-expand a thunk in a recursive group, on the grounds that if it is+part of a recursive group, then it will be called multiple times.++This is not necessarily true, e.g.  it would be safe to eta-expand t2 (but not+t1) in the following code:++  let go x = t1+      t1 = if ... then t2 else ...+      t2 = if ... then go 1 else ...+  in go 0++Detecting this would require finding out what variables are only ever called+from thunks. While this is certainly possible, we yet have to see this to be+relevant in the wild.+++Note [Analysing top-level binds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We can eta-expand top-level-binds if they are not exported, as we see all calls+to them. The plan is as follows: Treat the top-level binds as nested lets around+a body representing “all external calls”, which returns a pessimistic+CallArityRes (the co-call graph is the complete graph, all arityies 0).++Note [Trimming arity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In the Call Arity papers, we are working on an untyped lambda calculus with no+other id annotations, where eta-expansion is always possible. But this is not+the case for Core!+ 1. We need to ensure the invariant+      callArity e <= typeArity (exprType e)+    for the same reasons that exprArity needs this invariant (see Note+    [exprArity invariant] in CoreArity).++    If we are not doing that, a too-high arity annotation will be stored with+    the id, confusing the simplifier later on.++ 2. Eta-expanding a right hand side might invalidate existing annotations. In+    particular, if an id has a strictness annotation of <...><...>b, then+    passing two arguments to it will definitely bottom out, so the simplifier+    will throw away additional parameters. This conflicts with Call Arity! So+    we ensure that we never eta-expand such a value beyond the number of+    arguments mentioned in the strictness signature.+    See #10176 for a real-world-example.++Note [What is a thunk]+~~~~~~~~~~~~~~~~~~~~~~++Originally, everything that is not in WHNF (`exprIsWHNF`) is considered a+thunk, not eta-expanded, to avoid losing any sharing. This is also how the+published papers on Call Arity describe it.++In practice, there are thunks that do a just little work, such as+pattern-matching on a variable, and the benefits of eta-expansion likely+outweigh the cost of doing that repeatedly. Therefore, this implementation of+Call Arity considers everything that is not cheap (`exprIsCheap`) as a thunk.++Note [Call Arity and Join Points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The Call Arity analysis does not care about join points, and treats them just+like normal functions. This is ok.++The analysis *could* make use of the fact that join points are always evaluated+in the same context as the join-binding they are defined in and are always+one-shot, and handle join points separately, as suggested in+https://gitlab.haskell.org/ghc/ghc/issues/13479#note_134870.+This *might* be more efficient (for example, join points would not have to be+considered interesting variables), but it would also add redundant code. So for+now we do not do that.++The simplifier never eta-expands join points (it instead pushes extra arguments from+an eta-expanded context into the join point’s RHS), so the call arity+annotation on join points is not actually used. As it would be equally valid+(though less efficient) to eta-expand join points, this is the simplifier's+choice, and hence Call Arity sets the call arity for join points as well.+-}++-- Main entry point++callArityAnalProgram :: DynFlags -> CoreProgram -> CoreProgram+callArityAnalProgram _dflags binds = binds'+  where+    (_, binds') = callArityTopLvl [] emptyVarSet binds++-- See Note [Analysing top-level-binds]+callArityTopLvl :: [Var] -> VarSet -> [CoreBind] -> (CallArityRes, [CoreBind])+callArityTopLvl exported _ []+    = ( calledMultipleTimes $ (emptyUnVarGraph, mkVarEnv $ [(v, 0) | v <- exported])+      , [] )+callArityTopLvl exported int1 (b:bs)+    = (ae2, b':bs')+  where+    int2 = bindersOf b+    exported' = filter isExportedId int2 ++ exported+    int' = int1 `addInterestingBinds` b+    (ae1, bs') = callArityTopLvl exported' int' bs+    (ae2, b')  = callArityBind (boringBinds b) ae1 int1 b+++callArityRHS :: CoreExpr -> CoreExpr+callArityRHS = snd . callArityAnal 0 emptyVarSet++-- The main analysis function. See Note [Analysis type signature]+callArityAnal ::+    Arity ->  -- The arity this expression is called with+    VarSet -> -- The set of interesting variables+    CoreExpr ->  -- The expression to analyse+    (CallArityRes, CoreExpr)+        -- How this expression uses its interesting variables+        -- and the expression with IdInfo updated++-- The trivial base cases+callArityAnal _     _   e@(Lit _)+    = (emptyArityRes, e)+callArityAnal _     _   e@(Type _)+    = (emptyArityRes, e)+callArityAnal _     _   e@(Coercion _)+    = (emptyArityRes, e)+-- The transparent cases+callArityAnal arity int (Tick t e)+    = second (Tick t) $ callArityAnal arity int e+callArityAnal arity int (Cast e co)+    = second (\e -> Cast e co) $ callArityAnal arity int e++-- The interesting case: Variables, Lambdas, Lets, Applications, Cases+callArityAnal arity int e@(Var v)+    | v `elemVarSet` int+    = (unitArityRes v arity, e)+    | otherwise+    = (emptyArityRes, e)++-- Non-value lambdas are ignored+callArityAnal arity int (Lam v e) | not (isId v)+    = second (Lam v) $ callArityAnal arity (int `delVarSet` v) e++-- We have a lambda that may be called multiple times, so its free variables+-- can all be co-called.+callArityAnal 0     int (Lam v e)+    = (ae', Lam v e')+  where+    (ae, e') = callArityAnal 0 (int `delVarSet` v) e+    ae' = calledMultipleTimes ae+-- We have a lambda that we are calling. decrease arity.+callArityAnal arity int (Lam v e)+    = (ae, Lam v e')+  where+    (ae, e') = callArityAnal (arity - 1) (int `delVarSet` v) e++-- Application. Increase arity for the called expression, nothing to know about+-- the second+callArityAnal arity int (App e (Type t))+    = second (\e -> App e (Type t)) $ callArityAnal arity int e+callArityAnal arity int (App e1 e2)+    = (final_ae, App e1' e2')+  where+    (ae1, e1') = callArityAnal (arity + 1) int e1+    (ae2, e2') = callArityAnal 0           int e2+    -- If the argument is trivial (e.g. a variable), then it will _not_ be+    -- let-bound in the Core to STG transformation (CorePrep actually),+    -- so no sharing will happen here, and we have to assume many calls.+    ae2' | exprIsTrivial e2 = calledMultipleTimes ae2+         | otherwise        = ae2+    final_ae = ae1 `both` ae2'++-- Case expression.+callArityAnal arity int (Case scrut bndr ty alts)+    = -- pprTrace "callArityAnal:Case"+      --          (vcat [ppr scrut, ppr final_ae])+      (final_ae, Case scrut' bndr ty alts')+  where+    (alt_aes, alts') = unzip $ map go alts+    go (dc, bndrs, e) = let (ae, e') = callArityAnal arity int e+                        in  (ae, (dc, bndrs, e'))+    alt_ae = lubRess alt_aes+    (scrut_ae, scrut') = callArityAnal 0 int scrut+    final_ae = scrut_ae `both` alt_ae++-- For lets, use callArityBind+callArityAnal arity int (Let bind e)+  = -- pprTrace "callArityAnal:Let"+    --          (vcat [ppr v, ppr arity, ppr n, ppr final_ae ])+    (final_ae, Let bind' e')+  where+    int_body = int `addInterestingBinds` bind+    (ae_body, e') = callArityAnal arity int_body e+    (final_ae, bind') = callArityBind (boringBinds bind) ae_body int bind++-- Which bindings should we look at?+-- See Note [Which variables are interesting]+isInteresting :: Var -> Bool+isInteresting v = not $ null (typeArity (idType v))++interestingBinds :: CoreBind -> [Var]+interestingBinds = filter isInteresting . bindersOf++boringBinds :: CoreBind -> VarSet+boringBinds = mkVarSet . filter (not . isInteresting) . bindersOf++addInterestingBinds :: VarSet -> CoreBind -> VarSet+addInterestingBinds int bind+    = int `delVarSetList`    bindersOf bind -- Possible shadowing+          `extendVarSetList` interestingBinds bind++-- Used for both local and top-level binds+-- Second argument is the demand from the body+callArityBind :: VarSet -> CallArityRes -> VarSet -> CoreBind -> (CallArityRes, CoreBind)+-- Non-recursive let+callArityBind boring_vars ae_body int (NonRec v rhs)+  | otherwise+  = -- pprTrace "callArityBind:NonRec"+    --          (vcat [ppr v, ppr ae_body, ppr int, ppr ae_rhs, ppr safe_arity])+    (final_ae, NonRec v' rhs')+  where+    is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk]+    -- If v is boring, we will not find it in ae_body, but always assume (0, False)+    boring = v `elemVarSet` boring_vars++    (arity, called_once)+        | boring    = (0, False) -- See Note [Taking boring variables into account]+        | otherwise = lookupCallArityRes ae_body v+    safe_arity | called_once = arity+               | is_thunk    = 0      -- A thunk! Do not eta-expand+               | otherwise   = arity++    -- See Note [Trimming arity]+    trimmed_arity = trimArity v safe_arity++    (ae_rhs, rhs') = callArityAnal trimmed_arity int rhs+++    ae_rhs'| called_once     = ae_rhs+           | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once+           | otherwise       = calledMultipleTimes ae_rhs++    called_by_v = domRes ae_rhs'+    called_with_v+        | boring    = domRes ae_body+        | otherwise = calledWith ae_body v `delUnVarSet` v+    final_ae = addCrossCoCalls called_by_v called_with_v $ ae_rhs' `lubRes` resDel v ae_body++    v' = v `setIdCallArity` trimmed_arity+++-- Recursive let. See Note [Recursion and fixpointing]+callArityBind boring_vars ae_body int b@(Rec binds)+  = -- (if length binds > 300 then+    -- pprTrace "callArityBind:Rec"+    --           (vcat [ppr (Rec binds'), ppr ae_body, ppr int, ppr ae_rhs]) else id) $+    (final_ae, Rec binds')+  where+    -- See Note [Taking boring variables into account]+    any_boring = any (`elemVarSet` boring_vars) [ i | (i, _) <- binds]++    int_body = int `addInterestingBinds` b+    (ae_rhs, binds') = fix initial_binds+    final_ae = bindersOf b `resDelList` ae_rhs++    initial_binds = [(i,Nothing,e) | (i,e) <- binds]++    fix :: [(Id, Maybe (Bool, Arity, CallArityRes), CoreExpr)] -> (CallArityRes, [(Id, CoreExpr)])+    fix ann_binds+        | -- pprTrace "callArityBind:fix" (vcat [ppr ann_binds, ppr any_change, ppr ae]) $+          any_change+        = fix ann_binds'+        | otherwise+        = (ae, map (\(i, _, e) -> (i, e)) ann_binds')+      where+        aes_old = [ (i,ae) | (i, Just (_,_,ae), _) <- ann_binds ]+        ae = callArityRecEnv any_boring aes_old ae_body++        rerun (i, mbLastRun, rhs)+            | i `elemVarSet` int_body && not (i `elemUnVarSet` domRes ae)+            -- No call to this yet, so do nothing+            = (False, (i, Nothing, rhs))++            | Just (old_called_once, old_arity, _) <- mbLastRun+            , called_once == old_called_once+            , new_arity == old_arity+            -- No change, no need to re-analyze+            = (False, (i, mbLastRun, rhs))++            | otherwise+            -- We previously analyzed this with a different arity (or not at all)+            = let is_thunk = not (exprIsCheap rhs) -- see note [What is a thunk]++                  safe_arity | is_thunk    = 0  -- See Note [Thunks in recursive groups]+                             | otherwise   = new_arity++                  -- See Note [Trimming arity]+                  trimmed_arity = trimArity i safe_arity++                  (ae_rhs, rhs') = callArityAnal trimmed_arity int_body rhs++                  ae_rhs' | called_once     = ae_rhs+                          | safe_arity == 0 = ae_rhs -- If it is not a function, its body is evaluated only once+                          | otherwise       = calledMultipleTimes ae_rhs++                  i' = i `setIdCallArity` trimmed_arity++              in (True, (i', Just (called_once, new_arity, ae_rhs'), rhs'))+          where+            -- See Note [Taking boring variables into account]+            (new_arity, called_once) | i `elemVarSet` boring_vars = (0, False)+                                     | otherwise                  = lookupCallArityRes ae i++        (changes, ann_binds') = unzip $ map rerun ann_binds+        any_change = or changes++-- Combining the results from body and rhs, (mutually) recursive case+-- See Note [Analysis II: The Co-Called analysis]+callArityRecEnv :: Bool -> [(Var, CallArityRes)] -> CallArityRes -> CallArityRes+callArityRecEnv any_boring ae_rhss ae_body+    = -- (if length ae_rhss > 300 then pprTrace "callArityRecEnv" (vcat [ppr ae_rhss, ppr ae_body, ppr ae_new]) else id) $+      ae_new+  where+    vars = map fst ae_rhss++    ae_combined = lubRess (map snd ae_rhss) `lubRes` ae_body++    cross_calls+        -- See Note [Taking boring variables into account]+        | any_boring               = completeGraph (domRes ae_combined)+        -- Also, calculating cross_calls is expensive. Simply be conservative+        -- if the mutually recursive group becomes too large.+        | lengthExceeds ae_rhss 25 = completeGraph (domRes ae_combined)+        | otherwise                = unionUnVarGraphs $ map cross_call ae_rhss+    cross_call (v, ae_rhs) = completeBipartiteGraph called_by_v called_with_v+      where+        is_thunk = idCallArity v == 0+        -- What rhs are relevant as happening before (or after) calling v?+        --    If v is a thunk, everything from all the _other_ variables+        --    If v is not a thunk, everything can happen.+        ae_before_v | is_thunk  = lubRess (map snd $ filter ((/= v) . fst) ae_rhss) `lubRes` ae_body+                    | otherwise = ae_combined+        -- What do we want to know from these?+        -- Which calls can happen next to any recursive call.+        called_with_v+            = unionUnVarSets $ map (calledWith ae_before_v) vars+        called_by_v = domRes ae_rhs++    ae_new = first (cross_calls `unionUnVarGraph`) ae_combined++-- See Note [Trimming arity]+trimArity :: Id -> Arity -> Arity+trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig]+  where+    max_arity_by_type = length (typeArity (idType v))+    max_arity_by_strsig+        | isBotRes result_info = length demands+        | otherwise = a++    (demands, result_info) = splitStrictSig (idStrictness v)++---------------------------------------+-- Functions related to CallArityRes --+---------------------------------------++-- Result type for the two analyses.+-- See Note [Analysis I: The arity analysis]+-- and Note [Analysis II: The Co-Called analysis]+type CallArityRes = (UnVarGraph, VarEnv Arity)++emptyArityRes :: CallArityRes+emptyArityRes = (emptyUnVarGraph, emptyVarEnv)++unitArityRes :: Var -> Arity -> CallArityRes+unitArityRes v arity = (emptyUnVarGraph, unitVarEnv v arity)++resDelList :: [Var] -> CallArityRes -> CallArityRes+resDelList vs ae = foldr resDel ae vs++resDel :: Var -> CallArityRes -> CallArityRes+resDel v (g, ae) = (g `delNode` v, ae `delVarEnv` v)++domRes :: CallArityRes -> UnVarSet+domRes (_, ae) = varEnvDom ae++-- In the result, find out the minimum arity and whether the variable is called+-- at most once.+lookupCallArityRes :: CallArityRes -> Var -> (Arity, Bool)+lookupCallArityRes (g, ae) v+    = case lookupVarEnv ae v of+        Just a -> (a, not (g `hasLoopAt` v))+        Nothing -> (0, False)++calledWith :: CallArityRes -> Var -> UnVarSet+calledWith (g, _) v = neighbors g v++addCrossCoCalls :: UnVarSet -> UnVarSet -> CallArityRes -> CallArityRes+addCrossCoCalls set1 set2 = first (completeBipartiteGraph set1 set2 `unionUnVarGraph`)++-- Replaces the co-call graph by a complete graph (i.e. no information)+calledMultipleTimes :: CallArityRes -> CallArityRes+calledMultipleTimes res = first (const (completeGraph (domRes res))) res++-- Used for application and cases+both :: CallArityRes -> CallArityRes -> CallArityRes+both r1 r2 = addCrossCoCalls (domRes r1) (domRes r2) $ r1 `lubRes` r2++-- Used when combining results from alternative cases; take the minimum+lubRes :: CallArityRes -> CallArityRes -> CallArityRes+lubRes (g1, ae1) (g2, ae2) = (g1 `unionUnVarGraph` g2, ae1 `lubArityEnv` ae2)++lubArityEnv :: VarEnv Arity -> VarEnv Arity -> VarEnv Arity+lubArityEnv = plusVarEnv_C min++lubRess :: [CallArityRes] -> CallArityRes+lubRess = foldl' lubRes emptyArityRes
+ compiler/simplCore/Exitify.hs view
@@ -0,0 +1,499 @@+module Exitify ( exitifyProgram ) where++{-+Note [Exitification]+~~~~~~~~~~~~~~~~~~~~++This module implements Exitification. The goal is to pull as much code out of+recursive functions as possible, as the simplifier is better at inlining into+call-sites that are not in recursive functions.++Example:++  let t = foo bar+  joinrec go 0     x y = t (x*x)+          go (n-1) x y = jump go (n-1) (x+y)+  in …++We’d like to inline `t`, but that does not happen: Because t is a thunk and is+used in a recursive function, doing so might lose sharing in general. In+this case, however, `t` is on the _exit path_ of `go`, so called at most once.+How do we make this clearly visible to the simplifier?++A code path (i.e., an expression in a tail-recursive position) in a recursive+function is an exit path if it does not contain a recursive call. We can bind+this expression outside the recursive function, as a join-point.++Example result:++  let t = foo bar+  join exit x = t (x*x)+  joinrec go 0     x y = jump exit x+          go (n-1) x y = jump go (n-1) (x+y)+  in …++Now `t` is no longer in a recursive function, and good things happen!+-}++import GhcPrelude+import Var+import Id+import IdInfo+import CoreSyn+import CoreUtils+import State+import Unique+import VarSet+import VarEnv+import CoreFVs+import FastString+import Type+import Util( mapSnd )++import Data.Bifunctor+import Control.Monad++-- | Traverses the AST, simply to find all joinrecs and call 'exitify' on them.+-- The really interesting function is exitifyRec+exitifyProgram :: CoreProgram -> CoreProgram+exitifyProgram binds = map goTopLvl binds+  where+    goTopLvl (NonRec v e) = NonRec v (go in_scope_toplvl e)+    goTopLvl (Rec pairs) = Rec (map (second (go in_scope_toplvl)) pairs)+      -- Top-level bindings are never join points++    in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds++    go :: InScopeSet -> CoreExpr -> CoreExpr+    go _    e@(Var{})       = e+    go _    e@(Lit {})      = e+    go _    e@(Type {})     = e+    go _    e@(Coercion {}) = e+    go in_scope (Cast e' c) = Cast (go in_scope e') c+    go in_scope (Tick t e') = Tick t (go in_scope e')+    go in_scope (App e1 e2) = App (go in_scope e1) (go in_scope e2)++    go in_scope (Lam v e')+      = Lam v (go in_scope' e')+      where in_scope' = in_scope `extendInScopeSet` v++    go in_scope (Case scrut bndr ty alts)+      = Case (go in_scope scrut) bndr ty (map go_alt alts)+      where+        in_scope1 = in_scope `extendInScopeSet` bndr+        go_alt (dc, pats, rhs) = (dc, pats, go in_scope' rhs)+           where in_scope' = in_scope1 `extendInScopeSetList` pats++    go in_scope (Let (NonRec bndr rhs) body)+      = Let (NonRec bndr (go in_scope rhs)) (go in_scope' body)+      where+        in_scope' = in_scope `extendInScopeSet` bndr++    go in_scope (Let (Rec pairs) body)+      | is_join_rec = mkLets (exitifyRec in_scope' pairs') body'+      | otherwise   = Let (Rec pairs') body'+      where+        is_join_rec = any (isJoinId . fst) pairs+        in_scope'   = in_scope `extendInScopeSetList` bindersOf (Rec pairs)+        pairs'      = mapSnd (go in_scope') pairs+        body'       = go in_scope' body+++-- | State Monad used inside `exitify`+type ExitifyM =  State [(JoinId, CoreExpr)]++-- | Given a recursive group of a joinrec, identifies “exit paths” and binds them as+--   join-points outside the joinrec.+exitifyRec :: InScopeSet -> [(Var,CoreExpr)] -> [CoreBind]+exitifyRec in_scope pairs+  = [ NonRec xid rhs | (xid,rhs) <- exits ] ++ [Rec pairs']+  where+    -- We need the set of free variables of many subexpressions here, so+    -- annotate the AST with them+    -- see Note [Calculating free variables]+    ann_pairs = map (second freeVars) pairs++    -- Which are the recursive calls?+    recursive_calls = mkVarSet $ map fst pairs++    (pairs',exits) = (`runState` []) $ do+        forM ann_pairs $ \(x,rhs) -> do+            -- go past the lambdas of the join point+            let (args, body) = collectNAnnBndrs (idJoinArity x) rhs+            body' <- go args body+            let rhs' = mkLams args body'+            return (x, rhs')++    ---------------------+    -- 'go' is the main working function.+    -- It goes through the RHS (tail-call positions only),+    -- checks if there are no more recursive calls, if so, abstracts over+    -- variables bound on the way and lifts it out as a join point.+    --+    -- ExitifyM is a state monad to keep track of floated binds+    go :: [Var]           -- ^ Variables that are in-scope here, but+                          -- not in scope at the joinrec; that is,+                          -- we must potentially abstract over them.+                          -- Invariant: they are kept in dependency order+       -> CoreExprWithFVs -- ^ Current expression in tail position+       -> ExitifyM CoreExpr++    -- We first look at the expression (no matter what it shape is)+    -- and determine if we can turn it into a exit join point+    go captured ann_e+        | -- An exit expression has no recursive calls+          let fvs = dVarSetToVarSet (freeVarsOf ann_e)+        , disjointVarSet fvs recursive_calls+        = go_exit captured (deAnnotate ann_e) fvs++    -- We could not turn it into a exit joint point. So now recurse+    -- into all expression where eligible exit join points might sit,+    -- i.e. into all tail-call positions:++    -- Case right hand sides are in tail-call position+    go captured (_, AnnCase scrut bndr ty alts) = do+        alts' <- forM alts $ \(dc, pats, rhs) -> do+            rhs' <- go (captured ++ [bndr] ++ pats) rhs+            return (dc, pats, rhs')+        return $ Case (deAnnotate scrut) bndr ty alts'++    go captured (_, AnnLet ann_bind body)+        -- join point, RHS and body are in tail-call position+        | AnnNonRec j rhs <- ann_bind+        , Just join_arity <- isJoinId_maybe j+        = do let (params, join_body) = collectNAnnBndrs join_arity rhs+             join_body' <- go (captured ++ params) join_body+             let rhs' = mkLams params join_body'+             body' <- go (captured ++ [j]) body+             return $ Let (NonRec j rhs') body'++        -- rec join point, RHSs and body are in tail-call position+        | AnnRec pairs <- ann_bind+        , isJoinId (fst (head pairs))+        = do let js = map fst pairs+             pairs' <- forM pairs $ \(j,rhs) -> do+                 let join_arity = idJoinArity j+                     (params, join_body) = collectNAnnBndrs join_arity rhs+                 join_body' <- go (captured ++ js ++ params) join_body+                 let rhs' = mkLams params join_body'+                 return (j, rhs')+             body' <- go (captured ++ js) body+             return $ Let (Rec pairs') body'++        -- normal Let, only the body is in tail-call position+        | otherwise+        = do body' <- go (captured ++ bindersOf bind ) body+             return $ Let bind body'+      where bind = deAnnBind ann_bind++    -- Cannot be turned into an exit join point, but also has no+    -- tail-call subexpression. Nothing to do here.+    go _ ann_e = return (deAnnotate ann_e)++    ---------------------+    go_exit :: [Var]      -- Variables captured locally+            -> CoreExpr   -- An exit expression+            -> VarSet     -- Free vars of the expression+            -> ExitifyM CoreExpr+    -- go_exit deals with a tail expression that is floatable+    -- out as an exit point; that is, it mentions no recursive calls+    go_exit captured e fvs+      -- Do not touch an expression that is already a join jump where all arguments+      -- are captured variables. See Note [Idempotency]+      -- But _do_ float join jumps with interesting arguments.+      -- See Note [Jumps can be interesting]+      | (Var f, args) <- collectArgs e+      , isJoinId f+      , all isCapturedVarArg args+      = return e++      -- Do not touch a boring expression (see Note [Interesting expression])+      | not is_interesting+      = return e++      -- Cannot float out if local join points are used, as+      -- we cannot abstract over them+      | captures_join_points+      = return e++      -- We have something to float out!+      | otherwise+      = do { -- Assemble the RHS of the exit join point+             let rhs   = mkLams abs_vars e+                 avoid = in_scope `extendInScopeSetList` captured+             -- Remember this binding under a suitable name+           ; v <- addExit avoid (length abs_vars) rhs+             -- And jump to it from here+           ; return $ mkVarApps (Var v) abs_vars }++      where+        -- Used to detect exit expressoins that are already proper exit jumps+        isCapturedVarArg (Var v) = v `elem` captured+        isCapturedVarArg _ = False++        -- An interesting exit expression has free, non-imported+        -- variables from outside the recursive group+        -- See Note [Interesting expression]+        is_interesting = anyVarSet isLocalId $+                         fvs `minusVarSet` mkVarSet captured++        -- The arguments of this exit join point+        -- See Note [Picking arguments to abstract over]+        abs_vars = snd $ foldr pick (fvs, []) captured+          where+            pick v (fvs', acc) | v `elemVarSet` fvs' = (fvs' `delVarSet` v, zap v : acc)+                               | otherwise           = (fvs',               acc)++        -- We are going to abstract over these variables, so we must+        -- zap any IdInfo they have; see #15005+        -- cf. SetLevels.abstractVars+        zap v | isId v = setIdInfo v vanillaIdInfo+              | otherwise = v++        -- We cannot abstract over join points+        captures_join_points = any isJoinId abs_vars+++-- Picks a new unique, which is disjoint from+--  * the free variables of the whole joinrec+--  * any bound variables (captured)+--  * any exit join points created so far.+mkExitJoinId :: InScopeSet -> Type -> JoinArity -> ExitifyM JoinId+mkExitJoinId in_scope ty join_arity = do+    fs <- get+    let avoid = in_scope `extendInScopeSetList` (map fst fs)+                         `extendInScopeSet` exit_id_tmpl -- just cosmetics+    return (uniqAway avoid exit_id_tmpl)+  where+    exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ty+                    `asJoinId` join_arity++addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId+addExit in_scope join_arity rhs = do+    -- Pick a suitable name+    let ty = exprType rhs+    v <- mkExitJoinId in_scope ty join_arity+    fs <- get+    put ((v,rhs):fs)+    return v++{-+Note [Interesting expression]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not want this to happen:++  joinrec go 0     x y = x+          go (n-1) x y = jump go (n-1) (x+y)+  in …+==>+  join exit x = x+  joinrec go 0     x y = jump exit x+          go (n-1) x y = jump go (n-1) (x+y)+  in …++because the floated exit path (`x`) is simply a parameter of `go`; there are+not useful interactions exposed this way.++Neither do we want this to happen++  joinrec go 0     x y = x+x+          go (n-1) x y = jump go (n-1) (x+y)+  in …+==>+  join exit x = x+x+  joinrec go 0     x y = jump exit x+          go (n-1) x y = jump go (n-1) (x+y)+  in …++where the floated expression `x+x` is a bit more complicated, but still not+intersting.++Expressions are interesting when they move an occurrence of a variable outside+the recursive `go` that can benefit from being obviously called once, for example:+ * a local thunk that can then be inlined (see example in note [Exitification])+ * the parameter of a function, where the demand analyzer then can then+   see that it is called at most once, and hence improve the function’s+   strictness signature++So we only hoist an exit expression out if it mentiones at least one free,+non-imported variable.++Note [Jumps can be interesting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A jump to a join point can be interesting, if its arguments contain free+non-exported variables (z in the following example):++  joinrec go 0     x y = jump j (x+z)+          go (n-1) x y = jump go (n-1) (x+y)+  in …+==>+  join exit x y = jump j (x+z)+  joinrec go 0     x y = jump exit x+          go (n-1) x y = jump go (n-1) (x+y)+++The join point itself can be interesting, even if none if its+arguments have free variables free in the joinrec.  For example++  join j p = case p of (x,y) -> x+y+  joinrec go 0     x y = jump j (x,y)+          go (n-1) x y = jump go (n-1) (x+y) y+  in …++Here, `j` would not be inlined because we do not inline something that looks+like an exit join point (see Note [Do not inline exit join points]). But+if we exitify the 'jump j (x,y)' we get++  join j p = case p of (x,y) -> x+y+  join exit x y = jump j (x,y)+  joinrec go 0     x y = jump exit x y+          go (n-1) x y = jump go (n-1) (x+y) y+  in …++and now 'j' can inline, and we get rid of the pair. Here's another+example (assume `g` to be an imported function that, on its own,+does not make this interesting):++  join j y = map f y+  joinrec go 0     x y = jump j (map g x)+          go (n-1) x y = jump go (n-1) (x+y)+  in …++Again, `j` would not be inlined because we do not inline something that looks+like an exit join point (see Note [Do not inline exit join points]).++But after exitification we have++  join j y = map f y+  join exit x = jump j (map g x)+  joinrec go 0     x y = jump j (map g x)+              go (n-1) x y = jump go (n-1) (x+y)+  in …++and now we can inline `j` and this will allow `map/map` to fire.+++Note [Idempotency]+~~~~~~~~~~~~~~~~~~++We do not want this to happen, where we replace the floated expression with+essentially the same expression:++  join exit x = t (x*x)+  joinrec go 0     x y = jump exit x+          go (n-1) x y = jump go (n-1) (x+y)+  in …+==>+  join exit x = t (x*x)+  join exit' x = jump exit x+  joinrec go 0     x y = jump exit' x+          go (n-1) x y = jump go (n-1) (x+y)+  in …++So when the RHS is a join jump, and all of its arguments are captured variables,+then we leave it in place.++Note that `jump exit x` in this example looks interesting, as `exit` is a free+variable. Therefore, idempotency does not simply follow from floating only+interesting expressions.++Note [Calculating free variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have two options where to annotate the tree with free variables:++ A) The whole tree.+ B) Each individual joinrec as we come across it.++Downside of A: We pay the price on the whole module, even outside any joinrecs.+Downside of B: We pay the price per joinrec, possibly multiple times when+joinrecs are nested.++Further downside of A: If the exitify function returns annotated expressions,+it would have to ensure that the annotations are correct.++We therefore choose B, and calculate the free variables in `exitify`.+++Note [Do not inline exit join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have++  let t = foo bar+  join exit x = t (x*x)+  joinrec go 0     x y = jump exit x+          go (n-1) x y = jump go (n-1) (x+y)+  in …++we do not want the simplifier to simply inline `exit` back in (which it happily+would).++To prevent this, we need to recognize exit join points, and then disable+inlining.++Exit join points, recognizeable using `isExitJoinId` are join points with an+occurence in a recursive group, and can be recognized (after the occurence+analyzer ran!) using `isExitJoinId`.+This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`,+because the lambdas of a non-recursive join point are not considered for+`occ_in_lam`.  For example, in the following code, `j1` is /not/ marked+occ_in_lam, because `j2` is called only once.++  join j1 x = x+1+  join j2 y = join j1 (y+2)++To prevent inlining, we check for isExitJoinId+* In `preInlineUnconditionally` directly.+* In `simplLetUnfolding` we simply give exit join points no unfolding, which+  prevents inlining in `postInlineUnconditionally` and call sites.++Note [Placement of the exitification pass]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+I (Joachim) experimented with multiple positions for the Exitification pass in+the Core2Core pipeline:++ A) Before the `simpl_phases`+ B) Between the `simpl_phases` and the "main" simplifier pass+ C) After demand_analyser+ D) Before the final simplification phase++Here is the table (this is without inlining join exit points in the final+simplifier run):++        Program |                       Allocs                      |                      Instrs+                | ABCD.log     A.log     B.log     C.log     D.log  | ABCD.log     A.log     B.log     C.log     D.log+----------------|---------------------------------------------------|-------------------------------------------------+ fannkuch-redux |   -99.9%     +0.0%    -99.9%    -99.9%    -99.9%  |    -3.9%     +0.5%     -3.0%     -3.9%     -3.9%+          fasta |    -0.0%     +0.0%     +0.0%     -0.0%     -0.0%  |    -8.5%     +0.0%     +0.0%     -0.0%     -8.5%+            fem |     0.0%      0.0%      0.0%      0.0%     +0.0%  |    -2.2%     -0.1%     -0.1%     -2.1%     -2.1%+           fish |     0.0%      0.0%      0.0%      0.0%     +0.0%  |    -3.1%     +0.0%     -1.1%     -1.1%     -0.0%+   k-nucleotide |   -91.3%    -91.0%    -91.0%    -91.3%    -91.3%  |    -6.3%    +11.4%    +11.4%     -6.3%     -6.2%+            scs |    -0.0%     -0.0%     -0.0%     -0.0%     -0.0%  |    -3.4%     -3.0%     -3.1%     -3.3%     -3.3%+         simple |    -6.0%      0.0%     -6.0%     -6.0%     +0.0%  |    -3.4%     +0.0%     -5.2%     -3.4%     -0.1%+  spectral-norm |    -0.0%      0.0%      0.0%     -0.0%     +0.0%  |    -2.7%     +0.0%     -2.7%     -5.4%     -5.4%+----------------|---------------------------------------------------|-------------------------------------------------+            Min |   -95.0%    -91.0%    -95.0%    -95.0%    -95.0%  |    -8.5%     -3.0%     -5.2%     -6.3%     -8.5%+            Max |    +0.2%     +0.2%     +0.2%     +0.2%     +1.5%  |    +0.4%    +11.4%    +11.4%     +0.4%     +1.5%+ Geometric Mean |    -4.7%     -2.1%     -4.7%     -4.7%     -4.6%  |    -0.4%     +0.1%     -0.1%     -0.3%     -0.2%++Position A is disqualified, as it does not get rid of the allocations in+fannkuch-redux.+Position A and B are disqualified because it increases instructions in k-nucleotide.+Positions C and D have their advantages: C decreases allocations in simpl, but D instructions in fasta.++Assuming we have a budget of _one_ run of Exitification, then C wins (but we+could get more from running it multiple times, as seen in fish).++Note [Picking arguments to abstract over]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When we create an exit join point, so we need to abstract over those of its+free variables that are be out-of-scope at the destination of the exit join+point. So we go through the list `captured` and pick those that are actually+free variables of the join point.++We do not just `filter (`elemVarSet` fvs) captured`, as there might be+shadowing, and `captured` may contain multiple variables with the same Unique. I+these cases we want to abstract only over the last occurence, hence the `foldr`+(with emphasis on the `r`). This is #15110.++-}
+ compiler/simplCore/FloatIn.hs view
@@ -0,0 +1,771 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++************************************************************************+*                                                                      *+\section[FloatIn]{Floating Inwards pass}+*                                                                      *+************************************************************************++The main purpose of @floatInwards@ is floating into branches of a+case, so that we don't allocate things, save them on the stack, and+then discover that they aren't needed in the chosen branch.+-}++{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fprof-auto #-}++module FloatIn ( floatInwards ) where++#include "HsVersions.h"++import GhcPrelude++import CoreSyn+import MkCore hiding    ( wrapFloats )+import HscTypes         ( ModGuts(..) )+import CoreUtils+import CoreFVs+import CoreMonad        ( CoreM )+import Id               ( isOneShotBndr, idType, isJoinId, isJoinId_maybe )+import Var+import Type+import VarSet+import Util+import DynFlags+import Outputable+-- import Data.List        ( mapAccumL )+import BasicTypes       ( RecFlag(..), isRec )++{-+Top-level interface function, @floatInwards@.  Note that we do not+actually float any bindings downwards from the top-level.+-}++floatInwards :: ModGuts -> CoreM ModGuts+floatInwards pgm@(ModGuts { mg_binds = binds })+  = do { dflags <- getDynFlags+       ; return (pgm { mg_binds = map (fi_top_bind dflags) binds }) }+  where+    fi_top_bind dflags (NonRec binder rhs)+      = NonRec binder (fiExpr dflags [] (freeVars rhs))+    fi_top_bind dflags (Rec pairs)+      = Rec [ (b, fiExpr dflags [] (freeVars rhs)) | (b, rhs) <- pairs ]+++{-+************************************************************************+*                                                                      *+\subsection{Mail from Andr\'e [edited]}+*                                                                      *+************************************************************************++{\em Will wrote: What??? I thought the idea was to float as far+inwards as possible, no matter what.  This is dropping all bindings+every time it sees a lambda of any kind.  Help! }++You are assuming we DO DO full laziness AFTER floating inwards!  We+have to [not float inside lambdas] if we don't.++If we indeed do full laziness after the floating inwards (we could+check the compilation flags for that) then I agree we could be more+aggressive and do float inwards past lambdas.++Actually we are not doing a proper full laziness (see below), which+was another reason for not floating inwards past a lambda.++This can easily be fixed.  The problem is that we float lets outwards,+but there are a few expressions which are not let bound, like case+scrutinees and case alternatives.  After floating inwards the+simplifier could decide to inline the let and the laziness would be+lost, e.g.++\begin{verbatim}+let a = expensive             ==> \b -> case expensive of ...+in \ b -> case a of ...+\end{verbatim}+The fix is+\begin{enumerate}+\item+to let bind the algebraic case scrutinees (done, I think) and+the case alternatives (except the ones with an+unboxed type)(not done, I think). This is best done in the+SetLevels.hs module, which tags things with their level numbers.+\item+do the full laziness pass (floating lets outwards).+\item+simplify. The simplifier inlines the (trivial) lets that were+ created but were not floated outwards.+\end{enumerate}++With the fix I think Will's suggestion that we can gain even more from+strictness by floating inwards past lambdas makes sense.++We still gain even without going past lambdas, as things may be+strict in the (new) context of a branch (where it was floated to) or+of a let rhs, e.g.+\begin{verbatim}+let a = something            case x of+in case x of                   alt1 -> case something of a -> a + a+     alt1 -> a + a      ==>    alt2 -> b+     alt2 -> b++let a = something           let b = case something of a -> a + a+in let b = a + a        ==> in (b,b)+in (b,b)+\end{verbatim}+Also, even if a is not found to be strict in the new context and is+still left as a let, if the branch is not taken (or b is not entered)+the closure for a is not built.++************************************************************************+*                                                                      *+\subsection{Main floating-inwards code}+*                                                                      *+************************************************************************+-}++type FreeVarSet  = DIdSet+type BoundVarSet = DIdSet++data FloatInBind = FB BoundVarSet FreeVarSet FloatBind+        -- The FreeVarSet is the free variables of the binding.  In the case+        -- of recursive bindings, the set doesn't include the bound+        -- variables.++type FloatInBinds = [FloatInBind]+        -- In reverse dependency order (innermost binder first)++fiExpr :: DynFlags+       -> FloatInBinds      -- Binds we're trying to drop+                            -- as far "inwards" as possible+       -> CoreExprWithFVs   -- Input expr+       -> CoreExpr          -- Result++fiExpr _ to_drop (_, AnnLit lit)     = wrapFloats to_drop (Lit lit)+                                       -- See Note [Dead bindings]+fiExpr _ to_drop (_, AnnType ty)     = ASSERT( null to_drop ) Type ty+fiExpr _ to_drop (_, AnnVar v)       = wrapFloats to_drop (Var v)+fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co)+fiExpr dflags to_drop (_, AnnCast expr (co_ann, co))+  = wrapFloats (drop_here ++ co_drop) $+    Cast (fiExpr dflags e_drop expr) co+  where+    [drop_here, e_drop, co_drop]+      = sepBindsByDropPoint dflags False+          [freeVarsOf expr, freeVarsOfAnn co_ann]+          to_drop++{-+Applications: we do float inside applications, mainly because we+need to get at all the arguments.  The next simplifier run will+pull out any silly ones.+-}++fiExpr dflags to_drop ann_expr@(_,AnnApp {})+  = wrapFloats drop_here $ wrapFloats extra_drop $+    mkTicks ticks $+    mkApps (fiExpr dflags fun_drop ann_fun)+           (zipWith (fiExpr dflags) arg_drops ann_args)+  where+    (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr+    fun_ty  = exprType (deAnnotate ann_fun)+    fun_fvs = freeVarsOf ann_fun+    arg_fvs = map freeVarsOf ann_args++    (drop_here : extra_drop : fun_drop : arg_drops)+       = sepBindsByDropPoint dflags False+                             (extra_fvs : fun_fvs : arg_fvs)+                             to_drop+         -- Shortcut behaviour: if to_drop is empty,+         -- sepBindsByDropPoint returns a suitable bunch of empty+         -- lists without evaluating extra_fvs, and hence without+         -- peering into each argument++    (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args+    extra_fvs0 = case ann_fun of+                   (_, AnnVar _) -> fun_fvs+                   _             -> emptyDVarSet+          -- Don't float the binding for f into f x y z; see Note [Join points]+          -- for why we *can't* do it when f is a join point. (If f isn't a+          -- join point, floating it in isn't especially harmful but it's+          -- useless since the simplifier will immediately float it back out.)++    add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet)+    add_arg (fun_ty, extra_fvs) (_, AnnType ty)+      = (piResultTy fun_ty ty, extra_fvs)++    add_arg (fun_ty, extra_fvs) (arg_fvs, arg)+      | noFloatIntoArg arg arg_ty+      = (res_ty, extra_fvs `unionDVarSet` arg_fvs)+      | otherwise+      = (res_ty, extra_fvs)+      where+       (arg_ty, res_ty) = splitFunTy fun_ty++{- Note [Dead bindings]+~~~~~~~~~~~~~~~~~~~~~~~+At a literal we won't usually have any floated bindings; the+only way that can happen is if the binding wrapped the literal+/in the original input program/.  e.g.+   case x of { DEFAULT -> 1# }+But, while this may be unusual it is not actually wrong, and it did+once happen (#15696).++Note [Do not destroy the let/app invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Watch out for+   f (x +# y)+We don't want to float bindings into here+   f (case ... of { x -> x +# y })+because that might destroy the let/app invariant, which requires+unlifted function arguments to be ok-for-speculation.++Note [Join points]+~~~~~~~~~~~~~~~~~~+Generally, we don't need to worry about join points - there are places we're+not allowed to float them, but since they can't have occurrences in those+places, we're not tempted.++We do need to be careful about jumps, however:++  joinrec j x y z = ... in+  jump j a b c++Previous versions often floated the definition of a recursive function into its+only non-recursive occurrence. But for a join point, this is a disaster:++  (joinrec j x y z = ... in+  jump j) a b c -- wrong!++Every jump must be exact, so the jump to j must have three arguments. Hence+we're careful not to float into the target of a jump (though we can float into+the arguments just fine).++Note [Floating in past a lambda group]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* We must be careful about floating inside a value lambda.+  That risks losing laziness.+  The float-out pass might rescue us, but then again it might not.++* We must be careful about type lambdas too.  At one time we did, and+  there is no risk of duplicating work thereby, but we do need to be+  careful.  In particular, here is a bad case (it happened in the+  cichelli benchmark:+        let v = ...+        in let f = /\t -> \a -> ...+           ==>+        let f = /\t -> let v = ... in \a -> ...+  This is bad as now f is an updatable closure (update PAP)+  and has arity 0.++* Hack alert!  We only float in through one-shot lambdas,+  not (as you might guess) through lone big lambdas.+  Reason: we float *out* past big lambdas (see the test in the Lam+  case of FloatOut.floatExpr) and we don't want to float straight+  back in again.++  It *is* important to float into one-shot lambdas, however;+  see the remarks with noFloatIntoRhs.++So we treat lambda in groups, using the following rule:++ Float in if (a) there is at least one Id,+         and (b) there are no non-one-shot Ids++ Otherwise drop all the bindings outside the group.++This is what the 'go' function in the AnnLam case is doing.++(Join points are handled similarly: a join point is considered one-shot iff+it's non-recursive, so we float only into non-recursive join points.)++Urk! if all are tyvars, and we don't float in, we may miss an+      opportunity to float inside a nested case branch+++Note [Floating coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~+We could, in principle, have a coercion binding like+   case f x of co { DEFAULT -> e1 e2 }+It's not common to have a function that returns a coercion, but nothing+in Core prohibits it.  If so, 'co' might be mentioned in e1 or e2+/only in a type/.  E.g. suppose e1 was+  let (x :: Int |> co) = blah in blah2+++But, with coercions appearing in types, there is a complication: we+might be floating in a "strict let" -- that is, a case. Case expressions+mention their return type. We absolutely can't float a coercion binding+inward to the point that the type of the expression it's about to wrap+mentions the coercion. So we include the union of the sets of free variables+of the types of all the drop points involved. If any of the floaters+bind a coercion variable mentioned in any of the types, that binder must+be dropped right away.++-}++fiExpr dflags to_drop lam@(_, AnnLam _ _)+  | noFloatIntoLam bndrs       -- Dump it all here+     -- NB: Must line up with noFloatIntoRhs (AnnLam...); see #7088+  = wrapFloats to_drop (mkLams bndrs (fiExpr dflags [] body))++  | otherwise           -- Float inside+  = mkLams bndrs (fiExpr dflags to_drop body)++  where+    (bndrs, body) = collectAnnBndrs lam++{-+We don't float lets inwards past an SCC.+        ToDo: keep info on current cc, and when passing+        one, if it is not the same, annotate all lets in binds with current+        cc, change current cc to the new one and float binds into expr.+-}++fiExpr dflags to_drop (_, AnnTick tickish expr)+  | tickish `tickishScopesLike` SoftScope+  = Tick tickish (fiExpr dflags to_drop expr)++  | otherwise -- Wimp out for now - we could push values in+  = wrapFloats to_drop (Tick tickish (fiExpr dflags [] expr))++{-+For @Lets@, the possible ``drop points'' for the \tr{to_drop}+bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,+or~(b2), in each of the RHSs of the pairs of a @Rec@.++Note that we do {\em weird things} with this let's binding.  Consider:+\begin{verbatim}+let+    w = ...+in {+    let v = ... w ...+    in ... v .. w ...+}+\end{verbatim}+Look at the inner \tr{let}.  As \tr{w} is used in both the bind and+body of the inner let, we could panic and leave \tr{w}'s binding where+it is.  But \tr{v} is floatable further into the body of the inner let, and+{\em then} \tr{w} will also be only in the body of that inner let.++So: rather than drop \tr{w}'s binding here, we add it onto the list of+things to drop in the outer let's body, and let nature take its+course.++Note [extra_fvs (1): avoid floating into RHS]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider let x=\y....t... in body.  We do not necessarily want to float+a binding for t into the RHS, because it'll immediately be floated out+again.  (It won't go inside the lambda else we risk losing work.)+In letrec, we need to be more careful still. We don't want to transform+        let x# = y# +# 1#+        in+        letrec f = \z. ...x#...f...+        in ...+into+        letrec f = let x# = y# +# 1# in \z. ...x#...f... in ...+because now we can't float the let out again, because a letrec+can't have unboxed bindings.++So we make "extra_fvs" which is the rhs_fvs of such bindings, and+arrange to dump bindings that bind extra_fvs before the entire let.++Note [extra_fvs (2): free variables of rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  let x{rule mentioning y} = rhs in body+Here y is not free in rhs or body; but we still want to dump bindings+that bind y outside the let.  So we augment extra_fvs with the+idRuleAndUnfoldingVars of x.  No need for type variables, hence not using+idFreeVars.+-}++fiExpr dflags to_drop (_,AnnLet bind body)+  = fiExpr dflags (after ++ new_float : before) body+           -- to_drop is in reverse dependency order+  where+    (before, new_float, after) = fiBind dflags to_drop bind body_fvs+    body_fvs    = freeVarsOf body++{- Note [Floating primops]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We try to float-in a case expression over an unlifted type.  The+motivating example was #5658: in particular, this change allows+array indexing operations, which have a single DEFAULT alternative+without any binders, to be floated inward.++SIMD primops for unpacking SIMD vectors into an unboxed tuple of unboxed+scalars also need to be floated inward, but unpacks have a single non-DEFAULT+alternative that binds the elements of the tuple. We now therefore also support+floating in cases with a single alternative that may bind values.++But there are wrinkles++* Which unlifted cases do we float? See PrimOp.hs+  Note [PrimOp can_fail and has_side_effects] which explains:+   - We can float-in can_fail primops, but we can't float them out.+   - But we can float a has_side_effects primop, but NOT inside a lambda,+     so for now we don't float them at all.+  Hence exprOkForSideEffects++* Because we can float can-fail primops (array indexing, division) inwards+  but not outwards, we must be careful not to transform+     case a /# b of r -> f (F# r)+  ===>+    f (case a /# b of r -> F# r)+  because that creates a new thunk that wasn't there before.  And+  because it can't be floated out (can_fail), the thunk will stay+  there.  Disaster!  (This happened in nofib 'simple' and 'scs'.)++  Solution: only float cases into the branches of other cases, and+  not into the arguments of an application, or the RHS of a let. This+  is somewhat conservative, but it's simple.  And it still hits the+  cases like #5658.   This is implemented in sepBindsByJoinPoint;+  if is_case is False we dump all floating cases right here.++* #14511 is another example of why we want to restrict float-in+  of case-expressions.  Consider+     case indexArray# a n of (# r #) -> writeArray# ma i (f r)+  Now, floating that indexing operation into the (f r) thunk will+  not create any new thunks, but it will keep the array 'a' alive+  for much longer than the programmer expected.++  So again, not floating a case into a let or argument seems like+  the Right Thing++For @Case@, the possible drop points for the 'to_drop'+bindings are:+  (a) inside the scrutinee+  (b) inside one of the alternatives/default (default FVs always /first/!).++-}++fiExpr dflags to_drop (_, AnnCase scrut case_bndr _ [(con,alt_bndrs,rhs)])+  | isUnliftedType (idType case_bndr)+  , exprOkForSideEffects (deAnnotate scrut)+      -- See Note [Floating primops]+  = wrapFloats shared_binds $+    fiExpr dflags (case_float : rhs_binds) rhs+  where+    case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs+                    (FloatCase scrut' case_bndr con alt_bndrs)+    scrut'     = fiExpr dflags scrut_binds scrut+    rhs_fvs    = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs)+    scrut_fvs  = freeVarsOf scrut++    [shared_binds, scrut_binds, rhs_binds]+       = sepBindsByDropPoint dflags False+           [scrut_fvs, rhs_fvs]+           to_drop++fiExpr dflags to_drop (_, AnnCase scrut case_bndr ty alts)+  = wrapFloats drop_here1 $+    wrapFloats drop_here2 $+    Case (fiExpr dflags scrut_drops scrut) case_bndr ty+         (zipWith fi_alt alts_drops_s alts)+  where+        -- Float into the scrut and alts-considered-together just like App+    [drop_here1, scrut_drops, alts_drops]+       = sepBindsByDropPoint dflags False+           [scrut_fvs, all_alts_fvs]+           to_drop++        -- Float into the alts with the is_case flag set+    (drop_here2 : alts_drops_s)+      | [ _ ] <- alts = [] : [alts_drops]+      | otherwise     = sepBindsByDropPoint dflags True alts_fvs alts_drops++    scrut_fvs    = freeVarsOf scrut+    alts_fvs     = map alt_fvs alts+    all_alts_fvs = unionDVarSets alts_fvs+    alt_fvs (_con, args, rhs)+      = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args)+           -- Delete case_bndr and args from free vars of rhs+           -- to get free vars of alt++    fi_alt to_drop (con, args, rhs) = (con, args, fiExpr dflags to_drop rhs)++------------------+fiBind :: DynFlags+       -> FloatInBinds      -- Binds we're trying to drop+                            -- as far "inwards" as possible+       -> CoreBindWithFVs   -- Input binding+       -> DVarSet           -- Free in scope of binding+       -> ( FloatInBinds    -- Land these before+          , FloatInBind     -- The binding itself+          , FloatInBinds)   -- Land these after++fiBind dflags to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs+  = ( extra_binds ++ shared_binds          -- Land these before+                                           -- See Note [extra_fvs (1,2)]+    , FB (unitDVarSet id) rhs_fvs'         -- The new binding itself+          (FloatLet (NonRec id rhs'))+    , body_binds )                         -- Land these after++  where+    body_fvs2 = body_fvs `delDVarSet` id++    rule_fvs = bndrRuleAndUnfoldingVarsDSet id        -- See Note [extra_fvs (2): free variables of rules]+    extra_fvs | noFloatIntoRhs NonRecursive id rhs+              = rule_fvs `unionDVarSet` rhs_fvs+              | otherwise+              = rule_fvs+        -- See Note [extra_fvs (1): avoid floating into RHS]+        -- No point in floating in only to float straight out again+        -- We *can't* float into ok-for-speculation unlifted RHSs+        -- But do float into join points++    [shared_binds, extra_binds, rhs_binds, body_binds]+        = sepBindsByDropPoint dflags False+            [extra_fvs, rhs_fvs, body_fvs2]+            to_drop++        -- Push rhs_binds into the right hand side of the binding+    rhs'     = fiRhs dflags rhs_binds id ann_rhs+    rhs_fvs' = rhs_fvs `unionDVarSet` floatedBindsFVs rhs_binds `unionDVarSet` rule_fvs+                        -- Don't forget the rule_fvs; the binding mentions them!++fiBind dflags to_drop (AnnRec bindings) body_fvs+  = ( extra_binds ++ shared_binds+    , FB (mkDVarSet ids) rhs_fvs'+         (FloatLet (Rec (fi_bind rhss_binds bindings)))+    , body_binds )+  where+    (ids, rhss) = unzip bindings+    rhss_fvs = map freeVarsOf rhss++        -- See Note [extra_fvs (1,2)]+    rule_fvs = mapUnionDVarSet bndrRuleAndUnfoldingVarsDSet ids+    extra_fvs = rule_fvs `unionDVarSet`+                unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings+                              , noFloatIntoRhs Recursive bndr rhs ]++    (shared_binds:extra_binds:body_binds:rhss_binds)+        = sepBindsByDropPoint dflags False+            (extra_fvs:body_fvs:rhss_fvs)+            to_drop++    rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet`+               unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet`+               rule_fvs         -- Don't forget the rule variables!++    -- Push rhs_binds into the right hand side of the binding+    fi_bind :: [FloatInBinds]       -- one per "drop pt" conjured w/ fvs_of_rhss+            -> [(Id, CoreExprWithFVs)]+            -> [(Id, CoreExpr)]++    fi_bind to_drops pairs+      = [ (binder, fiRhs dflags to_drop binder rhs)+        | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ]++------------------+fiRhs :: DynFlags -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr+fiRhs dflags to_drop bndr rhs+  | Just join_arity <- isJoinId_maybe bndr+  , let (bndrs, body) = collectNAnnBndrs join_arity rhs+  = mkLams bndrs (fiExpr dflags to_drop body)+  | otherwise+  = fiExpr dflags to_drop rhs++------------------+noFloatIntoLam :: [Var] -> Bool+noFloatIntoLam bndrs = any bad bndrs+  where+    bad b = isId b && not (isOneShotBndr b)+    -- Don't float inside a non-one-shot lambda++noFloatIntoRhs :: RecFlag -> Id -> CoreExprWithFVs' -> Bool+-- ^ True if it's a bad idea to float bindings into this RHS+noFloatIntoRhs is_rec bndr rhs+  | isJoinId bndr+  = isRec is_rec -- Joins are one-shot iff non-recursive++  | otherwise+  = noFloatIntoArg rhs (idType bndr)++noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool+noFloatIntoArg expr expr_ty+  | isUnliftedType expr_ty+  = True  -- See Note [Do not destroy the let/app invariant]++   | AnnLam bndr e <- expr+   , (bndrs, _) <- collectAnnBndrs e+   =  noFloatIntoLam (bndr:bndrs)  -- Wrinkle 1 (a)+   || all isTyVar (bndr:bndrs)     -- Wrinkle 1 (b)+      -- See Note [noFloatInto considerations] wrinkle 2++  | otherwise  -- Note [noFloatInto considerations] wrinkle 2+  = exprIsTrivial deann_expr || exprIsHNF deann_expr+  where+    deann_expr = deAnnotate' expr++{- Note [noFloatInto considerations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When do we want to float bindings into+   - noFloatIntoRHs: the RHS of a let-binding+   - noFloatIntoArg: the argument of a function application++Definitely don't float in if it has unlifted type; that+would destroy the let/app invariant.++* Wrinkle 1: do not float in if+     (a) any non-one-shot value lambdas+  or (b) all type lambdas+  In both cases we'll float straight back out again+  NB: Must line up with fiExpr (AnnLam...); see #7088++  (a) is important: we /must/ float into a one-shot lambda group+  (which includes join points). This makes a big difference+  for things like+     f x# = let x = I# x#+            in let j = \() -> ...x...+               in if <condition> then normal-path else j ()+  If x is used only in the error case join point, j, we must float the+  boxing constructor into it, else we box it every time which is very+  bad news indeed.++* Wrinkle 2: for RHSs, do not float into a HNF; we'll just float right+  back out again... not tragic, but a waste of time.++  For function arguments we will still end up with this+  in-then-out stuff; consider+    letrec x = e in f x+  Here x is not a HNF, so we'll produce+    f (letrec x = e in x)+  which is OK... it's not that common, and we'll end up+  floating out again, in CorePrep if not earlier.+  Still, we use exprIsTrivial to catch this case (sigh)+++************************************************************************+*                                                                      *+\subsection{@sepBindsByDropPoint@}+*                                                                      *+************************************************************************++This is the crucial function.  The idea is: We have a wad of bindings+that we'd like to distribute inside a collection of {\em drop points};+insides the alternatives of a \tr{case} would be one example of some+drop points; the RHS and body of a non-recursive \tr{let} binding+would be another (2-element) collection.++So: We're given a list of sets-of-free-variables, one per drop point,+and a list of floating-inwards bindings.  If a binding can go into+only one drop point (without suddenly making something out-of-scope),+in it goes.  If a binding is used inside {\em multiple} drop points,+then it has to go in a you-must-drop-it-above-all-these-drop-points+point.++We have to maintain the order on these drop-point-related lists.+-}++-- pprFIB :: FloatInBinds -> SDoc+-- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs]++sepBindsByDropPoint+    :: DynFlags+    -> Bool                -- True <=> is case expression+    -> [FreeVarSet]        -- One set of FVs per drop point+                           -- Always at least two long!+    -> FloatInBinds        -- Candidate floaters+    -> [FloatInBinds]      -- FIRST one is bindings which must not be floated+                           -- inside any drop point; the rest correspond+                           -- one-to-one with the input list of FV sets++-- Every input floater is returned somewhere in the result;+-- none are dropped, not even ones which don't seem to be+-- free in *any* of the drop-point fvs.  Why?  Because, for example,+-- a binding (let x = E in B) might have a specialised version of+-- x (say x') stored inside x, but x' isn't free in E or B.++type DropBox = (FreeVarSet, FloatInBinds)++sepBindsByDropPoint dflags is_case drop_pts floaters+  | null floaters  -- Shortcut common case+  = [] : [[] | _ <- drop_pts]++  | otherwise+  = ASSERT( drop_pts `lengthAtLeast` 2 )+    go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))+  where+    n_alts = length drop_pts++    go :: FloatInBinds -> [DropBox] -> [FloatInBinds]+        -- The *first* one in the argument list is the drop_here set+        -- The FloatInBinds in the lists are in the reverse of+        -- the normal FloatInBinds order; that is, they are the right way round!++    go [] drop_boxes = map (reverse . snd) drop_boxes++    go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)+        = go binds new_boxes+        where+          -- "here" means the group of bindings dropped at the top of the fork++          (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs+                                        | (fvs, _) <- drop_boxes]++          drop_here = used_here || cant_push++          n_used_alts = count id used_in_flags -- returns number of Trues in list.++          cant_push+            | is_case   = n_used_alts == n_alts   -- Used in all, don't push+                                                  -- Remember n_alts > 1+                          || (n_used_alts > 1 && not (floatIsDupable dflags bind))+                             -- floatIsDupable: see Note [Duplicating floats]++            | otherwise = floatIsCase bind || n_used_alts > 1+                             -- floatIsCase: see Note [Floating primops]++          new_boxes | drop_here = (insert here_box : fork_boxes)+                    | otherwise = (here_box : new_fork_boxes)++          new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe+                                        fork_boxes used_in_flags++          insert :: DropBox -> DropBox+          insert (fvs,drops) = (fvs `unionDVarSet` bind_fvs, bind_w_fvs:drops)++          insert_maybe box True  = insert box+          insert_maybe box False = box++    go _ _ = panic "sepBindsByDropPoint/go"+++{- Note [Duplicating floats]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++For case expressions we duplicate the binding if it is reasonably+small, and if it is not used in all the RHSs This is good for+situations like+     let x = I# y in+     case e of+       C -> error x+       D -> error x+       E -> ...not mentioning x...++If the thing is used in all RHSs there is nothing gained,+so we don't duplicate then.+-}++floatedBindsFVs :: FloatInBinds -> FreeVarSet+floatedBindsFVs binds = mapUnionDVarSet fbFVs binds++fbFVs :: FloatInBind -> DVarSet+fbFVs (FB _ fvs _) = fvs++wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr+-- Remember FloatInBinds is in *reverse* dependency order+wrapFloats []               e = e+wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)++floatIsDupable :: DynFlags -> FloatBind -> Bool+floatIsDupable dflags (FloatCase scrut _ _ _) = exprIsDupable dflags scrut+floatIsDupable dflags (FloatLet (Rec prs))    = all (exprIsDupable dflags . snd) prs+floatIsDupable dflags (FloatLet (NonRec _ r)) = exprIsDupable dflags r++floatIsCase :: FloatBind -> Bool+floatIsCase (FloatCase {}) = True+floatIsCase (FloatLet {})  = False
+ compiler/simplCore/FloatOut.hs view
@@ -0,0 +1,755 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[FloatOut]{Float bindings outwards (towards the top level)}++``Long-distance'' floating of bindings towards the top level.+-}++{-# LANGUAGE CPP #-}++module FloatOut ( floatOutwards ) where++import GhcPrelude++import CoreSyn+import CoreUtils+import MkCore+import CoreArity        ( etaExpand )+import CoreMonad        ( FloatOutSwitches(..) )++import DynFlags+import ErrUtils         ( dumpIfSet_dyn )+import Id               ( Id, idArity, idType, isBottomingId,+                          isJoinId, isJoinId_maybe )+import SetLevels+import UniqSupply       ( UniqSupply )+import Bag+import Util+import Maybes+import Outputable+import Type+import qualified Data.IntMap as M++import Data.List        ( partition )++#include "HsVersions.h"++{-+        -----------------+        Overall game plan+        -----------------++The Big Main Idea is:++        To float out sub-expressions that can thereby get outside+        a non-one-shot value lambda, and hence may be shared.+++To achieve this we may need to do two things:++   a) Let-bind the sub-expression:++        f (g x)  ==>  let lvl = f (g x) in lvl++      Now we can float the binding for 'lvl'.++   b) More than that, we may need to abstract wrt a type variable++        \x -> ... /\a -> let v = ...a... in ....++      Here the binding for v mentions 'a' but not 'x'.  So we+      abstract wrt 'a', to give this binding for 'v':++            vp = /\a -> ...a...+            v  = vp a++      Now the binding for vp can float out unimpeded.+      I can't remember why this case seemed important enough to+      deal with, but I certainly found cases where important floats+      didn't happen if we did not abstract wrt tyvars.++With this in mind we can also achieve another goal: lambda lifting.+We can make an arbitrary (function) binding float to top level by+abstracting wrt *all* local variables, not just type variables, leaving+a binding that can be floated right to top level.  Whether or not this+happens is controlled by a flag.+++Random comments+~~~~~~~~~~~~~~~++At the moment we never float a binding out to between two adjacent+lambdas.  For example:++@+        \x y -> let t = x+x in ...+===>+        \x -> let t = x+x in \y -> ...+@+Reason: this is less efficient in the case where the original lambda+is never partially applied.++But there's a case I've seen where this might not be true.  Consider:+@+elEm2 x ys+  = elem' x ys+  where+    elem' _ []  = False+    elem' x (y:ys)      = x==y || elem' x ys+@+It turns out that this generates a subexpression of the form+@+        \deq x ys -> let eq = eqFromEqDict deq in ...+@+which might usefully be separated to+@+        \deq -> let eq = eqFromEqDict deq in \xy -> ...+@+Well, maybe.  We don't do this at the moment.++Note [Join points]+~~~~~~~~~~~~~~~~~~+Every occurrence of a join point must be a tail call (see Note [Invariants on+join points] in CoreSyn), so we must be careful with how far we float them. The+mechanism for doing so is the *join ceiling*, detailed in Note [Join ceiling]+in SetLevels. For us, the significance is that a binder might be marked to be+dropped at the nearest boundary between tail calls and non-tail calls. For+example:++  (< join j = ... in+     let x = < ... > in+     case < ... > of+       A -> ...+       B -> ...+   >) < ... > < ... >++Here the join ceilings are marked with angle brackets. Either side of an+application is a join ceiling, as is the scrutinee position of a case+expression or the RHS of a let binding (but not a join point).++Why do we *want* do float join points at all? After all, they're never+allocated, so there's no sharing to be gained by floating them. However, the+other benefit of floating is making RHSes small, and this can have a significant+impact. In particular, stream fusion has been known to produce nested loops like+this:++  joinrec j1 x1 =+    joinrec j2 x2 =+      joinrec j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...+      in jump j3 x2+    in jump j2 x1+  in jump j1 x++(Assume x1 and x2 do *not* occur free in j3.)++Here j1 and j2 are wholly superfluous---each of them merely forwards its+argument to j3. Since j3 only refers to x3, we can float j2 and j3 to make+everything one big mutual recursion:++  joinrec j1 x1 = jump j2 x1+          j2 x2 = jump j3 x2+          j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...+  in jump j1 x++Now the simplifier will happily inline the trivial j1 and j2, leaving only j3.+Without floating, we're stuck with three loops instead of one.++************************************************************************+*                                                                      *+\subsection[floatOutwards]{@floatOutwards@: let-floating interface function}+*                                                                      *+************************************************************************+-}++floatOutwards :: FloatOutSwitches+              -> DynFlags+              -> UniqSupply+              -> CoreProgram -> IO CoreProgram++floatOutwards float_sws dflags us pgm+  = do {+        let { annotated_w_levels = setLevels float_sws pgm us ;+              (fss, binds_s')    = unzip (map floatTopBind annotated_w_levels)+            } ;++        dumpIfSet_dyn dflags Opt_D_verbose_core2core "Levels added:"+                  (vcat (map ppr annotated_w_levels));++        let { (tlets, ntlets, lams) = get_stats (sum_stats fss) };++        dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "FloatOut stats:"+                (hcat [ int tlets,  text " Lets floated to top level; ",+                        int ntlets, text " Lets floated elsewhere; from ",+                        int lams,   text " Lambda groups"]);++        return (bagToList (unionManyBags binds_s'))+    }++floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind)+floatTopBind bind+  = case (floatBind bind) of { (fs, floats, bind') ->+    let float_bag = flattenTopFloats floats+    in case bind' of+      -- bind' can't have unlifted values or join points, so can only be one+      -- value bind, rec or non-rec (see comment on floatBind)+      [Rec prs]    -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs)))+      [NonRec b e] -> (fs, float_bag `snocBag` NonRec b e)+      _            -> pprPanic "floatTopBind" (ppr bind') }++{-+************************************************************************+*                                                                      *+\subsection[FloatOut-Bind]{Floating in a binding (the business end)}+*                                                                      *+************************************************************************+-}++floatBind :: LevelledBind -> (FloatStats, FloatBinds, [CoreBind])+  -- Returns a list with either+  --   * A single non-recursive binding (value or join point), or+  --   * The following, in order:+  --     * Zero or more non-rec unlifted bindings+  --     * One or both of:+  --       * A recursive group of join binds+  --       * A recursive group of value binds+  -- See Note [Floating out of Rec rhss] for why things get arranged this way.+floatBind (NonRec (TB var _) rhs)+  = case (floatRhs var rhs) of { (fs, rhs_floats, rhs') ->++        -- A tiresome hack:+        -- see Note [Bottoming floats: eta expansion] in SetLevels+    let rhs'' | isBottomingId var = etaExpand (idArity var) rhs'+              | otherwise         = rhs'++    in (fs, rhs_floats, [NonRec var rhs'']) }++floatBind (Rec pairs)+  = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) ->+    let (new_ul_pairss, new_other_pairss) = unzip new_pairs+        (new_join_pairs, new_l_pairs)     = partition (isJoinId . fst)+                                                      (concat new_other_pairss)+        -- Can't put the join points and the values in the same rec group+        new_rec_binds | null new_join_pairs = [ Rec new_l_pairs    ]+                      | null new_l_pairs    = [ Rec new_join_pairs ]+                      | otherwise           = [ Rec new_l_pairs+                                              , Rec new_join_pairs ]+        new_non_rec_binds = [ NonRec b e | (b, e) <- concat new_ul_pairss ]+    in+    (fs, rhs_floats, new_non_rec_binds ++ new_rec_binds) }+  where+    do_pair :: (LevelledBndr, LevelledExpr)+            -> (FloatStats, FloatBinds,+                ([(Id,CoreExpr)],  -- Non-recursive unlifted value bindings+                 [(Id,CoreExpr)])) -- Join points and lifted value bindings+    do_pair (TB name spec, rhs)+      | isTopLvl dest_lvl  -- See Note [floatBind for top level]+      = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->+        (fs, emptyFloats, ([], addTopFloatPairs (flattenTopFloats rhs_floats)+                                                [(name, rhs')]))}+      | otherwise         -- Note [Floating out of Rec rhss]+      = case (floatRhs name rhs) of { (fs, rhs_floats, rhs') ->+        case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) ->+        case (splitRecFloats heres) of { (ul_pairs, pairs, case_heres) ->+        let pairs' = (name, installUnderLambdas case_heres rhs') : pairs in+        (fs, rhs_floats', (ul_pairs, pairs')) }}}+      where+        dest_lvl = floatSpecLevel spec++splitRecFloats :: Bag FloatBind+               -> ([(Id,CoreExpr)], -- Non-recursive unlifted value bindings+                   [(Id,CoreExpr)], -- Join points and lifted value bindings+                   Bag FloatBind)   -- A tail of further bindings+-- The "tail" begins with a case+-- See Note [Floating out of Rec rhss]+splitRecFloats fs+  = go [] [] (bagToList fs)+  where+    go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b)+                                               , not (isJoinId b)+                                               = go ((b,r):ul_prs) prs fs+                                               | otherwise+                                               = go ul_prs ((b,r):prs) fs+    go ul_prs prs (FloatLet (Rec prs')   : fs) = go ul_prs (prs' ++ prs) fs+    go ul_prs prs fs                           = (reverse ul_prs, prs,+                                                  listToBag fs)+                                                   -- Order only matters for+                                                   -- non-rec++installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr+-- Note [Floating out of Rec rhss]+installUnderLambdas floats e+  | isEmptyBag floats = e+  | otherwise         = go e+  where+    go (Lam b e)                 = Lam b (go e)+    go e                         = install floats e++---------------+floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b])+floatList _ [] = (zeroStats, emptyFloats, [])+floatList f (a:as) = case f a            of { (fs_a,  binds_a,  b)  ->+                     case floatList f as of { (fs_as, binds_as, bs) ->+                     (fs_a `add_stats` fs_as, binds_a `plusFloats`  binds_as, b:bs) }}++{-+Note [Floating out of Rec rhss]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider   Rec { f<1,0> = \xy. body }+From the body we may get some floats. The ones with level <1,0> must+stay here, since they may mention f.  Ideally we'd like to make them+part of the Rec block pairs -- but we can't if there are any+FloatCases involved.++Nor is it a good idea to dump them in the rhs, but outside the lambda+    f = case x of I# y -> \xy. body+because now f's arity might get worse, which is Not Good. (And if+there's an SCC around the RHS it might not get better again.+See #5342.)++So, gruesomely, we split the floats into+ * the outer FloatLets, which can join the Rec, and+ * an inner batch starting in a FloatCase, which are then+   pushed *inside* the lambdas.+This loses full-laziness the rare situation where there is a+FloatCase and a Rec interacting.++If there are unlifted FloatLets (that *aren't* join points) among the floats,+we can't add them to the recursive group without angering Core Lint, but since+they must be ok-for-speculation, they can't actually be making any recursive+calls, so we can safely pull them out and keep them non-recursive.++(Why is something getting floated to <1,0> that doesn't make a recursive call?+The case that came up in testing was that f *and* the unlifted binding were+getting floated *to the same place*:++  \x<2,0> ->+    ... <3,0>+    letrec { f<F<2,0>> =+      ... let x'<F<2,0>> = x +# 1# in ...+    } in ...++Everything gets labeled "float to <2,0>" because it all depends on x, but this+makes f and x' look mutually recursive when they're not.++The test was shootout/k-nucleotide, as compiled using commit 47d5dd68 on the+wip/join-points branch.++TODO: This can probably be solved somehow in SetLevels. The difference between+"this *is at* level <2,0>" and "this *depends on* level <2,0>" is very+important.)++Note [floatBind for top level]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus+         letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... }+The binding for bar will be in the "tops" part of the floating binds,+and thus not partioned by floatBody.++We could perhaps get rid of the 'tops' component of the floating binds,+but this case works just as well.+++************************************************************************++\subsection[FloatOut-Expr]{Floating in expressions}+*                                                                      *+************************************************************************+-}++floatBody :: Level+          -> LevelledExpr+          -> (FloatStats, FloatBinds, CoreExpr)++floatBody lvl arg       -- Used rec rhss, and case-alternative rhss+  = case (floatExpr arg) of { (fsa, floats, arg') ->+    case (partitionByLevel lvl floats) of { (floats', heres) ->+        -- Dump bindings are bound here+    (fsa, floats', install heres arg') }}++-----------------++{- Note [Floating past breakpoints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We used to disallow floating out of breakpoint ticks (see #10052). However, I+think this is too restrictive.++Consider the case of an expression scoped over by a breakpoint tick,++  tick<...> (let x = ... in f x)++In this case it is completely legal to float out x, despite the fact that+breakpoint ticks are scoped,++  let x = ... in (tick<...>  f x)++The reason here is that we know that the breakpoint will still be hit when the+expression is entered since the tick still scopes over the RHS.++-}++floatExpr :: LevelledExpr+          -> (FloatStats, FloatBinds, CoreExpr)+floatExpr (Var v)   = (zeroStats, emptyFloats, Var v)+floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty)+floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co)+floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit)++floatExpr (App e a)+  = case (atJoinCeiling $ floatExpr  e) of { (fse, floats_e, e') ->+    case (atJoinCeiling $ floatExpr  a) of { (fsa, floats_a, a') ->+    (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }}++floatExpr lam@(Lam (TB _ lam_spec) _)+  = let (bndrs_w_lvls, body) = collectBinders lam+        bndrs                = [b | TB b _ <- bndrs_w_lvls]+        bndr_lvl             = asJoinCeilLvl (floatSpecLevel lam_spec)+        -- All the binders have the same level+        -- See SetLevels.lvlLamBndrs+        -- Use asJoinCeilLvl to make this the join ceiling+    in+    case (floatBody bndr_lvl body) of { (fs, floats, body') ->+    (add_to_stats fs floats, floats, mkLams bndrs body') }++floatExpr (Tick tickish expr)+  | tickish `tickishScopesLike` SoftScope -- not scoped, can just float+  = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->+    (fs, floating_defns, Tick tickish expr') }++  | not (tickishCounts tickish) || tickishCanSplit tickish+  = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->+    let -- Annotate bindings floated outwards past an scc expression+        -- with the cc.  We mark that cc as "duplicated", though.+        annotated_defns = wrapTick (mkNoCount tickish) floating_defns+    in+    (fs, annotated_defns, Tick tickish expr') }++  -- Note [Floating past breakpoints]+  | Breakpoint{} <- tickish+  = case (floatExpr expr)    of { (fs, floating_defns, expr') ->+    (fs, floating_defns, Tick tickish expr') }++  | otherwise+  = pprPanic "floatExpr tick" (ppr tickish)++floatExpr (Cast expr co)+  = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') ->+    (fs, floating_defns, Cast expr' co) }++floatExpr (Let bind body)+  = case bind_spec of+      FloatMe dest_lvl+        -> case (floatBind bind) of { (fsb, bind_floats, binds') ->+           case (floatExpr body) of { (fse, body_floats, body') ->+           let new_bind_floats = foldr plusFloats emptyFloats+                                   (map (unitLetFloat dest_lvl) binds') in+           ( add_stats fsb fse+           , bind_floats `plusFloats` new_bind_floats+                         `plusFloats` body_floats+           , body') }}++      StayPut bind_lvl  -- See Note [Avoiding unnecessary floating]+        -> case (floatBind bind)          of { (fsb, bind_floats, binds') ->+           case (floatBody bind_lvl body) of { (fse, body_floats, body') ->+           ( add_stats fsb fse+           , bind_floats `plusFloats` body_floats+           , foldr Let body' binds' ) }}+  where+    bind_spec = case bind of+                 NonRec (TB _ s) _     -> s+                 Rec ((TB _ s, _) : _) -> s+                 Rec []                -> panic "floatExpr:rec"++floatExpr (Case scrut (TB case_bndr case_spec) ty alts)+  = case case_spec of+      FloatMe dest_lvl  -- Case expression moves+        | [(con@(DataAlt {}), bndrs, rhs)] <- alts+        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->+           case                 floatExpr rhs   of { (fsb, fdb, rhs') ->+           let+             float = unitCaseFloat dest_lvl scrut'+                          case_bndr con [b | TB b _ <- bndrs]+           in+           (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }}+        | otherwise+        -> pprPanic "Floating multi-case" (ppr alts)++      StayPut bind_lvl  -- Case expression stays put+        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->+           case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts')  ->+           (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts')+           }}+  where+    float_alt bind_lvl (con, bs, rhs)+        = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') ->+          (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) }++floatRhs :: CoreBndr+         -> LevelledExpr+         -> (FloatStats, FloatBinds, CoreExpr)+floatRhs bndr rhs+  | Just join_arity <- isJoinId_maybe bndr+  , Just (bndrs, body) <- try_collect join_arity rhs []+  = case bndrs of+      []                -> floatExpr rhs+      (TB _ lam_spec):_ ->+        let lvl = floatSpecLevel lam_spec in+        case floatBody lvl body of { (fs, floats, body') ->+        (fs, floats, mkLams [b | TB b _ <- bndrs] body') }+  | otherwise+  = atJoinCeiling $ floatExpr rhs+  where+    try_collect 0 expr      acc = Just (reverse acc, expr)+    try_collect n (Lam b e) acc = try_collect (n-1) e (b:acc)+    try_collect _ _         _   = Nothing++{-+Note [Avoiding unnecessary floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general we want to avoid floating a let unnecessarily, because+it might worsen strictness:+    let+       x = ...(let y = e in y+y)....+Here y is demanded.  If we float it outside the lazy 'x=..' then+we'd have to zap its demand info, and it may never be restored.++So at a 'let' we leave the binding right where the are unless+the binding will escape a value lambda, e.g.++(\x -> let y = fac 100 in y)++That's what the partitionByMajorLevel does in the floatExpr (Let ...)+case.++Notice, though, that we must take care to drop any bindings+from the body of the let that depend on the staying-put bindings.++We used instead to do the partitionByMajorLevel on the RHS of an '=',+in floatRhs.  But that was quite tiresome.  We needed to test for+values or trival rhss, because (in particular) we don't want to insert+new bindings between the "=" and the "\".  E.g.+        f = \x -> let <bind> in <body>+We do not want+        f = let <bind> in \x -> <body>+(a) The simplifier will immediately float it further out, so we may+        as well do so right now; in general, keeping rhss as manifest+        values is good+(b) If a float-in pass follows immediately, it might add yet more+        bindings just after the '='.  And some of them might (correctly)+        be strict even though the 'let f' is lazy, because f, being a value,+        gets its demand-info zapped by the simplifier.+And even all that turned out to be very fragile, and broke+altogether when profiling got in the way.++So now we do the partition right at the (Let..) itself.++************************************************************************+*                                                                      *+\subsection{Utility bits for floating stats}+*                                                                      *+************************************************************************++I didn't implement this with unboxed numbers.  I don't want to be too+strict in this stuff, as it is rarely turned on.  (WDP 95/09)+-}++data FloatStats+  = FlS Int  -- Number of top-floats * lambda groups they've been past+        Int  -- Number of non-top-floats * lambda groups they've been past+        Int  -- Number of lambda (groups) seen++get_stats :: FloatStats -> (Int, Int, Int)+get_stats (FlS a b c) = (a, b, c)++zeroStats :: FloatStats+zeroStats = FlS 0 0 0++sum_stats :: [FloatStats] -> FloatStats+sum_stats xs = foldr add_stats zeroStats xs++add_stats :: FloatStats -> FloatStats -> FloatStats+add_stats (FlS a1 b1 c1) (FlS a2 b2 c2)+  = FlS (a1 + a2) (b1 + b2) (c1 + c2)++add_to_stats :: FloatStats -> FloatBinds -> FloatStats+add_to_stats (FlS a b c) (FB tops ceils others)+  = FlS (a + lengthBag tops)+        (b + lengthBag ceils + lengthBag (flattenMajor others))+        (c + 1)++{-+************************************************************************+*                                                                      *+\subsection{Utility bits for floating}+*                                                                      *+************************************************************************++Note [Representation of FloatBinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The FloatBinds types is somewhat important.  We can get very large numbers+of floating bindings, often all destined for the top level.  A typical example+is     x = [4,2,5,2,5, .... ]+Then we get lots of small expressions like (fromInteger 4), which all get+lifted to top level.++The trouble is that+  (a) we partition these floating bindings *at every binding site*+  (b) SetLevels introduces a new bindings site for every float+So we had better not look at each binding at each binding site!++That is why MajorEnv is represented as a finite map.++We keep the bindings destined for the *top* level separate, because+we float them out even if they don't escape a *value* lambda; see+partitionByMajorLevel.+-}++type FloatLet = CoreBind        -- INVARIANT: a FloatLet is always lifted+type MajorEnv = M.IntMap MinorEnv         -- Keyed by major level+type MinorEnv = M.IntMap (Bag FloatBind)  -- Keyed by minor level++data FloatBinds  = FB !(Bag FloatLet)           -- Destined for top level+                      !(Bag FloatBind)          -- Destined for join ceiling+                      !MajorEnv                 -- Other levels+     -- See Note [Representation of FloatBinds]++instance Outputable FloatBinds where+  ppr (FB fbs ceils defs)+      = text "FB" <+> (braces $ vcat+           [ text "tops ="     <+> ppr fbs+           , text "ceils ="    <+> ppr ceils+           , text "non-tops =" <+> ppr defs ])++flattenTopFloats :: FloatBinds -> Bag CoreBind+flattenTopFloats (FB tops ceils defs)+  = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs )+    ASSERT2( isEmptyBag ceils, ppr ceils )+    tops++addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]+addTopFloatPairs float_bag prs+  = foldrBag add prs float_bag+  where+    add (NonRec b r) prs  = (b,r):prs+    add (Rec prs1)   prs2 = prs1 ++ prs2++flattenMajor :: MajorEnv -> Bag FloatBind+flattenMajor = M.foldr (unionBags . flattenMinor) emptyBag++flattenMinor :: MinorEnv -> Bag FloatBind+flattenMinor = M.foldr unionBags emptyBag++emptyFloats :: FloatBinds+emptyFloats = FB emptyBag emptyBag M.empty++unitCaseFloat :: Level -> CoreExpr -> Id -> AltCon -> [Var] -> FloatBinds+unitCaseFloat (Level major minor t) e b con bs+  | t == JoinCeilLvl+  = FB emptyBag floats M.empty+  | otherwise+  = FB emptyBag emptyBag (M.singleton major (M.singleton minor floats))+  where+    floats = unitBag (FloatCase e b con bs)++unitLetFloat :: Level -> FloatLet -> FloatBinds+unitLetFloat lvl@(Level major minor t) b+  | isTopLvl lvl     = FB (unitBag b) emptyBag M.empty+  | t == JoinCeilLvl = FB emptyBag floats M.empty+  | otherwise        = FB emptyBag emptyBag (M.singleton major+                                              (M.singleton minor floats))+  where+    floats = unitBag (FloatLet b)++plusFloats :: FloatBinds -> FloatBinds -> FloatBinds+plusFloats (FB t1 c1 l1) (FB t2 c2 l2)+  = FB (t1 `unionBags` t2) (c1 `unionBags` c2) (l1 `plusMajor` l2)++plusMajor :: MajorEnv -> MajorEnv -> MajorEnv+plusMajor = M.unionWith plusMinor++plusMinor :: MinorEnv -> MinorEnv -> MinorEnv+plusMinor = M.unionWith unionBags++install :: Bag FloatBind -> CoreExpr -> CoreExpr+install defn_groups expr+  = foldrBag wrapFloat expr defn_groups++partitionByLevel+        :: Level                -- Partitioning level+        -> FloatBinds           -- Defns to be divided into 2 piles...+        -> (FloatBinds,         -- Defns  with level strictly < partition level,+            Bag FloatBind)      -- The rest++{-+--       ---- partitionByMajorLevel ----+-- Float it if we escape a value lambda,+--     *or* if we get to the top level+--     *or* if it's a case-float and its minor level is < current+--+-- If we can get to the top level, say "yes" anyway. This means that+--      x = f e+-- transforms to+--    lvl = e+--    x = f lvl+-- which is as it should be++partitionByMajorLevel (Level major _) (FB tops defns)+  = (FB tops outer, heres `unionBags` flattenMajor inner)+  where+    (outer, mb_heres, inner) = M.splitLookup major defns+    heres = case mb_heres of+               Nothing -> emptyBag+               Just h  -> flattenMinor h+-}++partitionByLevel (Level major minor typ) (FB tops ceils defns)+  = (FB tops ceils' (outer_maj `plusMajor` M.singleton major outer_min),+     here_min `unionBags` here_ceil+              `unionBags` flattenMinor inner_min+              `unionBags` flattenMajor inner_maj)++  where+    (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns+    (outer_min, mb_here_min, inner_min) = case mb_here_maj of+                                            Nothing -> (M.empty, Nothing, M.empty)+                                            Just min_defns -> M.splitLookup minor min_defns+    here_min = mb_here_min `orElse` emptyBag+    (here_ceil, ceils') | typ == JoinCeilLvl = (ceils, emptyBag)+                        | otherwise          = (emptyBag, ceils)++-- Like partitionByLevel, but instead split out the bindings that are marked+-- to float to the nearest join ceiling (see Note [Join points])+partitionAtJoinCeiling :: FloatBinds -> (FloatBinds, Bag FloatBind)+partitionAtJoinCeiling (FB tops ceils defs)+  = (FB tops emptyBag defs, ceils)++-- Perform some action at a join ceiling, i.e., don't let join points float out+-- (see Note [Join points])+atJoinCeiling :: (FloatStats, FloatBinds, CoreExpr)+              -> (FloatStats, FloatBinds, CoreExpr)+atJoinCeiling (fs, floats, expr')+  = (fs, floats', install ceils expr')+  where+    (floats', ceils) = partitionAtJoinCeiling floats++wrapTick :: Tickish Id -> FloatBinds -> FloatBinds+wrapTick t (FB tops ceils defns)+  = FB (mapBag wrap_bind tops) (wrap_defns ceils)+       (M.map (M.map wrap_defns) defns)+  where+    wrap_defns = mapBag wrap_one++    wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs)+    wrap_bind (Rec pairs)         = Rec (mapSnd maybe_tick pairs)++    wrap_one (FloatLet bind)      = FloatLet (wrap_bind bind)+    wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs++    maybe_tick e | exprIsHNF e = tickHNFArgs t e+                 | otherwise   = mkTick t e+      -- we don't need to wrap a tick around an HNF when we float it+      -- outside a tick: that is an invariant of the tick semantics+      -- Conversely, inlining of HNFs inside an SCC is allowed, and+      -- indeed the HNF we're floating here might well be inlined back+      -- again, and we don't want to end up with duplicate ticks.
+ compiler/simplCore/LiberateCase.hs view
@@ -0,0 +1,442 @@+{-+(c) The AQUA Project, Glasgow University, 1994-1998++\section[LiberateCase]{Unroll recursion to allow evals to be lifted from a loop}+-}++{-# LANGUAGE CPP #-}+module LiberateCase ( liberateCase ) where++#include "HsVersions.h"++import GhcPrelude++import DynFlags+import CoreSyn+import CoreUnfold       ( couldBeSmallEnoughToInline )+import TysWiredIn       ( unitDataConId )+import Id+import VarEnv+import Util             ( notNull )++{-+The liberate-case transformation+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This module walks over @Core@, and looks for @case@ on free variables.+The criterion is:+        if there is case on a free on the route to the recursive call,+        then the recursive call is replaced with an unfolding.++Example++   f = \ t -> case v of+                 V a b -> a : f t++=> the inner f is replaced.++   f = \ t -> case v of+                 V a b -> a : (letrec+                                f =  \ t -> case v of+                                               V a b -> a : f t+                               in f) t+(note the NEED for shadowing)++=> Simplify++  f = \ t -> case v of+                 V a b -> a : (letrec+                                f = \ t -> a : f t+                               in f t)++Better code, because 'a' is  free inside the inner letrec, rather+than needing projection from v.++Note that this deals with *free variables*.  SpecConstr deals with+*arguments* that are of known form.  E.g.++        last []     = error+        last (x:[]) = x+        last (x:xs) = last xs+++Note [Scrutinee with cast]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+    f = \ t -> case (v `cast` co) of+                 V a b -> a : f t++Exactly the same optimisation (unrolling one call to f) will work here,+despite the cast.  See mk_alt_env in the Case branch of libCase.+++To think about (Apr 94)+~~~~~~~~~~~~~~+Main worry: duplicating code excessively.  At the moment we duplicate+the entire binding group once at each recursive call.  But there may+be a group of recursive calls which share a common set of evaluated+free variables, in which case the duplication is a plain waste.++Another thing we could consider adding is some unfold-threshold thing,+so that we'll only duplicate if the size of the group rhss isn't too+big.++Data types+~~~~~~~~~~+The ``level'' of a binder tells how many+recursive defns lexically enclose the binding+A recursive defn "encloses" its RHS, not its+scope.  For example:+\begin{verbatim}+        letrec f = let g = ... in ...+        in+        let h = ...+        in ...+\end{verbatim}+Here, the level of @f@ is zero, the level of @g@ is one,+and the level of @h@ is zero (NB not one).+++************************************************************************+*                                                                      *+         Top-level code+*                                                                      *+************************************************************************+-}++liberateCase :: DynFlags -> CoreProgram -> CoreProgram+liberateCase dflags binds = do_prog (initEnv dflags) binds+  where+    do_prog _   [] = []+    do_prog env (bind:binds) = bind' : do_prog env' binds+                             where+                               (env', bind') = libCaseBind env bind++{-+************************************************************************+*                                                                      *+         Main payload+*                                                                      *+************************************************************************++Bindings+~~~~~~~~+-}++libCaseBind :: LibCaseEnv -> CoreBind -> (LibCaseEnv, CoreBind)++libCaseBind env (NonRec binder rhs)+  = (addBinders env [binder], NonRec binder (libCase env rhs))++libCaseBind env (Rec pairs)+  = (env_body, Rec pairs')+  where+    binders = map fst pairs++    env_body = addBinders env binders++    pairs' = [(binder, libCase env_rhs rhs) | (binder,rhs) <- pairs]++        -- We extend the rec-env by binding each Id to its rhs, first+        -- processing the rhs with an *un-extended* environment, so+        -- that the same process doesn't occur for ever!+    env_rhs | is_dupable_bind = addRecBinds env dup_pairs+            | otherwise       = env++    dup_pairs = [ (localiseId binder, libCase env_body rhs)+                | (binder, rhs) <- pairs ]+        -- localiseID : see Note [Need to localiseId in libCaseBind]++    is_dupable_bind = small_enough && all ok_pair pairs++    -- Size: we are going to duplicate dup_pairs; to find their+    --       size, build a fake binding (let { dup_pairs } in (),+    --       and find the size of that+    -- See Note [Small enough]+    small_enough = case bombOutSize env of+                      Nothing   -> True   -- Infinity+                      Just size -> couldBeSmallEnoughToInline (lc_dflags env) size $+                                   Let (Rec dup_pairs) (Var unitDataConId)++    ok_pair (id,_)+        =  idArity id > 0          -- Note [Only functions!]+        && not (isBottomingId id)  -- Note [Not bottoming ids]++{- Note [Not bottoming Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do not specialise error-functions (this is unusual, but I once saw it,+(acually in Data.Typable.Internal)++Note [Only functions!]+~~~~~~~~~~~~~~~~~~~~~~+Consider the following code++       f = g (case v of V a b -> a : t f)++where g is expensive. If we aren't careful, liberate case will turn this into++       f = g (case v of+               V a b -> a : t (letrec f = g (case v of V a b -> a : f t)+                                in f)+             )++Yikes! We evaluate g twice. This leads to a O(2^n) explosion+if g calls back to the same code recursively.++Solution: make sure that we only do the liberate-case thing on *functions*++Note [Small enough]+~~~~~~~~~~~~~~~~~~~+Consider+  \fv. letrec+         f = \x. BIG...(case fv of { (a,b) -> ...g.. })...+         g = \y. SMALL...f...++Then we *can* in principle do liberate-case on 'g' (small RHS) but not+for 'f' (too big).  But doing so is not profitable, because duplicating+'g' at its call site in 'f' doesn't get rid of any cases.  So we just+ask for the whole group to be small enough.++Note [Need to localiseId in libCaseBind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The call to localiseId is needed for two subtle reasons+(a)  Reset the export flags on the binders so+        that we don't get name clashes on exported things if the+        local binding floats out to top level.  This is most unlikely+        to happen, since the whole point concerns free variables.+        But resetting the export flag is right regardless.++(b)  Make the name an Internal one.  External Names should never be+        nested; if it were floated to the top level, we'd get a name+        clash at code generation time.++Expressions+~~~~~~~~~~~+-}++libCase :: LibCaseEnv+        -> CoreExpr+        -> CoreExpr++libCase env (Var v)             = libCaseApp env v []+libCase _   (Lit lit)           = Lit lit+libCase _   (Type ty)           = Type ty+libCase _   (Coercion co)       = Coercion co+libCase env e@(App {})          | let (fun, args) = collectArgs e+                                , Var v <- fun+                                = libCaseApp env v args+libCase env (App fun arg)       = App (libCase env fun) (libCase env arg)+libCase env (Tick tickish body) = Tick tickish (libCase env body)+libCase env (Cast e co)         = Cast (libCase env e) co++libCase env (Lam binder body)+  = Lam binder (libCase (addBinders env [binder]) body)++libCase env (Let bind body)+  = Let bind' (libCase env_body body)+  where+    (env_body, bind') = libCaseBind env bind++libCase env (Case scrut bndr ty alts)+  = Case (libCase env scrut) bndr ty (map (libCaseAlt env_alts) alts)+  where+    env_alts = addBinders (mk_alt_env scrut) [bndr]+    mk_alt_env (Var scrut_var) = addScrutedVar env scrut_var+    mk_alt_env (Cast scrut _)  = mk_alt_env scrut       -- Note [Scrutinee with cast]+    mk_alt_env _               = env++libCaseAlt :: LibCaseEnv -> (AltCon, [CoreBndr], CoreExpr)+                         -> (AltCon, [CoreBndr], CoreExpr)+libCaseAlt env (con,args,rhs) = (con, args, libCase (addBinders env args) rhs)++{-+Ids+~~~++To unfold, we can't just wrap the id itself in its binding if it's a join point:++  jump j a b c  =>  (joinrec j x y z = ... in jump j) a b c -- wrong!!!++Every jump must provide all arguments, so we have to be careful to wrap the+whole jump instead:++  jump j a b c  =>  joinrec j x y z = ... in jump j a b c -- right++-}++libCaseApp :: LibCaseEnv -> Id -> [CoreExpr] -> CoreExpr+libCaseApp env v args+  | Just the_bind <- lookupRecId env v  -- It's a use of a recursive thing+  , notNull free_scruts                 -- with free vars scrutinised in RHS+  = Let the_bind expr'++  | otherwise+  = expr'++  where+    rec_id_level = lookupLevel env v+    free_scruts  = freeScruts env rec_id_level+    expr'        = mkApps (Var v) (map (libCase env) args)++freeScruts :: LibCaseEnv+           -> LibCaseLevel      -- Level of the recursive Id+           -> [Id]              -- Ids that are scrutinised between the binding+                                -- of the recursive Id and here+freeScruts env rec_bind_lvl+  = [v | (v, scrut_bind_lvl, scrut_at_lvl) <- lc_scruts env+       , scrut_bind_lvl <= rec_bind_lvl+       , scrut_at_lvl > rec_bind_lvl]+        -- Note [When to specialise]+        -- Note [Avoiding fruitless liberate-case]++{-+Note [When to specialise]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f = \x. letrec g = \y. case x of+                           True  -> ... (f a) ...+                           False -> ... (g b) ...++We get the following levels+          f  0+          x  1+          g  1+          y  2++Then 'x' is being scrutinised at a deeper level than its binding, so+it's added to lc_sruts:  [(x,1)]++We do *not* want to specialise the call to 'f', because 'x' is not free+in 'f'.  So here the bind-level of 'x' (=1) is not <= the bind-level of 'f' (=0).++We *do* want to specialise the call to 'g', because 'x' is free in g.+Here the bind-level of 'x' (=1) is <= the bind-level of 'g' (=1).++Note [Avoiding fruitless liberate-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider also:+  f = \x. case top_lvl_thing of+                I# _ -> let g = \y. ... g ...+                        in ...++Here, top_lvl_thing is scrutinised at a level (1) deeper than its+binding site (0).  Nevertheless, we do NOT want to specialise the call+to 'g' because all the structure in its free variables is already+visible at the definition site for g.  Hence, when considering specialising+an occurrence of 'g', we want to check that there's a scruted-var v st++   a) v's binding site is *outside* g+   b) v's scrutinisation site is *inside* g+++************************************************************************+*                                                                      *+        Utility functions+*                                                                      *+************************************************************************+-}++addBinders :: LibCaseEnv -> [CoreBndr] -> LibCaseEnv+addBinders env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env }) binders+  = env { lc_lvl_env = lvl_env' }+  where+    lvl_env' = extendVarEnvList lvl_env (binders `zip` repeat lvl)++addRecBinds :: LibCaseEnv -> [(Id,CoreExpr)] -> LibCaseEnv+addRecBinds env@(LibCaseEnv {lc_lvl = lvl, lc_lvl_env = lvl_env,+                             lc_rec_env = rec_env}) pairs+  = env { lc_lvl = lvl', lc_lvl_env = lvl_env', lc_rec_env = rec_env' }+  where+    lvl'     = lvl + 1+    lvl_env' = extendVarEnvList lvl_env [(binder,lvl) | (binder,_) <- pairs]+    rec_env' = extendVarEnvList rec_env [(binder, Rec pairs) | (binder,_) <- pairs]++addScrutedVar :: LibCaseEnv+              -> Id             -- This Id is being scrutinised by a case expression+              -> LibCaseEnv++addScrutedVar env@(LibCaseEnv { lc_lvl = lvl, lc_lvl_env = lvl_env,+                                lc_scruts = scruts }) scrut_var+  | bind_lvl < lvl+  = env { lc_scruts = scruts' }+        -- Add to scruts iff the scrut_var is being scrutinised at+        -- a deeper level than its defn++  | otherwise = env+  where+    scruts'  = (scrut_var, bind_lvl, lvl) : scruts+    bind_lvl = case lookupVarEnv lvl_env scrut_var of+                 Just lvl -> lvl+                 Nothing  -> topLevel++lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBind+lookupRecId env id = lookupVarEnv (lc_rec_env env) id++lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel+lookupLevel env id+  = case lookupVarEnv (lc_lvl_env env) id of+      Just lvl -> lvl+      Nothing  -> topLevel++{-+************************************************************************+*                                                                      *+         The environment+*                                                                      *+************************************************************************+-}++type LibCaseLevel = Int++topLevel :: LibCaseLevel+topLevel = 0++data LibCaseEnv+  = LibCaseEnv {+        lc_dflags :: DynFlags,++        lc_lvl :: LibCaseLevel, -- Current level+                -- The level is incremented when (and only when) going+                -- inside the RHS of a (sufficiently small) recursive+                -- function.++        lc_lvl_env :: IdEnv LibCaseLevel,+                -- Binds all non-top-level in-scope Ids (top-level and+                -- imported things have a level of zero)++        lc_rec_env :: IdEnv CoreBind,+                -- Binds *only* recursively defined ids, to their own+                -- binding group, and *only* in their own RHSs++        lc_scruts :: [(Id, LibCaseLevel, LibCaseLevel)]+                -- Each of these Ids was scrutinised by an enclosing+                -- case expression, at a level deeper than its binding+                -- level.+                --+                -- The first LibCaseLevel is the *binding level* of+                --   the scrutinised Id,+                -- The second is the level *at which it was scrutinised*.+                --   (see Note [Avoiding fruitless liberate-case])+                -- The former is a bit redundant, since you could always+                -- look it up in lc_lvl_env, but it's just cached here+                --+                -- The order is insignificant; it's a bag really+                --+                -- There's one element per scrutinisation;+                --    in principle the same Id may appear multiple times,+                --    although that'd be unusual:+                --       case x of { (a,b) -> ....(case x of ...) .. }+        }++initEnv :: DynFlags -> LibCaseEnv+initEnv dflags+  = LibCaseEnv { lc_dflags = dflags,+                 lc_lvl = 0,+                 lc_lvl_env = emptyVarEnv,+                 lc_rec_env = emptyVarEnv,+                 lc_scruts = [] }++-- Bomb-out size for deciding if+-- potential liberatees are too big.+-- (passed in from cmd-line args)+bombOutSize :: LibCaseEnv -> Maybe Int+bombOutSize = liberateCaseThreshold . lc_dflags
+ compiler/simplCore/SAT.hs view
@@ -0,0 +1,433 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++************************************************************************++               Static Argument Transformation pass++************************************************************************++May be seen as removing invariants from loops:+Arguments of recursive functions that do not change in recursive+calls are removed from the recursion, which is done locally+and only passes the arguments which effectively change.++Example:+map = /\ ab -> \f -> \xs -> case xs of+                 []       -> []+                 (a:b) -> f a : map f b++as map is recursively called with the same argument f (unmodified)+we transform it to++map = /\ ab -> \f -> \xs -> let map' ys = case ys of+                       []     -> []+                       (a:b) -> f a : map' b+                in map' xs++Notice that for a compiler that uses lambda lifting this is+useless as map' will be transformed back to what map was.++We could possibly do the same for big lambdas, but we don't as+they will eventually be removed in later stages of the compiler,+therefore there is no penalty in keeping them.++We only apply the SAT when the number of static args is > 2. This+produces few bad cases.  See+                should_transform+in saTransform.++Here are the headline nofib results:+                  Size    Allocs   Runtime+Min             +0.0%    -13.7%    -21.4%+Max             +0.1%     +0.0%     +5.4%+Geometric Mean  +0.0%     -0.2%     -6.9%++The previous patch, to fix polymorphic floatout demand signatures, is+essential to make this work well!+-}++{-# LANGUAGE CPP #-}+module SAT ( doStaticArgs ) where++import GhcPrelude++import Var+import CoreSyn+import CoreUtils+import Type+import Coercion+import Id+import Name+import VarEnv+import UniqSupply+import Util+import UniqFM+import VarSet+import Unique+import UniqSet+import Outputable++import Data.List+import FastString++#include "HsVersions.h"++doStaticArgs :: UniqSupply -> CoreProgram -> CoreProgram+doStaticArgs us binds = snd $ mapAccumL sat_bind_threaded_us us binds+  where+    sat_bind_threaded_us us bind =+        let (us1, us2) = splitUniqSupply us+        in (us1, fst $ runSAT us2 (satBind bind emptyUniqSet))++-- We don't bother to SAT recursive groups since it can lead+-- to massive code expansion: see Andre Santos' thesis for details.+-- This means we only apply the actual SAT to Rec groups of one element,+-- but we want to recurse into the others anyway to discover other binds+satBind :: CoreBind -> IdSet -> SatM (CoreBind, IdSATInfo)+satBind (NonRec binder expr) interesting_ids = do+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids+    return (NonRec binder expr', finalizeApp expr_app sat_info_expr)+satBind (Rec [(binder, rhs)]) interesting_ids = do+    let interesting_ids' = interesting_ids `addOneToUniqSet` binder+        (rhs_binders, rhs_body) = collectBinders rhs+    (rhs_body', sat_info_rhs_body) <- satTopLevelExpr rhs_body interesting_ids'+    let sat_info_rhs_from_args = unitVarEnv binder (bindersToSATInfo rhs_binders)+        sat_info_rhs' = mergeIdSATInfo sat_info_rhs_from_args sat_info_rhs_body++        shadowing = binder `elementOfUniqSet` interesting_ids+        sat_info_rhs'' = if shadowing+                        then sat_info_rhs' `delFromUFM` binder -- For safety+                        else sat_info_rhs'++    bind' <- saTransformMaybe binder (lookupUFM sat_info_rhs' binder)+                              rhs_binders rhs_body'+    return (bind', sat_info_rhs'')+satBind (Rec pairs) interesting_ids = do+    let (binders, rhss) = unzip pairs+    rhss_SATed <- mapM (\e -> satTopLevelExpr e interesting_ids) rhss+    let (rhss', sat_info_rhss') = unzip rhss_SATed+    return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss')++data App = VarApp Id | TypeApp Type | CoApp Coercion+data Staticness a = Static a | NotStatic++type IdAppInfo = (Id, SATInfo)++type SATInfo = [Staticness App]+type IdSATInfo = IdEnv SATInfo+emptyIdSATInfo :: IdSATInfo+emptyIdSATInfo = emptyUFM++{-+pprIdSATInfo id_sat_info = vcat (map pprIdAndSATInfo (Map.toList id_sat_info))+  where pprIdAndSATInfo (v, sat_info) = hang (ppr v <> colon) 4 (pprSATInfo sat_info)+-}++pprSATInfo :: SATInfo -> SDoc+pprSATInfo staticness = hcat $ map pprStaticness staticness++pprStaticness :: Staticness App -> SDoc+pprStaticness (Static (VarApp _))  = text "SV"+pprStaticness (Static (TypeApp _)) = text "ST"+pprStaticness (Static (CoApp _))   = text "SC"+pprStaticness NotStatic            = text "NS"+++mergeSATInfo :: SATInfo -> SATInfo -> SATInfo+mergeSATInfo l r = zipWith mergeSA l r+  where+    mergeSA NotStatic _ = NotStatic+    mergeSA _ NotStatic = NotStatic+    mergeSA (Static (VarApp v)) (Static (VarApp v'))+      | v == v'   = Static (VarApp v)+      | otherwise = NotStatic+    mergeSA (Static (TypeApp t)) (Static (TypeApp t'))+      | t `eqType` t' = Static (TypeApp t)+      | otherwise     = NotStatic+    mergeSA (Static (CoApp c)) (Static (CoApp c'))+      | c `eqCoercion` c' = Static (CoApp c)+      | otherwise             = NotStatic+    mergeSA _ _  = pprPanic "mergeSATInfo" $+                          text "Left:"+                       <> pprSATInfo l <> text ", "+                       <> text "Right:"+                       <> pprSATInfo r++mergeIdSATInfo :: IdSATInfo -> IdSATInfo -> IdSATInfo+mergeIdSATInfo = plusUFM_C mergeSATInfo++mergeIdSATInfos :: [IdSATInfo] -> IdSATInfo+mergeIdSATInfos = foldl' mergeIdSATInfo emptyIdSATInfo++bindersToSATInfo :: [Id] -> SATInfo+bindersToSATInfo vs = map (Static . binderToApp) vs+    where binderToApp v | isId v    = VarApp v+                        | isTyVar v = TypeApp $ mkTyVarTy v+                        | otherwise = CoApp $ mkCoVarCo v++finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo+finalizeApp Nothing id_sat_info = id_sat_info+finalizeApp (Just (v, sat_info')) id_sat_info =+    let sat_info'' = case lookupUFM id_sat_info v of+                        Nothing -> sat_info'+                        Just sat_info -> mergeSATInfo sat_info sat_info'+    in extendVarEnv id_sat_info v sat_info''++satTopLevelExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo)+satTopLevelExpr expr interesting_ids = do+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids+    return (expr', finalizeApp expr_app sat_info_expr)++satExpr :: CoreExpr -> IdSet -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)+satExpr var@(Var v) interesting_ids = do+    let app_info = if v `elementOfUniqSet` interesting_ids+                   then Just (v, [])+                   else Nothing+    return (var, emptyIdSATInfo, app_info)++satExpr lit@(Lit _) _ = do+    return (lit, emptyIdSATInfo, Nothing)++satExpr (Lam binders body) interesting_ids = do+    (body', sat_info, this_app) <- satExpr body interesting_ids+    return (Lam binders body', finalizeApp this_app sat_info, Nothing)++satExpr (App fn arg) interesting_ids = do+    (fn', sat_info_fn, fn_app) <- satExpr fn interesting_ids+    let satRemainder = boring fn' sat_info_fn+    case fn_app of+        Nothing -> satRemainder Nothing+        Just (fn_id, fn_app_info) ->+            -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface)+            let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness])+            in case arg of+                Type t     -> satRemainderWithStaticness $ Static (TypeApp t)+                Coercion c -> satRemainderWithStaticness $ Static (CoApp c)+                Var v      -> satRemainderWithStaticness $ Static (VarApp v)+                _          -> satRemainderWithStaticness $ NotStatic+  where+    boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo)+    boring fn' sat_info_fn app_info =+        do (arg', sat_info_arg, arg_app) <- satExpr arg interesting_ids+           let sat_info_arg' = finalizeApp arg_app sat_info_arg+               sat_info = mergeIdSATInfo sat_info_fn sat_info_arg'+           return (App fn' arg', sat_info, app_info)++satExpr (Case expr bndr ty alts) interesting_ids = do+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids+    let sat_info_expr' = finalizeApp expr_app sat_info_expr++    zipped_alts' <- mapM satAlt alts+    let (alts', sat_infos_alts) = unzip zipped_alts'+    return (Case expr' bndr ty alts', mergeIdSATInfo sat_info_expr' (mergeIdSATInfos sat_infos_alts), Nothing)+  where+    satAlt (con, bndrs, expr) = do+        (expr', sat_info_expr) <- satTopLevelExpr expr interesting_ids+        return ((con, bndrs, expr'), sat_info_expr)++satExpr (Let bind body) interesting_ids = do+    (body', sat_info_body, body_app) <- satExpr body interesting_ids+    (bind', sat_info_bind) <- satBind bind interesting_ids+    return (Let bind' body', mergeIdSATInfo sat_info_body sat_info_bind, body_app)++satExpr (Tick tickish expr) interesting_ids = do+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids+    return (Tick tickish expr', sat_info_expr, expr_app)++satExpr ty@(Type _) _ = do+    return (ty, emptyIdSATInfo, Nothing)++satExpr co@(Coercion _) _ = do+    return (co, emptyIdSATInfo, Nothing)++satExpr (Cast expr coercion) interesting_ids = do+    (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids+    return (Cast expr' coercion, sat_info_expr, expr_app)++{-+************************************************************************++                Static Argument Transformation Monad++************************************************************************+-}++type SatM result = UniqSM result++runSAT :: UniqSupply -> SatM a -> a+runSAT = initUs_++newUnique :: SatM Unique+newUnique = getUniqueM++{-+************************************************************************++                Static Argument Transformation Monad++************************************************************************++To do the transformation, the game plan is to:++1. Create a small nonrecursive RHS that takes the+   original arguments to the function but discards+   the ones that are static and makes a call to the+   SATed version with the remainder. We intend that+   this will be inlined later, removing the overhead++2. Bind this nonrecursive RHS over the original body+   WITH THE SAME UNIQUE as the original body so that+   any recursive calls to the original now go via+   the small wrapper++3. Rebind the original function to a new one which contains+   our SATed function and just makes a call to it:+   we call the thing making this call the local body++Example: transform this++    map :: forall a b. (a->b) -> [a] -> [b]+    map = /\ab. \(f:a->b) (as:[a]) -> body[map]+to+    map :: forall a b. (a->b) -> [a] -> [b]+    map = /\ab. \(f:a->b) (as:[a]) ->+         letrec map' :: [a] -> [b]+                    -- The "worker function+                map' = \(as:[a]) ->+                         let map :: forall a' b'. (a -> b) -> [a] -> [b]+                                -- The "shadow function+                             map = /\a'b'. \(f':(a->b) (as:[a]).+                                   map' as+                         in body[map]+         in map' as++Note [Shadow binding]+~~~~~~~~~~~~~~~~~~~~~+The calls to the inner map inside body[map] should get inlined+by the local re-binding of 'map'.  We call this the "shadow binding".++But we can't use the original binder 'map' unchanged, because+it might be exported, in which case the shadow binding won't be+discarded as dead code after it is inlined.++So we use a hack: we make a new SysLocal binder with the *same* unique+as binder.  (Another alternative would be to reset the export flag.)++Note [Binder type capture]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Notice that in the inner map (the "shadow function"), the static arguments+are discarded -- it's as if they were underscores.  Instead, mentions+of these arguments (notably in the types of dynamic arguments) are bound+by the *outer* lambdas of the main function.  So we must make up fresh+names for the static arguments so that they do not capture variables+mentioned in the types of dynamic args.++In the map example, the shadow function must clone the static type+argument a,b, giving a',b', to ensure that in the \(as:[a]), the 'a'+is bound by the outer forall.  We clone f' too for consistency, but+that doesn't matter either way because static Id arguments aren't+mentioned in the shadow binding at all.++If we don't we get something like this:++[Exported]+[Arity 3]+GHC.Base.until =+  \ (@ a_aiK)+    (p_a6T :: a_aiK -> GHC.Types.Bool)+    (f_a6V :: a_aiK -> a_aiK)+    (x_a6X :: a_aiK) ->+    letrec {+      sat_worker_s1aU :: a_aiK -> a_aiK+      []+      sat_worker_s1aU =+        \ (x_a6X :: a_aiK) ->+          let {+            sat_shadow_r17 :: forall a_a3O.+                              (a_a3O -> GHC.Types.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O+            []+            sat_shadow_r17 =+              \ (@ a_aiK)+                (p_a6T :: a_aiK -> GHC.Types.Bool)+                (f_a6V :: a_aiK -> a_aiK)+                (x_a6X :: a_aiK) ->+                sat_worker_s1aU x_a6X } in+          case p_a6T x_a6X of wild_X3y [ALWAYS Dead Nothing] {+            GHC.Types.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X);+            GHC.Types.True -> x_a6X+          }; } in+    sat_worker_s1aU x_a6X++Where sat_shadow has captured the type variables of x_a6X etc as it has a a_aiK+type argument. This is bad because it means the application sat_worker_s1aU x_a6X+is not well typed.+-}++saTransformMaybe :: Id -> Maybe SATInfo -> [Id] -> CoreExpr -> SatM CoreBind+saTransformMaybe binder maybe_arg_staticness rhs_binders rhs_body+  | Just arg_staticness <- maybe_arg_staticness+  , should_transform arg_staticness+  = saTransform binder arg_staticness rhs_binders rhs_body+  | otherwise+  = return (Rec [(binder, mkLams rhs_binders rhs_body)])+  where+    should_transform staticness = n_static_args > 1 -- THIS IS THE DECISION POINT+      where+        n_static_args = count isStaticValue staticness++saTransform :: Id -> SATInfo -> [Id] -> CoreExpr -> SatM CoreBind+saTransform binder arg_staticness rhs_binders rhs_body+  = do  { shadow_lam_bndrs <- mapM clone binders_w_staticness+        ; uniq             <- newUnique+        ; return (NonRec binder (mk_new_rhs uniq shadow_lam_bndrs)) }+  where+    -- Running example: foldr+    -- foldr \alpha \beta c n xs = e, for some e+    -- arg_staticness = [Static TypeApp, Static TypeApp, Static VarApp, Static VarApp, NonStatic]+    -- rhs_binders = [\alpha, \beta, c, n, xs]+    -- rhs_body = e++    binders_w_staticness = rhs_binders `zip` (arg_staticness ++ repeat NotStatic)+                                        -- Any extra args are assumed NotStatic++    non_static_args :: [Var]+            -- non_static_args = [xs]+            -- rhs_binders_without_type_capture = [\alpha', \beta', c, n, xs]+    non_static_args = [v | (v, NotStatic) <- binders_w_staticness]++    clone (bndr, NotStatic) = return bndr+    clone (bndr, _        ) = do { uniq <- newUnique+                                 ; return (setVarUnique bndr uniq) }++    -- new_rhs = \alpha beta c n xs ->+    --           let sat_worker = \xs -> let sat_shadow = \alpha' beta' c n xs ->+    --                                       sat_worker xs+    --                                   in e+    --           in sat_worker xs+    mk_new_rhs uniq shadow_lam_bndrs+        = mkLams rhs_binders $+          Let (Rec [(rec_body_bndr, rec_body)])+          local_body+        where+          local_body = mkVarApps (Var rec_body_bndr) non_static_args++          rec_body = mkLams non_static_args $+                     Let (NonRec shadow_bndr shadow_rhs) rhs_body++            -- See Note [Binder type capture]+          shadow_rhs = mkLams shadow_lam_bndrs local_body+            -- nonrec_rhs = \alpha' beta' c n xs -> sat_worker xs++          rec_body_bndr = mkSysLocal (fsLit "sat_worker") uniq (exprType rec_body)+            -- rec_body_bndr = sat_worker++            -- See Note [Shadow binding]; make a SysLocal+          shadow_bndr = mkSysLocal (occNameFS (getOccName binder))+                                   (idUnique binder)+                                   (exprType shadow_rhs)++isStaticValue :: Staticness App -> Bool+isStaticValue (Static (VarApp _)) = True+isStaticValue _                   = False
+ compiler/simplCore/SetLevels.hs view
@@ -0,0 +1,1722 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section{SetLevels}++                ***************************+                        Overview+                ***************************++1. We attach binding levels to Core bindings, in preparation for floating+   outwards (@FloatOut@).++2. We also let-ify many expressions (notably case scrutinees), so they+   will have a fighting chance of being floated sensible.++3. Note [Need for cloning during float-out]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   We clone the binders of any floatable let-binding, so that when it is+   floated out it will be unique. Example+      (let x=2 in x) + (let x=3 in x)+   we must clone before floating so we get+      let x1=2 in+      let x2=3 in+      x1+x2++   NOTE: this can't be done using the uniqAway idea, because the variable+         must be unique in the whole program, not just its current scope,+         because two variables in different scopes may float out to the+         same top level place++   NOTE: Very tiresomely, we must apply this substitution to+         the rules stored inside a variable too.++   We do *not* clone top-level bindings, because some of them must not change,+   but we *do* clone bindings that are heading for the top level++4. Note [Binder-swap during float-out]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   In the expression+        case x of wild { p -> ...wild... }+   we substitute x for wild in the RHS of the case alternatives:+        case x of wild { p -> ...x... }+   This means that a sub-expression involving x is not "trapped" inside the RHS.+   And it's not inconvenient because we already have a substitution.++  Note that this is EXACTLY BACKWARDS from the what the simplifier does.+  The simplifier tries to get rid of occurrences of x, in favour of wild,+  in the hope that there will only be one remaining occurrence of x, namely+  the scrutinee of the case, and we can inline it.+-}++{-# LANGUAGE CPP, MultiWayIf #-}+module SetLevels (+        setLevels,++        Level(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl,+        LevelledBind, LevelledExpr, LevelledBndr,+        FloatSpec(..), floatSpecLevel,++        incMinorLvl, ltMajLvl, ltLvl, isTopLvl+    ) where++#include "HsVersions.h"++import GhcPrelude++import CoreSyn+import CoreMonad        ( FloatOutSwitches(..) )+import CoreUtils        ( exprType, exprIsHNF+                        , exprOkForSpeculation+                        , exprIsTopLevelBindable+                        , isExprLevPoly+                        , collectMakeStaticArgs+                        )+import CoreArity        ( exprBotStrictness_maybe )+import CoreFVs          -- all of it+import CoreSubst+import MkCore           ( sortQuantVars )++import Id+import IdInfo+import Var+import VarSet+import UniqSet          ( nonDetFoldUniqSet )+import UniqDSet         ( getUniqDSet )+import VarEnv+import Literal          ( litIsTrivial )+import Demand           ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity )+import Name             ( getOccName, mkSystemVarName )+import OccName          ( occNameString )+import Type             ( Type, mkLamTypes, splitTyConApp_maybe, tyCoVarsOfType, closeOverKindsDSet )+import BasicTypes       ( Arity, RecFlag(..), isRec )+import DataCon          ( dataConOrigResTy )+import TysWiredIn+import UniqSupply+import Util+import Outputable+import FastString+import UniqDFM+import FV+import Data.Maybe+import MonadUtils       ( mapAccumLM )++{-+************************************************************************+*                                                                      *+\subsection{Level numbers}+*                                                                      *+************************************************************************+-}++type LevelledExpr = TaggedExpr FloatSpec+type LevelledBind = TaggedBind FloatSpec+type LevelledBndr = TaggedBndr FloatSpec++data Level = Level Int  -- Level number of enclosing lambdas+                   Int  -- Number of big-lambda and/or case expressions and/or+                        -- context boundaries between+                        -- here and the nearest enclosing lambda+                   LevelType -- Binder or join ceiling?+data LevelType = BndrLvl | JoinCeilLvl deriving (Eq)++data FloatSpec+  = FloatMe Level       -- Float to just inside the binding+                        --    tagged with this level+  | StayPut Level       -- Stay where it is; binding is+                        --     tagged with this level++floatSpecLevel :: FloatSpec -> Level+floatSpecLevel (FloatMe l) = l+floatSpecLevel (StayPut l) = l++{-+The {\em level number} on a (type-)lambda-bound variable is the+nesting depth of the (type-)lambda which binds it.  The outermost lambda+has level 1, so (Level 0 0) means that the variable is bound outside any lambda.++On an expression, it's the maximum level number of its free+(type-)variables.  On a let(rec)-bound variable, it's the level of its+RHS.  On a case-bound variable, it's the number of enclosing lambdas.++Top-level variables: level~0.  Those bound on the RHS of a top-level+definition but ``before'' a lambda; e.g., the \tr{x} in (levels shown+as ``subscripts'')...+\begin{verbatim}+a_0 = let  b_? = ...  in+           x_1 = ... b ... in ...+\end{verbatim}++The main function @lvlExpr@ carries a ``context level'' (@le_ctxt_lvl@).+That's meant to be the level number of the enclosing binder in the+final (floated) program.  If the level number of a sub-expression is+less than that of the context, then it might be worth let-binding the+sub-expression so that it will indeed float.++If you can float to level @Level 0 0@ worth doing so because then your+allocation becomes static instead of dynamic.  We always start with+context @Level 0 0@.+++Note [FloatOut inside INLINE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+@InlineCtxt@ very similar to @Level 0 0@, but is used for one purpose:+to say "don't float anything out of here".  That's exactly what we+want for the body of an INLINE, where we don't want to float anything+out at all.  See notes with lvlMFE below.++But, check this out:++-- At one time I tried the effect of not floating anything out of an InlineMe,+-- but it sometimes works badly.  For example, consider PrelArr.done.  It+-- has the form         __inline (\d. e)+-- where e doesn't mention d.  If we float this to+--      __inline (let x = e in \d. x)+-- things are bad.  The inliner doesn't even inline it because it doesn't look+-- like a head-normal form.  So it seems a lesser evil to let things float.+-- In SetLevels we do set the context to (Level 0 0) when we get to an InlineMe+-- which discourages floating out.++So the conclusion is: don't do any floating at all inside an InlineMe.+(In the above example, don't float the {x=e} out of the \d.)++One particular case is that of workers: we don't want to float the+call to the worker outside the wrapper, otherwise the worker might get+inlined into the floated expression, and an importing module won't see+the worker at all.++Note [Join ceiling]+~~~~~~~~~~~~~~~~~~~+Join points can't float very far; too far, and they can't remain join points+So, suppose we have:++  f x = (joinrec j y = ... x ... in jump j x) + 1++One may be tempted to float j out to the top of f's RHS, but then the jump+would not be a tail call. Thus we keep track of a level called the *join+ceiling* past which join points are not allowed to float.++The troublesome thing is that, unlike most levels to which something might+float, there is not necessarily an identifier to which the join ceiling is+attached. Fortunately, if something is to be floated to a join ceiling, it must+be dropped at the *nearest* join ceiling. Thus each level is marked as to+whether it is a join ceiling, so that FloatOut can tell which binders are being+floated to the nearest join ceiling and which to a particular binder (or set of+binders).+-}++instance Outputable FloatSpec where+  ppr (FloatMe l) = char 'F' <> ppr l+  ppr (StayPut l) = ppr l++tOP_LEVEL :: Level+tOP_LEVEL   = Level 0 0 BndrLvl++incMajorLvl :: Level -> Level+incMajorLvl (Level major _ _) = Level (major + 1) 0 BndrLvl++incMinorLvl :: Level -> Level+incMinorLvl (Level major minor _) = Level major (minor+1) BndrLvl++asJoinCeilLvl :: Level -> Level+asJoinCeilLvl (Level major minor _) = Level major minor JoinCeilLvl++maxLvl :: Level -> Level -> Level+maxLvl l1@(Level maj1 min1 _) l2@(Level maj2 min2 _)+  | (maj1 > maj2) || (maj1 == maj2 && min1 > min2) = l1+  | otherwise                                      = l2++ltLvl :: Level -> Level -> Bool+ltLvl (Level maj1 min1 _) (Level maj2 min2 _)+  = (maj1 < maj2) || (maj1 == maj2 && min1 < min2)++ltMajLvl :: Level -> Level -> Bool+    -- Tells if one level belongs to a difft *lambda* level to another+ltMajLvl (Level maj1 _ _) (Level maj2 _ _) = maj1 < maj2++isTopLvl :: Level -> Bool+isTopLvl (Level 0 0 _) = True+isTopLvl _             = False++isJoinCeilLvl :: Level -> Bool+isJoinCeilLvl (Level _ _ t) = t == JoinCeilLvl++instance Outputable Level where+  ppr (Level maj min typ)+    = hcat [ char '<', int maj, char ',', int min, char '>'+           , ppWhen (typ == JoinCeilLvl) (char 'C') ]++instance Eq Level where+  (Level maj1 min1 _) == (Level maj2 min2 _) = maj1 == maj2 && min1 == min2++{-+************************************************************************+*                                                                      *+\subsection{Main level-setting code}+*                                                                      *+************************************************************************+-}++setLevels :: FloatOutSwitches+          -> CoreProgram+          -> UniqSupply+          -> [LevelledBind]++setLevels float_lams binds us+  = initLvl us (do_them init_env binds)+  where+    init_env = initialEnv float_lams++    do_them :: LevelEnv -> [CoreBind] -> LvlM [LevelledBind]+    do_them _ [] = return []+    do_them env (b:bs)+      = do { (lvld_bind, env') <- lvlTopBind env b+           ; lvld_binds <- do_them env' bs+           ; return (lvld_bind : lvld_binds) }++lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv)+lvlTopBind env (NonRec bndr rhs)+  = do { rhs' <- lvl_top env NonRecursive bndr rhs+       ; let (env', [bndr']) = substAndLvlBndrs NonRecursive env tOP_LEVEL [bndr]+       ; return (NonRec bndr' rhs', env') }++lvlTopBind env (Rec pairs)+  = do { let (env', bndrs') = substAndLvlBndrs Recursive env tOP_LEVEL+                                               (map fst pairs)+       ; rhss' <- mapM (\(b,r) -> lvl_top env' Recursive b r) pairs+       ; return (Rec (bndrs' `zip` rhss'), env') }++lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr+lvl_top env is_rec bndr rhs+  = lvlRhs env is_rec+           (isBottomingId bndr)+           Nothing  -- Not a join point+           (freeVars rhs)++{-+************************************************************************+*                                                                      *+\subsection{Setting expression levels}+*                                                                      *+************************************************************************++Note [Floating over-saturated applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we see (f x y), and (f x) is a redex (ie f's arity is 1),+we call (f x) an "over-saturated application"++Should we float out an over-sat app, if can escape a value lambda?+It is sometimes very beneficial (-7% runtime -4% alloc over nofib -O2).+But we don't want to do it for class selectors, because the work saved+is minimal, and the extra local thunks allocated cost money.++Arguably we could float even class-op applications if they were going to+top level -- but then they must be applied to a constant dictionary and+will almost certainly be optimised away anyway.+-}++lvlExpr :: LevelEnv             -- Context+        -> CoreExprWithFVs      -- Input expression+        -> LvlM LevelledExpr    -- Result expression++{-+The @le_ctxt_lvl@ is, roughly, the level of the innermost enclosing+binder.  Here's an example++        v = \x -> ...\y -> let r = case (..x..) of+                                        ..x..+                           in ..++When looking at the rhs of @r@, @le_ctxt_lvl@ will be 1 because that's+the level of @r@, even though it's inside a level-2 @\y@.  It's+important that @le_ctxt_lvl@ is 1 and not 2 in @r@'s rhs, because we+don't want @lvlExpr@ to turn the scrutinee of the @case@ into an MFE+--- because it isn't a *maximal* free expression.++If there were another lambda in @r@'s rhs, it would get level-2 as well.+-}++lvlExpr env (_, AnnType ty)     = return (Type (CoreSubst.substTy (le_subst env) ty))+lvlExpr env (_, AnnCoercion co) = return (Coercion (substCo (le_subst env) co))+lvlExpr env (_, AnnVar v)       = return (lookupVar env v)+lvlExpr _   (_, AnnLit lit)     = return (Lit lit)++lvlExpr env (_, AnnCast expr (_, co)) = do+    expr' <- lvlNonTailExpr env expr+    return (Cast expr' (substCo (le_subst env) co))++lvlExpr env (_, AnnTick tickish expr) = do+    expr' <- lvlNonTailExpr env expr+    let tickish' = substTickish (le_subst env) tickish+    return (Tick tickish' expr')++lvlExpr env expr@(_, AnnApp _ _) = lvlApp env expr (collectAnnArgs expr)++-- We don't split adjacent lambdas.  That is, given+--      \x y -> (x+1,y)+-- we don't float to give+--      \x -> let v = x+1 in \y -> (v,y)+-- Why not?  Because partial applications are fairly rare, and splitting+-- lambdas makes them more expensive.++lvlExpr env expr@(_, AnnLam {})+  = do { new_body <- lvlNonTailMFE new_env True body+       ; return (mkLams new_bndrs new_body) }+  where+    (bndrs, body)        = collectAnnBndrs expr+    (env1, bndrs1)       = substBndrsSL NonRecursive env bndrs+    (new_env, new_bndrs) = lvlLamBndrs env1 (le_ctxt_lvl env) bndrs1+        -- At one time we called a special version of collectBinders,+        -- which ignored coercions, because we don't want to split+        -- a lambda like this (\x -> coerce t (\s -> ...))+        -- This used to happen quite a bit in state-transformer programs,+        -- but not nearly so much now non-recursive newtypes are transparent.+        -- [See SetLevels rev 1.50 for a version with this approach.]++lvlExpr env (_, AnnLet bind body)+  = do { (bind', new_env) <- lvlBind env bind+       ; body' <- lvlExpr new_env body+           -- No point in going via lvlMFE here.  If the binding is alive+           -- (mentioned in body), and the whole let-expression doesn't+           -- float, then neither will the body+       ; return (Let bind' body') }++lvlExpr env (_, AnnCase scrut case_bndr ty alts)+  = do { scrut' <- lvlNonTailMFE env True scrut+       ; lvlCase env (freeVarsOf scrut) scrut' case_bndr ty alts }++lvlNonTailExpr :: LevelEnv             -- Context+               -> CoreExprWithFVs      -- Input expression+               -> LvlM LevelledExpr    -- Result expression+lvlNonTailExpr env expr+  = lvlExpr (placeJoinCeiling env) expr++-------------------------------------------+lvlApp :: LevelEnv+       -> CoreExprWithFVs+       -> (CoreExprWithFVs, [CoreExprWithFVs]) -- Input application+        -> LvlM LevelledExpr                   -- Result expression+lvlApp env orig_expr ((_,AnnVar fn), args)+  | floatOverSat env   -- See Note [Floating over-saturated applications]+  , arity > 0+  , arity < n_val_args+  , Nothing <- isClassOpId_maybe fn+  =  do { rargs' <- mapM (lvlNonTailMFE env False) rargs+        ; lapp'  <- lvlNonTailMFE env False lapp+        ; return (foldl' App lapp' rargs') }++  | otherwise+  = do { (_, args') <- mapAccumLM lvl_arg stricts args+            -- Take account of argument strictness; see+            -- Note [Floating to the top]+       ; return (foldl' App (lookupVar env fn) args') }+  where+    n_val_args = count (isValArg . deAnnotate) args+    arity      = idArity fn++    stricts :: [Demand]   -- True for strict /value/ arguments+    stricts = case splitStrictSig (idStrictness fn) of+                (arg_ds, _) | arg_ds `lengthExceeds` n_val_args+                            -> []+                            | otherwise+                            -> arg_ds++    -- Separate out the PAP that we are floating from the extra+    -- arguments, by traversing the spine until we have collected+    -- (n_val_args - arity) value arguments.+    (lapp, rargs) = left (n_val_args - arity) orig_expr []++    left 0 e               rargs = (e, rargs)+    left n (_, AnnApp f a) rargs+       | isValArg (deAnnotate a) = left (n-1) f (a:rargs)+       | otherwise               = left n     f (a:rargs)+    left _ _ _                   = panic "SetLevels.lvlExpr.left"++    is_val_arg :: CoreExprWithFVs -> Bool+    is_val_arg (_, AnnType {}) = False+    is_val_arg _               = True++    lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr)+    lvl_arg strs arg | (str1 : strs') <- strs+                     , is_val_arg arg+                     = do { arg' <- lvlMFE env (isStrictDmd str1) arg+                          ; return (strs', arg') }+                     | otherwise+                     = do { arg' <- lvlMFE env False arg+                          ; return (strs, arg') }++lvlApp env _ (fun, args)+  =  -- No PAPs that we can float: just carry on with the+     -- arguments and the function.+     do { args' <- mapM (lvlNonTailMFE env False) args+        ; fun'  <- lvlNonTailExpr env fun+        ; return (foldl' App fun' args') }++-------------------------------------------+lvlCase :: LevelEnv             -- Level of in-scope names/tyvars+        -> DVarSet              -- Free vars of input scrutinee+        -> LevelledExpr         -- Processed scrutinee+        -> Id -> Type           -- Case binder and result type+        -> [CoreAltWithFVs]     -- Input alternatives+        -> LvlM LevelledExpr    -- Result expression+lvlCase env scrut_fvs scrut' case_bndr ty alts+  -- See Note [Floating single-alternative cases]+  | [(con@(DataAlt {}), bs, body)] <- alts+  , exprIsHNF (deTagExpr scrut')  -- See Note [Check the output scrutinee for exprIsHNF]+  , not (isTopLvl dest_lvl)       -- Can't have top-level cases+  , not (floatTopLvlOnly env)     -- Can float anywhere+  =     -- Always float the case if possible+        -- Unlike lets we don't insist that it escapes a value lambda+    do { (env1, (case_bndr' : bs')) <- cloneCaseBndrs env dest_lvl (case_bndr : bs)+       ; let rhs_env = extendCaseBndrEnv env1 case_bndr scrut'+       ; body' <- lvlMFE rhs_env True body+       ; let alt' = (con, map (stayPut dest_lvl) bs', body')+       ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty' [alt']) }++  | otherwise     -- Stays put+  = do { let (alts_env1, [case_bndr']) = substAndLvlBndrs NonRecursive env incd_lvl [case_bndr]+             alts_env = extendCaseBndrEnv alts_env1 case_bndr scrut'+       ; alts' <- mapM (lvl_alt alts_env) alts+       ; return (Case scrut' case_bndr' ty' alts') }+  where+    ty' = substTy (le_subst env) ty++    incd_lvl = incMinorLvl (le_ctxt_lvl env)+    dest_lvl = maxFvLevel (const True) env scrut_fvs+            -- Don't abstract over type variables, hence const True++    lvl_alt alts_env (con, bs, rhs)+      = do { rhs' <- lvlMFE new_env True rhs+           ; return (con, bs', rhs') }+      where+        (new_env, bs') = substAndLvlBndrs NonRecursive alts_env incd_lvl bs++{- Note [Floating single-alternative cases]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+  data T a = MkT !a+  f :: T Int -> blah+  f x vs = case x of { MkT y ->+             let f vs = ...(case y of I# w -> e)...f..+             in f vs++Here we can float the (case y ...) out, because y is sure+to be evaluated, to give+  f x vs = case x of { MkT y ->+           caes y of I# w ->+             let f vs = ...(e)...f..+             in f vs++That saves unboxing it every time round the loop.  It's important in+some DPH stuff where we really want to avoid that repeated unboxing in+the inner loop.++Things to note:++ * The test we perform is exprIsHNF, and /not/ exprOkForSpeculation.++     - exrpIsHNF catches the key case of an evaluated variable++     - exprOkForSpeculation is /false/ of an evaluated variable;+       See Note [exprOkForSpeculation and evaluated variables] in CoreUtils+       So we'd actually miss the key case!++     - Nothing is gained from the extra generality of exprOkForSpeculation+       since we only consider floating a case whose single alternative+       is a DataAlt   K a b -> rhs++ * We can't float a case to top level++ * It's worth doing this float even if we don't float+   the case outside a value lambda.  Example+     case x of {+       MkT y -> (case y of I# w2 -> ..., case y of I# w2 -> ...)+   If we floated the cases out we could eliminate one of them.++ * We only do this with a single-alternative case++Note [Check the output scrutinee for exprIsHNF]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+  case x of y {+    A -> ....(case y of alts)....+  }++Because of the binder-swap, the inner case will get substituted to+(case x of ..).  So when testing whether the scrutinee is in HNF we+must be careful to test the *result* scrutinee ('x' in this case), not+the *input* one 'y'.  The latter *is* in HNF here (because y is+evaluated), but the former is not -- and indeed we can't float the+inner case out, at least not unless x is also evaluated at its binding+site.  See #5453.++That's why we apply exprIsHNF to scrut' and not to scrut.++See Note [Floating single-alternative cases] for why+we use exprIsHNF in the first place.+-}++lvlNonTailMFE :: LevelEnv             -- Level of in-scope names/tyvars+              -> Bool                 -- True <=> strict context [body of case+                                      --   or let]+              -> CoreExprWithFVs      -- input expression+              -> LvlM LevelledExpr    -- Result expression+lvlNonTailMFE env strict_ctxt ann_expr+  = lvlMFE (placeJoinCeiling env) strict_ctxt ann_expr++lvlMFE ::  LevelEnv             -- Level of in-scope names/tyvars+        -> Bool                 -- True <=> strict context [body of case or let]+        -> CoreExprWithFVs      -- input expression+        -> LvlM LevelledExpr    -- Result expression+-- lvlMFE is just like lvlExpr, except that it might let-bind+-- the expression, so that it can itself be floated.++lvlMFE env _ (_, AnnType ty)+  = return (Type (CoreSubst.substTy (le_subst env) ty))++-- No point in floating out an expression wrapped in a coercion or note+-- If we do we'll transform  lvl = e |> co+--                       to  lvl' = e; lvl = lvl' |> co+-- and then inline lvl.  Better just to float out the payload.+lvlMFE env strict_ctxt (_, AnnTick t e)+  = do { e' <- lvlMFE env strict_ctxt e+       ; let t' = substTickish (le_subst env) t+       ; return (Tick t' e') }++lvlMFE env strict_ctxt (_, AnnCast e (_, co))+  = do  { e' <- lvlMFE env strict_ctxt e+        ; return (Cast e' (substCo (le_subst env) co)) }++lvlMFE env strict_ctxt e@(_, AnnCase {})+  | strict_ctxt       -- Don't share cases in a strict context+  = lvlExpr env e     -- See Note [Case MFEs]++lvlMFE env strict_ctxt ann_expr+  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)+         -- Only floating to the top level is allowed.+  || anyDVarSet isJoinId fvs   -- If there is a free join, don't float+                               -- See Note [Free join points]+  || isExprLevPoly expr+         -- We can't let-bind levity polymorphic expressions+         -- See Note [Levity polymorphism invariants] in CoreSyn+  || notWorthFloating expr abs_vars+  || not float_me+  =     -- Don't float it out+    lvlExpr env ann_expr++  |  float_is_new_lam || exprIsTopLevelBindable expr expr_ty+         -- No wrapping needed if the type is lifted, or is a literal string+         -- or if we are wrapping it in one or more value lambdas+  = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive+                              (isJust mb_bot_str)+                              join_arity_maybe+                              ann_expr+                  -- Treat the expr just like a right-hand side+       ; var <- newLvlVar expr1 join_arity_maybe is_mk_static+       ; let var2 = annotateBotStr var float_n_lams mb_bot_str+       ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1)+                     (mkVarApps (Var var2) abs_vars)) }++  -- OK, so the float has an unlifted type (not top-level bindable)+  --     and no new value lambdas (float_is_new_lam is False)+  -- Try for the boxing strategy+  -- See Note [Floating MFEs of unlifted type]+  | escapes_value_lam+  , not expr_ok_for_spec -- Boxing/unboxing isn't worth it for cheap expressions+                         -- See Note [Test cheapness with exprOkForSpeculation]+  , Just (tc, _) <- splitTyConApp_maybe expr_ty+  , Just dc <- boxingDataCon_maybe tc+  , let dc_res_ty = dataConOrigResTy dc  -- No free type variables+        [bx_bndr, ubx_bndr] = mkTemplateLocals [dc_res_ty, expr_ty]+  = do { expr1 <- lvlExpr rhs_env ann_expr+       ; let l1r       = incMinorLvlFrom rhs_env+             float_rhs = mkLams abs_vars_w_lvls $+                         Case expr1 (stayPut l1r ubx_bndr) dc_res_ty+                             [(DEFAULT, [], mkConApp dc [Var ubx_bndr])]++       ; var <- newLvlVar float_rhs Nothing is_mk_static+       ; let l1u      = incMinorLvlFrom env+             use_expr = Case (mkVarApps (Var var) abs_vars)+                             (stayPut l1u bx_bndr) expr_ty+                             [(DataAlt dc, [stayPut l1u ubx_bndr], Var ubx_bndr)]+       ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs)+                     use_expr) }++  | otherwise          -- e.g. do not float unboxed tuples+  = lvlExpr env ann_expr++  where+    expr         = deAnnotate ann_expr+    expr_ty      = exprType expr+    fvs          = freeVarsOf ann_expr+    fvs_ty       = tyCoVarsOfType expr_ty+    is_bot       = isBottomThunk mb_bot_str+    is_function  = isFunction ann_expr+    mb_bot_str   = exprBotStrictness_maybe expr+                           -- See Note [Bottoming floats]+                           -- esp Bottoming floats (2)+    expr_ok_for_spec = exprOkForSpeculation expr+    dest_lvl     = destLevel env fvs fvs_ty is_function is_bot False+    abs_vars     = abstractVars dest_lvl env fvs++    -- float_is_new_lam: the floated thing will be a new value lambda+    -- replacing, say (g (x+4)) by (lvl x).  No work is saved, nor is+    -- allocation saved.  The benefit is to get it to the top level+    -- and hence out of the body of this function altogether, making+    -- it smaller and more inlinable+    float_is_new_lam = float_n_lams > 0+    float_n_lams     = count isId abs_vars++    (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars++    join_arity_maybe = Nothing++    is_mk_static = isJust (collectMakeStaticArgs expr)+        -- Yuk: See Note [Grand plan for static forms] in main/StaticPtrTable++        -- A decision to float entails let-binding this thing, and we only do+        -- that if we'll escape a value lambda, or will go to the top level.+    float_me = saves_work || saves_alloc || is_mk_static++    -- We can save work if we can move a redex outside a value lambda+    -- But if float_is_new_lam is True, then the redex is wrapped in a+    -- a new lambda, so no work is saved+    saves_work = escapes_value_lam && not float_is_new_lam++    escapes_value_lam = dest_lvl `ltMajLvl` (le_ctxt_lvl env)+                  -- See Note [Escaping a value lambda]++    -- See Note [Floating to the top]+    saves_alloc =  isTopLvl dest_lvl+                && floatConsts env+                && (not strict_ctxt || is_bot || exprIsHNF expr)++isBottomThunk :: Maybe (Arity, s) -> Bool+-- See Note [Bottoming floats] (2)+isBottomThunk (Just (0, _)) = True   -- Zero arity+isBottomThunk _             = False++{- Note [Floating to the top]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We are keen to float something to the top level, even if it does not+escape a value lambda (and hence save work), for two reasons:++  * Doing so makes the function smaller, by floating out+    bottoming expressions, or integer or string literals.  That in+    turn makes it easier to inline, with less duplication.++  * (Minor) Doing so may turn a dynamic allocation (done by machine+    instructions) into a static one. Minor because we are assuming+    we are not escaping a value lambda.++But do not so if:+     - the context is a strict, and+     - the expression is not a HNF, and+     - the expression is not bottoming++Exammples:++* Bottoming+      f x = case x of+              0 -> error <big thing>+              _ -> x+1+  Here we want to float (error <big thing>) to top level, abstracting+  over 'x', so as to make f's RHS smaller.++* HNF+      f = case y of+            True  -> p:q+            False -> blah+  We may as well float the (p:q) so it becomes a static data structure.++* Case scrutinee+      f = case g True of ....+  Don't float (g True) to top level; then we have the admin of a+  top-level thunk to worry about, with zero gain.++* Case alternative+      h = case y of+             True  -> g True+             False -> False+  Don't float (g True) to the top level++* Arguments+     t = f (g True)+  If f is lazy, we /do/ float (g True) because then we can allocate+  the thunk statically rather than dynamically.  But if f is strict+  we don't (see the use of idStrictness in lvlApp).  It's not clear+  if this test is worth the bother: it's only about CAFs!++It's controlled by a flag (floatConsts), because doing this too+early loses opportunities for RULES which (needless to say) are+important in some nofib programs (gcd is an example).  [SPJ note:+I think this is obselete; the flag seems always on.]++Note [Floating join point bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Mostly we only float a join point if it can /stay/ a join point.  But+there is one exception: if it can go to the top level (#13286).+Consider+  f x = joinrec j y n = <...j y' n'...>+        in jump j x 0++Here we may just as well produce+  j y n = <....j y' n'...>+  f x = j x 0++and now there is a chance that 'f' will be inlined at its call sites.+It shouldn't make a lot of difference, but thes tests+  perf/should_run/MethSharing+  simplCore/should_compile/spec-inline+and one nofib program, all improve if you do float to top, because+of the resulting inlining of f.  So ok, let's do it.++Note [Free join points]+~~~~~~~~~~~~~~~~~~~~~~~+We never float a MFE that has a free join-point variable.  You mght think+this can never occur.  After all, consider+     join j x = ...+     in ....(jump j x)....+How might we ever want to float that (jump j x)?+  * If it would escape a value lambda, thus+        join j x = ... in (\y. ...(jump j x)... )+    then 'j' isn't a valid join point in the first place.++But consider+     join j x = .... in+     joinrec j2 y =  ...(jump j x)...(a+b)....++Since j2 is recursive, it /is/ worth floating (a+b) out of the joinrec.+But it is emphatically /not/ good to float the (jump j x) out:+ (a) 'j' will stop being a join point+ (b) In any case, jumping to 'j' must be an exit of the j2 loop, so no+     work would be saved by floating it out of the \y.++Even if we floated 'j' to top level, (b) would still hold.++Bottom line: never float a MFE that has a free JoinId.++Note [Floating MFEs of unlifted type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   case f x of (r::Int#) -> blah+we'd like to float (f x). But it's not trivial because it has type+Int#, and we don't want to evaluate it too early.  But we can instead+float a boxed version+   y = case f x of r -> I# r+and replace the original (f x) with+   case (case y of I# r -> r) of r -> blah++Being able to float unboxed expressions is sometimes important; see+#12603.  I'm not sure how /often/ it is important, but it's+not hard to achieve.++We only do it for a fixed collection of types for which we have a+convenient boxing constructor (see boxingDataCon_maybe).  In+particular we /don't/ do it for unboxed tuples; it's better to float+the components of the tuple individually.++I did experiment with a form of boxing that works for any type, namely+wrapping in a function.  In our example++   let y = case f x of r -> \v. f x+   in case y void of r -> blah++It works fine, but it's 50% slower (based on some crude benchmarking).+I suppose we could do it for types not covered by boxingDataCon_maybe,+but it's more code and I'll wait to see if anyone wants it.++Note [Test cheapness with exprOkForSpeculation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't want to float very cheap expressions by boxing and unboxing.+But we use exprOkForSpeculation for the test, not exprIsCheap.+Why?  Because it's important /not/ to transform+     f (a /# 3)+to+     f (case bx of I# a -> a /# 3)+and float bx = I# (a /# 3), because the application of f no+longer obeys the let/app invariant.  But (a /# 3) is ok-for-spec+due to a special hack that says division operators can't fail+when the denominator is definitely non-zero.  And yet that+same expression says False to exprIsCheap.  Simplest way to+guarantee the let/app invariant is to use the same function!++If an expression is okay for speculation, we could also float it out+*without* boxing and unboxing, since evaluating it early is okay.+However, it turned out to usually be better not to float such expressions,+since they tend to be extremely cheap things like (x +# 1#). Even the+cost of spilling the let-bound variable to the stack across a call may+exceed the cost of recomputing such an expression. (And we can't float+unlifted bindings to top-level.)++We could try to do something smarter here, and float out expensive yet+okay-for-speculation things, such as division by non-zero constants.+But I suspect it's a narrow target.++Note [Bottoming floats]+~~~~~~~~~~~~~~~~~~~~~~~+If we see+        f = \x. g (error "urk")+we'd like to float the call to error, to get+        lvl = error "urk"+        f = \x. g lvl++But, as ever, we need to be careful:++(1) We want to float a bottoming+    expression even if it has free variables:+        f = \x. g (let v = h x in error ("urk" ++ v))+    Then we'd like to abstract over 'x' can float the whole arg of g:+        lvl = \x. let v = h x in error ("urk" ++ v)+        f = \x. g (lvl x)+    To achieve this we pass is_bot to destLevel++(2) We do not do this for lambdas that return+    bottom.  Instead we treat the /body/ of such a function specially,+    via point (1).  For example:+        f = \x. ....(\y z. if x then error y else error z)....+    ===>+        lvl = \x z y. if b then error y else error z+        f = \x. ...(\y z. lvl x z y)...+    (There is no guarantee that we'll choose the perfect argument order.)++(3) If we have a /binding/ that returns bottom, we want to float it to top+    level, even if it has free vars (point (1)), and even it has lambdas.+    Example:+       ... let { v = \y. error (show x ++ show y) } in ...+    We want to abstract over x and float the whole thing to top:+       lvl = \xy. errror (show x ++ show y)+       ...let {v = lvl x} in ...++    Then of course we don't want to separately float the body (error ...)+    as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot+    argument.++See Maessen's paper 1999 "Bottom extraction: factoring error handling out+of functional programs" (unpublished I think).++When we do this, we set the strictness and arity of the new bottoming+Id, *immediately*, for three reasons:++  * To prevent the abstracted thing being immediately inlined back in again+    via preInlineUnconditionally.  The latter has a test for bottoming Ids+    to stop inlining them, so we'd better make sure it *is* a bottoming Id!++  * So that it's properly exposed as such in the interface file, even if+    this is all happening after strictness analysis.++  * In case we do CSE with the same expression that *is* marked bottom+        lvl          = error "urk"+          x{str=bot) = error "urk"+    Here we don't want to replace 'x' with 'lvl', else we may get Lint+    errors, e.g. via a case with empty alternatives:  (case x of {})+    Lint complains unless the scrutinee of such a case is clearly bottom.++    This was reported in #11290.   But since the whole bottoming-float+    thing is based on the cheap-and-cheerful exprIsBottom, I'm not sure+    that it'll nail all such cases.++Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Tiresomely, though, the simplifier has an invariant that the manifest+arity of the RHS should be the same as the arity; but we can't call+etaExpand during SetLevels because it works over a decorated form of+CoreExpr.  So we do the eta expansion later, in FloatOut.++Note [Case MFEs]+~~~~~~~~~~~~~~~~+We don't float a case expression as an MFE from a strict context.  Why not?+Because in doing so we share a tiny bit of computation (the switch) but+in exchange we build a thunk, which is bad.  This case reduces allocation+by 7% in spectral/puzzle (a rather strange benchmark) and 1.2% in real/fem.+Doesn't change any other allocation at all.++We will make a separate decision for the scrutinee and alternatives.++However this can have a knock-on effect for fusion: consider+    \v -> foldr k z (case x of I# y -> build ..y..)+Perhaps we can float the entire (case x of ...) out of the \v.  Then+fusion will not happen, but we will get more sharing.  But if we don't+float the case (as advocated here) we won't float the (build ...y..)+either, so fusion will happen.  It can be a big effect, esp in some+artificial benchmarks (e.g. integer, queens), but there is no perfect+answer.++-}++annotateBotStr :: Id -> Arity -> Maybe (Arity, StrictSig) -> Id+-- See Note [Bottoming floats] for why we want to add+-- bottoming information right now+--+-- n_extra are the number of extra value arguments added during floating+annotateBotStr id n_extra mb_str+  = case mb_str of+      Nothing           -> id+      Just (arity, sig) -> id `setIdArity`      (arity + n_extra)+                              `setIdStrictness` (increaseStrictSigArity n_extra sig)++notWorthFloating :: CoreExpr -> [Var] -> Bool+-- Returns True if the expression would be replaced by+-- something bigger than it is now.  For example:+--   abs_vars = tvars only:  return True if e is trivial,+--                           but False for anything bigger+--   abs_vars = [x] (an Id): return True for trivial, or an application (f x)+--                           but False for (f x x)+--+-- One big goal is that floating should be idempotent.  Eg if+-- we replace e with (lvl79 x y) and then run FloatOut again, don't want+-- to replace (lvl79 x y) with (lvl83 x y)!++notWorthFloating e abs_vars+  = go e (count isId abs_vars)+  where+    go (Var {}) n    = n >= 0+    go (Lit lit) n   = ASSERT( n==0 )+                       litIsTrivial lit   -- Note [Floating literals]+    go (Tick t e) n  = not (tickishIsCode t) && go e n+    go (Cast e _)  n = go e n+    go (App e arg) n+       | Type {}     <- arg = go e n+       | Coercion {} <- 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 (Tick t e)            = not (tickishIsCode t) && is_triv e+    is_triv _                     = False++{-+Note [Floating literals]+~~~~~~~~~~~~~~~~~~~~~~~~+It's important to float Integer literals, so that they get shared,+rather than being allocated every time round the loop.+Hence the litIsTrivial.++Ditto literal strings (LitString), which we'd like to float to top+level, which is now possible.+++Note [Escaping a value lambda]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to float even cheap expressions out of value lambdas,+because that saves allocation.  Consider+        f = \x.  .. (\y.e) ...+Then we'd like to avoid allocating the (\y.e) every time we call f,+(assuming e does not mention x). An example where this really makes a+difference is simplrun009.++Another reason it's good is because it makes SpecContr fire on functions.+Consider+        f = \x. ....(f (\y.e))....+After floating we get+        lvl = \y.e+        f = \x. ....(f lvl)...+and that is much easier for SpecConstr to generate a robust+specialisation for.++However, if we are wrapping the thing in extra value lambdas (in+abs_vars), then nothing is saved.  E.g.+        f = \xyz. ...(e1[y],e2)....+If we float+        lvl = \y. (e1[y],e2)+        f = \xyz. ...(lvl y)...+we have saved nothing: one pair will still be allocated for each+call of 'f'.  Hence the (not float_is_lam) in float_me.+++************************************************************************+*                                                                      *+\subsection{Bindings}+*                                                                      *+************************************************************************++The binding stuff works for top level too.+-}++lvlBind :: LevelEnv+        -> CoreBindWithFVs+        -> LvlM (LevelledBind, LevelEnv)++lvlBind env (AnnNonRec bndr rhs)+  | isTyVar bndr    -- Don't do anything for TyVar binders+                    --   (simplifier gets rid of them pronto)+  || isCoVar bndr   -- Difficult to fix up CoVar occurrences (see extendPolyLvlEnv)+                    -- so we will ignore this case for now+  || not (profitableFloat env dest_lvl)+  || (isTopLvl dest_lvl && not (exprIsTopLevelBindable deann_rhs bndr_ty))+          -- We can't float an unlifted binding to top level (except+          -- literal strings), so we don't float it at all.  It's a+          -- bit brutal, but unlifted bindings aren't expensive either++  = -- No float+    do { rhs' <- lvlRhs env NonRecursive is_bot mb_join_arity rhs+       ; let  bind_lvl        = incMinorLvl (le_ctxt_lvl env)+              (env', [bndr']) = substAndLvlBndrs NonRecursive env bind_lvl [bndr]+       ; return (NonRec bndr' rhs', env') }++  -- Otherwise we are going to float+  | null abs_vars+  = do {  -- No type abstraction; clone existing binder+         rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive+                             is_bot mb_join_arity rhs+       ; (env', [bndr']) <- cloneLetVars NonRecursive env dest_lvl [bndr]+       ; let bndr2 = annotateBotStr bndr' 0 mb_bot_str+       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }++  | otherwise+  = do {  -- Yes, type abstraction; create a new binder, extend substitution, etc+         rhs' <- lvlFloatRhs abs_vars dest_lvl env NonRecursive+                             is_bot mb_join_arity rhs+       ; (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr]+       ; let bndr2 = annotateBotStr bndr' n_extra mb_bot_str+       ; return (NonRec (TB bndr2 (FloatMe dest_lvl)) rhs', env') }++  where+    bndr_ty    = idType bndr+    ty_fvs     = tyCoVarsOfType bndr_ty+    rhs_fvs    = freeVarsOf rhs+    bind_fvs   = rhs_fvs `unionDVarSet` dIdFreeVars bndr+    abs_vars   = abstractVars dest_lvl env bind_fvs+    dest_lvl   = destLevel env bind_fvs ty_fvs (isFunction rhs) is_bot is_join++    deann_rhs  = deAnnotate rhs+    mb_bot_str = exprBotStrictness_maybe deann_rhs+    is_bot     = isJust mb_bot_str+        -- NB: not isBottomThunk!  See Note [Bottoming floats] point (3)++    n_extra    = count isId abs_vars+    mb_join_arity = isJoinId_maybe bndr+    is_join       = isJust mb_join_arity++lvlBind env (AnnRec pairs)+  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)+         -- Only floating to the top level is allowed.+  || not (profitableFloat env dest_lvl)+  = do { let bind_lvl       = incMinorLvl (le_ctxt_lvl env)+             (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs+             lvl_rhs (b,r)  = lvlRhs env' Recursive is_bot (isJoinId_maybe b) r+       ; rhss' <- mapM lvl_rhs pairs+       ; return (Rec (bndrs' `zip` rhss'), env') }++  | null abs_vars+  = do { (new_env, new_bndrs) <- cloneLetVars Recursive env dest_lvl bndrs+       ; new_rhss <- mapM (do_rhs new_env) pairs+       ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)+                , new_env) }++-- ToDo: when enabling the floatLambda stuff,+--       I think we want to stop doing this+  | [(bndr,rhs)] <- pairs+  , count isId abs_vars > 1+  = do  -- Special case for self recursion where there are+        -- several variables carried around: build a local loop:+        --      poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars+        -- This just makes the closures a bit smaller.  If we don't do+        -- this, allocation rises significantly on some programs+        --+        -- We could elaborate it for the case where there are several+        -- mutually recursive functions, but it's quite a bit more complicated+        --+        -- This all seems a bit ad hoc -- sigh+    let (rhs_env, abs_vars_w_lvls) = lvlLamBndrs env dest_lvl abs_vars+        rhs_lvl = le_ctxt_lvl rhs_env++    (rhs_env', [new_bndr]) <- cloneLetVars Recursive rhs_env rhs_lvl [bndr]+    let+        (lam_bndrs, rhs_body)   = collectAnnBndrs rhs+        (body_env1, lam_bndrs1) = substBndrsSL NonRecursive rhs_env' lam_bndrs+        (body_env2, lam_bndrs2) = lvlLamBndrs body_env1 rhs_lvl lam_bndrs1+    new_rhs_body <- lvlRhs body_env2 Recursive is_bot (get_join bndr) rhs_body+    (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr]+    return (Rec [(TB poly_bndr (FloatMe dest_lvl)+                 , mkLams abs_vars_w_lvls $+                   mkLams lam_bndrs2 $+                   Let (Rec [( TB new_bndr (StayPut rhs_lvl)+                             , mkLams lam_bndrs2 new_rhs_body)])+                       (mkVarApps (Var new_bndr) lam_bndrs1))]+           , poly_env)++  | otherwise  -- Non-null abs_vars+  = do { (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs+       ; new_rhss <- mapM (do_rhs new_env) pairs+       ; return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss)+                , new_env) }++  where+    (bndrs,rhss) = unzip pairs+    is_join  = isJoinId (head bndrs)+                -- bndrs is always non-empty and if one is a join they all are+                -- Both are checked by Lint+    is_fun   = all isFunction rhss+    is_bot   = False  -- It's odd to have an unconditionally divergent+                      -- function in a Rec, and we don't much care what+                      -- happens to it.  False is simple!++    do_rhs env (bndr,rhs) = lvlFloatRhs abs_vars dest_lvl env Recursive+                                        is_bot (get_join bndr)+                                        rhs++    get_join bndr | need_zap  = Nothing+                  | otherwise = isJoinId_maybe bndr+    need_zap = dest_lvl `ltLvl` joinCeilingLevel env++        -- Finding the free vars of the binding group is annoying+    bind_fvs = ((unionDVarSets [ freeVarsOf rhs | (_, rhs) <- pairs])+                `unionDVarSet`+                (fvDVarSet $ unionsFV [ idFVs bndr+                                      | (bndr, (_,_)) <- pairs]))+               `delDVarSetList`+                bndrs++    ty_fvs   = foldr (unionVarSet . tyCoVarsOfType . idType) emptyVarSet bndrs+    dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot is_join+    abs_vars = abstractVars dest_lvl env bind_fvs++profitableFloat :: LevelEnv -> Level -> Bool+profitableFloat env dest_lvl+  =  (dest_lvl `ltMajLvl` le_ctxt_lvl env)  -- Escapes a value lambda+  || isTopLvl dest_lvl                      -- Going all the way to top level+++----------------------------------------------------+-- Three help functions for the type-abstraction case++lvlRhs :: LevelEnv+       -> RecFlag+       -> Bool               -- Is this a bottoming function+       -> Maybe JoinArity+       -> CoreExprWithFVs+       -> LvlM LevelledExpr+lvlRhs env rec_flag is_bot mb_join_arity expr+  = lvlFloatRhs [] (le_ctxt_lvl env) env+                rec_flag is_bot mb_join_arity expr++lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag+            -> Bool   -- Binding is for a bottoming function+            -> Maybe JoinArity+            -> CoreExprWithFVs+            -> LvlM (Expr LevelledBndr)+-- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline+lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs+  = do { body' <- if not is_bot  -- See Note [Floating from a RHS]+                     && any isId bndrs+                  then lvlMFE  body_env True body+                  else lvlExpr body_env      body+       ; return (mkLams bndrs' body') }+  where+    (bndrs, body)     | Just join_arity <- mb_join_arity+                      = collectNAnnBndrs join_arity rhs+                      | otherwise+                      = collectAnnBndrs rhs+    (env1, bndrs1)    = substBndrsSL NonRecursive env bndrs+    all_bndrs         = abs_vars ++ bndrs1+    (body_env, bndrs') | Just _ <- mb_join_arity+                      = lvlJoinBndrs env1 dest_lvl rec all_bndrs+                      | otherwise+                      = case lvlLamBndrs env1 dest_lvl all_bndrs of+                          (env2, bndrs') -> (placeJoinCeiling env2, bndrs')+        -- The important thing here is that we call lvlLamBndrs on+        -- all these binders at once (abs_vars and bndrs), so they+        -- all get the same major level.  Otherwise we create stupid+        -- let-bindings inside, joyfully thinking they can float; but+        -- in the end they don't because we never float bindings in+        -- between lambdas++{- Note [Floating from a RHS]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When floating the RHS of a let-binding, we don't always want to apply+lvlMFE to the body of a lambda, as we usually do, because the entire+binding body is already going to the right place (dest_lvl).++A particular example is the top level.  Consider+   concat = /\ a -> foldr ..a.. (++) []+We don't want to float the body of the lambda to get+   lvl    = /\ a -> foldr ..a.. (++) []+   concat = /\ a -> lvl a+That would be stupid.++Previously this was avoided in a much nastier way, by testing strict_ctxt+in float_me in lvlMFE.  But that wasn't even right because it would fail+to float out the error sub-expression in+    f = \x. case x of+              True  -> error ("blah" ++ show x)+              False -> ...++But we must be careful:++* If we had+    f = \x -> factorial 20+  we /would/ want to float that (factorial 20) out!  Functions are treated+  differently: see the use of isFunction in the calls to destLevel. If+  there are only type lambdas, then destLevel will say "go to top, and+  abstract over the free tyvars" and we don't want that here.++* But if we had+    f = \x -> error (...x....)+  we would NOT want to float the bottoming expression out to give+    lvl = \x -> error (...x...)+    f = \x -> lvl x++Conclusion: use lvlMFE if there are+  * any value lambdas in the original function, and+  * this is not a bottoming function (the is_bot argument)+Use lvlExpr otherwise.  A little subtle, and I got it wrong at least twice+(e.g. #13369).+-}++{-+************************************************************************+*                                                                      *+\subsection{Deciding floatability}+*                                                                      *+************************************************************************+-}++substAndLvlBndrs :: RecFlag -> LevelEnv -> Level -> [InVar] -> (LevelEnv, [LevelledBndr])+substAndLvlBndrs is_rec env lvl bndrs+  = lvlBndrs subst_env lvl subst_bndrs+  where+    (subst_env, subst_bndrs) = substBndrsSL is_rec env bndrs++substBndrsSL :: RecFlag -> LevelEnv -> [InVar] -> (LevelEnv, [OutVar])+-- So named only to avoid the name clash with CoreSubst.substBndrs+substBndrsSL is_rec env@(LE { le_subst = subst, le_env = id_env }) bndrs+  = ( env { le_subst    = subst'+          , le_env      = foldl' add_id  id_env (bndrs `zip` bndrs') }+    , bndrs')+  where+    (subst', bndrs') = case is_rec of+                         NonRecursive -> substBndrs    subst bndrs+                         Recursive    -> substRecBndrs subst bndrs++lvlLamBndrs :: LevelEnv -> Level -> [OutVar] -> (LevelEnv, [LevelledBndr])+-- Compute the levels for the binders of a lambda group+lvlLamBndrs env lvl bndrs+  = lvlBndrs env new_lvl bndrs+  where+    new_lvl | any is_major bndrs = incMajorLvl lvl+            | otherwise          = incMinorLvl lvl++    is_major bndr = isId bndr && not (isProbablyOneShotLambda bndr)+       -- The "probably" part says "don't float things out of a+       -- probable one-shot lambda"+       -- See Note [Computing one-shot info] in Demand.hs++lvlJoinBndrs :: LevelEnv -> Level -> RecFlag -> [OutVar]+             -> (LevelEnv, [LevelledBndr])+lvlJoinBndrs env lvl rec bndrs+  = lvlBndrs env new_lvl bndrs+  where+    new_lvl | isRec rec = incMajorLvl lvl+            | otherwise = incMinorLvl lvl+      -- Non-recursive join points are one-shot; recursive ones are not++lvlBndrs :: LevelEnv -> Level -> [CoreBndr] -> (LevelEnv, [LevelledBndr])+-- The binders returned are exactly the same as the ones passed,+-- apart from applying the substitution, but they are now paired+-- with a (StayPut level)+--+-- The returned envt has le_ctxt_lvl updated to the new_lvl+--+-- All the new binders get the same level, because+-- any floating binding is either going to float past+-- all or none.  We never separate binders.+lvlBndrs env@(LE { le_lvl_env = lvl_env }) new_lvl bndrs+  = ( env { le_ctxt_lvl = new_lvl+          , le_join_ceil = new_lvl+          , le_lvl_env  = addLvls new_lvl lvl_env bndrs }+    , map (stayPut new_lvl) bndrs)++stayPut :: Level -> OutVar -> LevelledBndr+stayPut new_lvl bndr = TB bndr (StayPut new_lvl)++  -- Destination level is the max Id level of the expression+  -- (We'll abstract the type variables, if any.)+destLevel :: LevelEnv+          -> DVarSet    -- Free vars of the term+          -> TyCoVarSet -- Free in the /type/ of the term+                        -- (a subset of the previous argument)+          -> Bool   -- True <=> is function+          -> Bool   -- True <=> is bottom+          -> Bool   -- True <=> is a join point+          -> Level+-- INVARIANT: if is_join=True then result >= join_ceiling+destLevel env fvs fvs_ty is_function is_bot is_join+  | isTopLvl max_fv_id_level  -- Float even joins if they get to top level+                              -- See Note [Floating join point bindings]+  = tOP_LEVEL++  | is_join  -- Never float a join point past the join ceiling+             -- See Note [Join points] in FloatOut+  = if max_fv_id_level `ltLvl` join_ceiling+    then join_ceiling+    else max_fv_id_level++  | is_bot              -- Send bottoming bindings to the top+  = as_far_as_poss      -- regardless; see Note [Bottoming floats]+                        -- Esp Bottoming floats (1)++  | Just n_args <- floatLams env+  , n_args > 0  -- n=0 case handled uniformly by the 'otherwise' case+  , is_function+  , countFreeIds fvs <= n_args+  = as_far_as_poss  -- Send functions to top level; see+                    -- the comments with isFunction++  | otherwise = max_fv_id_level+  where+    join_ceiling    = joinCeilingLevel env+    max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the+                                              -- tyvars will be abstracted++    as_far_as_poss = maxFvLevel' isId env fvs_ty+                     -- See Note [Floating and kind casts]++{- Note [Floating and kind casts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   case x of+     K (co :: * ~# k) -> let v :: Int |> co+                             v = e+                         in blah++Then, even if we are abstracting over Ids, or if e is bottom, we can't+float v outside the 'co' binding.  Reason: if we did we'd get+    v' :: forall k. (Int ~# Age) => Int |> co+and now 'co' isn't in scope in that type. The underlying reason is+that 'co' is a value-level thing and we can't abstract over that in a+type (else we'd get a dependent type).  So if v's /type/ mentions 'co'+we can't float it out beyond the binding site of 'co'.++That's why we have this as_far_as_poss stuff.  Usually as_far_as_poss+is just tOP_LEVEL; but occasionally a coercion variable (which is an+Id) mentioned in type prevents this.++Example #14270 comment:15.+-}+++isFunction :: CoreExprWithFVs -> Bool+-- The idea here is that we want to float *functions* to+-- the top level.  This saves no work, but+--      (a) it can make the host function body a lot smaller,+--              and hence inlinable.+--      (b) it can also save allocation when the function is recursive:+--          h = \x -> letrec f = \y -> ...f...y...x...+--                    in f x+--     becomes+--          f = \x y -> ...(f x)...y...x...+--          h = \x -> f x x+--     No allocation for f now.+-- We may only want to do this if there are sufficiently few free+-- variables.  We certainly only want to do it for values, and not for+-- constructors.  So the simple thing is just to look for lambdas+isFunction (_, AnnLam b e) | isId b    = True+                           | otherwise = isFunction e+-- isFunction (_, AnnTick _ e)         = isFunction e  -- dubious+isFunction _                           = False++countFreeIds :: DVarSet -> Int+countFreeIds = nonDetFoldUDFM add 0 . getUniqDSet+  -- It's OK to use nonDetFoldUDFM here because we're just counting things.+  where+    add :: Var -> Int -> Int+    add v n | isId v    = n+1+            | otherwise = n++{-+************************************************************************+*                                                                      *+\subsection{Free-To-Level Monad}+*                                                                      *+************************************************************************+-}++data LevelEnv+  = LE { le_switches :: FloatOutSwitches+       , le_ctxt_lvl :: Level           -- The current level+       , le_lvl_env  :: VarEnv Level    -- Domain is *post-cloned* TyVars and Ids+       , le_join_ceil:: Level           -- Highest level to which joins float+                                        -- Invariant: always >= le_ctxt_lvl++       -- See Note [le_subst and le_env]+       , le_subst    :: Subst           -- Domain is pre-cloned TyVars and Ids+                                        -- The Id -> CoreExpr in the Subst is ignored+                                        -- (since we want to substitute a LevelledExpr for+                                        -- an Id via le_env) but we do use the Co/TyVar substs+       , le_env      :: IdEnv ([OutVar], LevelledExpr)  -- Domain is pre-cloned Ids+    }++{- Note [le_subst and le_env]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We clone let- and case-bound variables so that they are still distinct+when floated out; hence the le_subst/le_env.  (see point 3 of the+module overview comment).  We also use these envs when making a+variable polymorphic because we want to float it out past a big+lambda.++The le_subst and le_env always implement the same mapping,+     in_x :->  out_x a b+where out_x is an OutVar, and a,b are its arguments (when+we perform abstraction at the same time as floating).++  le_subst maps to CoreExpr+  le_env   maps to LevelledExpr++Since the range is always a variable or application, there is never+any difference between the two, but sadly the types differ.  The+le_subst is used when substituting in a variable's IdInfo; the le_env+when we find a Var.++In addition the le_env records a [OutVar] of variables free in the+OutExpr/LevelledExpr, just so we don't have to call freeVars+repeatedly.  This list is always non-empty, and the first element is+out_x++The domain of the both envs is *pre-cloned* Ids, though++The domain of the le_lvl_env is the *post-cloned* Ids+-}++initialEnv :: FloatOutSwitches -> LevelEnv+initialEnv float_lams+  = LE { le_switches = float_lams+       , le_ctxt_lvl = tOP_LEVEL+       , le_join_ceil = panic "initialEnv"+       , le_lvl_env = emptyVarEnv+       , le_subst = emptySubst+       , le_env = emptyVarEnv }++addLvl :: Level -> VarEnv Level -> OutVar -> VarEnv Level+addLvl dest_lvl env v' = extendVarEnv env v' dest_lvl++addLvls :: Level -> VarEnv Level -> [OutVar] -> VarEnv Level+addLvls dest_lvl env vs = foldl' (addLvl dest_lvl) env vs++floatLams :: LevelEnv -> Maybe Int+floatLams le = floatOutLambdas (le_switches le)++floatConsts :: LevelEnv -> Bool+floatConsts le = floatOutConstants (le_switches le)++floatOverSat :: LevelEnv -> Bool+floatOverSat le = floatOutOverSatApps (le_switches le)++floatTopLvlOnly :: LevelEnv -> Bool+floatTopLvlOnly le = floatToTopLevelOnly (le_switches le)++incMinorLvlFrom :: LevelEnv -> Level+incMinorLvlFrom env = incMinorLvl (le_ctxt_lvl env)++-- extendCaseBndrEnv adds the mapping case-bndr->scrut-var if it can+-- See Note [Binder-swap during float-out]+extendCaseBndrEnv :: LevelEnv+                  -> Id                 -- Pre-cloned case binder+                  -> Expr LevelledBndr  -- Post-cloned scrutinee+                  -> LevelEnv+extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })+                  case_bndr (Var scrut_var)+  = le { le_subst   = extendSubstWithVar subst case_bndr scrut_var+       , le_env     = add_id id_env (case_bndr, scrut_var) }+extendCaseBndrEnv env _ _ = env++-- See Note [Join ceiling]+placeJoinCeiling :: LevelEnv -> LevelEnv+placeJoinCeiling le@(LE { le_ctxt_lvl = lvl })+  = le { le_ctxt_lvl = lvl', le_join_ceil = lvl' }+  where+    lvl' = asJoinCeilLvl (incMinorLvl lvl)++maxFvLevel :: (Var -> Bool) -> LevelEnv -> DVarSet -> Level+maxFvLevel max_me env var_set+  = foldDVarSet (maxIn max_me env) tOP_LEVEL var_set++maxFvLevel' :: (Var -> Bool) -> LevelEnv -> TyCoVarSet -> Level+-- Same but for TyCoVarSet+maxFvLevel' max_me env var_set+  = nonDetFoldUniqSet (maxIn max_me env) tOP_LEVEL var_set++maxIn :: (Var -> Bool) -> LevelEnv -> InVar -> Level -> Level+maxIn max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) in_var lvl+  = case lookupVarEnv id_env in_var of+      Just (abs_vars, _) -> foldr max_out lvl abs_vars+      Nothing            -> max_out in_var lvl+  where+    max_out out_var lvl+        | max_me out_var = case lookupVarEnv lvl_env out_var of+                                Just lvl' -> maxLvl lvl' lvl+                                Nothing   -> lvl+        | otherwise = lvl       -- Ignore some vars depending on max_me++lookupVar :: LevelEnv -> Id -> LevelledExpr+lookupVar le v = case lookupVarEnv (le_env le) v of+                    Just (_, expr) -> expr+                    _              -> Var v++-- Level to which join points are allowed to float (boundary of current tail+-- context). See Note [Join ceiling]+joinCeilingLevel :: LevelEnv -> Level+joinCeilingLevel = le_join_ceil++abstractVars :: Level -> LevelEnv -> DVarSet -> [OutVar]+        -- Find the variables in fvs, free vars of the target expression,+        -- whose level is greater than the destination level+        -- These are the ones we are going to abstract out+        --+        -- Note that to get reproducible builds, the variables need to be+        -- abstracted in deterministic order, not dependent on the values of+        -- Uniques. This is achieved by using DVarSets, deterministic free+        -- variable computation and deterministic sort.+        -- See Note [Unique Determinism] in Unique for explanation of why+        -- Uniques are not deterministic.+abstractVars dest_lvl (LE { le_subst = subst, le_lvl_env = lvl_env }) in_fvs+  =  -- NB: sortQuantVars might not put duplicates next to each other+    map zap $ sortQuantVars $+    filter abstract_me      $+    dVarSetElems            $+    closeOverKindsDSet      $+    substDVarSet subst in_fvs+        -- NB: it's important to call abstract_me only on the OutIds the+        -- come from substDVarSet (not on fv, which is an InId)+  where+    abstract_me v = case lookupVarEnv lvl_env v of+                        Just lvl -> dest_lvl `ltLvl` lvl+                        Nothing  -> False++        -- We are going to lambda-abstract, so nuke any IdInfo,+        -- and add the tyvars of the Id (if necessary)+    zap v | isId v = WARN( isStableUnfolding (idUnfolding v) ||+                           not (isEmptyRuleInfo (idSpecialisation v)),+                           text "absVarsOf: discarding info on" <+> ppr v )+                     setIdInfo v vanillaIdInfo+          | otherwise = v++type LvlM result = UniqSM result++initLvl :: UniqSupply -> UniqSM a -> a+initLvl = initUs_++newPolyBndrs :: Level -> LevelEnv -> [OutVar] -> [InId]+             -> LvlM (LevelEnv, [OutId])+-- The envt is extended to bind the new bndrs to dest_lvl, but+-- the le_ctxt_lvl is unaffected+newPolyBndrs dest_lvl+             env@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env })+             abs_vars bndrs+ = ASSERT( all (not . isCoVar) bndrs )   -- What would we add to the CoSubst in this case. No easy answer.+   do { uniqs <- getUniquesM+      ; let new_bndrs = zipWith mk_poly_bndr bndrs uniqs+            bndr_prs  = bndrs `zip` new_bndrs+            env' = env { le_lvl_env = addLvls dest_lvl lvl_env new_bndrs+                       , le_subst   = foldl' add_subst subst   bndr_prs+                       , le_env     = foldl' add_id    id_env  bndr_prs }+      ; return (env', new_bndrs) }+  where+    add_subst env (v, v') = extendIdSubst env v (mkVarApps (Var v') abs_vars)+    add_id    env (v, v') = extendVarEnv env v ((v':abs_vars), mkVarApps (Var v') abs_vars)++    mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $         -- Note [transferPolyIdInfo] in Id.hs+                             transfer_join_info bndr $+                             mkSysLocalOrCoVar (mkFastString str) uniq poly_ty+                           where+                             str     = "poly_" ++ occNameString (getOccName bndr)+                             poly_ty = mkLamTypes abs_vars (CoreSubst.substTy subst (idType bndr))++    -- If we are floating a join point to top level, it stops being+    -- a join point.  Otherwise it continues to be a join point,+    -- but we may need to adjust its arity+    dest_is_top = isTopLvl dest_lvl+    transfer_join_info bndr new_bndr+      | Just join_arity <- isJoinId_maybe bndr+      , not dest_is_top+      = new_bndr `asJoinId` join_arity + length abs_vars+      | otherwise+      = new_bndr++newLvlVar :: LevelledExpr        -- The RHS of the new binding+          -> Maybe JoinArity     -- Its join arity, if it is a join point+          -> Bool                -- True <=> the RHS looks like (makeStatic ...)+          -> LvlM Id+newLvlVar lvld_rhs join_arity_maybe is_mk_static+  = do { uniq <- getUniqueM+       ; return (add_join_info (mk_id uniq rhs_ty))+       }+  where+    add_join_info var = var `asJoinId_maybe` join_arity_maybe+    de_tagged_rhs = deTagExpr lvld_rhs+    rhs_ty        = exprType de_tagged_rhs++    mk_id uniq rhs_ty+      -- See Note [Grand plan for static forms] in StaticPtrTable.+      | is_mk_static+      = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))+                            rhs_ty+      | otherwise+      = mkSysLocalOrCoVar (mkFastString "lvl") uniq rhs_ty++cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])+cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })+               new_lvl vs+  = do { us <- getUniqueSupplyM+       ; let (subst', vs') = cloneBndrs subst us vs+             env' = env { le_ctxt_lvl  = new_lvl+                        , le_join_ceil = new_lvl+                        , le_lvl_env   = addLvls new_lvl lvl_env vs'+                        , le_subst     = subst'+                        , le_env       = foldl' add_id id_env (vs `zip` vs') }++       ; return (env', vs') }++cloneLetVars :: RecFlag -> LevelEnv -> Level -> [InVar]+             -> LvlM (LevelEnv, [OutVar])+-- See Note [Need for cloning during float-out]+-- Works for Ids bound by let(rec)+-- The dest_lvl is attributed to the binders in the new env,+-- but cloneVars doesn't affect the le_ctxt_lvl of the incoming env+cloneLetVars is_rec+          env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })+          dest_lvl vs+  = do { us <- getUniqueSupplyM+       ; let vs1  = map zap vs+                      -- See Note [Zapping the demand info]+             (subst', vs2) = case is_rec of+                               NonRecursive -> cloneBndrs      subst us vs1+                               Recursive    -> cloneRecIdBndrs subst us vs1+             prs  = vs `zip` vs2+             env' = env { le_lvl_env = addLvls dest_lvl lvl_env vs2+                        , le_subst   = subst'+                        , le_env     = foldl' add_id id_env prs }++       ; return (env', vs2) }+  where+    zap :: Var -> Var+    zap v | isId v    = zap_join (zapIdDemandInfo v)+          | otherwise = v++    zap_join | isTopLvl dest_lvl = zapJoinId+             | otherwise         = id++add_id :: IdEnv ([Var], LevelledExpr) -> (Var, Var) -> IdEnv ([Var], LevelledExpr)+add_id id_env (v, v1)+  | isTyVar v = delVarEnv    id_env v+  | otherwise = extendVarEnv id_env v ([v1], ASSERT(not (isCoVar v1)) Var v1)++{-+Note [Zapping the demand info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+VERY IMPORTANT: we must zap the demand info if the thing is going to+float out, because it may be less demanded than at its original+binding site.  Eg+   f :: Int -> Int+   f x = let v = 3*4 in v+x+Here v is strict; but if we float v to top level, it isn't any more.++Similarly, if we're floating a join point, it won't be one anymore, so we zap+join point information as well.+-}
+ compiler/simplCore/SimplCore.hs view
@@ -0,0 +1,1030 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[SimplCore]{Driver for simplifying @Core@ programs}+-}++{-# LANGUAGE CPP #-}++module SimplCore ( core2core, simplifyExpr ) where++#include "HsVersions.h"++import GhcPrelude++import DynFlags+import CoreSyn+import HscTypes+import CSE              ( cseProgram )+import Rules            ( mkRuleBase, unionRuleBase,+                          extendRuleBaseList, ruleCheckProgram, addRuleInfo,+                          getRules )+import PprCore          ( pprCoreBindings, pprCoreExpr )+import OccurAnal        ( occurAnalysePgm, occurAnalyseExpr )+import IdInfo+import CoreStats        ( coreBindsSize, coreBindsStats, exprSize )+import CoreUtils        ( mkTicks, stripTicksTop )+import CoreLint         ( endPass, lintPassResult, dumpPassResult,+                          lintAnnots )+import Simplify         ( simplTopBinds, simplExpr, simplRules )+import SimplUtils       ( simplEnvForGHCi, activeRule, activeUnfolding )+import SimplEnv+import SimplMonad+import CoreMonad+import qualified ErrUtils as Err+import FloatIn          ( floatInwards )+import FloatOut         ( floatOutwards )+import FamInstEnv+import Id+import ErrUtils         ( withTiming )+import BasicTypes       ( CompilerPhase(..), isDefaultInlinePragma, defaultInlinePragma )+import VarSet+import VarEnv+import LiberateCase     ( liberateCase )+import SAT              ( doStaticArgs )+import Specialise       ( specProgram)+import SpecConstr       ( specConstrProgram)+import DmdAnal          ( dmdAnalProgram )+import CallArity        ( callArityAnalProgram )+import Exitify          ( exitifyProgram )+import WorkWrap         ( wwTopBinds )+import SrcLoc+import Util+import Module+import Plugins          ( withPlugins, installCoreToDos )+import DynamicLoading  -- ( initializePlugins )++import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )+import UniqFM+import Outputable+import Control.Monad+import qualified GHC.LanguageExtensions as LangExt+{-+************************************************************************+*                                                                      *+\subsection{The driver for the simplifier}+*                                                                      *+************************************************************************+-}++core2core :: HscEnv -> ModGuts -> IO ModGuts+core2core hsc_env guts@(ModGuts { mg_module  = mod+                                , mg_loc     = loc+                                , mg_deps    = deps+                                , mg_rdr_env = rdr_env })+  = do { us <- mkSplitUniqSupply 's'+       -- make sure all plugins are loaded++       ; let builtin_passes = getCoreToDo dflags+             orph_mods = mkModuleSet (mod : dep_orphs deps)+       ;+       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod+                                    orph_mods print_unqual loc $+                           do { hsc_env' <- getHscEnv+                              ; dflags' <- liftIO $ initializePlugins hsc_env'+                                                      (hsc_dflags hsc_env')+                              ; all_passes <- withPlugins dflags'+                                                installCoreToDos+                                                builtin_passes+                              ; runCorePasses all_passes guts }++       ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats+             "Grand total simplifier statistics"+             (pprSimplCount stats)++       ; return guts2 }+  where+    dflags         = hsc_dflags hsc_env+    home_pkg_rules = hptRules hsc_env (dep_mods deps)+    hpt_rule_base  = mkRuleBase home_pkg_rules+    print_unqual   = mkPrintUnqualified dflags rdr_env+    -- mod: get the module out of the current HscEnv so we can retrieve it from the monad.+    -- This is very convienent for the users of the monad (e.g. plugins do not have to+    -- consume the ModGuts to find the module) but somewhat ugly because mg_module may+    -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which+    -- would mean our cached value would go out of date.++{-+************************************************************************+*                                                                      *+           Generating the main optimisation pipeline+*                                                                      *+************************************************************************+-}++getCoreToDo :: DynFlags -> [CoreToDo]+getCoreToDo dflags+  = flatten_todos core_todo+  where+    opt_level     = optLevel           dflags+    phases        = simplPhases        dflags+    max_iter      = maxSimplIterations dflags+    rule_check    = ruleCheck          dflags+    call_arity    = gopt Opt_CallArity                    dflags+    exitification = gopt Opt_Exitification                dflags+    strictness    = gopt Opt_Strictness                   dflags+    full_laziness = gopt Opt_FullLaziness                 dflags+    do_specialise = gopt Opt_Specialise                   dflags+    do_float_in   = gopt Opt_FloatIn                      dflags+    cse           = gopt Opt_CSE                          dflags+    spec_constr   = gopt Opt_SpecConstr                   dflags+    liberate_case = gopt Opt_LiberateCase                 dflags+    late_dmd_anal = gopt Opt_LateDmdAnal                  dflags+    late_specialise = gopt Opt_LateSpecialise             dflags+    static_args   = gopt Opt_StaticArgumentTransformation dflags+    rules_on      = gopt Opt_EnableRewriteRules           dflags+    eta_expand_on = gopt Opt_DoLambdaEtaExpansion         dflags+    ww_on         = gopt Opt_WorkerWrapper                dflags+    static_ptrs   = xopt LangExt.StaticPointers           dflags++    maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)++    maybe_strictness_before phase+      = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness++    base_mode = SimplMode { sm_phase      = panic "base_mode"+                          , sm_names      = []+                          , sm_dflags     = dflags+                          , sm_rules      = rules_on+                          , sm_eta_expand = eta_expand_on+                          , sm_inline     = True+                          , sm_case_case  = True }++    simpl_phase phase names iter+      = CoreDoPasses+      $   [ maybe_strictness_before phase+          , CoreDoSimplify iter+                (base_mode { sm_phase = Phase phase+                           , sm_names = names })++          , maybe_rule_check (Phase phase) ]++    simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter+                                | phase <- [phases, phases-1 .. 1] ]+++        -- initial simplify: mk specialiser happy: minimum effort please+    simpl_gently = CoreDoSimplify max_iter+                       (base_mode { sm_phase = InitialPhase+                                  , sm_names = ["Gentle"]+                                  , sm_rules = rules_on   -- Note [RULEs enabled in SimplGently]+                                  , sm_inline = True+                                              -- See Note [Inline in InitialPhase]+                                  , sm_case_case = False })+                          -- Don't do case-of-case transformations.+                          -- This makes full laziness work better++    strictness_pass = if ww_on+                       then [CoreDoStrictness,CoreDoWorkerWrapper]+                       else [CoreDoStrictness]+++    -- New demand analyser+    demand_analyser = (CoreDoPasses (+                           strictness_pass +++                           [simpl_phase 0 ["post-worker-wrapper"] max_iter]+                           ))++    -- Static forms are moved to the top level with the FloatOut pass.+    -- See Note [Grand plan for static forms] in StaticPtrTable.+    static_ptrs_float_outwards =+      runWhen static_ptrs $ CoreDoPasses+        [ simpl_gently -- Float Out can't handle type lets (sometimes created+                       -- by simpleOptPgm via mkParallelBindings)+        , CoreDoFloatOutwards FloatOutSwitches+          { floatOutLambdas   = Just 0+          , floatOutConstants = True+          , floatOutOverSatApps = False+          , floatToTopLevelOnly = True+          }+        ]++    core_todo =+     if opt_level == 0 then+       [ static_ptrs_float_outwards,+         CoreDoSimplify max_iter+             (base_mode { sm_phase = Phase 0+                        , sm_names = ["Non-opt simplification"] })+       ]++     else {- opt_level >= 1 -} [++    -- We want to do the static argument transform before full laziness as it+    -- may expose extra opportunities to float things outwards. However, to fix+    -- up the output of the transformation we need at do at least one simplify+    -- after this before anything else+        runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]),++        -- initial simplify: mk specialiser happy: minimum effort please+        simpl_gently,++        -- Specialisation is best done before full laziness+        -- so that overloaded functions have all their dictionary lambdas manifest+        runWhen do_specialise CoreDoSpecialising,++        if full_laziness then+           CoreDoFloatOutwards FloatOutSwitches {+                                 floatOutLambdas   = Just 0,+                                 floatOutConstants = True,+                                 floatOutOverSatApps = False,+                                 floatToTopLevelOnly = False }+                -- Was: gentleFloatOutSwitches+                --+                -- I have no idea why, but not floating constants to+                -- top level is very bad in some cases.+                --+                -- Notably: p_ident in spectral/rewrite+                --          Changing from "gentle" to "constantsOnly"+                --          improved rewrite's allocation by 19%, and+                --          made 0.0% difference to any other nofib+                --          benchmark+                --+                -- Not doing floatOutOverSatApps yet, we'll do+                -- that later on when we've had a chance to get more+                -- accurate arity information.  In fact it makes no+                -- difference at all to performance if we do it here,+                -- but maybe we save some unnecessary to-and-fro in+                -- the simplifier.+        else+           -- Even with full laziness turned off, we still need to float static+           -- forms to the top level. See Note [Grand plan for static forms] in+           -- StaticPtrTable.+           static_ptrs_float_outwards,++        simpl_phases,++                -- Phase 0: allow all Ids to be inlined now+                -- This gets foldr inlined before strictness analysis++                -- At least 3 iterations because otherwise we land up with+                -- huge dead expressions because of an infelicity in the+                -- simplifier.+                --      let k = BIG in foldr k z xs+                -- ==>  let k = BIG in letrec go = \xs -> ...(k x).... in go xs+                -- ==>  let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs+                -- Don't stop now!+        simpl_phase 0 ["main"] (max max_iter 3),++        runWhen do_float_in CoreDoFloatInwards,+            -- Run float-inwards immediately before the strictness analyser+            -- Doing so pushes bindings nearer their use site and hence makes+            -- them more likely to be strict. These bindings might only show+            -- up after the inlining from simplification.  Example in fulsom,+            -- Csg.calc, where an arg of timesDouble thereby becomes strict.++        runWhen call_arity $ CoreDoPasses+            [ CoreDoCallArity+            , simpl_phase 0 ["post-call-arity"] max_iter+            ],++        runWhen strictness demand_analyser,++        runWhen exitification CoreDoExitify,+            -- See note [Placement of the exitification pass]++        runWhen full_laziness $+           CoreDoFloatOutwards FloatOutSwitches {+                                 floatOutLambdas     = floatLamArgs dflags,+                                 floatOutConstants   = True,+                                 floatOutOverSatApps = True,+                                 floatToTopLevelOnly = False },+                -- nofib/spectral/hartel/wang doubles in speed if you+                -- do full laziness late in the day.  It only happens+                -- after fusion and other stuff, so the early pass doesn't+                -- catch it.  For the record, the redex is+                --        f_el22 (f_el21 r_midblock)+++        runWhen cse CoreCSE,+                -- We want CSE to follow the final full-laziness pass, because it may+                -- succeed in commoning up things floated out by full laziness.+                -- CSE used to rely on the no-shadowing invariant, but it doesn't any more++        runWhen do_float_in CoreDoFloatInwards,++        maybe_rule_check (Phase 0),++                -- Case-liberation for -O2.  This should be after+                -- strictness analysis and the simplification which follows it.+        runWhen liberate_case (CoreDoPasses [+            CoreLiberateCase,+            simpl_phase 0 ["post-liberate-case"] max_iter+            ]),         -- Run the simplifier after LiberateCase to vastly+                        -- reduce the possibility of shadowing+                        -- Reason: see Note [Shadowing] in SpecConstr.hs++        runWhen spec_constr CoreDoSpecConstr,++        maybe_rule_check (Phase 0),++        runWhen late_specialise+          (CoreDoPasses [ CoreDoSpecialising+                        , simpl_phase 0 ["post-late-spec"] max_iter]),++        -- LiberateCase can yield new CSE opportunities because it peels+        -- off one layer of a recursive function (concretely, I saw this+        -- in wheel-sieve1), and I'm guessing that SpecConstr can too+        -- And CSE is a very cheap pass. So it seems worth doing here.+        runWhen ((liberate_case || spec_constr) && cse) CoreCSE,++        -- Final clean-up simplification:+        simpl_phase 0 ["final"] max_iter,++        runWhen late_dmd_anal $ CoreDoPasses (+            strictness_pass +++            [simpl_phase 0 ["post-late-ww"] max_iter]+          ),++        -- Final run of the demand_analyser, ensures that one-shot thunks are+        -- really really one-shot thunks. Only needed if the demand analyser+        -- has run at all. See Note [Final Demand Analyser run] in DmdAnal+        -- It is EXTREMELY IMPORTANT to run this pass, otherwise execution+        -- can become /exponentially/ more expensive. See #11731, #12996.+        runWhen (strictness || late_dmd_anal) CoreDoStrictness,++        maybe_rule_check (Phase 0)+     ]++    -- Remove 'CoreDoNothing' and flatten 'CoreDoPasses' for clarity.+    flatten_todos [] = []+    flatten_todos (CoreDoNothing : rest) = flatten_todos rest+    flatten_todos (CoreDoPasses passes : rest) =+      flatten_todos passes ++ flatten_todos rest+    flatten_todos (todo : rest) = todo : flatten_todos rest++{- Note [Inline in InitialPhase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In GHC 8 and earlier we did not inline anything in the InitialPhase. But that is+confusing for users because when they say INLINE they expect the function to inline+right away.++So now we do inlining immediately, even in the InitialPhase, assuming that the+Id's Activation allows it.++This is a surprisingly big deal. Compiler performance improved a lot+when I made this change:++   perf/compiler/T5837.run            T5837 [stat too good] (normal)+   perf/compiler/parsing001.run       parsing001 [stat too good] (normal)+   perf/compiler/T12234.run           T12234 [stat too good] (optasm)+   perf/compiler/T9020.run            T9020 [stat too good] (optasm)+   perf/compiler/T3064.run            T3064 [stat too good] (normal)+   perf/compiler/T9961.run            T9961 [stat too good] (normal)+   perf/compiler/T13056.run           T13056 [stat too good] (optasm)+   perf/compiler/T9872d.run           T9872d [stat too good] (normal)+   perf/compiler/T783.run             T783 [stat too good] (normal)+   perf/compiler/T12227.run           T12227 [stat too good] (normal)+   perf/should_run/lazy-bs-alloc.run  lazy-bs-alloc [stat too good] (normal)+   perf/compiler/T1969.run            T1969 [stat too good] (normal)+   perf/compiler/T9872a.run           T9872a [stat too good] (normal)+   perf/compiler/T9872c.run           T9872c [stat too good] (normal)+   perf/compiler/T9872b.run           T9872b [stat too good] (normal)+   perf/compiler/T9872d.run           T9872d [stat too good] (normal)++Note [RULEs enabled in SimplGently]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+RULES are enabled when doing "gentle" simplification.  Two reasons:++  * We really want the class-op cancellation to happen:+        op (df d1 d2) --> $cop3 d1 d2+    because this breaks the mutual recursion between 'op' and 'df'++  * I wanted the RULE+        lift String ===> ...+    to work in Template Haskell when simplifying+    splices, so we get simpler code for literal strings++But watch out: list fusion can prevent floating.  So use phase control+to switch off those rules until after floating.++************************************************************************+*                                                                      *+                  The CoreToDo interpreter+*                                                                      *+************************************************************************+-}++runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts+runCorePasses passes guts+  = foldM do_pass guts passes+  where+    do_pass guts CoreDoNothing = return guts+    do_pass guts (CoreDoPasses ps) = runCorePasses ps guts+    do_pass guts pass+       = withTiming getDynFlags+                    (ppr pass <+> brackets (ppr mod))+                    (const ()) $ do+            { guts' <- lintAnnots (ppr pass) (doCorePass pass) guts+            ; endPass pass (mg_binds guts') (mg_rules guts')+            ; return guts' }++    mod = mg_module guts++doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts+doCorePass pass@(CoreDoSimplify {})  = {-# SCC "Simplify" #-}+                                       simplifyPgm pass++doCorePass CoreCSE                   = {-# SCC "CommonSubExpr" #-}+                                       doPass cseProgram++doCorePass CoreLiberateCase          = {-# SCC "LiberateCase" #-}+                                       doPassD liberateCase++doCorePass CoreDoFloatInwards        = {-# SCC "FloatInwards" #-}+                                       floatInwards++doCorePass (CoreDoFloatOutwards f)   = {-# SCC "FloatOutwards" #-}+                                       doPassDUM (floatOutwards f)++doCorePass CoreDoStaticArgs          = {-# SCC "StaticArgs" #-}+                                       doPassU doStaticArgs++doCorePass CoreDoCallArity           = {-# SCC "CallArity" #-}+                                       doPassD callArityAnalProgram++doCorePass CoreDoExitify             = {-# SCC "Exitify" #-}+                                       doPass exitifyProgram++doCorePass CoreDoStrictness          = {-# SCC "NewStranal" #-}+                                       doPassDFM dmdAnalProgram++doCorePass CoreDoWorkerWrapper       = {-# SCC "WorkWrap" #-}+                                       doPassDFU wwTopBinds++doCorePass CoreDoSpecialising        = {-# SCC "Specialise" #-}+                                       specProgram++doCorePass CoreDoSpecConstr          = {-# SCC "SpecConstr" #-}+                                       specConstrProgram++doCorePass CoreDoPrintCore              = observe   printCore+doCorePass (CoreDoRuleCheck phase pat)  = ruleCheckPass phase pat+doCorePass CoreDoNothing                = return+doCorePass (CoreDoPasses passes)        = runCorePasses passes++#if defined(GHCI)+doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass+#else+doCorePass pass@CoreDoPluginPass {}  = pprPanic "doCorePass" (ppr pass)+#endif++doCorePass pass@CoreDesugar          = pprPanic "doCorePass" (ppr pass)+doCorePass pass@CoreDesugarOpt       = pprPanic "doCorePass" (ppr pass)+doCorePass pass@CoreTidy             = pprPanic "doCorePass" (ppr pass)+doCorePass pass@CorePrep             = pprPanic "doCorePass" (ppr pass)+doCorePass pass@CoreOccurAnal        = pprPanic "doCorePass" (ppr pass)++{-+************************************************************************+*                                                                      *+\subsection{Core pass combinators}+*                                                                      *+************************************************************************+-}++printCore :: DynFlags -> CoreProgram -> IO ()+printCore dflags binds+    = Err.dumpIfSet dflags True "Print Core" (pprCoreBindings binds)++ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts+ruleCheckPass current_phase pat guts =+    withTiming getDynFlags+               (text "RuleCheck"<+>brackets (ppr $ mg_module guts))+               (const ()) $ do+    { rb <- getRuleBase+    ; dflags <- getDynFlags+    ; vis_orphs <- getVisibleOrphanMods+    ; let rule_fn fn = getRules (RuleEnv rb vis_orphs) fn+                        ++ (mg_rules guts)+    ; liftIO $ putLogMsg dflags NoReason Err.SevDump noSrcSpan+                   (defaultDumpStyle dflags)+                   (ruleCheckProgram current_phase pat+                      rule_fn (mg_binds guts))+    ; return guts }++doPassDUM :: (DynFlags -> UniqSupply -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDUM do_pass = doPassM $ \binds -> do+    dflags <- getDynFlags+    us     <- getUniqueSupplyM+    liftIO $ do_pass dflags us binds++doPassDM :: (DynFlags -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDM do_pass = doPassDUM (\dflags -> const (do_pass dflags))++doPassD :: (DynFlags -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPassD do_pass = doPassDM (\dflags -> return . do_pass dflags)++doPassDU :: (DynFlags -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDU do_pass = doPassDUM (\dflags us -> return . do_pass dflags us)++doPassU :: (UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPassU do_pass = doPassDU (const do_pass)++doPassDFM :: (DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDFM do_pass guts = do+    dflags <- getDynFlags+    p_fam_env <- getPackageFamInstEnv+    let fam_envs = (p_fam_env, mg_fam_inst_env guts)+    doPassM (liftIO . do_pass dflags fam_envs) guts++doPassDFU :: (DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPassDFU do_pass guts = do+    dflags <- getDynFlags+    us     <- getUniqueSupplyM+    p_fam_env <- getPackageFamInstEnv+    let fam_envs = (p_fam_env, mg_fam_inst_env guts)+    doPass (do_pass dflags fam_envs us) guts++-- Most passes return no stats and don't change rules: these combinators+-- let us lift them to the full blown ModGuts+CoreM world+doPassM :: Monad m => (CoreProgram -> m CoreProgram) -> ModGuts -> m ModGuts+doPassM bind_f guts = do+    binds' <- bind_f (mg_binds guts)+    return (guts { mg_binds = binds' })++doPass :: (CoreProgram -> CoreProgram) -> ModGuts -> CoreM ModGuts+doPass bind_f guts = return $ guts { mg_binds = bind_f (mg_binds guts) }++-- Observer passes just peek; don't modify the bindings at all+observe :: (DynFlags -> CoreProgram -> IO a) -> ModGuts -> CoreM ModGuts+observe do_pass = doPassM $ \binds -> do+    dflags <- getDynFlags+    _ <- liftIO $ do_pass dflags binds+    return binds++{-+************************************************************************+*                                                                      *+        Gentle simplification+*                                                                      *+************************************************************************+-}++simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do+             -> CoreExpr+             -> IO CoreExpr+-- simplifyExpr is called by the driver to simplify an+-- expression typed in at the interactive prompt+--+-- Also used by Template Haskell+simplifyExpr dflags expr+  = withTiming (pure dflags) (text "Simplify [expr]") (const ()) $+    do  {+        ; us <-  mkSplitUniqSupply 's'++        ; let sz = exprSize expr++        ; (expr', counts) <- initSmpl dflags emptyRuleEnv+                               emptyFamInstEnvs us sz+                               (simplExprGently (simplEnvForGHCi dflags) expr)++        ; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)+                  "Simplifier statistics" (pprSimplCount counts)++        ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression"+                        (pprCoreExpr expr')++        ; return expr'+        }++simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr+-- Simplifies an expression+--      does occurrence analysis, then simplification+--      and repeats (twice currently) because one pass+--      alone leaves tons of crud.+-- Used (a) for user expressions typed in at the interactive prompt+--      (b) the LHS and RHS of a RULE+--      (c) Template Haskell splices+--+-- The name 'Gently' suggests that the SimplMode is SimplGently,+-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't+-- enforce that; it just simplifies the expression twice++-- It's important that simplExprGently does eta reduction; see+-- Note [Simplifying the left-hand side of a RULE] above.  The+-- simplifier does indeed do eta reduction (it's in Simplify.completeLam)+-- but only if -O is on.++simplExprGently env expr = do+    expr1 <- simplExpr env (occurAnalyseExpr expr)+    simplExpr env (occurAnalyseExpr expr1)++{-+************************************************************************+*                                                                      *+\subsection{The driver for the simplifier}+*                                                                      *+************************************************************************+-}++simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts+simplifyPgm pass guts+  = do { hsc_env <- getHscEnv+       ; us <- getUniqueSupplyM+       ; rb <- getRuleBase+       ; liftIOWithCount $+         simplifyPgmIO pass hsc_env us rb guts }++simplifyPgmIO :: CoreToDo+              -> HscEnv+              -> UniqSupply+              -> RuleBase+              -> ModGuts+              -> IO (SimplCount, ModGuts)  -- New bindings++simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)+              hsc_env us hpt_rule_base+              guts@(ModGuts { mg_module = this_mod+                            , mg_rdr_env = rdr_env+                            , mg_deps = deps+                            , mg_binds = binds, mg_rules = rules+                            , mg_fam_inst_env = fam_inst_env })+  = do { (termination_msg, it_count, counts_out, guts')+           <- do_iteration us 1 [] binds rules++        ; Err.dumpIfSet dflags (dopt Opt_D_verbose_core2core dflags &&+                                dopt Opt_D_dump_simpl_stats  dflags)+                  "Simplifier statistics for following pass"+                  (vcat [text termination_msg <+> text "after" <+> ppr it_count+                                              <+> text "iterations",+                         blankLine,+                         pprSimplCount counts_out])++        ; return (counts_out, guts')+    }+  where+    dflags       = hsc_dflags hsc_env+    print_unqual = mkPrintUnqualified dflags rdr_env+    simpl_env    = mkSimplEnv mode+    active_rule  = activeRule mode+    active_unf   = activeUnfolding mode++    do_iteration :: UniqSupply+                 -> Int          -- Counts iterations+                 -> [SimplCount] -- Counts from earlier iterations, reversed+                 -> CoreProgram  -- Bindings in+                 -> [CoreRule]   -- and orphan rules+                 -> IO (String, Int, SimplCount, ModGuts)++    do_iteration us iteration_no counts_so_far binds rules+        -- iteration_no is the number of the iteration we are+        -- about to begin, with '1' for the first+      | iteration_no > max_iterations   -- Stop if we've run out of iterations+      = WARN( debugIsOn && (max_iterations > 2)+            , hang (text "Simplifier bailing out after" <+> int max_iterations+                    <+> text "iterations"+                    <+> (brackets $ hsep $ punctuate comma $+                         map (int . simplCountN) (reverse counts_so_far)))+                 2 (text "Size =" <+> ppr (coreBindsStats binds)))++                -- Subtract 1 from iteration_no to get the+                -- number of iterations we actually completed+        return ( "Simplifier baled out", iteration_no - 1+               , totalise counts_so_far+               , guts { mg_binds = binds, mg_rules = rules } )++      -- Try and force thunks off the binds; significantly reduces+      -- space usage, especially with -O.  JRS, 000620.+      | let sz = coreBindsSize binds+      , () <- sz `seq` ()     -- Force it+      = do {+                -- Occurrence analysis+           let { tagged_binds = {-# SCC "OccAnal" #-}+                     occurAnalysePgm this_mod active_unf active_rule rules+                                     binds+               } ;+           Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis"+                     (pprCoreBindings tagged_binds);++                -- Get any new rules, and extend the rule base+                -- See Note [Overall plumbing for rules] in Rules.hs+                -- We need to do this regularly, because simplification can+                -- poke on IdInfo thunks, which in turn brings in new rules+                -- behind the scenes.  Otherwise there's a danger we'll simply+                -- miss the rules for Ids hidden inside imported inlinings+           eps <- hscEPS hsc_env ;+           let  { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)+                ; rule_base2 = extendRuleBaseList rule_base1 rules+                ; fam_envs = (eps_fam_inst_env eps, fam_inst_env)+                ; vis_orphs = this_mod : dep_orphs deps } ;++                -- Simplify the program+           ((binds1, rules1), counts1) <-+             initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $+               do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}+                                      simplTopBinds simpl_env tagged_binds++                      -- Apply the substitution to rules defined in this module+                      -- for imported Ids.  Eg  RULE map my_f = blah+                      -- If we have a substitution my_f :-> other_f, we'd better+                      -- apply it to the rule to, or it'll never match+                  ; rules1 <- simplRules env1 Nothing rules Nothing++                  ; return (getTopFloatBinds floats, rules1) } ;++                -- Stop if nothing happened; don't dump output+                -- See Note [Which transformations are innocuous] in CoreMonad+           if isZeroSimplCount counts1 then+                return ( "Simplifier reached fixed point", iteration_no+                       , totalise (counts1 : counts_so_far)  -- Include "free" ticks+                       , guts { mg_binds = binds1, mg_rules = rules1 } )+           else do {+                -- Short out indirections+                -- We do this *after* at least one run of the simplifier+                -- because indirection-shorting uses the export flag on *occurrences*+                -- and that isn't guaranteed to be ok until after the first run propagates+                -- stuff from the binding site to its occurrences+                --+                -- ToDo: alas, this means that indirection-shorting does not happen at all+                --       if the simplifier does nothing (not common, I know, but unsavoury)+           let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;++                -- Dump the result of this iteration+           dump_end_iteration dflags print_unqual iteration_no counts1 binds2 rules1 ;+           lintPassResult hsc_env pass binds2 ;++                -- Loop+           do_iteration us2 (iteration_no + 1) (counts1:counts_so_far) binds2 rules1+           } }+      | otherwise = panic "do_iteration"+      where+        (us1, us2) = splitUniqSupply us++        -- Remember the counts_so_far are reversed+        totalise :: [SimplCount] -> SimplCount+        totalise = foldr (\c acc -> acc `plusSimplCount` c)+                         (zeroSimplCount dflags)++simplifyPgmIO _ _ _ _ _ = panic "simplifyPgmIO"++-------------------+dump_end_iteration :: DynFlags -> PrintUnqualified -> Int+                   -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()+dump_end_iteration dflags print_unqual iteration_no counts binds rules+  = dumpPassResult dflags print_unqual mb_flag hdr pp_counts binds rules+  where+    mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_iterations+            | otherwise                               = Nothing+            -- Show details if Opt_D_dump_simpl_iterations is on++    hdr = text "Simplifier iteration=" <> int iteration_no+    pp_counts = vcat [ text "---- Simplifier counts for" <+> hdr+                     , pprSimplCount counts+                     , text "---- End of simplifier counts for" <+> hdr ]++{-+************************************************************************+*                                                                      *+                Shorting out indirections+*                                                                      *+************************************************************************++If we have this:++        x_local = <expression>+        ...bindings...+        x_exported = x_local++where x_exported is exported, and x_local is not, then we replace it with this:++        x_exported = <expression>+        x_local = x_exported+        ...bindings...++Without this we never get rid of the x_exported = x_local thing.  This+save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and+makes strictness information propagate better.  This used to happen in+the final phase, but it's tidier to do it here.++Note [Messing up the exported Id's RULES]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must be careful about discarding (obviously) or even merging the+RULES on the exported Id. The example that went bad on me at one stage+was this one:++    iterate :: (a -> a) -> a -> [a]+        [Exported]+    iterate = iterateList++    iterateFB c f x = x `c` iterateFB c f (f x)+    iterateList f x =  x : iterateList f (f x)+        [Not exported]++    {-# RULES+    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)+    "iterateFB"                 iterateFB (:) = iterateList+     #-}++This got shorted out to:++    iterateList :: (a -> a) -> a -> [a]+    iterateList = iterate++    iterateFB c f x = x `c` iterateFB c f (f x)+    iterate f x =  x : iterate f (f x)++    {-# RULES+    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)+    "iterateFB"                 iterateFB (:) = iterate+     #-}++And now we get an infinite loop in the rule system+        iterate f x -> build (\cn -> iterateFB c f x)+                    -> iterateFB (:) f x+                    -> iterate f x++Old "solution":+        use rule switching-off pragmas to get rid+        of iterateList in the first place++But in principle the user *might* want rules that only apply to the Id+he says.  And inline pragmas are similar+   {-# NOINLINE f #-}+   f = local+   local = <stuff>+Then we do not want to get rid of the NOINLINE.++Hence hasShortableIdinfo.+++Note [Rules and indirection-zapping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Problem: what if x_exported has a RULE that mentions something in ...bindings...?+Then the things mentioned can be out of scope!  Solution+ a) Make sure that in this pass the usage-info from x_exported is+        available for ...bindings...+ b) If there are any such RULES, rec-ify the entire top-level.+    It'll get sorted out next time round++Other remarks+~~~~~~~~~~~~~+If more than one exported thing is equal to a local thing (i.e., the+local thing really is shared), then we do one only:+\begin{verbatim}+        x_local = ....+        x_exported1 = x_local+        x_exported2 = x_local+==>+        x_exported1 = ....++        x_exported2 = x_exported1+\end{verbatim}++We rely on prior eta reduction to simplify things like+\begin{verbatim}+        x_exported = /\ tyvars -> x_local tyvars+==>+        x_exported = x_local+\end{verbatim}+Hence,there's a possibility of leaving unchanged something like this:+\begin{verbatim}+        x_local = ....+        x_exported1 = x_local Int+\end{verbatim}+By the time we've thrown away the types in STG land this+could be eliminated.  But I don't think it's very common+and it's dangerous to do this fiddling in STG land+because we might elminate a binding that's mentioned in the+unfolding for something.++Note [Indirection zapping and ticks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unfortunately this is another place where we need a special case for+ticks. The following happens quite regularly:++        x_local = <expression>+        x_exported = tick<x> x_local++Which we want to become:++        x_exported =  tick<x> <expression>++As it makes no sense to keep the tick and the expression on separate+bindings. Note however that that this might increase the ticks scoping+over the execution of x_local, so we can only do this for floatable+ticks. More often than not, other references will be unfoldings of+x_exported, and therefore carry the tick anyway.+-}++type IndEnv = IdEnv (Id, [Tickish Var]) -- Maps local_id -> exported_id, ticks++shortOutIndirections :: CoreProgram -> CoreProgram+shortOutIndirections binds+  | isEmptyVarEnv ind_env = binds+  | no_need_to_flatten    = binds'                      -- See Note [Rules and indirect-zapping]+  | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff+  where+    ind_env            = makeIndEnv binds+    -- These exported Ids are the subjects  of the indirection-elimination+    exp_ids            = map fst $ nonDetEltsUFM ind_env+      -- It's OK to use nonDetEltsUFM here because we forget the ordering+      -- by immediately converting to a set or check if all the elements+      -- satisfy a predicate.+    exp_id_set         = mkVarSet exp_ids+    no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids+    binds'             = concatMap zap binds++    zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]+    zap (Rec pairs)       = [Rec (concatMap zapPair pairs)]++    zapPair (bndr, rhs)+        | bndr `elemVarSet` exp_id_set+        = []   -- Kill the exported-id binding++        | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr+        , (exp_id', lcl_id') <- transferIdInfo exp_id bndr+        =      -- Turn a local-id binding into two bindings+               --    exp_id = rhs; lcl_id = exp_id+          [ (exp_id', mkTicks ticks rhs),+            (lcl_id', Var exp_id') ]++        | otherwise+        = [(bndr,rhs)]++makeIndEnv :: [CoreBind] -> IndEnv+makeIndEnv binds+  = foldl' add_bind emptyVarEnv binds+  where+    add_bind :: IndEnv -> CoreBind -> IndEnv+    add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs)+    add_bind env (Rec pairs)              = foldl' add_pair env pairs++    add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv+    add_pair env (exported_id, exported)+        | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported+        , shortMeOut env exported_id local_id+        = extendVarEnv env local_id (exported_id, ticks)+    add_pair env _ = env++-----------------+shortMeOut :: IndEnv -> Id -> Id -> Bool+shortMeOut ind_env exported_id local_id+-- The if-then-else stuff is just so I can get a pprTrace to see+-- how often I don't get shorting out because of IdInfo stuff+  = if isExportedId exported_id &&              -- Only if this is exported++       isLocalId local_id &&                    -- Only if this one is defined in this+                                                --      module, so that we *can* change its+                                                --      binding to be the exported thing!++       not (isExportedId local_id) &&           -- Only if this one is not itself exported,+                                                --      since the transformation will nuke it++       not (local_id `elemVarEnv` ind_env)      -- Only if not already substituted for+    then+        if hasShortableIdInfo exported_id+        then True       -- See Note [Messing up the exported Id's IdInfo]+        else WARN( True, text "Not shorting out:" <+> ppr exported_id )+             False+    else+        False++-----------------+hasShortableIdInfo :: Id -> Bool+-- True if there is no user-attached IdInfo on exported_id,+-- so we can safely discard it+-- See Note [Messing up the exported Id's IdInfo]+hasShortableIdInfo id+  =  isEmptyRuleInfo (ruleInfo info)+  && isDefaultInlinePragma (inlinePragInfo info)+  && not (isStableUnfolding (unfoldingInfo info))+  where+     info = idInfo id++-----------------+{- Note [Transferring IdInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+     lcl_id = e; exp_id = lcl_id++and lcl_id has useful IdInfo, we don't want to discard it by going+     gbl_id = e; lcl_id = gbl_id++Instead, transfer IdInfo from lcl_id to exp_id, specifically+* (Stable) unfolding+* Strictness+* Rules+* Inline pragma++Overwriting, rather than merging, seems to work ok.++We also zap the InlinePragma on the lcl_id. It might originally+have had a NOINLINE, which we have now transferred; and we really+want the lcl_id to inline now that its RHS is trivial!+-}++transferIdInfo :: Id -> Id -> (Id, Id)+-- See Note [Transferring IdInfo]+transferIdInfo exported_id local_id+  = ( modifyIdInfo transfer exported_id+    , local_id `setInlinePragma` defaultInlinePragma )+  where+    local_info = idInfo local_id+    transfer exp_info = exp_info `setStrictnessInfo`    strictnessInfo local_info+                                 `setUnfoldingInfo`     unfoldingInfo local_info+                                 `setInlinePragInfo`    inlinePragInfo local_info+                                 `setRuleInfo`          addRuleInfo (ruleInfo exp_info) new_info+    new_info = setRuleInfoHead (idName exported_id)+                               (ruleInfo local_info)+        -- Remember to set the function-name field of the+        -- rules as we transfer them from one function to another
+ compiler/simplCore/SimplEnv.hs view
@@ -0,0 +1,936 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section[SimplMonad]{The simplifier Monad}+-}++{-# LANGUAGE CPP #-}++module SimplEnv (+        -- * The simplifier mode+        setMode, getMode, updMode, seDynFlags,++        -- * Environments+        SimplEnv(..), pprSimplEnv,   -- Temp not abstract+        mkSimplEnv, extendIdSubst,+        SimplEnv.extendTvSubst, SimplEnv.extendCvSubst,+        zapSubstEnv, setSubstEnv,+        getInScope, setInScopeFromE, setInScopeFromF,+        setInScopeSet, modifyInScope, addNewInScopeIds,+        getSimplRules,++        -- * Substitution results+        SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,++        -- * Simplifying 'Id' binders+        simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,+        simplBinder, simplBinders,+        substTy, substTyVar, getTCvSubst,+        substCo, substCoVar,++        -- * Floats+        SimplFloats(..), emptyFloats, mkRecFloats,+        mkFloatBind, addLetFloats, addJoinFloats, addFloats,+        extendFloats, wrapFloats,+        doFloatFromRhs, getTopFloatBinds,++        -- * LetFloats+        LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat,+        addLetFlts,  mapLetFloats,++        -- * JoinFloats+        JoinFloat, JoinFloats, emptyJoinFloats,+        wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts+    ) where++#include "HsVersions.h"++import GhcPrelude++import SimplMonad+import CoreMonad                ( SimplMode(..) )+import CoreSyn+import CoreUtils+import Var+import VarEnv+import VarSet+import OrdList+import Id+import MkCore                   ( mkWildValBinder )+import DynFlags                 ( DynFlags )+import TysWiredIn+import qualified Type+import Type hiding              ( substTy, substTyVar, substTyVarBndr )+import qualified Coercion+import Coercion hiding          ( substCo, substCoVar, substCoVarBndr )+import BasicTypes+import MonadUtils+import Outputable+import Util+import UniqFM                   ( pprUniqFM )++import Data.List++{-+************************************************************************+*                                                                      *+\subsubsection{The @SimplEnv@ type}+*                                                                      *+************************************************************************+-}++data SimplEnv+  = SimplEnv {+     ----------- Static part of the environment -----------+     -- Static in the sense of lexically scoped,+     -- wrt the original expression++        seMode      :: SimplMode++        -- The current substitution+      , seTvSubst   :: TvSubstEnv      -- InTyVar |--> OutType+      , seCvSubst   :: CvSubstEnv      -- InCoVar |--> OutCoercion+      , seIdSubst   :: SimplIdSubst    -- InId    |--> OutExpr++     ----------- Dynamic part of the environment -----------+     -- Dynamic in the sense of describing the setup where+     -- the expression finally ends up++        -- The current set of in-scope variables+        -- They are all OutVars, and all bound in this module+      , seInScope   :: InScopeSet       -- OutVars only+    }++data SimplFloats+  = SimplFloats+      { -- Ordinary let bindings+        sfLetFloats  :: LetFloats+                -- See Note [LetFloats]++        -- Join points+      , sfJoinFloats :: JoinFloats+                -- Handled separately; they don't go very far+                -- We consider these to be /inside/ sfLetFloats+                -- because join points can refer to ordinary bindings,+                -- but not vice versa++        -- Includes all variables bound by sfLetFloats and+        -- sfJoinFloats, plus at least whatever is in scope where+        -- these bindings land up.+      , sfInScope :: InScopeSet  -- All OutVars+      }++instance Outputable SimplFloats where+  ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is })+    = text "SimplFloats"+      <+> braces (vcat [ text "lets: " <+> ppr lf+                       , text "joins:" <+> ppr jf+                       , text "in_scope:" <+> ppr is ])++emptyFloats :: SimplEnv -> SimplFloats+emptyFloats env+  = SimplFloats { sfLetFloats  = emptyLetFloats+                , sfJoinFloats = emptyJoinFloats+                , sfInScope    = seInScope env }++pprSimplEnv :: SimplEnv -> SDoc+-- Used for debugging; selective+pprSimplEnv env+  = vcat [text "TvSubst:" <+> ppr (seTvSubst env),+          text "CvSubst:" <+> ppr (seCvSubst env),+          text "IdSubst:" <+> id_subst_doc,+          text "InScope:" <+> in_scope_vars_doc+    ]+  where+   id_subst_doc = pprUniqFM ppr (seIdSubst env)+   in_scope_vars_doc = pprVarSet (getInScopeVars (seInScope env))+                                 (vcat . map ppr_one)+   ppr_one v | isId v = ppr v <+> ppr (idUnfolding v)+             | otherwise = ppr v++type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr+        -- See Note [Extending the Subst] in CoreSubst++-- | A substitution result.+data SimplSR+  = DoneEx OutExpr (Maybe JoinArity)+       -- If  x :-> DoneEx e ja   is in the SimplIdSubst+       -- then replace occurrences of x by e+       -- and  ja = Just a <=> x is a join-point of arity a+       -- See Note [Join arity in SimplIdSubst]+++  | DoneId OutId+       -- If  x :-> DoneId v   is in the SimplIdSubst+       -- then replace occurrences of x by v+       -- and  v is a join-point of arity a+       --      <=> x is a join-point of arity a++  | ContEx TvSubstEnv                 -- A suspended substitution+           CvSubstEnv+           SimplIdSubst+           InExpr+      -- If   x :-> ContEx tv cv id e   is in the SimplISubst+      -- then replace occurrences of x by (subst (tv,cv,id) e)++instance Outputable SimplSR where+  ppr (DoneId v)    = text "DoneId" <+> ppr v+  ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e+    where+      pp_mj = case mj of+                Nothing -> empty+                Just n  -> parens (int n)++  ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-,+                                ppr (filter_env tv), ppr (filter_env id) -}]+        -- where+        -- fvs = exprFreeVars e+        -- filter_env env = filterVarEnv_Directly keep env+        -- keep uniq _ = uniq `elemUFM_Directly` fvs++{-+Note [SimplEnv invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~+seInScope:+        The in-scope part of Subst includes *all* in-scope TyVars and Ids+        The elements of the set may have better IdInfo than the+        occurrences of in-scope Ids, and (more important) they will+        have a correctly-substituted type.  So we use a lookup in this+        set to replace occurrences++        The Ids in the InScopeSet are replete with their Rules,+        and as we gather info about the unfolding of an Id, we replace+        it in the in-scope set.++        The in-scope set is actually a mapping OutVar -> OutVar, and+        in case expressions we sometimes bind++seIdSubst:+        The substitution is *apply-once* only, because InIds and OutIds+        can overlap.+        For example, we generally omit mappings+                a77 -> a77+        from the substitution, when we decide not to clone a77, but it's quite+        legitimate to put the mapping in the substitution anyway.++        Furthermore, consider+                let x = case k of I# x77 -> ... in+                let y = case k of I# x77 -> ... in ...+        and suppose the body is strict in both x and y.  Then the simplifier+        will pull the first (case k) to the top; so the second (case k) will+        cancel out, mapping x77 to, well, x77!  But one is an in-Id and the+        other is an out-Id.++        Of course, the substitution *must* applied! Things in its domain+        simply aren't necessarily bound in the result.++* substId adds a binding (DoneId new_id) to the substitution if+        the Id's unique has changed++  Note, though that the substitution isn't necessarily extended+  if the type of the Id changes.  Why not?  Because of the next point:++* We *always, always* finish by looking up in the in-scope set+  any variable that doesn't get a DoneEx or DoneVar hit in the substitution.+  Reason: so that we never finish up with a "old" Id in the result.+  An old Id might point to an old unfolding and so on... which gives a space+  leak.++  [The DoneEx and DoneVar hits map to "new" stuff.]++* It follows that substExpr must not do a no-op if the substitution is empty.+  substType is free to do so, however.++* When we come to a let-binding (say) we generate new IdInfo, including an+  unfolding, attach it to the binder, and add this newly adorned binder to+  the in-scope set.  So all subsequent occurrences of the binder will get+  mapped to the full-adorned binder, which is also the one put in the+  binding site.++* The in-scope "set" usually maps x->x; we use it simply for its domain.+  But sometimes we have two in-scope Ids that are synomyms, and should+  map to the same target:  x->x, y->x.  Notably:+        case y of x { ... }+  That's why the "set" is actually a VarEnv Var++Note [Join arity in SimplIdSubst]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have to remember which incoming variables are join points: the occurrences+may not be marked correctly yet, and we're in change of propagating the change if+OccurAnal makes something a join point).++Normally the in-scope set is where we keep the latest information, but+the in-scope set tracks only OutVars; if a binding is unconditionally+inlined (via DoneEx), it never makes it into the in-scope set, and we+need to know at the occurrence site that the variable is a join point+so that we know to drop the context. Thus we remember which join+points we're substituting. -}++mkSimplEnv :: SimplMode -> SimplEnv+mkSimplEnv mode+  = SimplEnv { seMode = mode+             , seInScope = init_in_scope+             , seTvSubst = emptyVarEnv+             , seCvSubst = emptyVarEnv+             , seIdSubst = emptyVarEnv }+        -- The top level "enclosing CC" is "SUBSUMED".++init_in_scope :: InScopeSet+init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy))+              -- See Note [WildCard binders]++{-+Note [WildCard binders]+~~~~~~~~~~~~~~~~~~~~~~~+The program to be simplified may have wild binders+    case e of wild { p -> ... }+We want to *rename* them away, so that there are no+occurrences of 'wild-id' (with wildCardKey).  The easy+way to do that is to start of with a representative+Id in the in-scope set++There can be *occurrences* of wild-id.  For example,+MkCore.mkCoreApp transforms+   e (a /# b)   -->   case (a /# b) of wild { DEFAULT -> e wild }+This is ok provided 'wild' isn't free in 'e', and that's the delicate+thing. Generally, you want to run the simplifier to get rid of the+wild-ids before doing much else.++It's a very dark corner of GHC.  Maybe it should be cleaned up.+-}++getMode :: SimplEnv -> SimplMode+getMode env = seMode env++seDynFlags :: SimplEnv -> DynFlags+seDynFlags env = sm_dflags (seMode env)++setMode :: SimplMode -> SimplEnv -> SimplEnv+setMode mode env = env { seMode = mode }++updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv+updMode upd env = env { seMode = upd (seMode env) }++---------------------+extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv+extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res+  = ASSERT2( isId var && not (isCoVar var), ppr var )+    env { seIdSubst = extendVarEnv subst var res }++extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv+extendTvSubst env@(SimplEnv {seTvSubst = tsubst}) var res+  = ASSERT2( isTyVar var, ppr var $$ ppr res )+    env {seTvSubst = extendVarEnv tsubst var res}++extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv+extendCvSubst env@(SimplEnv {seCvSubst = csubst}) var co+  = ASSERT( isCoVar var )+    env {seCvSubst = extendVarEnv csubst var co}++---------------------+getInScope :: SimplEnv -> InScopeSet+getInScope env = seInScope env++setInScopeSet :: SimplEnv -> InScopeSet -> SimplEnv+setInScopeSet env in_scope = env {seInScope = in_scope}++setInScopeFromE :: SimplEnv -> SimplEnv -> SimplEnv+-- See Note [Setting the right in-scope set]+setInScopeFromE rhs_env here_env = rhs_env { seInScope = seInScope here_env }++setInScopeFromF :: SimplEnv -> SimplFloats -> SimplEnv+setInScopeFromF env floats = env { seInScope = sfInScope floats }++addNewInScopeIds :: SimplEnv -> [CoreBndr] -> SimplEnv+        -- The new Ids are guaranteed to be freshly allocated+addNewInScopeIds env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) vs+  = env { seInScope = in_scope `extendInScopeSetList` vs,+          seIdSubst = id_subst `delVarEnvList` vs }+        -- Why delete?  Consider+        --      let x = a*b in (x, \x -> x+3)+        -- We add [x |-> a*b] to the substitution, but we must+        -- _delete_ it from the substitution when going inside+        -- the (\x -> ...)!++modifyInScope :: SimplEnv -> CoreBndr -> SimplEnv+-- The variable should already be in scope, but+-- replace the existing version with this new one+-- which has more information+modifyInScope env@(SimplEnv {seInScope = in_scope}) v+  = env {seInScope = extendInScopeSet in_scope v}++{- Note [Setting the right in-scope set]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  \x. (let x = e in b) arg[x]+where the let shadows the lambda.  Really this means something like+  \x1. (let x2 = e in b) arg[x1]++- When we capture the 'arg' in an ApplyToVal continuation, we capture+  the environment, which says what 'x' is bound to, namely x1++- Then that continuation gets pushed under the let++- Finally we simplify 'arg'.  We want+     - the static, lexical environment bindig x :-> x1+     - the in-scopeset from "here", under the 'let' which includes+       both x1 and x2++It's important to have the right in-scope set, else we may rename a+variable to one that is already in scope.  So we must pick up the+in-scope set from "here", but otherwise use the environment we+captured along with 'arg'.  This transfer of in-scope set is done by+setInScopeFromE.+-}++---------------------+zapSubstEnv :: SimplEnv -> SimplEnv+zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}++setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv+setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }++mkContEx :: SimplEnv -> InExpr -> SimplSR+mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e++{-+************************************************************************+*                                                                      *+\subsection{LetFloats}+*                                                                      *+************************************************************************++Note [LetFloats]+~~~~~~~~~~~~~~~~+The LetFloats is a bunch of bindings, classified by a FloatFlag.++* All of them satisfy the let/app invariant++Examples++  NonRec x (y:ys)       FltLifted+  Rec [(x,rhs)]         FltLifted++  NonRec x* (p:q)       FltOKSpec   -- RHS is WHNF.  Question: why not FltLifted?+  NonRec x# (y +# 3)    FltOkSpec   -- Unboxed, but ok-for-spec'n++  NonRec x* (f y)       FltCareful  -- Strict binding; might fail or diverge++Can't happen:+  NonRec x# (a /# b)    -- Might fail; does not satisfy let/app+  NonRec x# (f y)       -- Might diverge; does not satisfy let/app+-}++data LetFloats = LetFloats (OrdList OutBind) FloatFlag+                 -- See Note [LetFloats]++type JoinFloat  = OutBind+type JoinFloats = OrdList JoinFloat++data FloatFlag+  = FltLifted   -- All bindings are lifted and lazy *or*+                --     consist of a single primitive string literal+                --  Hence ok to float to top level, or recursive++  | FltOkSpec   -- All bindings are FltLifted *or*+                --      strict (perhaps because unlifted,+                --      perhaps because of a strict binder),+                --        *and* ok-for-speculation+                --  Hence ok to float out of the RHS+                --  of a lazy non-recursive let binding+                --  (but not to top level, or into a rec group)++  | FltCareful  -- At least one binding is strict (or unlifted)+                --      and not guaranteed cheap+                --      Do not float these bindings out of a lazy let++instance Outputable LetFloats where+  ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds)++instance Outputable FloatFlag where+  ppr FltLifted  = text "FltLifted"+  ppr FltOkSpec  = text "FltOkSpec"+  ppr FltCareful = text "FltCareful"++andFF :: FloatFlag -> FloatFlag -> FloatFlag+andFF FltCareful _          = FltCareful+andFF FltOkSpec  FltCareful = FltCareful+andFF FltOkSpec  _          = FltOkSpec+andFF FltLifted  flt        = flt++doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool+-- If you change this function look also at FloatIn.noFloatFromRhs+doFloatFromRhs lvl rec str (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs+  =  not (isNilOL fs) && want_to_float && can_float+  where+     want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs+                     -- See Note [Float when cheap or expandable]+     can_float = case ff of+                   FltLifted  -> True+                   FltOkSpec  -> isNotTopLevel lvl && isNonRec rec+                   FltCareful -> isNotTopLevel lvl && isNonRec rec && str++{-+Note [Float when cheap or expandable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to float a let from a let if the residual RHS is+   a) cheap, such as (\x. blah)+   b) expandable, such as (f b) if f is CONLIKE+But there are+  - cheap things that are not expandable (eg \x. expensive)+  - expandable things that are not cheap (eg (f b) where b is CONLIKE)+so we must take the 'or' of the two.+-}++emptyLetFloats :: LetFloats+emptyLetFloats = LetFloats nilOL FltLifted++emptyJoinFloats :: JoinFloats+emptyJoinFloats = nilOL++unitLetFloat :: OutBind -> LetFloats+-- This key function constructs a singleton float with the right form+unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))+                    LetFloats (unitOL bind) (flag bind)+  where+    flag (Rec {})                = FltLifted+    flag (NonRec bndr rhs)+      | not (isStrictId bndr)    = FltLifted+      | exprIsTickedString rhs   = FltLifted+          -- String literals can be floated freely.+          -- See Note [CoreSyn top-level string literals] in CoreSyn.+      | exprOkForSpeculation rhs = FltOkSpec  -- Unlifted, and lifted but ok-for-spec (eg HNF)+      | otherwise                = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr )+                                   FltCareful+      -- Unlifted binders can only be let-bound if exprOkForSpeculation holds++unitJoinFloat :: OutBind -> JoinFloats+unitJoinFloat bind = ASSERT(all isJoinId (bindersOf bind))+                     unitOL bind++mkFloatBind :: SimplEnv -> OutBind -> (SimplFloats, SimplEnv)+-- Make a singleton SimplFloats, and+-- extend the incoming SimplEnv's in-scope set with its binders+-- These binders may already be in the in-scope set,+-- but may have by now been augmented with more IdInfo+mkFloatBind env bind+  = (floats, env { seInScope = in_scope' })+  where+    floats+      | isJoinBind bind+      = SimplFloats { sfLetFloats  = emptyLetFloats+                    , sfJoinFloats = unitJoinFloat bind+                    , sfInScope    = in_scope' }+      | otherwise+      = SimplFloats { sfLetFloats  = unitLetFloat bind+                    , sfJoinFloats = emptyJoinFloats+                    , sfInScope    = in_scope' }++    in_scope' = seInScope env `extendInScopeSetBind` bind++extendFloats :: SimplFloats -> OutBind -> SimplFloats+-- Add this binding to the floats, and extend the in-scope env too+extendFloats (SimplFloats { sfLetFloats  = floats+                          , sfJoinFloats = jfloats+                          , sfInScope    = in_scope })+             bind+  | isJoinBind bind+  = SimplFloats { sfInScope    = in_scope'+                , sfLetFloats  = floats+                , sfJoinFloats = jfloats' }+  | otherwise+  = SimplFloats { sfInScope    = in_scope'+                , sfLetFloats  = floats'+                , sfJoinFloats = jfloats }+  where+    in_scope' = in_scope `extendInScopeSetBind` bind+    floats'   = floats  `addLetFlts`  unitLetFloat bind+    jfloats'  = jfloats `addJoinFlts` unitJoinFloat bind++addLetFloats :: SimplFloats -> LetFloats -> SimplFloats+-- Add the let-floats for env2 to env1;+-- *plus* the in-scope set for env2, which is bigger+-- than that for env1+addLetFloats floats let_floats@(LetFloats binds _)+  = floats { sfLetFloats = sfLetFloats floats `addLetFlts` let_floats+           , sfInScope   = foldlOL extendInScopeSetBind+                                   (sfInScope floats) binds }++addJoinFloats :: SimplFloats -> JoinFloats -> SimplFloats+addJoinFloats floats join_floats+  = floats { sfJoinFloats = sfJoinFloats floats `addJoinFlts` join_floats+           , sfInScope    = foldlOL extendInScopeSetBind+                                    (sfInScope floats) join_floats }++extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet+extendInScopeSetBind in_scope bind+  = extendInScopeSetList in_scope (bindersOf bind)++addFloats :: SimplFloats -> SimplFloats -> SimplFloats+-- Add both let-floats and join-floats for env2 to env1;+-- *plus* the in-scope set for env2, which is bigger+-- than that for env1+addFloats (SimplFloats { sfLetFloats = lf1, sfJoinFloats = jf1 })+          (SimplFloats { sfLetFloats = lf2, sfJoinFloats = jf2, sfInScope = in_scope })+  = SimplFloats { sfLetFloats  = lf1 `addLetFlts` lf2+                , sfJoinFloats = jf1 `addJoinFlts` jf2+                , sfInScope    = in_scope }++addLetFlts :: LetFloats -> LetFloats -> LetFloats+addLetFlts (LetFloats bs1 l1) (LetFloats bs2 l2)+  = LetFloats (bs1 `appOL` bs2) (l1 `andFF` l2)++letFloatBinds :: LetFloats -> [CoreBind]+letFloatBinds (LetFloats bs _) = fromOL bs++addJoinFlts :: JoinFloats -> JoinFloats -> JoinFloats+addJoinFlts = appOL++mkRecFloats :: SimplFloats -> SimplFloats+-- Flattens the floats from env2 into a single Rec group,+-- They must either all be lifted LetFloats or all JoinFloats+mkRecFloats floats@(SimplFloats { sfLetFloats  = LetFloats bs ff+                                , sfJoinFloats = jbs+                                , sfInScope    = in_scope })+  = ASSERT2( case ff of { FltLifted -> True; _ -> False }, ppr (fromOL bs) )+    ASSERT2( isNilOL bs || isNilOL jbs, ppr floats )+    SimplFloats { sfLetFloats  = floats'+                , sfJoinFloats = jfloats'+                , sfInScope    = in_scope }+  where+    floats'  | isNilOL bs  = emptyLetFloats+             | otherwise   = unitLetFloat (Rec (flattenBinds (fromOL bs)))+    jfloats' | isNilOL jbs = emptyJoinFloats+             | otherwise   = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))++wrapFloats :: SimplFloats -> OutExpr -> OutExpr+-- Wrap the floats around the expression; they should all+-- satisfy the let/app invariant, so mkLets should do the job just fine+wrapFloats (SimplFloats { sfLetFloats  = LetFloats bs _+                        , sfJoinFloats = jbs }) body+  = foldrOL Let (wrapJoinFloats jbs body) bs+     -- Note: Always safe to put the joins on the inside+     -- since the values can't refer to them++wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr)+-- Wrap the sfJoinFloats of the env around the expression,+-- and take them out of the SimplEnv+wrapJoinFloatsX floats body+  = ( floats { sfJoinFloats = emptyJoinFloats }+    , wrapJoinFloats (sfJoinFloats floats) body )++wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr+-- Wrap the sfJoinFloats of the env around the expression,+-- and take them out of the SimplEnv+wrapJoinFloats join_floats body+  = foldrOL Let body join_floats++getTopFloatBinds :: SimplFloats -> [CoreBind]+getTopFloatBinds (SimplFloats { sfLetFloats  = lbs+                              , sfJoinFloats = jbs})+  = ASSERT( isNilOL jbs )  -- Can't be any top-level join bindings+    letFloatBinds lbs++mapLetFloats :: LetFloats -> ((Id,CoreExpr) -> (Id,CoreExpr)) -> LetFloats+mapLetFloats (LetFloats fs ff) fun+   = LetFloats (mapOL app fs) ff+   where+    app (NonRec b e) = case fun (b,e) of (b',e') -> NonRec b' e'+    app (Rec bs)     = Rec (map fun bs)++{-+************************************************************************+*                                                                      *+                Substitution of Vars+*                                                                      *+************************************************************************++Note [Global Ids in the substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We look up even a global (eg imported) Id in the substitution. Consider+   case X.g_34 of b { (a,b) ->  ... case X.g_34 of { (p,q) -> ...} ... }+The binder-swap in the occurrence analyser will add a binding+for a LocalId version of g (with the same unique though):+   case X.g_34 of b { (a,b) ->  let g_34 = b in+                                ... case X.g_34 of { (p,q) -> ...} ... }+So we want to look up the inner X.g_34 in the substitution, where we'll+find that it has been substituted by b.  (Or conceivably cloned.)+-}++substId :: SimplEnv -> InId -> SimplSR+-- Returns DoneEx only on a non-Var expression+substId (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v+  = case lookupVarEnv ids v of  -- Note [Global Ids in the substitution]+        Nothing               -> DoneId (refineFromInScope in_scope v)+        Just (DoneId v)       -> DoneId (refineFromInScope in_scope v)+        Just res              -> res    -- DoneEx non-var, or ContEx++        -- Get the most up-to-date thing from the in-scope set+        -- Even though it isn't in the substitution, it may be in+        -- the in-scope set with better IdInfo++refineFromInScope :: InScopeSet -> Var -> Var+refineFromInScope in_scope v+  | isLocalId v = case lookupInScope in_scope v of+                  Just v' -> v'+                  Nothing -> WARN( True, ppr v ) v  -- This is an error!+  | otherwise = v++lookupRecBndr :: SimplEnv -> InId -> OutId+-- Look up an Id which has been put into the envt by simplRecBndrs,+-- but where we have not yet done its RHS+lookupRecBndr (SimplEnv { seInScope = in_scope, seIdSubst = ids }) v+  = case lookupVarEnv ids v of+        Just (DoneId v) -> v+        Just _ -> pprPanic "lookupRecBndr" (ppr v)+        Nothing -> refineFromInScope in_scope v++{-+************************************************************************+*                                                                      *+\section{Substituting an Id binder}+*                                                                      *+************************************************************************+++These functions are in the monad only so that they can be made strict via seq.++Note [Return type for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++   (join j :: Char -> Int -> Int) 77+   (     j x = \y. y + ord x    )+   (in case v of                )+   (     A -> j 'x'             )+   (     B -> j 'y'             )+   (     C -> <blah>            )++The simplifier pushes the "apply to 77" continuation inwards to give++   join j :: Char -> Int+        j x = (\y. y + ord x) 77+   in case v of+        A -> j 'x'+        B -> j 'y'+        C -> <blah> 77++Notice that the "apply to 77" continuation went into the RHS of the+join point.  And that meant that the return type of the join point+changed!!++That's why we pass res_ty into simplNonRecJoinBndr, and substIdBndr+takes a (Just res_ty) argument so that it knows to do the type-changing+thing.+-}++simplBinders :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])+simplBinders  env bndrs = mapAccumLM simplBinder  env bndrs++-------------+simplBinder :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)+-- Used for lambda and case-bound variables+-- Clone Id if necessary, substitute type+-- Return with IdInfo already substituted, but (fragile) occurrence info zapped+-- The substitution is extended only if the variable is cloned, because+-- we *don't* need to use it to track occurrence info.+simplBinder env bndr+  | isTyVar bndr  = do  { let (env', tv) = substTyVarBndr env bndr+                        ; seqTyVar tv `seq` return (env', tv) }+  | otherwise     = do  { let (env', id) = substIdBndr Nothing env bndr+                        ; seqId id `seq` return (env', id) }++---------------+simplNonRecBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)+-- A non-recursive let binder+simplNonRecBndr env id+  = do  { let (env1, id1) = substIdBndr Nothing env id+        ; seqId id1 `seq` return (env1, id1) }++---------------+simplNonRecJoinBndr :: SimplEnv -> OutType -> InBndr+                    -> SimplM (SimplEnv, OutBndr)+-- A non-recursive let binder for a join point;+-- context being pushed inward may change the type+-- See Note [Return type for join points]+simplNonRecJoinBndr env res_ty id+  = do  { let (env1, id1) = substIdBndr (Just res_ty) env id+        ; seqId id1 `seq` return (env1, id1) }++---------------+simplRecBndrs :: SimplEnv -> [InBndr] -> SimplM SimplEnv+-- Recursive let binders+simplRecBndrs env@(SimplEnv {}) ids+  = ASSERT(all (not . isJoinId) ids)+    do  { let (env1, ids1) = mapAccumL (substIdBndr Nothing) env ids+        ; seqIds ids1 `seq` return env1 }++---------------+simplRecJoinBndrs :: SimplEnv -> OutType -> [InBndr] -> SimplM SimplEnv+-- Recursive let binders for join points;+-- context being pushed inward may change types+-- See Note [Return type for join points]+simplRecJoinBndrs env@(SimplEnv {}) res_ty ids+  = ASSERT(all isJoinId ids)+    do  { let (env1, ids1) = mapAccumL (substIdBndr (Just res_ty)) env ids+        ; seqIds ids1 `seq` return env1 }++---------------+substIdBndr :: Maybe OutType -> SimplEnv -> InBndr -> (SimplEnv, OutBndr)+-- Might be a coercion variable+substIdBndr new_res_ty env bndr+  | isCoVar bndr  = substCoVarBndr env bndr+  | otherwise     = substNonCoVarIdBndr new_res_ty env bndr++---------------+substNonCoVarIdBndr+   :: Maybe OutType -- New result type, if a join binder+                    -- See Note [Return type for join points]+   -> SimplEnv+   -> InBndr    -- Env and binder to transform+   -> (SimplEnv, OutBndr)+-- Clone Id if necessary, substitute its type+-- Return an Id with its+--      * Type substituted+--      * UnfoldingInfo, Rules, WorkerInfo zapped+--      * Fragile OccInfo (only) zapped: Note [Robust OccInfo]+--      * Robust info, retained especially arity and demand info,+--         so that they are available to occurrences that occur in an+--         earlier binding of a letrec+--+-- For the robust info, see Note [Arity robustness]+--+-- Augment the substitution  if the unique changed+-- Extend the in-scope set with the new Id+--+-- Similar to CoreSubst.substIdBndr, except that+--      the type of id_subst differs+--      all fragile info is zapped+substNonCoVarIdBndr new_res_ty+                    env@(SimplEnv { seInScope = in_scope+                                  , seIdSubst = id_subst })+                    old_id+  = ASSERT2( not (isCoVar old_id), ppr old_id )+    (env { seInScope = in_scope `extendInScopeSet` new_id,+           seIdSubst = new_subst }, new_id)+  where+    id1    = uniqAway in_scope old_id+    id2    = substIdType env id1++    id3    | Just res_ty <- new_res_ty+           = id2 `setIdType` setJoinResTy (idJoinArity id2) res_ty (idType id2)+                             -- See Note [Return type for join points]+           | otherwise+           = id2++    new_id = zapFragileIdInfo id3       -- Zaps rules, worker-info, unfolding+                                        -- and fragile OccInfo++        -- Extend the substitution if the unique has changed,+        -- or there's some useful occurrence information+        -- See the notes with substTyVarBndr for the delSubstEnv+    new_subst | new_id /= old_id+              = extendVarEnv id_subst old_id (DoneId new_id)+              | otherwise+              = delVarEnv id_subst old_id++------------------------------------+seqTyVar :: TyVar -> ()+seqTyVar b = b `seq` ()++seqId :: Id -> ()+seqId id = seqType (idType id)  `seq`+           idInfo id            `seq`+           ()++seqIds :: [Id] -> ()+seqIds []       = ()+seqIds (id:ids) = seqId id `seq` seqIds ids++{-+Note [Arity robustness]+~~~~~~~~~~~~~~~~~~~~~~~+We *do* transfer the arity from from the in_id of a let binding to the+out_id.  This is important, so that the arity of an Id is visible in+its own RHS.  For example:+        f = \x. ....g (\y. f y)....+We can eta-reduce the arg to g, because f is a value.  But that+needs to be visible.++This interacts with the 'state hack' too:+        f :: Bool -> IO Int+        f = \x. case x of+                  True  -> f y+                  False -> \s -> ...+Can we eta-expand f?  Only if we see that f has arity 1, and then we+take advantage of the 'state hack' on the result of+(f y) :: State# -> (State#, Int) to expand the arity one more.++There is a disadvantage though.  Making the arity visible in the RHS+allows us to eta-reduce+        f = \x -> f x+to+        f = f+which technically is not sound.   This is very much a corner case, so+I'm not worried about it.  Another idea is to ensure that f's arity+never decreases; its arity started as 1, and we should never eta-reduce+below that.+++Note [Robust OccInfo]+~~~~~~~~~~~~~~~~~~~~~+It's important that we *do* retain the loop-breaker OccInfo, because+that's what stops the Id getting inlined infinitely, in the body of+the letrec.+-}+++{-+************************************************************************+*                                                                      *+                Impedance matching to type substitution+*                                                                      *+************************************************************************+-}++getTCvSubst :: SimplEnv -> TCvSubst+getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env+                      , seCvSubst = cv_env })+  = mkTCvSubst in_scope (tv_env, cv_env)++substTy :: SimplEnv -> Type -> Type+substTy env ty = Type.substTy (getTCvSubst env) ty++substTyVar :: SimplEnv -> TyVar -> Type+substTyVar env tv = Type.substTyVar (getTCvSubst env) tv++substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar)+substTyVarBndr env tv+  = case Type.substTyVarBndr (getTCvSubst env) tv of+        (TCvSubst in_scope' tv_env' cv_env', tv')+           -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv')++substCoVar :: SimplEnv -> CoVar -> Coercion+substCoVar env tv = Coercion.substCoVar (getTCvSubst env) tv++substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar)+substCoVarBndr env cv+  = case Coercion.substCoVarBndr (getTCvSubst env) cv of+        (TCvSubst in_scope' tv_env' cv_env', cv')+           -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')++substCo :: SimplEnv -> Coercion -> Coercion+substCo env co = Coercion.substCo (getTCvSubst env) co++------------------+substIdType :: SimplEnv -> Id -> Id+substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) id+  |  (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env)+  || noFreeVarsOfType old_ty+  = id+  | otherwise = Id.setIdType id (Type.substTy (TCvSubst in_scope tv_env cv_env) old_ty)+                -- The tyCoVarsOfType is cheaper than it looks+                -- because we cache the free tyvars of the type+                -- in a Note in the id's type itself+  where+    old_ty = idType id
+ compiler/simplCore/SimplMonad.hs view
@@ -0,0 +1,251 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section[SimplMonad]{The simplifier Monad}+-}++module SimplMonad (+        -- The monad+        SimplM,+        initSmpl, traceSmpl,+        getSimplRules, getFamEnvs,++        -- Unique supply+        MonadUnique(..), newId, newJoinId,++        -- Counting+        SimplCount, tick, freeTick, checkedTick,+        getSimplCount, zeroSimplCount, pprSimplCount,+        plusSimplCount, isZeroSimplCount+    ) where++import GhcPrelude++import Var              ( Var, isId, mkLocalVar )+import Name             ( mkSystemVarName )+import Id               ( Id, mkSysLocalOrCoVar )+import IdInfo           ( IdDetails(..), vanillaIdInfo, setArityInfo )+import Type             ( Type, mkLamTypes )+import FamInstEnv       ( FamInstEnv )+import CoreSyn          ( RuleEnv(..) )+import UniqSupply+import DynFlags+import CoreMonad+import Outputable+import FastString+import MonadUtils+import ErrUtils as Err+import Panic (throwGhcExceptionIO, GhcException (..))+import BasicTypes          ( IntWithInf, treatZeroAsInf, mkIntWithInf )+import Control.Monad       ( liftM, ap )++{-+************************************************************************+*                                                                      *+\subsection{Monad plumbing}+*                                                                      *+************************************************************************++For the simplifier monad, we want to {\em thread} a unique supply and a counter.+(Command-line switches move around through the explicitly-passed SimplEnv.)+-}++newtype SimplM result+  =  SM  { unSM :: SimplTopEnv  -- Envt that does not change much+                -> UniqSupply   -- We thread the unique supply because+                                -- constantly splitting it is rather expensive+                -> SimplCount+                -> IO (result, UniqSupply, SimplCount)}+  -- we only need IO here for dump output++data SimplTopEnv+  = STE { st_flags     :: DynFlags+        , st_max_ticks :: IntWithInf  -- Max #ticks in this simplifier run+        , st_rules     :: RuleEnv+        , st_fams      :: (FamInstEnv, FamInstEnv) }++initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)+         -> UniqSupply          -- No init count; set to 0+         -> Int                 -- Size of the bindings, used to limit+                                -- the number of ticks we allow+         -> SimplM a+         -> IO (a, SimplCount)++initSmpl dflags rules fam_envs us size m+  = do (result, _, count) <- unSM m env us (zeroSimplCount dflags)+       return (result, count)+  where+    env = STE { st_flags = dflags, st_rules = rules+              , st_max_ticks = computeMaxTicks dflags size+              , st_fams = fam_envs }++computeMaxTicks :: DynFlags -> Int -> IntWithInf+-- Compute the max simplifier ticks as+--     (base-size + pgm-size) * magic-multiplier * tick-factor/100+-- where+--    magic-multiplier is a constant that gives reasonable results+--    base-size is a constant to deal with size-zero programs+computeMaxTicks dflags size+  = treatZeroAsInf $+    fromInteger ((toInteger (size + base_size)+                  * toInteger (tick_factor * magic_multiplier))+          `div` 100)+  where+    tick_factor      = simplTickFactor dflags+    base_size        = 100+    magic_multiplier = 40+        -- MAGIC NUMBER, multiplies the simplTickFactor+        -- We can afford to be generous; this is really+        -- just checking for loops, and shouldn't usually fire+        -- A figure of 20 was too small: see #5539.++{-# INLINE thenSmpl #-}+{-# INLINE thenSmpl_ #-}+{-# INLINE returnSmpl #-}+++instance Functor SimplM where+    fmap = liftM++instance Applicative SimplM where+    pure  = returnSmpl+    (<*>) = ap+    (*>)  = thenSmpl_++instance Monad SimplM where+   (>>)   = (*>)+   (>>=)  = thenSmpl++returnSmpl :: a -> SimplM a+returnSmpl e = SM (\_st_env us sc -> return (e, us, sc))++thenSmpl  :: SimplM a -> (a -> SimplM b) -> SimplM b+thenSmpl_ :: SimplM a -> SimplM b -> SimplM b++thenSmpl m k+  = SM $ \st_env us0 sc0 -> do+      (m_result, us1, sc1) <- unSM m st_env us0 sc0+      unSM (k m_result) st_env us1 sc1++thenSmpl_ m k+  = SM $ \st_env us0 sc0 -> do+      (_, us1, sc1) <- unSM m st_env us0 sc0+      unSM k st_env us1 sc1++-- TODO: this specializing is not allowed+-- {-# SPECIALIZE mapM         :: (a -> SimplM b) -> [a] -> SimplM [b] #-}+-- {-# SPECIALIZE mapAndUnzipM :: (a -> SimplM (b, c)) -> [a] -> SimplM ([b],[c]) #-}+-- {-# SPECIALIZE mapAccumLM   :: (acc -> b -> SimplM (acc,c)) -> acc -> [b] -> SimplM (acc, [c]) #-}++traceSmpl :: String -> SDoc -> SimplM ()+traceSmpl herald doc+  = do { dflags <- getDynFlags+       ; liftIO $ Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_trace "Simpl Trace"+           (hang (text herald) 2 doc) }++{-+************************************************************************+*                                                                      *+\subsection{The unique supply}+*                                                                      *+************************************************************************+-}++instance MonadUnique SimplM where+    getUniqueSupplyM+       = SM (\_st_env us sc -> case splitUniqSupply us of+                                (us1, us2) -> return (us1, us2, sc))++    getUniqueM+       = SM (\_st_env us sc -> case takeUniqFromSupply us of+                                (u, us') -> return (u, us', sc))++    getUniquesM+        = SM (\_st_env us sc -> case splitUniqSupply us of+                                (us1, us2) -> return (uniqsFromSupply us1, us2, sc))++instance HasDynFlags SimplM where+    getDynFlags = SM (\st_env us sc -> return (st_flags st_env, us, sc))++instance MonadIO SimplM where+    liftIO m = SM $ \_ us sc -> do+      x <- m+      return (x, us, sc)++getSimplRules :: SimplM RuleEnv+getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc))++getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)+getFamEnvs = SM (\st_env us sc -> return (st_fams st_env, us, sc))++newId :: FastString -> Type -> SimplM Id+newId fs ty = do uniq <- getUniqueM+                 return (mkSysLocalOrCoVar fs uniq ty)++newJoinId :: [Var] -> Type -> SimplM Id+newJoinId bndrs body_ty+  = do { uniq <- getUniqueM+       ; let name       = mkSystemVarName uniq (fsLit "$j")+             join_id_ty = mkLamTypes bndrs body_ty  -- Note [Funky mkLamTypes]+             -- Note [idArity for join points] in SimplUtils+             arity      = length (filter isId bndrs)+             join_arity = length bndrs+             details    = JoinId join_arity+             id_info    = vanillaIdInfo `setArityInfo` arity+--                                        `setOccInfo` strongLoopBreaker++       ; return (mkLocalVar details name join_id_ty id_info) }++{-+************************************************************************+*                                                                      *+\subsection{Counting up what we've done}+*                                                                      *+************************************************************************+-}++getSimplCount :: SimplM SimplCount+getSimplCount = SM (\_st_env us sc -> return (sc, us, sc))++tick :: Tick -> SimplM ()+tick t = SM (\st_env us sc -> let sc' = doSimplTick (st_flags st_env) t sc+                              in sc' `seq` return ((), us, sc'))++checkedTick :: Tick -> SimplM ()+-- Try to take a tick, but fail if too many+checkedTick t+  = SM (\st_env us sc ->+           if st_max_ticks st_env <= mkIntWithInf (simplCountN sc)+           then throwGhcExceptionIO $+                  PprProgramError "Simplifier ticks exhausted" (msg sc)+           else let sc' = doSimplTick (st_flags st_env) t sc+                in sc' `seq` return ((), us, sc'))+  where+    msg sc = vcat+      [ text "When trying" <+> ppr t+      , text "To increase the limit, use -fsimpl-tick-factor=N (default 100)."+      , space+      , text "If you need to increase the limit substantially, please file a"+      , text "bug report and indicate the factor you needed."+      , space+      , text "If GHC was unable to complete compilation even"+               <+> text "with a very large factor"+      , text "(a thousand or more), please consult the"+                <+> doubleQuotes (text "Known bugs or infelicities")+      , text "section in the Users Guide before filing a report. There are a"+      , text "few situations unlikely to occur in practical programs for which"+      , text "simplifier non-termination has been judged acceptable."+      , space+      , pp_details sc+      , pprSimplCount sc ]+    pp_details sc+      | hasDetailedCounts sc = empty+      | otherwise = text "To see detailed counts use -ddump-simpl-stats"+++freeTick :: Tick -> SimplM ()+-- Record a tick, but don't add to the total tick count, which is+-- used to decide when nothing further has happened+freeTick t+   = SM (\_st_env us sc -> let sc' = doFreeSimplTick t sc+                           in sc' `seq` return ((), us, sc'))
+ compiler/simplCore/SimplUtils.hs view
@@ -0,0 +1,2326 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section[SimplUtils]{The simplifier utilities}+-}++{-# LANGUAGE CPP #-}++module SimplUtils (+        -- Rebuilding+        mkLam, mkCase, prepareAlts, tryEtaExpandRhs,++        -- Inlining,+        preInlineUnconditionally, postInlineUnconditionally,+        activeUnfolding, activeRule,+        getUnfoldingInRuleMatch,+        simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules,++        -- The continuation type+        SimplCont(..), DupFlag(..), StaticEnv,+        isSimplified, contIsStop,+        contIsDupable, contResultType, contHoleType,+        contIsTrivial, contArgs,+        countArgs,+        mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,+        interestingCallContext,++        -- ArgInfo+        ArgInfo(..), ArgSpec(..), mkArgInfo,+        addValArgTo, addCastTo, addTyArgTo,+        argInfoExpr, argInfoAppArgs, pushSimplifiedArgs,++        abstractFloats,++        -- Utilities+        isExitJoinId+    ) where++#include "HsVersions.h"++import GhcPrelude++import SimplEnv+import CoreMonad        ( SimplMode(..), Tick(..) )+import DynFlags+import CoreSyn+import qualified CoreSubst+import PprCore+import CoreFVs+import CoreUtils+import CoreArity+import CoreUnfold+import Name+import Id+import IdInfo+import Var+import Demand+import SimplMonad+import Type     hiding( substTy )+import Coercion hiding( substCo )+import DataCon          ( dataConWorkId, isNullaryRepDataCon )+import VarSet+import BasicTypes+import Util+import OrdList          ( isNilOL )+import MonadUtils+import Outputable+import Pair+import PrelRules+import FastString       ( fsLit )++import Control.Monad    ( when )+import Data.List        ( sortBy )++{-+************************************************************************+*                                                                      *+                The SimplCont and DupFlag types+*                                                                      *+************************************************************************++A SimplCont allows the simplifier to traverse the expression in a+zipper-like fashion.  The SimplCont represents the rest of the expression,+"above" the point of interest.++You can also think of a SimplCont as an "evaluation context", using+that term in the way it is used for operational semantics. This is the+way I usually think of it, For example you'll often see a syntax for+evaluation context looking like+        C ::= []  |  C e   |  case C of alts  |  C `cast` co+That's the kind of thing we are doing here, and I use that syntax in+the comments.+++Key points:+  * A SimplCont describes a *strict* context (just like+    evaluation contexts do).  E.g. Just [] is not a SimplCont++  * A SimplCont describes a context that *does not* bind+    any variables.  E.g. \x. [] is not a SimplCont+-}++data SimplCont+  = Stop                -- Stop[e] = e+        OutType         -- Type of the <hole>+        CallCtxt        -- Tells if there is something interesting about+                        --          the context, and hence the inliner+                        --          should be a bit keener (see interestingCallContext)+                        -- Specifically:+                        --     This is an argument of a function that has RULES+                        --     Inlining the call might allow the rule to fire+                        -- Never ValAppCxt (use ApplyToVal instead)+                        -- or CaseCtxt (use Select instead)++  | CastIt              -- (CastIt co K)[e] = K[ e `cast` co ]+        OutCoercion             -- The coercion simplified+                                -- Invariant: never an identity coercion+        SimplCont++  | ApplyToVal         -- (ApplyToVal arg K)[e] = K[ e arg ]+      { sc_dup  :: DupFlag      -- See Note [DupFlag invariants]+      , sc_arg  :: InExpr       -- The argument,+      , sc_env  :: StaticEnv    -- see Note [StaticEnv invariant]+      , sc_cont :: SimplCont }++  | ApplyToTy          -- (ApplyToTy ty K)[e] = K[ e ty ]+      { sc_arg_ty  :: OutType     -- Argument type+      , sc_hole_ty :: OutType     -- Type of the function, presumably (forall a. blah)+                                  -- See Note [The hole type in ApplyToTy]+      , sc_cont    :: SimplCont }++  | Select             -- (Select alts K)[e] = K[ case e of alts ]+      { sc_dup  :: DupFlag        -- See Note [DupFlag invariants]+      , sc_bndr :: InId           -- case binder+      , sc_alts :: [InAlt]        -- Alternatives+      , sc_env  :: StaticEnv      -- See Note [StaticEnv invariant]+      , sc_cont :: SimplCont }++  -- The two strict forms have no DupFlag, because we never duplicate them+  | StrictBind          -- (StrictBind x xs b K)[e] = let x = e in K[\xs.b]+                        --       or, equivalently,  = K[ (\x xs.b) e ]+      { sc_dup   :: DupFlag        -- See Note [DupFlag invariants]+      , sc_bndr  :: InId+      , sc_bndrs :: [InBndr]+      , sc_body  :: InExpr+      , sc_env   :: StaticEnv      -- See Note [StaticEnv invariant]+      , sc_cont  :: SimplCont }++  | StrictArg           -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ]+      { sc_dup  :: DupFlag     -- Always Simplified or OkToDup+      , sc_fun  :: ArgInfo     -- Specifies f, e1..en, Whether f has rules, etc+                               --     plus strictness flags for *further* args+      , sc_cci  :: CallCtxt    -- Whether *this* argument position is interesting+      , sc_cont :: SimplCont }++  | TickIt              -- (TickIt t K)[e] = K[ tick t e ]+        (Tickish Id)    -- Tick tickish <hole>+        SimplCont++type StaticEnv = SimplEnv       -- Just the static part is relevant++data DupFlag = NoDup       -- Unsimplified, might be big+             | Simplified  -- Simplified+             | OkToDup     -- Simplified and small++isSimplified :: DupFlag -> Bool+isSimplified NoDup = False+isSimplified _     = True       -- Invariant: the subst-env is empty++perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type+perhapsSubstTy dup env ty+  | isSimplified dup = ty+  | otherwise        = substTy env ty++{- Note [StaticEnv invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We pair up an InExpr or InAlts with a StaticEnv, which establishes the+lexical scope for that InExpr.  When we simplify that InExpr/InAlts, we+use+  - Its captured StaticEnv+  - Overriding its InScopeSet with the larger one at the+    simplification point.++Why override the InScopeSet?  Example:+      (let y = ey in f) ex+By the time we simplify ex, 'y' will be in scope.++However the InScopeSet in the StaticEnv is not irrelevant: it should+include all the free vars of applying the substitution to the InExpr.+Reason: contHoleType uses perhapsSubstTy to apply the substitution to+the expression, and that (rightly) gives ASSERT failures if the InScopeSet+isn't big enough.++Note [DupFlag invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~+In both (ApplyToVal dup _ env k)+   and  (Select dup _ _ env k)+the following invariants hold++  (a) if dup = OkToDup, then continuation k is also ok-to-dup+  (b) if dup = OkToDup or Simplified, the subst-env is empty+      (and and hence no need to re-simplify)+-}++instance Outputable DupFlag where+  ppr OkToDup    = text "ok"+  ppr NoDup      = text "nodup"+  ppr Simplified = text "simpl"++instance Outputable SimplCont where+  ppr (Stop ty interesting) = text "Stop" <> brackets (ppr interesting) <+> ppr ty+  ppr (CastIt co cont  )    = (text "CastIt" <+> pprOptCo co) $$ ppr cont+  ppr (TickIt t cont)       = (text "TickIt" <+> ppr t) $$ ppr cont+  ppr (ApplyToTy  { sc_arg_ty = ty, sc_cont = cont })+    = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont+  ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont })+    = (text "ApplyToVal" <+> ppr dup <+> pprParendExpr arg)+                                        $$ ppr cont+  ppr (StrictBind { sc_bndr = b, sc_cont = cont })+    = (text "StrictBind" <+> ppr b) $$ ppr cont+  ppr (StrictArg { sc_fun = ai, sc_cont = cont })+    = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont+  ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont })+    = (text "Select" <+> ppr dup <+> ppr bndr) $$+       whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont+++{- Note [The hole type in ApplyToTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The sc_hole_ty field of ApplyToTy records the type of the "hole" in the+continuation.  It is absolutely necessary to compute contHoleType, but it is+not used for anything else (and hence may not be evaluated).++Why is it necessary for contHoleType?  Consider the continuation+     ApplyToType Int (Stop Int)+corresponding to+     (<hole> @Int) :: Int+What is the type of <hole>?  It could be (forall a. Int) or (forall a. a),+and there is no way to know which, so we must record it.++In a chain of applications  (f @t1 @t2 @t3) we'll lazily compute exprType+for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably+doesn't matter because we'll never compute them all.++************************************************************************+*                                                                      *+                ArgInfo and ArgSpec+*                                                                      *+************************************************************************+-}++data ArgInfo+  = ArgInfo {+        ai_fun   :: OutId,      -- The function+        ai_args  :: [ArgSpec],  -- ...applied to these args (which are in *reverse* order)++        ai_type  :: OutType,    -- Type of (f a1 ... an)++        ai_rules :: FunRules,   -- Rules for this function++        ai_encl :: Bool,        -- Flag saying whether this function+                                -- or an enclosing one has rules (recursively)+                                --      True => be keener to inline in all args++        ai_strs :: [Bool],      -- Strictness of remaining arguments+                                --   Usually infinite, but if it is finite it guarantees+                                --   that the function diverges after being given+                                --   that number of args+        ai_discs :: [Int]       -- Discounts for remaining arguments; non-zero => be keener to inline+                                --   Always infinite+    }++data ArgSpec+  = ValArg OutExpr                    -- Apply to this (coercion or value); c.f. ApplyToVal+  | TyArg { as_arg_ty  :: OutType     -- Apply to this type; c.f. ApplyToTy+          , as_hole_ty :: OutType }   -- Type of the function (presumably forall a. blah)+  | CastBy OutCoercion                -- Cast by this; c.f. CastIt++instance Outputable ArgSpec where+  ppr (ValArg e)                 = text "ValArg" <+> ppr e+  ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty+  ppr (CastBy c)                 = text "CastBy" <+> ppr c++addValArgTo :: ArgInfo -> OutExpr -> ArgInfo+addValArgTo ai arg = ai { ai_args = ValArg arg : ai_args ai+                        , ai_type = applyTypeToArg (ai_type ai) arg+                        , ai_rules = decRules (ai_rules ai) }++addTyArgTo :: ArgInfo -> OutType -> ArgInfo+addTyArgTo ai arg_ty = ai { ai_args = arg_spec : ai_args ai+                          , ai_type = piResultTy poly_fun_ty arg_ty+                          , ai_rules = decRules (ai_rules ai) }+  where+    poly_fun_ty = ai_type ai+    arg_spec    = TyArg { as_arg_ty = arg_ty, as_hole_ty = poly_fun_ty }++addCastTo :: ArgInfo -> OutCoercion -> ArgInfo+addCastTo ai co = ai { ai_args = CastBy co : ai_args ai+                     , ai_type = pSnd (coercionKind co) }++argInfoAppArgs :: [ArgSpec] -> [OutExpr]+argInfoAppArgs []                              = []+argInfoAppArgs (CastBy {}                : _)  = []  -- Stop at a cast+argInfoAppArgs (ValArg e                 : as) = e       : argInfoAppArgs as+argInfoAppArgs (TyArg { as_arg_ty = ty } : as) = Type ty : argInfoAppArgs as++pushSimplifiedArgs :: SimplEnv -> [ArgSpec] -> SimplCont -> SimplCont+pushSimplifiedArgs _env []           k = k+pushSimplifiedArgs env  (arg : args) k+  = case arg of+      TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }+               -> ApplyToTy  { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = rest }+      ValArg e -> ApplyToVal { sc_arg = e, sc_env = env, sc_dup = Simplified, sc_cont = rest }+      CastBy c -> CastIt c rest+  where+    rest = pushSimplifiedArgs env args k+           -- The env has an empty SubstEnv++argInfoExpr :: OutId -> [ArgSpec] -> OutExpr+-- NB: the [ArgSpec] is reversed so that the first arg+-- in the list is the last one in the application+argInfoExpr fun rev_args+  = go rev_args+  where+    go []                              = Var fun+    go (ValArg a                 : as) = go as `App` a+    go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty+    go (CastBy co                : as) = mkCast (go as) co+++type FunRules = Maybe (Int, [CoreRule]) -- Remaining rules for this function+     -- Nothing => No rules+     -- Just (n, rules) => some rules, requiring at least n more type/value args++decRules :: FunRules -> FunRules+decRules (Just (n, rules)) = Just (n-1, rules)+decRules Nothing           = Nothing++mkFunRules :: [CoreRule] -> FunRules+mkFunRules [] = Nothing+mkFunRules rs = Just (n_required, rs)+  where+    n_required = maximum (map ruleArity rs)++{-+************************************************************************+*                                                                      *+                Functions on SimplCont+*                                                                      *+************************************************************************+-}++mkBoringStop :: OutType -> SimplCont+mkBoringStop ty = Stop ty BoringCtxt++mkRhsStop :: OutType -> SimplCont       -- See Note [RHS of lets] in CoreUnfold+mkRhsStop ty = Stop ty RhsCtxt++mkLazyArgStop :: OutType -> CallCtxt -> SimplCont+mkLazyArgStop ty cci = Stop ty cci++-------------------+contIsRhsOrArg :: SimplCont -> Bool+contIsRhsOrArg (Stop {})       = True+contIsRhsOrArg (StrictBind {}) = True+contIsRhsOrArg (StrictArg {})  = True+contIsRhsOrArg _               = False++contIsRhs :: SimplCont -> Bool+contIsRhs (Stop _ RhsCtxt) = True+contIsRhs _                = False++-------------------+contIsStop :: SimplCont -> Bool+contIsStop (Stop {}) = True+contIsStop _         = False++contIsDupable :: SimplCont -> Bool+contIsDupable (Stop {})                         = True+contIsDupable (ApplyToTy  { sc_cont = k })      = contIsDupable k+contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants]+contIsDupable (Select { sc_dup = OkToDup })     = True -- ...ditto...+contIsDupable (StrictArg { sc_dup = OkToDup })  = True -- ...ditto...+contIsDupable (CastIt _ k)                      = contIsDupable k+contIsDupable _                                 = False++-------------------+contIsTrivial :: SimplCont -> Bool+contIsTrivial (Stop {})                                         = True+contIsTrivial (ApplyToTy { sc_cont = k })                       = contIsTrivial k+contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k+contIsTrivial (CastIt _ k)                                      = contIsTrivial k+contIsTrivial _                                                 = False++-------------------+contResultType :: SimplCont -> OutType+contResultType (Stop ty _)                  = ty+contResultType (CastIt _ k)                 = contResultType k+contResultType (StrictBind { sc_cont = k }) = contResultType k+contResultType (StrictArg { sc_cont = k })  = contResultType k+contResultType (Select { sc_cont = k })     = contResultType k+contResultType (ApplyToTy  { sc_cont = k }) = contResultType k+contResultType (ApplyToVal { sc_cont = k }) = contResultType k+contResultType (TickIt _ k)                 = contResultType k++contHoleType :: SimplCont -> OutType+contHoleType (Stop ty _)                      = ty+contHoleType (TickIt _ k)                     = contHoleType k+contHoleType (CastIt co _)                    = pFst (coercionKind co)+contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })+  = perhapsSubstTy dup se (idType b)+contHoleType (StrictArg { sc_fun = ai })      = funArgTy (ai_type ai)+contHoleType (ApplyToTy  { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy]+contHoleType (ApplyToVal { sc_arg = e, sc_env = se, sc_dup = dup, sc_cont = k })+  = mkVisFunTy (perhapsSubstTy dup se (exprType e))+               (contHoleType k)+contHoleType (Select { sc_dup = d, sc_bndr =  b, sc_env = se })+  = perhapsSubstTy d se (idType b)++-------------------+countArgs :: SimplCont -> Int+-- Count all arguments, including types, coercions, and other values+countArgs (ApplyToTy  { sc_cont = cont }) = 1 + countArgs cont+countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont+countArgs _                               = 0++contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)+-- Summarises value args, discards type args and coercions+-- The returned continuation of the call is only used to+-- answer questions like "are you interesting?"+contArgs cont+  | lone cont = (True, [], cont)+  | otherwise = go [] cont+  where+    lone (ApplyToTy  {}) = False  -- See Note [Lone variables] in CoreUnfold+    lone (ApplyToVal {}) = False+    lone (CastIt {})     = False+    lone _               = True++    go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k })+                                        = go (is_interesting arg se : args) k+    go args (ApplyToTy { sc_cont = k }) = go args k+    go args (CastIt _ k)                = go args k+    go args k                           = (False, reverse args, k)++    is_interesting arg se = interestingArg se arg+                   -- Do *not* use short-cutting substitution here+                   -- because we want to get as much IdInfo as possible+++-------------------+mkArgInfo :: SimplEnv+          -> Id+          -> [CoreRule] -- Rules for function+          -> Int        -- Number of value args+          -> SimplCont  -- Context of the call+          -> ArgInfo++mkArgInfo env fun rules n_val_args call_cont+  | n_val_args < idArity fun            -- Note [Unsaturated functions]+  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty+            , ai_rules = fun_rules+            , ai_encl = False+            , ai_strs = vanilla_stricts+            , ai_discs = vanilla_discounts }+  | otherwise+  = ArgInfo { ai_fun = fun, ai_args = [], ai_type = fun_ty+            , ai_rules = fun_rules+            , ai_encl  = interestingArgContext rules call_cont+            , ai_strs  = arg_stricts+            , ai_discs = arg_discounts }+  where+    fun_ty = idType fun++    fun_rules = mkFunRules rules++    vanilla_discounts, arg_discounts :: [Int]+    vanilla_discounts = repeat 0+    arg_discounts = case idUnfolding fun of+                        CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}}+                              -> discounts ++ vanilla_discounts+                        _     -> vanilla_discounts++    vanilla_stricts, arg_stricts :: [Bool]+    vanilla_stricts  = repeat False++    arg_stricts+      | not (sm_inline (seMode env))+      = vanilla_stricts -- See Note [Do not expose strictness if sm_inline=False]+      | otherwise+      = add_type_str fun_ty $+        case splitStrictSig (idStrictness fun) of+          (demands, result_info)+                | not (demands `lengthExceeds` n_val_args)+                ->      -- Enough args, use the strictness given.+                        -- For bottoming functions we used to pretend that the arg+                        -- is lazy, so that we don't treat the arg as an+                        -- interesting context.  This avoids substituting+                        -- top-level bindings for (say) strings into+                        -- calls to error.  But now we are more careful about+                        -- inlining lone variables, so its ok (see SimplUtils.analyseCont)+                   if isBotRes result_info then+                        map isStrictDmd demands         -- Finite => result is bottom+                   else+                        map isStrictDmd demands ++ vanilla_stricts+               | otherwise+               -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)+                                <+> ppr n_val_args <+> ppr demands )+                   vanilla_stricts      -- Not enough args, or no strictness++    add_type_str :: Type -> [Bool] -> [Bool]+    -- If the function arg types are strict, record that in the 'strictness bits'+    -- No need to instantiate because unboxed types (which dominate the strict+    --   types) can't instantiate type variables.+    -- add_type_str is done repeatedly (for each call);+    --   might be better once-for-all in the function+    -- But beware primops/datacons with no strictness++    add_type_str _ [] = []+    add_type_str fun_ty all_strs@(str:strs)+      | Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty        -- Add strict-type info+      = (str || Just False == isLiftedType_maybe arg_ty)+        : add_type_str fun_ty' strs+          -- If the type is levity-polymorphic, we can't know whether it's+          -- strict. isLiftedType_maybe will return Just False only when+          -- we're sure the type is unlifted.++      | Just (_, fun_ty') <- splitForAllTy_maybe fun_ty+      = add_type_str fun_ty' all_strs     -- Look through foralls++      | otherwise+      = all_strs++{- Note [Unsaturated functions]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (test eyeball/inline4)+        x = a:as+        y = f x+where f has arity 2.  Then we do not want to inline 'x', because+it'll just be floated out again.  Even if f has lots of discounts+on its first argument -- it must be saturated for these to kick in++Note [Do not expose strictness if sm_inline=False]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+#15163 showed a case in which we had++  {-# INLINE [1] zip #-}+  zip = undefined++  {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-}++If we expose zip's bottoming nature when simplifing the LHS of the+RULE we get+  {-# RULES "foo" forall as bs.+                   stream (case zip of {}) = ..blah... #-}+discarding the arguments to zip.  Usually this is fine, but on the+LHS of a rule it's not, because 'as' and 'bs' are now not bound on+the LHS.++This is a pretty pathalogical example, so I'm not losing sleep over+it, but the simplest solution was to check sm_inline; if it is False,+which it is on the LHS of a rule (see updModeForRules), then don't+make use of the strictness info for the function.+-}+++{-+************************************************************************+*                                                                      *+        Interesting arguments+*                                                                      *+************************************************************************++Note [Interesting call context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to avoid inlining an expression where there can't possibly be+any gain, such as in an argument position.  Hence, if the continuation+is interesting (eg. a case scrutinee, application etc.) then we+inline, otherwise we don't.++Previously some_benefit used to return True only if the variable was+applied to some value arguments.  This didn't work:++        let x = _coerce_ (T Int) Int (I# 3) in+        case _coerce_ Int (T Int) x of+                I# y -> ....++we want to inline x, but can't see that it's a constructor in a case+scrutinee position, and some_benefit is False.++Another example:++dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)++....  case dMonadST _@_ x0 of (a,b,c) -> ....++we'd really like to inline dMonadST here, but we *don't* want to+inline if the case expression is just++        case x of y { DEFAULT -> ... }++since we can just eliminate this case instead (x is in WHNF).  Similar+applies when x is bound to a lambda expression.  Hence+contIsInteresting looks for case expressions with just a single+default case.++Note [No case of case is boring]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we see+   case f x of <alts>++we'd usually treat the context as interesting, to encourage 'f' to+inline.  But if case-of-case is off, it's really not so interesting+after all, because we are unlikely to be able to push the case+expression into the branches of any case in f's unfolding.  So, to+reduce unnecessary code expansion, we just make the context look boring.+This made a small compile-time perf improvement in perf/compiler/T6048,+and it looks plausible to me.+-}++interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt+-- See Note [Interesting call context]+interestingCallContext env cont+  = interesting cont+  where+    interesting (Select {})+       | sm_case_case (getMode env) = CaseCtxt+       | otherwise                  = BoringCtxt+       -- See Note [No case of case is boring]++    interesting (ApplyToVal {}) = ValAppCtxt+        -- Can happen if we have (f Int |> co) y+        -- If f has an INLINE prag we need to give it some+        -- motivation to inline. See Note [Cast then apply]+        -- in CoreUnfold++    interesting (StrictArg { sc_cci = cci }) = cci+    interesting (StrictBind {})              = BoringCtxt+    interesting (Stop _ cci)                 = cci+    interesting (TickIt _ k)                 = interesting k+    interesting (ApplyToTy { sc_cont = k })  = interesting k+    interesting (CastIt _ k)                 = interesting k+        -- If this call is the arg of a strict function, the context+        -- is a bit interesting.  If we inline here, we may get useful+        -- evaluation information to avoid repeated evals: e.g.+        --      x + (y * z)+        -- Here the contIsInteresting makes the '*' keener to inline,+        -- which in turn exposes a constructor which makes the '+' inline.+        -- Assuming that +,* aren't small enough to inline regardless.+        --+        -- It's also very important to inline in a strict context for things+        -- like+        --              foldr k z (f x)+        -- Here, the context of (f x) is strict, and if f's unfolding is+        -- a build it's *great* to inline it here.  So we must ensure that+        -- the context for (f x) is not totally uninteresting.++interestingArgContext :: [CoreRule] -> SimplCont -> Bool+-- If the argument has form (f x y), where x,y are boring,+-- and f is marked INLINE, then we don't want to inline f.+-- But if the context of the argument is+--      g (f x y)+-- where g has rules, then we *do* want to inline f, in case it+-- exposes a rule that might fire.  Similarly, if the context is+--      h (g (f x x))+-- where h has rules, then we do want to inline f; hence the+-- call_cont argument to interestingArgContext+--+-- The ai-rules flag makes this happen; if it's+-- set, the inliner gets just enough keener to inline f+-- regardless of how boring f's arguments are, if it's marked INLINE+--+-- The alternative would be to *always* inline an INLINE function,+-- regardless of how boring its context is; but that seems overkill+-- For example, it'd mean that wrapper functions were always inlined+--+-- The call_cont passed to interestingArgContext is the context of+-- the call itself, e.g. g <hole> in the example above+interestingArgContext rules call_cont+  = notNull rules || enclosing_fn_has_rules+  where+    enclosing_fn_has_rules = go call_cont++    go (Select {})                  = False+    go (ApplyToVal {})              = False  -- Shouldn't really happen+    go (ApplyToTy  {})              = False  -- Ditto+    go (StrictArg { sc_cci = cci }) = interesting cci+    go (StrictBind {})              = False      -- ??+    go (CastIt _ c)                 = go c+    go (Stop _ cci)                 = interesting cci+    go (TickIt _ c)                 = go c++    interesting RuleArgCtxt = True+    interesting _           = False+++{- Note [Interesting arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An argument is interesting if it deserves a discount for unfoldings+with a discount in that argument position.  The idea is to avoid+unfolding a function that is applied only to variables that have no+unfolding (i.e. they are probably lambda bound): f x y z There is+little point in inlining f here.++Generally, *values* (like (C a b) and (\x.e)) deserve discounts.  But+we must look through lets, eg (let x = e in C a b), because the let will+float, exposing the value, if we inline.  That makes it different to+exprIsHNF.++Before 2009 we said it was interesting if the argument had *any* structure+at all; i.e. (hasSomeUnfolding v).  But does too much inlining; see #3016.++But we don't regard (f x y) as interesting, unless f is unsaturated.+If it's saturated and f hasn't inlined, then it's probably not going+to now!++Note [Conlike is interesting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        f d = ...((*) d x y)...+        ... f (df d')...+where df is con-like. Then we'd really like to inline 'f' so that the+rule for (*) (df d) can fire.  To do this+  a) we give a discount for being an argument of a class-op (eg (*) d)+  b) we say that a con-like argument (eg (df d)) is interesting+-}++interestingArg :: SimplEnv -> CoreExpr -> ArgSummary+-- See Note [Interesting arguments]+interestingArg env e = go env 0 e+  where+    -- n is # value args to which the expression is applied+    go env n (Var v)+       = case substId env v of+           DoneId v'            -> go_var n v'+           DoneEx e _           -> go (zapSubstEnv env)             n e+           ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e++    go _   _ (Lit {})          = ValueArg+    go _   _ (Type _)          = TrivArg+    go _   _ (Coercion _)      = TrivArg+    go env n (App fn (Type _)) = go env n fn+    go env n (App fn _)        = go env (n+1) fn+    go env n (Tick _ a)        = go env n a+    go env n (Cast e _)        = go env n e+    go env n (Lam v e)+       | isTyVar v             = go env n e+       | n>0                   = NonTrivArg     -- (\x.b) e   is NonTriv+       | otherwise             = ValueArg+    go _ _ (Case {})           = NonTrivArg+    go env n (Let b e)         = case go env' n e of+                                   ValueArg -> ValueArg+                                   _        -> NonTrivArg+                               where+                                 env' = env `addNewInScopeIds` bindersOf b++    go_var n v+       | isConLikeId v     = ValueArg   -- Experimenting with 'conlike' rather that+                                        --    data constructors here+       | idArity v > n     = ValueArg   -- Catches (eg) primops with arity but no unfolding+       | n > 0             = NonTrivArg -- Saturated or unknown call+       | conlike_unfolding = ValueArg   -- n==0; look for an interesting unfolding+                                        -- See Note [Conlike is interesting]+       | otherwise         = TrivArg    -- n==0, no useful unfolding+       where+         conlike_unfolding = isConLikeUnfolding (idUnfolding v)++{-+************************************************************************+*                                                                      *+                  SimplMode+*                                                                      *+************************************************************************++The SimplMode controls several switches; see its definition in+CoreMonad+        sm_rules      :: Bool     -- Whether RULES are enabled+        sm_inline     :: Bool     -- Whether inlining is enabled+        sm_case_case  :: Bool     -- Whether case-of-case is enabled+        sm_eta_expand :: Bool     -- Whether eta-expansion is enabled+-}++simplEnvForGHCi :: DynFlags -> SimplEnv+simplEnvForGHCi dflags+  = mkSimplEnv $ SimplMode { sm_names  = ["GHCi"]+                           , sm_phase  = InitialPhase+                           , sm_dflags = dflags+                           , sm_rules  = rules_on+                           , sm_inline = False+                           , sm_eta_expand = eta_expand_on+                           , sm_case_case  = True }+  where+    rules_on      = gopt Opt_EnableRewriteRules   dflags+    eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags+   -- Do not do any inlining, in case we expose some unboxed+   -- tuple stuff that confuses the bytecode interpreter++updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode+-- See Note [Simplifying inside stable unfoldings]+updModeForStableUnfoldings inline_rule_act current_mode+  = current_mode { sm_phase      = phaseFromActivation inline_rule_act+                 , sm_inline     = True+                 , sm_eta_expand = False }+                     -- sm_eta_expand: see Note [No eta expansion in stable unfoldings]+       -- For sm_rules, just inherit; sm_rules might be "off"+       -- because of -fno-enable-rewrite-rules+  where+    phaseFromActivation (ActiveAfter _ n) = Phase n+    phaseFromActivation _                 = InitialPhase++updModeForRules :: SimplMode -> SimplMode+-- See Note [Simplifying rules]+updModeForRules current_mode+  = current_mode { sm_phase      = InitialPhase+                 , sm_inline     = False  -- See Note [Do not expose strictness if sm_inline=False]+                 , sm_rules      = False+                 , sm_eta_expand = False }++{- Note [Simplifying rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When simplifying a rule LHS, refrain from /any/ inlining or applying+of other RULES.++Doing anything to the LHS is plain confusing, because it means that what the+rule matches is not what the user wrote. c.f. #10595, and #10528.+Moreover, inlining (or applying rules) on rule LHSs risks introducing+Ticks into the LHS, which makes matching trickier. #10665, #10745.++Doing this to either side confounds tools like HERMIT, which seek to reason+about and apply the RULES as originally written. See #10829.++Note [No eta expansion in stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have a stable unfolding++  f :: Ord a => a -> IO ()+  -- Unfolding template+  --    = /\a \(d:Ord a) (x:a). bla++we do not want to eta-expand to++  f :: Ord a => a -> IO ()+  -- Unfolding template+  --    = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co++because not specialisation of the overloading doesn't work properly+(see Note [Specialisation shape] in Specialise), #9509.++So we disable eta-expansion in stable unfoldings.++Note [Inlining in gentle mode]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Something is inlined if+   (i)   the sm_inline flag is on, AND+   (ii)  the thing has an INLINE pragma, AND+   (iii) the thing is inlinable in the earliest phase.++Example of why (iii) is important:+  {-# INLINE [~1] g #-}+  g = ...++  {-# INLINE f #-}+  f x = g (g x)++If we were to inline g into f's inlining, then an importing module would+never be able to do+        f e --> g (g e) ---> RULE fires+because the stable unfolding for f has had g inlined into it.++On the other hand, it is bad not to do ANY inlining into an+stable unfolding, because then recursive knots in instance declarations+don't get unravelled.++However, *sometimes* SimplGently must do no call-site inlining at all+(hence sm_inline = False).  Before full laziness we must be careful+not to inline wrappers, because doing so inhibits floating+    e.g. ...(case f x of ...)...+    ==> ...(case (case x of I# x# -> fw x#) of ...)...+    ==> ...(case x of I# x# -> case fw x# of ...)...+and now the redex (f x) isn't floatable any more.++The no-inlining thing is also important for Template Haskell.  You might be+compiling in one-shot mode with -O2; but when TH compiles a splice before+running it, we don't want to use -O2.  Indeed, we don't want to inline+anything, because the byte-code interpreter might get confused about+unboxed tuples and suchlike.++Note [Simplifying inside stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must take care with simplification inside stable unfoldings (which come from+INLINE pragmas).++First, consider the following example+        let f = \pq -> BIG+        in+        let g = \y -> f y y+            {-# INLINE g #-}+        in ...g...g...g...g...g...+Now, if that's the ONLY occurrence of f, it might be inlined inside g,+and thence copied multiple times when g is inlined. HENCE we treat+any occurrence in a stable unfolding as a multiple occurrence, not a single+one; see OccurAnal.addRuleUsage.++Second, we do want *do* to some modest rules/inlining stuff in stable+unfoldings, partly to eliminate senseless crap, and partly to break+the recursive knots generated by instance declarations.++However, suppose we have+        {-# INLINE <act> f #-}+        f = <rhs>+meaning "inline f in phases p where activation <act>(p) holds".+Then what inlinings/rules can we apply to the copy of <rhs> captured in+f's stable unfolding?  Our model is that literally <rhs> is substituted for+f when it is inlined.  So our conservative plan (implemented by+updModeForStableUnfoldings) is this:++  -------------------------------------------------------------+  When simplifying the RHS of a stable unfolding, set the phase+  to the phase in which the stable unfolding first becomes active+  -------------------------------------------------------------++That ensures that++  a) Rules/inlinings that *cease* being active before p will+     not apply to the stable unfolding, consistent with it being+     inlined in its *original* form in phase p.++  b) Rules/inlinings that only become active *after* p will+     not apply to the stable unfolding, again to be consistent with+     inlining the *original* rhs in phase p.++For example,+        {-# INLINE f #-}+        f x = ...g...++        {-# NOINLINE [1] g #-}+        g y = ...++        {-# RULE h g = ... #-}+Here we must not inline g into f's RHS, even when we get to phase 0,+because when f is later inlined into some other module we want the+rule for h to fire.++Similarly, consider+        {-# INLINE f #-}+        f x = ...g...++        g y = ...+and suppose that there are auto-generated specialisations and a strictness+wrapper for g.  The specialisations get activation AlwaysActive, and the+strictness wrapper get activation (ActiveAfter 0).  So the strictness+wrepper fails the test and won't be inlined into f's stable unfolding. That+means f can inline, expose the specialised call to g, so the specialisation+rules can fire.++A note about wrappers+~~~~~~~~~~~~~~~~~~~~~+It's also important not to inline a worker back into a wrapper.+A wrapper looks like+        wraper = inline_me (\x -> ...worker... )+Normally, the inline_me prevents the worker getting inlined into+the wrapper (initially, the worker's only call site!).  But,+if the wrapper is sure to be called, the strictness analyser will+mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf+continuation.+-}++activeUnfolding :: SimplMode -> Id -> Bool+activeUnfolding mode id+  | isCompulsoryUnfolding (realIdUnfolding id)+  = True   -- Even sm_inline can't override compulsory unfoldings+  | otherwise+  = isActive (sm_phase mode) (idInlineActivation id)+  && sm_inline mode+      -- `or` isStableUnfolding (realIdUnfolding id)+      -- Inline things when+      --  (a) they are active+      --  (b) sm_inline says so, except that for stable unfoldings+      --                         (ie pragmas) we inline anyway++getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv+-- When matching in RULE, we want to "look through" an unfolding+-- (to see a constructor) if *rules* are on, even if *inlinings*+-- are not.  A notable example is DFuns, which really we want to+-- match in rules like (op dfun) in gentle mode. Another example+-- is 'otherwise' which we want exprIsConApp_maybe to be able to+-- see very early on+getUnfoldingInRuleMatch env+  = (in_scope, id_unf)+  where+    in_scope = seInScope env+    mode = getMode env+    id_unf id | unf_is_active id = idUnfolding id+              | otherwise        = NoUnfolding+    unf_is_active id+     | not (sm_rules mode) = -- active_unfolding_minimal id+                             isStableUnfolding (realIdUnfolding id)+        -- Do we even need to test this?  I think this InScopeEnv+        -- is only consulted if activeRule returns True, which+        -- never happens if sm_rules is False+     | otherwise           = isActive (sm_phase mode) (idInlineActivation id)++----------------------+activeRule :: SimplMode -> Activation -> Bool+-- Nothing => No rules at all+activeRule mode+  | not (sm_rules mode) = \_ -> False     -- Rewriting is off+  | otherwise           = isActive (sm_phase mode)++{-+************************************************************************+*                                                                      *+                  preInlineUnconditionally+*                                                                      *+************************************************************************++preInlineUnconditionally+~~~~~~~~~~~~~~~~~~~~~~~~+@preInlineUnconditionally@ examines a bndr to see if it is used just+once in a completely safe way, so that it is safe to discard the+binding inline its RHS at the (unique) usage site, REGARDLESS of how+big the RHS might be.  If this is the case we don't simplify the RHS+first, but just inline it un-simplified.++This is much better than first simplifying a perhaps-huge RHS and then+inlining and re-simplifying it.  Indeed, it can be at least quadratically+better.  Consider++        x1 = e1+        x2 = e2[x1]+        x3 = e3[x2]+        ...etc...+        xN = eN[xN-1]++We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.+This can happen with cascades of functions too:++        f1 = \x1.e1+        f2 = \xs.e2[f1]+        f3 = \xs.e3[f3]+        ...etc...++THE MAIN INVARIANT is this:++        ----  preInlineUnconditionally invariant -----+   IF preInlineUnconditionally chooses to inline x = <rhs>+   THEN doing the inlining should not change the occurrence+        info for the free vars of <rhs>+        ----------------------------------------------++For example, it's tempting to look at trivial binding like+        x = y+and inline it unconditionally.  But suppose x is used many times,+but this is the unique occurrence of y.  Then inlining x would change+y's occurrence info, which breaks the invariant.  It matters: y+might have a BIG rhs, which will now be dup'd at every occurrenc of x.+++Even RHSs labelled InlineMe aren't caught here, because there might be+no benefit from inlining at the call site.++[Sept 01] Don't unconditionally inline a top-level thing, because that+can simply make a static thing into something built dynamically.  E.g.+        x = (a,b)+        main = \s -> h x++[Remember that we treat \s as a one-shot lambda.]  No point in+inlining x unless there is something interesting about the call site.++But watch out: if you aren't careful, some useful foldr/build fusion+can be lost (most notably in spectral/hartel/parstof) because the+foldr didn't see the build.  Doing the dynamic allocation isn't a big+deal, in fact, but losing the fusion can be.  But the right thing here+seems to be to do a callSiteInline based on the fact that there is+something interesting about the call site (it's strict).  Hmm.  That+seems a bit fragile.++Conclusion: inline top level things gaily until Phase 0 (the last+phase), at which point don't.++Note [pre/postInlineUnconditionally in gentle mode]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Even in gentle mode we want to do preInlineUnconditionally.  The+reason is that too little clean-up happens if you don't inline+use-once things.  Also a bit of inlining is *good* for full laziness;+it can expose constant sub-expressions.  Example in+spectral/mandel/Mandel.hs, where the mandelset function gets a useful+let-float if you inline windowToViewport++However, as usual for Gentle mode, do not inline things that are+inactive in the initial stages.  See Note [Gentle mode].++Note [Stable unfoldings and preInlineUnconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas!+Example++   {-# INLINE f #-}+   f :: Eq a => a -> a+   f x = ...++   fInt :: Int -> Int+   fInt = f Int dEqInt++   ...fInt...fInt...fInt...++Here f occurs just once, in the RHS of fInt. But if we inline it there+it might make fInt look big, and we'll lose the opportunity to inline f+at each of fInt's call sites.  The INLINE pragma will only inline when+the application is saturated for exactly this reason; and we don't+want PreInlineUnconditionally to second-guess it.  A live example is+#3736.+    c.f. Note [Stable unfoldings and postInlineUnconditionally]++NB: if the pragma is INLINEABLE, then we don't want to behave in+this special way -- an INLINEABLE pragma just says to GHC "inline this+if you like".  But if there is a unique occurrence, we want to inline+the stable unfolding, not the RHS.++Note [Top-level bottoming Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Don't inline top-level Ids that are bottoming, even if they are used just+once, because FloatOut has gone to some trouble to extract them out.+Inlining them won't make the program run faster!++Note [Do not inline CoVars unconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Coercion variables appear inside coercions, and the RHS of a let-binding+is a term (not a coercion) so we can't necessarily inline the latter in+the former.+-}++preInlineUnconditionally+    :: SimplEnv -> TopLevelFlag -> InId+    -> InExpr -> StaticEnv  -- These two go together+    -> Maybe SimplEnv       -- Returned env has extended substitution+-- Precondition: rhs satisfies the let/app invariant+-- See Note [CoreSyn let/app invariant] in CoreSyn+-- Reason: we don't want to inline single uses, or discard dead bindings,+--         for unlifted, side-effect-ful bindings+preInlineUnconditionally env top_lvl bndr rhs rhs_env+  | not pre_inline_unconditionally           = Nothing+  | not active                               = Nothing+  | isTopLevel top_lvl && isBottomingId bndr = Nothing -- Note [Top-level bottoming Ids]+  | isCoVar bndr                             = Nothing -- Note [Do not inline CoVars unconditionally]+  | isExitJoinId bndr                        = Nothing -- Note [Do not inline exit join points]+                                                       -- in module Exitify+  | not (one_occ (idOccInfo bndr))           = Nothing+  | not (isStableUnfolding unf)              = Just (extend_subst_with rhs)++  -- Note [Stable unfoldings and preInlineUnconditionally]+  | isInlinablePragma inline_prag+  , Just inl <- maybeUnfoldingTemplate unf   = Just (extend_subst_with inl)+  | otherwise                                = Nothing+  where+    unf = idUnfolding bndr+    extend_subst_with inl_rhs = extendIdSubst env bndr (mkContEx rhs_env inl_rhs)++    one_occ IAmDead = True -- Happens in ((\x.1) v)+    one_occ (OneOcc { occ_one_br = True      -- One textual occurrence+                    , occ_in_lam = in_lam+                    , occ_int_cxt = int_cxt })+        | not in_lam = isNotTopLevel top_lvl || early_phase+        | otherwise  = int_cxt && canInlineInLam rhs+    one_occ _        = False++    pre_inline_unconditionally = gopt Opt_SimplPreInlining (seDynFlags env)+    mode   = getMode env+    active = isActive (sm_phase mode) (inlinePragmaActivation inline_prag)+             -- See Note [pre/postInlineUnconditionally in gentle mode]+    inline_prag = idInlinePragma bndr++-- Be very careful before inlining inside a lambda, because (a) we must not+-- invalidate occurrence information, and (b) we want to avoid pushing a+-- single allocation (here) into multiple allocations (inside lambda).+-- Inlining a *function* with a single *saturated* call would be ok, mind you.+--      || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)+--      where+--              is_cheap = exprIsCheap rhs+--              ok = is_cheap && int_cxt++        --      int_cxt         The context isn't totally boring+        -- E.g. let f = \ab.BIG in \y. map f xs+        --      Don't want to substitute for f, because then we allocate+        --      its closure every time the \y is called+        -- But: let f = \ab.BIG in \y. map (f y) xs+        --      Now we do want to substitute for f, even though it's not+        --      saturated, because we're going to allocate a closure for+        --      (f y) every time round the loop anyhow.++        -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,+        -- so substituting rhs inside a lambda doesn't change the occ info.+        -- Sadly, not quite the same as exprIsHNF.+    canInlineInLam (Lit _)    = True+    canInlineInLam (Lam b e)  = isRuntimeVar b || canInlineInLam e+    canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e+    canInlineInLam _          = False+      -- not ticks.  Counting ticks cannot be duplicated, and non-counting+      -- ticks around a Lam will disappear anyway.++    early_phase = case sm_phase mode of+                    Phase 0 -> False+                    _       -> True+-- If we don't have this early_phase test, consider+--      x = length [1,2,3]+-- The full laziness pass carefully floats all the cons cells to+-- top level, and preInlineUnconditionally floats them all back in.+-- Result is (a) static allocation replaced by dynamic allocation+--           (b) many simplifier iterations because this tickles+--               a related problem; only one inlining per pass+--+-- On the other hand, I have seen cases where top-level fusion is+-- lost if we don't inline top level thing (e.g. string constants)+-- Hence the test for phase zero (which is the phase for all the final+-- simplifications).  Until phase zero we take no special notice of+-- top level things, but then we become more leery about inlining+-- them.++{-+************************************************************************+*                                                                      *+                  postInlineUnconditionally+*                                                                      *+************************************************************************++postInlineUnconditionally+~~~~~~~~~~~~~~~~~~~~~~~~~+@postInlineUnconditionally@ decides whether to unconditionally inline+a thing based on the form of its RHS; in particular if it has a+trivial RHS.  If so, we can inline and discard the binding altogether.++NB: a loop breaker has must_keep_binding = True and non-loop-breakers+only have *forward* references. Hence, it's safe to discard the binding++NOTE: This isn't our last opportunity to inline.  We're at the binding+site right now, and we'll get another opportunity when we get to the+occurrence(s)++Note that we do this unconditional inlining only for trival RHSs.+Don't inline even WHNFs inside lambdas; doing so may simply increase+allocation when the function is called. This isn't the last chance; see+NOTE above.++NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?+Because we don't even want to inline them into the RHS of constructor+arguments. See NOTE above++NB: At one time even NOINLINE was ignored here: if the rhs is trivial+it's best to inline it anyway.  We often get a=E; b=a from desugaring,+with both a and b marked NOINLINE.  But that seems incompatible with+our new view that inlining is like a RULE, so I'm sticking to the 'active'+story for now.+-}++postInlineUnconditionally+    :: SimplEnv -> TopLevelFlag+    -> OutId            -- The binder (*not* a CoVar), including its unfolding+    -> OccInfo          -- From the InId+    -> OutExpr+    -> Bool+-- Precondition: rhs satisfies the let/app invariant+-- See Note [CoreSyn let/app invariant] in CoreSyn+-- Reason: we don't want to inline single uses, or discard dead bindings,+--         for unlifted, side-effect-ful bindings+postInlineUnconditionally env top_lvl bndr occ_info rhs+  | not active                  = False+  | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline+                                        -- because it might be referred to "earlier"+  | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally]+  | isTopLevel top_lvl          = False -- Note [Top level and postInlineUnconditionally]+  | exprIsTrivial rhs           = True+  | otherwise+  = case occ_info of+        -- The point of examining occ_info here is that for *non-values*+        -- that occur outside a lambda, the call-site inliner won't have+        -- a chance (because it doesn't know that the thing+        -- only occurs once).   The pre-inliner won't have gotten+        -- it either, if the thing occurs in more than one branch+        -- So the main target is things like+        --      let x = f y in+        --      case v of+        --         True  -> case x of ...+        --         False -> case x of ...+        -- This is very important in practice; e.g. wheel-seive1 doubles+        -- in allocation if you miss this out+      OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt }+               -- OneOcc => no code-duplication issue+        ->     smallEnoughToInline dflags unfolding     -- Small enough to dup+                        -- ToDo: consider discount on smallEnoughToInline if int_cxt is true+                        --+                        -- NB: Do NOT inline arbitrarily big things, even if one_br is True+                        -- Reason: doing so risks exponential behaviour.  We simplify a big+                        --         expression, inline it, and simplify it again.  But if the+                        --         very same thing happens in the big expression, we get+                        --         exponential cost!+                        -- PRINCIPLE: when we've already simplified an expression once,+                        -- make sure that we only inline it if it's reasonably small.++           && (not in_lam ||+                        -- Outside a lambda, we want to be reasonably aggressive+                        -- about inlining into multiple branches of case+                        -- e.g. let x = <non-value>+                        --      in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }+                        -- Inlining can be a big win if C3 is the hot-spot, even if+                        -- the uses in C1, C2 are not 'interesting'+                        -- An example that gets worse if you add int_cxt here is 'clausify'++                (isCheapUnfolding unfolding && int_cxt))+                        -- isCheap => acceptable work duplication; in_lam may be true+                        -- int_cxt to prevent us inlining inside a lambda without some+                        -- good reason.  See the notes on int_cxt in preInlineUnconditionally++      IAmDead -> True   -- This happens; for example, the case_bndr during case of+                        -- known constructor:  case (a,b) of x { (p,q) -> ... }+                        -- Here x isn't mentioned in the RHS, so we don't want to+                        -- create the (dead) let-binding  let x = (a,b) in ...++      _ -> False++-- Here's an example that we don't handle well:+--      let f = if b then Left (\x.BIG) else Right (\y.BIG)+--      in \y. ....case f of {...} ....+-- Here f is used just once, and duplicating the case work is fine (exprIsCheap).+-- But+--  - We can't preInlineUnconditionally because that woud invalidate+--    the occ info for b.+--  - We can't postInlineUnconditionally because the RHS is big, and+--    that risks exponential behaviour+--  - We can't call-site inline, because the rhs is big+-- Alas!++  where+    unfolding = idUnfolding bndr+    dflags    = seDynFlags env+    active    = isActive (sm_phase (getMode env)) (idInlineActivation bndr)+        -- See Note [pre/postInlineUnconditionally in gentle mode]++{-+Note [Top level and postInlineUnconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't do postInlineUnconditionally for top-level things (even for+ones that are trivial):++  * Doing so will inline top-level error expressions that have been+    carefully floated out by FloatOut.  More generally, it might+    replace static allocation with dynamic.++  * Even for trivial expressions there's a problem.  Consider+      {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-}+      blah xs = reverse xs+      ruggle = sort+    In one simplifier pass we might fire the rule, getting+      blah xs = ruggle xs+    but in *that* simplifier pass we must not do postInlineUnconditionally+    on 'ruggle' because then we'll have an unbound occurrence of 'ruggle'++    If the rhs is trivial it'll be inlined by callSiteInline, and then+    the binding will be dead and discarded by the next use of OccurAnal++  * There is less point, because the main goal is to get rid of local+    bindings used in multiple case branches.++  * The inliner should inline trivial things at call sites anyway.++  * The Id might be exported.  We could check for that separately,+    but since we aren't going to postInlineUnconditionally /any/+    top-level bindings, we don't need to test.++Note [Stable unfoldings and postInlineUnconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do not do postInlineUnconditionally if the Id has a stable unfolding,+otherwise we lose the unfolding.  Example++     -- f has stable unfolding with rhs (e |> co)+     --   where 'e' is big+     f = e |> co++Then there's a danger we'll optimise to++     f' = e+     f = f' |> co++and now postInlineUnconditionally, losing the stable unfolding on f.  Now f'+won't inline because 'e' is too big.++    c.f. Note [Stable unfoldings and preInlineUnconditionally]+++************************************************************************+*                                                                      *+        Rebuilding a lambda+*                                                                      *+************************************************************************+-}++mkLam :: SimplEnv -> [OutBndr] -> OutExpr -> SimplCont -> SimplM OutExpr+-- mkLam tries three things+--      a) eta reduction, if that gives a trivial expression+--      b) eta expansion [only if there are some value lambdas]++mkLam _env [] body _cont+  = return body+mkLam env bndrs body cont+  = do { dflags <- getDynFlags+       ; mkLam' dflags bndrs body }+  where+    mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr+    mkLam' dflags bndrs (Cast body co)+      | not (any bad bndrs)+        -- Note [Casts and lambdas]+      = do { lam <- mkLam' dflags bndrs body+           ; return (mkCast lam (mkPiCos Representational bndrs co)) }+      where+        co_vars  = tyCoVarsOfCo co+        bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars++    mkLam' dflags bndrs body@(Lam {})+      = mkLam' dflags (bndrs ++ bndrs1) body1+      where+        (bndrs1, body1) = collectBinders body++    mkLam' dflags bndrs (Tick t expr)+      | tickishFloatable t+      = mkTick t <$> mkLam' dflags bndrs expr++    mkLam' dflags bndrs body+      | gopt Opt_DoEtaReduction dflags+      , Just etad_lam <- tryEtaReduce bndrs body+      = do { tick (EtaReduction (head bndrs))+           ; return etad_lam }++      | not (contIsRhs cont)   -- See Note [Eta-expanding lambdas]+      , sm_eta_expand (getMode env)+      , any isRuntimeVar bndrs+      , let body_arity = exprEtaExpandArity dflags body+      , body_arity > 0+      = do { tick (EtaExpansion (head bndrs))+           ; let res = mkLams bndrs (etaExpand body_arity body)+           ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body)+                                          , text "after" <+> ppr res])+           ; return res }++      | otherwise+      = return (mkLams bndrs body)++{-+Note [Eta expanding lambdas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general we *do* want to eta-expand lambdas. Consider+   f (\x -> case x of (a,b) -> \s -> blah)+where 's' is a state token, and hence can be eta expanded.  This+showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather+important function!++The eta-expansion will never happen unless we do it now.  (Well, it's+possible that CorePrep will do it, but CorePrep only has a half-baked+eta-expander that can't deal with casts.  So it's much better to do it+here.)++However, when the lambda is let-bound, as the RHS of a let, we have a+better eta-expander (in the form of tryEtaExpandRhs), so we don't+bother to try expansion in mkLam in that case; hence the contIsRhs+guard.++NB: We check the SimplEnv (sm_eta_expand), not DynFlags.+    See Note [No eta expansion in stable unfoldings]++Note [Casts and lambdas]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        (\x. (\y. e) `cast` g1) `cast` g2+There is a danger here that the two lambdas look separated, and the+full laziness pass might float an expression to between the two.++So this equation in mkLam' floats the g1 out, thus:+        (\x. e `cast` g1)  -->  (\x.e) `cast` (tx -> g1)+where x:tx.++In general, this floats casts outside lambdas, where (I hope) they+might meet and cancel with some other cast:+        \x. e `cast` co   ===>   (\x. e) `cast` (tx -> co)+        /\a. e `cast` co  ===>   (/\a. e) `cast` (/\a. co)+        /\g. e `cast` co  ===>   (/\g. e) `cast` (/\g. co)+                          (if not (g `in` co))++Notice that it works regardless of 'e'.  Originally it worked only+if 'e' was itself a lambda, but in some cases that resulted in+fruitless iteration in the simplifier.  A good example was when+compiling Text.ParserCombinators.ReadPrec, where we had a definition+like    (\x. Get `cast` g)+where Get is a constructor with nonzero arity.  Then mkLam eta-expanded+the Get, and the next iteration eta-reduced it, and then eta-expanded+it again.++Note also the side condition for the case of coercion binders.+It does not make sense to transform+        /\g. e `cast` g  ==>  (/\g.e) `cast` (/\g.g)+because the latter is not well-kinded.++************************************************************************+*                                                                      *+              Eta expansion+*                                                                      *+************************************************************************+-}++tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr+                -> SimplM (Arity, Bool, OutExpr)+-- See Note [Eta-expanding at let bindings]+-- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then+--   (a) rhs' has manifest arity n+--   (b) if is_bot is True then rhs' applied to n args is guaranteed bottom+tryEtaExpandRhs mode bndr rhs+  | Just join_arity <- isJoinId_maybe bndr+  = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs+       ; return (count isId join_bndrs, exprIsBottom join_body, rhs) }+         -- Note [Do not eta-expand join points]+         -- But do return the correct arity and bottom-ness, because+         -- these are used to set the bndr's IdInfo (#15517)+         -- Note [idArity for join points]++  | otherwise+  = do { (new_arity, is_bot, new_rhs) <- try_expand++       ; WARN( new_arity < old_id_arity,+               (text "Arity decrease:" <+> (ppr bndr <+> ppr old_id_arity+                <+> ppr old_arity <+> ppr new_arity) $$ ppr new_rhs) )+                        -- Note [Arity decrease] in Simplify+         return (new_arity, is_bot, new_rhs) }+  where+    try_expand+      | exprIsTrivial rhs+      = return (exprArity rhs, False, rhs)++      | sm_eta_expand mode      -- Provided eta-expansion is on+      , new_arity > old_arity   -- And the current manifest arity isn't enough+      = do { tick (EtaExpansion bndr)+           ; return (new_arity, is_bot, etaExpand new_arity rhs) }++      | otherwise+      = return (old_arity, is_bot && new_arity == old_arity, rhs)++    dflags       = sm_dflags mode+    old_arity    = exprArity rhs -- See Note [Do not expand eta-expand PAPs]+    old_id_arity = idArity bndr++    (new_arity1, is_bot) = findRhsArity dflags bndr rhs old_arity+    new_arity2 = idCallArity bndr+    new_arity  = max new_arity1 new_arity2++{-+Note [Eta-expanding at let bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We now eta expand at let-bindings, which is where the payoff comes.+The most significant thing is that we can do a simple arity analysis+(in CoreArity.findRhsArity), which we can't do for free-floating lambdas++One useful consequence of not eta-expanding lambdas is this example:+   genMap :: C a => ...+   {-# INLINE genMap #-}+   genMap f xs = ...++   myMap :: D a => ...+   {-# INLINE myMap #-}+   myMap = genMap++Notice that 'genMap' should only inline if applied to two arguments.+In the stable unfolding for myMap we'll have the unfolding+    (\d -> genMap Int (..d..))+We do not want to eta-expand to+    (\d f xs -> genMap Int (..d..) f xs)+because then 'genMap' will inline, and it really shouldn't: at least+as far as the programmer is concerned, it's not applied to two+arguments!++Note [Do not eta-expand join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Similarly to CPR (see Note [Don't CPR join points] in WorkWrap), a join point+stands well to gain from its outer binding's eta-expansion, and eta-expanding a+join point is fraught with issues like how to deal with a cast:++    let join $j1 :: IO ()+             $j1 = ...+             $j2 :: Int -> IO ()+             $j2 n = if n > 0 then $j1+                              else ...++    =>++    let join $j1 :: IO ()+             $j1 = (\eta -> ...)+                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())+                                 ~  IO ()+             $j2 :: Int -> IO ()+             $j2 n = (\eta -> if n > 0 then $j1+                                       else ...)+                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())+                                 ~  IO ()++The cast here can't be pushed inside the lambda (since it's not casting to a+function type), so the lambda has to stay, but it can't because it contains a+reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather+than try and detect this situation (and whatever other situations crop up!), we+don't bother; again, any surrounding eta-expansion will improve these join+points anyway, since an outer cast can *always* be pushed inside. By the time+CorePrep comes around, the code is very likely to look more like this:++    let join $j1 :: State# RealWorld -> (# State# RealWorld, ())+             $j1 = (...) eta+             $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ())+             $j2 = if n > 0 then $j1+                            else (...) eta++Note [idArity for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because of Note [Do not eta-expand join points] we have it that the idArity+of a join point is always (less than or) equal to the join arity.+Essentially, for join points we set `idArity $j = count isId join_lam_bndrs`.+It really can be less if there are type-level binders in join_lam_bndrs.++Note [Do not eta-expand PAPs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to have old_arity = manifestArity rhs, which meant that we+would eta-expand even PAPs.  But this gives no particular advantage,+and can lead to a massive blow-up in code size, exhibited by #9020.+Suppose we have a PAP+    foo :: IO ()+    foo = returnIO ()+Then we can eta-expand do+    foo = (\eta. (returnIO () |> sym g) eta) |> g+where+    g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)++But there is really no point in doing this, and it generates masses of+coercions and whatnot that eventually disappear again. For T9020, GHC+allocated 6.6G beore, and 0.8G afterwards; and residency dropped from+1.8G to 45M.++But note that this won't eta-expand, say+  f = \g -> map g+Does it matter not eta-expanding such functions?  I'm not sure.  Perhaps+strictness analysis will have less to bite on?+++************************************************************************+*                                                                      *+\subsection{Floating lets out of big lambdas}+*                                                                      *+************************************************************************++Note [Floating and type abstraction]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+        x = /\a. C e1 e2+We'd like to float this to+        y1 = /\a. e1+        y2 = /\a. e2+        x  = /\a. C (y1 a) (y2 a)+for the usual reasons: we want to inline x rather vigorously.++You may think that this kind of thing is rare.  But in some programs it is+common.  For example, if you do closure conversion you might get:++        data a :-> b = forall e. (e -> a -> b) :$ e++        f_cc :: forall a. a :-> a+        f_cc = /\a. (\e. id a) :$ ()++Now we really want to inline that f_cc thing so that the+construction of the closure goes away.++So I have elaborated simplLazyBind to understand right-hand sides that look+like+        /\ a1..an. body++and treat them specially. The real work is done in SimplUtils.abstractFloats,+but there is quite a bit of plumbing in simplLazyBind as well.++The same transformation is good when there are lets in the body:++        /\abc -> let(rec) x = e in b+   ==>+        let(rec) x' = /\abc -> let x = x' a b c in e+        in+        /\abc -> let x = x' a b c in b++This is good because it can turn things like:++        let f = /\a -> letrec g = ... g ... in g+into+        letrec g' = /\a -> ... g' a ...+        in+        let f = /\ a -> g' a++which is better.  In effect, it means that big lambdas don't impede+let-floating.++This optimisation is CRUCIAL in eliminating the junk introduced by+desugaring mutually recursive definitions.  Don't eliminate it lightly!++[May 1999]  If we do this transformation *regardless* then we can+end up with some pretty silly stuff.  For example,++        let+            st = /\ s -> let { x1=r1 ; x2=r2 } in ...+        in ..+becomes+        let y1 = /\s -> r1+            y2 = /\s -> r2+            st = /\s -> ...[y1 s/x1, y2 s/x2]+        in ..++Unless the "..." is a WHNF there is really no point in doing this.+Indeed it can make things worse.  Suppose x1 is used strictly,+and is of the form++        x1* = case f y of { (a,b) -> e }++If we abstract this wrt the tyvar we then can't do the case inline+as we would normally do.++That's why the whole transformation is part of the same process that+floats let-bindings and constructor arguments out of RHSs.  In particular,+it is guarded by the doFloatFromRhs call in simplLazyBind.++Note [Which type variables to abstract over]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Abstract only over the type variables free in the rhs wrt which the+new binding is abstracted.  Note that++  * The naive approach of abstracting wrt the+    tyvars free in the Id's /type/ fails. Consider:+        /\ a b -> let t :: (a,b) = (e1, e2)+                      x :: a     = fst t+                  in ...+    Here, b isn't free in x's type, but we must nevertheless+    abstract wrt b as well, because t's type mentions b.+    Since t is floated too, we'd end up with the bogus:+         poly_t = /\ a b -> (e1, e2)+         poly_x = /\ a   -> fst (poly_t a *b*)++  * We must do closeOverKinds.  Example (#10934):+       f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ...+    Here we want to float 't', but we must remember to abstract over+    'k' as well, even though it is not explicitly mentioned in the RHS,+    otherwise we get+       t = /\ (f:k->*) (a:k). AccFailure @ (f a)+    which is obviously bogus.+-}++abstractFloats :: DynFlags -> TopLevelFlag -> [OutTyVar] -> SimplFloats+              -> OutExpr -> SimplM ([OutBind], OutExpr)+abstractFloats dflags top_lvl main_tvs floats body+  = ASSERT( notNull body_floats )+    ASSERT( isNilOL (sfJoinFloats floats) )+    do  { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats+        ; return (float_binds, CoreSubst.substExpr (text "abstract_floats1") subst body) }+  where+    is_top_lvl  = isTopLevel top_lvl+    main_tv_set = mkVarSet main_tvs+    body_floats = letFloatBinds (sfLetFloats floats)+    empty_subst = CoreSubst.mkEmptySubst (sfInScope floats)++    abstract :: CoreSubst.Subst -> OutBind -> SimplM (CoreSubst.Subst, OutBind)+    abstract subst (NonRec id rhs)+      = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id+           ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'+                 subst' = CoreSubst.extendIdSubst subst id poly_app+           ; return (subst', NonRec poly_id2 poly_rhs) }+      where+        rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs++        -- tvs_here: see Note [Which type variables to abstract over]+        tvs_here = scopedSort $+                   filter (`elemVarSet` main_tv_set) $+                   closeOverKindsList $+                   exprSomeFreeVarsList isTyVar rhs'++    abstract subst (Rec prs)+       = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids+            ; let subst' = CoreSubst.extendSubstList subst (ids `zip` poly_apps)+                  poly_pairs = [ mk_poly2 poly_id tvs_here rhs'+                               | (poly_id, rhs) <- poly_ids `zip` rhss+                               , let rhs' = CoreSubst.substExpr (text "abstract_floats")+                                                                subst' rhs ]+            ; return (subst', Rec poly_pairs) }+       where+         (ids,rhss) = unzip prs+                -- For a recursive group, it's a bit of a pain to work out the minimal+                -- set of tyvars over which to abstract:+                --      /\ a b c.  let x = ...a... in+                --                 letrec { p = ...x...q...+                --                          q = .....p...b... } in+                --                 ...+                -- Since 'x' is abstracted over 'a', the {p,q} group must be abstracted+                -- over 'a' (because x is replaced by (poly_x a)) as well as 'b'.+                -- Since it's a pain, we just use the whole set, which is always safe+                --+                -- If you ever want to be more selective, remember this bizarre case too:+                --      x::a = x+                -- Here, we must abstract 'x' over 'a'.+         tvs_here = scopedSort main_tvs++    mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr)+    mk_poly1 tvs_here var+      = do { uniq <- getUniqueM+           ; let  poly_name = setNameUnique (idName var) uniq           -- Keep same name+                  poly_ty   = mkInvForAllTys tvs_here (idType var) -- But new type of course+                  poly_id   = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in Id.hs+                              mkLocalIdOrCoVar poly_name poly_ty+           ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }+                -- In the olden days, it was crucial to copy the occInfo of the original var,+                -- because we were looking at occurrence-analysed but as yet unsimplified code!+                -- In particular, we mustn't lose the loop breakers.  BUT NOW we are looking+                -- at already simplified code, so it doesn't matter+                --+                -- It's even right to retain single-occurrence or dead-var info:+                -- Suppose we started with  /\a -> let x = E in B+                -- where x occurs once in B. Then we transform to:+                --      let x' = /\a -> E in /\a -> let x* = x' a in B+                -- where x* has an INLINE prag on it.  Now, once x* is inlined,+                -- the occurrences of x' will be just the occurrences originally+                -- pinned on x.++    mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr)+    mk_poly2 poly_id tvs_here rhs+      = (poly_id `setIdUnfolding` unf, poly_rhs)+      where+        poly_rhs = mkLams tvs_here rhs+        unf = mkUnfolding dflags InlineRhs is_top_lvl False poly_rhs++        -- We want the unfolding.  Consider+        --      let+        --            x = /\a. let y = ... in Just y+        --      in body+        -- Then we float the y-binding out (via abstractFloats and addPolyBind)+        -- but 'x' may well then be inlined in 'body' in which case we'd like the+        -- opportunity to inline 'y' too.++{-+Note [Abstract over coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the+type variable a.  Rather than sort this mess out, we simply bale out and abstract+wrt all the type variables if any of them are coercion variables.+++Historical note: if you use let-bindings instead of a substitution, beware of this:++                -- Suppose we start with:+                --+                --      x = /\ a -> let g = G in E+                --+                -- Then we'll float to get+                --+                --      x = let poly_g = /\ a -> G+                --          in /\ a -> let g = poly_g a in E+                --+                -- But now the occurrence analyser will see just one occurrence+                -- of poly_g, not inside a lambda, so the simplifier will+                -- PreInlineUnconditionally poly_g back into g!  Badk to square 1!+                -- (I used to think that the "don't inline lone occurrences" stuff+                --  would stop this happening, but since it's the *only* occurrence,+                --  PreInlineUnconditionally kicks in first!)+                --+                -- Solution: put an INLINE note on g's RHS, so that poly_g seems+                --           to appear many times.  (NB: mkInlineMe eliminates+                --           such notes on trivial RHSs, so do it manually.)++************************************************************************+*                                                                      *+                prepareAlts+*                                                                      *+************************************************************************++prepareAlts tries these things:++1.  Eliminate alternatives that cannot match, including the+    DEFAULT alternative.++2.  If the DEFAULT alternative can match only one possible constructor,+    then make that constructor explicit.+    e.g.+        case e of x { DEFAULT -> rhs }+     ===>+        case e of x { (a,b) -> rhs }+    where the type is a single constructor type.  This gives better code+    when rhs also scrutinises x or e.++3. Returns a list of the constructors that cannot holds in the+   DEFAULT alternative (if there is one)++Here "cannot match" includes knowledge from GADTs++It's a good idea to do this stuff before simplifying the alternatives, to+avoid simplifying alternatives we know can't happen, and to come up with+the list of constructors that are handled, to put into the IdInfo of the+case binder, for use when simplifying the alternatives.++Eliminating the default alternative in (1) isn't so obvious, but it can+happen:++data Colour = Red | Green | Blue++f x = case x of+        Red -> ..+        Green -> ..+        DEFAULT -> h x++h y = case y of+        Blue -> ..+        DEFAULT -> [ case y of ... ]++If we inline h into f, the default case of the inlined h can't happen.+If we don't notice this, we may end up filtering out *all* the cases+of the inner case y, which give us nowhere to go!+-}++prepareAlts :: OutExpr -> OutId -> [InAlt] -> SimplM ([AltCon], [InAlt])+-- The returned alternatives can be empty, none are possible+prepareAlts scrut case_bndr' alts+  | Just (tc, tys) <- splitTyConApp_maybe (varType case_bndr')+           -- Case binder is needed just for its type. Note that as an+           --   OutId, it has maximum information; this is important.+           --   Test simpl013 is an example+  = do { us <- getUniquesM+       ; let (idcs1, alts1)       = filterAlts tc tys imposs_cons alts+             (yes2,  alts2)       = refineDefaultAlt us tc tys idcs1 alts1+             (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2+             -- "idcs" stands for "impossible default data constructors"+             -- i.e. the constructors that can't match the default case+       ; when yes2 $ tick (FillInCaseDefault case_bndr')+       ; when yes3 $ tick (AltMerge case_bndr')+       ; return (idcs3, alts3) }++  | otherwise  -- Not a data type, so nothing interesting happens+  = return ([], alts)+  where+    imposs_cons = case scrut of+                    Var v -> otherCons (idUnfolding v)+                    _     -> []+++{-+************************************************************************+*                                                                      *+                mkCase+*                                                                      *+************************************************************************++mkCase tries these things++* Note [Nerge nested cases]+* Note [Eliminate identity case]+* Note [Scrutinee constant folding]++Note [Merge Nested Cases]+~~~~~~~~~~~~~~~~~~~~~~~~~+       case e of b {             ==>   case e of b {+         p1 -> rhs1                      p1 -> rhs1+         ...                             ...+         pm -> rhsm                      pm -> rhsm+         _  -> case b of b' {            pn -> let b'=b in rhsn+                     pn -> rhsn          ...+                     ...                 po -> let b'=b in rhso+                     po -> rhso          _  -> let b'=b in rhsd+                     _  -> rhsd+       }++which merges two cases in one case when -- the default alternative of+the outer case scrutises the same variable as the outer case. This+transformation is called Case Merging.  It avoids that the same+variable is scrutinised multiple times.++Note [Eliminate Identity Case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        case e of               ===> e+                True  -> True;+                False -> False++and similar friends.++Note [Scrutinee Constant Folding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+     case x op# k# of _ {  ===> case x of _ {+        a1# -> e1                  (a1# inv_op# k#) -> e1+        a2# -> e2                  (a2# inv_op# k#) -> e2+        ...                        ...+        DEFAULT -> ed              DEFAULT -> ed++     where (x op# k#) inv_op# k# == x++And similarly for commuted arguments and for some unary operations.++The purpose of this transformation is not only to avoid an arithmetic+operation at runtime but to allow other transformations to apply in cascade.++Example with the "Merge Nested Cases" optimization (from #12877):++      main = case t of t0+         0##     -> ...+         DEFAULT -> case t0 `minusWord#` 1## of t1+            0##    -> ...+            DEFAUT -> case t1 `minusWord#` 1## of t2+               0##     -> ...+               DEFAULT -> case t2 `minusWord#` 1## of _+                  0##     -> ...+                  DEFAULT -> ...++  becomes:++      main = case t of _+      0##     -> ...+      1##     -> ...+      2##     -> ...+      3##     -> ...+      DEFAULT -> ...++There are some wrinkles++* Do not apply caseRules if there is just a single DEFAULT alternative+     case e +# 3# of b { DEFAULT -> rhs }+  If we applied the transformation here we would (stupidly) get+     case a of b' { DEFAULT -> let b = e +# 3# in rhs }+  and now the process may repeat, because that let will really+  be a case.++* The type of the scrutinee might change.  E.g.+        case tagToEnum (x :: Int#) of (b::Bool)+          False -> e1+          True -> e2+  ==>+        case x of (b'::Int#)+          DEFAULT -> e1+          1#      -> e2++* The case binder may be used in the right hand sides, so we need+  to make a local binding for it, if it is alive.  e.g.+         case e +# 10# of b+           DEFAULT -> blah...b...+           44#     -> blah2...b...+  ===>+         case e of b'+           DEFAULT -> let b = b' +# 10# in blah...b...+           34#     -> let b = 44# in blah2...b...++  Note that in the non-DEFAULT cases we know what to bind 'b' to,+  whereas in the DEFAULT case we must reconstruct the original value.+  But NB: we use b'; we do not duplicate 'e'.++* In dataToTag we might need to make up some fake binders;+  see Note [caseRules for dataToTag] in PrelRules+-}++mkCase, mkCase1, mkCase2, mkCase3+   :: DynFlags+   -> OutExpr -> OutId+   -> OutType -> [OutAlt]               -- Alternatives in standard (increasing) order+   -> SimplM OutExpr++--------------------------------------------------+--      1. Merge Nested Cases+--------------------------------------------------++mkCase dflags scrut outer_bndr alts_ty ((DEFAULT, _, deflt_rhs) : outer_alts)+  | gopt Opt_CaseMerge dflags+  , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts)+       <- stripTicksTop tickishFloatable deflt_rhs+  , inner_scrut_var == outer_bndr+  = do  { tick (CaseMerge outer_bndr)++        ; let wrap_alt (con, args, rhs) = ASSERT( outer_bndr `notElem` args )+                                          (con, args, wrap_rhs rhs)+                -- Simplifier's no-shadowing invariant should ensure+                -- that outer_bndr is not shadowed by the inner patterns+              wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs+                -- The let is OK even for unboxed binders,++              wrapped_alts | isDeadBinder inner_bndr = inner_alts+                           | otherwise               = map wrap_alt inner_alts++              merged_alts = mergeAlts outer_alts wrapped_alts+                -- NB: mergeAlts gives priority to the left+                --      case x of+                --        A -> e1+                --        DEFAULT -> case x of+                --                      A -> e2+                --                      B -> e3+                -- When we merge, we must ensure that e1 takes+                -- precedence over e2 as the value for A!++        ; fmap (mkTicks ticks) $+          mkCase1 dflags scrut outer_bndr alts_ty merged_alts+        }+        -- Warning: don't call mkCase recursively!+        -- Firstly, there's no point, because inner alts have already had+        -- mkCase applied to them, so they won't have a case in their default+        -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr+        -- in munge_rhs may put a case into the DEFAULT branch!++mkCase dflags scrut bndr alts_ty alts = mkCase1 dflags scrut bndr alts_ty alts++--------------------------------------------------+--      2. Eliminate Identity Case+--------------------------------------------------++mkCase1 _dflags scrut case_bndr _ alts@((_,_,rhs1) : _)      -- Identity case+  | all identity_alt alts+  = do { tick (CaseIdentity case_bndr)+       ; return (mkTicks ticks $ re_cast scrut rhs1) }+  where+    ticks = concatMap (stripTicksT tickishFloatable . thdOf3) (tail alts)+    identity_alt (con, args, rhs) = check_eq rhs con args++    check_eq (Cast rhs co) con args        -- See Note [RHS casts]+      = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args+    check_eq (Tick t e) alt args+      = tickishFloatable t && check_eq e alt args++    check_eq (Lit lit) (LitAlt lit') _     = lit == lit'+    check_eq (Var v) _ _  | v == case_bndr = True+    check_eq (Var v)   (DataAlt con) args+      | null arg_tys, null args            = v == dataConWorkId con+                                             -- Optimisation only+    check_eq rhs        (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $+                                             mkConApp2 con arg_tys args+    check_eq _          _             _    = False++    arg_tys = tyConAppArgs (idType case_bndr)++        -- Note [RHS casts]+        -- ~~~~~~~~~~~~~~~~+        -- We've seen this:+        --      case e of x { _ -> x `cast` c }+        -- And we definitely want to eliminate this case, to give+        --      e `cast` c+        -- So we throw away the cast from the RHS, and reconstruct+        -- it at the other end.  All the RHS casts must be the same+        -- if (all identity_alt alts) holds.+        --+        -- Don't worry about nested casts, because the simplifier combines them++    re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co+    re_cast scrut _             = scrut++mkCase1 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts++--------------------------------------------------+--      2. Scrutinee Constant Folding+--------------------------------------------------++mkCase2 dflags scrut bndr alts_ty alts+  | -- See Note [Scrutinee Constant Folding]+    case alts of  -- Not if there is just a DEFAULT alternative+      [(DEFAULT,_,_)] -> False+      _               -> True+  , gopt Opt_CaseFolding dflags+  , Just (scrut', tx_con, mk_orig) <- caseRules dflags scrut+  = do { bndr' <- newId (fsLit "lwild") (exprType scrut')++       ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts+                  -- mapMaybeM: discard unreachable alternatives+                  -- See Note [Unreachable caseRules alternatives]+                  -- in PrelRules++       ; mkCase3 dflags scrut' bndr' alts_ty $+         add_default (re_sort alts')+       }++  | otherwise+  = mkCase3 dflags scrut bndr alts_ty alts+  where+    -- We need to keep the correct association between the scrutinee and its+    -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with+    -- "let bndr = ... in":+    --+    --     case v + 10 of y        =====> case v of y+    --        20      -> e1                 10      -> let y = 20     in e1+    --        DEFAULT -> e2                 DEFAULT -> let y = v + 10 in e2+    --+    -- Other transformations give: =====> case v of y'+    --                                      10      -> let y = 20      in e1+    --                                      DEFAULT -> let y = y' + 10 in e2+    --+    -- This wrapping is done in tx_alt; we use mk_orig, returned by caseRules,+    -- to construct an expression equivalent to the original one, for use+    -- in the DEFAULT case++    tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id+           -> CoreAlt -> SimplM (Maybe CoreAlt)+    tx_alt tx_con mk_orig new_bndr (con, bs, rhs)+      = case tx_con con of+          Nothing   -> return Nothing+          Just con' -> do { bs' <- mk_new_bndrs new_bndr con'+                          ; return (Just (con', bs', rhs')) }+      where+        rhs' | isDeadBinder bndr = rhs+             | otherwise         = bindNonRec bndr orig_val rhs++        orig_val = case con of+                      DEFAULT    -> mk_orig new_bndr+                      LitAlt l   -> Lit l+                      DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs++    mk_new_bndrs new_bndr (DataAlt dc)+      | not (isNullaryRepDataCon dc)+      = -- For non-nullary data cons we must invent some fake binders+        -- See Note [caseRules for dataToTag] in PrelRules+        do { us <- getUniquesM+           ; let (ex_tvs, arg_ids) = dataConRepInstPat us dc+                                        (tyConAppArgs (idType new_bndr))+           ; return (ex_tvs ++ arg_ids) }+    mk_new_bndrs _ _ = return []++    re_sort :: [CoreAlt] -> [CoreAlt]  -- Re-sort the alternatives to+    re_sort alts = sortBy cmpAlt alts  -- preserve the #case_invariants#++    add_default :: [CoreAlt] -> [CoreAlt]+    -- See Note [Literal cases]+    add_default ((LitAlt {}, bs, rhs) : alts) = (DEFAULT, bs, rhs) : alts+    add_default alts                          = alts++{- Note [Literal cases]+~~~~~~~~~~~~~~~~~~~~~~~+If we have+  case tagToEnum (a ># b) of+     False -> e1+     True  -> e2++then caseRules for TagToEnum will turn it into+  case tagToEnum (a ># b) of+     0# -> e1+     1# -> e2++Since the case is exhaustive (all cases are) we can convert it to+  case tagToEnum (a ># b) of+     DEFAULT -> e1+     1#      -> e2++This may generate sligthtly better code (although it should not, since+all cases are exhaustive) and/or optimise better.  I'm not certain that+it's necessary, but currenty we do make this change.  We do it here,+NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum]+in PrelRules)+-}++--------------------------------------------------+--      Catch-all+--------------------------------------------------+mkCase3 _dflags scrut bndr alts_ty alts+  = return (Case scrut bndr alts_ty alts)++-- See Note [Exitification] and Note [Do not inline exit join points] in Exitify.hs+-- This lives here (and not in Id) because occurrence info is only valid on+-- InIds, so it's crucial that isExitJoinId is only called on freshly+-- occ-analysed code. It's not a generic function you can call anywhere.+isExitJoinId :: Var -> Bool+isExitJoinId id = isJoinId id && isOneOcc (idOccInfo id) && occ_in_lam (idOccInfo id)++{-+Note [Dead binders]+~~~~~~~~~~~~~~~~~~~~+Note that dead-ness is maintained by the simplifier, so that it is+accurate after simplification as well as before.+++Note [Cascading case merge]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Case merging should cascade in one sweep, because it+happens bottom-up++      case e of a {+        DEFAULT -> case a of b+                      DEFAULT -> case b of c {+                                     DEFAULT -> e+                                     A -> ea+                      B -> eb+        C -> ec+==>+      case e of a {+        DEFAULT -> case a of b+                      DEFAULT -> let c = b in e+                      A -> let c = b in ea+                      B -> eb+        C -> ec+==>+      case e of a {+        DEFAULT -> let b = a in let c = b in e+        A -> let b = a in let c = b in ea+        B -> let b = a in eb+        C -> ec+++However here's a tricky case that we still don't catch, and I don't+see how to catch it in one pass:++  case x of c1 { I# a1 ->+  case a1 of c2 ->+    0 -> ...+    DEFAULT -> case x of c3 { I# a2 ->+               case a2 of ...++After occurrence analysis (and its binder-swap) we get this++  case x of c1 { I# a1 ->+  let x = c1 in         -- Binder-swap addition+  case a1 of c2 ->+    0 -> ...+    DEFAULT -> case x of c3 { I# a2 ->+               case a2 of ...++When we simplify the inner case x, we'll see that+x=c1=I# a1.  So we'll bind a2 to a1, and get++  case x of c1 { I# a1 ->+  case a1 of c2 ->+    0 -> ...+    DEFAULT -> case a1 of ...++This is corect, but we can't do a case merge in this sweep+because c2 /= a1.  Reason: the binding c1=I# a1 went inwards+without getting changed to c1=I# c2.++I don't think this is worth fixing, even if I knew how. It'll+all come out in the next pass anyway.+-}
+ compiler/simplCore/Simplify.hs view
@@ -0,0 +1,3602 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section[Simplify]{The main module of the simplifier}+-}++{-# LANGUAGE CPP #-}++module Simplify ( simplTopBinds, simplExpr, simplRules ) where++#include "HsVersions.h"++import GhcPrelude++import DynFlags+import SimplMonad+import Type hiding      ( substTy, substTyVar, extendTvSubst, extendCvSubst )+import SimplEnv+import SimplUtils+import OccurAnal        ( occurAnalyseExpr )+import FamInstEnv       ( FamInstEnv )+import Literal          ( litIsLifted ) --, mkLitInt ) -- temporalily commented out. See #8326+import Id+import MkId             ( seqId )+import MkCore           ( FloatBind, mkImpossibleExpr, castBottomExpr )+import qualified MkCore as MkCore+import IdInfo+import Name             ( mkSystemVarName, isExternalName, getOccFS )+import Coercion hiding  ( substCo, substCoVar )+import OptCoercion      ( optCoercion )+import FamInstEnv       ( topNormaliseType_maybe )+import DataCon          ( DataCon, dataConWorkId, dataConRepStrictness+                        , dataConRepArgTys, isUnboxedTupleCon+                        , StrictnessMark (..) )+import CoreMonad        ( Tick(..), SimplMode(..) )+import CoreSyn+import Demand           ( StrictSig(..), 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 BasicTypes       ( TopLevelFlag(..), isNotTopLevel, isTopLevel,+                          RecFlag(..), Arity )+import MonadUtils       ( mapAccumLM, liftIO )+import Var              ( isTyCoVar )+import Maybes           (  orElse )+import Control.Monad+import Outputable+import FastString+import Pair+import Util+import ErrUtils+import Module          ( moduleName, pprModuleName )+import PrimOp          ( PrimOp (SeqOp) )+++{-+The guts of the simplifier is in this module, but the driver loop for+the simplifier is in SimplCore.hs.++Note [The big picture]+~~~~~~~~~~~~~~~~~~~~~~+The general shape of the simplifier is this:++  simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)+  simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)++ * SimplEnv contains+     - Simplifier mode (which includes DynFlags for convenience)+     - Ambient substitution+     - InScopeSet++ * SimplFloats contains+     - Let-floats (which includes ok-for-spec case-floats)+     - Join floats+     - InScopeSet (including all the floats)++ * Expressions+      simplExpr :: SimplEnv -> InExpr -> SimplCont+                -> SimplM (SimplFloats, OutExpr)+   The result of simplifying an /expression/ is (floats, expr)+      - A bunch of floats (let bindings, join bindings)+      - A simplified expression.+   The overall result is effectively (let floats in expr)++ * Bindings+      simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)+   The result of simplifying a binding is+     - A bunch of floats, the last of which is the simplified binding+       There may be auxiliary bindings too; see prepareRhs+     - An environment suitable for simplifying the scope of the binding++   The floats may also be empty, if the binding is inlined unconditionally;+   in that case the returned SimplEnv will have an augmented substitution.++   The returned floats and env both have an in-scope set, and they are+   guaranteed to be the same.+++Note [Shadowing]+~~~~~~~~~~~~~~~~+The simplifier used to guarantee that the output had no shadowing, but+it does not do so any more.   (Actually, it never did!)  The reason is+documented with simplifyArgs.+++Eta expansion+~~~~~~~~~~~~~~+For eta expansion, we want to catch things like++        case e of (a,b) -> \x -> case a of (p,q) -> \y -> r++If the \x was on the RHS of a let, we'd eta expand to bring the two+lambdas together.  And in general that's a good thing to do.  Perhaps+we should eta expand wherever we find a (value) lambda?  Then the eta+expansion at a let RHS can concentrate solely on the PAP case.++************************************************************************+*                                                                      *+\subsection{Bindings}+*                                                                      *+************************************************************************+-}++simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)+-- See Note [The big picture]+simplTopBinds env0 binds0+  = do  {       -- Put all the top-level binders into scope at the start+                -- so that if a transformation rule has unexpectedly brought+                -- anything into scope, then we don't get a complaint about that.+                -- It's rather as if the top-level binders were imported.+                -- See note [Glomming] in OccurAnal.+        ; env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)+        ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0+        ; freeTick SimplifierDone+        ; return (floats, env2) }+  where+        -- We need to track the zapped top-level binders, because+        -- they should have their fragile IdInfo zapped (notably occurrence info)+        -- That's why we run down binds and bndrs' simultaneously.+        --+    simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)+    simpl_binds env []           = return (emptyFloats env, env)+    simpl_binds env (bind:binds) = do { (float,  env1) <- simpl_bind env bind+                                      ; (floats, env2) <- simpl_binds env1 binds+                                      ; return (float `addFloats` floats, env2) }++    simpl_bind env (Rec pairs)+      = simplRecBind env TopLevel Nothing pairs+    simpl_bind env (NonRec b r)+      = do { (env', b') <- addBndrRules env b (lookupRecBndr env b) Nothing+           ; simplRecOrTopPair env' TopLevel NonRecursive Nothing b b' r }++{-+************************************************************************+*                                                                      *+        Lazy bindings+*                                                                      *+************************************************************************++simplRecBind is used for+        * recursive bindings only+-}++simplRecBind :: SimplEnv -> TopLevelFlag -> MaybeJoinCont+             -> [(InId, InExpr)]+             -> SimplM (SimplFloats, SimplEnv)+simplRecBind env0 top_lvl mb_cont pairs0+  = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0+        ; (rec_floats, env1) <- go env_with_info triples+        ; return (mkRecFloats rec_floats, env1) }+  where+    add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))+        -- Add the (substituted) rules to the binder+    add_rules env (bndr, rhs)+        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) mb_cont+             ; return (env', (bndr, bndr', rhs)) }++    go env [] = return (emptyFloats env, env)++    go env ((old_bndr, new_bndr, rhs) : pairs)+        = do { (float, env1) <- simplRecOrTopPair env top_lvl Recursive mb_cont+                                                  old_bndr new_bndr rhs+             ; (floats, env2) <- go env1 pairs+             ; return (float `addFloats` floats, env2) }++{-+simplOrTopPair is used for+        * recursive bindings (whether top level or not)+        * top-level non-recursive bindings++It assumes the binder has already been simplified, but not its IdInfo.+-}++simplRecOrTopPair :: SimplEnv+                  -> TopLevelFlag -> RecFlag -> MaybeJoinCont+                  -> InId -> OutBndr -> InExpr  -- Binder and rhs+                  -> SimplM (SimplFloats, SimplEnv)++simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs+  | Just env' <- preInlineUnconditionally env top_lvl old_bndr rhs env+  = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}+    trace_bind "pre-inline-uncond" $+    do { tick (PreInlineUnconditionally old_bndr)+       ; return ( emptyFloats env, env' ) }++  | Just cont <- mb_cont+  = {-#SCC "simplRecOrTopPair-join" #-}+    ASSERT( isNotTopLevel top_lvl && isJoinId new_bndr )+    trace_bind "join" $+    simplJoinBind env cont old_bndr new_bndr rhs env++  | otherwise+  = {-#SCC "simplRecOrTopPair-normal" #-}+    trace_bind "normal" $+    simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env++  where+    dflags = seDynFlags env++    -- trace_bind emits a trace for each top-level binding, which+    -- helps to locate the tracing for inlining and rule firing+    trace_bind what thing_inside+      | not (dopt Opt_D_verbose_core2core dflags)+      = thing_inside+      | otherwise+      = pprTrace ("SimplBind " ++ what) (ppr old_bndr) thing_inside++--------------------------+simplLazyBind :: SimplEnv+              -> TopLevelFlag -> RecFlag+              -> InId -> OutId          -- Binder, both pre-and post simpl+                                        -- Not a JoinId+                                        -- The OutId has IdInfo, except arity, unfolding+                                        -- Ids only, no TyVars+              -> InExpr -> SimplEnv     -- The RHS and its environment+              -> SimplM (SimplFloats, SimplEnv)+-- Precondition: not a JoinId+-- Precondition: rhs obeys the let/app invariant+-- NOT used for JoinIds+simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se+  = ASSERT( isId bndr )+    ASSERT2( not (isJoinId bndr), ppr bndr )+    -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $+    do  { let   rhs_env     = rhs_se `setInScopeFromE` env+                (tvs, body) = case collectTyAndValBinders rhs of+                                (tvs, [], body)+                                  | surely_not_lam body -> (tvs, body)+                                _                       -> ([], rhs)++                surely_not_lam (Lam {})     = False+                surely_not_lam (Tick t e)+                  | not (tickishFloatable t) = surely_not_lam e+                   -- eta-reduction could float+                surely_not_lam _            = True+                        -- Do not do the "abstract tyvar" thing if there's+                        -- a lambda inside, because it defeats eta-reduction+                        --    f = /\a. \x. g a x+                        -- should eta-reduce.+++        ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs+                -- See Note [Floating and type abstraction] in SimplUtils++        -- Simplify the RHS+        ; let rhs_cont = mkRhsStop (substTy body_env (exprType body))+        ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont++              -- Never float join-floats out of a non-join let-binding+              -- So wrap the body in the join-floats right now+              -- Hence: body_floats1 consists only of let-floats+        ; let (body_floats1, body1) = wrapJoinFloatsX body_floats0 body0++        -- ANF-ise a constructor or PAP rhs+        -- We get at most one float per argument here+        ; (let_floats, body2) <- {-#SCC "prepareRhs" #-} prepareRhs (getMode env) top_lvl+                                            (getOccFS bndr1) (idInfo bndr1) body1+        ; let body_floats2 = body_floats1 `addLetFloats` let_floats++        ; (rhs_floats, rhs')+            <-  if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2)+                then                    -- No floating, revert to body1+                     {-#SCC "simplLazyBind-no-floating" #-}+                     do { rhs' <- mkLam env tvs' (wrapFloats body_floats2 body1) rhs_cont+                        ; return (emptyFloats env, rhs') }++                else if null tvs then   -- Simple floating+                     {-#SCC "simplLazyBind-simple-floating" #-}+                     do { tick LetFloatFromLet+                        ; return (body_floats2, body2) }++                else                    -- Do type-abstraction first+                     {-#SCC "simplLazyBind-type-abstraction-first" #-}+                     do { tick LetFloatFromLet+                        ; (poly_binds, body3) <- abstractFloats (seDynFlags env) top_lvl+                                                                tvs' body_floats2 body2+                        ; let floats = foldl' extendFloats (emptyFloats env) poly_binds+                        ; rhs' <- mkLam env tvs' body3 rhs_cont+                        ; return (floats, rhs') }++        ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)+                                             top_lvl Nothing bndr bndr1 rhs'+        ; return (rhs_floats `addFloats` bind_float, env2) }++--------------------------+simplJoinBind :: SimplEnv+              -> SimplCont+              -> InId -> OutId          -- Binder, both pre-and post simpl+                                        -- The OutId has IdInfo, except arity,+                                        --   unfolding+              -> InExpr -> SimplEnv     -- The right hand side and its env+              -> SimplM (SimplFloats, SimplEnv)+simplJoinBind env cont old_bndr new_bndr rhs rhs_se+  = do  { let rhs_env = rhs_se `setInScopeFromE` env+        ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont+        ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr rhs' }++--------------------------+simplNonRecX :: SimplEnv+             -> InId            -- Old binder; not a JoinId+             -> OutExpr         -- Simplified RHS+             -> SimplM (SimplFloats, SimplEnv)+-- A specialised variant of simplNonRec used when the RHS is already+-- simplified, notably in knownCon.  It uses case-binding where necessary.+--+-- Precondition: rhs satisfies the let/app invariant++simplNonRecX env bndr new_rhs+  | ASSERT2( not (isJoinId bndr), ppr bndr )+    isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }+  = return (emptyFloats env, env)    --  Here c is dead, and we avoid+                                         --  creating the binding c = (a,b)++  | Coercion co <- new_rhs+  = return (emptyFloats env, extendCvSubst env bndr co)++  | otherwise+  = do  { (env', bndr') <- simplBinder env bndr+        ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs }+                -- simplNonRecX is only used for NotTopLevel things++--------------------------+completeNonRecX :: TopLevelFlag -> SimplEnv+                -> Bool+                -> InId                 -- Old binder; not a JoinId+                -> OutId                -- New binder+                -> OutExpr              -- Simplified RHS+                -> SimplM (SimplFloats, SimplEnv)    -- The new binding is in the floats+-- Precondition: rhs satisfies the let/app invariant+--               See Note [CoreSyn let/app invariant] in CoreSyn++completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs+  = ASSERT2( not (isJoinId new_bndr), ppr new_bndr )+    do  { (prepd_floats, rhs1) <- prepareRhs (getMode env) top_lvl (getOccFS new_bndr)+                                             (idInfo new_bndr) new_rhs+        ; let floats = emptyFloats env `addLetFloats` prepd_floats+        ; (rhs_floats, rhs2) <-+                if doFloatFromRhs NotTopLevel NonRecursive is_strict floats rhs1+                then    -- Add the floats to the main env+                     do { tick LetFloatFromLet+                        ; return (floats, rhs1) }+                else    -- Do not float; wrap the floats around the RHS+                     return (emptyFloats env, wrapFloats floats rhs1)++        ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)+                                             NotTopLevel Nothing+                                             old_bndr new_bndr rhs2+        ; return (rhs_floats `addFloats` bind_float, env2) }+++{- *********************************************************************+*                                                                      *+           prepareRhs, makeTrivial+*                                                                      *+************************************************************************++Note [prepareRhs]+~~~~~~~~~~~~~~~~~+prepareRhs takes a putative RHS, checks whether it's a PAP or+constructor application and, if so, converts it to ANF, so that the+resulting thing can be inlined more easily.  Thus+        x = (f a, g b)+becomes+        t1 = f a+        t2 = g b+        x = (t1,t2)++We also want to deal well cases like this+        v = (f e1 `cast` co) e2+Here we want to make e1,e2 trivial and get+        x1 = e1; x2 = e2; v = (f x1 `cast` co) v2+That's what the 'go' loop in prepareRhs does+-}++prepareRhs :: SimplMode -> TopLevelFlag+           -> FastString   -- Base for any new variables+           -> IdInfo       -- IdInfo for the LHS of this binding+           -> OutExpr+           -> SimplM (LetFloats, OutExpr)+-- Transforms a RHS into a better RHS by adding floats+-- e.g        x = Just e+-- becomes    a = e+--            x = Just a+-- See Note [prepareRhs]+prepareRhs mode top_lvl occ info (Cast rhs co)  -- Note [Float coercions]+  | Pair ty1 _ty2 <- coercionKind co         -- Do *not* do this if rhs has an unlifted type+  , not (isUnliftedType ty1)                 -- see Note [Float coercions (unlifted)]+  = do  { (floats, rhs') <- makeTrivialWithInfo mode top_lvl occ sanitised_info rhs+        ; return (floats, Cast rhs' co) }+  where+    sanitised_info = vanillaIdInfo `setStrictnessInfo` strictnessInfo info+                                   `setDemandInfo`     demandInfo info++prepareRhs mode top_lvl occ _ rhs0+  = do  { (_is_exp, floats, rhs1) <- go 0 rhs0+        ; return (floats, rhs1) }+  where+    go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)+    go n_val_args (Cast rhs co)+        = do { (is_exp, floats, rhs') <- go n_val_args rhs+             ; return (is_exp, floats, Cast rhs' co) }+    go n_val_args (App fun (Type ty))+        = do { (is_exp, floats, rhs') <- go n_val_args fun+             ; return (is_exp, floats, App rhs' (Type ty)) }+    go n_val_args (App fun arg)+        = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun+             ; case is_exp of+                False -> return (False, emptyLetFloats, App fun arg)+                True  -> do { (floats2, arg') <- makeTrivial mode top_lvl occ arg+                            ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } }+    go n_val_args (Var fun)+        = return (is_exp, emptyLetFloats, Var fun)+        where+          is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP+                        -- See Note [CONLIKE pragma] in BasicTypes+                        -- The definition of is_exp should match that in+                        -- OccurAnal.occAnalApp++    go n_val_args (Tick t rhs)+        -- We want to be able to float bindings past this+        -- tick. Non-scoping ticks don't care.+        | tickishScoped t == NoScope+        = do { (is_exp, floats, rhs') <- go n_val_args rhs+             ; return (is_exp, floats, Tick t rhs') }++        -- On the other hand, for scoping ticks we need to be able to+        -- copy them on the floats, which in turn is only allowed if+        -- we can obtain non-counting ticks.+        | (not (tickishCounts t) || tickishCanSplit t)+        = do { (is_exp, floats, rhs') <- go n_val_args rhs+             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)+                   floats' = mapLetFloats floats tickIt+             ; return (is_exp, floats', Tick t rhs') }++    go _ other+        = return (False, emptyLetFloats, other)++{-+Note [Float coercions]+~~~~~~~~~~~~~~~~~~~~~~+When we find the binding+        x = e `cast` co+we'd like to transform it to+        x' = e+        x = x `cast` co         -- A trivial binding+There's a chance that e will be a constructor application or function, or something+like that, so moving the coercion to the usage site may well cancel the coercions+and lead to further optimisation.  Example:++     data family T a :: *+     data instance T Int = T Int++     foo :: Int -> Int -> Int+     foo m n = ...+        where+          x = T m+          go 0 = 0+          go n = case x of { T m -> go (n-m) }+                -- This case should optimise++Note [Preserve strictness when floating coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the Note [Float coercions] transformation, keep the strictness info.+Eg+        f = e `cast` co    -- f has strictness SSL+When we transform to+        f' = e             -- f' also has strictness SSL+        f = f' `cast` co   -- f still has strictness SSL++Its not wrong to drop it on the floor, but better to keep it.++Note [Float coercions (unlifted)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+BUT don't do [Float coercions] if 'e' has an unlifted type.+This *can* happen:++     foo :: Int = (error (# Int,Int #) "urk")+                  `cast` CoUnsafe (# Int,Int #) Int++If do the makeTrivial thing to the error call, we'll get+    foo = case error (# Int,Int #) "urk" of v -> v `cast` ...+But 'v' isn't in scope!++These strange casts can happen as a result of case-of-case+        bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of+                (# p,q #) -> p+q+-}++makeTrivialArg :: SimplMode -> ArgSpec -> SimplM (LetFloats, ArgSpec)+makeTrivialArg mode (ValArg e)+  = do { (floats, e') <- makeTrivial mode NotTopLevel (fsLit "arg") e+       ; return (floats, ValArg e') }+makeTrivialArg _ arg+  = return (emptyLetFloats, arg)  -- CastBy, TyArg++makeTrivial :: SimplMode -> TopLevelFlag+            -> FastString  -- ^ A "friendly name" to build the new binder from+            -> OutExpr     -- ^ This expression satisfies the let/app invariant+            -> SimplM (LetFloats, OutExpr)+-- Binds the expression to a variable, if it's not trivial, returning the variable+makeTrivial mode top_lvl context expr+ = makeTrivialWithInfo mode top_lvl context vanillaIdInfo expr++makeTrivialWithInfo :: SimplMode -> TopLevelFlag+                    -> FastString  -- ^ a "friendly name" to build the new binder from+                    -> IdInfo+                    -> OutExpr     -- ^ This expression satisfies the let/app invariant+                    -> SimplM (LetFloats, OutExpr)+-- Propagate strictness and demand info to the new binder+-- Note [Preserve strictness when floating coercions]+-- Returned SimplEnv has same substitution as incoming one+makeTrivialWithInfo mode top_lvl occ_fs info expr+  | exprIsTrivial expr                          -- Already trivial+  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise+                                                --   See Note [Cannot trivialise]+  = return (emptyLetFloats, expr)++  | otherwise+  = do  { (floats, expr1) <- prepareRhs mode top_lvl occ_fs info expr+        ; if   exprIsTrivial expr1  -- See Note [Trivial after prepareRhs]+          then return (floats, expr1)+          else do+        { uniq <- getUniqueM+        ; let name = mkSystemVarName uniq occ_fs+              var  = mkLocalIdOrCoVarWithInfo name expr_ty info++        -- Now something very like completeBind,+        -- but without the postInlineUnconditinoally part+        ; (arity, is_bot, expr2) <- tryEtaExpandRhs mode var expr1+        ; unf <- mkLetUnfolding (sm_dflags mode) top_lvl InlineRhs var expr2++        ; let final_id = addLetBndrInfo var arity is_bot unf+              bind     = NonRec final_id expr2++        ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) }}+   where+     expr_ty = exprType expr++bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool+-- True iff we can have a binding of this expression at this level+-- Precondition: the type is the type of the expression+bindingOk top_lvl expr expr_ty+  | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty+  | otherwise          = True++{- Note [Trivial after prepareRhs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we call makeTrival on (e |> co), the recursive use of prepareRhs+may leave us with+   { a1 = e }  and   (a1 |> co)+Now the latter is trivial, so we don't want to let-bind it.++Note [Cannot trivialise]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+   f :: Int -> Addr#++   foo :: Bar+   foo = Bar (f 3)++Then we can't ANF-ise foo, even though we'd like to, because+we can't make a top-level binding for the Addr# (f 3). And if+so we don't want to turn it into+   foo = let x = f 3 in Bar x+because we'll just end up inlining x back, and that makes the+simplifier loop.  Better not to ANF-ise it at all.++Literal strings are an exception.++   foo = Ptr "blob"#++We want to turn this into:++   foo1 = "blob"#+   foo = Ptr foo1++See Note [CoreSyn top-level string literals] in CoreSyn.++************************************************************************+*                                                                      *+          Completing a lazy binding+*                                                                      *+************************************************************************++completeBind+  * deals only with Ids, not TyVars+  * takes an already-simplified binder and RHS+  * is used for both recursive and non-recursive bindings+  * is used for both top-level and non-top-level bindings++It does the following:+  - tries discarding a dead binding+  - tries PostInlineUnconditionally+  - add unfolding [this is the only place we add an unfolding]+  - add arity++It does *not* attempt to do let-to-case.  Why?  Because it is used for+  - top-level bindings (when let-to-case is impossible)+  - many situations where the "rhs" is known to be a WHNF+                (so let-to-case is inappropriate).++Nor does it do the atomic-argument thing+-}++completeBind :: SimplEnv+             -> TopLevelFlag            -- Flag stuck into unfolding+             -> MaybeJoinCont           -- Required only for join point+             -> InId                    -- Old binder+             -> OutId -> OutExpr        -- New binder and RHS+             -> SimplM (SimplFloats, SimplEnv)+-- completeBind may choose to do its work+--      * by extending the substitution (e.g. let x = y in ...)+--      * or by adding to the floats in the envt+--+-- Binder /can/ be a JoinId+-- Precondition: rhs obeys the let/app invariant+completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs+ | isCoVar old_bndr+ = case new_rhs of+     Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)+     _           -> return (mkFloatBind env (NonRec new_bndr new_rhs))++ | otherwise+ = ASSERT( isId new_bndr )+   do { let old_info = idInfo old_bndr+            old_unf  = unfoldingInfo old_info+            occ_info = occInfo old_info++         -- Do eta-expansion on the RHS of the binding+         -- See Note [Eta-expanding at let bindings] in SimplUtils+      ; (new_arity, is_bot, final_rhs) <- tryEtaExpandRhs (getMode env)+                                                          new_bndr new_rhs++        -- Simplify the unfolding+      ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr+                                           final_rhs (idType new_bndr) old_unf++      ; let final_bndr = addLetBndrInfo new_bndr new_arity is_bot new_unfolding++      ; if postInlineUnconditionally env top_lvl final_bndr occ_info final_rhs++        then -- Inline and discard the binding+             do  { tick (PostInlineUnconditionally old_bndr)+                 ; return ( emptyFloats env+                          , extendIdSubst env old_bndr $+                            DoneEx final_rhs (isJoinId_maybe new_bndr)) }+                -- Use the substitution to make quite, quite sure that the+                -- substitution will happen, since we are going to discard the binding++        else -- Keep the binding+             -- pprTrace "Binding" (ppr final_bndr <+> ppr new_unfolding) $+             return (mkFloatBind env (NonRec final_bndr final_rhs)) }++addLetBndrInfo :: OutId -> Arity -> Bool -> Unfolding -> OutId+addLetBndrInfo new_bndr new_arity is_bot new_unf+  = new_bndr `setIdInfo` info5+  where+    info1 = idInfo new_bndr `setArityInfo` new_arity++    -- Unfolding info: Note [Setting the new unfolding]+    info2 = info1 `setUnfoldingInfo` new_unf++    -- Demand info: Note [Setting the demand info]+    -- We also have to nuke demand info if for some reason+    -- eta-expansion *reduces* the arity of the binding to less+    -- than that of the strictness sig. This can happen: see Note [Arity decrease].+    info3 | isEvaldUnfolding new_unf+            || (case strictnessInfo info2 of+                  StrictSig dmd_ty -> new_arity < dmdTypeDepth dmd_ty)+          = zapDemandInfo info2 `orElse` info2+          | otherwise+          = info2++    -- Bottoming bindings: see Note [Bottoming bindings]+    info4 | is_bot    = info3 `setStrictnessInfo`+                        mkClosedStrictSig (replicate new_arity topDmd) botRes+          | otherwise = info3++     -- Zap call arity info. We have used it by now (via+     -- `tryEtaExpandRhs`), and the simplifier can invalidate this+     -- information, leading to broken code later (e.g. #13479)+    info5 = zapCallArityInfo info4+++{- Note [Arity decrease]+~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking the arity of a binding should not decrease.  But it *can*+legitimately happen because of RULES.  Eg+        f = g Int+where g has arity 2, will have arity 2.  But if there's a rewrite rule+        g Int --> h+where h has arity 1, then f's arity will decrease.  Here's a real-life example,+which is in the output of Specialise:++     Rec {+        $dm {Arity 2} = \d.\x. op d+        {-# RULES forall d. $dm Int d = $s$dm #-}++        dInt = MkD .... opInt ...+        opInt {Arity 1} = $dm dInt++        $s$dm {Arity 0} = \x. op dInt }++Here opInt has arity 1; but when we apply the rule its arity drops to 0.+That's why Specialise goes to a little trouble to pin the right arity+on specialised functions too.++Note [Bottoming bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   let x = error "urk"+   in ...(case x of <alts>)...+or+   let f = \x. error (x ++ "urk")+   in ...(case f "foo" of <alts>)...++Then we'd like to drop the dead <alts> immediately.  So it's good to+propagate the info that x's RHS is bottom to x's IdInfo as rapidly as+possible.++We use tryEtaExpandRhs on every binding, and it turns ou that the+arity computation it performs (via CoreArity.findRhsArity) already+does a simple bottoming-expression analysis.  So all we need to do+is propagate that info to the binder's IdInfo.++This showed up in #12150; see comment:16.++Note [Setting the demand info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the unfolding is a value, the demand info may+go pear-shaped, so we nuke it.  Example:+     let x = (a,b) in+     case x of (p,q) -> h p q x+Here x is certainly demanded. But after we've nuked+the case, we'll get just+     let x = (a,b) in h a b x+and now x is not demanded (I'm assuming h is lazy)+This really happens.  Similarly+     let f = \x -> e in ...f..f...+After inlining f at some of its call sites the original binding may+(for example) be no longer strictly demanded.+The solution here is a bit ad hoc...+++************************************************************************+*                                                                      *+\subsection[Simplify-simplExpr]{The main function: simplExpr}+*                                                                      *+************************************************************************++The reason for this OutExprStuff stuff is that we want to float *after*+simplifying a RHS, not before.  If we do so naively we get quadratic+behaviour as things float out.++To see why it's important to do it after, consider this (real) example:++        let t = f x+        in fst t+==>+        let t = let a = e1+                    b = e2+                in (a,b)+        in fst t+==>+        let a = e1+            b = e2+            t = (a,b)+        in+        a       -- Can't inline a this round, cos it appears twice+==>+        e1++Each of the ==> steps is a round of simplification.  We'd save a+whole round if we float first.  This can cascade.  Consider++        let f = g d+        in \x -> ...f...+==>+        let f = let d1 = ..d.. in \y -> e+        in \x -> ...f...+==>+        let d1 = ..d..+        in \x -> ...(\y ->e)...++Only in this second round can the \y be applied, and it+might do the same again.+-}++simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr+simplExpr env (Type ty)+  = do { ty' <- simplType env ty  -- See Note [Avoiding space leaks in OutType]+       ; return (Type ty') }++simplExpr env expr+  = simplExprC env expr (mkBoringStop expr_out_ty)+  where+    expr_out_ty :: OutType+    expr_out_ty = substTy env (exprType expr)+    -- NB: Since 'expr' is term-valued, not (Type ty), this call+    --     to exprType will succeed.  exprType fails on (Type ty).++simplExprC :: SimplEnv+           -> InExpr     -- A term-valued expression, never (Type ty)+           -> SimplCont+           -> SimplM OutExpr+        -- Simplify an expression, given a continuation+simplExprC env expr cont+  = -- pprTrace "simplExprC" (ppr expr $$ ppr cont {- $$ ppr (seIdSubst env) -} $$ ppr (seLetFloats env) ) $+    do  { (floats, expr') <- simplExprF env expr cont+        ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $+          -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $+          -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $+          return (wrapFloats floats expr') }++--------------------------------------------------+simplExprF :: SimplEnv+           -> InExpr     -- A term-valued expression, never (Type ty)+           -> SimplCont+           -> SimplM (SimplFloats, OutExpr)++simplExprF env e cont+  = {- pprTrace "simplExprF" (vcat+      [ ppr e+      , text "cont =" <+> ppr cont+      , text "inscope =" <+> ppr (seInScope env)+      , text "tvsubst =" <+> ppr (seTvSubst env)+      , text "idsubst =" <+> ppr (seIdSubst env)+      , text "cvsubst =" <+> ppr (seCvSubst env)+      ]) $ -}+    simplExprF1 env e cont++simplExprF1 :: SimplEnv -> InExpr -> SimplCont+            -> SimplM (SimplFloats, OutExpr)++simplExprF1 _ (Type ty) _+  = pprPanic "simplExprF: type" (ppr ty)+    -- simplExprF does only with term-valued expressions+    -- The (Type ty) case is handled separately by simplExpr+    -- and by the other callers of simplExprF++simplExprF1 env (Var v)        cont = {-#SCC "simplIdF" #-} simplIdF env v cont+simplExprF1 env (Lit lit)      cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont+simplExprF1 env (Tick t expr)  cont = {-#SCC "simplTick" #-} simplTick env t expr cont+simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont+simplExprF1 env (Coercion co)  cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont++simplExprF1 env (App fun arg) cont+  = {-#SCC "simplExprF1-App" #-} case arg of+      Type ty -> do { -- The argument type will (almost) certainly be used+                      -- in the output program, so just force it now.+                      -- See Note [Avoiding space leaks in OutType]+                      arg' <- simplType env ty++                      -- But use substTy, not simplType, to avoid forcing+                      -- the hole type; it will likely not be needed.+                      -- See Note [The hole type in ApplyToTy]+                    ; let hole' = substTy env (exprType fun)++                    ; simplExprF env fun $+                      ApplyToTy { sc_arg_ty  = arg'+                                , sc_hole_ty = hole'+                                , sc_cont    = cont } }+      _       -> simplExprF env fun $+                 ApplyToVal { sc_arg = arg, sc_env = env+                            , sc_dup = NoDup, sc_cont = cont }++simplExprF1 env expr@(Lam {}) cont+  = {-#SCC "simplExprF1-Lam" #-}+    simplLam env zapped_bndrs body cont+        -- The main issue here is under-saturated lambdas+        --   (\x1. \x2. e) arg1+        -- Here x1 might have "occurs-once" occ-info, because occ-info+        -- is computed assuming that a group of lambdas is applied+        -- all at once.  If there are too few args, we must zap the+        -- occ-info, UNLESS the remaining binders are one-shot+  where+    (bndrs, body) = collectBinders expr+    zapped_bndrs | need_to_zap = map zap bndrs+                 | otherwise   = bndrs++    need_to_zap = any zappable_bndr (drop n_args bndrs)+    n_args = countArgs cont+        -- NB: countArgs counts all the args (incl type args)+        -- and likewise drop counts all binders (incl type lambdas)++    zappable_bndr b = isId b && not (isOneShotBndr b)+    zap b | isTyVar b = b+          | otherwise = zapLamIdInfo b++simplExprF1 env (Case scrut bndr _ alts) cont+  = {-#SCC "simplExprF1-Case" #-}+    simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr+                                 , sc_alts = alts+                                 , sc_env = env, sc_cont = cont })++simplExprF1 env (Let (Rec pairs) body) cont+  | Just pairs' <- joinPointBindings_maybe pairs+  = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont++  | otherwise+  = {-#SCC "simplRecE" #-} simplRecE env pairs body cont++simplExprF1 env (Let (NonRec bndr rhs) body) cont+  | Type ty <- rhs    -- First deal with type lets (let a = Type ty in e)+  = {-#SCC "simplExprF1-NonRecLet-Type" #-}+    ASSERT( isTyVar bndr )+    do { ty' <- simplType env ty+       ; simplExprF (extendTvSubst env bndr ty') body cont }++  | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs+  = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont++  | otherwise+  = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) ([], body) cont++{- Note [Avoiding space leaks in OutType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since the simplifier is run for multiple iterations, we need to ensure+that any thunks in the output of one simplifier iteration are forced+by the evaluation of the next simplifier iteration. Otherwise we may+retain multiple copies of the Core program and leak a terrible amount+of memory (as in #13426).++The simplifier is naturally strict in the entire "Expr part" of the+input Core program, because any expression may contain binders, which+we must find in order to extend the SimplEnv accordingly. But types+do not contain binders and so it is tempting to write things like++    simplExpr env (Type ty) = return (Type (substTy env ty))   -- Bad!++This is Bad because the result includes a thunk (substTy env ty) which+retains a reference to the whole simplifier environment; and the next+simplifier iteration will not force this thunk either, because the+line above is not strict in ty.++So instead our strategy is for the simplifier to fully evaluate+OutTypes when it emits them into the output Core program, for example++    simplExpr env (Type ty) = do { ty' <- simplType env ty     -- Good+                                 ; return (Type ty') }++where the only difference from above is that simplType calls seqType+on the result of substTy.++However, SimplCont can also contain OutTypes and it's not necessarily+a good idea to force types on the way in to SimplCont, because they+may end up not being used and forcing them could be a lot of wasted+work. T5631 is a good example of this.++- For ApplyToTy's sc_arg_ty, we force the type on the way in because+  the type will almost certainly appear as a type argument in the+  output program.++- For the hole types in Stop and ApplyToTy, we force the type when we+  emit it into the output program, after obtaining it from+  contResultType. (The hole type in ApplyToTy is only directly used+  to form the result type in a new Stop continuation.)+-}++---------------------------------+-- Simplify a join point, adding the context.+-- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do:+--   \x1 .. xn -> e => \x1 .. xn -> E[e]+-- Note that we need the arity of the join point, since e may be a lambda+-- (though this is unlikely). See Note [Case-of-case and join points].+simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont+             -> SimplM OutExpr+simplJoinRhs env bndr expr cont+  | Just arity <- isJoinId_maybe bndr+  =  do { let (join_bndrs, join_body) = collectNBinders arity expr+        ; (env', join_bndrs') <- simplLamBndrs env join_bndrs+        ; join_body' <- simplExprC env' join_body cont+        ; return $ mkLams join_bndrs' join_body' }++  | otherwise+  = pprPanic "simplJoinRhs" (ppr bndr)++---------------------------------+simplType :: SimplEnv -> InType -> SimplM OutType+        -- Kept monadic just so we can do the seqType+        -- See Note [Avoiding space leaks in OutType]+simplType env ty+  = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $+    seqType new_ty `seq` return new_ty+  where+    new_ty = substTy env ty++---------------------------------+simplCoercionF :: SimplEnv -> InCoercion -> SimplCont+               -> SimplM (SimplFloats, OutExpr)+simplCoercionF env co cont+  = do { co' <- simplCoercion env co+       ; rebuild env (Coercion co') cont }++simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion+simplCoercion env co+  = do { dflags <- getDynFlags+       ; let opt_co = optCoercion dflags (getTCvSubst env) co+       ; seqCo opt_co `seq` return opt_co }++-----------------------------------+-- | Push a TickIt context outwards past applications and cases, as+-- long as this is a non-scoping tick, to let case and application+-- optimisations apply.++simplTick :: SimplEnv -> Tickish Id -> InExpr -> SimplCont+          -> SimplM (SimplFloats, OutExpr)+simplTick env tickish expr cont+  -- A scoped tick turns into a continuation, so that we can spot+  -- (scc t (\x . e)) in simplLam and eliminate the scc.  If we didn't do+  -- it this way, then it would take two passes of the simplifier to+  -- reduce ((scc t (\x . e)) e').+  -- NB, don't do this with counting ticks, because if the expr is+  -- bottom, then rebuildCall will discard the continuation.++-- XXX: we cannot do this, because the simplifier assumes that+-- the context can be pushed into a case with a single branch. e.g.+--    scc<f>  case expensive of p -> e+-- becomes+--    case expensive of p -> scc<f> e+--+-- So I'm disabling this for now.  It just means we will do more+-- simplifier iterations that necessary in some cases.++--  | tickishScoped tickish && not (tickishCounts tickish)+--  = simplExprF env expr (TickIt tickish cont)++  -- For unscoped or soft-scoped ticks, we are allowed to float in new+  -- cost, so we simply push the continuation inside the tick.  This+  -- has the effect of moving the tick to the outside of a case or+  -- application context, allowing the normal case and application+  -- optimisations to fire.+  | tickish `tickishScopesLike` SoftScope+  = do { (floats, expr') <- simplExprF env expr cont+       ; return (floats, mkTick tickish expr')+       }++  -- Push tick inside if the context looks like this will allow us to+  -- do a case-of-case - see Note [case-of-scc-of-case]+  | Select {} <- cont, Just expr' <- push_tick_inside+  = simplExprF env expr' cont++  -- We don't want to move the tick, but we might still want to allow+  -- floats to pass through with appropriate wrapping (or not, see+  -- wrap_floats below)+  --- | not (tickishCounts tickish) || tickishCanSplit tickish+  -- = wrap_floats++  | otherwise+  = no_floating_past_tick++ where++  -- Try to push tick inside a case, see Note [case-of-scc-of-case].+  push_tick_inside =+    case expr0 of+      Case scrut bndr ty alts+             -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts)+      _other -> Nothing+   where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)+         movable t      = not (tickishCounts t) ||+                          t `tickishScopesLike` NoScope ||+                          tickishCanSplit t+         tickScrut e    = foldr mkTick e ticks+         -- Alternatives get annotated with all ticks that scope in some way,+         -- but we don't want to count entries.+         tickAlt (c,bs,e) = (c,bs, foldr mkTick e ts_scope)+         ts_scope         = map mkNoCount $+                            filter (not . (`tickishScopesLike` NoScope)) ticks++  no_floating_past_tick =+    do { let (inc,outc) = splitCont cont+       ; (floats, expr1) <- simplExprF env expr inc+       ; let expr2    = wrapFloats floats expr1+             tickish' = simplTickish env tickish+       ; rebuild env (mkTick tickish' expr2) outc+       }++-- Alternative version that wraps outgoing floats with the tick.  This+-- results in ticks being duplicated, as we don't make any attempt to+-- eliminate the tick if we re-inline the binding (because the tick+-- semantics allows unrestricted inlining of HNFs), so I'm not doing+-- this any more.  FloatOut will catch any real opportunities for+-- floating.+--+--  wrap_floats =+--    do { let (inc,outc) = splitCont cont+--       ; (env', expr') <- simplExprF (zapFloats env) expr inc+--       ; let tickish' = simplTickish env tickish+--       ; let wrap_float (b,rhs) = (zapIdStrictness (setIdArity b 0),+--                                   mkTick (mkNoCount tickish') rhs)+--              -- when wrapping a float with mkTick, we better zap the Id's+--              -- strictness info and arity, because it might be wrong now.+--       ; let env'' = addFloats env (mapFloats env' wrap_float)+--       ; rebuild env'' expr' (TickIt tickish' outc)+--       }+++  simplTickish env tickish+    | Breakpoint n ids <- tickish+          = Breakpoint n (map (getDoneId . substId env) ids)+    | otherwise = tickish++  -- Push type application and coercion inside a tick+  splitCont :: SimplCont -> (SimplCont, SimplCont)+  splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc)+    where (inc,outc) = splitCont tail+  splitCont (CastIt co c) = (CastIt co inc, outc)+    where (inc,outc) = splitCont c+  splitCont other = (mkBoringStop (contHoleType other), other)++  getDoneId (DoneId id)  = id+  getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst+  getDoneId other = pprPanic "getDoneId" (ppr other)++-- Note [case-of-scc-of-case]+-- It's pretty important to be able to transform case-of-case when+-- there's an SCC in the way.  For example, the following comes up+-- in nofib/real/compress/Encode.hs:+--+--        case scctick<code_string.r1>+--             case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje+--             of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) ->+--             (ww1_s13f, ww2_s13g, ww3_s13h)+--             }+--        of _ { (ww_s12Y, ww1_s12Z, ww2_s130) ->+--        tick<code_string.f1>+--        (ww_s12Y,+--         ww1_s12Z,+--         PTTrees.PT+--           @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf)+--        }+--+-- We really want this case-of-case to fire, because then the 3-tuple+-- will go away (indeed, the CPR optimisation is relying on this+-- happening).  But the scctick is in the way - we need to push it+-- inside to expose the case-of-case.  So we perform this+-- transformation on the inner case:+--+--   scctick c (case e of { p1 -> e1; ...; pn -> en })+--    ==>+--   case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en }+--+-- So we've moved a constant amount of work out of the scc to expose+-- the case.  We only do this when the continuation is interesting: in+-- for now, it has to be another Case (maybe generalise this later).++{-+************************************************************************+*                                                                      *+\subsection{The main rebuilder}+*                                                                      *+************************************************************************+-}++rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)+-- At this point the substitution in the SimplEnv should be irrelevant;+-- only the in-scope set matters+rebuild env expr cont+  = case cont of+      Stop {}          -> return (emptyFloats env, expr)+      TickIt t cont    -> rebuild env (mkTick t expr) cont+      CastIt co cont   -> rebuild env (mkCast expr co) cont+                       -- NB: mkCast implements the (Coercion co |> g) optimisation++      Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }+        -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont++      StrictArg { sc_fun = fun, sc_cont = cont }+        -> rebuildCall env (fun `addValArgTo` expr) cont+      StrictBind { sc_bndr = b, sc_bndrs = bs, sc_body = body+                 , sc_env = se, sc_cont = cont }+        -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr+                                  -- expr satisfies let/app since it started life+                                  -- in a call to simplNonRecE+              ; (floats2, expr') <- simplLam env' bs body cont+              ; return (floats1 `addFloats` floats2, expr') }++      ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}+        -> rebuild env (App expr (Type ty)) cont++      ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont}+        -- See Note [Avoid redundant simplification]+        -> do { (_, _, arg') <- simplArg env dup_flag se arg+              ; rebuild env (App expr arg') cont }++{-+************************************************************************+*                                                                      *+\subsection{Lambdas}+*                                                                      *+************************************************************************+-}++{- Note [Optimising reflexivity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important (for compiler performance) to get rid of reflexivity as soon+as it appears.  See #11735, #14737, and #15019.++In particular, we want to behave well on++ *  e |> co1 |> co2+    where the two happen to cancel out entirely. That is quite common;+    e.g. a newtype wrapping and unwrapping cancel.+++ * (f |> co) @t1 @t2 ... @tn x1 .. xm+   Here we wil use pushCoTyArg and pushCoValArg successively, which+   build up NthCo stacks.  Silly to do that if co is reflexive.++However, we don't want to call isReflexiveCo too much, because it uses+type equality which is expensive on big types (#14737 comment:7).++A good compromise (determined experimentally) seems to be to call+isReflexiveCo+ * when composing casts, and+ * at the end++In investigating this I saw missed opportunities for on-the-fly+coercion shrinkage. See #15090.+-}+++simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont+          -> SimplM (SimplFloats, OutExpr)+simplCast env body co0 cont0+  = do  { co1   <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0+        ; cont1 <- {-#SCC "simplCast-addCoerce" #-}+                   if isReflCo co1+                   then return cont0  -- See Note [Optimising reflexivity]+                   else addCoerce co1 cont0+        ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }+  where+        -- If the first parameter is MRefl, then simplifying revealed a+        -- reflexive coercion. Omit.+        addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont+        addCoerceM MRefl   cont = return cont+        addCoerceM (MCo co) cont = addCoerce co cont++        addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont+        addCoerce co1 (CastIt co2 cont)  -- See Note [Optimising reflexivity]+          | isReflexiveCo co' = return cont+          | otherwise         = addCoerce co' cont+          where+            co' = mkTransCo co1 co2++        addCoerce co cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })+          | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty+          = {-#SCC "addCoerce-pushCoTyArg" #-}+            do { tail' <- addCoerceM m_co' tail+               ; return (cont { sc_arg_ty = arg_ty', sc_cont = tail' }) }++        addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se+                                      , sc_dup = dup, sc_cont = tail })+          | Just (co1, m_co2) <- pushCoValArg co+          , Pair _ new_ty <- coercionKind co1+          , not (isTypeLevPoly new_ty)  -- Without this check, we get a lev-poly arg+                                        -- See Note [Levity polymorphism invariants] in CoreSyn+                                        -- test: typecheck/should_run/EtaExpandLevPoly+          = {-#SCC "addCoerce-pushCoValArg" #-}+            do { tail' <- addCoerceM m_co2 tail+               ; if isReflCo co1+                 then return (cont { sc_cont = tail' })+                      -- Avoid simplifying if possible;+                      -- See Note [Avoiding exponential behaviour]+                 else do+               { (dup', arg_se', arg') <- simplArg env dup arg_se arg+                    -- When we build the ApplyTo we can't mix the OutCoercion+                    -- 'co' with the InExpr 'arg', so we simplify+                    -- to make it all consistent.  It's a bit messy.+                    -- But it isn't a common case.+                    -- Example of use: #995+               ; return (ApplyToVal { sc_arg  = mkCast arg' co1+                                    , sc_env  = arg_se'+                                    , sc_dup  = dup'+                                    , sc_cont = tail' }) } }++        addCoerce co cont+          | isReflexiveCo co = return cont  -- Having this at the end makes a huge+                                            -- difference in T12227, for some reason+                                            -- See Note [Optimising reflexivity]+          | otherwise        = return (CastIt co cont)++simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr+         -> SimplM (DupFlag, StaticEnv, OutExpr)+simplArg env dup_flag arg_env arg+  | isSimplified dup_flag+  = return (dup_flag, arg_env, arg)+  | otherwise+  = do { arg' <- simplExpr (arg_env `setInScopeFromE` env) arg+       ; return (Simplified, zapSubstEnv arg_env, arg') }++{-+************************************************************************+*                                                                      *+\subsection{Lambdas}+*                                                                      *+************************************************************************+-}++simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont+         -> SimplM (SimplFloats, OutExpr)++simplLam env [] body cont+  = simplExprF env body cont++simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })+  = do { tick (BetaReduction bndr)+       ; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont }++simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se+                                           , sc_cont = cont, sc_dup = dup })+  | isSimplified dup  -- Don't re-simplify if we've simplified it once+                      -- See Note [Avoiding exponential behaviour]+  = do  { tick (BetaReduction bndr)+        ; (floats1, env') <- simplNonRecX env zapped_bndr arg+        ; (floats2, expr') <- simplLam env' bndrs body cont+        ; return (floats1 `addFloats` floats2, expr') }++  | otherwise+  = do  { tick (BetaReduction bndr)+        ; simplNonRecE env zapped_bndr (arg, arg_se) (bndrs, body) cont }+  where+    zapped_bndr  -- See Note [Zap unfolding when beta-reducing]+      | isId bndr = zapStableUnfolding bndr+      | otherwise = bndr++      -- Discard a non-counting tick on a lambda.  This may change the+      -- cost attribution slightly (moving the allocation of the+      -- lambda elsewhere), but we don't care: optimisation changes+      -- cost attribution all the time.+simplLam env bndrs body (TickIt tickish cont)+  | not (tickishCounts tickish)+  = simplLam env bndrs body cont++        -- Not enough args, so there are real lambdas left to put in the result+simplLam env bndrs body cont+  = do  { (env', bndrs') <- simplLamBndrs env bndrs+        ; body' <- simplExpr env' body+        ; new_lam <- mkLam env bndrs' body' cont+        ; rebuild env' new_lam cont }++-------------+simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)+-- Used for lambda binders.  These sometimes have unfoldings added by+-- the worker/wrapper pass that must be preserved, because they can't+-- be reconstructed from context.  For example:+--      f x = case x of (a,b) -> fw a b x+--      fw a b x{=(a,b)} = ...+-- The "{=(a,b)}" is an unfolding we can't reconstruct otherwise.+simplLamBndr env bndr+  | isId bndr && isFragileUnfolding old_unf   -- Special case+  = do { (env1, bndr1) <- simplBinder env bndr+       ; unf'          <- simplStableUnfolding env1 NotTopLevel Nothing bndr+                                               old_unf (idType bndr1)+       ; let bndr2 = bndr1 `setIdUnfolding` unf'+       ; return (modifyInScope env1 bndr2, bndr2) }++  | otherwise+  = simplBinder env bndr                -- Normal case+  where+    old_unf = idUnfolding bndr++simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])+simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs++------------------+simplNonRecE :: SimplEnv+             -> InId                    -- The binder, always an Id+                                        -- Never a join point+             -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)+             -> ([InBndr], InExpr)      -- Body of the let/lambda+                                        --      \xs.e+             -> SimplCont+             -> SimplM (SimplFloats, OutExpr)++-- simplNonRecE is used for+--  * non-top-level non-recursive non-join-point lets in expressions+--  * beta reduction+--+-- simplNonRec env b (rhs, rhs_se) (bs, body) k+--   = let env in+--     cont< let b = rhs_se(rhs) in \bs.body >+--+-- It deals with strict bindings, via the StrictBind continuation,+-- which may abort the whole process+--+-- Precondition: rhs satisfies the let/app invariant+--               Note [CoreSyn let/app invariant] in CoreSyn+--+-- The "body" of the binding comes as a pair of ([InId],InExpr)+-- representing a lambda; so we recurse back to simplLam+-- Why?  Because of the binder-occ-info-zapping done before+--       the call to simplLam in simplExprF (Lam ...)++simplNonRecE env bndr (rhs, rhs_se) (bndrs, body) cont+  | ASSERT( isId bndr && not (isJoinId bndr) ) True+  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se+  = do { tick (PreInlineUnconditionally bndr)+       ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $+         simplLam env' bndrs body cont }++  -- Deal with strict bindings+  | isStrictId bndr          -- Includes coercions+  , sm_case_case (getMode env)+  = simplExprF (rhs_se `setInScopeFromE` env) rhs+               (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs, sc_body = body+                           , sc_env = env, sc_cont = cont, sc_dup = NoDup })++  -- Deal with lazy bindings+  | otherwise+  = ASSERT( not (isTyVar bndr) )+    do { (env1, bndr1) <- simplNonRecBndr env bndr+       ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing+       ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se+       ; (floats2, expr') <- simplLam env3 bndrs body cont+       ; return (floats1 `addFloats` floats2, expr') }++------------------+simplRecE :: SimplEnv+          -> [(InId, InExpr)]+          -> InExpr+          -> SimplCont+          -> SimplM (SimplFloats, OutExpr)++-- simplRecE is used for+--  * non-top-level recursive lets in expressions+simplRecE env pairs body cont+  = do  { let bndrs = map fst pairs+        ; MASSERT(all (not . isJoinId) bndrs)+        ; env1 <- simplRecBndrs env bndrs+                -- NB: bndrs' don't have unfoldings or rules+                -- We add them as we go down+        ; (floats1, env2) <- simplRecBind env1 NotTopLevel Nothing pairs+        ; (floats2, expr') <- simplExprF env2 body cont+        ; return (floats1 `addFloats` floats2, expr') }++{- Note [Avoiding exponential behaviour]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+One way in which we can get exponential behaviour is if we simplify a+big expression, and the re-simplify it -- and then this happens in a+deeply-nested way.  So we must be jolly careful about re-simplifying+an expression.  That is why completeNonRecX does not try+preInlineUnconditionally.++Example:+  f BIG, where f has a RULE+Then+ * We simplify BIG before trying the rule; but the rule does not fire+ * We inline f = \x. x True+ * So if we did preInlineUnconditionally we'd re-simplify (BIG True)++However, if BIG has /not/ already been simplified, we'd /like/ to+simplify BIG True; maybe good things happen.  That is why++* simplLam has+    - a case for (isSimplified dup), which goes via simplNonRecX, and+    - a case for the un-simplified case, which goes via simplNonRecE++* We go to some efforts to avoid unnecessarily simplifying ApplyToVal,+  in at least two places+    - In simplCast/addCoerce, where we check for isReflCo+    - In rebuildCall we avoid simplifying arguments before we have to+      (see Note [Trying rewrite rules])+++Note [Zap unfolding when beta-reducing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Lambda-bound variables can have stable unfoldings, such as+   $j = \x. \b{Unf=Just x}. e+See Note [Case binders and join points] below; the unfolding for lets+us optimise e better.  However when we beta-reduce it we want to+revert to using the actual value, otherwise we can end up in the+stupid situation of+          let x = blah in+          let b{Unf=Just x} = y+          in ...b...+Here it'd be far better to drop the unfolding and use the actual RHS.++************************************************************************+*                                                                      *+                     Join points+*                                                                      *+********************************************************************* -}++{- Note [Rules and unfolding for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++   simplExpr (join j x = rhs                         ) cont+             (      {- RULE j (p:ps) = blah -}       )+             (      {- StableUnfolding j = blah -}   )+             (in blah                                )++Then we will push 'cont' into the rhs of 'j'.  But we should *also* push+'cont' into the RHS of+  * Any RULEs for j, e.g. generated by SpecConstr+  * Any stable unfolding for j, e.g. the result of an INLINE pragma++Simplifying rules and stable-unfoldings happens a bit after+simplifying the right-hand side, so we remember whether or not it+is a join point, and what 'cont' is, in a value of type MaybeJoinCont++#13900 wsa caused by forgetting to push 'cont' into the RHS+of a SpecConstr-generated RULE for a join point.+-}++type MaybeJoinCont = Maybe SimplCont+  -- Nothing => Not a join point+  -- Just k  => This is a join binding with continuation k+  -- See Note [Rules and unfolding for join points]++simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr+                     -> InExpr -> SimplCont+                     -> SimplM (SimplFloats, OutExpr)+simplNonRecJoinPoint env bndr rhs body cont+  | ASSERT( isJoinId bndr ) True+  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env+  = do { tick (PreInlineUnconditionally bndr)+       ; simplExprF env' body cont }++   | otherwise+   = wrapJoinCont env cont $ \ env cont ->+     do { -- We push join_cont into the join RHS and the body;+          -- and wrap wrap_cont around the whole thing+        ; let res_ty = contResultType cont+        ; (env1, bndr1)    <- simplNonRecJoinBndr env res_ty bndr+        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (Just cont)+        ; (floats1, env3)  <- simplJoinBind env2 cont bndr bndr2 rhs env+        ; (floats2, body') <- simplExprF env3 body cont+        ; return (floats1 `addFloats` floats2, body') }+++------------------+simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]+                  -> InExpr -> SimplCont+                  -> SimplM (SimplFloats, OutExpr)+simplRecJoinPoint env pairs body cont+  = wrapJoinCont env cont $ \ env cont ->+    do { let bndrs = map fst pairs+             res_ty = contResultType cont+       ; env1 <- simplRecJoinBndrs env res_ty bndrs+               -- NB: bndrs' don't have unfoldings or rules+               -- We add them as we go down+       ; (floats1, env2)  <- simplRecBind env1 NotTopLevel (Just cont) pairs+       ; (floats2, body') <- simplExprF env2 body cont+       ; return (floats1 `addFloats` floats2, body') }++--------------------+wrapJoinCont :: SimplEnv -> SimplCont+             -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))+             -> SimplM (SimplFloats, OutExpr)+-- Deal with making the continuation duplicable if necessary,+-- and with the no-case-of-case situation.+wrapJoinCont env cont thing_inside+  | contIsStop cont        -- Common case; no need for fancy footwork+  = thing_inside env cont++  | not (sm_case_case (getMode env))+    -- See Note [Join points wih -fno-case-of-case]+  = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))+       ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1+       ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont+       ; return (floats2 `addFloats` floats3, expr3) }++  | otherwise+    -- Normal case; see Note [Join points and case-of-case]+  = do { (floats1, cont')  <- mkDupableCont env cont+       ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'+       ; return (floats1 `addFloats` floats2, result) }+++--------------------+trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont+-- Drop outer context from join point invocation (jump)+-- See Note [Join points and case-of-case]++trimJoinCont _ Nothing cont+  = cont -- Not a jump+trimJoinCont var (Just arity) cont+  = trim arity cont+  where+    trim 0 cont@(Stop {})+      = cont+    trim 0 cont+      = mkBoringStop (contResultType cont)+    trim n cont@(ApplyToVal { sc_cont = k })+      = cont { sc_cont = trim (n-1) k }+    trim n cont@(ApplyToTy { sc_cont = k })+      = cont { sc_cont = trim (n-1) k } -- join arity counts types!+    trim _ cont+      = pprPanic "completeCall" $ ppr var $$ ppr cont+++{- Note [Join points and case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we perform the case-of-case transform (or otherwise push continuations+inward), we want to treat join points specially. Since they're always+tail-called and we want to maintain this invariant, we can do this (for any+evaluation context E):++  E[join j = e+    in case ... of+         A -> jump j 1+         B -> jump j 2+         C -> f 3]++    -->++  join j = E[e]+  in case ... of+       A -> jump j 1+       B -> jump j 2+       C -> E[f 3]++As is evident from the example, there are two components to this behavior:++  1. When entering the RHS of a join point, copy the context inside.+  2. When a join point is invoked, discard the outer context.++We need to be very careful here to remain consistent---neither part is+optional!++We need do make the continuation E duplicable (since we are duplicating it)+with mkDuableCont.+++Note [Join points wih -fno-case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Supose case-of-case is switched off, and we are simplifying++    case (join j x = <j-rhs> in+          case y of+             A -> j 1+             B -> j 2+             C -> e) of <outer-alts>++Usually, we'd push the outer continuation (case . of <outer-alts>) into+both the RHS and the body of the join point j.  But since we aren't doing+case-of-case we may then end up with this totally bogus result++    join x = case <j-rhs> of <outer-alts> in+    case (case y of+             A -> j 1+             B -> j 2+             C -> e) of <outer-alts>++This would be OK in the language of the paper, but not in GHC: j is no longer+a join point.  We can only do the "push contination into the RHS of the+join point j" if we also push the contination right down to the /jumps/ to+j, so that it can evaporate there.  If we are doing case-of-case, we'll get to++    join x = case <j-rhs> of <outer-alts> in+    case y of+      A -> j 1+      B -> j 2+      C -> case e of <outer-alts>++which is great.++Bottom line: if case-of-case is off, we must stop pushing the continuation+inwards altogether at any join point.  Instead simplify the (join ... in ...)+with a Stop continuation, and wrap the original continuation around the+outside.  Surprisingly tricky!+++************************************************************************+*                                                                      *+                     Variables+*                                                                      *+************************************************************************+-}++simplVar :: SimplEnv -> InVar -> SimplM OutExpr+-- Look up an InVar in the environment+simplVar env var+  | isTyVar var = return (Type (substTyVar env var))+  | isCoVar var = return (Coercion (substCoVar env var))+  | otherwise+  = case substId env var of+        ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e+        DoneId var1          -> return (Var var1)+        DoneEx e _           -> return e++simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)+simplIdF env var cont+  = case substId env var of+      ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont+                                -- Don't trim; haven't already simplified e,+                                -- so the cont is not embodied in e++      DoneId var1 -> completeCall env var1 (trimJoinCont var (isJoinId_maybe var1) cont)++      DoneEx e mb_join -> simplExprF (zapSubstEnv env) e (trimJoinCont var mb_join cont)+              -- Note [zapSubstEnv]+              -- The template is already simplified, so don't re-substitute.+              -- This is VITAL.  Consider+              --      let x = e in+              --      let y = \z -> ...x... in+              --      \ x -> ...y...+              -- We'll clone the inner \x, adding x->x' in the id_subst+              -- Then when we inline y, we must *not* replace x by x' in+              -- the inlined copy!!++---------------------------------------------------------+--      Dealing with a call site++completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)+completeCall env var cont+  | Just expr <- callSiteInline dflags var active_unf+                                lone_variable arg_infos interesting_cont+  -- Inline the variable's RHS+  = do { checkedTick (UnfoldingDone var)+       ; dump_inline expr cont+       ; simplExprF (zapSubstEnv env) expr cont }++  | otherwise+  -- Don't inline; instead rebuild the call+  = do { rule_base <- getSimplRules+       ; let info = mkArgInfo env var (getRules rule_base var)+                              n_val_args call_cont+       ; rebuildCall env info cont }++  where+    dflags = seDynFlags env+    (lone_variable, arg_infos, call_cont) = contArgs cont+    n_val_args       = length arg_infos+    interesting_cont = interestingCallContext env call_cont+    active_unf       = activeUnfolding (getMode env) var++    dump_inline unfolding cont+      | not (dopt Opt_D_dump_inlinings dflags) = return ()+      | not (dopt Opt_D_verbose_core2core dflags)+      = when (isExternalName (idName var)) $+            liftIO $ printOutputForUser dflags alwaysQualify $+                sep [text "Inlining done:", nest 4 (ppr var)]+      | otherwise+      = liftIO $ printOutputForUser dflags alwaysQualify $+           sep [text "Inlining done: " <> ppr var,+                nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),+                              text "Cont:  " <+> ppr cont])]++rebuildCall :: SimplEnv+            -> ArgInfo+            -> SimplCont+            -> SimplM (SimplFloats, OutExpr)+-- We decided not to inline, so+--    - simplify the arguments+--    - try rewrite rules+--    - and rebuild++---------- Bottoming applications --------------+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) cont+  -- When we run out of strictness args, it means+  -- that the call is definitely bottom; see SimplUtils.mkArgInfo+  -- Then we want to discard the entire strict continuation.  E.g.+  --    * case (error "hello") of { ... }+  --    * (error "Hello") arg+  --    * f (error "Hello") where f is strict+  --    etc+  -- Then, especially in the first of these cases, we'd like to discard+  -- the continuation, leaving just the bottoming expression.  But the+  -- type might not be right, so we may have to add a coerce.+  | not (contIsTrivial cont)     -- Only do this if there is a non-trivial+                                 -- continuation to discard, else we do it+                                 -- again and again!+  = seqType cont_ty `seq`        -- See Note [Avoiding space leaks in OutType]+    return (emptyFloats env, castBottomExpr res cont_ty)+  where+    res     = argInfoExpr fun rev_args+    cont_ty = contResultType cont++---------- Try rewrite RULES --------------+-- See Note [Trying rewrite rules]+rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args+                              , ai_rules = Just (nr_wanted, rules) }) cont+  | nr_wanted == 0 || no_more_args+  , let info' = info { ai_rules = Nothing }+  = -- We've accumulated a simplified call in <fun,rev_args>+    -- so try rewrite rules; see Note [RULEs apply to simplified arguments]+    -- See also Note [Rules for recursive functions]+    do { mb_match <- tryRules env rules fun (reverse rev_args) cont+       ; case mb_match of+             Just (env', rhs, cont') -> simplExprF env' rhs cont'+             Nothing                 -> rebuildCall env info' cont }+  where+    no_more_args = case cont of+                      ApplyToTy  {} -> False+                      ApplyToVal {} -> False+                      _             -> True+++---------- Simplify applications and casts --------------+rebuildCall env info (CastIt co cont)+  = rebuildCall env (addCastTo info co) cont++rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })+  = rebuildCall env (addTyArgTo info arg_ty) cont++rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty+                              , ai_strs = str:strs, ai_discs = disc:discs })+            (ApplyToVal { sc_arg = arg, sc_env = arg_se+                        , sc_dup = dup_flag, sc_cont = cont })+  | isSimplified dup_flag     -- See Note [Avoid redundant simplification]+  = rebuildCall env (addValArgTo info' arg) cont++  | str         -- Strict argument+  , sm_case_case (getMode env)+  = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $+    simplExprF (arg_se `setInScopeFromE` env) arg+               (StrictArg { sc_fun = info', sc_cci = cci_strict+                          , sc_dup = Simplified, sc_cont = cont })+                -- Note [Shadowing]++  | otherwise                           -- Lazy argument+        -- DO NOT float anything outside, hence simplExprC+        -- There is no benefit (unlike in a let-binding), and we'd+        -- have to be very careful about bogus strictness through+        -- floating a demanded let.+  = do  { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg+                             (mkLazyArgStop arg_ty cci_lazy)+        ; rebuildCall env (addValArgTo info' arg') cont }+  where+    info'  = info { ai_strs = strs, ai_discs = discs }+    arg_ty = funArgTy fun_ty++    -- Use this for lazy arguments+    cci_lazy | encl_rules = RuleArgCtxt+             | disc > 0   = DiscArgCtxt  -- Be keener here+             | otherwise  = BoringCtxt   -- Nothing interesting++    -- ..and this for strict arguments+    cci_strict | encl_rules = RuleArgCtxt+               | disc > 0   = DiscArgCtxt+               | otherwise  = RhsCtxt+      -- Why RhsCtxt?  if we see f (g x) (h x), and f is strict, we+      -- want to be a bit more eager to inline g, because it may+      -- expose an eval (on x perhaps) that can be eliminated or+      -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1+      -- It's worth an 18% improvement in allocation for this+      -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier'++---------- No further useful info, revert to generic rebuild ------------+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont+  = rebuild env (argInfoExpr fun rev_args) cont++{- Note [Trying rewrite rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet+simplified.  We want to simplify enough arguments to allow the rules+to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone+is sufficient.  Example: class ops+   (+) dNumInt e2 e3+If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the+latter's strictness when simplifying e2, e3.  Moreover, suppose we have+  RULE  f Int = \x. x True++Then given (f Int e1) we rewrite to+   (\x. x True) e1+without simplifying e1.  Now we can inline x into its unique call site,+and absorb the True into it all in the same pass.  If we simplified+e1 first, we couldn't do that; see Note [Avoiding exponential behaviour].++So we try to apply rules if either+  (a) no_more_args: we've run out of argument that the rules can "see"+  (b) nr_wanted: none of the rules wants any more arguments+++Note [RULES apply to simplified arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very desirable to try RULES once the arguments have been simplified, because+doing so ensures that rule cascades work in one pass.  Consider+   {-# RULES g (h x) = k x+             f (k x) = x #-}+   ...f (g (h x))...+Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If+we match f's rules against the un-simplified RHS, it won't match.  This+makes a particularly big difference when superclass selectors are involved:+        op ($p1 ($p2 (df d)))+We want all this to unravel in one sweep.++Note [Avoid redundant simplification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because RULES apply to simplified arguments, there's a danger of repeatedly+simplifying already-simplified arguments.  An important example is that of+        (>>=) d e1 e2+Here e1, e2 are simplified before the rule is applied, but don't really+participate in the rule firing. So we mark them as Simplified to avoid+re-simplifying them.++Note [Shadowing]+~~~~~~~~~~~~~~~~+This part of the simplifier may break the no-shadowing invariant+Consider+        f (...(\a -> e)...) (case y of (a,b) -> e')+where f is strict in its second arg+If we simplify the innermost one first we get (...(\a -> e)...)+Simplifying the second arg makes us float the case out, so we end up with+        case y of (a,b) -> f (...(\a -> e)...) e'+So the output does not have the no-shadowing invariant.  However, there is+no danger of getting name-capture, because when the first arg was simplified+we used an in-scope set that at least mentioned all the variables free in its+static environment, and that is enough.++We can't just do innermost first, or we'd end up with a dual problem:+        case x of (a,b) -> f e (...(\a -> e')...)++I spent hours trying to recover the no-shadowing invariant, but I just could+not think of an elegant way to do it.  The simplifier is already knee-deep in+continuations.  We have to keep the right in-scope set around; AND we have+to get the effect that finding (error "foo") in a strict arg position will+discard the entire application and replace it with (error "foo").  Getting+all this at once is TOO HARD!+++************************************************************************+*                                                                      *+                Rewrite rules+*                                                                      *+************************************************************************+-}++tryRules :: SimplEnv -> [CoreRule]+         -> Id -> [ArgSpec]+         -> SimplCont+         -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))++tryRules env rules fn args call_cont+  | null rules+  = return Nothing++{- Disabled until we fix #8326+  | fn `hasKey` tagToEnumKey   -- See Note [Optimising tagToEnum#]+  , [_type_arg, val_arg] <- args+  , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont+  , isDeadBinder bndr+  = do { let enum_to_tag :: CoreAlt -> CoreAlt+                -- Takes   K -> e  into   tagK# -> e+                -- where tagK# is the tag of constructor K+             enum_to_tag (DataAlt con, [], rhs)+               = ASSERT( isEnumerationTyCon (dataConTyCon con) )+                (LitAlt tag, [], rhs)+              where+                tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG))+             enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)++             new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts+             new_bndr = setIdType bndr intPrimTy+                 -- The binder is dead, but should have the right type+      ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }+-}++  | Just (rule, rule_rhs) <- lookupRule dflags (getUnfoldingInRuleMatch env)+                                        (activeRule (getMode env)) fn+                                        (argInfoAppArgs args) rules+  -- Fire a rule for the function+  = do { checkedTick (RuleFired (ruleName rule))+       ; let cont' = pushSimplifiedArgs zapped_env+                                        (drop (ruleArity rule) args)+                                        call_cont+                     -- (ruleArity rule) says how+                     -- many args the rule consumed++             occ_anald_rhs = occurAnalyseExpr rule_rhs+                 -- See Note [Occurrence-analyse after rule firing]+       ; dump rule rule_rhs+       ; return (Just (zapped_env, occ_anald_rhs, cont')) }+            -- The occ_anald_rhs and cont' are all Out things+            -- hence zapping the environment++  | otherwise  -- No rule fires+  = do { nodump  -- This ensures that an empty file is written+       ; return Nothing }++  where+    dflags     = seDynFlags env+    zapped_env = zapSubstEnv env  -- See Note [zapSubstEnv]++    printRuleModule rule+      = parens (maybe (text "BUILTIN")+                      (pprModuleName . moduleName)+                      (ruleModule rule))++    dump rule rule_rhs+      | dopt Opt_D_dump_rule_rewrites dflags+      = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat+          [ text "Rule:" <+> ftext (ruleName rule)+          , text "Module:" <+>  printRuleModule rule+          , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))+          , text "After: " <+> pprCoreExpr rule_rhs+          , text "Cont:  " <+> ppr call_cont ]++      | dopt Opt_D_dump_rule_firings dflags+      = log_rule dflags Opt_D_dump_rule_firings "Rule fired:" $+          ftext (ruleName rule)+            <+> printRuleModule rule++      | otherwise+      = return ()++    nodump+      | dopt Opt_D_dump_rule_rewrites dflags+      = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_rewrites "" empty++      | dopt Opt_D_dump_rule_firings dflags+      = liftIO $ dumpSDoc dflags alwaysQualify Opt_D_dump_rule_firings "" empty++      | otherwise+      = return ()++    log_rule dflags flag hdr details+      = liftIO . dumpSDoc dflags alwaysQualify flag "" $+                   sep [text hdr, nest 4 details]++trySeqRules :: SimplEnv+            -> OutExpr -> InExpr   -- Scrutinee and RHS+            -> SimplCont+            -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))+-- See Note [User-defined RULES for seq]+trySeqRules in_env scrut rhs cont+  = do { rule_base <- getSimplRules+       ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont }+  where+    no_cast_scrut = drop_casts scrut+    scrut_ty  = exprType no_cast_scrut+    seq_id_ty = idType seqId+    rhs_ty    = substTy in_env (exprType rhs)+    out_args  = [ TyArg { as_arg_ty  = scrut_ty+                        , as_hole_ty = seq_id_ty }+                , TyArg { as_arg_ty  = rhs_ty+                       , as_hole_ty  = piResultTy seq_id_ty scrut_ty }+                , ValArg no_cast_scrut]+    rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs+                           , sc_env = in_env, sc_cont = cont }+    -- Lazily evaluated, so we don't do most of this++    drop_casts (Cast e _) = drop_casts e+    drop_casts e          = e++{- Note [User-defined RULES for seq]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given+   case (scrut |> co) of _ -> rhs+look for rules that match the expression+   seq @t1 @t2 scrut+where scrut :: t1+      rhs   :: t2++If you find a match, rewrite it, and apply to 'rhs'.++Notice that we can simply drop casts on the fly here, which+makes it more likely that a rule will match.++See Note [User-defined RULES for seq] in MkId.++Note [Occurrence-analyse after rule firing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+After firing a rule, we occurrence-analyse the instantiated RHS before+simplifying it.  Usually this doesn't make much difference, but it can+be huge.  Here's an example (simplCore/should_compile/T7785)++  map f (map f (map f xs)++= -- Use build/fold form of map, twice+  map f (build (\cn. foldr (mapFB c f) n+                           (build (\cn. foldr (mapFB c f) n xs))))++= -- Apply fold/build rule+  map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n))++= -- Beta-reduce+  -- Alas we have no occurrence-analysed, so we don't know+  -- that c is used exactly once+  map f (build (\cn. let c1 = mapFB c f in+                     foldr (mapFB c1 f) n xs))++= -- Use mapFB rule:   mapFB (mapFB c f) g = mapFB c (f.g)+  -- We can do this because (mapFB c n) is a PAP and hence expandable+  map f (build (\cn. let c1 = mapFB c n in+                     foldr (mapFB c (f.f)) n x))++This is not too bad.  But now do the same with the outer map, and+we get another use of mapFB, and t can interact with /both/ remaining+mapFB calls in the above expression.  This is stupid because actually+that 'c1' binding is dead.  The outer map introduces another c2. If+there is a deep stack of maps we get lots of dead bindings, and lots+of redundant work as we repeatedly simplify the result of firing rules.++The easy thing to do is simply to occurrence analyse the result of+the rule firing.  Note that this occ-anals not only the RHS of the+rule, but also the function arguments, which by now are OutExprs.+E.g.+      RULE f (g x) = x+1++Call   f (g BIG)  -->   (\x. x+1) BIG++The rule binders are lambda-bound and applied to the OutExpr arguments+(here BIG) which lack all internal occurrence info.++Is this inefficient?  Not really: we are about to walk over the result+of the rule firing to simplify it, so occurrence analysis is at most+a constant factor.++Possible improvement: occ-anal the rules when putting them in the+database; and in the simplifier just occ-anal the OutExpr arguments.+But that's more complicated and the rule RHS is usually tiny; so I'm+just doing the simple thing.++Historical note: previously we did occ-anal the rules in Rule.hs,+but failed to occ-anal the OutExpr arguments, which led to the+nasty performance problem described above.+++Note [Optimising tagToEnum#]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have an enumeration data type:++  data Foo = A | B | C++Then we want to transform++   case tagToEnum# x of   ==>    case x of+     A -> e1                       DEFAULT -> e1+     B -> e2                       1#      -> e2+     C -> e3                       2#      -> e3++thereby getting rid of the tagToEnum# altogether.  If there was a DEFAULT+alternative we retain it (remember it comes first).  If not the case must+be exhaustive, and we reflect that in the transformed version by adding+a DEFAULT.  Otherwise Lint complains that the new case is not exhaustive.+See #8317.++Note [Rules for recursive functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You might think that we shouldn't apply rules for a loop breaker:+doing so might give rise to an infinite loop, because a RULE is+rather like an extra equation for the function:+     RULE:           f (g x) y = x+y+     Eqn:            f a     y = a-y++But it's too drastic to disable rules for loop breakers.+Even the foldr/build rule would be disabled, because foldr+is recursive, and hence a loop breaker:+     foldr k z (build g) = g k z+So it's up to the programmer: rules can cause divergence+++************************************************************************+*                                                                      *+                Rebuilding a case expression+*                                                                      *+************************************************************************++Note [Case elimination]+~~~~~~~~~~~~~~~~~~~~~~~+The case-elimination transformation discards redundant case expressions.+Start with a simple situation:++        case x# of      ===>   let y# = x# in e+          y# -> e++(when x#, y# are of primitive type, of course).  We can't (in general)+do this for algebraic cases, because we might turn bottom into+non-bottom!++The code in SimplUtils.prepareAlts has the effect of generalise this+idea to look for a case where we're scrutinising a variable, and we+know that only the default case can match.  For example:++        case x of+          0#      -> ...+          DEFAULT -> ...(case x of+                         0#      -> ...+                         DEFAULT -> ...) ...++Here the inner case is first trimmed to have only one alternative, the+DEFAULT, after which it's an instance of the previous case.  This+really only shows up in eliminating error-checking code.++Note that SimplUtils.mkCase combines identical RHSs.  So++        case e of       ===> case e of DEFAULT -> r+           True  -> r+           False -> r++Now again the case may be elminated by the CaseElim transformation.+This includes things like (==# a# b#)::Bool so that we simplify+      case ==# a# b# of { True -> x; False -> x }+to just+      x+This particular example shows up in default methods for+comparison operations (e.g. in (>=) for Int.Int32)++Note [Case to let transformation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a case over a lifted type has a single alternative, and is being+used as a strict 'let' (all isDeadBinder bndrs), we may want to do+this transformation:++    case e of r       ===>   let r = e in ...r...+      _ -> ...r...++We treat the unlifted and lifted cases separately:++* Unlifted case: 'e' satisfies exprOkForSpeculation+  (ok-for-spec is needed to satisfy the let/app invariant).+  This turns     case a +# b of r -> ...r...+  into           let r = a +# b in ...r...+  and thence     .....(a +# b)....++  However, if we have+      case indexArray# a i of r -> ...r...+  we might like to do the same, and inline the (indexArray# a i).+  But indexArray# is not okForSpeculation, so we don't build a let+  in rebuildCase (lest it get floated *out*), so the inlining doesn't+  happen either.  Annoying.++* Lifted case: we need to be sure that the expression is already+  evaluated (exprIsHNF).  If it's not already evaluated+      - we risk losing exceptions, divergence or+        user-specified thunk-forcing+      - even if 'e' is guaranteed to converge, we don't want to+        create a thunk (call by need) instead of evaluating it+        right away (call by value)++  However, we can turn the case into a /strict/ let if the 'r' is+  used strictly in the body.  Then we won't lose divergence; and+  we won't build a thunk because the let is strict.+  See also Note [Case-to-let for strictly-used binders]++  NB: absentError satisfies exprIsHNF: see Note [aBSENT_ERROR_ID] in MkCore.+  We want to turn+     case (absentError "foo") of r -> ...MkT r...+  into+     let r = absentError "foo" in ...MkT r...+++Note [Case-to-let for strictly-used binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have this:+   case <scrut> of r { _ -> ..r.. }++where 'r' is used strictly in (..r..), we can safely transform to+   let r = <scrut> in ...r...++This is a Good Thing, because 'r' might be dead (if the body just+calls error), or might be used just once (in which case it can be+inlined); or we might be able to float the let-binding up or down.+E.g. #15631 has an example.++Note that this can change the error behaviour.  For example, we might+transform+    case x of { _ -> error "bad" }+    --> error "bad"+which is might be puzzling if 'x' currently lambda-bound, but later gets+let-bound to (error "good").++Nevertheless, the paper "A semantics for imprecise exceptions" allows+this transformation. If you want to fix the evaluation order, use+'pseq'.  See #8900 for an example where the loss of this+transformation bit us in practice.++See also Note [Empty case alternatives] in CoreSyn.++Historical notes++There have been various earlier versions of this patch:++* By Sept 18 the code looked like this:+     || scrut_is_demanded_var scrut++    scrut_is_demanded_var :: CoreExpr -> Bool+    scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s+    scrut_is_demanded_var (Var _)    = isStrictDmd (idDemandInfo case_bndr)+    scrut_is_demanded_var _          = False++  This only fired if the scrutinee was a /variable/, which seems+  an unnecessary restriction. So in #15631 I relaxed it to allow+  arbitrary scrutinees.  Less code, less to explain -- but the change+  had 0.00% effect on nofib.++* Previously, in Jan 13 the code looked like this:+     || case_bndr_evald_next rhs++    case_bndr_evald_next :: CoreExpr -> Bool+      -- See Note [Case binder next]+    case_bndr_evald_next (Var v)         = v == case_bndr+    case_bndr_evald_next (Cast e _)      = case_bndr_evald_next e+    case_bndr_evald_next (App e _)       = case_bndr_evald_next e+    case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e+    case_bndr_evald_next _               = False++  This patch was part of fixing #7542. See also+  Note [Eta reduction of an eval'd function] in CoreUtils.)+++Further notes about case elimination+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:       test :: Integer -> IO ()+                test = print++Turns out that this compiles to:+    Print.test+      = \ eta :: Integer+          eta1 :: Void# ->+          case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->+          case hPutStr stdout+                 (PrelNum.jtos eta ($w[] @ Char))+                 eta1+          of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}++Notice the strange '<' which has no effect at all. This is a funny one.+It started like this:++f x y = if x < 0 then jtos x+          else if y==0 then "" else jtos x++At a particular call site we have (f v 1).  So we inline to get++        if v < 0 then jtos x+        else if 1==0 then "" else jtos x++Now simplify the 1==0 conditional:++        if v<0 then jtos v else jtos v++Now common-up the two branches of the case:++        case (v<0) of DEFAULT -> jtos v++Why don't we drop the case?  Because it's strict in v.  It's technically+wrong to drop even unnecessary evaluations, and in practice they+may be a result of 'seq' so we *definitely* don't want to drop those.+I don't really know how to improve this situation.+++Note [FloatBinds from constructor wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have FloatBinds coming from the constructor wrapper+(as in Note [exprIsConApp_maybe on data constructors with wrappers]),+ew cannot float past them. We'd need to float the FloatBind+together with the simplify floats, unfortunately the+simplifier doesn't have case-floats. The simplest thing we can+do is to wrap all the floats here. The next iteration of the+simplifier will take care of all these cases and lets.++Given data T = MkT !Bool, this allows us to simplify+case $WMkT b of { MkT x -> f x }+to+case b of { b' -> f b' }.++We could try and be more clever (like maybe wfloats only contain+let binders, so we could float them). But the need for the+extra complication is not clear.+-}++---------------------------------------------------------+--      Eliminate the case if possible++rebuildCase, reallyRebuildCase+   :: SimplEnv+   -> OutExpr          -- Scrutinee+   -> InId             -- Case binder+   -> [InAlt]          -- Alternatives (increasing order)+   -> SimplCont+   -> SimplM (SimplFloats, OutExpr)++--------------------------------------------------+--      1. Eliminate the case if there's a known constructor+--------------------------------------------------++rebuildCase env scrut case_bndr alts cont+  | Lit lit <- scrut    -- No need for same treatment as constructors+                        -- because literals are inlined more vigorously+  , not (litIsLifted lit)+  = do  { tick (KnownBranch case_bndr)+        ; case findAlt (LitAlt lit) alts of+            Nothing           -> missingAlt env case_bndr alts cont+            Just (_, bs, rhs) -> simple_rhs env [] scrut bs rhs }++  | Just (in_scope', wfloats, con, ty_args, other_args)+      <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut+        -- Works when the scrutinee is a variable with a known unfolding+        -- as well as when it's an explicit constructor application+  , let env0 = setInScopeSet env in_scope'+  = do  { tick (KnownBranch case_bndr)+        ; case findAlt (DataAlt con) alts of+            Nothing  -> missingAlt env0 case_bndr alts cont+            Just (DEFAULT, bs, rhs) -> let con_app = Var (dataConWorkId con)+                                                 `mkTyApps` ty_args+                                                 `mkApps`   other_args+                                       in simple_rhs env0 wfloats con_app bs rhs+            Just (_, bs, rhs)       -> knownCon env0 scrut wfloats con ty_args other_args+                                                case_bndr bs rhs cont+        }+  where+    simple_rhs env wfloats scrut' bs rhs =+      ASSERT( null bs )+      do { (floats1, env') <- simplNonRecX env case_bndr scrut'+             -- scrut is a constructor application,+             -- hence satisfies let/app invariant+         ; (floats2, expr') <- simplExprF env' rhs cont+         ; case wfloats of+             [] -> return (floats1 `addFloats` floats2, expr')+             _ -> return+               -- See Note [FloatBinds from constructor wrappers]+                   ( emptyFloats env,+                     MkCore.wrapFloats wfloats $+                     wrapFloats (floats1 `addFloats` floats2) expr' )}+++--------------------------------------------------+--      2. Eliminate the case if scrutinee is evaluated+--------------------------------------------------++rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont+  -- See if we can get rid of the case altogether+  -- See Note [Case elimination]+  -- mkCase made sure that if all the alternatives are equal,+  -- then there is now only one (DEFAULT) rhs++  -- 2a.  Dropping the case altogether, if+  --      a) it binds nothing (so it's really just a 'seq')+  --      b) evaluating the scrutinee has no side effects+  | is_plain_seq+  , exprOkForSideEffects scrut+          -- The entire case is dead, so we can drop it+          -- if the scrutinee converges without having imperative+          -- side effects or raising a Haskell exception+          -- See Note [PrimOp can_fail and has_side_effects] in PrimOp+   = simplExprF env rhs cont++  -- 2b.  Turn the case into a let, if+  --      a) it binds only the case-binder+  --      b) unlifted case: the scrutinee is ok-for-speculation+  --           lifted case: the scrutinee is in HNF (or will later be demanded)+  -- See Note [Case to let transformation]+  | all_dead_bndrs+  , doCaseToLet scrut case_bndr+  = do { tick (CaseElim case_bndr)+       ; (floats1, env') <- simplNonRecX env case_bndr scrut+       ; (floats2, expr') <- simplExprF env' rhs cont+       ; return (floats1 `addFloats` floats2, expr') }++  -- 2c. Try the seq rules if+  --     a) it binds only the case binder+  --     b) a rule for seq applies+  -- See Note [User-defined RULES for seq] in MkId+  | is_plain_seq+  = do { mb_rule <- trySeqRules env scrut rhs cont+       ; case mb_rule of+           Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont'+           Nothing                      -> reallyRebuildCase env scrut case_bndr alts cont }+  where+    all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]+    is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect++rebuildCase env scrut case_bndr alts cont+  = reallyRebuildCase env scrut case_bndr alts cont+++doCaseToLet :: OutExpr          -- Scrutinee+            -> InId             -- Case binder+            -> Bool+-- The situation is         case scrut of b { DEFAULT -> body }+-- Can we transform thus?   let { b = scrut } in body+doCaseToLet scrut case_bndr+  | isTyCoVar case_bndr    -- Respect CoreSyn+  = isTyCoArg scrut        -- Note [CoreSyn type and coercion invariant]++  | isUnliftedType (idType case_bndr)+  = exprOkForSpeculation scrut++  | otherwise  -- Scrut has a lifted type+  = exprIsHNF scrut+    || isStrictDmd (idDemandInfo case_bndr)+    -- See Note [Case-to-let for strictly-used binders]++--------------------------------------------------+--      3. Catch-all case+--------------------------------------------------++reallyRebuildCase env scrut case_bndr alts cont+  | not (sm_case_case (getMode env))+  = do { case_expr <- simplAlts env scrut case_bndr alts+                                (mkBoringStop (contHoleType cont))+       ; rebuild env case_expr cont }++  | otherwise+  = do { (floats, cont') <- mkDupableCaseCont env alts cont+       ; case_expr <- simplAlts (env `setInScopeFromF` floats)+                                scrut case_bndr alts cont'+       ; return (floats, case_expr) }++{-+simplCaseBinder checks whether the scrutinee is a variable, v.  If so,+try to eliminate uses of v in the RHSs in favour of case_bndr; that+way, there's a chance that v will now only be used once, and hence+inlined.++Historical note: we use to do the "case binder swap" in the Simplifier+so there were additional complications if the scrutinee was a variable.+Now the binder-swap stuff is done in the occurrence analyser; see+OccurAnal Note [Binder swap].++Note [knownCon occ info]+~~~~~~~~~~~~~~~~~~~~~~~~+If the case binder is not dead, then neither are the pattern bound+variables:+        case <any> of x { (a,b) ->+        case x of { (p,q) -> p } }+Here (a,b) both look dead, but come alive after the inner case is eliminated.+The point is that we bring into the envt a binding+        let x = (a,b)+after the outer case, and that makes (a,b) alive.  At least we do unless+the case binder is guaranteed dead.++Note [Case alternative occ info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we are simply reconstructing a case (the common case), we always+zap the occurrence info on the binders in the alternatives.  Even+if the case binder is dead, the scrutinee is usually a variable, and *that*+can bring the case-alternative binders back to life.+See Note [Add unfolding for scrutinee]++Note [Improving seq]+~~~~~~~~~~~~~~~~~~~+Consider+        type family F :: * -> *+        type instance F Int = Int++We'd like to transform+        case e of (x :: F Int) { DEFAULT -> rhs }+===>+        case e `cast` co of (x'::Int)+           I# x# -> let x = x' `cast` sym co+                    in rhs++so that 'rhs' can take advantage of the form of x'.  Notice that Note+[Case of cast] (in OccurAnal) may then apply to the result.++We'd also like to eliminate empty types (#13468). So if++    data Void+    type instance F Bool = Void++then we'd like to transform+        case (x :: F Bool) of { _ -> error "urk" }+===>+        case (x |> co) of (x' :: Void) of {}++Nota Bene: we used to have a built-in rule for 'seq' that dropped+casts, so that+    case (x |> co) of { _ -> blah }+dropped the cast; in order to improve the chances of trySeqRules+firing.  But that works in the /opposite/ direction to Note [Improving+seq] so there's a danger of flip/flopping.  Better to make trySeqRules+insensitive to the cast, which is now is.++The need for [Improving seq] showed up in Roman's experiments.  Example:+  foo :: F Int -> Int -> Int+  foo t n = t `seq` bar n+     where+       bar 0 = 0+       bar n = bar (n - case t of TI i -> i)+Here we'd like to avoid repeated evaluating t inside the loop, by+taking advantage of the `seq`.++At one point I did transformation in LiberateCase, but it's more+robust here.  (Otherwise, there's a danger that we'll simply drop the+'seq' altogether, before LiberateCase gets to see it.)+-}++simplAlts :: SimplEnv+          -> OutExpr         -- Scrutinee+          -> InId            -- Case binder+          -> [InAlt]         -- Non-empty+          -> SimplCont+          -> SimplM OutExpr  -- Returns the complete simplified case expression++simplAlts env0 scrut case_bndr alts cont'+  = do  { traceSmpl "simplAlts" (vcat [ ppr case_bndr+                                      , text "cont':" <+> ppr cont'+                                      , text "in_scope" <+> ppr (seInScope env0) ])+        ; (env1, case_bndr1) <- simplBinder env0 case_bndr+        ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding+              env2       = modifyInScope env1 case_bndr2+              -- See Note [Case binder evaluated-ness]++        ; fam_envs <- getFamEnvs+        ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut+                                                       case_bndr case_bndr2 alts++        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts+          -- NB: it's possible that the returned in_alts is empty: this is handled+          -- by the caller (rebuildCase) in the missingAlt function++        ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts+        ; -- pprTrace "simplAlts" (ppr case_bndr $$ ppr alts_ty $$ ppr alts_ty' $$ ppr alts $$ ppr cont') $++        ; let alts_ty' = contResultType cont'+        -- See Note [Avoiding space leaks in OutType]+        ; seqType alts_ty' `seq`+          mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' }+++------------------------------------+improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv+           -> OutExpr -> InId -> OutId -> [InAlt]+           -> SimplM (SimplEnv, OutExpr, OutId)+-- Note [Improving seq]+improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)]+  | Just (co, ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)+  = do { case_bndr2 <- newId (fsLit "nt") ty2+        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing+              env2 = extendIdSubst env case_bndr rhs+        ; return (env2, scrut `Cast` co, case_bndr2) }++improveSeq _ env scrut _ case_bndr1 _+  = return (env, scrut, case_bndr1)+++------------------------------------+simplAlt :: SimplEnv+         -> Maybe OutExpr  -- The scrutinee+         -> [AltCon]       -- These constructors can't be present when+                           -- matching the DEFAULT alternative+         -> OutId          -- The case binder+         -> SimplCont+         -> InAlt+         -> SimplM OutAlt++simplAlt env _ imposs_deflt_cons case_bndr' cont' (DEFAULT, bndrs, rhs)+  = ASSERT( null bndrs )+    do  { let env' = addBinderUnfolding env case_bndr'+                                        (mkOtherCon imposs_deflt_cons)+                -- Record the constructors that the case-binder *can't* be.+        ; rhs' <- simplExprC env' rhs cont'+        ; return (DEFAULT, [], rhs') }++simplAlt env scrut' _ case_bndr' cont' (LitAlt lit, bndrs, rhs)+  = ASSERT( null bndrs )+    do  { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)+        ; rhs' <- simplExprC env' rhs cont'+        ; return (LitAlt lit, [], rhs') }++simplAlt env scrut' _ case_bndr' cont' (DataAlt con, vs, rhs)+  = do  { -- See Note [Adding evaluatedness info to pattern-bound variables]+          let vs_with_evals = addEvals scrut' con vs+        ; (env', vs') <- simplLamBndrs env vs_with_evals++                -- Bind the case-binder to (con args)+        ; let inst_tys' = tyConAppArgs (idType case_bndr')+              con_app :: OutExpr+              con_app   = mkConApp2 con inst_tys' vs'++        ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app+        ; rhs' <- simplExprC env'' rhs cont'+        ; return (DataAlt con, vs', rhs') }++{- Note [Adding evaluatedness info to pattern-bound variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+addEvals records the evaluated-ness of the bound variables of+a case pattern.  This is *important*.  Consider++     data T = T !Int !Int++     case x of { T a b -> T (a+1) b }++We really must record that b is already evaluated so that we don't+go and re-evaluate it when constructing the result.+See Note [Data-con worker strictness] in MkId.hs++NB: simplLamBinders preserves this eval info++In addition to handling data constructor fields with !s, addEvals+also records the fact that the result of seq# is always in WHNF.+See Note [seq# magic] in PrelRules.  Example (#15226):++  case seq# v s of+    (# s', v' #) -> E++we want the compiler to be aware that v' is in WHNF in E.++Open problem: we don't record that v itself is in WHNF (and we can't+do it here).  The right thing is to do some kind of binder-swap;+see #15226 for discussion.+-}++addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]+-- See Note [Adding evaluatedness info to pattern-bound variables]+addEvals scrut con vs+  -- Deal with seq# applications+  | Just scr <- scrut+  , isUnboxedTupleCon con+  , [s,x] <- vs+    -- Use stripNArgs rather than collectArgsTicks to avoid building+    -- a list of arguments only to throw it away immediately.+  , Just (Var f) <- stripNArgs 4 scr+  , Just SeqOp <- isPrimOpId_maybe f+  , let x' = zapIdOccInfoAndSetEvald MarkedStrict x+  = [s, x']++  -- Deal with banged datacon fields+addEvals _scrut con vs = go vs the_strs+    where+      the_strs = dataConRepStrictness con++      go [] [] = []+      go (v:vs') strs | isTyVar v = v : go vs' strs+      go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs+      go _ _ = pprPanic "Simplify.addEvals"+                (ppr con $$+                 ppr vs  $$+                 ppr_with_length (map strdisp the_strs) $$+                 ppr_with_length (dataConRepArgTys con) $$+                 ppr_with_length (dataConRepStrictness con))+        where+          ppr_with_length list+            = ppr list <+> parens (text "length =" <+> ppr (length list))+          strdisp MarkedStrict = "MarkedStrict"+          strdisp NotMarkedStrict = "NotMarkedStrict"++zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id+zapIdOccInfoAndSetEvald str v =+  setCaseBndrEvald str $ -- Add eval'dness info+  zapIdOccInfo v         -- And kill occ info;+                         -- see Note [Case alternative occ info]++addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv+addAltUnfoldings env scrut case_bndr con_app+  = do { let con_app_unf = mk_simple_unf con_app+             env1 = addBinderUnfolding env case_bndr con_app_unf++             -- See Note [Add unfolding for scrutinee]+             env2 = case scrut of+                      Just (Var v)           -> addBinderUnfolding env1 v con_app_unf+                      Just (Cast (Var v) co) -> addBinderUnfolding env1 v $+                                                mk_simple_unf (Cast con_app (mkSymCo co))+                      _                      -> env1++       ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])+       ; return env2 }+  where+    mk_simple_unf = mkSimpleUnfolding (seDynFlags env)++addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv+addBinderUnfolding env bndr unf+  | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf+  = WARN( not (eqType (idType bndr) (exprType tmpl)),+          ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) )+    modifyInScope env (bndr `setIdUnfolding` unf)++  | otherwise+  = modifyInScope env (bndr `setIdUnfolding` unf)++zapBndrOccInfo :: Bool -> Id -> Id+-- Consider  case e of b { (a,b) -> ... }+-- Then if we bind b to (a,b) in "...", and b is not dead,+-- then we must zap the deadness info on a,b+zapBndrOccInfo keep_occ_info pat_id+  | keep_occ_info = pat_id+  | otherwise     = zapIdOccInfo pat_id++{- Note [Case binder evaluated-ness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We pin on a (OtherCon []) unfolding to the case-binder of a Case,+even though it'll be over-ridden in every case alternative with a more+informative unfolding.  Why?  Because suppose a later, less clever, pass+simply replaces all occurrences of the case binder with the binder itself;+then Lint may complain about the let/app invariant.  Example+    case e of b { DEFAULT -> let v = reallyUnsafePtrEq# b y in ....+                ; K       -> blah }++The let/app invariant requires that y is evaluated in the call to+reallyUnsafePtrEq#, which it is.  But we still want that to be true if we+propagate binders to occurrences.++This showed up in #13027.++Note [Add unfolding for scrutinee]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general it's unlikely that a variable scrutinee will appear+in the case alternatives   case x of { ...x unlikely to appear... }+because the binder-swap in OccAnal has got rid of all such occurrences+See Note [Binder swap] in OccAnal.++BUT it is still VERY IMPORTANT to add a suitable unfolding for a+variable scrutinee, in simplAlt.  Here's why+   case x of y+     (a,b) -> case b of c+                I# v -> ...(f y)...+There is no occurrence of 'b' in the (...(f y)...).  But y gets+the unfolding (a,b), and *that* mentions b.  If f has a RULE+    RULE f (p, I# q) = ...+we want that rule to match, so we must extend the in-scope env with a+suitable unfolding for 'y'.  It's *essential* for rule matching; but+it's also good for case-elimintation -- suppose that 'f' was inlined+and did multi-level case analysis, then we'd solve it in one+simplifier sweep instead of two.++Exactly the same issue arises in SpecConstr;+see Note [Add scrutinee to ValueEnv too] in SpecConstr++HOWEVER, given+  case x of y { Just a -> r1; Nothing -> r2 }+we do not want to add the unfolding x -> y to 'x', which might seem cool,+since 'y' itself has different unfoldings in r1 and r2.  Reason: if we+did that, we'd have to zap y's deadness info and that is a very useful+piece of information.++So instead we add the unfolding x -> Just a, and x -> Nothing in the+respective RHSs.+++************************************************************************+*                                                                      *+\subsection{Known constructor}+*                                                                      *+************************************************************************++We are a bit careful with occurrence info.  Here's an example++        (\x* -> case x of (a*, b) -> f a) (h v, e)++where the * means "occurs once".  This effectively becomes+        case (h v, e) of (a*, b) -> f a)+and then+        let a* = h v; b = e in f a+and then+        f (h v)++All this should happen in one sweep.+-}++knownCon :: SimplEnv+         -> OutExpr                                           -- The scrutinee+         -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr]  -- The scrutinee (in pieces)+         -> InId -> [InBndr] -> InExpr                        -- The alternative+         -> SimplCont+         -> SimplM (SimplFloats, OutExpr)++knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont+  = do  { (floats1, env1)  <- bind_args env bs dc_args+        ; (floats2, env2) <- bind_case_bndr env1+        ; (floats3, expr') <- simplExprF env2 rhs cont+        ; case dc_floats of+            [] ->+              return (floats1 `addFloats` floats2 `addFloats` floats3, expr')+            _ ->+              return ( emptyFloats env+               -- See Note [FloatBinds from constructor wrappers]+                     , MkCore.wrapFloats dc_floats $+                       wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') }+  where+    zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId++                  -- Ugh!+    bind_args env' [] _  = return (emptyFloats env', env')++    bind_args env' (b:bs') (Type ty : args)+      = ASSERT( isTyVar b )+        bind_args (extendTvSubst env' b ty) bs' args++    bind_args env' (b:bs') (Coercion co : args)+      = ASSERT( isCoVar b )+        bind_args (extendCvSubst env' b co) bs' args++    bind_args env' (b:bs') (arg : args)+      = ASSERT( isId b )+        do { let b' = zap_occ b+             -- Note that the binder might be "dead", because it doesn't+             -- occur in the RHS; and simplNonRecX may therefore discard+             -- it via postInlineUnconditionally.+             -- Nevertheless we must keep it if the case-binder is alive,+             -- because it may be used in the con_app.  See Note [knownCon occ info]+           ; (floats1, env2) <- simplNonRecX env' b' arg  -- arg satisfies let/app invariant+           ; (floats2, env3)  <- bind_args env2 bs' args+           ; return (floats1 `addFloats` floats2, env3) }++    bind_args _ _ _ =+      pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$+                             text "scrut:" <+> ppr scrut++       -- It's useful to bind bndr to scrut, rather than to a fresh+       -- binding      x = Con arg1 .. argn+       -- because very often the scrut is a variable, so we avoid+       -- creating, and then subsequently eliminating, a let-binding+       -- BUT, if scrut is a not a variable, we must be careful+       -- about duplicating the arg redexes; in that case, make+       -- a new con-app from the args+    bind_case_bndr env+      | isDeadBinder bndr   = return (emptyFloats env, env)+      | exprIsTrivial scrut = return (emptyFloats env+                                     , extendIdSubst env bndr (DoneEx scrut Nothing))+      | otherwise           = do { dc_args <- mapM (simplVar env) bs+                                         -- dc_ty_args are aready OutTypes,+                                         -- but bs are InBndrs+                                 ; let con_app = Var (dataConWorkId dc)+                                                 `mkTyApps` dc_ty_args+                                                 `mkApps`   dc_args+                                 ; simplNonRecX env bndr con_app }++-------------------+missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont+           -> SimplM (SimplFloats, OutExpr)+                -- This isn't strictly an error, although it is unusual.+                -- It's possible that the simplifier might "see" that+                -- an inner case has no accessible alternatives before+                -- it "sees" that the entire branch of an outer case is+                -- inaccessible.  So we simply put an error case here instead.+missingAlt env case_bndr _ cont+  = WARN( True, text "missingAlt" <+> ppr case_bndr )+    -- See Note [Avoiding space leaks in OutType]+    let cont_ty = contResultType cont+    in seqType cont_ty `seq`+       return (emptyFloats env, mkImpossibleExpr cont_ty)++{-+************************************************************************+*                                                                      *+\subsection{Duplicating continuations}+*                                                                      *+************************************************************************++Consider+  let x* = case e of { True -> e1; False -> e2 }+  in b+where x* is a strict binding.  Then mkDupableCont will be given+the continuation+   case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop+and will split it into+   dupable:      case [] of { True -> $j1; False -> $j2 } ; stop+   join floats:  $j1 = e1, $j2 = e2+   non_dupable:  let x* = [] in b; stop++Putting this back together would give+   let x* = let { $j1 = e1; $j2 = e2 } in+            case e of { True -> $j1; False -> $j2 }+   in b+(Of course we only do this if 'e' wants to duplicate that continuation.)+Note how important it is that the new join points wrap around the+inner expression, and not around the whole thing.++In contrast, any let-bindings introduced by mkDupableCont can wrap+around the entire thing.++Note [Bottom alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have+     case (case x of { A -> error .. ; B -> e; C -> error ..)+       of alts+then we can just duplicate those alts because the A and C cases+will disappear immediately.  This is more direct than creating+join points and inlining them away.  See #4930.+-}++--------------------+mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont+                  -> SimplM (SimplFloats, SimplCont)+mkDupableCaseCont env alts cont+  | altsWouldDup alts = mkDupableCont env cont+  | otherwise         = return (emptyFloats env, cont)++altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative+altsWouldDup []  = False        -- See Note [Bottom alternatives]+altsWouldDup [_] = False+altsWouldDup (alt:alts)+  | is_bot_alt alt = altsWouldDup alts+  | otherwise      = not (all is_bot_alt alts)+  where+    is_bot_alt (_,_,rhs) = exprIsBottom rhs++-------------------------+mkDupableCont :: SimplEnv -> SimplCont+              -> SimplM ( SimplFloats  -- Incoming SimplEnv augmented with+                                       --   extra let/join-floats and in-scope variables+                        , SimplCont)   -- dup_cont: duplicable continuation++mkDupableCont env cont+  | contIsDupable cont+  = return (emptyFloats env, cont)++mkDupableCont _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn++mkDupableCont env (CastIt ty cont)+  = do  { (floats, cont') <- mkDupableCont env cont+        ; return (floats, CastIt ty cont') }++-- Duplicating ticks for now, not sure if this is good or not+mkDupableCont env (TickIt t cont)+  = do  { (floats, cont') <- mkDupableCont env cont+        ; return (floats, TickIt t cont') }++mkDupableCont env (StrictBind { sc_bndr = bndr, sc_bndrs = bndrs+                              , sc_body = body, sc_env = se, sc_cont = cont})+  -- See Note [Duplicating StrictBind]+  = do { let sb_env = se `setInScopeFromE` env+       ; (sb_env1, bndr') <- simplBinder sb_env bndr+       ; (floats1, join_inner) <- simplLam sb_env1 bndrs body cont+          -- No need to use mkDupableCont before simplLam; we+          -- use cont once here, and then share the result if necessary++       ; let join_body = wrapFloats floats1 join_inner+             res_ty    = contResultType cont++       ; (floats2, body2)+            <- if exprIsDupable (seDynFlags env) join_body+               then return (emptyFloats env, join_body)+               else do { join_bndr <- newJoinId [bndr'] res_ty+                       ; let join_call = App (Var join_bndr) (Var bndr')+                             join_rhs  = Lam (setOneShotLambda bndr') join_body+                             join_bind = NonRec join_bndr join_rhs+                             floats    = emptyFloats env `extendFloats` join_bind+                       ; return (floats, join_call) }+       ; return ( floats2+                , StrictBind { sc_bndr = bndr', sc_bndrs = []+                             , sc_body = body2+                             , sc_env  = zapSubstEnv se `setInScopeFromF` floats2+                                         -- See Note [StaticEnv invariant] in SimplUtils+                             , sc_dup  = OkToDup+                             , sc_cont = mkBoringStop res_ty } ) }++mkDupableCont env (StrictArg { sc_fun = info, sc_cci = cci, sc_cont = cont })+        -- See Note [Duplicating StrictArg]+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+  = do { (floats1, cont') <- mkDupableCont env cont+       ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg (getMode env))+                                           (ai_args info)+       ; return ( foldl' addLetFloats floats1 floats_s+                , StrictArg { sc_fun = info { ai_args = args' }+                            , sc_cci = cci+                            , sc_cont = cont'+                            , sc_dup = OkToDup} ) }++mkDupableCont env (ApplyToTy { sc_cont = cont+                             , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })+  = do  { (floats, cont') <- mkDupableCont env cont+        ; return (floats, ApplyToTy { sc_cont = cont'+                                    , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }++mkDupableCont env (ApplyToVal { sc_arg = arg, sc_dup = dup+                              , sc_env = se, sc_cont = cont })+  =     -- e.g.         [...hole...] (...arg...)+        --      ==>+        --              let a = ...arg...+        --              in [...hole...] a+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+    do  { (floats1, cont') <- mkDupableCont env cont+        ; let env' = env `setInScopeFromF` floats1+        ; (_, se', arg') <- simplArg env' dup se arg+        ; (let_floats2, arg'') <- makeTrivial (getMode env) NotTopLevel (fsLit "karg") arg'+        ; let all_floats = floats1 `addLetFloats` let_floats2+        ; return ( all_floats+                 , ApplyToVal { sc_arg = arg''+                              , sc_env = se' `setInScopeFromF` all_floats+                                         -- Ensure that sc_env includes the free vars of+                                         -- arg'' in its in-scope set, even if makeTrivial+                                         -- has turned arg'' into a fresh variable+                                         -- See Note [StaticEnv invariant] in SimplUtils+                              , sc_dup = OkToDup, sc_cont = cont' }) }++mkDupableCont env (Select { sc_bndr = case_bndr, sc_alts = alts+                          , sc_env = se, sc_cont = cont })+  =     -- e.g.         (case [...hole...] of { pi -> ei })+        --      ===>+        --              let ji = \xij -> ei+        --              in case [...hole...] of { pi -> ji xij }+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+    do  { tick (CaseOfCase case_bndr)+        ; (floats, alt_cont) <- mkDupableCaseCont env alts cont+                -- NB: We call mkDupableCaseCont here to make cont duplicable+                --     (if necessary, depending on the number of alts)+                -- And this is important: see Note [Fusing case continuations]++        ; let alt_env = se `setInScopeFromF` floats+        ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr+        ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) alts+        -- Safe to say that there are no handled-cons for the DEFAULT case+                -- NB: simplBinder does not zap deadness occ-info, so+                -- a dead case_bndr' will still advertise its deadness+                -- This is really important because in+                --      case e of b { (# p,q #) -> ... }+                -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),+                -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.+                -- In the new alts we build, we have the new case binder, so it must retain+                -- its deadness.+        -- NB: we don't use alt_env further; it has the substEnv for+        --     the alternatives, and we don't want that++        ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (seDynFlags env) case_bndr')+                                              emptyJoinFloats alts'++        ; let all_floats = floats `addJoinFloats` join_floats+                           -- Note [Duplicated env]+        ; return (all_floats+                 , Select { sc_dup  = OkToDup+                          , sc_bndr = case_bndr'+                          , sc_alts = alts''+                          , sc_env  = zapSubstEnv se `setInScopeFromF` all_floats+                                      -- See Note [StaticEnv invariant] in SimplUtils+                          , sc_cont = mkBoringStop (contResultType cont) } ) }++mkDupableAlt :: DynFlags -> OutId+             -> JoinFloats -> OutAlt+             -> SimplM (JoinFloats, OutAlt)+mkDupableAlt dflags case_bndr jfloats (con, bndrs', rhs')+  | exprIsDupable dflags rhs'  -- Note [Small alternative rhs]+  = return (jfloats, (con, bndrs', rhs'))++  | otherwise+  = do  { let rhs_ty'  = exprType rhs'+              scrut_ty = idType case_bndr+              case_bndr_w_unf+                = case con of+                      DEFAULT    -> case_bndr+                      DataAlt dc -> setIdUnfolding case_bndr unf+                          where+                                 -- See Note [Case binders and join points]+                             unf = mkInlineUnfolding rhs+                             rhs = mkConApp2 dc (tyConAppArgs scrut_ty) bndrs'++                      LitAlt {} -> WARN( True, text "mkDupableAlt"+                                                <+> ppr case_bndr <+> ppr con )+                                   case_bndr+                           -- The case binder is alive but trivial, so why has+                           -- it not been substituted away?++              final_bndrs'+                | isDeadBinder case_bndr = filter abstract_over bndrs'+                | otherwise              = bndrs' ++ [case_bndr_w_unf]++              abstract_over bndr+                  | isTyVar bndr = True -- Abstract over all type variables just in case+                  | otherwise    = not (isDeadBinder bndr)+                        -- The deadness info on the new Ids is preserved by simplBinders+              final_args = varsToCoreExprs final_bndrs'+                           -- Note [Join point abstraction]++                -- We make the lambdas into one-shot-lambdas.  The+                -- join point is sure to be applied at most once, and doing so+                -- prevents the body of the join point being floated out by+                -- the full laziness pass+              really_final_bndrs     = map one_shot final_bndrs'+              one_shot v | isId v    = setOneShotLambda v+                         | otherwise = v+              join_rhs   = mkLams really_final_bndrs rhs'++        ; join_bndr <- newJoinId final_bndrs' rhs_ty'++        ; let join_call = mkApps (Var join_bndr) final_args+              alt'      = (con, bndrs', join_call)++        ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)+                 , alt') }+                -- See Note [Duplicated env]++{-+Note [Fusing case continuations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important to fuse two successive case continuations when the+first has one alternative.  That's why we call prepareCaseCont here.+Consider this, which arises from thunk splitting (see Note [Thunk+splitting] in WorkWrap):++      let+        x* = case (case v of {pn -> rn}) of+               I# a -> I# a+      in body++The simplifier will find+    (Var v) with continuation+            Select (pn -> rn) (+            Select [I# a -> I# a] (+            StrictBind body Stop++So we'll call mkDupableCont on+   Select [I# a -> I# a] (StrictBind body Stop)+There is just one alternative in the first Select, so we want to+simplify the rhs (I# a) with continuation (StrictBind body Stop)+Supposing that body is big, we end up with+          let $j a = <let x = I# a in body>+          in case v of { pn -> case rn of+                                 I# a -> $j a }+This is just what we want because the rn produces a box that+the case rn cancels with.++See #4957 a fuller example.++Note [Case binders and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   case (case .. ) of c {+     I# c# -> ....c....++If we make a join point with c but not c# we get+  $j = \c -> ....c....++But if later inlining scrutinises the c, thus++  $j = \c -> ... case c of { I# y -> ... } ...++we won't see that 'c' has already been scrutinised.  This actually+happens in the 'tabulate' function in wave4main, and makes a significant+difference to allocation.++An alternative plan is this:++   $j = \c# -> let c = I# c# in ...c....++but that is bad if 'c' is *not* later scrutinised.++So instead we do both: we pass 'c' and 'c#' , and record in c's inlining+(a stable unfolding) that it's really I# c#, thus++   $j = \c# -> \c[=I# c#] -> ...c....++Absence analysis may later discard 'c'.++NB: take great care when doing strictness analysis;+    see Note [Lambda-bound unfoldings] in DmdAnal.++Also note that we can still end up passing stuff that isn't used.  Before+strictness analysis we have+   let $j x y c{=(x,y)} = (h c, ...)+   in ...+After strictness analysis we see that h is strict, we end up with+   let $j x y c{=(x,y)} = ($wh x y, ...)+and c is unused.++Note [Duplicated env]+~~~~~~~~~~~~~~~~~~~~~+Some of the alternatives are simplified, but have not been turned into a join point+So they *must* have a zapped subst-env.  So we can't use completeNonRecX to+bind the join point, because it might to do PostInlineUnconditionally, and+we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,+but zapping it (as we do in mkDupableCont, the Select case) is safe, and+at worst delays the join-point inlining.++Note [Small alternative rhs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is worth checking for a small RHS because otherwise we+get extra let bindings that may cause an extra iteration of the simplifier to+inline back in place.  Quite often the rhs is just a variable or constructor.+The Ord instance of Maybe in PrelMaybe.hs, for example, took several extra+iterations because the version with the let bindings looked big, and so wasn't+inlined, but after the join points had been inlined it looked smaller, and so+was inlined.++NB: we have to check the size of rhs', not rhs.+Duplicating a small InAlt might invalidate occurrence information+However, if it *is* dupable, we return the *un* simplified alternative,+because otherwise we'd need to pair it up with an empty subst-env....+but we only have one env shared between all the alts.+(Remember we must zap the subst-env before re-simplifying something).+Rather than do this we simply agree to re-simplify the original (small) thing later.++Note [Funky mkLamTypes]+~~~~~~~~~~~~~~~~~~~~~~+Notice the funky mkLamTypes.  If the constructor has existentials+it's possible that the join point will be abstracted over+type variables as well as term variables.+ Example:  Suppose we have+        data T = forall t.  C [t]+ Then faced with+        case (case e of ...) of+            C t xs::[t] -> rhs+ We get the join point+        let j :: forall t. [t] -> ...+            j = /\t \xs::[t] -> rhs+        in+        case (case e of ...) of+            C t xs::[t] -> j t xs++Note [Duplicating StrictArg]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We make a StrictArg duplicable simply by making all its+stored-up arguments (in sc_fun) trivial, by let-binding+them.  Thus:+        f E [..hole..]+        ==>     let a = E+                in f a [..hole..]+Now if the thing in the hole is a case expression (which is when+we'll call mkDupableCont), we'll push the function call into the+branches, which is what we want.  Now RULES for f may fire, and+call-pattern specialisation.  Here's an example from #3116+     go (n+1) (case l of+                 1  -> bs'+                 _  -> Chunk p fpc (o+1) (l-1) bs')+If we can push the call for 'go' inside the case, we get+call-pattern specialisation for 'go', which is *crucial* for+this program.++Here is the (&&) example:+        && E (case x of { T -> F; F -> T })+  ==>   let a = E in+        case x of { T -> && a F; F -> && a T }+Much better!++Notice that+  * Arguments to f *after* the strict one are handled by+    the ApplyToVal case of mkDupableCont.  Eg+        f [..hole..] E++  * We can only do the let-binding of E because the function+    part of a StrictArg continuation is an explicit syntax+    tree.  In earlier versions we represented it as a function+    (CoreExpr -> CoreEpxr) which we couldn't take apart.++Historical aide: previously we did this (where E is a+big argument:+        f E [..hole..]+        ==>     let $j = \a -> f E a+                in $j [..hole..]++But this is terrible! Here's an example:+        && E (case x of { T -> F; F -> T })+Now, && is strict so we end up simplifying the case with+an ArgOf continuation.  If we let-bind it, we get+        let $j = \v -> && E v+        in simplExpr (case x of { T -> F; F -> T })+                     (ArgOf (\r -> $j r)+And after simplifying more we get+        let $j = \v -> && E v+        in case x of { T -> $j F; F -> $j T }+Which is a Very Bad Thing+++Note [Duplicating StrictBind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We make a StrictBind duplicable in a very similar way to+that for case expressions.  After all,+   let x* = e in b   is similar to    case e of x -> b++So we potentially make a join-point for the body, thus:+   let x = [] in b   ==>   join j x = b+                           in let x = [] in j x+++Note [Join point abstraction]  Historical note+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: This note is now historical, describing how (in the past) we used+to add a void argument to nullary join points.  But now that "join+point" is not a fuzzy concept but a formal syntactic construct (as+distinguished by the JoinId constructor of IdDetails), each of these+concerns is handled separately, with no need for a vestigial extra+argument.++Join points always have at least one value argument,+for several reasons++* If we try to lift a primitive-typed something out+  for let-binding-purposes, we will *caseify* it (!),+  with potentially-disastrous strictness results.  So+  instead we turn it into a function: \v -> e+  where v::Void#.  The value passed to this function is void,+  which generates (almost) no code.++* CPR.  We used to say "&& isUnliftedType rhs_ty'" here, but now+  we make the join point into a function whenever used_bndrs'+  is empty.  This makes the join-point more CPR friendly.+  Consider:       let j = if .. then I# 3 else I# 4+                  in case .. of { A -> j; B -> j; C -> ... }++  Now CPR doesn't w/w j because it's a thunk, so+  that means that the enclosing function can't w/w either,+  which is a lose.  Here's the example that happened in practice:+          kgmod :: Int -> Int -> Int+          kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0+                      then 78+                      else 5++* Let-no-escape.  We want a join point to turn into a let-no-escape+  so that it is implemented as a jump, and one of the conditions+  for LNE is that it's not updatable.  In CoreToStg, see+  Note [What is a non-escaping let]++* Floating.  Since a join point will be entered once, no sharing is+  gained by floating out, but something might be lost by doing+  so because it might be allocated.++I have seen a case alternative like this:+        True -> \v -> ...+It's a bit silly to add the realWorld dummy arg in this case, making+        $j = \s v -> ...+           True -> $j s+(the \v alone is enough to make CPR happy) but I think it's rare++There's a slight infelicity here: we pass the overall+case_bndr to all the join points if it's used in *any* RHS,+because we don't know its usage in each RHS separately++++************************************************************************+*                                                                      *+                    Unfoldings+*                                                                      *+************************************************************************+-}++simplLetUnfolding :: SimplEnv-> TopLevelFlag+                  -> MaybeJoinCont+                  -> InId+                  -> OutExpr -> OutType+                  -> Unfolding -> SimplM Unfolding+simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty unf+  | isStableUnfolding unf+  = simplStableUnfolding env top_lvl cont_mb id unf rhs_ty+  | isExitJoinId id+  = return noUnfolding -- See Note [Do not inline exit join points] in Exitify+  | otherwise+  = mkLetUnfolding (seDynFlags env) top_lvl InlineRhs id new_rhs++-------------------+mkLetUnfolding :: DynFlags -> TopLevelFlag -> UnfoldingSource+               -> InId -> OutExpr -> SimplM Unfolding+mkLetUnfolding dflags top_lvl src id new_rhs+  = is_bottoming `seq`  -- See Note [Force bottoming field]+    return (mkUnfolding dflags src is_top_lvl is_bottoming new_rhs)+            -- We make an  unfolding *even for loop-breakers*.+            -- Reason: (a) It might be useful to know that they are WHNF+            --         (b) In TidyPgm we currently assume that, if we want to+            --             expose the unfolding then indeed we *have* an unfolding+            --             to expose.  (We could instead use the RHS, but currently+            --             we don't.)  The simple thing is always to have one.+  where+    is_top_lvl   = isTopLevel top_lvl+    is_bottoming = isBottomingId id++-------------------+simplStableUnfolding :: SimplEnv -> TopLevelFlag+                     -> MaybeJoinCont  -- Just k => a join point with continuation k+                     -> InId+                     -> Unfolding -> OutType -> SimplM Unfolding+-- Note [Setting the new unfolding]+simplStableUnfolding env top_lvl mb_cont id unf rhs_ty+  = case unf of+      NoUnfolding   -> return unf+      BootUnfolding -> return unf+      OtherCon {}   -> return unf++      DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }+        -> do { (env', bndrs') <- simplBinders unf_env bndrs+              ; args' <- mapM (simplExpr env') args+              ; return (mkDFunUnfolding bndrs' con args') }++      CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }+        | isStableSource src+        -> do { expr' <- case mb_cont of -- See Note [Rules and unfolding for join points]+                           Just cont -> simplJoinRhs unf_env id expr cont+                           Nothing   -> simplExprC unf_env expr (mkBoringStop rhs_ty)+              ; case guide of+                  UnfWhen { ug_arity = arity+                          , ug_unsat_ok = sat_ok+                          , ug_boring_ok = boring_ok+                          }+                          -- Happens for INLINE things+                     -> let guide' =+                              UnfWhen { ug_arity = arity+                                      , ug_unsat_ok = sat_ok+                                      , ug_boring_ok =+                                          boring_ok || inlineBoringOk expr'+                                      }+                        -- Refresh the boring-ok flag, in case expr'+                        -- has got small. This happens, notably in the inlinings+                        -- for dfuns for single-method classes; see+                        -- Note [Single-method classes] in TcInstDcls.+                        -- A test case is #4138+                        -- But retain a previous boring_ok of True; e.g. see+                        -- the way it is set in calcUnfoldingGuidanceWithArity+                        in return (mkCoreUnfolding src is_top_lvl expr' guide')+                            -- See Note [Top-level flag on inline rules] in CoreUnfold++                  _other              -- Happens for INLINABLE things+                     -> mkLetUnfolding dflags top_lvl src id expr' }+                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE+                -- unfolding, and we need to make sure the guidance is kept up+                -- to date with respect to any changes in the unfolding.++        | otherwise -> return noUnfolding   -- Discard unstable unfoldings+  where+    dflags     = seDynFlags env+    is_top_lvl = isTopLevel top_lvl+    act        = idInlineActivation id+    unf_env    = updMode (updModeForStableUnfoldings act) env+         -- See Note [Simplifying inside stable unfoldings] in SimplUtils++{-+Note [Force bottoming field]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to force bottoming, or the new unfolding holds+on to the old unfolding (which is part of the id).++Note [Setting the new unfolding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we+  should do nothing at all, but simplifying gently might get rid of+  more crap.++* If not, we make an unfolding from the new RHS.  But *only* for+  non-loop-breakers. Making loop breakers not have an unfolding at all+  means that we can avoid tests in exprIsConApp, for example.  This is+  important: if exprIsConApp says 'yes' for a recursive thing, then we+  can get into an infinite loop++If there's a stable unfolding on a loop breaker (which happens for+INLINABLE), we hang on to the inlining.  It's pretty dodgy, but the+user did say 'INLINE'.  May need to revisit this choice.++************************************************************************+*                                                                      *+                    Rules+*                                                                      *+************************************************************************++Note [Rules in a letrec]+~~~~~~~~~~~~~~~~~~~~~~~~+After creating fresh binders for the binders of a letrec, we+substitute the RULES and add them back onto the binders; this is done+*before* processing any of the RHSs.  This is important.  Manuel found+cases where he really, really wanted a RULE for a recursive function+to apply in that function's own right-hand side.++See Note [Forming Rec groups] in OccurAnal+-}++addBndrRules :: SimplEnv -> InBndr -> OutBndr+             -> MaybeJoinCont   -- Just k for a join point binder+                                -- Nothing otherwise+             -> SimplM (SimplEnv, OutBndr)+-- Rules are added back into the bin+addBndrRules env in_id out_id mb_cont+  | null old_rules+  = return (env, out_id)+  | otherwise+  = do { new_rules <- simplRules env (Just out_id) old_rules mb_cont+       ; let final_id  = out_id `setIdSpecialisation` mkRuleInfo new_rules+       ; return (modifyInScope env final_id, final_id) }+  where+    old_rules = ruleInfoRules (idSpecialisation in_id)++simplRules :: SimplEnv -> Maybe OutId -> [CoreRule]+           -> MaybeJoinCont -> SimplM [CoreRule]+simplRules env mb_new_id rules mb_cont+  = mapM simpl_rule rules+  where+    simpl_rule rule@(BuiltinRule {})+      = return rule++    simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args+                          , ru_fn = fn_name, ru_rhs = rhs })+      = do { (env', bndrs') <- simplBinders env bndrs+           ; let rhs_ty = substTy env' (exprType rhs)+                 rhs_cont = case mb_cont of  -- See Note [Rules and unfolding for join points]+                                Nothing   -> mkBoringStop rhs_ty+                                Just cont -> ASSERT2( join_ok, bad_join_msg )+                                             cont+                 rule_env = updMode updModeForRules env'+                 fn_name' = case mb_new_id of+                              Just id -> idName id+                              Nothing -> fn_name++                 -- join_ok is an assertion check that the join-arity of the+                 -- binder matches that of the rule, so that pushing the+                 -- continuation into the RHS makes sense+                 join_ok = case mb_new_id of+                             Just id | Just join_arity <- isJoinId_maybe id+                                     -> length args == join_arity+                             _ -> False+                 bad_join_msg = vcat [ ppr mb_new_id, ppr rule+                                     , ppr (fmap isJoinId_maybe mb_new_id) ]++           ; args' <- mapM (simplExpr rule_env) args+           ; rhs'  <- simplExprC rule_env rhs rhs_cont+           ; return (rule { ru_bndrs = bndrs'+                          , ru_fn    = fn_name'+                          , ru_args  = args'+                          , ru_rhs   = rhs' }) }
+ compiler/simplStg/SimplStg.hs view
@@ -0,0 +1,140 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section[SimplStg]{Driver for simplifying @STG@ programs}+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module SimplStg ( stg2stg ) where++#include "HsVersions.h"++import GhcPrelude++import StgSyn++import StgLint          ( lintStgTopBindings )+import StgStats         ( showStgStats )+import UnariseStg       ( unarise )+import StgCse           ( stgCse )+import StgLiftLams      ( stgLiftLams )+import Module           ( Module )++import DynFlags+import ErrUtils+import UniqSupply+import Outputable+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.State.Strict++newtype StgM a = StgM { _unStgM :: StateT UniqSupply IO a }+  deriving (Functor, Applicative, Monad, MonadIO)++instance MonadUnique StgM where+  getUniqueSupplyM = StgM (state splitUniqSupply)+  getUniqueM = StgM (state takeUniqFromSupply)++runStgM :: UniqSupply -> StgM a -> IO a+runStgM us (StgM m) = evalStateT m us++stg2stg :: DynFlags                  -- includes spec of what stg-to-stg passes to do+        -> Module                    -- module being compiled+        -> [StgTopBinding]           -- input program+        -> IO [StgTopBinding]        -- output program++stg2stg dflags this_mod binds+  = do  { showPass dflags "Stg2Stg"+        ; us <- mkSplitUniqSupply 'g'++        -- Do the main business!+        ; binds' <- runStgM us $+            foldM do_stg_pass binds (getStgToDo dflags)++        ; dump_when Opt_D_dump_stg "STG syntax:" binds'++        ; return binds'+   }++  where+    stg_linter what+      | gopt Opt_DoStgLinting dflags+      = lintStgTopBindings dflags this_mod what+      | otherwise+      = \ _whodunnit _binds -> return ()++    -------------------------------------------+    do_stg_pass :: [StgTopBinding] -> StgToDo -> StgM [StgTopBinding]+    do_stg_pass binds to_do+      = case to_do of+          StgDoNothing ->+            return binds++          StgStats ->+            trace (showStgStats binds) (return binds)++          StgCSE -> do+            let binds' = {-# SCC "StgCse" #-} stgCse binds+            end_pass "StgCse" binds'++          StgLiftLams -> do+            us <- getUniqueSupplyM+            let binds' = {-# SCC "StgLiftLams" #-} stgLiftLams dflags us binds+            end_pass "StgLiftLams" binds'++          StgUnarise -> do+            liftIO (dump_when Opt_D_dump_stg "Pre unarise:" binds)+            us <- getUniqueSupplyM+            liftIO (stg_linter False "Pre-unarise" binds)+            let binds' = unarise us binds+            liftIO (stg_linter True "Unarise" binds')+            return binds'++    dump_when flag header binds+      = dumpIfSet_dyn dflags flag header (pprStgTopBindings binds)++    end_pass what binds2+      = liftIO $ do -- report verbosely, if required+          dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what+            (vcat (map ppr binds2))+          stg_linter False what binds2+          return binds2++-- -----------------------------------------------------------------------------+-- StgToDo:  abstraction of stg-to-stg passes to run.++-- | Optional Stg-to-Stg passes.+data StgToDo+  = StgCSE+  -- ^ Common subexpression elimination+  | StgLiftLams+  -- ^ Lambda lifting closure variables, trading stack/register allocation for+  -- heap allocation+  | StgStats+  | StgUnarise+  -- ^ Mandatory unarise pass, desugaring unboxed tuple and sum binders+  | StgDoNothing+  -- ^ Useful for building up 'getStgToDo'+  deriving Eq++-- | Which Stg-to-Stg passes to run. Depends on flags, ways etc.+getStgToDo :: DynFlags -> [StgToDo]+getStgToDo dflags =+  filter (/= StgDoNothing)+    [ mandatory StgUnarise+    -- Important that unarisation comes first+    -- See Note [StgCse after unarisation] in StgCse+    , optional Opt_StgCSE StgCSE+    , optional Opt_StgLiftLams StgLiftLams+    , optional Opt_StgStats StgStats+    ] where+      optional opt = runWhen (gopt opt dflags)+      mandatory = id++runWhen :: Bool -> StgToDo -> StgToDo+runWhen True todo = todo+runWhen _    _    = StgDoNothing
+ compiler/simplStg/StgCse.hs view
@@ -0,0 +1,483 @@+{-# LANGUAGE TypeFamilies #-}++{-|+Note [CSE for Stg]+~~~~~~~~~~~~~~~~~~+This module implements a simple common subexpression elimination pass for STG.+This is useful because there are expressions that we want to common up (because+they are operationally equivalent), but that we cannot common up in Core, because+their types differ.+This was originally reported as #9291.++There are two types of common code occurrences that we aim for, see+note [Case 1: CSEing allocated closures] and+note [Case 2: CSEing case binders] below.+++Note [Case 1: CSEing allocated closures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The first kind of CSE opportunity we aim for is generated by this Haskell code:++    bar :: a -> (Either Int a, Either Bool a)+    bar x = (Right x, Right x)++which produces this Core:++    bar :: forall a. a -> (Either Int a, Either Bool a)+    bar @a x = (Right @Int @a x, Right @Bool @a x)++where the two components of the tuple are different terms, and cannot be+commoned up (easily). On the STG level we have++    bar [x] = let c1 = Right [x]+                  c2 = Right [x]+              in (c1,c2)++and now it is obvious that we can write++    bar [x] = let c1 = Right [x]+              in (c1,c1)++instead.+++Note [Case 2: CSEing case binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The second kind of CSE opportunity we aim for is more interesting, and+came up in #9291 and #5344: The Haskell code++    foo :: Either Int a -> Either Bool a+    foo (Right x) = Right x+    foo _         = Left False++produces this Core++    foo :: forall a. Either Int a -> Either Bool a+    foo @a e = case e of b { Left n -> …+                           , Right x -> Right @Bool @a x }++where we cannot CSE `Right @Bool @a x` with the case binder `b` as they have+different types. But in STG we have++    foo [e] = case e of b { Left [n] -> …+                          , Right [x] -> Right [x] }++and nothing stops us from transforming that to++    foo [e] = case e of b { Left [n] -> …+                          , Right [x] -> b}+++Note [StgCse after unarisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider two unboxed sum terms:++    (# 1 | #) :: (# Int | Int# #)+    (# 1 | #) :: (# Int | Int  #)++These two terms are not equal as they unarise to different unboxed+tuples. However if we run StgCse before Unarise, it'll think the two+terms (# 1 | #) are equal, and replace one of these with a binder to+the other. That's bad -- #15300.++Solution: do unarise first.++-}++module StgCse (stgCse) where++import GhcPrelude++import DataCon+import Id+import StgSyn+import Outputable+import VarEnv+import CoreSyn (AltCon(..))+import Data.List (mapAccumL)+import Data.Maybe (fromMaybe)+import CoreMap+import NameEnv+import Control.Monad( (>=>) )++--------------+-- The Trie --+--------------++-- A lookup trie for data constructor applications, i.e.+-- keys of type `(DataCon, [StgArg])`, following the patterns in TrieMap.++data StgArgMap a = SAM+    { sam_var :: DVarEnv a+    , sam_lit :: LiteralMap a+    }++instance TrieMap StgArgMap where+    type Key StgArgMap = StgArg+    emptyTM  = SAM { sam_var = emptyTM+                   , sam_lit = emptyTM }+    lookupTM (StgVarArg var) = sam_var >.> lkDFreeVar var+    lookupTM (StgLitArg lit) = sam_lit >.> lookupTM lit+    alterTM  (StgVarArg var) f m = m { sam_var = sam_var m |> xtDFreeVar var f }+    alterTM  (StgLitArg lit) f m = m { sam_lit = sam_lit m |> alterTM lit f }+    foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m)+    mapTM f (SAM {sam_var = varm, sam_lit = litm}) =+        SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm }++newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) }++instance TrieMap ConAppMap where+    type Key ConAppMap = (DataCon, [StgArg])+    emptyTM  = CAM emptyTM+    lookupTM (dataCon, args) = un_cam >.> lkDNamed dataCon >=> lookupTM args+    alterTM  (dataCon, args) f m =+        m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f }+    foldTM k = un_cam >.> foldTM (foldTM k)+    mapTM f  = un_cam >.> mapTM (mapTM f) >.> CAM++-----------------+-- The CSE Env --+-----------------++-- | The CSE environment. See note [CseEnv Example]+data CseEnv = CseEnv+    { ce_conAppMap :: ConAppMap OutId+        -- ^ The main component of the environment is the trie that maps+        --   data constructor applications (with their `OutId` arguments)+        --   to an in-scope name that can be used instead.+        --   This name is always either a let-bound variable or a case binder.+    , ce_subst     :: IdEnv OutId+        -- ^ This substitution is applied to the code as we traverse it.+        --   Entries have one of two reasons:+        --+        --   * The input might have shadowing (see Note [Shadowing]), so we have+        --     to rename some binders as we traverse the tree.+        --   * If we remove `let x = Con z` because  `let y = Con z` is in scope,+        --     we note this here as x ↦ y.+    , ce_bndrMap     :: IdEnv OutId+        -- ^ If we come across a case expression case x as b of … with a trivial+        --   binder, we add b ↦ x to this.+        --   This map is *only* used when looking something up in the ce_conAppMap.+        --   See Note [Trivial case scrutinee]+    , ce_in_scope  :: InScopeSet+        -- ^ The third component is an in-scope set, to rename away any+        --   shadowing binders+    }++{-|+Note [CseEnv Example]+~~~~~~~~~~~~~~~~~~~~~+The following tables shows how the CseEnvironment changes as code is traversed,+as well as the changes to that code.++  InExpr                         OutExpr+     conAppMap                   subst          in_scope+  ───────────────────────────────────────────────────────────+  -- empty                       {}             {}+  case … as a of {Con x y ->     case … as a of {Con x y ->+  -- Con x y ↦ a                 {}             {a,x,y}+  let b = Con x y                (removed)+  -- Con x y ↦ a                 b↦a            {a,x,y,b}+  let c = Bar a                  let c = Bar a+  -- Con x y ↦ a, Bar a ↦ c      b↦a            {a,x,y,b,c}+  let c = some expression        let c' = some expression+  -- Con x y ↦ a, Bar a ↦ c      b↦a, c↦c',     {a,x,y,b,c,c'}+  let d = Bar b                  (removed)+  -- Con x y ↦ a, Bar a ↦ c      b↦a, c↦c', d↦c {a,x,y,b,c,c',d}+  (a, b, c d)                    (a, a, c' c)+-}++initEnv :: InScopeSet -> CseEnv+initEnv in_scope = CseEnv+    { ce_conAppMap = emptyTM+    , ce_subst     = emptyVarEnv+    , ce_bndrMap   = emptyVarEnv+    , ce_in_scope  = in_scope+    }++envLookup :: DataCon -> [OutStgArg] -> CseEnv -> Maybe OutId+envLookup dataCon args env = lookupTM (dataCon, args') (ce_conAppMap env)+  where args' = map go args -- See Note [Trivial case scrutinee]+        go (StgVarArg v  ) = StgVarArg (fromMaybe v $ lookupVarEnv (ce_bndrMap env) v)+        go (StgLitArg lit) = StgLitArg lit++addDataCon :: OutId -> DataCon -> [OutStgArg] -> CseEnv -> CseEnv+-- do not bother with nullary data constructors, they are static anyways+addDataCon _ _ [] env = env+addDataCon bndr dataCon args env = env { ce_conAppMap = new_env }+  where+    new_env = insertTM (dataCon, args) bndr (ce_conAppMap env)++forgetCse :: CseEnv -> CseEnv+forgetCse env = env { ce_conAppMap = emptyTM }+    -- See note [Free variables of an StgClosure]++addSubst :: OutId -> OutId -> CseEnv -> CseEnv+addSubst from to env+    = env { ce_subst = extendVarEnv (ce_subst env) from to }++addTrivCaseBndr :: OutId -> OutId -> CseEnv -> CseEnv+addTrivCaseBndr from to env+    = env { ce_bndrMap = extendVarEnv (ce_bndrMap env) from to }++substArgs :: CseEnv -> [InStgArg] -> [OutStgArg]+substArgs env = map (substArg env)++substArg :: CseEnv -> InStgArg -> OutStgArg+substArg env (StgVarArg from) = StgVarArg (substVar env from)+substArg _   (StgLitArg lit)  = StgLitArg lit++substVar :: CseEnv -> InId -> OutId+substVar env id = fromMaybe id $ lookupVarEnv (ce_subst env) id++-- Functions to enter binders++-- This is much simpler than the equivalent code in CoreSubst:+--  * We do not substitute type variables, and+--  * There is nothing relevant in IdInfo at this stage+--    that needs substitutions.+-- Therefore, no special treatment for a recursive group is required.++substBndr :: CseEnv -> InId -> (CseEnv, OutId)+substBndr env old_id+  = (new_env, new_id)+  where+    new_id = uniqAway (ce_in_scope env) old_id+    no_change = new_id == old_id+    env' = env { ce_in_scope = ce_in_scope env `extendInScopeSet` new_id }+    new_env | no_change = env'+            | otherwise = env' { ce_subst = extendVarEnv (ce_subst env) old_id new_id }++substBndrs :: CseEnv -> [InVar] -> (CseEnv, [OutVar])+substBndrs env bndrs = mapAccumL substBndr env bndrs++substPairs :: CseEnv -> [(InVar, a)] -> (CseEnv, [(OutVar, a)])+substPairs env bndrs = mapAccumL go env bndrs+  where go env (id, x) = let (env', id') = substBndr env id+                         in (env', (id', x))++-- Main entry point++stgCse :: [InStgTopBinding] -> [OutStgTopBinding]+stgCse binds = snd $ mapAccumL stgCseTopLvl emptyInScopeSet binds++-- Top level bindings.+--+-- We do not CSE these, as top-level closures are allocated statically anyways.+-- Also, they might be exported.+-- But we still have to collect the set of in-scope variables, otherwise+-- uniqAway might shadow a top-level closure.++stgCseTopLvl :: InScopeSet -> InStgTopBinding -> (InScopeSet, OutStgTopBinding)+stgCseTopLvl in_scope t@(StgTopStringLit _ _) = (in_scope, t)+stgCseTopLvl in_scope (StgTopLifted (StgNonRec bndr rhs))+    = (in_scope'+      , StgTopLifted (StgNonRec bndr (stgCseTopLvlRhs in_scope rhs)))+  where in_scope' = in_scope `extendInScopeSet` bndr++stgCseTopLvl in_scope (StgTopLifted (StgRec eqs))+    = ( in_scope'+      , StgTopLifted (StgRec [ (bndr, stgCseTopLvlRhs in_scope' rhs) | (bndr, rhs) <- eqs ]))+  where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ]++stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs+stgCseTopLvlRhs in_scope (StgRhsClosure ext ccs upd args body)+    = let body' = stgCseExpr (initEnv in_scope) body+      in  StgRhsClosure ext ccs upd args body'+stgCseTopLvlRhs _ (StgRhsCon ccs dataCon args)+    = StgRhsCon ccs dataCon args++------------------------------+-- The actual AST traversal --+------------------------------++-- Trivial cases+stgCseExpr :: CseEnv -> InStgExpr -> OutStgExpr+stgCseExpr env (StgApp fun args)+    = StgApp fun' args'+  where fun' = substVar env fun+        args' = substArgs env args+stgCseExpr _ (StgLit lit)+    = StgLit lit+stgCseExpr env (StgOpApp op args tys)+    = StgOpApp op args' tys+  where args' = substArgs env args+stgCseExpr _ (StgLam _ _)+    = pprPanic "stgCseExp" (text "StgLam")+stgCseExpr env (StgTick tick body)+    = let body' = stgCseExpr env body+      in StgTick tick body'+stgCseExpr env (StgCase scrut bndr ty alts)+    = mkStgCase scrut' bndr' ty alts'+  where+    scrut' = stgCseExpr env scrut+    (env1, bndr') = substBndr env bndr+    env2 | StgApp trivial_scrut [] <- scrut' = addTrivCaseBndr bndr trivial_scrut env1+                 -- See Note [Trivial case scrutinee]+         | otherwise                         = env1+    alts' = map (stgCseAlt env2 ty bndr') alts+++-- A constructor application.+-- To be removed by a variable use when found in the CSE environment+stgCseExpr env (StgConApp dataCon args tys)+    | Just bndr' <- envLookup dataCon args' env+    = StgApp bndr' []+    | otherwise+    = StgConApp dataCon args' tys+  where args' = substArgs env args++-- Let bindings+-- The binding might be removed due to CSE (we do not want trivial bindings on+-- the STG level), so use the smart constructor `mkStgLet` to remove the binding+-- if empty.+stgCseExpr env (StgLet ext binds body)+    = let (binds', env') = stgCseBind env binds+          body' = stgCseExpr env' body+      in mkStgLet (StgLet ext) binds' body'+stgCseExpr env (StgLetNoEscape ext binds body)+    = let (binds', env') = stgCseBind env binds+          body' = stgCseExpr env' body+      in mkStgLet (StgLetNoEscape ext) binds' body'++-- Case alternatives+-- Extend the CSE environment+stgCseAlt :: CseEnv -> AltType -> OutId -> InStgAlt -> OutStgAlt+stgCseAlt env ty case_bndr (DataAlt dataCon, args, rhs)+    = let (env1, args') = substBndrs env args+          env2+            -- To avoid dealing with unboxed sums StgCse runs after unarise and+            -- should maintain invariants listed in Note [Post-unarisation+            -- invariants]. One of the invariants is that some binders are not+            -- used (unboxed tuple case binders) which is what we check with+            -- `stgCaseBndrInScope` here. If the case binder is not in scope we+            -- don't add it to the CSE env. See also #15300.+            | stgCaseBndrInScope ty True -- CSE runs after unarise+            = addDataCon case_bndr dataCon (map StgVarArg args') env1+            | otherwise+            = env1+            -- see note [Case 2: CSEing case binders]+          rhs' = stgCseExpr env2 rhs+      in (DataAlt dataCon, args', rhs')+stgCseAlt env _ _ (altCon, args, rhs)+    = let (env1, args') = substBndrs env args+          rhs' = stgCseExpr env1 rhs+      in (altCon, args', rhs')++-- Bindings+stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv)+stgCseBind env (StgNonRec b e)+    = let (env1, b') = substBndr env b+      in case stgCseRhs env1 b' e of+        (Nothing,      env2) -> (Nothing,                env2)+        (Just (b2,e'), env2) -> (Just (StgNonRec b2 e'), env2)+stgCseBind env (StgRec pairs)+    = let (env1, pairs1) = substPairs env pairs+      in case stgCsePairs env1 pairs1 of+        ([],     env2) -> (Nothing, env2)+        (pairs2, env2) -> (Just (StgRec pairs2), env2)++stgCsePairs :: CseEnv -> [(OutId, InStgRhs)] -> ([(OutId, OutStgRhs)], CseEnv)+stgCsePairs env [] = ([], env)+stgCsePairs env0 ((b,e):pairs)+  = let (pairMB, env1) = stgCseRhs env0 b e+        (pairs', env2) = stgCsePairs env1 pairs+    in (pairMB `mbCons` pairs', env2)+  where+    mbCons = maybe id (:)++-- The RHS of a binding.+-- If it is a constructor application, either short-cut it or extend the environment+stgCseRhs :: CseEnv -> OutId -> InStgRhs -> (Maybe (OutId, OutStgRhs), CseEnv)+stgCseRhs env bndr (StgRhsCon ccs dataCon args)+    | Just other_bndr <- envLookup dataCon args' env+    = let env' = addSubst bndr other_bndr env+      in (Nothing, env')+    | otherwise+    = let env' = addDataCon bndr dataCon args' env+            -- see note [Case 1: CSEing allocated closures]+          pair = (bndr, StgRhsCon ccs dataCon args')+      in (Just pair, env')+  where args' = substArgs env args+stgCseRhs env bndr (StgRhsClosure ext ccs upd args body)+    = let (env1, args') = substBndrs env args+          env2 = forgetCse env1 -- See note [Free variables of an StgClosure]+          body' = stgCseExpr env2 body+      in (Just (substVar env bndr, StgRhsClosure ext ccs upd args' body'), env)+++mkStgCase :: StgExpr -> OutId -> AltType -> [StgAlt] -> StgExpr+mkStgCase scrut bndr ty alts | all isBndr alts = scrut+                             | otherwise       = StgCase scrut bndr ty alts++  where+    -- see Note [All alternatives are the binder]+    isBndr (_, _, StgApp f []) = f == bndr+    isBndr _                   = False+++-- Utilities++-- | This function short-cuts let-bindings that are now obsolete+mkStgLet :: (a -> b -> b) -> Maybe a -> b -> b+mkStgLet _      Nothing      body = body+mkStgLet stgLet (Just binds) body = stgLet binds body+++{-+Note [All alternatives are the binder]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When all alternatives simply refer to the case binder, then we do not have+to bother with the case expression at all (#13588). CoreSTG does this as well,+but sometimes, types get into the way:++    newtype T = MkT Int+    f :: (Int, Int) -> (T, Int)+    f (x, y) = (MkT x, y)++Core cannot just turn this into++    f p = p++as this would not be well-typed. But to STG, where MkT is no longer in the way,+we can.++Note [Trivial case scrutinee]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to be able to handle nested reconstruction of constructors as in++    nested :: Either Int (Either Int a) -> Either Bool (Either Bool a)+    nested (Right (Right v)) = Right (Right v)+    nested _ = Left True++So if we come across++    case x of r1+      Right a -> case a of r2+              Right b -> let v = Right b+                         in Right v++we first replace v with r2. Next we want to replace Right r2 with r1. But the+ce_conAppMap contains Right a!++Therefore, we add r1 ↦ x to ce_bndrMap when analysing the outer case, and use+this substitution before looking Right r2 up in ce_conAppMap, and everything+works out.++Note [Free variables of an StgClosure]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+StgClosures (function and thunks) have an explicit list of free variables:++foo [x] =+    let not_a_free_var = Left [x]+    let a_free_var = Right [x]+    let closure = \[x a_free_var] -> \[y] -> bar y (Left [x]) a_free_var+    in closure++If we were to CSE `Left [x]` in the body of `closure` with `not_a_free_var`,+then the list of free variables would be wrong, so for now, we do not CSE+across such a closure, simply because I (Joachim) was not sure about possible+knock-on effects. If deemed safe and worth the slight code complication of+re-calculating this list during or after this pass, this can surely be done.+-}
+ compiler/simplStg/StgLiftLams.hs view
@@ -0,0 +1,102 @@+-- | Implements a selective lambda lifter, running late in the optimisation+-- pipeline.+--+-- The transformation itself is implemented in "StgLiftLams.Transformation".+-- If you are interested in the cost model that is employed to decide whether+-- to lift a binding or not, look at "StgLiftLams.Analysis".+-- "StgLiftLams.LiftM" contains the transformation monad that hides away some+-- plumbing of the transformation.+module StgLiftLams (+    -- * Late lambda lifting in STG+    -- $note+    Transformation.stgLiftLams+  ) where++import qualified StgLiftLams.Transformation as Transformation++-- Note [Late lambda lifting in STG]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- $note+-- See also the <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page>+-- and #9476.+--+-- The basic idea behind lambda lifting is to turn locally defined functions+-- into top-level functions. Free variables are then passed as additional+-- arguments at *call sites* instead of having a closure allocated for them at+-- *definition site*. Example:+--+-- @+--    let x = ...; y = ... in+--    let f = {x y} \a -> a + x + y in+--    let g = {f x} \b -> f b + x in+--    g 5+-- @+--+-- Lambda lifting @f@ would+--+--   1. Turn @f@'s free variables into formal parameters+--   2. Update @f@'s call site within @g@ to @f x y b@+--   3. Update @g@'s closure: Add @y@ as an additional free variable, while+--      removing @f@, because @f@ no longer allocates and can be floated to+--      top-level.+--   4. Actually float the binding of @f@ to top-level, eliminating the @let@+--      in the process.+--+-- This results in the following program (with free var annotations):+--+-- @+--    f x y a = a + x + y;+--    let x = ...; y = ... in+--    let g = {x y} \b -> f x y b + x in+--    g 5+-- @+--+-- This optimisation is all about lifting only when it is beneficial to do so.+-- The above seems like a worthwhile lift, judging from heap allocation:+-- We eliminate @f@'s closure, saving to allocate a closure with 2 words, while+-- not changing the size of @g@'s closure.+--+-- You can probably sense that there's some kind of cost model at play here.+-- And you are right! But we also employ a couple of other heuristics for the+-- lifting decision which are outlined in "StgLiftLams.Analysis#when".+--+-- The transformation is done in "StgLiftLams.Transformation", which calls out+-- to 'StgLiftLams.Analysis.goodToLift' for its lifting decision.+-- It relies on "StgLiftLams.LiftM", which abstracts some subtle STG invariants+-- into a monadic substrate.+--+-- Suffice to say: We trade heap allocation for stack allocation.+-- The additional arguments have to passed on the stack (or in registers,+-- depending on architecture) every time we call the function to save a single+-- heap allocation when entering the let binding. Nofib suggests a mean+-- improvement of about 1% for this pass, so it seems like a worthwhile thing to+-- do. Compile-times went up by 0.6%, so all in all a very modest change.+--+-- For a concrete example, look at @spectral/atom@. There's a call to 'zipWith'+-- that is ultimately compiled to something like this+-- (module desugaring/lowering to actual STG):+--+-- @+--    propagate dt = ...;+--    runExperiment ... =+--      let xs = ... in+--      let ys = ... in+--      let go = {dt go} \xs ys -> case (xs, ys) of+--            ([], []) -> []+--            (x:xs', y:ys') -> propagate dt x y : go xs' ys'+--      in go xs ys+-- @+--+-- This will lambda lift @go@ to top-level, speeding up the resulting program+-- by roughly one percent:+--+-- @+--    propagate dt = ...;+--    go dt xs ys = case (xs, ys) of+--      ([], []) -> []+--      (x:xs', y:ys') -> propagate dt x y : go dt xs' ys'+--    runExperiment ... =+--      let xs = ... in+--      let ys = ... in+--      in go dt xs ys+-- @
+ compiler/simplStg/StgLiftLams/Analysis.hs view
@@ -0,0 +1,565 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}++-- | Provides the heuristics for when it's beneficial to lambda lift bindings.+-- Most significantly, this employs a cost model to estimate impact on heap+-- allocations, by looking at an STG expression's 'Skeleton'.+module StgLiftLams.Analysis (+    -- * #when# When to lift+    -- $when++    -- * #clogro# Estimating closure growth+    -- $clogro++    -- * AST annotation+    Skeleton(..), BinderInfo(..), binderInfoBndr,+    LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt, tagSkeletonTopBind,+    -- * Lifting decision+    goodToLift,+    closureGrowth -- Exported just for the docs+  ) where++import GhcPrelude++import BasicTypes+import Demand+import DynFlags+import Id+import SMRep ( WordOff )+import StgSyn+import qualified StgCmmArgRep+import qualified StgCmmClosure+import qualified StgCmmLayout+import Outputable+import Util+import VarSet++import Data.Maybe ( mapMaybe )++-- Note [When to lift]+-- ~~~~~~~~~~~~~~~~~~~+-- $when+-- The analysis proceeds in two steps:+--+--   1. It tags the syntax tree with analysis information in the form of+--      'BinderInfo' at each binder and 'Skeleton's at each let-binding+--      by 'tagSkeletonTopBind' and friends.+--   2. The resulting syntax tree is treated by the "StgLiftLams.Transformation"+--      module, calling out to 'goodToLift' to decide if a binding is worthwhile+--      to lift.+--      'goodToLift' consults argument occurrence information in 'BinderInfo'+--      and estimates 'closureGrowth', for which it needs the 'Skeleton'.+--+-- So the annotations from 'tagSkeletonTopBind' ultimately fuel 'goodToLift',+-- which employs a number of heuristics to identify and exclude lambda lifting+-- opportunities deemed non-beneficial:+--+--  [Top-level bindings] can't be lifted.+--  [Thunks] and data constructors shouldn't be lifted in order not to destroy+--    sharing.+--  [Argument occurrences] #arg_occs# of binders prohibit them to be lifted.+--    Doing the lift would re-introduce the very allocation at call sites that+--    we tried to get rid off in the first place. We capture analysis+--    information in 'BinderInfo'. Note that we also consider a nullary+--    application as argument occurrence, because it would turn into an n-ary+--    partial application created by a generic apply function. This occurs in+--    CPS-heavy code like the CS benchmark.+--  [Join points] should not be lifted, simply because there's no reduction in+--    allocation to be had.+--  [Abstracting over join points] destroys join points, because they end up as+--    arguments to the lifted function.+--  [Abstracting over known local functions] turns a known call into an unknown+--    call (e.g. some @stg_ap_*@), which is generally slower. Can be turned off+--    with @-fstg-lift-lams-known@.+--  [Calling convention] Don't lift when the resulting function would have a+--    higher arity than available argument registers for the calling convention.+--    Can be influenced with @-fstg-lift-(non)rec-args(-any)@.+--  [Closure growth] introduced when former free variables have to be available+--    at call sites may actually lead to an increase in overall allocations+--  resulting from a lift. Estimating closure growth is described in+--  "StgLiftLams.Analysis#clogro" and is what most of this module is ultimately+--  concerned with.+--+-- There's a <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page> with+-- some more background and history.++-- Note [Estimating closure growth]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- $clogro+-- We estimate closure growth by abstracting the syntax tree into a 'Skeleton',+-- capturing only syntactic details relevant to 'closureGrowth', such as+--+--   * 'ClosureSk', representing closure allocation.+--   * 'RhsSk', representing a RHS of a binding and how many times it's called+--     by an appropriate 'DmdShell'.+--   * 'AltSk', 'BothSk' and 'NilSk' for choice, sequence and empty element.+--+-- This abstraction is mostly so that the main analysis function 'closureGrowth'+-- can stay simple and focused. Also, skeletons tend to be much smaller than+-- the syntax tree they abstract, so it makes sense to construct them once and+-- and operate on them instead of the actual syntax tree.+--+-- A more detailed treatment of computing closure growth, including examples,+-- can be found in the paper referenced from the+-- <https://gitlab.haskell.org/ghc/ghc/wikis/late-lam-lift wiki page>.++llTrace :: String -> SDoc -> a -> a+llTrace _ _ c = c+-- llTrace a b c = pprTrace a b c++type instance BinderP      'LiftLams = BinderInfo+type instance XRhsClosure  'LiftLams = DIdSet+type instance XLet         'LiftLams = Skeleton+type instance XLetNoEscape 'LiftLams = Skeleton++freeVarsOfRhs :: (XRhsClosure pass ~ DIdSet) => GenStgRhs pass -> DIdSet+freeVarsOfRhs (StgRhsCon _ _ args) = mkDVarSet [ id | StgVarArg id <- args ]+freeVarsOfRhs (StgRhsClosure fvs _ _ _ _) = fvs++-- | Captures details of the syntax tree relevant to the cost model, such as+-- closures, multi-shot lambdas and case expressions.+data Skeleton+  = ClosureSk !Id !DIdSet {- ^ free vars -} !Skeleton+  | RhsSk !DmdShell {- ^ how often the RHS was entered -} !Skeleton+  | AltSk !Skeleton !Skeleton+  | BothSk !Skeleton !Skeleton+  | NilSk++bothSk :: Skeleton -> Skeleton -> Skeleton+bothSk NilSk b = b+bothSk a NilSk = a+bothSk a b     = BothSk a b++altSk :: Skeleton -> Skeleton -> Skeleton+altSk NilSk b = b+altSk a NilSk = a+altSk a b     = AltSk a b++rhsSk :: DmdShell -> Skeleton -> Skeleton+rhsSk _        NilSk = NilSk+rhsSk body_dmd skel  = RhsSk body_dmd skel++-- | The type used in binder positions in 'GenStgExpr's.+data BinderInfo+  = BindsClosure !Id !Bool -- ^ Let(-no-escape)-bound thing with a flag+                           --   indicating whether it occurs as an argument+                           --   or in a nullary application+                           --   (see "StgLiftLams.Analysis#arg_occs").+  | BoringBinder !Id       -- ^ Every other kind of binder++-- | Gets the bound 'Id' out a 'BinderInfo'.+binderInfoBndr :: BinderInfo -> Id+binderInfoBndr (BoringBinder bndr)   = bndr+binderInfoBndr (BindsClosure bndr _) = bndr++-- | Returns 'Nothing' for 'BoringBinder's and 'Just' the flag indicating+-- occurrences as argument or in a nullary applications otherwise.+binderInfoOccursAsArg :: BinderInfo -> Maybe Bool+binderInfoOccursAsArg BoringBinder{}     = Nothing+binderInfoOccursAsArg (BindsClosure _ b) = Just b++instance Outputable Skeleton where+  ppr NilSk = text ""+  ppr (AltSk l r) = vcat+    [ text "{ " <+> ppr l+    , text "ALT"+    , text "  " <+> ppr r+    , text "}"+    ]+  ppr (BothSk l r) = ppr l $$ ppr r+  ppr (ClosureSk f fvs body) = ppr f <+> ppr fvs $$ nest 2 (ppr body)+  ppr (RhsSk body_dmd body) = hcat+    [ text "λ["+    , ppr str+    , text ", "+    , ppr use+    , text "]. "+    , ppr body+    ]+    where+      str+        | isStrictDmd body_dmd = '1'+        | otherwise = '0'+      use+        | isAbsDmd body_dmd = '0'+        | isUsedOnce body_dmd = '1'+        | otherwise = 'ω'++instance Outputable BinderInfo where+  ppr = ppr . binderInfoBndr++instance OutputableBndr BinderInfo where+  pprBndr b = pprBndr b . binderInfoBndr+  pprPrefixOcc = pprPrefixOcc . binderInfoBndr+  pprInfixOcc = pprInfixOcc . binderInfoBndr+  bndrIsJoin_maybe = bndrIsJoin_maybe . binderInfoBndr++mkArgOccs :: [StgArg] -> IdSet+mkArgOccs = mkVarSet . mapMaybe stg_arg_var+  where+    stg_arg_var (StgVarArg occ) = Just occ+    stg_arg_var _               = Nothing++-- | Tags every binder with its 'BinderInfo' and let bindings with their+-- 'Skeleton's.+tagSkeletonTopBind :: CgStgBinding -> LlStgBinding+-- NilSk is OK when tagging top-level bindings. Also, top-level things are never+-- lambda-lifted, so no need to track their argument occurrences. They can also+-- never be let-no-escapes (thus we pass False).+tagSkeletonTopBind bind = bind'+  where+    (_, _, _, bind') = tagSkeletonBinding False NilSk emptyVarSet bind++-- | Tags binders of an 'StgExpr' with its 'BinderInfo' and let bindings with+-- their 'Skeleton's. Additionally, returns its 'Skeleton' and the set of binder+-- occurrences in argument and nullary application position+-- (cf. "StgLiftLams.Analysis#arg_occs").+tagSkeletonExpr :: CgStgExpr -> (Skeleton, IdSet, LlStgExpr)+tagSkeletonExpr (StgLit lit)+  = (NilSk, emptyVarSet, StgLit lit)+tagSkeletonExpr (StgConApp con args tys)+  = (NilSk, mkArgOccs args, StgConApp con args tys)+tagSkeletonExpr (StgOpApp op args ty)+  = (NilSk, mkArgOccs args, StgOpApp op args ty)+tagSkeletonExpr (StgApp f args)+  = (NilSk, arg_occs, StgApp f args)+  where+    arg_occs+      -- This checks for nullary applications, which we treat the same as+      -- argument occurrences, see "StgLiftLams.Analysis#arg_occs".+      | null args = unitVarSet f+      | otherwise = mkArgOccs args+tagSkeletonExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam")+tagSkeletonExpr (StgCase scrut bndr ty alts)+  = (skel, arg_occs, StgCase scrut' bndr' ty alts')+  where+    (scrut_skel, scrut_arg_occs, scrut') = tagSkeletonExpr scrut+    (alt_skels, alt_arg_occss, alts') = mapAndUnzip3 tagSkeletonAlt alts+    skel = bothSk scrut_skel (foldr altSk NilSk alt_skels)+    arg_occs = unionVarSets (scrut_arg_occs:alt_arg_occss) `delVarSet` bndr+    bndr' = BoringBinder bndr+tagSkeletonExpr (StgTick t e)+  = (skel, arg_occs, StgTick t e')+  where+    (skel, arg_occs, e') = tagSkeletonExpr e+tagSkeletonExpr (StgLet _ bind body) = tagSkeletonLet False body bind+tagSkeletonExpr (StgLetNoEscape _ bind body) = tagSkeletonLet True body bind++mkLet :: Bool -> Skeleton -> LlStgBinding -> LlStgExpr -> LlStgExpr+mkLet True = StgLetNoEscape+mkLet _    = StgLet++tagSkeletonLet+  :: Bool+  -- ^ Is the binding a let-no-escape?+  -> CgStgExpr+  -- ^ Let body+  -> CgStgBinding+  -- ^ Binding group+  -> (Skeleton, IdSet, LlStgExpr)+  -- ^ RHS skeletons, argument occurrences and annotated binding+tagSkeletonLet is_lne body bind+  = (let_skel, arg_occs, mkLet is_lne scope bind' body')+  where+    (body_skel, body_arg_occs, body') = tagSkeletonExpr body+    (let_skel, arg_occs, scope, bind')+      = tagSkeletonBinding is_lne body_skel body_arg_occs bind++tagSkeletonBinding+  :: Bool+  -- ^ Is the binding a let-no-escape?+  -> Skeleton+  -- ^ Let body skeleton+  -> IdSet+  -- ^ Argument occurrences in the body+  -> CgStgBinding+  -- ^ Binding group+  -> (Skeleton, IdSet, Skeleton, LlStgBinding)+  -- ^ Let skeleton, argument occurrences, scope skeleton of binding and+  --   the annotated binding+tagSkeletonBinding is_lne body_skel body_arg_occs (StgNonRec bndr rhs)+  = (let_skel, arg_occs, scope, bind')+  where+    (rhs_skel, rhs_arg_occs, rhs') = tagSkeletonRhs bndr rhs+    arg_occs = (body_arg_occs `unionVarSet` rhs_arg_occs) `delVarSet` bndr+    bind_skel+      | is_lne    = rhs_skel -- no closure is allocated for let-no-escapes+      | otherwise = ClosureSk bndr (freeVarsOfRhs rhs) rhs_skel+    let_skel = bothSk body_skel bind_skel+    occurs_as_arg = bndr `elemVarSet` body_arg_occs+    -- Compared to the recursive case, this exploits the fact that @bndr@ is+    -- never free in @rhs@.+    scope = body_skel+    bind' = StgNonRec (BindsClosure bndr occurs_as_arg) rhs'+tagSkeletonBinding is_lne body_skel body_arg_occs (StgRec pairs)+  = (let_skel, arg_occs, scope, StgRec pairs')+  where+    (bndrs, _) = unzip pairs+    -- Local recursive STG bindings also regard the defined binders as free+    -- vars. We want to delete those for our cost model, as these are known+    -- calls anyway when we add them to the same top-level recursive group as+    -- the top-level binding currently being analysed.+    skel_occs_rhss' = map (uncurry tagSkeletonRhs) pairs+    rhss_arg_occs = map sndOf3 skel_occs_rhss'+    scope_occs = unionVarSets (body_arg_occs:rhss_arg_occs)+    arg_occs = scope_occs `delVarSetList` bndrs+    -- @skel_rhss@ aren't yet wrapped in closures. We'll do that in a moment,+    -- but we also need the un-wrapped skeletons for calculating the @scope@+    -- of the group, as the outer closures don't contribute to closure growth+    -- when we lift this specific binding.+    scope = foldr (bothSk . fstOf3) body_skel skel_occs_rhss'+    -- Now we can build the actual Skeleton for the expression just by+    -- iterating over each bind pair.+    (bind_skels, pairs') = unzip (zipWith single_bind bndrs skel_occs_rhss')+    let_skel = foldr bothSk body_skel bind_skels+    single_bind bndr (skel_rhs, _, rhs') = (bind_skel, (bndr', rhs'))+      where+        -- Here, we finally add the closure around each @skel_rhs@.+        bind_skel+          | is_lne    = skel_rhs -- no closure is allocated for let-no-escapes+          | otherwise = ClosureSk bndr fvs skel_rhs+        fvs = freeVarsOfRhs rhs' `dVarSetMinusVarSet` mkVarSet bndrs+        bndr' = BindsClosure bndr (bndr `elemVarSet` scope_occs)++tagSkeletonRhs :: Id -> CgStgRhs -> (Skeleton, IdSet, LlStgRhs)+tagSkeletonRhs _ (StgRhsCon ccs dc args)+  = (NilSk, mkArgOccs args, StgRhsCon ccs dc args)+tagSkeletonRhs bndr (StgRhsClosure fvs ccs upd bndrs body)+  = (rhs_skel, body_arg_occs, StgRhsClosure fvs ccs upd bndrs' body')+  where+    bndrs' = map BoringBinder bndrs+    (body_skel, body_arg_occs, body') = tagSkeletonExpr body+    rhs_skel = rhsSk (rhsDmdShell bndr) body_skel++-- | How many times will the lambda body of the RHS bound to the given+-- identifier be evaluated, relative to its defining context? This function+-- computes the answer in form of a 'DmdShell'.+rhsDmdShell :: Id -> DmdShell+rhsDmdShell bndr+  | is_thunk = oneifyDmd ds+  | otherwise = peelManyCalls (idArity bndr) cd+  where+    is_thunk = idArity bndr == 0+    -- Let's pray idDemandInfo is still OK after unarise...+    (ds, cd) = toCleanDmd (idDemandInfo bndr)++tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt)+tagSkeletonAlt (con, bndrs, rhs)+  = (alt_skel, arg_occs, (con, map BoringBinder bndrs, rhs'))+  where+    (alt_skel, alt_arg_occs, rhs') = tagSkeletonExpr rhs+    arg_occs = alt_arg_occs `delVarSetList` bndrs++-- | Combines several heuristics to decide whether to lambda-lift a given+-- @let@-binding to top-level. See "StgLiftLams.Analysis#when" for details.+goodToLift+  :: DynFlags+  -> TopLevelFlag+  -> RecFlag+  -> (DIdSet -> DIdSet) -- ^ An expander function, turning 'InId's into+                        -- 'OutId's. See 'StgLiftLams.LiftM.liftedIdsExpander'.+  -> [(BinderInfo, LlStgRhs)]+  -> Skeleton+  -> Maybe DIdSet       -- ^ @Just abs_ids@ <=> This binding is beneficial to+                        -- lift and @abs_ids@ are the variables it would+                        -- abstract over+goodToLift dflags top_lvl rec_flag expander pairs scope = decide+  [ ("top-level", isTopLevel top_lvl) -- keep in sync with Note [When to lift]+  , ("memoized", any_memoized)+  , ("argument occurrences", arg_occs)+  , ("join point", is_join_point)+  , ("abstracts join points", abstracts_join_ids)+  , ("abstracts known local function", abstracts_known_local_fun)+  , ("args spill on stack", args_spill_on_stack)+  , ("increases allocation", inc_allocs)+  ] where+      decide deciders+        | not (fancy_or deciders)+        = llTrace "stgLiftLams:lifting"+                  (ppr bndrs <+> ppr abs_ids $$+                   ppr allocs $$+                   ppr scope) $+          Just abs_ids+        | otherwise+        = Nothing+      ppr_deciders = vcat . map (text . fst) . filter snd+      fancy_or deciders+        = llTrace "stgLiftLams:goodToLift" (ppr bndrs $$ ppr_deciders deciders) $+          any snd deciders++      bndrs = map (binderInfoBndr . fst) pairs+      bndrs_set = mkVarSet bndrs+      rhss = map snd pairs++      -- First objective: Calculate @abs_ids@, e.g. the former free variables+      -- the lifted binding would abstract over. We have to merge the free+      -- variables of all RHS to get the set of variables that will have to be+      -- passed through parameters.+      fvs = unionDVarSets (map freeVarsOfRhs rhss)+      -- To lift the binding to top-level, we want to delete the lifted binders+      -- themselves from the free var set. Local let bindings track recursive+      -- occurrences in their free variable set. We neither want to apply our+      -- cost model to them (see 'tagSkeletonRhs'), nor pass them as parameters+      -- when lifted, as these are known calls. We call the resulting set the+      -- identifiers we abstract over, thus @abs_ids@. These are all 'OutId's.+      -- We will save the set in 'LiftM.e_expansions' for each of the variables+      -- if we perform the lift.+      abs_ids = expander (delDVarSetList fvs bndrs)++      -- We don't lift updatable thunks or constructors+      any_memoized = any is_memoized_rhs rhss+      is_memoized_rhs StgRhsCon{} = True+      is_memoized_rhs (StgRhsClosure _ _ upd _ _) = isUpdatable upd++      -- Don't lift binders occuring as arguments. This would result in complex+      -- argument expressions which would have to be given a name, reintroducing+      -- the very allocation at each call site that we wanted to get rid off in+      -- the first place.+      arg_occs = or (mapMaybe (binderInfoOccursAsArg . fst) pairs)++      -- These don't allocate anyway.+      is_join_point = any isJoinId bndrs++      -- Abstracting over join points/let-no-escapes spoils them.+      abstracts_join_ids = any isJoinId (dVarSetElems abs_ids)++      -- Abstracting over known local functions that aren't floated themselves+      -- turns a known, fast call into an unknown, slow call:+      --+      --    let f x = ...+      --        g y = ... f x ... -- this was a known call+      --    in g 4+      --+      -- After lifting @g@, but not @f@:+      --+      --    l_g f y = ... f y ... -- this is now an unknown call+      --    let f x = ...+      --    in l_g f 4+      --+      -- We can abuse the results of arity analysis for this:+      -- idArity f > 0 ==> known+      known_fun id = idArity id > 0+      abstracts_known_local_fun+        = not (liftLamsKnown dflags) && any known_fun (dVarSetElems abs_ids)++      -- Number of arguments of a RHS in the current binding group if we decide+      -- to lift it+      n_args+        = length+        . StgCmmClosure.nonVoidIds -- void parameters don't appear in Cmm+        . (dVarSetElems abs_ids ++)+        . rhsLambdaBndrs+      max_n_args+        | isRec rec_flag = liftLamsRecArgs dflags+        | otherwise      = liftLamsNonRecArgs dflags+      -- We have 5 hardware registers on x86_64 to pass arguments in. Any excess+      -- args are passed on the stack, which means slow memory accesses+      args_spill_on_stack+        | Just n <- max_n_args = maximum (map n_args rhss) > n+        | otherwise = False++      -- We only perform the lift if allocations didn't increase.+      -- Note that @clo_growth@ will be 'infinity' if there was positive growth+      -- under a multi-shot lambda.+      -- Also, abstracting over LNEs is unacceptable. LNEs might return+      -- unlifted tuples, which idClosureFootprint can't cope with.+      inc_allocs = abstracts_join_ids || allocs > 0+      allocs = clo_growth + mkIntWithInf (negate closuresSize)+      -- We calculate and then add up the size of each binding's closure.+      -- GHC does not currently share closure environments, and we either lift+      -- the entire recursive binding group or none of it.+      closuresSize = sum $ flip map rhss $ \rhs ->+        closureSize dflags+        . dVarSetElems+        . expander+        . flip dVarSetMinusVarSet bndrs_set+        $ freeVarsOfRhs rhs+      clo_growth = closureGrowth expander (idClosureFootprint dflags) bndrs_set abs_ids scope++rhsLambdaBndrs :: LlStgRhs -> [Id]+rhsLambdaBndrs StgRhsCon{} = []+rhsLambdaBndrs (StgRhsClosure _ _ _ bndrs _) = map binderInfoBndr bndrs++-- | The size in words of a function closure closing over the given 'Id's,+-- including the header.+closureSize :: DynFlags -> [Id] -> WordOff+closureSize dflags ids = words + sTD_HDR_SIZE dflags+  -- We go through sTD_HDR_SIZE rather than fixedHdrSizeW so that we don't+  -- optimise differently when profiling is enabled.+  where+    (words, _, _)+      -- Functions have a StdHeader (as opposed to ThunkHeader).+      = StgCmmLayout.mkVirtHeapOffsets dflags StgCmmLayout.StdHeader+      . StgCmmClosure.addIdReps+      . StgCmmClosure.nonVoidIds+      $ ids++-- | The number of words a single 'Id' adds to a closure's size.+-- Note that this can't handle unboxed tuples (which may still be present in+-- let-no-escapes, even after Unarise), in which case+-- @'StgCmmClosure.idPrimRep'@ will crash.+idClosureFootprint:: DynFlags -> Id -> WordOff+idClosureFootprint dflags+  = StgCmmArgRep.argRepSizeW dflags+  . StgCmmArgRep.idArgRep++-- | @closureGrowth expander sizer f fvs@ computes the closure growth in words+-- as a result of lifting @f@ to top-level. If there was any growing closure+-- under a multi-shot lambda, the result will be 'infinity'.+-- Also see "StgLiftLams.Analysis#clogro".+closureGrowth+  :: (DIdSet -> DIdSet)+  -- ^ Expands outer free ids that were lifted to their free vars+  -> (Id -> Int)+  -- ^ Computes the closure footprint of an identifier+  -> IdSet+  -- ^ Binding group for which lifting is to be decided+  -> DIdSet+  -- ^ Free vars of the whole binding group prior to lifting it. These must be+  --   available at call sites if we decide to lift the binding group.+  -> Skeleton+  -- ^ Abstraction of the scope of the function+  -> IntWithInf+  -- ^ Closure growth. 'infinity' indicates there was growth under a+  --   (multi-shot) lambda.+closureGrowth expander sizer group abs_ids = go+  where+    go NilSk = 0+    go (BothSk a b) = go a + go b+    go (AltSk a b) = max (go a) (go b)+    go (ClosureSk _ clo_fvs rhs)+      -- If no binder of the @group@ occurs free in the closure, the lifting+      -- won't have any effect on it and we can omit the recursive call.+      | n_occs == 0 = 0+      -- Otherwise, we account the cost of allocating the closure and add it to+      -- the closure growth of its RHS.+      | otherwise   = mkIntWithInf cost + go rhs+      where+        n_occs = sizeDVarSet (clo_fvs' `dVarSetIntersectVarSet` group)+        -- What we close over considering prior lifting decisions+        clo_fvs' = expander clo_fvs+        -- Variables that would additionally occur free in the closure body if+        -- we lift @f@+        newbies = abs_ids `minusDVarSet` clo_fvs'+        -- Lifting @f@ removes @f@ from the closure but adds all @newbies@+        cost = foldDVarSet (\id size -> sizer id + size) 0 newbies - n_occs+    go (RhsSk body_dmd body)+      -- The conservative assumption would be that+      --   1. Every RHS with positive growth would be called multiple times,+      --      modulo thunks.+      --   2. Every RHS with negative growth wouldn't be called at all.+      --+      -- In the first case, we'd have to return 'infinity', while in the+      -- second case, we'd have to return 0. But we can do far better+      -- considering information from the demand analyser, which provides us+      -- with conservative estimates on minimum and maximum evaluation+      -- cardinality. The @body_dmd@ part of 'RhsSk' is the result of+      -- 'rhsDmdShell' and accurately captures the cardinality of the RHSs body+      -- relative to its defining context.+      | isAbsDmd body_dmd   = 0+      | cg <= 0             = if isStrictDmd body_dmd then cg else 0+      | isUsedOnce body_dmd = cg+      | otherwise           = infinity+      where+        cg = go body
+ compiler/simplStg/StgLiftLams/LiftM.hs view
@@ -0,0 +1,348 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}++-- | Hides away distracting bookkeeping while lambda lifting into a 'LiftM'+-- monad.+module StgLiftLams.LiftM (+    decomposeStgBinding, mkStgBinding,+    Env (..),+    -- * #floats# Handling floats+    -- $floats+    FloatLang (..), collectFloats, -- Exported just for the docs+    -- * Transformation monad+    LiftM, runLiftM, withCaffyness,+    -- ** Adding bindings+    startBindingGroup, endBindingGroup, addTopStringLit, addLiftedBinding,+    -- ** Substitution and binders+    withSubstBndr, withSubstBndrs, withLiftedBndr, withLiftedBndrs,+    -- ** Occurrences+    substOcc, isLifted, formerFreeVars, liftedIdsExpander+  ) where++#include "HsVersions.h"++import GhcPrelude++import BasicTypes+import CostCentre ( isCurrentCCS, dontCareCCS )+import DynFlags+import FastString+import Id+import IdInfo+import Name+import Outputable+import OrdList+import StgSubst+import StgSyn+import Type+import UniqSupply+import Util+import VarEnv+import VarSet++import Control.Arrow ( second )+import Control.Monad.Trans.Class+import Control.Monad.Trans.RWS.Strict ( RWST, runRWST )+import qualified Control.Monad.Trans.RWS.Strict as RWS+import Control.Monad.Trans.Cont ( ContT (..) )+import Data.ByteString ( ByteString )++-- | @uncurry 'mkStgBinding' . 'decomposeStgBinding' = id@+decomposeStgBinding :: GenStgBinding pass -> (RecFlag, [(BinderP pass, GenStgRhs pass)])+decomposeStgBinding (StgRec pairs) = (Recursive, pairs)+decomposeStgBinding (StgNonRec bndr rhs) = (NonRecursive, [(bndr, rhs)])++mkStgBinding :: RecFlag -> [(BinderP pass, GenStgRhs pass)] -> GenStgBinding pass+mkStgBinding Recursive = StgRec+mkStgBinding NonRecursive = uncurry StgNonRec . head++-- | Environment threaded around in a scoped, @Reader@-like fashion.+data Env+  = Env+  { e_dflags     :: !DynFlags+  -- ^ Read-only.+  , e_subst      :: !Subst+  -- ^ We need to track the renamings of local 'InId's to their lifted 'OutId',+  -- because shadowing might make a closure's free variables unavailable at its+  -- call sites. Consider:+  -- @+  --    let f y = x + y in let x = 4 in f x+  -- @+  -- Here, @f@ can't be lifted to top-level, because its free variable @x@ isn't+  -- available at its call site.+  , e_expansions :: !(IdEnv DIdSet)+  -- ^ Lifted 'Id's don't occur as free variables in any closure anymore, because+  -- they are bound at the top-level. Every occurrence must supply the formerly+  -- free variables of the lifted 'Id', so they in turn become free variables of+  -- the call sites. This environment tracks this expansion from lifted 'Id's to+  -- their free variables.+  --+  -- 'InId's to 'OutId's.+  --+  -- Invariant: 'Id's not present in this map won't be substituted.+  , e_in_caffy_context :: !Bool+  -- ^ Are we currently analysing within a caffy context (e.g. the containing+  -- top-level binder's 'idCafInfo' is 'MayHaveCafRefs')? If not, we can safely+  -- assume that functions we lift out aren't caffy either.+  }++emptyEnv :: DynFlags -> Env+emptyEnv dflags = Env dflags emptySubst emptyVarEnv False+++-- Note [Handling floats]+-- ~~~~~~~~~~~~~~~~~~~~~~+-- $floats+-- Consider the following expression:+--+-- @+--     f x =+--       let g y = ... f y ...+--       in g x+-- @+--+-- What happens when we want to lift @g@? Normally, we'd put the lifted @l_g@+-- binding above the binding for @f@:+--+-- @+--     g f y = ... f y ...+--     f x = g f x+-- @+--+-- But this very unnecessarily turns a known call to @f@ into an unknown one, in+-- addition to complicating matters for the analysis.+-- Instead, we'd really like to put both functions in the same recursive group,+-- thereby preserving the known call:+--+-- @+--     Rec {+--       g y = ... f y ...+--       f x = g x+--     }+-- @+--+-- But we don't want this to happen for just /any/ binding. That would create+-- possibly huge recursive groups in the process, calling for an occurrence+-- analyser on STG.+-- So, we need to track when we lift a binding out of a recursive RHS and add+-- the binding to the same recursive group as the enclosing recursive binding+-- (which must have either already been at the top-level or decided to be+-- lifted itself in order to preserve the known call).+--+-- This is done by expressing this kind of nesting structure as a 'Writer' over+-- @['FloatLang']@ and flattening this expression in 'runLiftM' by a call to+-- 'collectFloats'.+-- API-wise, the analysis will not need to know about the whole 'FloatLang'+-- business and will just manipulate it indirectly through actions in 'LiftM'.++-- | We need to detect when we are lifting something out of the RHS of a+-- recursive binding (c.f. "StgLiftLams.LiftM#floats"), in which case that+-- binding needs to be added to the same top-level recursive group. This+-- requires we detect a certain nesting structure, which is encoded by+-- 'StartBindingGroup' and 'EndBindingGroup'.+--+-- Although 'collectFloats' will only ever care if the current binding to be+-- lifted (through 'LiftedBinding') will occur inside such a binding group or+-- not, e.g. doesn't care about the nesting level as long as its greater than 0.+data FloatLang+  = StartBindingGroup+  | EndBindingGroup+  | PlainTopBinding OutStgTopBinding+  | LiftedBinding OutStgBinding++instance Outputable FloatLang where+  ppr StartBindingGroup = char '('+  ppr EndBindingGroup = char ')'+  ppr (PlainTopBinding StgTopStringLit{}) = text "<str>"+  ppr (PlainTopBinding (StgTopLifted b)) = ppr (LiftedBinding b)+  ppr (LiftedBinding bind) = (if isRec rec then char 'r' else char 'n') <+> ppr (map fst pairs)+    where+      (rec, pairs) = decomposeStgBinding bind++-- | Flattens an expression in @['FloatLang']@ into an STG program, see #floats.+-- Important pre-conditions: The nesting of opening 'StartBindinGroup's and+-- closing 'EndBindinGroup's is balanced. Also, it is crucial that every binding+-- group has at least one recursive binding inside. Otherwise there's no point+-- in announcing the binding group in the first place and an @ASSERT@ will+-- trigger.+collectFloats :: [FloatLang] -> [OutStgTopBinding]+collectFloats = go (0 :: Int) []+  where+    go 0 [] [] = []+    go _ _ [] = pprPanic "collectFloats" (text "unterminated group")+    go n binds (f:rest) = case f of+      StartBindingGroup -> go (n+1) binds rest+      EndBindingGroup+        | n == 0 -> pprPanic "collectFloats" (text "no group to end")+        | n == 1 -> StgTopLifted (merge_binds binds) : go 0 [] rest+        | otherwise -> go (n-1) binds rest+      PlainTopBinding top_bind+        | n == 0 -> top_bind : go n binds rest+        | otherwise -> pprPanic "collectFloats" (text "plain top binding inside group")+      LiftedBinding bind+        | n == 0 -> StgTopLifted (rm_cccs bind) : go n binds rest+        | otherwise -> go n (bind:binds) rest++    map_rhss f = uncurry mkStgBinding . second (map (second f)) . decomposeStgBinding+    rm_cccs = map_rhss removeRhsCCCS+    merge_binds binds = ASSERT( any is_rec binds )+                        StgRec (concatMap (snd . decomposeStgBinding . rm_cccs) binds)+    is_rec StgRec{} = True+    is_rec _ = False++-- | Omitting this makes for strange closure allocation schemes that crash the+-- GC.+removeRhsCCCS :: GenStgRhs pass -> GenStgRhs pass+removeRhsCCCS (StgRhsClosure ext ccs upd bndrs body)+  | isCurrentCCS ccs+  = StgRhsClosure ext dontCareCCS upd bndrs body+removeRhsCCCS (StgRhsCon ccs con args)+  | isCurrentCCS ccs+  = StgRhsCon dontCareCCS con args+removeRhsCCCS rhs = rhs++-- | The analysis monad consists of the following 'RWST' components:+--+--     * 'Env': Reader-like context. Contains a substitution, info about how+--       how lifted identifiers are to be expanded into applications and details+--       such as 'DynFlags' and a flag helping with determining if a lifted+--       binding is caffy.+--+--     * @'OrdList' 'FloatLang'@: Writer output for the resulting STG program.+--+--     * No pure state component+--+--     * But wrapping around 'UniqSM' for generating fresh lifted binders.+--       (The @uniqAway@ approach could give the same name to two different+--       lifted binders, so this is necessary.)+newtype LiftM a+  = LiftM { unwrapLiftM :: RWST Env (OrdList FloatLang) () UniqSM a }+  deriving (Functor, Applicative, Monad)++instance HasDynFlags LiftM where+  getDynFlags = LiftM (RWS.asks e_dflags)++instance MonadUnique LiftM where+  getUniqueSupplyM = LiftM (lift getUniqueSupplyM)+  getUniqueM = LiftM (lift getUniqueM)+  getUniquesM = LiftM (lift getUniquesM)++runLiftM :: DynFlags -> UniqSupply -> LiftM () -> [OutStgTopBinding]+runLiftM dflags us (LiftM m) = collectFloats (fromOL floats)+  where+    (_, _, floats) = initUs_ us (runRWST m (emptyEnv dflags) ())++-- | Assumes a given caffyness for the execution of the passed action, which+-- influences the 'cafInfo' of lifted bindings.+withCaffyness :: Bool -> LiftM a -> LiftM a+withCaffyness caffy action+  = LiftM (RWS.local (\e -> e { e_in_caffy_context = caffy }) (unwrapLiftM action))++-- | Writes a plain 'StgTopStringLit' to the output.+addTopStringLit :: OutId -> ByteString -> LiftM ()+addTopStringLit id = LiftM . RWS.tell . unitOL . PlainTopBinding . StgTopStringLit id++-- | Starts a recursive binding group. See #floats# and 'collectFloats'.+startBindingGroup :: LiftM ()+startBindingGroup = LiftM $ RWS.tell $ unitOL $ StartBindingGroup++-- | Ends a recursive binding group. See #floats# and 'collectFloats'.+endBindingGroup :: LiftM ()+endBindingGroup = LiftM $ RWS.tell $ unitOL $ EndBindingGroup++-- | Lifts a binding to top-level. Depending on whether it's declared inside+-- a recursive RHS (see #floats# and 'collectFloats'), this might be added to+-- an existing recursive top-level binding group.+addLiftedBinding :: OutStgBinding -> LiftM ()+addLiftedBinding = LiftM . RWS.tell . unitOL . LiftedBinding++-- | Takes a binder and a continuation which is called with the substituted+-- binder. The continuation will be evaluated in a 'LiftM' context in which that+-- binder is deemed in scope. Think of it as a 'RWS.local' computation: After+-- the continuation finishes, the new binding won't be in scope anymore.+withSubstBndr :: Id -> (Id -> LiftM a) -> LiftM a+withSubstBndr bndr inner = LiftM $ do+  subst <- RWS.asks e_subst+  let (bndr', subst') = substBndr bndr subst+  RWS.local (\e -> e { e_subst = subst' }) (unwrapLiftM (inner bndr'))++-- | See 'withSubstBndr'.+withSubstBndrs :: Traversable f => f Id -> (f Id -> LiftM a) -> LiftM a+withSubstBndrs = runContT . traverse (ContT . withSubstBndr)++-- | Similarly to 'withSubstBndr', this function takes a set of variables to+-- abstract over, the binder to lift (and generate a fresh, substituted name+-- for) and a continuation in which that fresh, lifted binder is in scope.+--+-- It takes care of all the details involved with copying and adjusting the+-- binder, fresh name generation and caffyness.+withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a+withLiftedBndr abs_ids bndr inner = do+  uniq <- getUniqueM+  let str = "$l" ++ occNameString (getOccName bndr)+  let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr)+  -- When the enclosing top-level binding is not caffy, then the lifted+  -- binding will not be caffy either. If we don't recognize this, non-caffy+  -- things call caffy things and then codegen screws up.+  in_caffy_ctxt <- LiftM (RWS.asks e_in_caffy_context)+  let caf_info = if in_caffy_ctxt then MayHaveCafRefs else NoCafRefs+  let bndr'+        -- See Note [transferPolyIdInfo] in Id.hs. We need to do this at least+        -- for arity information.+        = transferPolyIdInfo bndr (dVarSetElems abs_ids)+        -- Otherwise we confuse code gen if bndr was not caffy: the new bndr is+        -- assumed to be caffy and will need an SRT. Transitive call sites might+        -- not be caffy themselves and subsequently will miss a static link+        -- field in their closure. Chaos ensues.+        . flip setIdCafInfo caf_info+        . mkSysLocalOrCoVar (mkFastString str) uniq+        $ ty+  LiftM $ RWS.local+    (\e -> e+      { e_subst = extendSubst bndr bndr' $ extendInScope bndr' $ e_subst e+      , e_expansions = extendVarEnv (e_expansions e) bndr abs_ids+      })+    (unwrapLiftM (inner bndr'))++-- | See 'withLiftedBndr'.+withLiftedBndrs :: Traversable f => DIdSet -> f Id -> (f Id -> LiftM a) -> LiftM a+withLiftedBndrs abs_ids = runContT . traverse (ContT . withLiftedBndr abs_ids)++-- | Substitutes a binder /occurrence/, which was brought in scope earlier by+-- 'withSubstBndr'\/'withLiftedBndr'.+substOcc :: Id -> LiftM Id+substOcc id = LiftM (RWS.asks (lookupIdSubst id . e_subst))++-- | Whether the given binding was decided to be lambda lifted.+isLifted :: InId -> LiftM Bool+isLifted bndr = LiftM (RWS.asks (elemVarEnv bndr . e_expansions))++-- | Returns an empty list for a binding that was not lifted and the list of all+-- local variables the binding abstracts over (so, exactly the additional+-- arguments at adjusted call sites) otherwise.+formerFreeVars :: InId -> LiftM [OutId]+formerFreeVars f = LiftM $ do+  expansions <- RWS.asks e_expansions+  pure $ case lookupVarEnv expansions f of+    Nothing -> []+    Just fvs -> dVarSetElems fvs++-- | Creates an /expander function/ for the current set of lifted binders.+-- This expander function will replace any 'InId' by their corresponding 'OutId'+-- and, in addition, will expand any lifted binders by the former free variables+-- it abstracts over.+liftedIdsExpander :: LiftM (DIdSet -> DIdSet)+liftedIdsExpander = LiftM $ do+  expansions <- RWS.asks e_expansions+  subst <- RWS.asks e_subst+  -- We use @noWarnLookupIdSubst@ here in order to suppress "not in scope"+  -- warnings generated by 'lookupIdSubst' due to local bindings within RHS.+  -- These are not in the InScopeSet of @subst@ and extending the InScopeSet in+  -- @goodToLift@/@closureGrowth@ before passing it on to @expander@ is too much+  -- trouble.+  let go set fv = case lookupVarEnv expansions fv of+        Nothing -> extendDVarSet set (noWarnLookupIdSubst fv subst) -- Not lifted+        Just fvs' -> unionDVarSet set fvs'+  let expander fvs = foldl' go emptyDVarSet (dVarSetElems fvs)+  pure expander
+ compiler/simplStg/StgLiftLams/Transformation.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE CPP #-}++-- | (Mostly) textbook instance of the lambda lifting transformation,+-- selecting which bindings to lambda lift by consulting 'goodToLift'.+module StgLiftLams.Transformation (stgLiftLams) where++#include "HsVersions.h"++import GhcPrelude++import BasicTypes+import DynFlags+import Id+import IdInfo+import StgFVs ( annBindingFreeVars )+import StgLiftLams.Analysis+import StgLiftLams.LiftM+import StgSyn+import Outputable+import UniqSupply+import Util+import VarSet+import Control.Monad ( when )+import Data.Maybe ( isNothing )++-- | Lambda lifts bindings to top-level deemed worth lifting (see 'goodToLift').+stgLiftLams :: DynFlags -> UniqSupply -> [InStgTopBinding] -> [OutStgTopBinding]+stgLiftLams dflags us = runLiftM dflags us . foldr liftTopLvl (pure ())++liftTopLvl :: InStgTopBinding -> LiftM () -> LiftM ()+liftTopLvl (StgTopStringLit bndr lit) rest = withSubstBndr bndr $ \bndr' -> do+  addTopStringLit bndr' lit+  rest+liftTopLvl (StgTopLifted bind) rest = do+  let is_rec = isRec $ fst $ decomposeStgBinding bind+  when is_rec startBindingGroup+  let bind_w_fvs = annBindingFreeVars bind+  withLiftedBind TopLevel (tagSkeletonTopBind bind_w_fvs) NilSk $ \mb_bind' -> do+    -- We signal lifting of a binding through returning Nothing.+    -- Should never happen for a top-level binding, though, since we are already+    -- at top-level.+    case mb_bind' of+      Nothing -> pprPanic "StgLiftLams" (text "Lifted top-level binding")+      Just bind' -> addLiftedBinding bind'+    when is_rec endBindingGroup+    rest++withLiftedBind+  :: TopLevelFlag+  -> LlStgBinding+  -> Skeleton+  -> (Maybe OutStgBinding -> LiftM a)+  -> LiftM a+withLiftedBind top_lvl bind scope k+  | isTopLevel top_lvl+  = withCaffyness (is_caffy pairs) go+  | otherwise+  = go+  where+    (rec, pairs) = decomposeStgBinding bind+    is_caffy = any (mayHaveCafRefs . idCafInfo . binderInfoBndr . fst)+    go = withLiftedBindPairs top_lvl rec pairs scope (k . fmap (mkStgBinding rec))++withLiftedBindPairs+  :: TopLevelFlag+  -> RecFlag+  -> [(BinderInfo, LlStgRhs)]+  -> Skeleton+  -> (Maybe [(Id, OutStgRhs)] -> LiftM a)+  -> LiftM a+withLiftedBindPairs top rec pairs scope k = do+  let (infos, rhss) = unzip pairs+  let bndrs = map binderInfoBndr infos+  expander <- liftedIdsExpander+  dflags <- getDynFlags+  case goodToLift dflags top rec expander pairs scope of+    -- @abs_ids@ is the set of all variables that need to become parameters.+    Just abs_ids -> withLiftedBndrs abs_ids bndrs $ \bndrs' -> do+      -- Within this block, all binders in @bndrs@ will be noted as lifted, so+      -- that the return value of @liftedIdsExpander@ in this context will also+      -- expand the bindings in @bndrs@ to their free variables.+      -- Now we can recurse into the RHSs and see if we can lift any further+      -- bindings. We pass the set of expanded free variables (thus OutIds) on+      -- to @liftRhs@ so that it can add them as parameter binders.+      when (isRec rec) startBindingGroup+      rhss' <- traverse (liftRhs (Just abs_ids)) rhss+      let pairs' = zip bndrs' rhss'+      addLiftedBinding (mkStgBinding rec pairs')+      when (isRec rec) endBindingGroup+      k Nothing+    Nothing -> withSubstBndrs bndrs $ \bndrs' -> do+      -- Don't lift the current binding, but possibly some bindings in their+      -- RHSs.+      rhss' <- traverse (liftRhs Nothing) rhss+      let pairs' = zip bndrs' rhss'+      k (Just pairs')++liftRhs+  :: Maybe (DIdSet)+  -- ^ @Just former_fvs@ <=> this RHS was lifted and we have to add @former_fvs@+  -- as lambda binders, discarding all free vars.+  -> LlStgRhs+  -> LiftM OutStgRhs+liftRhs mb_former_fvs rhs@(StgRhsCon ccs con args)+  = ASSERT2(isNothing mb_former_fvs, text "Should never lift a constructor" $$ ppr rhs)+    StgRhsCon ccs con <$> traverse liftArgs args+liftRhs Nothing (StgRhsClosure _ ccs upd infos body) = do+  -- This RHS wasn't lifted.+  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->+    StgRhsClosure noExtSilent ccs upd bndrs' <$> liftExpr body+liftRhs (Just former_fvs) (StgRhsClosure _ ccs upd infos body) = do+  -- This RHS was lifted. Insert extra binders for @former_fvs@.+  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' -> do+    let bndrs'' = dVarSetElems former_fvs ++ bndrs'+    StgRhsClosure noExtSilent ccs upd bndrs'' <$> liftExpr body++liftArgs :: InStgArg -> LiftM OutStgArg+liftArgs a@(StgLitArg _) = pure a+liftArgs (StgVarArg occ) = do+  ASSERTM2( not <$> isLifted occ, text "StgArgs should never be lifted" $$ ppr occ )+  StgVarArg <$> substOcc occ++liftExpr :: LlStgExpr -> LiftM OutStgExpr+liftExpr (StgLit lit) = pure (StgLit lit)+liftExpr (StgTick t e) = StgTick t <$> liftExpr e+liftExpr (StgApp f args) = do+  f' <- substOcc f+  args' <- traverse liftArgs args+  fvs' <- formerFreeVars f+  let top_lvl_args = map StgVarArg fvs' ++ args'+  pure (StgApp f' top_lvl_args)+liftExpr (StgConApp con args tys) = StgConApp con <$> traverse liftArgs args <*> pure tys+liftExpr (StgOpApp op args ty) = StgOpApp op <$> traverse liftArgs args <*> pure ty+liftExpr (StgLam _ _) = pprPanic "stgLiftLams" (text "StgLam")+liftExpr (StgCase scrut info ty alts) = do+  scrut' <- liftExpr scrut+  withSubstBndr (binderInfoBndr info) $ \bndr' -> do+    alts' <- traverse liftAlt alts+    pure (StgCase scrut' bndr' ty alts')+liftExpr (StgLet scope bind body)+  = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do+      body' <- liftExpr body+      case mb_bind' of+        Nothing -> pure body' -- withLiftedBindPairs decided to lift it and already added floats+        Just bind' -> pure (StgLet noExtSilent bind' body')+liftExpr (StgLetNoEscape scope bind body)+  = withLiftedBind NotTopLevel bind scope $ \mb_bind' -> do+      body' <- liftExpr body+      case mb_bind' of+        Nothing -> pprPanic "stgLiftLams" (text "Should never decide to lift LNEs")+        Just bind' -> pure (StgLetNoEscape noExtSilent bind' body')++liftAlt :: LlStgAlt -> LiftM OutStgAlt+liftAlt (con, infos, rhs) = withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->+  (,,) con bndrs' <$> liftExpr rhs
+ compiler/simplStg/StgStats.hs view
@@ -0,0 +1,173 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[StgStats]{Gathers statistical information about programs}+++The program gather statistics about+\begin{enumerate}+\item number of boxed cases+\item number of unboxed cases+\item number of let-no-escapes+\item number of non-updatable lets+\item number of updatable lets+\item number of applications+\item number of primitive applications+\item number of closures (does not include lets bound to constructors)+\item number of free variables in closures+%\item number of top-level functions+%\item number of top-level CAFs+\item number of constructors+\end{enumerate}+-}++{-# LANGUAGE CPP #-}++module StgStats ( showStgStats ) where++#include "HsVersions.h"++import GhcPrelude++import StgSyn++import Id (Id)+import Panic++import Data.Map (Map)+import qualified Data.Map as Map++data CounterType+  = Literals+  | Applications+  | ConstructorApps+  | PrimitiveApps+  | LetNoEscapes+  | StgCases+  | FreeVariables+  | ConstructorBinds Bool{-True<=>top-level-}+  | ReEntrantBinds   Bool{-ditto-}+  | SingleEntryBinds Bool{-ditto-}+  | UpdatableBinds   Bool{-ditto-}+  deriving (Eq, Ord)++type Count      = Int+type StatEnv    = Map CounterType Count++emptySE :: StatEnv+emptySE = Map.empty++combineSE :: StatEnv -> StatEnv -> StatEnv+combineSE = Map.unionWith (+)++combineSEs :: [StatEnv] -> StatEnv+combineSEs = foldr combineSE emptySE++countOne :: CounterType -> StatEnv+countOne c = Map.singleton c 1++{-+************************************************************************+*                                                                      *+\subsection{Top-level list of bindings (a ``program'')}+*                                                                      *+************************************************************************+-}++showStgStats :: [StgTopBinding] -> String++showStgStats prog+  = "STG Statistics:\n\n"+    ++ concat (map showc (Map.toList (gatherStgStats prog)))+  where+    showc (x,n) = (showString (s x) . shows n) "\n"++    s Literals                = "Literals                   "+    s Applications            = "Applications               "+    s ConstructorApps         = "ConstructorApps            "+    s PrimitiveApps           = "PrimitiveApps              "+    s LetNoEscapes            = "LetNoEscapes               "+    s StgCases                = "StgCases                   "+    s FreeVariables           = "FreeVariables              "+    s (ConstructorBinds True) = "ConstructorBinds_Top       "+    s (ReEntrantBinds True)   = "ReEntrantBinds_Top         "+    s (SingleEntryBinds True) = "SingleEntryBinds_Top       "+    s (UpdatableBinds True)   = "UpdatableBinds_Top         "+    s (ConstructorBinds _)    = "ConstructorBinds_Nested    "+    s (ReEntrantBinds _)      = "ReEntrantBindsBinds_Nested "+    s (SingleEntryBinds _)    = "SingleEntryBinds_Nested    "+    s (UpdatableBinds _)      = "UpdatableBinds_Nested      "++gatherStgStats :: [StgTopBinding] -> StatEnv+gatherStgStats binds = combineSEs (map statTopBinding binds)++{-+************************************************************************+*                                                                      *+\subsection{Bindings}+*                                                                      *+************************************************************************+-}++statTopBinding :: StgTopBinding -> StatEnv+statTopBinding (StgTopStringLit _ _) = countOne Literals+statTopBinding (StgTopLifted bind) = statBinding True bind++statBinding :: Bool -- True <=> top-level; False <=> nested+            -> StgBinding+            -> StatEnv++statBinding top (StgNonRec b rhs)+  = statRhs top (b, rhs)++statBinding top (StgRec pairs)+  = combineSEs (map (statRhs top) pairs)++statRhs :: Bool -> (Id, StgRhs) -> StatEnv++statRhs top (_, StgRhsCon _ _ _)+  = countOne (ConstructorBinds top)++statRhs top (_, StgRhsClosure _ _ u _ body)+  = statExpr body `combineSE`+    countOne (+      case u of+        ReEntrant   -> ReEntrantBinds   top+        Updatable   -> UpdatableBinds   top+        SingleEntry -> SingleEntryBinds top+    )++{-+************************************************************************+*                                                                      *+\subsection{Expressions}+*                                                                      *+************************************************************************+-}++statExpr :: StgExpr -> StatEnv++statExpr (StgApp _ _)     = countOne Applications+statExpr (StgLit _)       = countOne Literals+statExpr (StgConApp _ _ _)= countOne ConstructorApps+statExpr (StgOpApp _ _ _) = countOne PrimitiveApps+statExpr (StgTick _ e)    = statExpr e++statExpr (StgLetNoEscape _ binds body)+  = statBinding False{-not top-level-} binds    `combineSE`+    statExpr body                               `combineSE`+    countOne LetNoEscapes++statExpr (StgLet _ binds body)+  = statBinding False{-not top-level-} binds    `combineSE`+    statExpr body++statExpr (StgCase expr _ _ alts)+  = statExpr expr       `combineSE`+    stat_alts alts      `combineSE`+    countOne StgCases+  where+    stat_alts alts+        = combineSEs (map statExpr [ e | (_,_,e) <- alts ])++statExpr (StgLam {}) = panic "statExpr StgLam"
+ compiler/simplStg/UnariseStg.hs view
@@ -0,0 +1,767 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-2012++Note [Unarisation]+~~~~~~~~~~~~~~~~~~+The idea of this pass is to translate away *all* unboxed-tuple and unboxed-sum+binders. So for example:++  f (x :: (# Int, Bool #)) = f x + f (# 1, True #)++  ==>++  f (x1 :: Int) (x2 :: Bool) = f x1 x2 + f 1 True++It is important that we do this at the STG level and NOT at the Core level+because it would be very hard to make this pass Core-type-preserving. In this+example the type of 'f' changes, for example.++STG fed to the code generators *must* be unarised because the code generators do+not support unboxed tuple and unboxed sum binders natively.++In more detail: (see next note for unboxed sums)++Suppose that a variable x : (# t1, t2 #).++  * At the binding site for x, make up fresh vars  x1:t1, x2:t2++  * Extend the UnariseEnv   x :-> MultiVal [x1,x2]++  * Replace the binding with a curried binding for x1,x2++       Lambda:   \x.e                ==>   \x1 x2. e+       Case alt: MkT a b x c d -> e  ==>   MkT a b x1 x2 c d -> e++  * Replace argument occurrences with a sequence of args via a lookup in+    UnariseEnv++       f a b x c d   ==>   f a b x1 x2 c d++  * Replace tail-call occurrences with an unboxed tuple via a lookup in+    UnariseEnv++       x  ==>  (# x1, x2 #)++    So, for example++       f x = x    ==>   f x1 x2 = (# x1, x2 #)++  * We /always/ eliminate a case expression when++       - It scrutinises an unboxed tuple or unboxed sum++       - The scrutinee is a variable (or when it is an explicit tuple, but the+         simplifier eliminates those)++    The case alternative (there can be only one) can be one of these two+    things:++      - An unboxed tuple pattern. e.g.++          case v of x { (# x1, x2, x3 #) -> ... }++        Scrutinee has to be in form `(# t1, t2, t3 #)` so we just extend the+        environment with++          x :-> MultiVal [t1,t2,t3]+          x1 :-> UnaryVal t1, x2 :-> UnaryVal t2, x3 :-> UnaryVal t3++      - A DEFAULT alternative. Just the same, without the bindings for x1,x2,x3++By the end of this pass, we only have unboxed tuples in return positions.+Unboxed sums are completely eliminated, see next note.++Note [Translating unboxed sums to unboxed tuples]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unarise also eliminates unboxed sum binders, and translates unboxed sums in+return positions to unboxed tuples. We want to overlap fields of a sum when+translating it to a tuple to have efficient memory layout. When translating a+sum pattern to a tuple pattern, we need to translate it so that binders of sum+alternatives will be mapped to right arguments after the term translation. So+translation of sum DataCon applications to tuple DataCon applications and+translation of sum patterns to tuple patterns need to be in sync.++These translations work like this. Suppose we have++  (# x1 | | ... #) :: (# t1 | t2 | ... #)++remember that t1, t2 ... can be sums and tuples too. So we first generate+layouts of those. Then we "merge" layouts of each alternative, which gives us a+sum layout with best overlapping possible.++Layout of a flat type 'ty1' is just [ty1].+Layout of a tuple is just concatenation of layouts of its fields.++For layout of a sum type,++  - We first get layouts of all alternatives.+  - We sort these layouts based on their "slot types".+  - We merge all the alternatives.++For example, say we have (# (# Int#, Char #) | (# Int#, Int# #) | Int# #)++  - Layouts of alternatives: [ [Word, Ptr], [Word, Word], [Word] ]+  - Sorted: [ [Ptr, Word], [Word, Word], [Word] ]+  - Merge all alternatives together: [ Ptr, Word, Word ]++We add a slot for the tag to the first position. So our tuple type is++  (# Tag#, Any, Word#, Word# #)+  (we use Any for pointer slots)++Now, any term of this sum type needs to generate a tuple of this type instead.+The translation works by simply putting arguments to first slots that they fit+in. Suppose we had++  (# (# 42#, 'c' #) | | #)++42# fits in Word#, 'c' fits in Any, so we generate this application:++  (# 1#, 'c', 42#, rubbish #)++Another example using the same type: (# | (# 2#, 3# #) | #). 2# fits in Word#,+3# fits in Word #, so we get:++  (# 2#, rubbish, 2#, 3# #).++Note [Types in StgConApp]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have this unboxed sum term:++  (# 123 | #)++What will be the unboxed tuple representation? We can't tell without knowing the+type of this term. For example, these are all valid tuples for this:++  (# 1#, 123 #)          -- when type is (# Int | String #)+  (# 1#, 123, rubbish #) -- when type is (# Int | Float# #)+  (# 1#, 123, rubbish, rubbish #)+                         -- when type is (# Int | (# Int, Int, Int #) #)++So we pass type arguments of the DataCon's TyCon in StgConApp to decide what+layout to use. Note that unlifted values can't be let-bound, so we don't need+types in StgRhsCon.++Note [UnariseEnv can map to literals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To avoid redundant case expressions when unarising unboxed sums, UnariseEnv+needs to map variables to literals too. Suppose we have this Core:++  f (# x | #)++  ==> (CorePrep)++  case (# x | #) of y {+    _ -> f y+  }++  ==> (MultiVal)++  case (# 1#, x #) of [x1, x2] {+    _ -> f x1 x2+  }++To eliminate this case expression we need to map x1 to 1# in UnariseEnv:++  x1 :-> UnaryVal 1#, x2 :-> UnaryVal x++so that `f x1 x2` becomes `f 1# x`.++Note [Unarisation and arity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because of unarisation, the arity that will be recorded in the generated info+table for an Id may be larger than the idArity. Instead we record what we call+the RepArity, which is the Arity taking into account any expanded arguments, and+corresponds to the number of (possibly-void) *registers* arguments will arrive+in.++Note [Post-unarisation invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+STG programs after unarisation have these invariants:++  * No unboxed sums at all.++  * No unboxed tuple binders. Tuples only appear in return position.++  * DataCon applications (StgRhsCon and StgConApp) don't have void arguments.+    This means that it's safe to wrap `StgArg`s of DataCon applications with+    `StgCmmEnv.NonVoid`, for example.++  * Alt binders (binders in patterns) are always non-void.+-}++{-# LANGUAGE CPP, TupleSections #-}++module UnariseStg (unarise) where++#include "HsVersions.h"++import GhcPrelude++import BasicTypes+import CoreSyn+import DataCon+import FastString (FastString, mkFastString)+import Id+import Literal+import MkCore (aBSENT_SUM_FIELD_ERROR_ID)+import MkId (voidPrimId, voidArgId)+import MonadUtils (mapAccumLM)+import Outputable+import RepType+import StgSyn+import Type+import TysPrim (intPrimTy,wordPrimTy,word64PrimTy)+import TysWiredIn+import UniqSupply+import Util+import VarEnv++import Data.Bifunctor (second)+import Data.Maybe (mapMaybe)+import qualified Data.IntMap as IM++--------------------------------------------------------------------------------++-- | A mapping from binders to the Ids they were expanded/renamed to.+--+--   x :-> MultiVal [a,b,c] in rho+--+-- iff  x's typePrimRep is not a singleton, or equivalently+--      x's type is an unboxed tuple, sum or void.+--+--    x :-> UnaryVal x'+--+-- iff x's RepType is UnaryRep or equivalently+--     x's type is not unboxed tuple, sum or void.+--+-- So+--     x :-> MultiVal [a] in rho+-- means x is represented by singleton tuple.+--+--     x :-> MultiVal [] in rho+-- means x is void.+--+-- INVARIANT: OutStgArgs in the range only have NvUnaryTypes+--            (i.e. no unboxed tuples, sums or voids)+--+type UnariseEnv = VarEnv UnariseVal++data UnariseVal+  = MultiVal [OutStgArg] -- MultiVal to tuple. Can be empty list (void).+  | UnaryVal OutStgArg   -- See NOTE [Renaming during unarisation].++instance Outputable UnariseVal where+  ppr (MultiVal args) = text "MultiVal" <+> ppr args+  ppr (UnaryVal arg)   = text "UnaryVal" <+> ppr arg++-- | Extend the environment, checking the UnariseEnv invariant.+extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv+extendRho rho x (MultiVal args)+  = ASSERT(all (isNvUnaryType . stgArgType) args)+    extendVarEnv rho x (MultiVal args)+extendRho rho x (UnaryVal val)+  = ASSERT(isNvUnaryType (stgArgType val))+    extendVarEnv rho x (UnaryVal val)++--------------------------------------------------------------------------------++unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]+unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds)++unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding+unariseTopBinding rho (StgTopLifted bind)+  = StgTopLifted <$> unariseBinding rho bind+unariseTopBinding _ bind@StgTopStringLit{} = return bind++unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding+unariseBinding rho (StgNonRec x rhs)+  = StgNonRec x <$> unariseRhs rho rhs+unariseBinding rho (StgRec xrhss)+  = StgRec <$> mapM (\(x, rhs) -> (x,) <$> unariseRhs rho rhs) xrhss++unariseRhs :: UnariseEnv -> StgRhs -> UniqSM StgRhs+unariseRhs rho (StgRhsClosure ext ccs update_flag args expr)+  = do (rho', args1) <- unariseFunArgBinders rho args+       expr' <- unariseExpr rho' expr+       return (StgRhsClosure ext ccs update_flag args1 expr')++unariseRhs rho (StgRhsCon ccs con args)+  = ASSERT(not (isUnboxedTupleCon con || isUnboxedSumCon con))+    return (StgRhsCon ccs con (unariseConArgs rho args))++--------------------------------------------------------------------------------++unariseExpr :: UnariseEnv -> StgExpr -> UniqSM StgExpr++unariseExpr rho e@(StgApp f [])+  = case lookupVarEnv rho f of+      Just (MultiVal args)  -- Including empty tuples+        -> return (mkTuple args)+      Just (UnaryVal (StgVarArg f'))+        -> return (StgApp f' [])+      Just (UnaryVal (StgLitArg f'))+        -> return (StgLit f')+      Nothing+        -> return e++unariseExpr rho e@(StgApp f args)+  = return (StgApp f' (unariseFunArgs rho args))+  where+    f' = case lookupVarEnv rho f of+           Just (UnaryVal (StgVarArg f')) -> f'+           Nothing -> f+           err -> pprPanic "unariseExpr - app2" (ppr e $$ ppr err)+               -- Can't happen because 'args' is non-empty, and+               -- a tuple or sum cannot be applied to anything++unariseExpr _ (StgLit l)+  = return (StgLit l)++unariseExpr rho (StgConApp dc args ty_args)+  | Just args' <- unariseMulti_maybe rho dc args ty_args+  = return (mkTuple args')++  | otherwise+  , let args' = unariseConArgs rho args+  = return (StgConApp dc args' (map stgArgType args'))++unariseExpr rho (StgOpApp op args ty)+  = return (StgOpApp op (unariseFunArgs rho args) ty)++unariseExpr _ e@StgLam{}+  = pprPanic "unariseExpr: found lambda" (ppr e)++unariseExpr rho (StgCase scrut bndr alt_ty alts)+  -- tuple/sum binders in the scrutinee can always be eliminated+  | StgApp v [] <- scrut+  , Just (MultiVal xs) <- lookupVarEnv rho v+  = elimCase rho xs bndr alt_ty alts++  -- Handle strict lets for tuples and sums:+  --   case (# a,b #) of r -> rhs+  -- and analogously for sums+  | StgConApp dc args ty_args <- scrut+  , Just args' <- unariseMulti_maybe rho dc args ty_args+  = elimCase rho args' bndr alt_ty alts++  -- general case+  | otherwise+  = do scrut' <- unariseExpr rho scrut+       alts'  <- unariseAlts rho alt_ty bndr alts+       return (StgCase scrut' bndr alt_ty alts')+                       -- bndr may have a unboxed sum/tuple type but it will be+                       -- dead after unarise (checked in StgLint)++unariseExpr rho (StgLet ext bind e)+  = StgLet ext <$> unariseBinding rho bind <*> unariseExpr rho e++unariseExpr rho (StgLetNoEscape ext bind e)+  = StgLetNoEscape ext <$> unariseBinding rho bind <*> unariseExpr rho e++unariseExpr rho (StgTick tick e)+  = StgTick tick <$> unariseExpr rho e++-- Doesn't return void args.+unariseMulti_maybe :: UnariseEnv -> DataCon -> [InStgArg] -> [Type] -> Maybe [OutStgArg]+unariseMulti_maybe rho dc args ty_args+  | isUnboxedTupleCon dc+  = Just (unariseConArgs rho args)++  | isUnboxedSumCon dc+  , let args1 = ASSERT(isSingleton args) (unariseConArgs rho args)+  = Just (mkUbxSum dc ty_args args1)++  | otherwise+  = Nothing++--------------------------------------------------------------------------------++elimCase :: UnariseEnv+         -> [OutStgArg] -- non-void args+         -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr++elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]+  = do let rho1 = extendRho rho bndr (MultiVal args)+           rho2+             | isUnboxedTupleBndr bndr+             = mapTupleIdBinders bndrs args rho1+             | otherwise+             = ASSERT(isUnboxedSumBndr bndr)+               if null bndrs then rho1+                             else mapSumIdBinders bndrs args rho1++       unariseExpr rho2 rhs++elimCase rho args bndr (MultiValAlt _) alts+  | isUnboxedSumBndr bndr+  = do let (tag_arg : real_args) = args+       tag_bndr <- mkId (mkFastString "tag") tagTy+          -- this won't be used but we need a binder anyway+       let rho1 = extendRho rho bndr (MultiVal args)+           scrut' = case tag_arg of+                      StgVarArg v     -> StgApp v []+                      StgLitArg l     -> StgLit l++       alts' <- unariseSumAlts rho1 real_args alts+       return (StgCase scrut' tag_bndr tagAltTy alts')++elimCase _ args bndr alt_ty alts+  = pprPanic "elimCase - unhandled case"+      (ppr args <+> ppr bndr <+> ppr alt_ty $$ ppr alts)++--------------------------------------------------------------------------------++unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]+unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]+  | isUnboxedTupleBndr bndr+  = do (rho', ys) <- unariseConArgBinder rho bndr+       e' <- unariseExpr rho' e+       return [(DataAlt (tupleDataCon Unboxed n), ys, e')]++unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]+  | isUnboxedTupleBndr bndr+  = do (rho', ys1) <- unariseConArgBinders rho ys+       MASSERT(ys1 `lengthIs` n)+       let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))+       e' <- unariseExpr rho'' e+       return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]++unariseAlts _ (MultiValAlt _) bndr alts+  | isUnboxedTupleBndr bndr+  = pprPanic "unariseExpr: strange multi val alts" (ppr alts)++-- In this case we don't need to scrutinize the tag bit+unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]+  | isUnboxedSumBndr bndr+  = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr+       rhs' <- unariseExpr rho_sum_bndrs rhs+       return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')]++unariseAlts rho (MultiValAlt _) bndr alts+  | isUnboxedSumBndr bndr+  = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr+       alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts+       let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'+       return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)),+                 scrt_bndrs,+                 inner_case) ]++unariseAlts rho _ _ alts+  = mapM (\alt -> unariseAlt rho alt) alts++unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt+unariseAlt rho (con, xs, e)+  = do (rho', xs') <- unariseConArgBinders rho xs+       (con, xs',) <$> unariseExpr rho' e++--------------------------------------------------------------------------------++-- | Make alternatives that match on the tag of a sum+-- (i.e. generate LitAlts for the tag)+unariseSumAlts :: UnariseEnv+               -> [StgArg] -- sum components _excluding_ the tag bit.+               -> [StgAlt] -- original alternative with sum LHS+               -> UniqSM [StgAlt]+unariseSumAlts env args alts+  = do alts' <- mapM (unariseSumAlt env args) alts+       return (mkDefaultLitAlt alts')++unariseSumAlt :: UnariseEnv+              -> [StgArg] -- sum components _excluding_ the tag bit.+              -> StgAlt   -- original alternative with sum LHS+              -> UniqSM StgAlt+unariseSumAlt rho _ (DEFAULT, _, e)+  = ( DEFAULT, [], ) <$> unariseExpr rho e++unariseSumAlt rho args (DataAlt sumCon, bs, e)+  = do let rho' = mapSumIdBinders bs args rho+       e' <- unariseExpr rho' e+       return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)) intPrimTy), [], e' )++unariseSumAlt _ scrt alt+  = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt)++--------------------------------------------------------------------------------++mapTupleIdBinders+  :: [InId]       -- Un-processed binders of a tuple alternative.+                  -- Can have void binders.+  -> [OutStgArg]  -- Arguments that form the tuple (after unarisation).+                  -- Can't have void args.+  -> UnariseEnv+  -> UnariseEnv+mapTupleIdBinders ids args0 rho0+  = ASSERT(not (any (isVoidTy . stgArgType) args0))+    let+      ids_unarised :: [(Id, [PrimRep])]+      ids_unarised = map (\id -> (id, typePrimRep (idType id))) ids++      map_ids :: UnariseEnv -> [(Id, [PrimRep])] -> [StgArg] -> UnariseEnv+      map_ids rho [] _  = rho+      map_ids rho ((x, x_reps) : xs) args =+        let+          x_arity = length x_reps+          (x_args, args') =+            ASSERT(args `lengthAtLeast` x_arity)+            splitAt x_arity args++          rho'+            | x_arity == 1+            = ASSERT(x_args `lengthIs` 1)+              extendRho rho x (UnaryVal (head x_args))+            | otherwise+            = extendRho rho x (MultiVal x_args)+        in+          map_ids rho' xs args'+    in+      map_ids rho0 ids_unarised args0++mapSumIdBinders+  :: [InId]      -- Binder of a sum alternative (remember that sum patterns+                 -- only have one binder, so this list should be a singleton)+  -> [OutStgArg] -- Arguments that form the sum (NOT including the tag).+                 -- Can't have void args.+  -> UnariseEnv+  -> UnariseEnv++mapSumIdBinders [id] args rho0+  = ASSERT(not (any (isVoidTy . stgArgType) args))+    let+      arg_slots = map primRepSlot $ concatMap (typePrimRep . stgArgType) args+      id_slots  = map primRepSlot $ typePrimRep (idType id)+      layout1   = layoutUbxSum arg_slots id_slots+    in+      if isMultiValBndr id+        then extendRho rho0 id (MultiVal [ args !! i | i <- layout1 ])+        else ASSERT(layout1 `lengthIs` 1)+             extendRho rho0 id (UnaryVal (args !! head layout1))++mapSumIdBinders ids sum_args _+  = pprPanic "mapSumIdBinders" (ppr ids $$ ppr sum_args)++-- | Build a unboxed sum term from arguments of an alternative.+--+-- Example, for (# x | #) :: (# (# #) | Int #) we call+--+--   mkUbxSum (# _ | #) [ (# #), Int ] [ voidPrimId ]+--+-- which returns+--+--   [ 1#, rubbish ]+--+mkUbxSum+  :: DataCon      -- Sum data con+  -> [Type]       -- Type arguments of the sum data con+  -> [OutStgArg]  -- Actual arguments of the alternative.+  -> [OutStgArg]  -- Final tuple arguments+mkUbxSum dc ty_args args0+  = let+      (_ : sum_slots) = ubxSumRepType (map typePrimRep ty_args)+        -- drop tag slot++      tag = dataConTag dc++      layout'  = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)+      tag_arg  = StgLitArg (LitNumber LitNumInt (fromIntegral tag) intPrimTy)+      arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)++      mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]+      mkTupArgs _ [] _+        = []+      mkTupArgs arg_idx (slot : slots_left) arg_map+        | Just stg_arg <- IM.lookup arg_idx arg_map+        = stg_arg : mkTupArgs (arg_idx + 1) slots_left arg_map+        | otherwise+        = slotRubbishArg slot : mkTupArgs (arg_idx + 1) slots_left arg_map++      slotRubbishArg :: SlotTy -> StgArg+      slotRubbishArg PtrSlot    = StgVarArg aBSENT_SUM_FIELD_ERROR_ID+                         -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in MkCore+      slotRubbishArg WordSlot   = StgLitArg (LitNumber LitNumWord 0 wordPrimTy)+      slotRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy)+      slotRubbishArg FloatSlot  = StgLitArg (LitFloat 0)+      slotRubbishArg DoubleSlot = StgLitArg (LitDouble 0)+    in+      tag_arg : mkTupArgs 0 sum_slots arg_idxs++--------------------------------------------------------------------------------++{-+For arguments (StgArg) and binders (Id) we have two kind of unarisation:++  - When unarising function arg binders and arguments, we don't want to remove+    void binders and arguments. For example,++      f :: (# (# #), (# #) #) -> Void# -> RealWorld# -> ...+      f x y z = <body>++    Here after unarise we should still get a function with arity 3. Similarly+    in the call site we shouldn't remove void arguments:++      f (# (# #), (# #) #) voidId rw++    When unarising <body>, we extend the environment with these binders:++      x :-> MultiVal [], y :-> MultiVal [], z :-> MultiVal []++    Because their rep types are `MultiRep []` (aka. void). This means that when+    we see `x` in a function argument position, we actually replace it with a+    void argument. When we see it in a DataCon argument position, we just get+    rid of it, because DataCon applications in STG are always saturated.++  - When unarising case alternative binders we remove void binders, but we+    still update the environment the same way, because those binders may be+    used in the RHS. Example:++      case x of y {+        (# x1, x2, x3 #) -> <RHS>+      }++    We know that y can't be void, because we don't scrutinize voids, so x will+    be unarised to some number of arguments, and those arguments will have at+    least one non-void thing. So in the rho we will have something like:++      x :-> MultiVal [xu1, xu2]++    Now, after we eliminate void binders in the pattern, we get exactly the same+    number of binders, and extend rho again with these:++      x1 :-> UnaryVal xu1+      x2 :-> MultiVal [] -- x2 is void+      x3 :-> UnaryVal xu2++    Now when we see x2 in a function argument position or in return position, we+    generate void#. In constructor argument position, we just remove it.++So in short, when we have a void id,++  - We keep it if it's a lambda argument binder or+                       in argument position of an application.++  - We remove it if it's a DataCon field binder or+                         in argument position of a DataCon application.+-}++unariseArgBinder+    :: Bool -- data con arg?+    -> UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])+unariseArgBinder is_con_arg rho x =+  case typePrimRep (idType x) of+    []+      | is_con_arg+      -> return (extendRho rho x (MultiVal []), [])+      | otherwise -- fun arg, do not remove void binders+      -> return (extendRho rho x (MultiVal []), [voidArgId])++    [rep]+      -- Arg represented as single variable, but original type may still be an+      -- unboxed sum/tuple, e.g. (# Void# | Void# #).+      --+      -- While not unarising the binder in this case does not break any programs+      -- (because it unarises to a single variable), it triggers StgLint as we+      -- break the the post-unarisation invariant that says unboxed tuple/sum+      -- binders should vanish. See Note [Post-unarisation invariants].+      | isUnboxedSumType (idType x) || isUnboxedTupleType (idType x)+      -> do x' <- mkId (mkFastString "us") (primRepToType rep)+            return (extendRho rho x (MultiVal [StgVarArg x']), [x'])+      | otherwise+      -> return (rho, [x])++    reps -> do+      xs <- mkIds (mkFastString "us") (map primRepToType reps)+      return (extendRho rho x (MultiVal (map StgVarArg xs)), xs)++--------------------------------------------------------------------------------++-- | MultiVal a function argument. Never returns an empty list.+unariseFunArg :: UnariseEnv -> StgArg -> [StgArg]+unariseFunArg rho (StgVarArg x) =+  case lookupVarEnv rho x of+    Just (MultiVal [])  -> [voidArg]   -- NB: do not remove void args+    Just (MultiVal as)  -> as+    Just (UnaryVal arg) -> [arg]+    Nothing             -> [StgVarArg x]+unariseFunArg _ arg = [arg]++unariseFunArgs :: UnariseEnv -> [StgArg] -> [StgArg]+unariseFunArgs = concatMap . unariseFunArg++unariseFunArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])+unariseFunArgBinders rho xs = second concat <$> mapAccumLM unariseFunArgBinder rho xs++-- Result list of binders is never empty+unariseFunArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])+unariseFunArgBinder = unariseArgBinder False++--------------------------------------------------------------------------------++-- | MultiVal a DataCon argument. Returns an empty list when argument is void.+unariseConArg :: UnariseEnv -> InStgArg -> [OutStgArg]+unariseConArg rho (StgVarArg x) =+  case lookupVarEnv rho x of+    Just (UnaryVal arg) -> [arg]+    Just (MultiVal as) -> as      -- 'as' can be empty+    Nothing+      | isVoidTy (idType x) -> [] -- e.g. C realWorld#+                                  -- Here realWorld# is not in the envt, but+                                  -- is a void, and so should be eliminated+      | otherwise -> [StgVarArg x]+unariseConArg _ arg@(StgLitArg lit) =+    ASSERT(not (isVoidTy (literalType lit)))  -- We have no void literals+    [arg]++unariseConArgs :: UnariseEnv -> [InStgArg] -> [OutStgArg]+unariseConArgs = concatMap . unariseConArg++unariseConArgBinders :: UnariseEnv -> [Id] -> UniqSM (UnariseEnv, [Id])+unariseConArgBinders rho xs = second concat <$> mapAccumLM unariseConArgBinder rho xs++-- Different from `unariseFunArgBinder`: result list of binders may be empty.+-- See DataCon applications case in Note [Post-unarisation invariants].+unariseConArgBinder :: UnariseEnv -> Id -> UniqSM (UnariseEnv, [Id])+unariseConArgBinder = unariseArgBinder True++--------------------------------------------------------------------------------++mkIds :: FastString -> [UnaryType] -> UniqSM [Id]+mkIds fs tys = mapM (mkId fs) tys++mkId :: FastString -> UnaryType -> UniqSM Id+mkId = mkSysLocalOrCoVarM++isMultiValBndr :: Id -> Bool+isMultiValBndr id+  | [_] <- typePrimRep (idType id)+  = False+  | otherwise+  = True++isUnboxedSumBndr :: Id -> Bool+isUnboxedSumBndr = isUnboxedSumType . idType++isUnboxedTupleBndr :: Id -> Bool+isUnboxedTupleBndr = isUnboxedTupleType . idType++mkTuple :: [StgArg] -> StgExpr+mkTuple args = StgConApp (tupleDataCon Unboxed (length args)) args (map stgArgType args)++tagAltTy :: AltType+tagAltTy = PrimAlt IntRep++tagTy :: Type+tagTy = intPrimTy++voidArg :: StgArg+voidArg = StgVarArg voidPrimId++mkDefaultLitAlt :: [StgAlt] -> [StgAlt]+-- We have an exhauseive list of literal alternatives+--    1# -> e1+--    2# -> e2+-- Since they are exhaustive, we can replace one with DEFAULT, to avoid+-- generating a final test. Remember, the DEFAULT comes first if it exists.+mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")+mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts+mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts+mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> ppr alts)
+ compiler/specialise/SpecConstr.hs view
@@ -0,0 +1,2356 @@+{-+ToDo [Oct 2013]+~~~~~~~~~~~~~~~+1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim)+2. Nuke NoSpecConstr+++(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[SpecConstr]{Specialise over constructors}+-}++{-# LANGUAGE CPP #-}++module SpecConstr(+        specConstrProgram,+        SpecConstrAnnotation(..)+    ) where++#include "HsVersions.h"++import GhcPrelude++import CoreSyn+import CoreSubst+import CoreUtils+import CoreUnfold       ( couldBeSmallEnoughToInline )+import CoreFVs          ( exprsFreeVarsList )+import CoreMonad+import Literal          ( litIsLifted )+import HscTypes         ( ModGuts(..) )+import WwLib            ( isWorkerSmallEnough, mkWorkerArgs )+import DataCon+import Coercion         hiding( substCo )+import Rules+import Type             hiding ( substTy )+import TyCon            ( tyConName )+import Id+import PprCore          ( pprParendExpr )+import MkCore           ( mkImpossibleExpr )+import VarEnv+import VarSet+import Name+import BasicTypes+import DynFlags         ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )+                        , gopt, hasPprDebug )+import Maybes           ( orElse, catMaybes, isJust, isNothing )+import Demand+import GHC.Serialized   ( deserializeWithData )+import Util+import Pair+import UniqSupply+import Outputable+import FastString+import UniqFM+import MonadUtils+import Control.Monad    ( zipWithM )+import Data.List+import PrelNames        ( specTyConName )+import Module+import TyCon ( TyCon )+import GHC.Exts( SpecConstrAnnotation(..) )+import Data.Ord( comparing )++{-+-----------------------------------------------------+                        Game plan+-----------------------------------------------------++Consider+        drop n []     = []+        drop 0 xs     = []+        drop n (x:xs) = drop (n-1) xs++After the first time round, we could pass n unboxed.  This happens in+numerical code too.  Here's what it looks like in Core:++        drop n xs = case xs of+                      []     -> []+                      (y:ys) -> case n of+                                  I# n# -> case n# of+                                             0 -> []+                                             _ -> drop (I# (n# -# 1#)) xs++Notice that the recursive call has an explicit constructor as argument.+Noticing this, we can make a specialised version of drop++        RULE: drop (I# n#) xs ==> drop' n# xs++        drop' n# xs = let n = I# n# in ...orig RHS...++Now the simplifier will apply the specialisation in the rhs of drop', giving++        drop' n# xs = case xs of+                      []     -> []+                      (y:ys) -> case n# of+                                  0 -> []+                                  _ -> drop' (n# -# 1#) xs++Much better!++We'd also like to catch cases where a parameter is carried along unchanged,+but evaluated each time round the loop:++        f i n = if i>0 || i>n then i else f (i*2) n++Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.+In Core, by the time we've w/wd (f is strict in i) we get++        f i# n = case i# ># 0 of+                   False -> I# i#+                   True  -> case n of { I# n# ->+                            case i# ># n# of+                                False -> I# i#+                                True  -> f (i# *# 2#) n++At the call to f, we see that the argument, n is known to be (I# n#),+and n is evaluated elsewhere in the body of f, so we can play the same+trick as above.+++Note [Reboxing]+~~~~~~~~~~~~~~~+We must be careful not to allocate the same constructor twice.  Consider+        f p = (...(case p of (a,b) -> e)...p...,+               ...let t = (r,s) in ...t...(f t)...)+At the recursive call to f, we can see that t is a pair.  But we do NOT want+to make a specialised copy:+        f' a b = let p = (a,b) in (..., ...)+because now t is allocated by the caller, then r and s are passed to the+recursive call, which allocates the (r,s) pair again.++This happens if+  (a) the argument p is used in other than a case-scrutinisation way.+  (b) the argument to the call is not a 'fresh' tuple; you have to+        look into its unfolding to see that it's a tuple++Hence the "OR" part of Note [Good arguments] below.++ALTERNATIVE 2: pass both boxed and unboxed versions.  This no longer saves+allocation, but does perhaps save evals. In the RULE we'd have+something like++  f (I# x#) = f' (I# x#) x#++If at the call site the (I# x) was an unfolding, then we'd have to+rely on CSE to eliminate the duplicate allocation.... This alternative+doesn't look attractive enough to pursue.++ALTERNATIVE 3: ignore the reboxing problem.  The trouble is that+the conservative reboxing story prevents many useful functions from being+specialised.  Example:+        foo :: Maybe Int -> Int -> Int+        foo   (Just m) 0 = 0+        foo x@(Just m) n = foo x (n-m)+Here the use of 'x' will clearly not require boxing in the specialised function.++The strictness analyser has the same problem, in fact.  Example:+        f p@(a,b) = ...+If we pass just 'a' and 'b' to the worker, it might need to rebox the+pair to create (a,b).  A more sophisticated analysis might figure out+precisely the cases in which this could happen, but the strictness+analyser does no such analysis; it just passes 'a' and 'b', and hopes+for the best.++So my current choice is to make SpecConstr similarly aggressive, and+ignore the bad potential of reboxing.+++Note [Good arguments]+~~~~~~~~~~~~~~~~~~~~~+So we look for++* A self-recursive function.  Ignore mutual recursion for now,+  because it's less common, and the code is simpler for self-recursion.++* EITHER++   a) At a recursive call, one or more parameters is an explicit+      constructor application+        AND+      That same parameter is scrutinised by a case somewhere in+      the RHS of the function++  OR++    b) At a recursive call, one or more parameters has an unfolding+       that is an explicit constructor application+        AND+      That same parameter is scrutinised by a case somewhere in+      the RHS of the function+        AND+      Those are the only uses of the parameter (see Note [Reboxing])+++What to abstract over+~~~~~~~~~~~~~~~~~~~~~+There's a bit of a complication with type arguments.  If the call+site looks like++        f p = ...f ((:) [a] x xs)...++then our specialised function look like++        f_spec x xs = let p = (:) [a] x xs in ....as before....++This only makes sense if either+  a) the type variable 'a' is in scope at the top of f, or+  b) the type variable 'a' is an argument to f (and hence fs)++Actually, (a) may hold for value arguments too, in which case+we may not want to pass them.  Suppose 'x' is in scope at f's+defn, but xs is not.  Then we'd like++        f_spec xs = let p = (:) [a] x xs in ....as before....++Similarly (b) may hold too.  If x is already an argument at the+call, no need to pass it again.++Finally, if 'a' is not in scope at the call site, we could abstract+it as we do the term variables:++        f_spec a x xs = let p = (:) [a] x xs in ...as before...++So the grand plan is:++        * abstract the call site to a constructor-only pattern+          e.g.  C x (D (f p) (g q))  ==>  C s1 (D s2 s3)++        * Find the free variables of the abstracted pattern++        * Pass these variables, less any that are in scope at+          the fn defn.  But see Note [Shadowing] below.+++NOTICE that we only abstract over variables that are not in scope,+so we're in no danger of shadowing variables used in "higher up"+in f_spec's RHS.+++Note [Shadowing]+~~~~~~~~~~~~~~~~+In this pass we gather up usage information that may mention variables+that are bound between the usage site and the definition site; or (more+seriously) may be bound to something different at the definition site.+For example:++        f x = letrec g y v = let x = ...+                             in ...(g (a,b) x)...++Since 'x' is in scope at the call site, we may make a rewrite rule that+looks like+        RULE forall a,b. g (a,b) x = ...+But this rule will never match, because it's really a different 'x' at+the call site -- and that difference will be manifest by the time the+simplifier gets to it.  [A worry: the simplifier doesn't *guarantee*+no-shadowing, so perhaps it may not be distinct?]++Anyway, the rule isn't actually wrong, it's just not useful.  One possibility+is to run deShadowBinds before running SpecConstr, but instead we run the+simplifier.  That gives the simplest possible program for SpecConstr to+chew on; and it virtually guarantees no shadowing.++Note [Specialising for constant parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This one is about specialising on a *constant* (but not necessarily+constructor) argument++    foo :: Int -> (Int -> Int) -> Int+    foo 0 f = 0+    foo m f = foo (f m) (+1)++It produces++    lvl_rmV :: GHC.Base.Int -> GHC.Base.Int+    lvl_rmV =+      \ (ds_dlk :: GHC.Base.Int) ->+        case ds_dlk of wild_alH { GHC.Base.I# x_alG ->+        GHC.Base.I# (GHC.Prim.+# x_alG 1)++    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->+    GHC.Prim.Int#+    T.$wfoo =+      \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->+        case ww_sme of ds_Xlw {+          __DEFAULT ->+        case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->+        T.$wfoo ww1_Xmz lvl_rmV+        };+          0 -> 0+        }++The recursive call has lvl_rmV as its argument, so we could create a specialised copy+with that argument baked in; that is, not passed at all.   Now it can perhaps be inlined.++When is this worth it?  Call the constant 'lvl'+- If 'lvl' has an unfolding that is a constructor, see if the corresponding+  parameter is scrutinised anywhere in the body.++- If 'lvl' has an unfolding that is a inlinable function, see if the corresponding+  parameter is applied (...to enough arguments...?)++  Also do this is if the function has RULES?++Also++Note [Specialising for lambda parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    foo :: Int -> (Int -> Int) -> Int+    foo 0 f = 0+    foo m f = foo (f m) (\n -> n-m)++This is subtly different from the previous one in that we get an+explicit lambda as the argument:++    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->+    GHC.Prim.Int#+    T.$wfoo =+      \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->+        case ww_sm8 of ds_Xlr {+          __DEFAULT ->+        case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->+        T.$wfoo+          ww1_Xmq+          (\ (n_ad3 :: GHC.Base.Int) ->+             case n_ad3 of wild_alB { GHC.Base.I# x_alA ->+             GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)+             })+        };+          0 -> 0+        }++I wonder if SpecConstr couldn't be extended to handle this? After all,+lambda is a sort of constructor for functions and perhaps it already+has most of the necessary machinery?++Furthermore, there's an immediate win, because you don't need to allocate the lambda+at the call site; and if perchance it's called in the recursive call, then you+may avoid allocating it altogether.  Just like for constructors.++Looks cool, but probably rare...but it might be easy to implement.+++Note [SpecConstr for casts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    data family T a :: *+    data instance T Int = T Int++    foo n = ...+       where+         go (T 0) = 0+         go (T n) = go (T (n-1))++The recursive call ends up looking like+        go (T (I# ...) `cast` g)+So we want to spot the constructor application inside the cast.+That's why we have the Cast case in argToPat++Note [Local recursive groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For a *local* recursive group, we can see all the calls to the+function, so we seed the specialisation loop from the calls in the+body, not from the calls in the RHS.  Consider:++  bar m n = foo n (n,n) (n,n) (n,n) (n,n)+   where+     foo n p q r s+       | n == 0    = m+       | n > 3000  = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }+       | n > 2000  = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }+       | n > 1000  = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }+       | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }++If we start with the RHSs of 'foo', we get lots and lots of specialisations,+most of which are not needed.  But if we start with the (single) call+in the rhs of 'bar' we get exactly one fully-specialised copy, and all+the recursive calls go to this fully-specialised copy. Indeed, the original+function is later collected as dead code.  This is very important in+specialising the loops arising from stream fusion, for example in NDP where+we were getting literally hundreds of (mostly unused) specialisations of+a local function.++In a case like the above we end up never calling the original un-specialised+function.  (Although we still leave its code around just in case.)++However, if we find any boring calls in the body, including *unsaturated*+ones, such as+      letrec foo x y = ....foo...+      in map foo xs+then we will end up calling the un-specialised function, so then we *should*+use the calls in the un-specialised RHS as seeds.  We call these+"boring call patterns", and callsToPats reports if it finds any of these.++Note [Seeding top-level recursive groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This seeding is done in the binding for seed_calls in specRec.++1. If all the bindings in a top-level recursive group are local (not+   exported), then all the calls are in the rest of the top-level+   bindings.  This means we can specialise with those call patterns+   ONLY, and NOT with the RHSs of the recursive group (exactly like+   Note [Local recursive groups])++2. But if any of the bindings are exported, the function may be called+   with any old arguments, so (for lack of anything better) we specialise+   based on+     (a) the call patterns in the RHS+     (b) the call patterns in the rest of the top-level bindings+   NB: before Apr 15 we used (a) only, but Dimitrios had an example+       where (b) was crucial, so I added that.+       Adding (b) also improved nofib allocation results:+                  multiplier: 4%   better+                  minimax:    2.8% better++Actually in case (2), instead of using the calls from the RHS, it+would be better to specialise in the importing module.  We'd need to+add an INLINABLE pragma to the function, and then it can be+specialised in the importing scope, just as is done for type classes+in Specialise.specImports. This remains to be done (#10346).++Note [Top-level recursive groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To get the call usage information from "the rest of the top level+bindings" (c.f. Note [Seeding top-level recursive groups]), we work+backwards through the top-level bindings so we see the usage before we+get to the binding of the function.  Before we can collect the usage+though, we go through all the bindings and add them to the+environment. This is necessary because usage is only tracked for+functions in the environment.  These two passes are called+   'go' and 'goEnv'+in specConstrProgram.  (Looks a bit revolting to me.)++Note [Do not specialise diverging functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Specialising a function that just diverges is a waste of code.+Furthermore, it broke GHC (simpl014) thus:+   {-# STR Sb #-}+   f = \x. case x of (a,b) -> f x+If we specialise f we get+   f = \x. case x of (a,b) -> fspec a b+But fspec doesn't have decent strictness info.  As it happened,+(f x) :: IO t, so the state hack applied and we eta expanded fspec,+and hence f.  But now f's strictness is less than its arity, which+breaks an invariant.+++Note [Forcing specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With stream fusion and in other similar cases, we want to fully+specialise some (but not necessarily all!) loops regardless of their+size and the number of specialisations.++We allow a library to do this, in one of two ways (one which is+deprecated):++  1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body.++  2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts,+     and then add *that* type as a parameter to the loop body++The reason #2 is deprecated is because it requires GHCi, which isn't+available for things like a cross compiler using stage1.++Here's a (simplified) example from the `vector` package. You may bring+the special 'force specialization' type into scope by saying:++  import GHC.Types (SPEC(..))++or by defining your own type (again, deprecated):++  data SPEC = SPEC | SPEC2+  {-# ANN type SPEC ForceSpecConstr #-}++(Note this is the exact same definition of GHC.Types.SPEC, just+without the annotation.)++After that, you say:++  foldl :: (a -> b -> a) -> a -> Stream b -> a+  {-# INLINE foldl #-}+  foldl f z (Stream step s _) = foldl_loop SPEC z s+    where+      foldl_loop !sPEC z s = case step s of+                              Yield x s' -> foldl_loop sPEC (f z x) s'+                              Skip       -> foldl_loop sPEC z s'+                              Done       -> z++SpecConstr will spot the SPEC parameter and always fully specialise+foldl_loop. Note that++  * We have to prevent the SPEC argument from being removed by+    w/w which is why (a) SPEC is a sum type, and (b) we have to seq on+    the SPEC argument.++  * And lastly, the SPEC argument is ultimately eliminated by+    SpecConstr itself so there is no runtime overhead.++This is all quite ugly; we ought to come up with a better design.++ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set+sc_force to True when calling specLoop. This flag does four things:++  * Ignore specConstrThreshold, to specialise functions of arbitrary size+        (see scTopBind)+  * Ignore specConstrCount, to make arbitrary numbers of specialisations+        (see specialise)+  * Specialise even for arguments that are not scrutinised in the loop+        (see argToPat; #4448)+  * Only specialise on recursive types a finite number of times+        (see is_too_recursive; #5550; Note [Limit recursive specialisation])++The flag holds only for specialising a single binding group, and NOT+for nested bindings.  (So really it should be passed around explicitly+and not stored in ScEnv.)  #14379 turned out to be caused by+   f SPEC x = let g1 x = ...+              in ...+We force-specialise f (because of the SPEC), but that generates a specialised+copy of g1 (as well as the original).  Alas g1 has a nested binding g2; and+in each copy of g1 we get an unspecialised and specialised copy of g2; and so+on. Result, exponential.  So the force-spec flag now only applies to one+level of bindings at a time.++Mechanism for this one-level-only thing:++ - Switch it on at the call to specRec, in scExpr and scTopBinds+ - Switch it off when doing the RHSs;+   this can be done very conveniently in decreaseSpecCount++What alternatives did I consider?++* Annotating the loop itself doesn't work because (a) it is local and+  (b) it will be w/w'ed and having w/w propagating annotations somehow+  doesn't seem like a good idea. The types of the loop arguments+  really seem to be the most persistent thing.++* Annotating the types that make up the loop state doesn't work,+  either, because (a) it would prevent us from using types like Either+  or tuples here, (b) we don't want to restrict the set of types that+  can be used in Stream states and (c) some types are fixed by the+  user (e.g., the accumulator here) but we still want to specialise as+  much as possible.++Alternatives to ForceSpecConstr+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Instead of giving the loop an extra argument of type SPEC, we+also considered *wrapping* arguments in SPEC, thus+  data SPEC a = SPEC a | SPEC2++  loop = \arg -> case arg of+                     SPEC state ->+                        case state of (x,y) -> ... loop (SPEC (x',y')) ...+                        S2 -> error ...+The idea is that a SPEC argument says "specialise this argument+regardless of whether the function case-analyses it".  But this+doesn't work well:+  * SPEC must still be a sum type, else the strictness analyser+    eliminates it+  * But that means that 'loop' won't be strict in its real payload+This loss of strictness in turn screws up specialisation, because+we may end up with calls like+   loop (SPEC (case z of (p,q) -> (q,p)))+Without the SPEC, if 'loop' were strict, the case would move out+and we'd see loop applied to a pair. But if 'loop' isn't strict+this doesn't look like a specialisable call.++Note [Limit recursive specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is possible for ForceSpecConstr to cause an infinite loop of specialisation.+Because there is no limit on the number of specialisations, a recursive call with+a recursive constructor as an argument (for example, list cons) will generate+a specialisation for that constructor. If the resulting specialisation also+contains a recursive call with the constructor, this could proceed indefinitely.++For example, if ForceSpecConstr is on:+  loop :: [Int] -> [Int] -> [Int]+  loop z []         = z+  loop z (x:xs)     = loop (x:z) xs+this example will create a specialisation for the pattern+  loop (a:b) c      = loop' a b c++  loop' a b []      = (a:b)+  loop' a b (x:xs)  = loop (x:(a:b)) xs+and a new pattern is found:+  loop (a:(b:c)) d  = loop'' a b c d+which can continue indefinitely.++Roman's suggestion to fix this was to stop after a couple of times on recursive types,+but still specialising on non-recursive types as much as possible.++To implement this, we count the number of times we have gone round the+"specialise recursively" loop ('go' in 'specRec').  Once have gone round+more than N times (controlled by -fspec-constr-recursive=N) we check++  - If sc_force is off, and sc_count is (Just max) then we don't+    need to do anything: trim_pats will limit the number of specs++  - Otherwise check if any function has now got more than (sc_count env)+    specialisations.  If sc_count is "no limit" then we arbitrarily+    choose 10 as the limit (ugh).++See #5550.   Also #13623, where this test had become over-aggressive,+and we lost a wonderful specialisation that we really wanted!++Note [NoSpecConstr]+~~~~~~~~~~~~~~~~~~~+The ignoreDataCon stuff allows you to say+    {-# ANN type T NoSpecConstr #-}+to mean "don't specialise on arguments of this type".  It was added+before we had ForceSpecConstr.  Lacking ForceSpecConstr we specialised+regardless of size; and then we needed a way to turn that *off*.  Now+that we have ForceSpecConstr, this NoSpecConstr is probably redundant.+(Used only for PArray, TODO: remove?)++-----------------------------------------------------+                Stuff not yet handled+-----------------------------------------------------++Here are notes arising from Roman's work that I don't want to lose.++Example 1+~~~~~~~~~+    data T a = T !a++    foo :: Int -> T Int -> Int+    foo 0 t = 0+    foo x t | even x    = case t of { T n -> foo (x-n) t }+            | otherwise = foo (x-1) t++SpecConstr does no specialisation, because the second recursive call+looks like a boxed use of the argument.  A pity.++    $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#+    $wfoo_sFw =+      \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->+         case ww_sFo of ds_Xw6 [Just L] {+           __DEFAULT ->+                case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {+                  __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;+                  0 ->+                    case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->+                    case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->+                    $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy+                    } } };+           0 -> 0++Example 2+~~~~~~~~~+    data a :*: b = !a :*: !b+    data T a = T !a++    foo :: (Int :*: T Int) -> Int+    foo (0 :*: t) = 0+    foo (x :*: t) | even x    = case t of { T n -> foo ((x-n) :*: t) }+                  | otherwise = foo ((x-1) :*: t)++Very similar to the previous one, except that the parameters are now in+a strict tuple. Before SpecConstr, we have++    $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#+    $wfoo_sG3 =+      \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T+    GHC.Base.Int) ->+        case ww_sFU of ds_Xws [Just L] {+          __DEFAULT ->+        case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {+          __DEFAULT ->+            case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->+            $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2             -- $wfoo1+            };+          0 ->+            case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->+            case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->+            $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB        -- $wfoo2+            } } };+          0 -> 0 }++We get two specialisations:+"SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}+                  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)+                  = Foo.$s$wfoo1 a_sFB sc_sGC ;+"SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}+                  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))+                  = Foo.$s$wfoo y_aFp sc_sGC ;++But perhaps the first one isn't good.  After all, we know that tpl_B2 is+a T (I# x) really, because T is strict and Int has one constructor.  (We can't+unbox the strict fields, because T is polymorphic!)++************************************************************************+*                                                                      *+\subsection{Top level wrapper stuff}+*                                                                      *+************************************************************************+-}++specConstrProgram :: ModGuts -> CoreM ModGuts+specConstrProgram guts+  = do+      dflags <- getDynFlags+      us     <- getUniqueSupplyM+      annos  <- getFirstAnnotations deserializeWithData guts+      this_mod <- getModule+      let binds' = reverse $ fst $ initUs us $ do+                    -- Note [Top-level recursive groups]+                    (env, binds) <- goEnv (initScEnv dflags this_mod annos)+                                          (mg_binds guts)+                        -- binds is identical to (mg_binds guts), except that the+                        -- binders on the LHS have been replaced by extendBndr+                        --   (SPJ this seems like overkill; I don't think the binders+                        --    will change at all; and we don't substitute in the RHSs anyway!!)+                    go env nullUsage (reverse binds)++      return (guts { mg_binds = binds' })+  where+    -- See Note [Top-level recursive groups]+    goEnv env []            = return (env, [])+    goEnv env (bind:binds)  = do (env', bind')   <- scTopBindEnv env bind+                                 (env'', binds') <- goEnv env' binds+                                 return (env'', bind' : binds')++    -- Arg list of bindings is in reverse order+    go _   _   []           = return []+    go env usg (bind:binds) = do (usg', bind') <- scTopBind env usg bind+                                 binds' <- go env usg' binds+                                 return (bind' : binds')++{-+************************************************************************+*                                                                      *+\subsection{Environment: goes downwards}+*                                                                      *+************************************************************************++Note [Work-free values only in environment]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The sc_vals field keeps track of in-scope value bindings, so+that if we come across (case x of Just y ->...) we can reduce the+case from knowing that x is bound to a pair.++But only *work-free* values are ok here. For example if the envt had+    x -> Just (expensive v)+then we do NOT want to expand to+     let y = expensive v in ...+because the x-binding still exists and we've now duplicated (expensive v).++This seldom happens because let-bound constructor applications are+ANF-ised, but it can happen as a result of on-the-fly transformations in+SpecConstr itself.  Here is #7865:++        let {+          a'_shr =+            case xs_af8 of _ {+              [] -> acc_af6;+              : ds_dgt [Dmd=<L,A>] ds_dgu [Dmd=<L,A>] ->+                (expensive x_af7, x_af7+            } } in+        let {+          ds_sht =+            case a'_shr of _ { (p'_afd, q'_afe) ->+            TSpecConstr_DoubleInline.recursive+              (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd)+            } } in++When processed knowing that xs_af8 was bound to a cons, we simplify to+   a'_shr = (expensive x_af7, x_af7)+and we do NOT want to inline that at the occurrence of a'_shr in ds_sht.+(There are other occurrences of a'_shr.)  No no no.++It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned+into a work-free value again, thus+   a1 = expensive x_af7+   a'_shr = (a1, x_af7)+but that's more work, so until its shown to be important I'm going to+leave it for now.++Note [Making SpecConstr keener]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this, in (perf/should_run/T9339)+   last (filter odd [1..1000])++After optimisation, including SpecConstr, we get:+   f :: Int# -> Int -> Int+   f x y = case case remInt# x 2# of+             __DEFAULT -> case x of+                            __DEFAULT -> f (+# wild_Xp 1#) (I# x)+                            1000000# -> ...+             0# -> case x of+                     __DEFAULT -> f (+# wild_Xp 1#) y+                    1000000#   -> y++Not good!  We build an (I# x) box every time around the loop.+SpecConstr (as described in the paper) does not specialise f, despite+the call (f ... (I# x)) because 'y' is not scrutinied in the body.+But it is much better to specialise f for the case where the argument+is of form (I# x); then we build the box only when returning y, which+is on the cold path.++Another example:++   f x = ...(g x)....++Here 'x' is not scrutinised in f's body; but if we did specialise 'f'+then the call (g x) might allow 'g' to be specialised in turn.++So sc_keen controls whether or not we take account of whether argument is+scrutinised in the body.  True <=> ignore that, and speicalise whenever+the function is applied to a data constructor.+-}++data ScEnv = SCE { sc_dflags    :: DynFlags,+                   sc_module    :: !Module,+                   sc_size      :: Maybe Int,   -- Size threshold+                                                -- Nothing => no limit++                   sc_count     :: Maybe Int,   -- Max # of specialisations for any one fn+                                                -- Nothing => no limit+                                                -- See Note [Avoiding exponential blowup]++                   sc_recursive :: Int,         -- Max # of specialisations over recursive type.+                                                -- Stops ForceSpecConstr from diverging.++                   sc_keen     :: Bool,         -- Specialise on arguments that are known+                                                -- constructors, even if they are not+                                                -- scrutinised in the body.  See+                                                -- Note [Making SpecConstr keener]++                   sc_force     :: Bool,        -- Force specialisation?+                                                -- See Note [Forcing specialisation]++                   sc_subst     :: Subst,       -- Current substitution+                                                -- Maps InIds to OutExprs++                   sc_how_bound :: HowBoundEnv,+                        -- Binds interesting non-top-level variables+                        -- Domain is OutVars (*after* applying the substitution)++                   sc_vals      :: ValueEnv,+                        -- Domain is OutIds (*after* applying the substitution)+                        -- Used even for top-level bindings (but not imported ones)+                        -- The range of the ValueEnv is *work-free* values+                        -- such as (\x. blah), or (Just v)+                        -- but NOT (Just (expensive v))+                        -- See Note [Work-free values only in environment]++                   sc_annotations :: UniqFM SpecConstrAnnotation+             }++---------------------+type HowBoundEnv = VarEnv HowBound      -- Domain is OutVars++---------------------+type ValueEnv = IdEnv Value             -- Domain is OutIds+data Value    = ConVal AltCon [CoreArg] -- _Saturated_ constructors+                                        --   The AltCon is never DEFAULT+              | LambdaVal               -- Inlinable lambdas or PAPs++instance Outputable Value where+   ppr (ConVal con args) = ppr con <+> interpp'SP args+   ppr LambdaVal         = text "<Lambda>"++---------------------+initScEnv :: DynFlags -> Module -> UniqFM SpecConstrAnnotation -> ScEnv+initScEnv dflags this_mod anns+  = SCE { sc_dflags      = dflags,+          sc_module      = this_mod,+          sc_size        = specConstrThreshold dflags,+          sc_count       = specConstrCount     dflags,+          sc_recursive   = specConstrRecursive dflags,+          sc_keen        = gopt Opt_SpecConstrKeen dflags,+          sc_force       = False,+          sc_subst       = emptySubst,+          sc_how_bound   = emptyVarEnv,+          sc_vals        = emptyVarEnv,+          sc_annotations = anns }++data HowBound = RecFun  -- These are the recursive functions for which+                        -- we seek interesting call patterns++              | RecArg  -- These are those functions' arguments, or their sub-components;+                        -- we gather occurrence information for these++instance Outputable HowBound where+  ppr RecFun = text "RecFun"+  ppr RecArg = text "RecArg"++scForce :: ScEnv -> Bool -> ScEnv+scForce env b = env { sc_force = b }++lookupHowBound :: ScEnv -> Id -> Maybe HowBound+lookupHowBound env id = lookupVarEnv (sc_how_bound env) id++scSubstId :: ScEnv -> Id -> CoreExpr+scSubstId env v = lookupIdSubst (text "scSubstId") (sc_subst env) v++scSubstTy :: ScEnv -> Type -> Type+scSubstTy env ty = substTy (sc_subst env) ty++scSubstCo :: ScEnv -> Coercion -> Coercion+scSubstCo env co = substCo (sc_subst env) co++zapScSubst :: ScEnv -> ScEnv+zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) }++extendScInScope :: ScEnv -> [Var] -> ScEnv+        -- Bring the quantified variables into scope+extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }++        -- Extend the substitution+extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv+extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }++extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv+extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }++extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv+extendHowBound env bndrs how_bound+  = env { sc_how_bound = extendVarEnvList (sc_how_bound env)+                            [(bndr,how_bound) | bndr <- bndrs] }++extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])+extendBndrsWith how_bound env bndrs+  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')+  where+    (subst', bndrs') = substBndrs (sc_subst env) bndrs+    hb_env' = sc_how_bound env `extendVarEnvList`+                    [(bndr,how_bound) | bndr <- bndrs']++extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)+extendBndrWith how_bound env bndr+  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')+  where+    (subst', bndr') = substBndr (sc_subst env) bndr+    hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound++extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])+extendRecBndrs env bndrs  = (env { sc_subst = subst' }, bndrs')+                      where+                        (subst', bndrs') = substRecBndrs (sc_subst env) bndrs++extendBndr :: ScEnv -> Var -> (ScEnv, Var)+extendBndr  env bndr  = (env { sc_subst = subst' }, bndr')+                      where+                        (subst', bndr') = substBndr (sc_subst env) bndr++extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv+extendValEnv env _  Nothing   = env+extendValEnv env id (Just cv)+ | valueIsWorkFree cv      -- Don't duplicate work!!  #7865+ = env { sc_vals = extendVarEnv (sc_vals env) id cv }+extendValEnv env _ _ = env++extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var])+-- When we encounter+--      case scrut of b+--          C x y -> ...+-- we want to bind b, to (C x y)+-- NB1: Extends only the sc_vals part of the envt+-- NB2: Kill the dead-ness info on the pattern binders x,y, since+--      they are potentially made alive by the [b -> C x y] binding+extendCaseBndrs env scrut case_bndr con alt_bndrs+   = (env2, alt_bndrs')+ where+   live_case_bndr = not (isDeadBinder case_bndr)+   env1 | Var v <- stripTicksTopE (const True) scrut+                         = extendValEnv env v cval+        | otherwise      = env  -- See Note [Add scrutinee to ValueEnv too]+   env2 | live_case_bndr = extendValEnv env1 case_bndr cval+        | otherwise      = env1++   alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr }+              = map zap alt_bndrs+              | otherwise+              = alt_bndrs++   cval = case con of+                DEFAULT    -> Nothing+                LitAlt {}  -> Just (ConVal con [])+                DataAlt {} -> Just (ConVal con vanilla_args)+                      where+                        vanilla_args = map Type (tyConAppArgs (idType case_bndr)) +++                                       varsToCoreExprs alt_bndrs++   zap v | isTyVar v = v                -- See NB2 above+         | otherwise = zapIdOccInfo v+++decreaseSpecCount :: ScEnv -> Int -> ScEnv+-- See Note [Avoiding exponential blowup]+decreaseSpecCount env n_specs+  = env { sc_force = False   -- See Note [Forcing specialisation]+        , sc_count = case sc_count env of+                       Nothing -> Nothing+                       Just n  -> Just (n `div` (n_specs + 1)) }+        -- The "+1" takes account of the original function;+        -- See Note [Avoiding exponential blowup]++---------------------------------------------------+-- See Note [Forcing specialisation]+ignoreType    :: ScEnv -> Type   -> Bool+ignoreDataCon  :: ScEnv -> DataCon -> Bool+forceSpecBndr :: ScEnv -> Var    -> Bool++ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc)++ignoreType env ty+  = case tyConAppTyCon_maybe ty of+      Just tycon -> ignoreTyCon env tycon+      _          -> False++ignoreTyCon :: ScEnv -> TyCon -> Bool+ignoreTyCon env tycon+  = lookupUFM (sc_annotations env) tycon == Just NoSpecConstr++forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTys . varType $ var++forceSpecFunTy :: ScEnv -> Type -> Bool+forceSpecFunTy env = any (forceSpecArgTy env) . fst . splitFunTys++forceSpecArgTy :: ScEnv -> Type -> Bool+forceSpecArgTy env ty+  | Just ty' <- coreView ty = forceSpecArgTy env ty'++forceSpecArgTy env ty+  | Just (tycon, tys) <- splitTyConApp_maybe ty+  , tycon /= funTyCon+      = tyConName tycon == specTyConName+        || lookupUFM (sc_annotations env) tycon == Just ForceSpecConstr+        || any (forceSpecArgTy env) tys++forceSpecArgTy _ _ = False++{-+Note [Add scrutinee to ValueEnv too]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+   case x of y+     (a,b) -> case b of c+                I# v -> ...(f y)...+By the time we get to the call (f y), the ValueEnv+will have a binding for y, and for c+    y -> (a,b)+    c -> I# v+BUT that's not enough!  Looking at the call (f y) we+see that y is pair (a,b), but we also need to know what 'b' is.+So in extendCaseBndrs we must *also* add the binding+   b -> I# v+else we lose a useful specialisation for f.  This is necessary even+though the simplifier has systematically replaced uses of 'x' with 'y'+and 'b' with 'c' in the code.  The use of 'b' in the ValueEnv came+from outside the case.  See #4908 for the live example.++Note [Avoiding exponential blowup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The sc_count field of the ScEnv says how many times we are prepared to+duplicate a single function.  But we must take care with recursive+specialisations.  Consider++        let $j1 = let $j2 = let $j3 = ...+                            in+                            ...$j3...+                  in+                  ...$j2...+        in+        ...$j1...++If we specialise $j1 then in each specialisation (as well as the original)+we can specialise $j2, and similarly $j3.  Even if we make just *one*+specialisation of each, because we also have the original we'll get 2^n+copies of $j3, which is not good.++So when recursively specialising we divide the sc_count by the number of+copies we are making at this level, including the original.+++************************************************************************+*                                                                      *+\subsection{Usage information: flows upwards}+*                                                                      *+************************************************************************+-}++data ScUsage+   = SCU {+        scu_calls :: CallEnv,           -- Calls+                                        -- The functions are a subset of the+                                        --      RecFuns in the ScEnv++        scu_occs :: !(IdEnv ArgOcc)     -- Information on argument occurrences+     }                                  -- The domain is OutIds++type CallEnv = IdEnv [Call]+data Call = Call Id [CoreArg] ValueEnv+        -- The arguments of the call, together with the+        -- env giving the constructor bindings at the call site+        -- We keep the function mainly for debug output++instance Outputable ScUsage where+  ppr (SCU { scu_calls = calls, scu_occs = occs })+    = text "SCU" <+> braces (sep [ ptext (sLit "calls =") <+> ppr calls+                                         , text "occs =" <+> ppr occs ])++instance Outputable Call where+  ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args)++nullUsage :: ScUsage+nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }++combineCalls :: CallEnv -> CallEnv -> CallEnv+combineCalls = plusVarEnv_C (++)+  where+--    plus cs ds | length res > 1+--               = pprTrace "combineCalls" (vcat [ text "cs:" <+> ppr cs+--                                               , text "ds:" <+> ppr ds])+--                 res+--               | otherwise = res+--       where+--          res = cs ++ ds++combineUsage :: ScUsage -> ScUsage -> ScUsage+combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),+                           scu_occs  = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }++combineUsages :: [ScUsage] -> ScUsage+combineUsages [] = nullUsage+combineUsages us = foldr1 combineUsage us++lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc])+lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs+  = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},+     [lookupVarEnv sc_occs b `orElse` NoOcc | b <- bndrs])++data ArgOcc = NoOcc     -- Doesn't occur at all; or a type argument+            | UnkOcc    -- Used in some unknown way++            | ScrutOcc  -- See Note [ScrutOcc]+                 (DataConEnv [ArgOcc])   -- How the sub-components are used++type DataConEnv a = UniqFM a     -- Keyed by DataCon++{- Note  [ScrutOcc]+~~~~~~~~~~~~~~~~~~~+An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,+is *only* taken apart or applied.++  Functions, literal: ScrutOcc emptyUFM+  Data constructors:  ScrutOcc subs,++where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,+The domain of the UniqFM is the Unique of the data constructor++The [ArgOcc] is the occurrences of the *pattern-bound* components+of the data structure.  E.g.+        data T a = forall b. MkT a b (b->a)+A pattern binds b, x::a, y::b, z::b->a, but not 'a'!++-}++instance Outputable ArgOcc where+  ppr (ScrutOcc xs) = text "scrut-occ" <> ppr xs+  ppr UnkOcc        = text "unk-occ"+  ppr NoOcc         = text "no-occ"++evalScrutOcc :: ArgOcc+evalScrutOcc = ScrutOcc emptyUFM++-- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so+-- that if the thing is scrutinised anywhere then we get to see that+-- in the overall result, even if it's also used in a boxed way+-- This might be too aggressive; see Note [Reboxing] Alternative 3+combineOcc :: ArgOcc -> ArgOcc -> ArgOcc+combineOcc NoOcc         occ           = occ+combineOcc occ           NoOcc         = occ+combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)+combineOcc UnkOcc        (ScrutOcc ys) = ScrutOcc ys+combineOcc (ScrutOcc xs) UnkOcc        = ScrutOcc xs+combineOcc UnkOcc        UnkOcc        = UnkOcc++combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]+combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys++setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage+-- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee+-- is a variable, and an interesting variable+setScrutOcc env usg (Cast e _) occ      = setScrutOcc env usg e occ+setScrutOcc env usg (Tick _ e) occ      = setScrutOcc env usg e occ+setScrutOcc env usg (Var v)    occ+  | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }+  | otherwise                           = usg+setScrutOcc _env usg _other _occ        -- Catch-all+  = usg++{-+************************************************************************+*                                                                      *+\subsection{The main recursive function}+*                                                                      *+************************************************************************++The main recursive function gathers up usage information, and+creates specialised versions of functions.+-}++scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr)+        -- The unique supply is needed when we invent+        -- a new name for the specialised function and its args++scExpr env e = scExpr' env e++scExpr' env (Var v)      = case scSubstId env v of+                            Var v' -> return (mkVarUsage env v' [], Var v')+                            e'     -> scExpr (zapScSubst env) e'++scExpr' env (Type t)     = return (nullUsage, Type (scSubstTy env t))+scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c))+scExpr' _   e@(Lit {})   = return (nullUsage, e)+scExpr' env (Tick t e)   = do (usg, e') <- scExpr env e+                              return (usg, Tick t e')+scExpr' env (Cast e co)  = do (usg, e') <- scExpr env e+                              return (usg, mkCast e' (scSubstCo env co))+                              -- Important to use mkCast here+                              -- See Note [SpecConstr call patterns]+scExpr' env e@(App _ _)  = scApp env (collectArgs e)+scExpr' env (Lam b e)    = do let (env', b') = extendBndr env b+                              (usg, e') <- scExpr env' e+                              return (usg, Lam b' e')++scExpr' env (Case scrut b ty alts)+  = do  { (scrut_usg, scrut') <- scExpr env scrut+        ; case isValue (sc_vals env) scrut' of+                Just (ConVal con args) -> sc_con_app con args scrut'+                _other                 -> sc_vanilla scrut_usg scrut'+        }+  where+    sc_con_app con args scrut'  -- Known constructor; simplify+     = do { let (_, bs, rhs) = findAlt con alts+                                  `orElse` (DEFAULT, [], mkImpossibleExpr ty)+                alt_env'     = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)+          ; scExpr alt_env' rhs }++    sc_vanilla scrut_usg scrut' -- Normal case+     = do { let (alt_env,b') = extendBndrWith RecArg env b+                        -- Record RecArg for the components++          ; (alt_usgs, alt_occs, alts')+                <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts++          ; let scrut_occ  = foldr combineOcc NoOcc alt_occs+                scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ+                -- The combined usage of the scrutinee is given+                -- by scrut_occ, which is passed to scScrut, which+                -- in turn treats a bare-variable scrutinee specially++          ; return (foldr combineUsage scrut_usg' alt_usgs,+                    Case scrut' b' (scSubstTy env ty) alts') }++    sc_alt env scrut' b' (con,bs,rhs)+     = do { let (env1, bs1) = extendBndrsWith RecArg env bs+                (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1+          ; (usg, rhs') <- scExpr env2 rhs+          ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2)+                scrut_occ = case con of+                               DataAlt dc -> ScrutOcc (unitUFM dc arg_occs)+                               _          -> ScrutOcc emptyUFM+          ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) }++scExpr' env (Let (NonRec bndr rhs) body)+  | isTyVar bndr        -- Type-lets may be created by doBeta+  = scExpr' (extendScSubst env bndr rhs) body++  | otherwise+  = do  { let (body_env, bndr') = extendBndr env bndr+        ; rhs_info  <- scRecRhs env (bndr',rhs)++        ; let body_env2 = extendHowBound body_env [bndr'] RecFun+                           -- Note [Local let bindings]+              rhs'      = ri_new_rhs rhs_info+              body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')++        ; (body_usg, body') <- scExpr body_env3 body++          -- NB: For non-recursive bindings we inherit sc_force flag from+          -- the parent function (see Note [Forcing specialisation])+        ; (spec_usg, specs) <- specNonRec env body_usg rhs_info++        ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }+                    `combineUsage` spec_usg,  -- Note [spec_usg includes rhs_usg]+                  mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body')+        }+++-- A *local* recursive group: see Note [Local recursive groups]+scExpr' env (Let (Rec prs) body)+  = do  { let (bndrs,rhss)      = unzip prs+              (rhs_env1,bndrs') = extendRecBndrs env bndrs+              rhs_env2          = extendHowBound rhs_env1 bndrs' RecFun+              force_spec        = any (forceSpecBndr env) bndrs'+                -- Note [Forcing specialisation]++        ; rhs_infos <- mapM (scRecRhs rhs_env2) (bndrs' `zip` rhss)+        ; (body_usg, body')     <- scExpr rhs_env2 body++        -- NB: start specLoop from body_usg+        ; (spec_usg, specs) <- specRec NotTopLevel (scForce rhs_env2 force_spec)+                                       body_usg rhs_infos+                -- Do not unconditionally generate specialisations from rhs_usgs+                -- Instead use them only if we find an unspecialised call+                -- See Note [Local recursive groups]++        ; let all_usg = spec_usg `combineUsage` body_usg  -- Note [spec_usg includes rhs_usg]+              bind'   = Rec (concat (zipWith ruleInfoBinds rhs_infos specs))++        ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' },+                  Let bind' body') }++{-+Note [Local let bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~+It is not uncommon to find this++   let $j = \x. <blah> in ...$j True...$j True...++Here $j is an arbitrary let-bound function, but it often comes up for+join points.  We might like to specialise $j for its call patterns.+Notice the difference from a letrec, where we look for call patterns+in the *RHS* of the function.  Here we look for call patterns in the+*body* of the let.++At one point I predicated this on the RHS mentioning the outer+recursive function, but that's not essential and might even be+harmful.  I'm not sure.+-}++scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr)++scApp env (Var fn, args)        -- Function is a variable+  = ASSERT( not (null args) )+    do  { args_w_usgs <- mapM (scExpr env) args+        ; let (arg_usgs, args') = unzip args_w_usgs+              arg_usg = combineUsages arg_usgs+        ; case scSubstId env fn of+            fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args')+                        -- Do beta-reduction and try again++            Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args',+                               mkApps (Var fn') args')++            other_fn' -> return (arg_usg, mkApps other_fn' args') }+                -- NB: doing this ignores any usage info from the substituted+                --     function, but I don't think that matters.  If it does+                --     we can fix it.+  where+    doBeta :: OutExpr -> [OutExpr] -> OutExpr+    -- ToDo: adjust for System IF+    doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)+    doBeta fn              args         = mkApps fn args++-- The function is almost always a variable, but not always.+-- In particular, if this pass follows float-in,+-- which it may, we can get+--      (let f = ...f... in f) arg1 arg2+scApp env (other_fn, args)+  = do  { (fn_usg,   fn')   <- scExpr env other_fn+        ; (arg_usgs, args') <- mapAndUnzipM (scExpr env) args+        ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') }++----------------------+mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage+mkVarUsage env fn args+  = case lookupHowBound env fn of+        Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env)]+                           , scu_occs  = emptyVarEnv }+        Just RecArg -> SCU { scu_calls = emptyVarEnv+                           , scu_occs  = unitVarEnv fn arg_occ }+        Nothing     -> nullUsage+  where+    -- I rather think we could use UnkOcc all the time+    arg_occ | null args = UnkOcc+            | otherwise = evalScrutOcc++----------------------+scTopBindEnv :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind)+scTopBindEnv env (Rec prs)+  = do  { let (rhs_env1,bndrs') = extendRecBndrs env bndrs+              rhs_env2          = extendHowBound rhs_env1 bndrs RecFun++              prs'              = zip bndrs' rhss+        ; return (rhs_env2, Rec prs') }+  where+    (bndrs,rhss) = unzip prs++scTopBindEnv env (NonRec bndr rhs)+  = do  { let (env1, bndr') = extendBndr env bndr+              env2          = extendValEnv env1 bndr' (isValue (sc_vals env) rhs)+        ; return (env2, NonRec bndr' rhs) }++----------------------+scTopBind :: ScEnv -> ScUsage -> CoreBind -> UniqSM (ScUsage, CoreBind)++{-+scTopBind _ usage _+  | pprTrace "scTopBind_usage" (ppr (scu_calls usage)) False+  = error "false"+-}++scTopBind env body_usage (Rec prs)+  | Just threshold <- sc_size env+  , not force_spec+  , not (all (couldBeSmallEnoughToInline (sc_dflags env) threshold) rhss)+                -- No specialisation+  = -- pprTrace "scTopBind: nospec" (ppr bndrs) $+    do  { (rhs_usgs, rhss')   <- mapAndUnzipM (scExpr env) rhss+        ; return (body_usage `combineUsage` combineUsages rhs_usgs, Rec (bndrs `zip` rhss')) }++  | otherwise   -- Do specialisation+  = do  { rhs_infos <- mapM (scRecRhs env) prs++        ; (spec_usage, specs) <- specRec TopLevel (scForce env force_spec)+                                         body_usage rhs_infos++        ; return (body_usage `combineUsage` spec_usage,+                  Rec (concat (zipWith ruleInfoBinds rhs_infos specs))) }+  where+    (bndrs,rhss) = unzip prs+    force_spec   = any (forceSpecBndr env) bndrs+      -- Note [Forcing specialisation]++scTopBind env usage (NonRec bndr rhs)   -- Oddly, we don't seem to specialise top-level non-rec functions+  = do  { (rhs_usg', rhs') <- scExpr env rhs+        ; return (usage `combineUsage` rhs_usg', NonRec bndr rhs') }++----------------------+scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM RhsInfo+scRecRhs env (bndr,rhs)+  = do  { let (arg_bndrs,body)       = collectBinders rhs+              (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs+        ; (body_usg, body')         <- scExpr body_env body+        ; let (rhs_usg, arg_occs)    = lookupOccs body_usg arg_bndrs'+        ; return (RI { ri_rhs_usg = rhs_usg+                     , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body'+                     , ri_lam_bndrs = arg_bndrs, ri_lam_body = body+                     , ri_arg_occs = arg_occs }) }+                -- The arg_occs says how the visible,+                -- lambda-bound binders of the RHS are used+                -- (including the TyVar binders)+                -- Two pats are the same if they match both ways++----------------------+ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]+ruleInfoBinds (RI { ri_fn = fn, ri_new_rhs = new_rhs })+              (SI { si_specs = specs })+  = [(id,rhs) | OS { os_id = id, os_rhs = rhs } <- specs] +++              -- First the specialised bindings++    [(fn `addIdSpecialisations` rules, new_rhs)]+              -- And now the original binding+  where+    rules = [r | OS { os_rule = r } <- specs]++{-+************************************************************************+*                                                                      *+                The specialiser itself+*                                                                      *+************************************************************************+-}++data RhsInfo+  = RI { ri_fn :: OutId                 -- The binder+       , ri_new_rhs :: OutExpr          -- The specialised RHS (in current envt)+       , ri_rhs_usg :: ScUsage          -- Usage info from specialising RHS++       , ri_lam_bndrs :: [InVar]       -- The *original* RHS (\xs.body)+       , ri_lam_body  :: InExpr        --   Note [Specialise original body]+       , ri_arg_occs  :: [ArgOcc]      -- Info on how the xs occur in body+    }++data SpecInfo       -- Info about specialisations for a particular Id+  = SI { si_specs :: [OneSpec]          -- The specialisations we have generated++       , si_n_specs :: Int              -- Length of si_specs; used for numbering them++       , si_mb_unspec :: Maybe ScUsage  -- Just cs  => we have not yet used calls in the+       }                                --             from calls in the *original* RHS as+                                        --             seeds for new specialisations;+                                        --             if you decide to do so, here is the+                                        --             RHS usage (which has not yet been+                                        --             unleashed)+                                        -- Nothing => we have+                                        -- See Note [Local recursive groups]+                                        -- See Note [spec_usg includes rhs_usg]++        -- One specialisation: Rule plus definition+data OneSpec =+  OS { os_pat  :: CallPat    -- Call pattern that generated this specialisation+     , os_rule :: CoreRule   -- Rule connecting original id with the specialisation+     , os_id   :: OutId      -- Spec id+     , os_rhs  :: OutExpr }  -- Spec rhs++noSpecInfo :: SpecInfo+noSpecInfo = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Nothing }++----------------------+specNonRec :: ScEnv+           -> ScUsage         -- Body usage+           -> RhsInfo         -- Structure info usage info for un-specialised RHS+           -> UniqSM (ScUsage, SpecInfo)       -- Usage from RHSs (specialised and not)+                                               --     plus details of specialisations++specNonRec env body_usg rhs_info+  = specialise env (scu_calls body_usg) rhs_info+               (noSpecInfo { si_mb_unspec = Just (ri_rhs_usg rhs_info) })++----------------------+specRec :: TopLevelFlag -> ScEnv+        -> ScUsage                         -- Body usage+        -> [RhsInfo]                       -- Structure info and usage info for un-specialised RHSs+        -> UniqSM (ScUsage, [SpecInfo])    -- Usage from all RHSs (specialised and not)+                                           --     plus details of specialisations++specRec top_lvl env body_usg rhs_infos+  = go 1 seed_calls nullUsage init_spec_infos+  where+    (seed_calls, init_spec_infos)    -- Note [Seeding top-level recursive groups]+       | isTopLevel top_lvl+       , any (isExportedId . ri_fn) rhs_infos   -- Seed from body and RHSs+       = (all_calls,     [noSpecInfo | _ <- rhs_infos])+       | otherwise                              -- Seed from body only+       = (calls_in_body, [noSpecInfo { si_mb_unspec = Just (ri_rhs_usg ri) }+                         | ri <- rhs_infos])++    calls_in_body = scu_calls body_usg+    calls_in_rhss = foldr (combineCalls . scu_calls . ri_rhs_usg) emptyVarEnv rhs_infos+    all_calls = calls_in_rhss `combineCalls` calls_in_body++    -- Loop, specialising, until you get no new specialisations+    go :: Int   -- Which iteration of the "until no new specialisations"+                -- loop we are on; first iteration is 1+       -> CallEnv   -- Seed calls+                    -- Two accumulating parameters:+       -> ScUsage      -- Usage from earlier specialisations+       -> [SpecInfo]   -- Details of specialisations so far+       -> UniqSM (ScUsage, [SpecInfo])+    go n_iter seed_calls usg_so_far spec_infos+      | isEmptyVarEnv seed_calls+      = -- pprTrace "specRec1" (vcat [ ppr (map ri_fn rhs_infos)+        --                           , ppr seed_calls+        --                           , ppr body_usg ]) $+        return (usg_so_far, spec_infos)++      -- Limit recursive specialisation+      -- See Note [Limit recursive specialisation]+      | n_iter > sc_recursive env  -- Too many iterations of the 'go' loop+      , sc_force env || isNothing (sc_count env)+           -- If both of these are false, the sc_count+           -- threshold will prevent non-termination+      , any ((> the_limit) . si_n_specs) spec_infos+      = -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $+        return (usg_so_far, spec_infos)++      | otherwise+      = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos)+        --                           , text "iteration" <+> int n_iter+        --                          , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)+        --                    ]) $+        do  { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos+            ; let (extra_usg_s, new_spec_infos) = unzip specs_w_usg+                  extra_usg = combineUsages extra_usg_s+                  all_usg   = usg_so_far `combineUsage` extra_usg+            ; go (n_iter + 1) (scu_calls extra_usg) all_usg new_spec_infos }++    -- See Note [Limit recursive specialisation]+    the_limit = case sc_count env of+                  Nothing  -> 10    -- Ugh!+                  Just max -> max+++----------------------+specialise+   :: ScEnv+   -> CallEnv                     -- Info on newly-discovered calls to this function+   -> RhsInfo+   -> SpecInfo                    -- Original RHS plus patterns dealt with+   -> UniqSM (ScUsage, SpecInfo)  -- New specialised versions and their usage++-- See Note [spec_usg includes rhs_usg]++-- Note: this only generates *specialised* bindings+-- The original binding is added by ruleInfoBinds+--+-- Note: the rhs here is the optimised version of the original rhs+-- So when we make a specialised copy of the RHS, we're starting+-- from an RHS whose nested functions have been optimised already.++specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs+                              , ri_lam_body = body, ri_arg_occs = arg_occs })+               spec_info@(SI { si_specs = specs, si_n_specs = spec_count+                             , si_mb_unspec = mb_unspec })+  | isBottomingId fn      -- Note [Do not specialise diverging functions]+                          -- and do not generate specialisation seeds from its RHS+  = -- pprTrace "specialise bot" (ppr fn) $+    return (nullUsage, spec_info)++  | isNeverActive (idInlineActivation fn) -- See Note [Transfer activation]+    || null arg_bndrs                     -- Only specialise functions+  = -- pprTrace "specialise inactive" (ppr fn) $+    case mb_unspec of    -- Behave as if there was a single, boring call+      Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing })+                         -- See Note [spec_usg includes rhs_usg]+      Nothing      -> return (nullUsage, spec_info)++  | Just all_calls <- lookupVarEnv bind_calls fn+  = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $+    do  { (boring_call, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls++        ; let n_pats = length new_pats+--        ; if (not (null new_pats) || isJust mb_unspec) then+--            pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns"+--                                        , text "mb_unspec" <+> ppr (isJust mb_unspec)+--                                        , text "arg_occs" <+> ppr arg_occs+--                                        , text "good pats" <+> ppr new_pats])  $+--               return ()+--          else return ()++        ; let spec_env = decreaseSpecCount env n_pats+        ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)+                                                 (new_pats `zip` [spec_count..])+                -- See Note [Specialise original body]++        ; let spec_usg = combineUsages spec_usgs++              -- If there were any boring calls among the seeds (= all_calls), then those+              -- calls will call the un-specialised function.  So we should use the seeds+              -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning+              -- then in new_usg.+              (new_usg, mb_unspec')+                  = case mb_unspec of+                      Just rhs_usg | boring_call -> (spec_usg `combineUsage` rhs_usg, Nothing)+                      _                          -> (spec_usg,                      mb_unspec)++--        ; pprTrace "specialise return }"+--             (vcat [ ppr fn+--                   , text "boring_call:" <+> ppr boring_call+--                   , text "new calls:" <+> ppr (scu_calls new_usg)]) $+--          return ()++          ; return (new_usg, SI { si_specs = new_specs ++ specs+                                , si_n_specs = spec_count + n_pats+                                , si_mb_unspec = mb_unspec' }) }++  | otherwise  -- No new seeds, so return nullUsage+  = return (nullUsage, spec_info)+++++---------------------+spec_one :: ScEnv+         -> OutId       -- Function+         -> [InVar]     -- Lambda-binders of RHS; should match patterns+         -> InExpr      -- Body of the original function+         -> (CallPat, Int)+         -> UniqSM (ScUsage, OneSpec)   -- Rule and binding++-- spec_one creates a specialised copy of the function, together+-- with a rule for using it.  I'm very proud of how short this+-- function is, considering what it does :-).++{-+  Example++     In-scope: a, x::a+     f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...+          [c::*, v::(b,c) are presumably bound by the (...) part]+  ==>+     f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->+                  (...entire body of f...) [b -> (b,c),+                                            y -> ((:) (a,(b,c)) (x,v) hw)]++     RULE:  forall b::* c::*,           -- Note, *not* forall a, x+                   v::(b,c),+                   hw::[(a,(b,c))] .++            f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw+-}++spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)+  = do  { spec_uniq <- getUniqueM+        ; let spec_env   = extendScSubstList (extendScInScope env qvars)+                                             (arg_bndrs `zip` pats)+              fn_name    = idName fn+              fn_loc     = nameSrcSpan fn_name+              fn_occ     = nameOccName fn_name+              spec_occ   = mkSpecOcc fn_occ+              -- We use fn_occ rather than fn in the rule_name string+              -- as we don't want the uniq to end up in the rule, and+              -- hence in the ABI, as that can cause spurious ABI+              -- changes (#4012).+              rule_name  = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number)+              spec_name  = mkInternalName spec_uniq spec_occ fn_loc+--      ; pprTrace "{spec_one" (ppr (sc_count env) <+> ppr fn+--                              <+> ppr pats <+> text "-->" <+> ppr spec_name) $+--        return ()++        -- Specialise the body+        ; (spec_usg, spec_body) <- scExpr spec_env body++--      ; pprTrace "done spec_one}" (ppr fn) $+--        return ()++                -- And build the results+        ; let (spec_lam_args, spec_call_args) = mkWorkerArgs (sc_dflags env)+                                                             qvars body_ty+                -- Usual w/w hack to avoid generating+                -- a spec_rhs of unlifted type and no args++              spec_lam_args_str = handOutStrictnessInformation (fst (splitStrictSig spec_str)) spec_lam_args+                -- Annotate the variables with the strictness information from+                -- the function (see Note [Strictness information in worker binders])++              spec_join_arity | isJoinId fn = Just (length spec_lam_args)+                              | otherwise   = Nothing+              spec_id    = mkLocalIdOrCoVar spec_name+                                            (mkLamTypes spec_lam_args body_ty)+                             -- See Note [Transfer strictness]+                             `setIdStrictness` spec_str+                             `setIdArity` count isId spec_lam_args+                             `asJoinId_maybe` spec_join_arity+              spec_str   = calcSpecStrictness fn spec_lam_args pats+++                -- Conditionally use result of new worker-wrapper transform+              spec_rhs   = mkLams spec_lam_args_str spec_body+              body_ty    = exprType spec_body+              rule_rhs   = mkVarApps (Var spec_id) spec_call_args+              inline_act = idInlineActivation fn+              this_mod   = sc_module spec_env+              rule       = mkRule this_mod True {- Auto -} True {- Local -}+                                  rule_name inline_act fn_name qvars pats rule_rhs+                           -- See Note [Transfer activation]+        ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule+                               , os_id = spec_id+                               , os_rhs = spec_rhs }) }+++-- See Note [Strictness information in worker binders]+handOutStrictnessInformation :: [Demand] -> [Var] -> [Var]+handOutStrictnessInformation = go+  where+    go _ [] = []+    go [] vs = vs+    go (d:dmds) (v:vs) | isId v = setIdDemandInfo v d : go dmds vs+    go dmds (v:vs) = v : go dmds vs++calcSpecStrictness :: Id                     -- The original function+                   -> [Var] -> [CoreExpr]    -- Call pattern+                   -> StrictSig              -- Strictness of specialised thing+-- See Note [Transfer strictness]+calcSpecStrictness fn qvars pats+  = mkClosedStrictSig spec_dmds topRes+  where+    spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]+    StrictSig (DmdType _ dmds _) = idStrictness fn++    dmd_env = go emptyVarEnv dmds pats++    go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv+    go env ds (Type {} : pats)     = go env ds pats+    go env ds (Coercion {} : pats) = go env ds pats+    go env (d:ds) (pat : pats)     = go (go_one env d pat) ds pats+    go env _      _                = env++    go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv+    go_one env d   (Var v) = extendVarEnv_C bothDmd env v d+    go_one env d e+           | Just ds <- splitProdDmd_maybe d  -- NB: d does not have to be strict+           , (Var _, args) <- collectArgs e = go env ds args+    go_one env _         _ = env++{-+Note [spec_usg includes rhs_usg]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In calls to 'specialise', the returned ScUsage must include the rhs_usg in+the passed-in SpecInfo, unless there are no calls at all to the function.++The caller can, indeed must, assume this.  He should not combine in rhs_usg+himself, or he'll get rhs_usg twice -- and that can lead to an exponential+blowup of duplicates in the CallEnv.  This is what gave rise to the massive+performance loss in #8852.++Note [Specialise original body]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The RhsInfo for a binding keeps the *original* body of the binding.  We+must specialise that, *not* the result of applying specExpr to the RHS+(which is also kept in RhsInfo). Otherwise we end up specialising a+specialised RHS, and that can lead directly to exponential behaviour.++Note [Transfer activation]+~~~~~~~~~~~~~~~~~~~~~~~~~~+  This note is for SpecConstr, but exactly the same thing+  happens in the overloading specialiser; see+  Note [Auto-specialisation and RULES] in Specialise.++In which phase should the specialise-constructor rules be active?+Originally I made them always-active, but Manuel found that this+defeated some clever user-written rules.  Then I made them active only+in Phase 0; after all, currently, the specConstr transformation is+only run after the simplifier has reached Phase 0, but that meant+that specialisations didn't fire inside wrappers; see test+simplCore/should_compile/spec-inline.++So now I just use the inline-activation of the parent Id, as the+activation for the specialisation RULE, just like the main specialiser;++This in turn means there is no point in specialising NOINLINE things,+so we test for that.++Note [Transfer strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We must transfer strictness information from the original function to+the specialised one.  Suppose, for example++  f has strictness     SS+        and a RULE     f (a:as) b = f_spec a as b++Now we want f_spec to have strictness  LLS, otherwise we'll use call-by-need+when calling f_spec instead of call-by-value.  And that can result in+unbounded worsening in space (cf the classic foldl vs foldl')++See #3437 for a good example.++The function calcSpecStrictness performs the calculation.++Note [Strictness information in worker binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++After having calculated the strictness annotation for the worker (see Note+[Transfer strictness] above), we also want to have this information attached to+the worker’s arguments, for the benefit of later passes. The function+handOutStrictnessInformation decomposes the strictness annotation calculated by+calcSpecStrictness and attaches them to the variables.++************************************************************************+*                                                                      *+\subsection{Argument analysis}+*                                                                      *+************************************************************************++This code deals with analysing call-site arguments to see whether+they are constructor applications.++Note [Free type variables of the qvar types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a call (f @a x True), that we want to specialise, what variables should+we quantify over.  Clearly over 'a' and 'x', but what about any type variables+free in x's type?  In fact we don't need to worry about them because (f @a)+can only be a well-typed application if its type is compatible with x, so any+variables free in x's type must be free in (f @a), and hence either be gathered+via 'a' itself, or be in scope at f's defn.  Hence we just take+  (exprsFreeVars pats).++BUT phantom type synonyms can mess this reasoning up,+  eg   x::T b   with  type T b = Int+So we apply expandTypeSynonyms to the bound Ids.+See # 5458.  Yuk.++Note [SpecConstr call patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A "call patterns" that we collect is going to become the LHS of a RULE.+It's important that it doesn't have+     e |> Refl+or+    e |> g1 |> g2+because both of these will be optimised by Simplify.simplRule. In the+former case such optimisation benign, because the rule will match more+terms; but in the latter we may lose a binding of 'g1' or 'g2', and+end up with a rule LHS that doesn't bind the template variables+(#10602).++The simplifier eliminates such things, but SpecConstr itself constructs+new terms by substituting.  So the 'mkCast' in the Cast case of scExpr+is very important!++Note [Choosing patterns]+~~~~~~~~~~~~~~~~~~~~~~~~+If we get lots of patterns we may not want to make a specialisation+for each of them (code bloat), so we choose as follows, implemented+by trim_pats.++* The flag -fspec-constr-count-N sets the sc_count field+  of the ScEnv to (Just n).  This limits the total number+  of specialisations for a given function to N.++* -fno-spec-constr-count sets the sc_count field to Nothing,+  which switches of the limit.++* The ghastly ForceSpecConstr trick also switches of the limit+  for a particular function++* Otherwise we sort the patterns to choose the most general+  ones first; more general => more widely applicable.++Note [SpecConstr and casts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#14270) a call like++    let f = e+    in ... f (K @(a |> co)) ...++where 'co' is a coercion variable not in scope at f's definition site.+If we aren't caereful we'll get++    let $sf a co = e (K @(a |> co))+        RULE "SC:f" forall a co.  f (K @(a |> co)) = $sf a co+        f = e+    in ...++But alas, when we match the call we won't bind 'co', because type-matching+(for good reasons) discards casts).++I don't know how to solve this, so for now I'm just discarding any+call patterns that+  * Mentions a coercion variable in a type argument+  * That is not in scope at the binding of the function++I think this is very rare.++It is important (e.g. #14936) that this /only/ applies to+coercions mentioned in casts.  We don't want to be discombobulated+by casts in terms!  For example, consider+   f ((e1,e2) |> sym co)+where, say,+   f  :: Foo -> blah+   co :: Foo ~R (Int,Int)++Here we definitely do want to specialise for that pair!  We do not+match on the structre of the coercion; instead we just match on a+coercion variable, so the RULE looks like++   forall (x::Int, y::Int, co :: (Int,Int) ~R Foo)+     f ((x,y) |> co) = $sf x y co++Often the body of f looks like+   f arg = ...(case arg |> co' of+                (x,y) -> blah)...++so that the specialised f will turn into+   $sf x y co = let arg = (x,y) |> co+                in ...(case arg>| co' of+                         (x,y) -> blah)....++which will simplify to not use 'co' at all.  But we can't guarantee+that co will end up unused, so we still pass it.  Absence analysis+may remove it later.++Note that this /also/ discards the call pattern if we have a cast in a+/term/, although in fact Rules.match does make a very flaky and+fragile attempt to match coercions.  e.g. a call like+    f (Maybe Age) (Nothing |> co) blah+    where co :: Maybe Int ~ Maybe Age+will be discarded.  It's extremely fragile to match on the form of a+coercion, so I think it's better just not to try.  A more complicated+alternative would be to discard calls that mention coercion variables+only in kind-casts, but I'm doing the simple thing for now.+-}++type CallPat = ([Var], [CoreExpr])      -- Quantified variables and arguments+                                        -- See Note [SpecConstr call patterns]++callsToNewPats :: ScEnv -> Id+               -> SpecInfo+               -> [ArgOcc] -> [Call]+               -> UniqSM (Bool, [CallPat])+        -- Result has no duplicate patterns,+        -- nor ones mentioned in done_pats+        -- Bool indicates that there was at least one boring pattern+callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls+  = do  { mb_pats <- mapM (callToPats env bndr_occs) calls++        ; let have_boring_call = any isNothing mb_pats++              good_pats :: [CallPat]+              good_pats = catMaybes mb_pats++              -- Remove patterns we have already done+              new_pats = filterOut is_done good_pats+              is_done p = any (samePat p . os_pat) done_specs++              -- Remove duplicates+              non_dups = nubBy samePat new_pats++              -- Remove ones that have too many worker variables+              small_pats = filterOut too_big non_dups+              too_big (vars,_) = not (isWorkerSmallEnough (sc_dflags env) vars)+                  -- We are about to construct w/w pair in 'spec_one'.+                  -- Omit specialisation leading to high arity workers.+                  -- See Note [Limit w/w arity] in WwLib++                -- Discard specialisations if there are too many of them+              trimmed_pats = trim_pats env fn spec_info small_pats++--        ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls+--                                       , text "done_specs:" <+> ppr (map os_pat done_specs)+--                                       , text "good_pats:" <+> ppr good_pats ]) $+--          return ()++        ; return (have_boring_call, trimmed_pats) }+++trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> [CallPat]+-- See Note [Choosing patterns]+trim_pats env fn (SI { si_n_specs = done_spec_count }) pats+  | sc_force env+    || isNothing mb_scc+    || n_remaining >= n_pats+  = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats)+    pats          -- No need to trim++  | otherwise+  = emit_trace $  -- Need to trim, so keep the best ones+    take n_remaining sorted_pats++  where+    n_pats         = length pats+    spec_count'    = n_pats + done_spec_count+    n_remaining    = max_specs - done_spec_count+    mb_scc         = sc_count env+    Just max_specs = mb_scc++    sorted_pats = map fst $+                  sortBy (comparing snd) $+                  [(pat, pat_cons pat) | pat <- pats]+     -- Sort in order of increasing number of constructors+     -- (i.e. decreasing generality) and pick the initial+     -- segment of this list++    pat_cons :: CallPat -> Int+    -- How many data constructors of literals are in+    -- the pattern.  More data-cons => less general+    pat_cons (qs, ps) = foldr ((+) . n_cons) 0 ps+       where+          q_set = mkVarSet qs+          n_cons (Var v) | v `elemVarSet` q_set = 0+                         | otherwise            = 1+          n_cons (Cast e _)  = n_cons e+          n_cons (App e1 e2) = n_cons e1 + n_cons e2+          n_cons (Lit {})    = 1+          n_cons _           = 0++    emit_trace result+       | debugIsOn || hasPprDebug (sc_dflags env)+         -- Suppress this scary message for ordinary users!  #5125+       = pprTrace "SpecConstr" msg result+       | otherwise+       = result+    msg = vcat [ sep [ text "Function" <+> quotes (ppr fn)+                     , nest 2 (text "has" <+>+                               speakNOf spec_count' (text "call pattern") <> comma <+>+                               text "but the limit is" <+> int max_specs) ]+               , text "Use -fspec-constr-count=n to set the bound"+               , text "done_spec_count =" <+> int done_spec_count+               , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats+               , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ]+++callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)+        -- The [Var] is the variables to quantify over in the rule+        --      Type variables come first, since they may scope+        --      over the following term variables+        -- The [CoreExpr] are the argument patterns for the rule+callToPats env bndr_occs call@(Call _ args con_env)+  | args `ltLength` bndr_occs      -- Check saturated+  = return Nothing+  | otherwise+  = do  { let in_scope = substInScope (sc_subst env)+        ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs+        ; let pat_fvs = exprsFreeVarsList pats+                -- To get determinism we need the list of free variables in+                -- deterministic order. Otherwise we end up creating+                -- lambdas with different argument orders. See+                -- determinism/simplCore/should_compile/spec-inline-determ.hs+                -- for an example. For explanation of determinism+                -- considerations See Note [Unique Determinism] in Unique.++              in_scope_vars = getInScopeVars in_scope+              is_in_scope v = v `elemVarSet` in_scope_vars+              qvars         = filterOut is_in_scope pat_fvs+                -- Quantify over variables that are not in scope+                -- at the call site+                -- See Note [Free type variables of the qvar types]+                -- See Note [Shadowing] at the top++              (ktvs, ids)   = partition isTyVar qvars+              qvars'        = scopedSort ktvs ++ map sanitise ids+                -- Order into kind variables, type variables, term variables+                -- The kind of a type variable may mention a kind variable+                -- and the type of a term variable may mention a type variable++              sanitise id   = id `setIdType` expandTypeSynonyms (idType id)+                -- See Note [Free type variables of the qvar types]++              -- Bad coercion variables: see Note [SpecConstr and casts]+              bad_covars :: CoVarSet+              bad_covars = mapUnionVarSet get_bad_covars pats+              get_bad_covars :: CoreArg -> CoVarSet+              get_bad_covars (Type ty)+                = filterVarSet (\v -> isId v && not (is_in_scope v)) $+                  tyCoVarsOfType ty+              get_bad_covars _+                = emptyVarSet++        ; -- pprTrace "callToPats"  (ppr args $$ ppr bndr_occs) $+          WARN( not (isEmptyVarSet bad_covars)+              , text "SpecConstr: bad covars:" <+> ppr bad_covars+                $$ ppr call )+          if interesting && isEmptyVarSet bad_covars+          then return (Just (qvars', pats))+          else return Nothing }++    -- argToPat takes an actual argument, and returns an abstracted+    -- version, consisting of just the "constructor skeleton" of the+    -- argument, with non-constructor sub-expression replaced by new+    -- placeholder variables.  For example:+    --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)++argToPat :: ScEnv+         -> InScopeSet                  -- What's in scope at the fn defn site+         -> ValueEnv                    -- ValueEnv at the call site+         -> CoreArg                     -- A call arg (or component thereof)+         -> ArgOcc+         -> UniqSM (Bool, CoreArg)++-- Returns (interesting, pat),+-- where pat is the pattern derived from the argument+--            interesting=True if the pattern is non-trivial (not a variable or type)+-- E.g.         x:xs         --> (True, x:xs)+--              f xs         --> (False, w)        where w is a fresh wildcard+--              (f xs, 'c')  --> (True, (w, 'c'))  where w is a fresh wildcard+--              \x. x+y      --> (True, \x. x+y)+--              lvl7         --> (True, lvl7)      if lvl7 is bound+--                                                 somewhere further out++argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ+  = return (False, arg)++argToPat env in_scope val_env (Tick _ arg) arg_occ+  = argToPat env in_scope val_env arg arg_occ+        -- Note [Notes in call patterns]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        -- Ignore Notes.  In particular, we want to ignore any InlineMe notes+        -- Perhaps we should not ignore profiling notes, but I'm going to+        -- ride roughshod over them all for now.+        --- See Note [Notes in RULE matching] in Rules++argToPat env in_scope val_env (Let _ arg) arg_occ+  = argToPat env in_scope val_env arg arg_occ+        -- See Note [Matching lets] in Rule.hs+        -- Look through let expressions+        -- e.g.         f (let v = rhs in (v,w))+        -- Here we can specialise for f (v,w)+        -- because the rule-matcher will look through the let.++{- Disabled; see Note [Matching cases] in Rule.hs+argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ+  | exprOkForSpeculation scrut  -- See Note [Matching cases] in Rule.hhs+  = argToPat env in_scope val_env rhs arg_occ+-}++argToPat env in_scope val_env (Cast arg co) arg_occ+  | not (ignoreType env ty2)+  = do  { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ+        ; if not interesting then+                wildCardPat ty2+          else do+        { -- Make a wild-card pattern for the coercion+          uniq <- getUniqueM+        ; let co_name = mkSysTvName uniq (fsLit "sg")+              co_var  = mkCoVar co_name (mkCoercionType Representational ty1 ty2)+        ; return (interesting, Cast arg' (mkCoVarCo co_var)) } }+  where+    Pair ty1 ty2 = coercionKind co++++{-      Disabling lambda specialisation for now+        It's fragile, and the spec_loop can be infinite+argToPat in_scope val_env arg arg_occ+  | is_value_lam arg+  = return (True, arg)+  where+    is_value_lam (Lam v e)         -- Spot a value lambda, even if+        | isId v       = True      -- it is inside a type lambda+        | otherwise    = is_value_lam e+    is_value_lam other = False+-}++  -- Check for a constructor application+  -- NB: this *precedes* the Var case, so that we catch nullary constrs+argToPat env in_scope val_env arg arg_occ+  | Just (ConVal (DataAlt dc) args) <- isValue val_env arg+  , not (ignoreDataCon env dc)        -- See Note [NoSpecConstr]+  , Just arg_occs <- mb_scrut dc+  = do  { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args+        ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs+        ; return (True,+                  mkConApp dc (ty_args ++ args')) }+  where+    mb_scrut dc = case arg_occ of+                    ScrutOcc bs | Just occs <- lookupUFM bs dc+                                -> Just (occs)  -- See Note [Reboxing]+                    _other      | sc_force env || sc_keen env+                                -> Just (repeat UnkOcc)+                                | otherwise+                                -> Nothing++  -- Check if the argument is a variable that+  --    (a) is used in an interesting way in the function body+  --    (b) we know what its value is+  -- In that case it counts as "interesting"+argToPat env in_scope val_env (Var v) arg_occ+  | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a)+    is_value,                                                            -- (b)+       -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing]+       -- So sc_keen focused just on f (I# x), where we have freshly-allocated+       -- box that we can eliminate in the caller+    not (ignoreType env (varType v))+  = return (True, Var v)+  where+    is_value+        | isLocalId v = v `elemInScopeSet` in_scope+                        && isJust (lookupVarEnv val_env v)+                -- Local variables have values in val_env+        | otherwise   = isValueUnfolding (idUnfolding v)+                -- Imports have unfoldings++--      I'm really not sure what this comment means+--      And by not wild-carding we tend to get forall'd+--      variables that are in scope, which in turn can+--      expose the weakness in let-matching+--      See Note [Matching lets] in Rules++  -- Check for a variable bound inside the function.+  -- Don't make a wild-card, because we may usefully share+  --    e.g.  f a = let x = ... in f (x,x)+  -- NB: this case follows the lambda and con-app cases!!+-- argToPat _in_scope _val_env (Var v) _arg_occ+--   = return (False, Var v)+        -- SLPJ : disabling this to avoid proliferation of versions+        -- also works badly when thinking about seeding the loop+        -- from the body of the let+        --       f x y = letrec g z = ... in g (x,y)+        -- We don't want to specialise for that *particular* x,y++  -- The default case: make a wild-card+  -- We use this for coercions too+argToPat _env _in_scope _val_env arg _arg_occ+  = wildCardPat (exprType arg)++wildCardPat :: Type -> UniqSM (Bool, CoreArg)+wildCardPat ty+  = do { uniq <- getUniqueM+       ; let id = mkSysLocalOrCoVar (fsLit "sc") uniq ty+       ; return (False, varToCoreExpr id) }++argsToPats :: ScEnv -> InScopeSet -> ValueEnv+           -> [CoreArg] -> [ArgOcc]  -- Should be same length+           -> UniqSM (Bool, [CoreArg])+argsToPats env in_scope val_env args occs+  = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs+       ; let (interesting_s, args') = unzip stuff+       ; return (or interesting_s, args') }++isValue :: ValueEnv -> CoreExpr -> Maybe Value+isValue _env (Lit lit)+  | litIsLifted lit = Nothing+  | otherwise       = Just (ConVal (LitAlt lit) [])++isValue env (Var v)+  | Just cval <- lookupVarEnv env v+  = Just cval  -- You might think we could look in the idUnfolding here+               -- but that doesn't take account of which branch of a+               -- case we are in, which is the whole point++  | not (isLocalId v) && isCheapUnfolding unf+  = isValue env (unfoldingTemplate unf)+  where+    unf = idUnfolding v+        -- However we do want to consult the unfolding+        -- as well, for let-bound constructors!++isValue env (Lam b e)+  | isTyVar b = case isValue env e of+                  Just _  -> Just LambdaVal+                  Nothing -> Nothing+  | otherwise = Just LambdaVal++isValue env (Tick t e)+  | not (tickishIsCode t)+  = isValue env e++isValue _env expr       -- Maybe it's a constructor application+  | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr+  = case isDataConWorkId_maybe fun of++        Just con | args `lengthAtLeast` dataConRepArity con+                -- Check saturated; might be > because the+                --                  arity excludes type args+                -> Just (ConVal (DataAlt con) args)++        _other | valArgCount args < idArity fun+                -- Under-applied function+               -> Just LambdaVal        -- Partial application++        _other -> Nothing++isValue _env _expr = Nothing++valueIsWorkFree :: Value -> Bool+valueIsWorkFree LambdaVal       = True+valueIsWorkFree (ConVal _ args) = all exprIsWorkFree args++samePat :: CallPat -> CallPat -> Bool+samePat (vs1, as1) (vs2, as2)+  = all2 same as1 as2+  where+    same (Var v1) (Var v2)+        | v1 `elem` vs1 = v2 `elem` vs2+        | v2 `elem` vs2 = False+        | otherwise     = v1 == v2++    same (Lit l1)    (Lit l2)    = l1==l2+    same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2++    same (Type {}) (Type {}) = True     -- Note [Ignore type differences]+    same (Coercion {}) (Coercion {}) = True+    same (Tick _ e1) e2 = same e1 e2  -- Ignore casts and notes+    same (Cast e1 _) e2 = same e1 e2+    same e1 (Tick _ e2) = same e1 e2+    same e1 (Cast e2 _) = same e1 e2++    same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)+                 False  -- Let, lambda, case should not occur+    bad (Case {}) = True+    bad (Let {})  = True+    bad (Lam {})  = True+    bad _other    = False++{-+Note [Ignore type differences]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not want to generate specialisations where the call patterns+differ only in their type arguments!  Not only is it utterly useless,+but it also means that (with polymorphic recursion) we can generate+an infinite number of specialisations. Example is Data.Sequence.adjustTree,+I think.+-}
+ compiler/specialise/Specialise.hs view
@@ -0,0 +1,2463 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}+-}++{-# LANGUAGE CPP #-}+module Specialise ( specProgram, specUnfolding ) where++#include "HsVersions.h"++import GhcPrelude++import Id+import TcType hiding( substTy )+import Type   hiding( substTy, extendTvSubstList )+import Module( Module, HasModule(..) )+import Coercion( Coercion )+import CoreMonad+import qualified CoreSubst+import CoreUnfold+import Var              ( isLocalVar )+import VarSet+import VarEnv+import CoreSyn+import Rules+import CoreOpt          ( collectBindersPushingCo )+import CoreUtils        ( exprIsTrivial, applyTypeToArgs, mkCast )+import CoreFVs+import CoreArity        ( etaExpandToJoinPointRule )+import UniqSupply+import Name+import MkId             ( voidArgId, voidPrimId )+import Maybes           ( catMaybes, isJust )+import MonadUtils       ( foldlM )+import BasicTypes+import HscTypes+import Bag+import DynFlags+import Util+import Outputable+import FastString+import State+import UniqDFM++import Control.Monad+import qualified Control.Monad.Fail as MonadFail++{-+************************************************************************+*                                                                      *+\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}+*                                                                      *+************************************************************************++These notes describe how we implement specialisation to eliminate+overloading.++The specialisation pass works on Core+syntax, complete with all the explicit dictionary application,+abstraction and construction as added by the type checker.  The+existing type checker remains largely as it is.++One important thought: the {\em types} passed to an overloaded+function, and the {\em dictionaries} passed are mutually redundant.+If the same function is applied to the same type(s) then it is sure to+be applied to the same dictionary(s)---or rather to the same {\em+values}.  (The arguments might look different but they will evaluate+to the same value.)++Second important thought: we know that we can make progress by+treating dictionary arguments as static and worth specialising on.  So+we can do without binding-time analysis, and instead specialise on+dictionary arguments and no others.++The basic idea+~~~~~~~~~~~~~~+Suppose we have++        let f = <f_rhs>+        in <body>++and suppose f is overloaded.++STEP 1: CALL-INSTANCE COLLECTION++We traverse <body>, accumulating all applications of f to types and+dictionaries.++(Might there be partial applications, to just some of its types and+dictionaries?  In principle yes, but in practice the type checker only+builds applications of f to all its types and dictionaries, so partial+applications could only arise as a result of transformation, and even+then I think it's unlikely.  In any case, we simply don't accumulate such+partial applications.)+++STEP 2: EQUIVALENCES++So now we have a collection of calls to f:+        f t1 t2 d1 d2+        f t3 t4 d3 d4+        ...+Notice that f may take several type arguments.  To avoid ambiguity, we+say that f is called at type t1/t2 and t3/t4.++We take equivalence classes using equality of the *types* (ignoring+the dictionary args, which as mentioned previously are redundant).++STEP 3: SPECIALISATION++For each equivalence class, choose a representative (f t1 t2 d1 d2),+and create a local instance of f, defined thus:++        f@t1/t2 = <f_rhs> t1 t2 d1 d2++f_rhs presumably has some big lambdas and dictionary lambdas, so lots+of simplification will now result.  However we don't actually *do* that+simplification.  Rather, we leave it for the simplifier to do.  If we+*did* do it, though, we'd get more call instances from the specialised+RHS.  We can work out what they are by instantiating the call-instance+set from f's RHS with the types t1, t2.++Add this new id to f's IdInfo, to record that f has a specialised version.++Before doing any of this, check that f's IdInfo doesn't already+tell us about an existing instance of f at the required type/s.+(This might happen if specialisation was applied more than once, or+it might arise from user SPECIALIZE pragmas.)++Recursion+~~~~~~~~~+Wait a minute!  What if f is recursive?  Then we can't just plug in+its right-hand side, can we?++But it's ok.  The type checker *always* creates non-recursive definitions+for overloaded recursive functions.  For example:++        f x = f (x+x)           -- Yes I know its silly++becomes++        f a (d::Num a) = let p = +.sel a d+                         in+                         letrec fl (y::a) = fl (p y y)+                         in+                         fl++We still have recursion for non-overloaded functions which we+specialise, but the recursive call should get specialised to the+same recursive version.+++Polymorphism 1+~~~~~~~~~~~~~~++All this is crystal clear when the function is applied to *constant+types*; that is, types which have no type variables inside.  But what if+it is applied to non-constant types?  Suppose we find a call of f at type+t1/t2.  There are two possibilities:++(a) The free type variables of t1, t2 are in scope at the definition point+of f.  In this case there's no problem, we proceed just as before.  A common+example is as follows.  Here's the Haskell:++        g y = let f x = x+x+              in f y + f y++After typechecking we have++        g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x+                                in +.sel a d (f a d y) (f a d y)++Notice that the call to f is at type type "a"; a non-constant type.+Both calls to f are at the same type, so we can specialise to give:++        g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x+                                in +.sel a d (f@a y) (f@a y)+++(b) The other case is when the type variables in the instance types+are *not* in scope at the definition point of f.  The example we are+working with above is a good case.  There are two instances of (+.sel a d),+but "a" is not in scope at the definition of +.sel.  Can we do anything?+Yes, we can "common them up", a sort of limited common sub-expression deal.+This would give:++        g a (d::Num a) (y::a) = let +.sel@a = +.sel a d+                                    f@a (x::a) = +.sel@a x x+                                in +.sel@a (f@a y) (f@a y)++This can save work, and can't be spotted by the type checker, because+the two instances of +.sel weren't originally at the same type.++Further notes on (b)++* There are quite a few variations here.  For example, the defn of+  +.sel could be floated ouside the \y, to attempt to gain laziness.+  It certainly mustn't be floated outside the \d because the d has to+  be in scope too.++* We don't want to inline f_rhs in this case, because+that will duplicate code.  Just commoning up the call is the point.++* Nothing gets added to +.sel's IdInfo.++* Don't bother unless the equivalence class has more than one item!++Not clear whether this is all worth it.  It is of course OK to+simply discard call-instances when passing a big lambda.++Polymorphism 2 -- Overloading+~~~~~~~~~~~~~~+Consider a function whose most general type is++        f :: forall a b. Ord a => [a] -> b -> b++There is really no point in making a version of g at Int/Int and another+at Int/Bool, because it's only instantiating the type variable "a" which+buys us any efficiency. Since g is completely polymorphic in b there+ain't much point in making separate versions of g for the different+b types.++That suggests that we should identify which of g's type variables+are constrained (like "a") and which are unconstrained (like "b").+Then when taking equivalence classes in STEP 2, we ignore the type args+corresponding to unconstrained type variable.  In STEP 3 we make+polymorphic versions.  Thus:++        f@t1/ = /\b -> <f_rhs> t1 b d1 d2++We do this.+++Dictionary floating+~~~~~~~~~~~~~~~~~~~+Consider this++        f a (d::Num a) = let g = ...+                         in+                         ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...++Here, g is only called at one type, but the dictionary isn't in scope at the+definition point for g.  Usually the type checker would build a+definition for d1 which enclosed g, but the transformation system+might have moved d1's defn inward.  Solution: float dictionary bindings+outwards along with call instances.++Consider++        f x = let g p q = p==q+                  h r s = (r+s, g r s)+              in+              h x x+++Before specialisation, leaving out type abstractions we have++        f df x = let g :: Eq a => a -> a -> Bool+                     g dg p q = == dg p q+                     h :: Num a => a -> a -> (a, Bool)+                     h dh r s = let deq = eqFromNum dh+                                in (+ dh r s, g deq r s)+              in+              h df x x++After specialising h we get a specialised version of h, like this:++                    h' r s = let deq = eqFromNum df+                             in (+ df r s, g deq r s)++But we can't naively make an instance for g from this, because deq is not in scope+at the defn of g.  Instead, we have to float out the (new) defn of deq+to widen its scope.  Notice that this floating can't be done in advance -- it only+shows up when specialisation is done.++User SPECIALIZE pragmas+~~~~~~~~~~~~~~~~~~~~~~~+Specialisation pragmas can be digested by the type checker, and implemented+by adding extra definitions along with that of f, in the same way as before++        f@t1/t2 = <f_rhs> t1 t2 d1 d2++Indeed the pragmas *have* to be dealt with by the type checker, because+only it knows how to build the dictionaries d1 and d2!  For example++        g :: Ord a => [a] -> [a]+        {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}++Here, the specialised version of g is an application of g's rhs to the+Ord dictionary for (Tree Int), which only the type checker can conjure+up.  There might not even *be* one, if (Tree Int) is not an instance of+Ord!  (All the other specialision has suitable dictionaries to hand+from actual calls.)++Problem.  The type checker doesn't have to hand a convenient <f_rhs>, because+it is buried in a complex (as-yet-un-desugared) binding group.+Maybe we should say++        f@t1/t2 = f* t1 t2 d1 d2++where f* is the Id f with an IdInfo which says "inline me regardless!".+Indeed all the specialisation could be done in this way.+That in turn means that the simplifier has to be prepared to inline absolutely+any in-scope let-bound thing.+++Again, the pragma should permit polymorphism in unconstrained variables:++        h :: Ord a => [a] -> b -> b+        {-# SPECIALIZE h :: [Int] -> b -> b #-}++We *insist* that all overloaded type variables are specialised to ground types,+(and hence there can be no context inside a SPECIALIZE pragma).+We *permit* unconstrained type variables to be specialised to+        - a ground type+        - or left as a polymorphic type variable+but nothing in between.  So++        {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}++is *illegal*.  (It can be handled, but it adds complication, and gains the+programmer nothing.)+++SPECIALISING INSTANCE DECLARATIONS+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++        instance Foo a => Foo [a] where+                ...+        {-# SPECIALIZE instance Foo [Int] #-}++The original instance decl creates a dictionary-function+definition:++        dfun.Foo.List :: forall a. Foo a -> Foo [a]++The SPECIALIZE pragma just makes a specialised copy, just as for+ordinary function definitions:++        dfun.Foo.List@Int :: Foo [Int]+        dfun.Foo.List@Int = dfun.Foo.List Int dFooInt++The information about what instance of the dfun exist gets added to+the dfun's IdInfo in the same way as a user-defined function too.+++Automatic instance decl specialisation?+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Can instance decls be specialised automatically?  It's tricky.+We could collect call-instance information for each dfun, but+then when we specialised their bodies we'd get new call-instances+for ordinary functions; and when we specialised their bodies, we might get+new call-instances of the dfuns, and so on.  This all arises because of+the unrestricted mutual recursion between instance decls and value decls.++Still, there's no actual problem; it just means that we may not do all+the specialisation we could theoretically do.++Furthermore, instance decls are usually exported and used non-locally,+so we'll want to compile enough to get those specialisations done.++Lastly, there's no such thing as a local instance decl, so we can+survive solely by spitting out *usage* information, and then reading that+back in as a pragma when next compiling the file.  So for now,+we only specialise instance decls in response to pragmas.+++SPITTING OUT USAGE INFORMATION+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++To spit out usage information we need to traverse the code collecting+call-instance information for all imported (non-prelude?) functions+and data types. Then we equivalence-class it and spit it out.++This is done at the top-level when all the call instances which escape+must be for imported functions and data types.++*** Not currently done ***+++Partial specialisation by pragmas+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What about partial specialisation:++        k :: (Ord a, Eq b) => [a] -> b -> b -> [a]+        {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}++or even++        {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}++Seems quite reasonable.  Similar things could be done with instance decls:++        instance (Foo a, Foo b) => Foo (a,b) where+                ...+        {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}+        {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}++Ho hum.  Things are complex enough without this.  I pass.+++Requirements for the simplifier+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The simplifier has to be able to take advantage of the specialisation.++* When the simplifier finds an application of a polymorphic f, it looks in+f's IdInfo in case there is a suitable instance to call instead.  This converts++        f t1 t2 d1 d2   ===>   f_t1_t2++Note that the dictionaries get eaten up too!++* Dictionary selection operations on constant dictionaries must be+  short-circuited:++        +.sel Int d     ===>  +Int++The obvious way to do this is in the same way as other specialised+calls: +.sel has inside it some IdInfo which tells that if it's applied+to the type Int then it should eat a dictionary and transform to +Int.++In short, dictionary selectors need IdInfo inside them for constant+methods.++* Exactly the same applies if a superclass dictionary is being+  extracted:++        Eq.sel Int d   ===>   dEqInt++* Something similar applies to dictionary construction too.  Suppose+dfun.Eq.List is the function taking a dictionary for (Eq a) to+one for (Eq [a]).  Then we want++        dfun.Eq.List Int d      ===> dEq.List_Int++Where does the Eq [Int] dictionary come from?  It is built in+response to a SPECIALIZE pragma on the Eq [a] instance decl.++In short, dfun Ids need IdInfo with a specialisation for each+constant instance of their instance declaration.++All this uses a single mechanism: the SpecEnv inside an Id+++What does the specialisation IdInfo look like?+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The SpecEnv of an Id maps a list of types (the template) to an expression++        [Type]  |->  Expr++For example, if f has this RuleInfo:++        [Int, a]  ->  \d:Ord Int. f' a++it means that we can replace the call++        f Int t  ===>  (\d. f' t)++This chucks one dictionary away and proceeds with the+specialised version of f, namely f'.+++What can't be done this way?+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is no way, post-typechecker, to get a dictionary for (say)+Eq a from a dictionary for Eq [a].  So if we find++        ==.sel [t] d++we can't transform to++        eqList (==.sel t d')++where+        eqList :: (a->a->Bool) -> [a] -> [a] -> Bool++Of course, we currently have no way to automatically derive+eqList, nor to connect it to the Eq [a] instance decl, but you+can imagine that it might somehow be possible.  Taking advantage+of this is permanently ruled out.++Still, this is no great hardship, because we intend to eliminate+overloading altogether anyway!++A note about non-tyvar dictionaries+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some Ids have types like++        forall a,b,c. Eq a -> Ord [a] -> tau++This seems curious at first, because we usually only have dictionary+args whose types are of the form (C a) where a is a type variable.+But this doesn't hold for the functions arising from instance decls,+which sometimes get arguments with types of form (C (T a)) for some+type constructor T.++Should we specialise wrt this compound-type dictionary?  We used to say+"no", saying:+        "This is a heuristic judgement, as indeed is the fact that we+        specialise wrt only dictionaries.  We choose *not* to specialise+        wrt compound dictionaries because at the moment the only place+        they show up is in instance decls, where they are simply plugged+        into a returned dictionary.  So nothing is gained by specialising+        wrt them."++But it is simpler and more uniform to specialise wrt these dicts too;+and in future GHC is likely to support full fledged type signatures+like+        f :: Eq [(a,b)] => ...+++************************************************************************+*                                                                      *+\subsubsection{The new specialiser}+*                                                                      *+************************************************************************++Our basic game plan is this.  For let(rec) bound function+        f :: (C a, D c) => (a,b,c,d) -> Bool++* Find any specialised calls of f, (f ts ds), where+  ts are the type arguments t1 .. t4, and+  ds are the dictionary arguments d1 .. d2.++* Add a new definition for f1 (say):++        f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2++  Note that we abstract over the unconstrained type arguments.++* Add the mapping++        [t1,b,t3,d]  |->  \d1 d2 -> f1 b d++  to the specialisations of f.  This will be used by the+  simplifier to replace calls+                (f t1 t2 t3 t4) da db+  by+                (\d1 d1 -> f1 t2 t4) da db++  All the stuff about how many dictionaries to discard, and what types+  to apply the specialised function to, are handled by the fact that the+  SpecEnv contains a template for the result of the specialisation.++We don't build *partial* specialisations for f.  For example:++  f :: Eq a => a -> a -> Bool+  {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-}++Here, little is gained by making a specialised copy of f.+There's a distinct danger that the specialised version would+first build a dictionary for (Eq b, Eq c), and then select the (==)+method from it!  Even if it didn't, not a great deal is saved.++We do, however, generate polymorphic, but not overloaded, specialisations:++  f :: Eq a => [a] -> b -> b -> b+  ... SPECIALISE f :: [Int] -> b -> b -> b ...++Hence, the invariant is this:++        *** no specialised version is overloaded ***+++************************************************************************+*                                                                      *+\subsubsection{The exported function}+*                                                                      *+************************************************************************+-}++-- | Specialise calls to type-class overloaded functions occuring in a program.+specProgram :: ModGuts -> CoreM ModGuts+specProgram guts@(ModGuts { mg_module = this_mod+                          , mg_rules = local_rules+                          , mg_binds = binds })+  = do { dflags <- getDynFlags++             -- Specialise the bindings of this module+       ; (binds', uds) <- runSpecM dflags this_mod (go binds)++             -- Specialise imported functions+       ; hpt_rules <- getRuleBase+       ; let rule_base = extendRuleBaseList hpt_rules local_rules+       ; (new_rules, spec_binds) <- specImports dflags this_mod top_env emptyVarSet+                                                [] rule_base uds++       ; let final_binds+               | null spec_binds = binds'+               | otherwise       = Rec (flattenBinds spec_binds) : binds'+                   -- Note [Glom the bindings if imported functions are specialised]++       ; return (guts { mg_binds = final_binds+                      , mg_rules = new_rules ++ local_rules }) }+  where+        -- We need to start with a Subst that knows all the things+        -- that are in scope, so that the substitution engine doesn't+        -- accidentally re-use a unique that's already in use+        -- Easiest thing is to do it all at once, as if all the top-level+        -- decls were mutually recursive+    top_env = SE { se_subst = CoreSubst.mkEmptySubst $ mkInScopeSet $ mkVarSet $+                              bindersOfBinds binds+                 , se_interesting = emptyVarSet }++    go []           = return ([], emptyUDs)+    go (bind:binds) = do (binds', uds) <- go binds+                         (bind', uds') <- specBind top_env bind uds+                         return (bind' ++ binds', uds')++{-+Note [Wrap bindings returned by specImports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'specImports' returns a set of specialized bindings. However, these are lacking+necessary floated dictionary bindings, which are returned by+UsageDetails(ud_binds). These dictionaries need to be brought into scope with+'wrapDictBinds' before the bindings returned by 'specImports' can be used. See,+for instance, the 'specImports' call in 'specProgram'.+++Note [Disabling cross-module specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since GHC 7.10 we have performed specialisation of INLINABLE bindings living+in modules outside of the current module. This can sometimes uncover user code+which explodes in size when aggressively optimized. The+-fno-cross-module-specialise option was introduced to allow users to being+bitten by such instances to revert to the pre-7.10 behavior.++See #10491+-}++-- | Specialise a set of calls to imported bindings+specImports :: DynFlags+            -> Module+            -> SpecEnv          -- Passed in so that all top-level Ids are in scope+            -> VarSet           -- Don't specialise these ones+                                -- See Note [Avoiding recursive specialisation]+            -> [Id]             -- Stack of imported functions being specialised+            -> RuleBase         -- Rules from this module and the home package+                                -- (but not external packages, which can change)+            -> UsageDetails     -- Calls for imported things, and floating bindings+            -> CoreM ( [CoreRule]   -- New rules+                     , [CoreBind] ) -- Specialised bindings+                                    -- See Note [Wrapping bindings returned by specImports]+specImports dflags this_mod top_env done callers rule_base+            (MkUD { ud_binds = dict_binds, ud_calls = calls })+  -- See Note [Disabling cross-module specialisation]+  | not $ gopt Opt_CrossModuleSpecialise dflags+  = return ([], [])++  | otherwise+  = do { let import_calls = dVarEnvElts calls+       ; (rules, spec_binds) <- go rule_base import_calls++             -- Don't forget to wrap the specialized bindings with+             -- bindings for the needed dictionaries.+             -- See Note [Wrap bindings returned by specImports]+       ; let spec_binds' = wrapDictBinds dict_binds spec_binds++       ; return (rules, spec_binds') }+  where+    go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind])+    go _ [] = return ([], [])+    go rb (cis@(CIS fn _) : other_calls)+      = do { let ok_calls = filterCalls cis dict_binds+                     -- Drop calls that (directly or indirectly) refer to fn+                     -- See Note [Avoiding loops]+--           ; debugTraceMsg (text "specImport" <+> vcat [ ppr fn+--                                                       , text "calls" <+> ppr cis+--                                                       , text "ud_binds =" <+> ppr dict_binds+--                                                       , text "dump set =" <+> ppr dump_set+--                                                       , text "filtered calls =" <+> ppr ok_calls ])+           ; (rules1, spec_binds1) <- specImport dflags this_mod top_env+                                                 done callers rb fn ok_calls++           ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls+           ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }++specImport :: DynFlags+           -> Module+           -> SpecEnv               -- Passed in so that all top-level Ids are in scope+           -> VarSet                -- Don't specialise these+                                    -- See Note [Avoiding recursive specialisation]+           -> [Id]                  -- Stack of imported functions being specialised+           -> RuleBase              -- Rules from this module+           -> Id -> [CallInfo]      -- Imported function and calls for it+           -> CoreM ( [CoreRule]    -- New rules+                    , [CoreBind] )  -- Specialised bindings+specImport dflags this_mod top_env done callers rb fn calls_for_fn+  | fn `elemVarSet` done+  = return ([], [])     -- No warning.  This actually happens all the time+                        -- when specialising a recursive function, because+                        -- the RHS of the specialised function contains a recursive+                        -- call to the original function++  | null calls_for_fn   -- We filtered out all the calls in deleteCallsMentioning+  = return ([], [])++  | wantSpecImport dflags unfolding+  , Just rhs <- maybeUnfoldingTemplate unfolding+  = do {     -- Get rules from the external package state+             -- We keep doing this in case we "page-fault in"+             -- more rules as we go along+       ; hsc_env <- getHscEnv+       ; eps <- liftIO $ hscEPS hsc_env+       ; vis_orphs <- getVisibleOrphanMods+       ; let full_rb = unionRuleBase rb (eps_rule_base eps)+             rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn++       ; (rules1, spec_pairs, uds)+             <- -- pprTrace "specImport1" (vcat [ppr fn, ppr calls_for_fn, ppr rhs]) $+                runSpecM dflags this_mod $+                specCalls (Just this_mod) top_env rules_for_fn calls_for_fn fn rhs+       ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]+             -- After the rules kick in we may get recursion, but+             -- we rely on a global GlomBinds to sort that out later+             -- See Note [Glom the bindings if imported functions are specialised]++              -- Now specialise any cascaded calls+       ; (rules2, spec_binds2) <- -- pprTrace "specImport 2" (ppr fn $$ ppr rules1 $$ ppr spec_binds1) $+                                  specImports dflags this_mod top_env+                                              (extendVarSet done fn)+                                              (fn:callers)+                                              (extendRuleBaseList rb rules1)+                                              uds++       ; let final_binds = spec_binds2 ++ spec_binds1++       ; return (rules2 ++ rules1, final_binds) }++  | otherwise = do { tryWarnMissingSpecs dflags callers fn calls_for_fn+                   ; return ([], [])}++  where+    unfolding = realIdUnfolding fn   -- We want to see the unfolding even for loop breakers++-- | Returns whether or not to show a missed-spec warning.+-- If -Wall-missed-specializations is on, show the warning.+-- Otherwise, if -Wmissed-specializations is on, only show a warning+-- if there is at least one imported function being specialized,+-- and if all imported functions are marked with an inline pragma+-- Use the most specific warning as the reason.+tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM ()+-- See Note [Warning about missed specialisations]+tryWarnMissingSpecs dflags callers fn calls_for_fn+  | wopt Opt_WarnMissedSpecs dflags+    && not (null callers)+    && allCallersInlined                  = doWarn $ Reason Opt_WarnMissedSpecs+  | wopt Opt_WarnAllMissedSpecs dflags    = doWarn $ Reason Opt_WarnAllMissedSpecs+  | otherwise                             = return ()+  where+    allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers+    doWarn reason = +      warnMsg reason+        (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))+                2 (vcat [ text "when specialising" <+> quotes (ppr caller)+                        | caller <- callers])+          , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))+          , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])++wantSpecImport :: DynFlags -> Unfolding -> Bool+-- See Note [Specialise imported INLINABLE things]+wantSpecImport dflags unf+ = case unf of+     NoUnfolding      -> False+     BootUnfolding    -> False+     OtherCon {}      -> False+     DFunUnfolding {} -> True+     CoreUnfolding { uf_src = src, uf_guidance = _guidance }+       | gopt Opt_SpecialiseAggressively dflags -> True+       | isStableSource src -> True+               -- Specialise even INLINE things; it hasn't inlined yet,+               -- so perhaps it never will.  Moreover it may have calls+               -- inside it that we want to specialise+       | otherwise -> False    -- Stable, not INLINE, hence INLINABLE++{- Note [Warning about missed specialisations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose+ * In module Lib, you carefully mark a function 'foo' INLINABLE+ * Import Lib(foo) into another module M+ * Call 'foo' at some specialised type in M+Then you jolly well expect it to be specialised in M.  But what if+'foo' calls another function 'Lib.bar'.  Then you'd like 'bar' to be+specialised too.  But if 'bar' is not marked INLINABLE it may well+not be specialised.  The warning Opt_WarnMissedSpecs warns about this.++It's more noisy to warning about a missed specialisation opportunity+for /every/ overloaded imported function, but sometimes useful. That+is what Opt_WarnAllMissedSpecs does.++ToDo: warn about missed opportunities for local functions.++Note [Specialise imported INLINABLE things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What imported functions do we specialise?  The basic set is+ * DFuns and things with INLINABLE pragmas.+but with -fspecialise-aggressively we add+ * Anything with an unfolding template++#8874 has a good example of why we want to auto-specialise DFuns.++We have the -fspecialise-aggressively flag (usually off), because we+risk lots of orphan modules from over-vigorous specialisation.+However it's not a big deal: anything non-recursive with an+unfolding-template will probably have been inlined already.++Note [Glom the bindings if imported functions are specialised]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have an imported, *recursive*, INLINABLE function+   f :: Eq a => a -> a+   f = /\a \d x. ...(f a d)...+In the module being compiled we have+   g x = f (x::Int)+Now we'll make a specialised function+   f_spec :: Int -> Int+   f_spec = \x -> ...(f Int dInt)...+   {-# RULE  f Int _ = f_spec #-}+   g = \x. f Int dInt x+Note that f_spec doesn't look recursive+After rewriting with the RULE, we get+   f_spec = \x -> ...(f_spec)...+BUT since f_spec was non-recursive before it'll *stay* non-recursive.+The occurrence analyser never turns a NonRec into a Rec.  So we must+make sure that f_spec is recursive.  Easiest thing is to make all+the specialisations for imported bindings recursive.+++Note [Avoiding recursive specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we specialise 'f' we may find new overloaded calls to 'g', 'h' in+'f's RHS.  So we want to specialise g,h.  But we don't want to+specialise f any more!  It's possible that f's RHS might have a+recursive yet-more-specialised call, so we'd diverge in that case.+And if the call is to the same type, one specialisation is enough.+Avoiding this recursive specialisation loop is the reason for the+'done' VarSet passed to specImports and specImport.++************************************************************************+*                                                                      *+\subsubsection{@specExpr@: the main function}+*                                                                      *+************************************************************************+-}++data SpecEnv+  = SE { se_subst :: CoreSubst.Subst+             -- We carry a substitution down:+             -- a) we must clone any binding that might float outwards,+             --    to avoid name clashes+             -- b) we carry a type substitution to use when analysing+             --    the RHS of specialised bindings (no type-let!)+++       , se_interesting :: VarSet+             -- Dict Ids that we know something about+             -- and hence may be worth specialising against+             -- See Note [Interesting dictionary arguments]+     }++specVar :: SpecEnv -> Id -> CoreExpr+specVar env v = CoreSubst.lookupIdSubst (text "specVar") (se_subst env) v++specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)++---------------- First the easy cases --------------------+specExpr env (Type ty)     = return (Type     (substTy env ty), emptyUDs)+specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs)+specExpr env (Var v)       = return (specVar env v, emptyUDs)+specExpr _   (Lit lit)     = return (Lit lit,       emptyUDs)+specExpr env (Cast e co)+  = do { (e', uds) <- specExpr env e+       ; return ((mkCast e' (substCo env co)), uds) }+specExpr env (Tick tickish body)+  = do { (body', uds) <- specExpr env body+       ; return (Tick (specTickish env tickish) body', uds) }++---------------- Applications might generate a call instance --------------------+specExpr env expr@(App {})+  = go expr []+  where+    go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg+                               (fun', uds_app) <- go fun (arg':args)+                               return (App fun' arg', uds_arg `plusUDs` uds_app)++    go (Var f)       args = case specVar env f of+                                Var f' -> return (Var f', mkCallUDs env f' args)+                                e'     -> return (e', emptyUDs) -- I don't expect this!+    go other         _    = specExpr env other++---------------- Lambda/case require dumping of usage details --------------------+specExpr env e@(Lam _ _) = do+    (body', uds) <- specExpr env' body+    let (free_uds, dumped_dbs) = dumpUDs bndrs' uds+    return (mkLams bndrs' (wrapDictBindsE dumped_dbs body'), free_uds)+  where+    (bndrs, body) = collectBinders e+    (env', bndrs') = substBndrs env bndrs+        -- More efficient to collect a group of binders together all at once+        -- and we don't want to split a lambda group with dumped bindings++specExpr env (Case scrut case_bndr ty alts)+  = do { (scrut', scrut_uds) <- specExpr env scrut+       ; (scrut'', case_bndr', alts', alts_uds)+             <- specCase env scrut' case_bndr alts+       ; return (Case scrut'' case_bndr' (substTy env ty) alts'+                , scrut_uds `plusUDs` alts_uds) }++---------------- Finally, let is the interesting case --------------------+specExpr env (Let bind body)+  = do { -- Clone binders+         (rhs_env, body_env, bind') <- cloneBindSM env bind++         -- Deal with the body+       ; (body', body_uds) <- specExpr body_env body++        -- Deal with the bindings+      ; (binds', uds) <- specBind rhs_env bind' body_uds++        -- All done+      ; return (foldr Let body' binds', uds) }++specTickish :: SpecEnv -> Tickish Id -> Tickish Id+specTickish env (Breakpoint ix ids)+  = Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]]+  -- drop vars from the list if they have a non-variable substitution.+  -- should never happen, but it's harmless to drop them anyway.+specTickish _ other_tickish = other_tickish++specCase :: SpecEnv+         -> CoreExpr            -- Scrutinee, already done+         -> Id -> [CoreAlt]+         -> SpecM ( CoreExpr    -- New scrutinee+                  , Id+                  , [CoreAlt]+                  , UsageDetails)+specCase env scrut' case_bndr [(con, args, rhs)]+  | isDictId case_bndr           -- See Note [Floating dictionaries out of cases]+  , interestingDict env scrut'+  , not (isDeadBinder case_bndr && null sc_args')+  = do { (case_bndr_flt : sc_args_flt) <- mapM clone_me (case_bndr' : sc_args')++       ; let sc_rhss = [ Case (Var case_bndr_flt) case_bndr' (idType sc_arg')+                              [(con, args', Var sc_arg')]+                       | sc_arg' <- sc_args' ]++             -- Extend the substitution for RHS to map the *original* binders+             -- to their floated versions.+             mb_sc_flts :: [Maybe DictId]+             mb_sc_flts = map (lookupVarEnv clone_env) args'+             clone_env  = zipVarEnv sc_args' sc_args_flt+             subst_prs  = (case_bndr, Var case_bndr_flt)+                        : [ (arg, Var sc_flt)+                          | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]+             env_rhs' = env_rhs { se_subst = CoreSubst.extendIdSubstList (se_subst env_rhs) subst_prs+                                , se_interesting = se_interesting env_rhs `extendVarSetList`+                                                   (case_bndr_flt : sc_args_flt) }++       ; (rhs', rhs_uds)   <- specExpr env_rhs' rhs+       ; let scrut_bind    = mkDB (NonRec case_bndr_flt scrut')+             case_bndr_set = unitVarSet case_bndr_flt+             sc_binds      = [(NonRec sc_arg_flt sc_rhs, case_bndr_set)+                             | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ]+             flt_binds     = scrut_bind : sc_binds+             (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds+             all_uds = flt_binds `addDictBinds` free_uds+             alt'    = (con, args', wrapDictBindsE dumped_dbs rhs')+       ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }+  where+    (env_rhs, (case_bndr':args')) = substBndrs env (case_bndr:args)+    sc_args' = filter is_flt_sc_arg args'++    clone_me bndr = do { uniq <- getUniqueM+                       ; return (mkUserLocalOrCoVar occ uniq ty loc) }+       where+         name = idName bndr+         ty   = idType bndr+         occ  = nameOccName name+         loc  = getSrcSpan name++    arg_set = mkVarSet args'+    is_flt_sc_arg var =  isId var+                      && not (isDeadBinder var)+                      && isDictTy var_ty+                      && not (tyCoVarsOfType var_ty `intersectsVarSet` arg_set)+       where+         var_ty = idType var+++specCase env scrut case_bndr alts+  = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts+       ; return (scrut, case_bndr', alts', uds_alts) }+  where+    (env_alt, case_bndr') = substBndr env case_bndr+    spec_alt (con, args, rhs) = do+          (rhs', uds) <- specExpr env_rhs rhs+          let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds+          return ((con, args', wrapDictBindsE dumped_dbs rhs'), free_uds)+        where+          (env_rhs, args') = substBndrs env_alt args++{-+Note [Floating dictionaries out of cases]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   g = \d. case d of { MkD sc ... -> ...(f sc)... }+Naively we can't float d2's binding out of the case expression,+because 'sc' is bound by the case, and that in turn means we can't+specialise f, which seems a pity.++So we invert the case, by floating out a binding+for 'sc_flt' thus:+    sc_flt = case d of { MkD sc ... -> sc }+Now we can float the call instance for 'f'.  Indeed this is just+what'll happen if 'sc' was originally bound with a let binding,+but case is more efficient, and necessary with equalities. So it's+good to work with both.++You might think that this won't make any difference, because the+call instance will only get nuked by the \d.  BUT if 'g' itself is+specialised, then transitively we should be able to specialise f.++In general, given+   case e of cb { MkD sc ... -> ...(f sc)... }+we transform to+   let cb_flt = e+       sc_flt = case cb_flt of { MkD sc ... -> sc }+   in+   case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... }++The "_flt" things are the floated binds; we use the current substitution+to substitute sc -> sc_flt in the RHS++************************************************************************+*                                                                      *+                     Dealing with a binding+*                                                                      *+************************************************************************+-}++specBind :: SpecEnv                     -- Use this for RHSs+         -> CoreBind                    -- Binders are already cloned by cloneBindSM,+                                        -- but RHSs are un-processed+         -> UsageDetails                -- Info on how the scope of the binding+         -> SpecM ([CoreBind],          -- New bindings+                   UsageDetails)        -- And info to pass upstream++-- Returned UsageDetails:+--    No calls for binders of this bind+specBind rhs_env (NonRec fn rhs) body_uds+  = do { (rhs', rhs_uds) <- specExpr rhs_env rhs+       ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds fn rhs++       ; let pairs = spec_defns ++ [(fn', rhs')]+                        -- fn' mentions the spec_defns in its rules,+                        -- so put the latter first++             combined_uds = body_uds1 `plusUDs` rhs_uds++             (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds++             final_binds :: [DictBind]+             -- See Note [From non-recursive to recursive]+             final_binds+               | not (isEmptyBag dump_dbs)+               , not (null spec_defns)+               = [recWithDumpedDicts pairs dump_dbs]+               | otherwise+               = [mkDB $ NonRec b r | (b,r) <- pairs]+                 ++ bagToList dump_dbs++       ; if float_all then+             -- Rather than discard the calls mentioning the bound variables+             -- we float this (dictionary) binding along with the others+              return ([], free_uds `snocDictBinds` final_binds)+         else+             -- No call in final_uds mentions bound variables,+             -- so we can just leave the binding here+              return (map fst final_binds, free_uds) }+++specBind rhs_env (Rec pairs) body_uds+       -- Note [Specialising a recursive group]+  = do { let (bndrs,rhss) = unzip pairs+       ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss+       ; let scope_uds = body_uds `plusUDs` rhs_uds+                       -- Includes binds and calls arising from rhss++       ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs++       ; (bndrs3, spec_defns3, uds3)+             <- if null spec_defns1  -- Common case: no specialisation+                then return (bndrs1, [], uds1)+                else do {            -- Specialisation occurred; do it again+                          (bndrs2, spec_defns2, uds2)+                              <- specDefns rhs_env uds1 (bndrs1 `zip` rhss)+                        ; return (bndrs2, spec_defns2 ++ spec_defns1, uds2) }++       ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs uds3+             final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss')+                                             dumped_dbs++       ; if float_all then+              return ([], final_uds `snocDictBind` final_bind)+         else+              return ([fst final_bind], final_uds) }+++---------------------------+specDefns :: SpecEnv+          -> UsageDetails               -- Info on how it is used in its scope+          -> [(OutId,InExpr)]           -- The things being bound and their un-processed RHS+          -> SpecM ([OutId],            -- Original Ids with RULES added+                    [(OutId,OutExpr)],  -- Extra, specialised bindings+                    UsageDetails)       -- Stuff to fling upwards from the specialised versions++-- Specialise a list of bindings (the contents of a Rec), but flowing usages+-- upwards binding by binding.  Example: { f = ...g ...; g = ...f .... }+-- Then if the input CallDetails has a specialised call for 'g', whose specialisation+-- in turn generates a specialised call for 'f', we catch that in this one sweep.+-- But not vice versa (it's a fixpoint problem).++specDefns _env uds []+  = return ([], [], uds)+specDefns env uds ((bndr,rhs):pairs)+  = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs+       ; (bndr1, spec_defns2, uds2)  <- specDefn env uds1 bndr rhs+       ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) }++---------------------------+specDefn :: SpecEnv+         -> UsageDetails                -- Info on how it is used in its scope+         -> OutId -> InExpr             -- The thing being bound and its un-processed RHS+         -> SpecM (Id,                  -- Original Id with added RULES+                   [(Id,CoreExpr)],     -- Extra, specialised bindings+                   UsageDetails)        -- Stuff to fling upwards from the specialised versions++specDefn env body_uds fn rhs+  = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds+             rules_for_me = idCoreRules fn+       ; (rules, spec_defns, spec_uds) <- specCalls Nothing env rules_for_me+                                                    calls_for_me fn rhs+       ; return ( fn `addIdSpecialisations` rules+                , spec_defns+                , body_uds_without_me `plusUDs` spec_uds) }+                -- It's important that the `plusUDs` is this way+                -- round, because body_uds_without_me may bind+                -- dictionaries that are used in calls_for_me passed+                -- to specDefn.  So the dictionary bindings in+                -- spec_uds may mention dictionaries bound in+                -- body_uds_without_me++---------------------------+specCalls :: Maybe Module      -- Just this_mod  =>  specialising imported fn+                               -- Nothing        =>  specialising local fn+          -> SpecEnv+          -> [CoreRule]        -- Existing RULES for the fn+          -> [CallInfo]+          -> OutId -> InExpr+          -> SpecM SpecInfo    -- New rules, specialised bindings, and usage details++-- This function checks existing rules, and does not create+-- duplicate ones. So the caller does not need to do this filtering.+-- See 'already_covered'++type SpecInfo = ( [CoreRule]       -- Specialisation rules+                , [(Id,CoreExpr)]  -- Specialised definition+                , UsageDetails )   -- Usage details from specialised RHSs++specCalls mb_mod env existing_rules calls_for_me fn rhs+        -- The first case is the interesting one+  |  rhs_tyvars `lengthIs`      n_tyvars -- Rhs of fn's defn has right number of big lambdas+  && rhs_bndrs1 `lengthAtLeast` n_dicts -- and enough dict args+  && notNull calls_for_me               -- And there are some calls to specialise+  && not (isNeverActive (idInlineActivation fn))+        -- Don't specialise NOINLINE things+        -- See Note [Auto-specialisation and RULES]++--   && not (certainlyWillInline (idUnfolding fn))      -- And it's not small+--      See Note [Inline specialisation] for why we do not+--      switch off specialisation for inline functions++  = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $+    foldlM spec_call ([], [], emptyUDs) calls_for_me++  | otherwise   -- No calls or RHS doesn't fit our preconceptions+  = WARN( not (exprIsTrivial rhs) && notNull calls_for_me,+          text "Missed specialisation opportunity for"+                                 <+> ppr fn $$ _trace_doc )+          -- Note [Specialisation shape]+    -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $+    return ([], [], emptyUDs)+  where+    _trace_doc = sep [ ppr rhs_tyvars, ppr n_tyvars+                     , ppr rhs_bndrs, ppr n_dicts+                     , ppr (idInlineActivation fn) ]++    fn_type                 = idType fn+    fn_arity                = idArity fn+    fn_unf                  = realIdUnfolding fn  -- Ignore loop-breaker-ness here+    (tyvars, theta, _)      = tcSplitSigmaTy fn_type+    n_tyvars                = length tyvars+    n_dicts                 = length theta+    inl_prag                = idInlinePragma fn+    inl_act                 = inlinePragmaActivation inl_prag+    is_local                = isLocalId fn++        -- Figure out whether the function has an INLINE pragma+        -- See Note [Inline specialisations]++    (rhs_bndrs, rhs_body)      = collectBindersPushingCo rhs+                                 -- See Note [Account for casts in binding]+    (rhs_tyvars, rhs_bndrs1)   = span isTyVar rhs_bndrs+    (rhs_dict_ids, rhs_bndrs2) = splitAt n_dicts rhs_bndrs1+    body                       = mkLams rhs_bndrs2 rhs_body+                                 -- Glue back on the non-dict lambdas++    in_scope = CoreSubst.substInScope (se_subst env)++    already_covered :: DynFlags -> [CoreRule] -> [CoreExpr] -> Bool+    already_covered dflags new_rules args      -- Note [Specialisations already covered]+       = isJust (lookupRule dflags (in_scope, realIdUnfolding)+                            (const True) fn args+                            (new_rules ++ existing_rules))+         -- NB: we look both in the new_rules (generated by this invocation+         --     of specCalls), and in existing_rules (passed in to specCalls)++    mk_ty_args :: [Maybe Type] -> [TyVar] -> [CoreExpr]+    mk_ty_args [] poly_tvs+      = ASSERT( null poly_tvs ) []+    mk_ty_args (Nothing : call_ts) (poly_tv : poly_tvs)+      = Type (mkTyVarTy poly_tv) : mk_ty_args call_ts poly_tvs+    mk_ty_args (Just ty : call_ts) poly_tvs+      = Type ty : mk_ty_args call_ts poly_tvs+    mk_ty_args (Nothing : _) [] = panic "mk_ty_args"++    ----------------------------------------------------------+        -- Specialise to one particular call pattern+    spec_call :: SpecInfo                         -- Accumulating parameter+              -> CallInfo                         -- Call instance+              -> SpecM SpecInfo+    spec_call spec_acc@(rules_acc, pairs_acc, uds_acc)+              (CI { ci_key = CallKey call_ts, ci_args = call_ds })+      = ASSERT( call_ts `lengthIs` n_tyvars  && call_ds `lengthIs` n_dicts )++        -- Suppose f's defn is  f = /\ a b c -> \ d1 d2 -> rhs+        -- Suppose the call is for f [Just t1, Nothing, Just t3] [dx1, dx2]++        -- Construct the new binding+        --      f1 = SUBST[a->t1,c->t3, d1->d1', d2->d2'] (/\ b -> rhs)+        -- PLUS the rule+        --      RULE "SPEC f" forall b d1' d2'. f b d1' d2' = f1 b+        --      In the rule, d1' and d2' are just wildcards, not used in the RHS+        -- PLUS the usage-details+        --      { d1' = dx1; d2' = dx2 }+        -- where d1', d2' are cloned versions of d1,d2, with the type substitution+        -- applied.  These auxiliary bindings just avoid duplication of dx1, dx2+        --+        -- Note that the substitution is applied to the whole thing.+        -- This is convenient, but just slightly fragile.  Notably:+        --      * There had better be no name clashes in a/b/c+        do { let+                -- poly_tyvars = [b] in the example above+                -- spec_tyvars = [a,c]+                -- ty_args     = [t1,b,t3]+                spec_tv_binds = [(tv,ty) | (tv, Just ty) <- rhs_tyvars `zip` call_ts]+                env1          = extendTvSubstList env spec_tv_binds+                (rhs_env, poly_tyvars) = substBndrs env1+                                            [tv | (tv, Nothing) <- rhs_tyvars `zip` call_ts]++             -- Clone rhs_dicts, including instantiating their types+           ; inst_dict_ids <- mapM (newDictBndr rhs_env) rhs_dict_ids+           ; let (rhs_env2, dx_binds, spec_dict_args)+                            = bindAuxiliaryDicts rhs_env rhs_dict_ids call_ds inst_dict_ids+                 ty_args    = mk_ty_args call_ts poly_tyvars+                 ev_args    = map varToCoreExpr inst_dict_ids  -- ev_args, ev_bndrs:+                 ev_bndrs   = exprsFreeIdsList ev_args         -- See Note [Evidence foralls]+                 rule_args  = ty_args     ++ ev_args+                 rule_bndrs = poly_tyvars ++ ev_bndrs++           ; dflags <- getDynFlags+           ; if already_covered dflags rules_acc rule_args+             then return spec_acc+             else -- pprTrace "spec_call" (vcat [ ppr _call_info, ppr fn, ppr rhs_dict_ids+                  --                           , text "rhs_env2" <+> ppr (se_subst rhs_env2)+                  --                           , ppr dx_binds ]) $+                  do+           {    -- Figure out the type of the specialised function+             let body_ty = applyTypeToArgs rhs fn_type rule_args+                 (lam_args, app_args)           -- Add a dummy argument if body_ty is unlifted+                   | isUnliftedType body_ty     -- C.f. WwLib.mkWorkerArgs+                   , not (isJoinId fn)+                   = (poly_tyvars ++ [voidArgId], poly_tyvars ++ [voidPrimId])+                   | otherwise = (poly_tyvars, poly_tyvars)+                 spec_id_ty = mkLamTypes lam_args body_ty+                 join_arity_change = length app_args - length rule_args+                 spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn+                                 = Just (orig_join_arity + join_arity_change)+                                 | otherwise+                                 = Nothing++           ; spec_f <- newSpecIdSM fn spec_id_ty spec_join_arity+           ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_args body)+           ; this_mod <- getModule+           ; let+                -- The rule to put in the function's specialisation is:+                --      forall b, d1',d2'.  f t1 b t3 d1' d2' = f1 b+                herald = case mb_mod of+                           Nothing        -- Specialising local fn+                               -> text "SPEC"+                           Just this_mod  -- Specialising imported fn+                               -> text "SPEC/" <> ppr this_mod++                rule_name = mkFastString $ showSDoc dflags $+                            herald <+> ftext (occNameFS (getOccName fn))+                                   <+> hsep (map ppr_call_key_ty call_ts)+                            -- This name ends up in interface files, so use occNameString.+                            -- Otherwise uniques end up there, making builds+                            -- less deterministic (See #4012 comment:61 ff)++                rule_wout_eta = mkRule+                                  this_mod+                                  True {- Auto generated -}+                                  is_local+                                  rule_name+                                  inl_act       -- Note [Auto-specialisation and RULES]+                                  (idName fn)+                                  rule_bndrs+                                  rule_args+                                  (mkVarApps (Var spec_f) app_args)++                spec_rule+                  = case isJoinId_maybe fn of+                      Just join_arity -> etaExpandToJoinPointRule join_arity+                                                                  rule_wout_eta+                      Nothing -> rule_wout_eta++                -- Add the { d1' = dx1; d2' = dx2 } usage stuff+                spec_uds = foldr consDictBind rhs_uds dx_binds++                --------------------------------------+                -- Add a suitable unfolding if the spec_inl_prag says so+                -- See Note [Inline specialisations]+                (spec_inl_prag, spec_unf)+                  | not is_local && isStrongLoopBreaker (idOccInfo fn)+                  = (neverInlinePragma, noUnfolding)+                        -- See Note [Specialising imported functions] in OccurAnal++                  | InlinePragma { inl_inline = Inlinable } <- inl_prag+                  = (inl_prag { inl_inline = NoUserInline }, noUnfolding)++                  | otherwise+                  = (inl_prag, specUnfolding dflags poly_tyvars spec_app+                                             arity_decrease fn_unf)++                arity_decrease = length spec_dict_args+                spec_app e = (e `mkApps` ty_args) `mkApps` spec_dict_args++                --------------------------------------+                -- Adding arity information just propagates it a bit faster+                --      See Note [Arity decrease] in Simplify+                -- Copy InlinePragma information from the parent Id.+                -- So if f has INLINE[1] so does spec_f+                spec_f_w_arity = spec_f `setIdArity`      max 0 (fn_arity - n_dicts)+                                        `setInlinePragma` spec_inl_prag+                                        `setIdUnfolding`  spec_unf+                                        `asJoinId_maybe`  spec_join_arity++           ; return ( spec_rule                  : rules_acc+                    , (spec_f_w_arity, spec_rhs) : pairs_acc+                    , spec_uds           `plusUDs` uds_acc+                    ) } }++{- Note [Account for casts in binding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f :: Eq a => a -> IO ()+   {-# INLINABLE f+       StableUnf = (/\a \(d:Eq a) (x:a). blah) |> g+     #-}+   f = ...++In f's stable unfolding we have done some modest simplification which+has pushed the cast to the outside.  (I wonder if this is the Right+Thing, but it's what happens now; see SimplUtils Note [Casts and+lambdas].)  Now that stable unfolding must be specialised, so we want+to push the cast back inside. It would be terrible if the cast+defeated specialisation!  Hence the use of collectBindersPushingCo.++Note [Evidence foralls]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose (#12212) that we are specialising+   f :: forall a b. (Num a, F a ~ F b) => blah+with a=b=Int. Then the RULE will be something like+   RULE forall (d:Num Int) (g :: F Int ~ F Int).+        f Int Int d g = f_spec+But both varToCoreExpr (when constructing the LHS args), and the+simplifier (when simplifying the LHS args), will transform to+   RULE forall (d:Num Int) (g :: F Int ~ F Int).+        f Int Int d <F Int> = f_spec+by replacing g with Refl.  So now 'g' is unbound, which results in a later+crash. So we use Refl right off the bat, and do not forall-quantify 'g':+ * varToCoreExpr generates a Refl+ * exprsFreeIdsList returns the Ids bound by the args,+   which won't include g++You might wonder if this will match as often, but the simplifier replaces+complicated Refl coercions with Refl pretty aggressively.++Note [Orphans and auto-generated rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we specialise an INLINABLE function, or when we have+-fspecialise-aggressively, we auto-generate RULES that are orphans.+We don't want to warn about these, or we'd generate a lot of warnings.+Thus, we only warn about user-specified orphan rules.++Indeed, we don't even treat the module as an orphan module if it has+auto-generated *rule* orphans.  Orphan modules are read every time we+compile, so they are pretty obtrusive and slow down every compilation,+even non-optimised ones.  (Reason: for type class instances it's a+type correctness issue.)  But specialisation rules are strictly for+*optimisation* only so it's fine not to read the interface.++What this means is that a SPEC rules from auto-specialisation in+module M will be used in other modules only if M.hi has been read for+some other reason, which is actually pretty likely.+-}++bindAuxiliaryDicts+        :: SpecEnv+        -> [DictId] -> [CoreExpr]   -- Original dict bndrs, and the witnessing expressions+        -> [DictId]                 -- A cloned dict-id for each dict arg+        -> (SpecEnv,                -- Substitute for all orig_dicts+            [DictBind],             -- Auxiliary dict bindings+            [CoreExpr])             -- Witnessing expressions (all trivial)+-- Bind any dictionary arguments to fresh names, to preserve sharing+bindAuxiliaryDicts env@(SE { se_subst = subst, se_interesting = interesting })+                   orig_dict_ids call_ds inst_dict_ids+  = (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`+                                     (orig_dict_ids `zip` spec_dict_args)+                                  `CoreSubst.extendInScopeList` dx_ids+               , se_interesting = interesting `unionVarSet` interesting_dicts }++    dx_ids = [dx_id | (NonRec dx_id _, _) <- dx_binds]+    interesting_dicts = mkVarSet [ dx_id | (NonRec dx_id dx, _) <- dx_binds+                                 , interestingDict env dx ]+                  -- See Note [Make the new dictionaries interesting]++    go :: [CoreExpr] -> [CoreBndr] -> ([DictBind], [CoreExpr])+    go [] _  = ([], [])+    go (dx:dxs) (dx_id:dx_ids)+      | exprIsTrivial dx = (dx_binds,                          dx        : args)+      | otherwise        = (mkDB (NonRec dx_id dx) : dx_binds, Var dx_id : args)+      where+        (dx_binds, args) = go dxs dx_ids+             -- In the first case extend the substitution but not bindings;+             -- in the latter extend the bindings but not the substitution.+             -- For the former, note that we bind the *original* dict in the substitution,+             -- overriding any d->dx_id binding put there by substBndrs+    go _ _ = pprPanic "bindAuxiliaryDicts" (ppr orig_dict_ids $$ ppr call_ds $$ ppr inst_dict_ids)++{-+Note [Make the new dictionaries interesting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Important!  We're going to substitute dx_id1 for d+and we want it to look "interesting", else we won't gather *any*+consequential calls. E.g.+    f d = ...g d....+If we specialise f for a call (f (dfun dNumInt)), we'll get+a consequent call (g d') with an auxiliary definition+    d' = df dNumInt+We want that consequent call to look interesting+++Note [From non-recursive to recursive]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Even in the non-recursive case, if any dict-binds depend on 'fn' we might+have built a recursive knot++      f a d x = <blah>+      MkUD { ud_binds = NonRec d7  (MkD ..f..)+           , ud_calls = ...(f T d7)... }++The we generate++     Rec { fs x = <blah>[T/a, d7/d]+           f a d x = <blah>+               RULE f T _ = fs+           d7 = ...f... }++Here the recursion is only through the RULE.++However we definitely should /not/ make the Rec in this wildly common+case:+      d = ...+      MkUD { ud_binds = NonRec d7 (...d...)+           , ud_calls = ...(f T d7)... }++Here we want simply to add d to the floats, giving+      MkUD { ud_binds = NonRec d (...)+                        NonRec d7 (...d...)+           , ud_calls = ...(f T d7)... }++In general, we need only make this Rec if+  - there are some specialisations (spec_binds non-empty)+  - there are some dict_binds that depend on f (dump_dbs non-empty)++Note [Avoiding loops]+~~~~~~~~~~~~~~~~~~~~~+When specialising /dictionary functions/ we must be very careful to+avoid building loops. Here is an example that bit us badly: #3591++     class Eq a => C a+     instance Eq [a] => C [a]++This translates to+     dfun :: Eq [a] -> C [a]+     dfun a d = MkD a d (meth d)++     d4 :: Eq [T] = <blah>+     d2 ::  C [T] = dfun T d4+     d1 :: Eq [T] = $p1 d2+     d3 ::  C [T] = dfun T d1++None of these definitions is recursive. What happened was that we+generated a specialisation:++     RULE forall d. dfun T d = dT  :: C [T]+     dT = (MkD a d (meth d)) [T/a, d1/d]+        = MkD T d1 (meth d1)++But now we use the RULE on the RHS of d2, to get++    d2 = dT = MkD d1 (meth d1)+    d1 = $p1 d2++and now d1 is bottom!  The problem is that when specialising 'dfun' we+should first dump "below" the binding all floated dictionary bindings+that mention 'dfun' itself.  So d2 and d3 (and hence d1) must be+placed below 'dfun', and thus unavailable to it when specialising+'dfun'.  That in turn means that the call (dfun T d1) must be+discarded.  On the other hand, the call (dfun T d4) is fine, assuming+d4 doesn't mention dfun.++Solution:+  Discard all calls that mention dictionaries that depend+  (directly or indirectly) on the dfun we are specialising.+  This is done by 'filterCalls'++--------------+Here's another example, this time for an imported dfun, so the call+to filterCalls is in specImports (#13429). Suppose we have+  class Monoid v => C v a where ...++We start with a call+   f @ [Integer] @ Integer $fC[]Integer++Specialising call to 'f' gives dict bindings+   $dMonoid_1 :: Monoid [Integer]+   $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer++   $dC_1 :: C [Integer] (Node [Integer] Integer)+   $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1++...plus a recursive call to+   f @ [Integer] @ (Node [Integer] Integer) $dC_1++Specialising that call gives+   $dMonoid_2  :: Monoid [Integer]+   $dMonoid_2  = M.$p1C @ [Integer] $dC_1++   $dC_2 :: C [Integer] (Node [Integer] Integer)+   $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2++Now we have two calls to the imported function+  M.$fCvNode :: Monoid v => C v a+  M.$fCvNode @v @a m = C m some_fun++But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2)+for specialisation, else we get:++  $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1+  $dMonoid_2 = M.$p1C @ [Integer] $dC_1+  $s$fCvNode = C $dMonoid_2 ...+    RULE M.$fCvNode [Integer] _ _ = $s$fCvNode++Now use the rule to rewrite the call in the RHS of $dC_1+and we get a loop!++--------------+Here's yet another example++  class C a where { foo,bar :: [a] -> [a] }++  instance C Int where+     foo x = r_bar x+     bar xs = reverse xs++  r_bar :: C a => [a] -> [a]+  r_bar xs = bar (xs ++ xs)++That translates to:++    r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)++    Rec { $fCInt :: C Int = MkC foo_help reverse+          foo_help (xs::[Int]) = r_bar Int $fCInt xs }++The call (r_bar $fCInt) mentions $fCInt,+                        which mentions foo_help,+                        which mentions r_bar+But we DO want to specialise r_bar at Int:++    Rec { $fCInt :: C Int = MkC foo_help reverse+          foo_help (xs::[Int]) = r_bar Int $fCInt xs++          r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)+            RULE r_bar Int _ = r_bar_Int++          r_bar_Int xs = bar Int $fCInt (xs ++ xs)+           }++Note that, because of its RULE, r_bar joins the recursive+group.  (In this case it'll unravel a short moment later.)+++Note [Specialising a recursive group]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    let rec { f x = ...g x'...+            ; g y = ...f y'.... }+    in f 'a'+Here we specialise 'f' at Char; but that is very likely to lead to+a specialisation of 'g' at Char.  We must do the latter, else the+whole point of specialisation is lost.++But we do not want to keep iterating to a fixpoint, because in the+presence of polymorphic recursion we might generate an infinite number+of specialisations.++So we use the following heuristic:+  * Arrange the rec block in dependency order, so far as possible+    (the occurrence analyser already does this)++  * Specialise it much like a sequence of lets++  * Then go through the block a second time, feeding call-info from+    the RHSs back in the bottom, as it were++In effect, the ordering maxmimises the effectiveness of each sweep,+and we do just two sweeps.   This should catch almost every case of+monomorphic recursion -- the exception could be a very knotted-up+recursion with multiple cycles tied up together.++This plan is implemented in the Rec case of specBindItself.++Note [Specialisations already covered]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We obviously don't want to generate two specialisations for the same+argument pattern.  There are two wrinkles++1. We do the already-covered test in specDefn, not when we generate+the CallInfo in mkCallUDs.  We used to test in the latter place, but+we now iterate the specialiser somewhat, and the Id at the call site+might therefore not have all the RULES that we can see in specDefn++2. What about two specialisations where the second is an *instance*+of the first?  If the more specific one shows up first, we'll generate+specialisations for both.  If the *less* specific one shows up first,+we *don't* currently generate a specialisation for the more specific+one.  (See the call to lookupRule in already_covered.)  Reasons:+  (a) lookupRule doesn't say which matches are exact (bad reason)+  (b) if the earlier specialisation is user-provided, it's+      far from clear that we should auto-specialise further++Note [Auto-specialisation and RULES]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+   g :: Num a => a -> a+   g = ...++   f :: (Int -> Int) -> Int+   f w = ...+   {-# RULE f g = 0 #-}++Suppose that auto-specialisation makes a specialised version of+g::Int->Int That version won't appear in the LHS of the RULE for f.+So if the specialisation rule fires too early, the rule for f may+never fire.++It might be possible to add new rules, to "complete" the rewrite system.+Thus when adding+        RULE forall d. g Int d = g_spec+also add+        RULE f g_spec = 0++But that's a bit complicated.  For now we ask the programmer's help,+by *copying the INLINE activation pragma* to the auto-specialised+rule.  So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule+will also not be active until phase 2.  And that's what programmers+should jolly well do anyway, even aside from specialisation, to ensure+that g doesn't inline too early.++This in turn means that the RULE would never fire for a NOINLINE+thing so not much point in generating a specialisation at all.++Note [Specialisation shape]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We only specialise a function if it has visible top-level lambdas+corresponding to its overloading.  E.g. if+        f :: forall a. Eq a => ....+then its body must look like+        f = /\a. \d. ...++Reason: when specialising the body for a call (f ty dexp), we want to+substitute dexp for d, and pick up specialised calls in the body of f.++This doesn't always work.  One example I came across was this:+        newtype Gen a = MkGen{ unGen :: Int -> a }++        choose :: Eq a => a -> Gen a+        choose n = MkGen (\r -> n)++        oneof = choose (1::Int)++It's a silly example, but we get+        choose = /\a. g `cast` co+where choose doesn't have any dict arguments.  Thus far I have not+tried to fix this (wait till there's a real example).++Mind you, then 'choose' will be inlined (since RHS is trivial) so+it doesn't matter.  This comes up with single-method classes++   class C a where { op :: a -> a }+   instance C a => C [a] where ....+==>+   $fCList :: C a => C [a]+   $fCList = $copList |> (...coercion>...)+   ....(uses of $fCList at particular types)...++So we suppress the WARN if the rhs is trivial.++Note [Inline specialisations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is what we do with the InlinePragma of the original function+  * Activation/RuleMatchInfo: both transferred to the+                              specialised function+  * InlineSpec:+       (a) An INLINE pragma is transferred+       (b) An INLINABLE pragma is *not* transferred++Why (a): transfer INLINE pragmas? The point of INLINE was precisely to+specialise the function at its call site, and arguably that's not so+important for the specialised copies.  BUT *pragma-directed*+specialisation now takes place in the typechecker/desugarer, with+manually specified INLINEs.  The specialisation here is automatic.+It'd be very odd if a function marked INLINE was specialised (because+of some local use), and then forever after (including importing+modules) the specialised version wasn't INLINEd.  After all, the+programmer said INLINE!++You might wonder why we specialise INLINE functions at all.  After+all they should be inlined, right?  Two reasons:++ * Even INLINE functions are sometimes not inlined, when they aren't+   applied to interesting arguments.  But perhaps the type arguments+   alone are enough to specialise (even though the args are too boring+   to trigger inlining), and it's certainly better to call the+   specialised version.++ * The RHS of an INLINE function might call another overloaded function,+   and we'd like to generate a specialised version of that function too.+   This actually happens a lot. Consider+      replicateM_ :: (Monad m) => Int -> m a -> m ()+      {-# INLINABLE replicateM_ #-}+      replicateM_ d x ma = ...+   The strictness analyser may transform to+      replicateM_ :: (Monad m) => Int -> m a -> m ()+      {-# INLINE replicateM_ #-}+      replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma++      $wreplicateM_ :: (Monad m) => Int# -> m a -> m ()+      {-# INLINABLE $wreplicateM_ #-}+      $wreplicateM_ = ...+   Now an importing module has a specialised call to replicateM_, say+   (replicateM_ dMonadIO).  We certainly want to specialise $wreplicateM_!+   This particular example had a huge effect on the call to replicateM_+   in nofib/shootout/n-body.++Why (b): discard INLINABLE pragmas? See #4874 for persuasive examples.+Suppose we have+    {-# INLINABLE f #-}+    f :: Ord a => [a] -> Int+    f xs = letrec f' = ...f'... in f'+Then, when f is specialised and optimised we might get+    wgo :: [Int] -> Int#+    wgo = ...wgo...+    f_spec :: [Int] -> Int+    f_spec xs = case wgo xs of { r -> I# r }+and we clearly want to inline f_spec at call sites.  But if we still+have the big, un-optimised of f (albeit specialised) captured in an+INLINABLE pragma for f_spec, we won't get that optimisation.++So we simply drop INLINABLE pragmas when specialising. It's not really+a complete solution; ignoring specialisation for now, INLINABLE functions+don't get properly strictness analysed, for example. But it works well+for examples involving specialisation, which is the dominant use of+INLINABLE.  See #4874.+++************************************************************************+*                                                                      *+\subsubsection{UsageDetails and suchlike}+*                                                                      *+************************************************************************+-}++data UsageDetails+  = MkUD {+      ud_binds :: !(Bag DictBind),+               -- See Note [Floated dictionary bindings]+               -- The order is important;+               -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1+               -- (Remember, Bags preserve order in GHC.)++      ud_calls :: !CallDetails++      -- INVARIANT: suppose bs = bindersOf ud_binds+      -- Then 'calls' may *mention* 'bs',+      -- but there should be no calls *for* bs+    }++-- | A 'DictBind' is a binding along with a cached set containing its free+-- variables (both type variables and dictionaries)+type DictBind = (CoreBind, VarSet)++{- Note [Floated dictionary bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We float out dictionary bindings for the reasons described under+"Dictionary floating" above.  But not /just/ dictionary bindings.+Consider++   f :: Eq a => blah+   f a d = rhs++   $c== :: T -> T -> Bool+   $c== x y = ...++   $df :: Eq T+   $df = Eq $c== ...++   gurgle = ...(f @T $df)...++We gather the call info for (f @T $df), and we don't want to drop it+when we come across the binding for $df.  So we add $df to the floats+and continue.  But then we have to add $c== to the floats, and so on.+These all float above the binding for 'f', and and now we can+successfully specialise 'f'.++So the DictBinds in (ud_binds :: Bag DictBind) may contain+non-dictionary bindings too.+-}++instance Outputable UsageDetails where+  ppr (MkUD { ud_binds = dbs, ud_calls = calls })+        = text "MkUD" <+> braces (sep (punctuate comma+                [text "binds" <+> equals <+> ppr dbs,+                 text "calls" <+> equals <+> ppr calls]))++emptyUDs :: UsageDetails+emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv }++------------------------------------------------------------+type CallDetails  = DIdEnv CallInfoSet+  -- The order of specialized binds and rules depends on how we linearize+  -- CallDetails, so to get determinism we must use a deterministic set here.+  -- See Note [Deterministic UniqFM] in UniqDFM++data CallInfoSet = CIS Id (Bag CallInfo)+  -- The list of types and dictionaries is guaranteed to+  -- match the type of f+  -- The Bag may contain duplicate calls (i.e. f @T and another f @T)+  -- These dups are eliminated by already_covered in specCalls++data CallInfo+  = CI { ci_key  :: CallKey     -- Type arguments+       , ci_args :: [DictExpr]  -- Dictionary arguments+       , ci_fvs  :: VarSet      -- Free vars of the ci_key and ci_args+                                -- call (including tyvars)+                                -- [*not* include the main id itself, of course]+    }++newtype CallKey   = CallKey [Maybe Type]+  -- Nothing => unconstrained type argument++type DictExpr = CoreExpr++ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet+ciSetFilter p (CIS id a) = CIS id (filterBag p a)++instance Outputable CallInfoSet where+  ppr (CIS fn map) = hang (text "CIS" <+> ppr fn)+                        2 (ppr map)++pprCallInfo :: Id -> CallInfo -> SDoc+pprCallInfo fn (CI { ci_key = key })+  = ppr fn <+> ppr key++ppr_call_key_ty :: Maybe Type -> SDoc+ppr_call_key_ty Nothing   = char '_'+ppr_call_key_ty (Just ty) = char '@' <+> pprParendType ty++instance Outputable CallKey where+  ppr (CallKey ts) = brackets (fsep (map ppr_call_key_ty ts))++instance Outputable CallInfo where+  ppr (CI { ci_key = key, ci_args = args, ci_fvs = fvs })+    = text "CI" <> braces (hsep [ ppr key, ppr args, ppr fvs ])++unionCalls :: CallDetails -> CallDetails -> CallDetails+unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2++unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet+unionCallInfoSet (CIS f calls1) (CIS _ calls2) =+  CIS f (calls1 `unionBags` calls2)++callDetailsFVs :: CallDetails -> VarSet+callDetailsFVs calls =+  nonDetFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls+  -- It's OK to use nonDetFoldUDFM here because we forget the ordering+  -- immediately by converting to a nondeterministic set.++callInfoFVs :: CallInfoSet -> VarSet+callInfoFVs (CIS _ call_info) =+  foldrBag (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info++------------------------------------------------------------+singleCall :: Id -> [Maybe Type] -> [DictExpr] -> UsageDetails+singleCall id tys dicts+  = MkUD {ud_binds = emptyBag,+          ud_calls = unitDVarEnv id $ CIS id $+                     unitBag (CI { ci_key = CallKey tys+                                 , ci_args = dicts+                                 , ci_fvs  = call_fvs }) }+  where+    call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs+    tys_fvs  = tyCoVarsOfTypes (catMaybes tys)+        -- The type args (tys) are guaranteed to be part of the dictionary+        -- types, because they are just the constrained types,+        -- and the dictionary is therefore sure to be bound+        -- inside the binding for any type variables free in the type;+        -- hence it's safe to neglect tyvars free in tys when making+        -- the free-var set for this call+        -- BUT I don't trust this reasoning; play safe and include tys_fvs+        --+        -- We don't include the 'id' itself.++mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails+mkCallUDs env f args+  = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ])+    res+  where+    res = mkCallUDs' env f args++mkCallUDs' env f args+  | not (want_calls_for f)  -- Imported from elsewhere+  || null theta             -- Not overloaded+  = emptyUDs++  |  not (all type_determines_value theta)+  || not (spec_tys `lengthIs` n_tyvars)+  || not ( dicts   `lengthIs` n_dicts)+  || not (any (interestingDict env) dicts)    -- Note [Interesting dictionary arguments]+  -- See also Note [Specialisations already covered]+  = -- pprTrace "mkCallUDs: discarding" _trace_doc+    emptyUDs    -- Not overloaded, or no specialisation wanted++  | otherwise+  = -- pprTrace "mkCallUDs: keeping" _trace_doc+    singleCall f spec_tys dicts+  where+    _trace_doc = vcat [ppr f, ppr args, ppr n_tyvars, ppr n_dicts+                      , ppr (map (interestingDict env) dicts)]+    (tyvars, theta, _)      = tcSplitSigmaTy (idType f)+    constrained_tyvars      = tyCoVarsOfTypes theta+    n_tyvars                = length tyvars+    n_dicts                 = length theta++    spec_tys = [mk_spec_ty tv ty | (tv, ty) <- tyvars `type_zip` args]+    dicts    = [dict_expr | (_, dict_expr) <- theta `zip` (drop n_tyvars args)]++    -- ignores Coercion arguments+    type_zip :: [TyVar] -> [CoreExpr] -> [(TyVar, Type)]+    type_zip tvs      (Coercion _ : args) = type_zip tvs args+    type_zip (tv:tvs) (Type ty : args)    = (tv, ty) : type_zip tvs args+    type_zip _        _                   = []++    mk_spec_ty tyvar ty+        | tyvar `elemVarSet` constrained_tyvars = Just ty+        | otherwise                             = Nothing++    want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f))+         -- For imported things, we gather call instances if+         -- there is an unfolding that we could in principle specialise+         -- We might still decide not to use it (consulting dflags)+         -- in specImports+         -- Use 'realIdUnfolding' to ignore the loop-breaker flag!++    type_determines_value pred    -- See Note [Type determines value]+        = case classifyPredType pred of+            ClassPred cls _ -> not (isIPClass cls)  -- Superclasses can't be IPs+            EqPred {}       -> True+            IrredPred {}    -> True   -- Things like (D []) where D is a+                                      -- Constraint-ranged family; #7785+            ForAllPred {}   -> True++{-+Note [Type determines value]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Only specialise if all overloading is on non-IP *class* params,+because these are the ones whose *type* determines their *value*.  In+parrticular, with implicit params, the type args *don't* say what the+value of the implicit param is!  See #7101++However, consider+         type family D (v::*->*) :: Constraint+         type instance D [] = ()+         f :: D v => v Char -> Int+If we see a call (f "foo"), we'll pass a "dictionary"+  () |> (g :: () ~ D [])+and it's good to specialise f at this dictionary.++So the question is: can an implicit parameter "hide inside" a+type-family constraint like (D a).  Well, no.  We don't allow+        type instance D Maybe = ?x:Int+Hence the IrredPred case in type_determines_value.+See #7785.++Note [Interesting dictionary arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+         \a.\d:Eq a.  let f = ... in ...(f d)...+There really is not much point in specialising f wrt the dictionary d,+because the code for the specialised f is not improved at all, because+d is lambda-bound.  We simply get junk specialisations.++What is "interesting"?  Just that it has *some* structure.  But what about+variables?++ * A variable might be imported, in which case its unfolding+   will tell us whether it has useful structure++ * Local variables are cloned on the way down (to avoid clashes when+   we float dictionaries), and cloning drops the unfolding+   (cloneIdBndr).  Moreover, we make up some new bindings, and it's a+   nuisance to give them unfoldings.  So we keep track of the+   "interesting" dictionaries as a VarSet in SpecEnv.+   We have to take care to put any new interesting dictionary+   bindings in the set.++We accidentally lost accurate tracking of local variables for a long+time, because cloned variables don't have unfoldings. But makes a+massive difference in a few cases, eg #5113. For nofib as a+whole it's only a small win: 2.2% improvement in allocation for ansi,+1.2% for bspt, but mostly 0.0!  Average 0.1% increase in binary size.+-}++interestingDict :: SpecEnv -> CoreExpr -> Bool+-- A dictionary argument is interesting if it has *some* structure+-- NB: "dictionary" arguments include constraints of all sorts,+--     including equality constraints; hence the Coercion case+interestingDict env (Var v) =  hasSomeUnfolding (idUnfolding v)+                            || isDataConWorkId v+                            || v `elemVarSet` se_interesting env+interestingDict _ (Type _)                = False+interestingDict _ (Coercion _)            = False+interestingDict env (App fn (Type _))     = interestingDict env fn+interestingDict env (App fn (Coercion _)) = interestingDict env fn+interestingDict env (Tick _ a)            = interestingDict env a+interestingDict env (Cast e _)            = interestingDict env e+interestingDict _ _                       = True++plusUDs :: UsageDetails -> UsageDetails -> UsageDetails+plusUDs (MkUD {ud_binds = db1, ud_calls = calls1})+        (MkUD {ud_binds = db2, ud_calls = calls2})+  = MkUD { ud_binds = db1    `unionBags`   db2+         , ud_calls = calls1 `unionCalls`  calls2 }++-----------------------------+_dictBindBndrs :: Bag DictBind -> [Id]+_dictBindBndrs dbs = foldrBag ((++) . bindersOf . fst) [] dbs++-- | Construct a 'DictBind' from a 'CoreBind'+mkDB :: CoreBind -> DictBind+mkDB bind = (bind, bind_fvs bind)++-- | Identify the free variables of a 'CoreBind'+bind_fvs :: CoreBind -> VarSet+bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)+bind_fvs (Rec prs)         = foldl' delVarSet rhs_fvs bndrs+                           where+                             bndrs = map fst prs+                             rhs_fvs = unionVarSets (map pair_fvs prs)++pair_fvs :: (Id, CoreExpr) -> VarSet+pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs+                       `unionVarSet` idFreeVars bndr+        -- idFreeVars: don't forget variables mentioned in+        -- the rules of the bndr.  C.f. OccAnal.addRuleUsage+        -- Also tyvars mentioned in its type; they may not appear+        -- in the RHS+        --      type T a = Int+        --      x :: T a = 3+  where+    interesting :: InterestingVarFun+    interesting v = isLocalVar v || (isId v && isDFunId v)+        -- Very important: include DFunIds /even/ if it is imported+        -- Reason: See Note [Avoiding loops], the second exmaple+        --         involving an imported dfun.  We must know whether+        --         a dictionary binding depends on an imported dfun,+        --         in case we try to specialise that imported dfun+        --         #13429 illustrates++-- | Flatten a set of "dumped" 'DictBind's, and some other binding+-- pairs, into a single recursive binding.+recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind ->DictBind+recWithDumpedDicts pairs dbs+  = (Rec bindings, fvs)+  where+    (bindings, fvs) = foldrBag add+                               ([], emptyVarSet)+                               (dbs `snocBag` mkDB (Rec pairs))+    add (NonRec b r, fvs') (pairs, fvs) =+      ((b,r) : pairs, fvs `unionVarSet` fvs')+    add (Rec prs1,   fvs') (pairs, fvs) =+      (prs1 ++ pairs, fvs `unionVarSet` fvs')++snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails+-- Add ud_binds to the tail end of the bindings in uds+snocDictBinds uds dbs+  = uds { ud_binds = ud_binds uds `unionBags` listToBag dbs }++consDictBind :: DictBind -> UsageDetails -> UsageDetails+consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds }++addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails+addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds }++snocDictBind :: UsageDetails -> DictBind -> UsageDetails+snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind }++wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]+wrapDictBinds dbs binds+  = foldrBag add binds dbs+  where+    add (bind,_) binds = bind : binds++wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr+wrapDictBindsE dbs expr+  = foldrBag add expr dbs+  where+    add (bind,_) expr = Let bind expr++----------------------+dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind)+-- Used at a lambda or case binder; just dump anything mentioning the binder+dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })+  | null bndrs = (uds, emptyBag)  -- Common in case alternatives+  | otherwise  = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $+                 (free_uds, dump_dbs)+  where+    free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }+    bndr_set = mkVarSet bndrs+    (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set+    free_calls = deleteCallsMentioning dump_set $   -- Drop calls mentioning bndr_set on the floor+                 deleteCallsFor bndrs orig_calls    -- Discard calls for bndr_set; there should be+                                                    -- no calls for any of the dicts in dump_dbs++dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)+-- Used at a let(rec) binding.+-- We return a boolean indicating whether the binding itself is mentioned,+-- directly or indirectly, by any of the ud_calls; in that case we want to+-- float the binding itself;+-- See Note [Floated dictionary bindings]+dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })+  = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $+    (free_uds, dump_dbs, float_all)+  where+    free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }+    bndr_set = mkVarSet bndrs+    (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set+    free_calls = deleteCallsFor bndrs orig_calls+    float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls++callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])+callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })+  = -- pprTrace ("callsForMe")+    --          (vcat [ppr fn,+    --                 text "Orig dbs ="     <+> ppr (_dictBindBndrs orig_dbs),+    --                 text "Orig calls ="   <+> ppr orig_calls,+    --                 text "Dep set ="      <+> ppr dep_set,+    --                 text "Calls for me =" <+> ppr calls_for_me]) $+    (uds_without_me, calls_for_me)+  where+    uds_without_me = MkUD { ud_binds = orig_dbs+                          , ud_calls = delDVarEnv orig_calls fn }+    calls_for_me = case lookupDVarEnv orig_calls fn of+                        Nothing -> []+                        Just cis -> filterCalls cis orig_dbs+         -- filterCalls: drop calls that (directly or indirectly)+         -- refer to fn.  See Note [Avoiding loops]++----------------------+filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]+-- See Note [Avoiding loops]+filterCalls (CIS fn call_bag) dbs+  = filter ok_call (bagToList call_bag)+  where+    dump_set = foldlBag go (unitVarSet fn) dbs+      -- This dump-set could also be computed by splitDictBinds+      --   (_,_,dump_set) = splitDictBinds dbs {fn}+      -- But this variant is shorter++    go so_far (db,fvs) | fvs `intersectsVarSet` so_far+                       = extendVarSetList so_far (bindersOf db)+                       | otherwise = so_far++    ok_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` dump_set)++----------------------+splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)+-- splitDictBinds dbs bndrs returns+--   (free_dbs, dump_dbs, dump_set)+-- where+--   * dump_dbs depends, transitively on bndrs+--   * free_dbs does not depend on bndrs+--   * dump_set = bndrs `union` bndrs(dump_dbs)+splitDictBinds dbs bndr_set+   = foldlBag split_db (emptyBag, emptyBag, bndr_set) dbs+                -- Important that it's foldl not foldr;+                -- we're accumulating the set of dumped ids in dump_set+   where+    split_db (free_dbs, dump_dbs, dump_idset) db@(bind, fvs)+        | dump_idset `intersectsVarSet` fvs     -- Dump it+        = (free_dbs, dump_dbs `snocBag` db,+           extendVarSetList dump_idset (bindersOf bind))++        | otherwise     -- Don't dump it+        = (free_dbs `snocBag` db, dump_dbs, dump_idset)+++----------------------+deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails+-- Remove calls *mentioning* bs in any way+deleteCallsMentioning bs calls+  = mapDVarEnv (ciSetFilter keep_call) calls+  where+    keep_call (CI { ci_fvs = fvs }) = not (fvs `intersectsVarSet` bs)++deleteCallsFor :: [Id] -> CallDetails -> CallDetails+-- Remove calls *for* bs+deleteCallsFor bs calls = delDVarEnvList calls bs++{-+************************************************************************+*                                                                      *+\subsubsection{Boring helper functions}+*                                                                      *+************************************************************************+-}++newtype SpecM a = SpecM (State SpecState a)++data SpecState = SpecState {+                     spec_uniq_supply :: UniqSupply,+                     spec_module :: Module,+                     spec_dflags :: DynFlags+                 }++instance Functor SpecM where+    fmap = liftM++instance Applicative SpecM where+    pure x = SpecM $ return x+    (<*>) = ap++instance Monad SpecM where+    SpecM x >>= f = SpecM $ do y <- x+                               case f y of+                                   SpecM z ->+                                       z+#if !MIN_VERSION_base(4,13,0)+    fail = MonadFail.fail+#endif++instance MonadFail.MonadFail SpecM where+   fail str = SpecM $ error str++instance MonadUnique SpecM where+    getUniqueSupplyM+        = SpecM $ do st <- get+                     let (us1, us2) = splitUniqSupply $ spec_uniq_supply st+                     put $ st { spec_uniq_supply = us2 }+                     return us1++    getUniqueM+        = SpecM $ do st <- get+                     let (u,us') = takeUniqFromSupply $ spec_uniq_supply st+                     put $ st { spec_uniq_supply = us' }+                     return u++instance HasDynFlags SpecM where+    getDynFlags = SpecM $ liftM spec_dflags get++instance HasModule SpecM where+    getModule = SpecM $ liftM spec_module get++runSpecM :: DynFlags -> Module -> SpecM a -> CoreM a+runSpecM dflags this_mod (SpecM spec)+    = do us <- getUniqueSupplyM+         let initialState = SpecState {+                                spec_uniq_supply = us,+                                spec_module = this_mod,+                                spec_dflags = dflags+                            }+         return $ evalState spec initialState++mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)+mapAndCombineSM _ []     = return ([], emptyUDs)+mapAndCombineSM f (x:xs) = do (y, uds1) <- f x+                              (ys, uds2) <- mapAndCombineSM f xs+                              return (y:ys, uds1 `plusUDs` uds2)++extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv+extendTvSubstList env tv_binds+  = env { se_subst = CoreSubst.extendTvSubstList (se_subst env) tv_binds }++substTy :: SpecEnv -> Type -> Type+substTy env ty = CoreSubst.substTy (se_subst env) ty++substCo :: SpecEnv -> Coercion -> Coercion+substCo env co = CoreSubst.substCo (se_subst env) co++substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr)+substBndr env bs = case CoreSubst.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+                      (subst', bs') -> (env { se_subst = subst' }, bs')++cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind)+-- Clone the binders of the bind; return new bind with the cloned binders+-- Return the substitution to use for RHSs, and the one to use for the body+cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs)+  = do { us <- getUniqueSupplyM+       ; let (subst', bndr') = CoreSubst.cloneIdBndr subst us bndr+             interesting' | interestingDict env rhs+                          = interesting `extendVarSet` bndr'+                          | otherwise = interesting+       ; return (env, env { se_subst = subst', se_interesting = interesting' }+                , NonRec bndr' rhs) }++cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs)+  = do { us <- getUniqueSupplyM+       ; let (subst', bndrs') = CoreSubst.cloneRecIdBndrs subst us (map fst pairs)+             env' = env { se_subst = subst'+                        , se_interesting = interesting `extendVarSetList`+                                           [ v | (v,r) <- pairs, interestingDict env r ] }+       ; return (env', env', Rec (bndrs' `zip` map snd pairs)) }++newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr+-- Make up completely fresh binders for the dictionaries+-- Their bindings are going to float outwards+newDictBndr env b = do { uniq <- getUniqueM+                       ; let n   = idName b+                             ty' = substTy env (idType b)+                       ; return (mkUserLocalOrCoVar (nameOccName n) uniq ty' (getSrcSpan n)) }++newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id+    -- Give the new Id a similar occurrence name to the old one+newSpecIdSM old_id new_ty join_arity_maybe+  = do  { uniq <- getUniqueM+        ; let name    = idName old_id+              new_occ = mkSpecOcc (nameOccName name)+              new_id  = mkUserLocalOrCoVar new_occ uniq new_ty (getSrcSpan name)+                          `asJoinId_maybe` join_arity_maybe+        ; return new_id }++{-+                Old (but interesting) stuff about unboxed bindings+                ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++What should we do when a value is specialised to a *strict* unboxed value?++        map_*_* f (x:xs) = let h = f x+                               t = map f xs+                           in h:t++Could convert let to case:++        map_*_Int# f (x:xs) = case f x of h# ->+                              let t = map f xs+                              in h#:t++This may be undesirable since it forces evaluation here, but the value+may not be used in all branches of the body. In the general case this+transformation is impossible since the mutual recursion in a letrec+cannot be expressed as a case.++There is also a problem with top-level unboxed values, since our+implementation cannot handle unboxed values at the top level.++Solution: Lift the binding of the unboxed value and extract it when it+is used:++        map_*_Int# f (x:xs) = let h = case (f x) of h# -> _Lift h#+                                  t = map f xs+                              in case h of+                                 _Lift h# -> h#:t++Now give it to the simplifier and the _Lifting will be optimised away.++The benefit is that we have given the specialised "unboxed" values a+very simple lifted semantics and then leave it up to the simplifier to+optimise it --- knowing that the overheads will be removed in nearly+all cases.++In particular, the value will only be evaluated in the branches of the+program which use it, rather than being forced at the point where the+value is bound. For example:++        filtermap_*_* p f (x:xs)+          = let h = f x+                t = ...+            in case p x of+                True  -> h:t+                False -> t+   ==>+        filtermap_*_Int# p f (x:xs)+          = let h = case (f x) of h# -> _Lift h#+                t = ...+            in case p x of+                True  -> case h of _Lift h#+                           -> h#:t+                False -> t++The binding for h can still be inlined in the one branch and the+_Lifting eliminated.+++Question: When won't the _Lifting be eliminated?++Answer: When they at the top-level (where it is necessary) or when+inlining would duplicate work (or possibly code depending on+options). However, the _Lifting will still be eliminated if the+strictness analyser deems the lifted binding strict.+-}
+ compiler/stgSyn/CoreToStg.hs view
@@ -0,0 +1,935 @@+{-# LANGUAGE CPP #-}++--+-- (c) The GRASP/AQUA Project, Glasgow University, 1993-1998+--++--------------------------------------------------------------+-- Converting Core to STG Syntax+--------------------------------------------------------------++-- And, as we have the info in hand, we may convert some lets to+-- let-no-escapes.++module CoreToStg ( coreToStg ) where++#include "HsVersions.h"++import GhcPrelude++import CoreSyn+import CoreUtils        ( exprType, findDefault, isJoinBind+                        , exprIsTickedString_maybe )+import CoreArity        ( manifestArity )+import StgSyn++import Type+import RepType+import TyCon+import MkId             ( coercionTokenId )+import Id+import IdInfo+import DataCon+import CostCentre+import VarEnv+import Module+import Name             ( isExternalName, nameOccName, nameModule_maybe )+import OccName          ( occNameFS )+import BasicTypes       ( Arity )+import TysWiredIn       ( unboxedUnitDataCon, unitDataConId )+import Literal+import Outputable+import MonadUtils+import FastString+import Util+import DynFlags+import ForeignCall+import Demand           ( isUsedOnce )+import PrimOp           ( PrimCall(..) )+import SrcLoc           ( mkGeneralSrcSpan )++import Data.List.NonEmpty (nonEmpty, toList)+import Data.Maybe    (fromMaybe)+import Control.Monad (liftM, ap)++-- Note [Live vs free]+-- ~~~~~~~~~~~~~~~~~~~+--+-- The two are not the same. Liveness is an operational property rather+-- than a semantic one. A variable is live at a particular execution+-- point if it can be referred to directly again. In particular, a dead+-- variable's stack slot (if it has one):+--+--           - should be stubbed to avoid space leaks, and+--           - may be reused for something else.+--+-- There ought to be a better way to say this. Here are some examples:+--+--         let v = [q] \[x] -> e+--         in+--         ...v...  (but no q's)+--+-- Just after the `in', v is live, but q is dead. If the whole of that+-- let expression was enclosed in a case expression, thus:+--+--         case (let v = [q] \[x] -> e in ...v...) of+--                 alts[...q...]+--+-- (ie `alts' mention `q'), then `q' is live even after the `in'; because+-- we'll return later to the `alts' and need it.+--+-- Let-no-escapes make this a bit more interesting:+--+--         let-no-escape v = [q] \ [x] -> e+--         in+--         ...v...+--+-- Here, `q' is still live at the `in', because `v' is represented not by+-- a closure but by the current stack state.  In other words, if `v' is+-- live then so is `q'. Furthermore, if `e' mentions an enclosing+-- let-no-escaped variable, then its free variables are also live if `v' is.++-- Note [What are these SRTs all about?]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Consider the Core program,+--+--     fibs = go 1 1+--       where go a b = let c = a + c+--                      in c : go b c+--     add x = map (\y -> x*y) fibs+--+-- In this case we have a CAF, 'fibs', which is quite large after evaluation and+-- has only one possible user, 'add'. Consequently, we want to ensure that when+-- all references to 'add' die we can garbage collect any bit of 'fibs' that we+-- have evaluated.+--+-- However, how do we know whether there are any references to 'fibs' still+-- around? Afterall, the only reference to it is buried in the code generated+-- for 'add'. The answer is that we record the CAFs referred to by a definition+-- in its info table, namely a part of it known as the Static Reference Table+-- (SRT).+--+-- Since SRTs are so common, we use a special compact encoding for them in: we+-- produce one table containing a list of CAFs in a module and then include a+-- bitmap in each info table describing which entries of this table the closure+-- references.+--+-- See also: commentary/rts/storage/gc/CAFs on the GHC Wiki.++-- Note [What is a non-escaping let]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- NB: Nowadays this is recognized by the occurrence analyser by turning a+-- "non-escaping let" into a join point. The following is then an operational+-- account of join points.+--+-- Consider:+--+--     let x = fvs \ args -> e+--     in+--         if ... then x else+--            if ... then x else ...+--+-- `x' is used twice (so we probably can't unfold it), but when it is+-- entered, the stack is deeper than it was when the definition of `x'+-- happened.  Specifically, if instead of allocating a closure for `x',+-- we saved all `x's fvs on the stack, and remembered the stack depth at+-- that moment, then whenever we enter `x' we can simply set the stack+-- pointer(s) to these remembered (compile-time-fixed) values, and jump+-- to the code for `x'.+--+-- All of this is provided x is:+--   1. non-updatable;+--   2. guaranteed to be entered before the stack retreats -- ie x is not+--      buried in a heap-allocated closure, or passed as an argument to+--      something;+--   3. all the enters have exactly the right number of arguments,+--      no more no less;+--   4. all the enters are tail calls; that is, they return to the+--      caller enclosing the definition of `x'.+--+-- Under these circumstances we say that `x' is non-escaping.+--+-- An example of when (4) does not hold:+--+--     let x = ...+--     in case x of ...alts...+--+-- Here, `x' is certainly entered only when the stack is deeper than when+-- `x' is defined, but here it must return to ...alts... So we can't just+-- adjust the stack down to `x''s recalled points, because that would lost+-- alts' context.+--+-- Things can get a little more complicated.  Consider:+--+--     let y = ...+--     in let x = fvs \ args -> ...y...+--     in ...x...+--+-- Now, if `x' is used in a non-escaping way in ...x..., and `y' is used in a+-- non-escaping way in ...y..., then `y' is non-escaping.+--+-- `x' can even be recursive!  Eg:+--+--     letrec x = [y] \ [v] -> if v then x True else ...+--     in+--         ...(x b)...++-- Note [Cost-centre initialization plan]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Previously `coreToStg` was initializing cost-centre stack fields as `noCCS`,+-- and the fields were then fixed by a separate pass `stgMassageForProfiling`.+-- We now initialize these correctly. The initialization works like this:+--+--   - For non-top level bindings always use `currentCCS`.+--+--   - For top-level bindings, check if the binding is a CAF+--+--     - CAF:      If -fcaf-all is enabled, create a new CAF just for this CAF+--                 and use it. Note that these new cost centres need to be+--                 collected to be able to generate cost centre initialization+--                 code, so `coreToTopStgRhs` now returns `CollectedCCs`.+--+--                 If -fcaf-all is not enabled, use "all CAFs" cost centre.+--+--     - Non-CAF:  Top-level (static) data is not counted in heap profiles; nor+--                 do we set CCCS from it; so we just slam in+--                 dontCareCostCentre.++-- --------------------------------------------------------------+-- Setting variable info: top-level, binds, RHSs+-- --------------------------------------------------------------++coreToStg :: DynFlags -> Module -> CoreProgram+          -> ([StgTopBinding], CollectedCCs)+coreToStg dflags this_mod pgm+  = (pgm', final_ccs)+  where+    (_, (local_ccs, local_cc_stacks), pgm')+      = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm++    prof = WayProf `elem` ways dflags++    final_ccs+      | prof && gopt Opt_AutoSccsOnIndividualCafs dflags+      = (local_ccs,local_cc_stacks)  -- don't need "all CAFs" CC+      | prof+      = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks)+      | otherwise+      = emptyCollectedCCs++    (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod++coreTopBindsToStg+    :: DynFlags+    -> Module+    -> IdEnv HowBound           -- environment for the bindings+    -> CollectedCCs+    -> CoreProgram+    -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])++coreTopBindsToStg _      _        env ccs []+  = (env, ccs, [])+coreTopBindsToStg dflags this_mod env ccs (b:bs)+  = (env2, ccs2, b':bs')+  where+        (env1, ccs1, b' ) =+          coreTopBindToStg dflags this_mod env ccs b+        (env2, ccs2, bs') =+          coreTopBindsToStg dflags this_mod env1 ccs1 bs++coreTopBindToStg+        :: DynFlags+        -> Module+        -> IdEnv HowBound+        -> CollectedCCs+        -> CoreBind+        -> (IdEnv HowBound, CollectedCCs, StgTopBinding)++coreTopBindToStg _ _ env ccs (NonRec id e)+  | Just str <- exprIsTickedString_maybe e+  -- top-level string literal+  -- See Note [CoreSyn top-level string literals] in CoreSyn+  = let+        env' = extendVarEnv env id how_bound+        how_bound = LetBound TopLet 0+    in (env', ccs, StgTopStringLit id str)++coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)+  = let+        env'      = extendVarEnv env id how_bound+        how_bound = LetBound TopLet $! manifestArity rhs++        (stg_rhs, ccs') =+            initCts env $+              coreToTopStgRhs dflags ccs this_mod (id,rhs)++        bind = StgTopLifted $ StgNonRec id stg_rhs+    in+    ASSERT2(consistentCafInfo id bind, ppr id )+      -- NB: previously the assertion printed 'rhs' and 'bind'+      --     as well as 'id', but that led to a black hole+      --     where printing the assertion error tripped the+      --     assertion again!+    (env', ccs', bind)++coreTopBindToStg dflags this_mod env ccs (Rec pairs)+  = ASSERT( not (null pairs) )+    let+        binders = map fst pairs++        extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)+                     | (b, rhs) <- pairs ]+        env' = extendVarEnvList env extra_env'++        -- generate StgTopBindings and CAF cost centres created for CAFs+        (ccs', stg_rhss)+          = initCts env' $ do+               mapAccumLM (\ccs rhs -> do+                            (rhs', ccs') <-+                              coreToTopStgRhs dflags ccs this_mod rhs+                            return (ccs', rhs'))+                          ccs+                          pairs++        bind = StgTopLifted $ StgRec (zip binders stg_rhss)+    in+    ASSERT2(consistentCafInfo (head binders) bind, ppr binders)+    (env', ccs', bind)+++-- Assertion helper: this checks that the CafInfo on the Id matches+-- what CoreToStg has figured out about the binding's SRT.  The+-- CafInfo will be exact in all cases except when CorePrep has+-- floated out a binding, in which case it will be approximate.+consistentCafInfo :: Id -> StgTopBinding -> Bool+consistentCafInfo id bind+  = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )+    safe+  where+    safe  = id_marked_caffy || not binding_is_caffy+    exact = id_marked_caffy == binding_is_caffy+    id_marked_caffy  = mayHaveCafRefs (idCafInfo id)+    binding_is_caffy = topStgBindHasCafRefs bind+    is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat"++coreToTopStgRhs+        :: DynFlags+        -> CollectedCCs+        -> Module+        -> (Id,CoreExpr)+        -> CtsM (StgRhs, CollectedCCs)++coreToTopStgRhs dflags ccs this_mod (bndr, rhs)+  = do { new_rhs <- coreToStgExpr rhs++       ; let (stg_rhs, ccs') =+               mkTopStgRhs dflags this_mod ccs bndr new_rhs+             stg_arity =+               stgRhsArity stg_rhs++       ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs,+                 ccs') }+  where+        -- It's vital that the arity on a top-level Id matches+        -- the arity of the generated STG binding, else an importing+        -- module will use the wrong calling convention+        --      (#2844 was an example where this happened)+        -- NB1: we can't move the assertion further out without+        --      blocking the "knot" tied in coreTopBindsToStg+        -- NB2: the arity check is only needed for Ids with External+        --      Names, because they are externally visible.  The CorePrep+        --      pass introduces "sat" things with Local Names and does+        --      not bother to set their Arity info, so don't fail for those+    arity_ok stg_arity+       | isExternalName (idName bndr) = id_arity == stg_arity+       | otherwise                    = True+    id_arity  = idArity bndr+    mk_arity_msg stg_arity+        = vcat [ppr bndr,+                text "Id arity:" <+> ppr id_arity,+                text "STG arity:" <+> ppr stg_arity]++-- ---------------------------------------------------------------------------+-- Expressions+-- ---------------------------------------------------------------------------++coreToStgExpr+        :: CoreExpr+        -> CtsM StgExpr++-- The second and third components can be derived in a simple bottom up pass, not+-- dependent on any decisions about which variables will be let-no-escaped or+-- not.  The first component, that is, the decorated expression, may then depend+-- on these components, but it in turn is not scrutinised as the basis for any+-- decisions.  Hence no black holes.++-- No LitInteger's or LitNatural's should be left by the time this is called.+-- CorePrep should have converted them all to a real core representation.+coreToStgExpr (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger"+coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural"+coreToStgExpr (Lit l)      = return (StgLit l)+coreToStgExpr (App (Lit LitRubbish) _some_unlifted_type)+  -- We lower 'LitRubbish' to @()@ here, which is much easier than doing it in+  -- a STG to Cmm pass.+  = coreToStgExpr (Var unitDataConId)+coreToStgExpr (Var v)      = coreToStgApp Nothing v               [] []+coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] []++coreToStgExpr expr@(App _ _)+  = coreToStgApp Nothing f args ticks+  where+    (f, args, ticks) = myCollectArgs expr++coreToStgExpr expr@(Lam _ _)+  = let+        (args, body) = myCollectBinders expr+        args'        = filterStgBinders args+    in+    extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do+    body' <- coreToStgExpr body+    let+        result_expr = case nonEmpty args' of+          Nothing     -> body'+          Just args'' -> StgLam args'' body'++    return result_expr++coreToStgExpr (Tick tick expr)+  = do case tick of+         HpcTick{}    -> return ()+         ProfNote{}   -> return ()+         SourceNote{} -> return ()+         Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"+       expr2 <- coreToStgExpr expr+       return (StgTick tick expr2)++coreToStgExpr (Cast expr _)+  = coreToStgExpr expr++-- Cases require a little more real work.++coreToStgExpr (Case scrut _ _ [])+  = coreToStgExpr scrut+    -- See Note [Empty case alternatives] in CoreSyn If the case+    -- alternatives are empty, the scrutinee must diverge or raise an+    -- exception, so we can just dive into it.+    --+    -- Of course this may seg-fault if the scrutinee *does* return.  A+    -- belt-and-braces approach would be to move this case into the+    -- code generator, and put a return point anyway that calls a+    -- runtime system error function.+++coreToStgExpr (Case scrut bndr _ alts) = do+    alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)+    scrut2 <- coreToStgExpr scrut+    return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2)+  where+    vars_alt (con, binders, rhs)+      | DataAlt c <- con, c == unboxedUnitDataCon+      = -- This case is a bit smelly.+        -- See Note [Nullary unboxed tuple] in Type.hs+        -- where a nullary tuple is mapped to (State# World#)+        ASSERT( null binders )+        do { rhs2 <- coreToStgExpr rhs+           ; return (DEFAULT, [], rhs2)  }+      | otherwise+      = let     -- Remove type variables+            binders' = filterStgBinders binders+        in+        extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do+        rhs2 <- coreToStgExpr rhs+        return (con, binders', rhs2)++coreToStgExpr (Let bind body) = do+    coreToStgLet bind body++coreToStgExpr e = pprPanic "coreToStgExpr" (ppr e)++mkStgAltType :: Id -> [CoreAlt] -> AltType+mkStgAltType bndr alts+  | isUnboxedTupleType bndr_ty || isUnboxedSumType bndr_ty+  = MultiValAlt (length prim_reps)  -- always use MultiValAlt for unboxed tuples++  | otherwise+  = case prim_reps of+      [LiftedRep] -> case tyConAppTyCon_maybe (unwrapType bndr_ty) of+        Just tc+          | isAbstractTyCon tc -> look_for_better_tycon+          | isAlgTyCon tc      -> AlgAlt tc+          | otherwise          -> ASSERT2( _is_poly_alt_tycon tc, ppr tc )+                                  PolyAlt+        Nothing                -> PolyAlt+      [unlifted] -> PrimAlt unlifted+      not_unary  -> MultiValAlt (length not_unary)+  where+   bndr_ty   = idType bndr+   prim_reps = typePrimRep bndr_ty++   _is_poly_alt_tycon tc+        =  isFunTyCon tc+        || isPrimTyCon tc   -- "Any" is lifted but primitive+        || isFamilyTyCon tc -- Type family; e.g. Any, or arising from strict+                            -- function application where argument has a+                            -- type-family type++   -- Sometimes, the TyCon is a AbstractTyCon which may not have any+   -- constructors inside it.  Then we may get a better TyCon by+   -- grabbing the one from a constructor alternative+   -- if one exists.+   look_for_better_tycon+        | ((DataAlt con, _, _) : _) <- data_alts =+                AlgAlt (dataConTyCon con)+        | otherwise =+                ASSERT(null data_alts)+                PolyAlt+        where+                (data_alts, _deflt) = findDefault alts++-- ---------------------------------------------------------------------------+-- Applications+-- ---------------------------------------------------------------------------++coreToStgApp+         :: Maybe UpdateFlag            -- Just upd <=> this application is+                                        -- the rhs of a thunk binding+                                        --      x = [...] \upd [] -> the_app+                                        -- with specified update flag+        -> Id                           -- Function+        -> [CoreArg]                    -- Arguments+        -> [Tickish Id]                 -- Debug ticks+        -> CtsM StgExpr+++coreToStgApp _ f args ticks = do+    (args', ticks') <- coreToStgArgs args+    how_bound <- lookupVarCts f++    let+        n_val_args       = valArgCount args++        -- Mostly, the arity info of a function is in the fn's IdInfo+        -- But new bindings introduced by CoreSat may not have no+        -- arity info; it would do us no good anyway.  For example:+        --      let f = \ab -> e in f+        -- No point in having correct arity info for f!+        -- Hence the hasArity stuff below.+        -- NB: f_arity is only consulted for LetBound things+        f_arity   = stgArity f how_bound+        saturated = f_arity <= n_val_args++        res_ty = exprType (mkApps (Var f) args)+        app = case idDetails f of+                DataConWorkId dc+                  | saturated    -> StgConApp dc args'+                                      (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty)))++                -- Some primitive operator that might be implemented as a library call.+                PrimOpId op      -> ASSERT( saturated )+                                    StgOpApp (StgPrimOp op) args' res_ty++                -- A call to some primitive Cmm function.+                FCallId (CCall (CCallSpec (StaticTarget _ lbl (Just pkgId) True)+                                          PrimCallConv _))+                                 -> ASSERT( saturated )+                                    StgOpApp (StgPrimCallOp (PrimCall lbl pkgId)) args' res_ty++                -- A regular foreign call.+                FCallId call     -> ASSERT( saturated )+                                    StgOpApp (StgFCallOp call (idUnique f)) args' res_ty++                TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')+                _other           -> StgApp f args'++        tapp = foldr StgTick app (ticks ++ ticks')++    -- Forcing these fixes a leak in the code generator, noticed while+    -- profiling for trac #4367+    app `seq` return tapp++-- ---------------------------------------------------------------------------+-- Argument lists+-- This is the guy that turns applications into A-normal form+-- ---------------------------------------------------------------------------++coreToStgArgs :: [CoreArg] -> CtsM ([StgArg], [Tickish Id])+coreToStgArgs []+  = return ([], [])++coreToStgArgs (Type _ : args) = do     -- Type argument+    (args', ts) <- coreToStgArgs args+    return (args', ts)++coreToStgArgs (Coercion _ : args)  -- Coercion argument; replace with place holder+  = do { (args', ts) <- coreToStgArgs args+       ; return (StgVarArg coercionTokenId : args', ts) }++coreToStgArgs (Tick t e : args)+  = ASSERT( not (tickishIsCode t) )+    do { (args', ts) <- coreToStgArgs (e : args)+       ; return (args', t:ts) }++coreToStgArgs (arg : args) = do         -- Non-type argument+    (stg_args, ticks) <- coreToStgArgs args+    arg' <- coreToStgExpr arg+    let+        (aticks, arg'') = stripStgTicksTop tickishFloatable arg'+        stg_arg = case arg'' of+                       StgApp v []        -> StgVarArg v+                       StgConApp con [] _ -> StgVarArg (dataConWorkId con)+                       StgLit lit         -> StgLitArg lit+                       _                  -> pprPanic "coreToStgArgs" (ppr arg)++        -- WARNING: what if we have an argument like (v `cast` co)+        --          where 'co' changes the representation type?+        --          (This really only happens if co is unsafe.)+        -- Then all the getArgAmode stuff in CgBindery will set the+        -- cg_rep of the CgIdInfo based on the type of v, rather+        -- than the type of 'co'.+        -- This matters particularly when the function is a primop+        -- or foreign call.+        -- Wanted: a better solution than this hacky warning+    let+        arg_ty = exprType arg+        stg_arg_ty = stgArgType stg_arg+        bad_args = (isUnliftedType arg_ty && not (isUnliftedType stg_arg_ty))+                || (typePrimRep arg_ty /= typePrimRep stg_arg_ty)+        -- In GHCi we coerce an argument of type BCO# (unlifted) to HValue (lifted),+        -- and pass it to a function expecting an HValue (arg_ty).  This is ok because+        -- we can treat an unlifted value as lifted.  But the other way round+        -- we complain.+        -- We also want to check if a pointer is cast to a non-ptr etc++    WARN( bad_args, text "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" $$ ppr arg )+     return (stg_arg : stg_args, ticks ++ aticks)+++-- ---------------------------------------------------------------------------+-- The magic for lets:+-- ---------------------------------------------------------------------------++coreToStgLet+         :: CoreBind     -- bindings+         -> CoreExpr     -- body+         -> CtsM StgExpr -- new let++coreToStgLet bind body = do+    (bind2, body2)+       <- do++          ( bind2, env_ext)+                <- vars_bind bind++          -- Do the body+          extendVarEnvCts env_ext $ do+             body2 <- coreToStgExpr body++             return (bind2, body2)++        -- Compute the new let-expression+    let+        new_let | isJoinBind bind = StgLetNoEscape noExtSilent bind2 body2+                | otherwise       = StgLet noExtSilent bind2 body2++    return new_let+  where+    mk_binding binder rhs+        = (binder, LetBound NestedLet (manifestArity rhs))++    vars_bind :: CoreBind+              -> CtsM (StgBinding,+                       [(Id, HowBound)])  -- extension to environment++    vars_bind (NonRec binder rhs) = do+        rhs2 <- coreToStgRhs (binder,rhs)+        let+            env_ext_item = mk_binding binder rhs++        return (StgNonRec binder rhs2, [env_ext_item])++    vars_bind (Rec pairs)+      =    let+                binders = map fst pairs+                env_ext = [ mk_binding b rhs+                          | (b,rhs) <- pairs ]+           in+           extendVarEnvCts env_ext $ do+              rhss2 <- mapM coreToStgRhs pairs+              return (StgRec (binders `zip` rhss2), env_ext)++coreToStgRhs :: (Id,CoreExpr)+             -> CtsM StgRhs++coreToStgRhs (bndr, rhs) = do+    new_rhs <- coreToStgExpr rhs+    return (mkStgRhs bndr new_rhs)++-- Generate a top-level RHS. Any new cost centres generated for CAFs will be+-- appended to `CollectedCCs` argument.+mkTopStgRhs :: DynFlags -> Module -> CollectedCCs+            -> Id -> StgExpr -> (StgRhs, CollectedCCs)++mkTopStgRhs dflags this_mod ccs bndr rhs+  | StgLam bndrs body <- rhs+  = -- StgLam can't have empty arguments, so not CAF+    ( StgRhsClosure noExtSilent+                    dontCareCCS+                    ReEntrant+                    (toList bndrs) body+    , ccs )++  | StgConApp con args _ <- unticked_rhs+  , -- Dynamic StgConApps are updatable+    not (isDllConApp dflags this_mod con args)+  = -- CorePrep does this right, but just to make sure+    ASSERT2( not (isUnboxedTupleCon con || isUnboxedSumCon con)+           , ppr bndr $$ ppr con $$ ppr args)+    ( StgRhsCon dontCareCCS con args, ccs )++  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].+  | gopt Opt_AutoSccsOnIndividualCafs dflags+  = ( StgRhsClosure noExtSilent+                    caf_ccs+                    upd_flag [] rhs+    , collectCC caf_cc caf_ccs ccs )++  | otherwise+  = ( StgRhsClosure noExtSilent+                    all_cafs_ccs+                    upd_flag [] rhs+    , ccs )++  where+    (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs++    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry+             | otherwise                      = Updatable++    -- CAF cost centres generated for -fcaf-all+    caf_cc = mkAutoCC bndr modl+    caf_ccs = mkSingletonCCS caf_cc+           -- careful: the binder might be :Main.main,+           -- which doesn't belong to module mod_name.+           -- bug #249, tests prof001, prof002+    modl | Just m <- nameModule_maybe (idName bndr) = m+         | otherwise = this_mod++    -- default CAF cost centre+    (_, all_cafs_ccs) = getAllCAFsCC this_mod++-- Generate a non-top-level RHS. Cost-centre is always currentCCS,+-- see Note [Cost-centre initialzation plan].+mkStgRhs :: Id -> StgExpr -> StgRhs+mkStgRhs bndr rhs+  | StgLam bndrs body <- rhs+  = StgRhsClosure noExtSilent+                  currentCCS+                  ReEntrant+                  (toList bndrs) body++  | isJoinId bndr -- must be a nullary join point+  = ASSERT(idJoinArity bndr == 0)+    StgRhsClosure noExtSilent+                  currentCCS+                  ReEntrant -- ignored for LNE+                  [] rhs++  | StgConApp con args _ <- unticked_rhs+  = StgRhsCon currentCCS con args++  | otherwise+  = StgRhsClosure noExtSilent+                  currentCCS+                  upd_flag [] rhs+  where+    (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs++    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry+             | otherwise                      = Updatable++  {-+    SDM: disabled.  Eval/Apply can't handle functions with arity zero very+    well; and making these into simple non-updatable thunks breaks other+    assumptions (namely that they will be entered only once).++    upd_flag | isPAP env rhs  = ReEntrant+             | otherwise      = Updatable++-- Detect thunks which will reduce immediately to PAPs, and make them+-- non-updatable.  This has several advantages:+--+--         - the non-updatable thunk behaves exactly like the PAP,+--+--         - the thunk is more efficient to enter, because it is+--           specialised to the task.+--+--         - we save one update frame, one stg_update_PAP, one update+--           and lots of PAP_enters.+--+--         - in the case where the thunk is top-level, we save building+--           a black hole and furthermore the thunk isn't considered to+--           be a CAF any more, so it doesn't appear in any SRTs.+--+-- We do it here, because the arity information is accurate, and we need+-- to do it before the SRT pass to save the SRT entries associated with+-- any top-level PAPs.++isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args+                              where+                                 arity = stgArity f (lookupBinding env f)+isPAP env _               = False++-}++{- ToDo:+          upd = if isOnceDem dem+                    then (if isNotTop toplev+                            then SingleEntry    -- HA!  Paydirt for "dem"+                            else+                     (if debugIsOn then trace "WARNING: SE CAFs unsupported, forcing UPD instead" else id) $+                     Updatable)+                else Updatable+        -- For now we forbid SingleEntry CAFs; they tickle the+        -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link,+        -- and I don't understand why.  There's only one SE_CAF (well,+        -- only one that tickled a great gaping bug in an earlier attempt+        -- at ClosureInfo.getEntryConvention) in the whole of nofib,+        -- specifically Main.lvl6 in spectral/cryptarithm2.+        -- So no great loss.  KSW 2000-07.+-}++-- ---------------------------------------------------------------------------+-- A monad for the core-to-STG pass+-- ---------------------------------------------------------------------------++-- There's a lot of stuff to pass around, so we use this CtsM+-- ("core-to-STG monad") monad to help.  All the stuff here is only passed+-- *down*.++newtype CtsM a = CtsM+    { unCtsM :: IdEnv HowBound+             -> a+    }++data HowBound+  = ImportBound         -- Used only as a response to lookupBinding; never+                        -- exists in the range of the (IdEnv HowBound)++  | LetBound            -- A let(rec) in this module+        LetInfo         -- Whether top level or nested+        Arity           -- Its arity (local Ids don't have arity info at this point)++  | LambdaBound         -- Used for both lambda and case+  deriving (Eq)++data LetInfo+  = TopLet              -- top level things+  | NestedLet+  deriving (Eq)++-- For a let(rec)-bound variable, x, we record LiveInfo, the set of+-- variables that are live if x is live.  This LiveInfo comprises+--         (a) dynamic live variables (ones with a non-top-level binding)+--         (b) static live variabes (CAFs or things that refer to CAFs)+--+-- For "normal" variables (a) is just x alone.  If x is a let-no-escaped+-- variable then x is represented by a code pointer and a stack pointer+-- (well, one for each stack).  So all of the variables needed in the+-- execution of x are live if x is, and are therefore recorded in the+-- LetBound constructor; x itself *is* included.+--+-- The set of dynamic live variables is guaranteed ot have no further+-- let-no-escaped variables in it.++-- The std monad functions:++initCts :: IdEnv HowBound -> CtsM a -> a+initCts env m = unCtsM m env++++{-# INLINE thenCts #-}+{-# INLINE returnCts #-}++returnCts :: a -> CtsM a+returnCts e = CtsM $ \_ -> e++thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b+thenCts m k = CtsM $ \env+  -> unCtsM (k (unCtsM m env)) env++instance Functor CtsM where+    fmap = liftM++instance Applicative CtsM where+    pure = returnCts+    (<*>) = ap++instance Monad CtsM where+    (>>=)  = thenCts++-- Functions specific to this monad:++extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a+extendVarEnvCts ids_w_howbound expr+   =    CtsM $   \env+   -> unCtsM expr (extendVarEnvList env ids_w_howbound)++lookupVarCts :: Id -> CtsM HowBound+lookupVarCts v = CtsM $ \env -> lookupBinding env v++lookupBinding :: IdEnv HowBound -> Id -> HowBound+lookupBinding env v = case lookupVarEnv env v of+                        Just xx -> xx+                        Nothing -> ASSERT2( isGlobalId v, ppr v ) ImportBound++getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)+getAllCAFsCC this_mod =+    let+      span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better+      all_cafs_cc  = mkAllCafsCC this_mod span+      all_cafs_ccs = mkSingletonCCS all_cafs_cc+    in+      (all_cafs_cc, all_cafs_ccs)++-- Misc.++filterStgBinders :: [Var] -> [Var]+filterStgBinders bndrs = filter isId bndrs++myCollectBinders :: Expr Var -> ([Var], Expr Var)+myCollectBinders expr+  = go [] expr+  where+    go bs (Lam b e)          = go (b:bs) e+    go bs (Cast e _)         = go bs e+    go bs e                  = (reverse bs, e)++-- | Precondition: argument expression is an 'App', and there is a 'Var' at the+-- head of the 'App' chain.+myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id])+myCollectArgs expr+  = go expr [] []+  where+    go (Var v)          as ts = (v, as, ts)+    go (App f a)        as ts = go f (a:as) ts+    go (Tick t e)       as ts = ASSERT( all isTypeArg as )+                                go e as (t:ts) -- ticks can appear in type apps+    go (Cast e _)       as ts = go e as ts+    go (Lam b e)        as ts+       | isTyVar b            = go e as ts -- Note [Collect args]+    go _                _  _  = pprPanic "CoreToStg.myCollectArgs" (ppr expr)++-- Note [Collect args]+-- ~~~~~~~~~~~~~~~~~~~+--+-- This big-lambda case occurred following a rather obscure eta expansion.+-- It all seems a bit yukky to me.++stgArity :: Id -> HowBound -> Arity+stgArity _ (LetBound _ arity) = arity+stgArity f ImportBound        = idArity f+stgArity _ LambdaBound        = 0
+ compiler/stgSyn/StgFVs.hs view
@@ -0,0 +1,130 @@+-- | Free variable analysis on STG terms.+module StgFVs (+    annTopBindingsFreeVars,+    annBindingFreeVars+  ) where++import GhcPrelude++import StgSyn+import Id+import VarSet+import CoreSyn    ( Tickish(Breakpoint) )+import Outputable+import Util++import Data.Maybe ( mapMaybe )++newtype Env+  = Env+  { locals :: IdSet+  }++emptyEnv :: Env+emptyEnv = Env emptyVarSet++addLocals :: [Id] -> Env -> Env+addLocals bndrs env+  = env { locals = extendVarSetList (locals env) bndrs }++-- | Annotates a top-level STG binding group with its free variables.+annTopBindingsFreeVars :: [StgTopBinding] -> [CgStgTopBinding]+annTopBindingsFreeVars = map go+  where+    go (StgTopStringLit id bs) = StgTopStringLit id bs+    go (StgTopLifted bind)+      = StgTopLifted (annBindingFreeVars bind)++-- | Annotates an STG binding with its free variables.+annBindingFreeVars :: StgBinding -> CgStgBinding+annBindingFreeVars = fst . binding emptyEnv emptyDVarSet++boundIds :: StgBinding -> [Id]+boundIds (StgNonRec b _) = [b]+boundIds (StgRec pairs)  = map fst pairs++-- Note [Tracking local binders]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- 'locals' contains non-toplevel, non-imported binders.+-- We maintain the set in 'expr', 'alt' and 'rhs', which are the only+-- places where new local binders are introduced.+-- Why do it there rather than in 'binding'? Two reasons:+--+--   1. We call 'binding' from 'annTopBindingsFreeVars', which would+--      add top-level bindings to the 'locals' set.+--   2. In the let(-no-escape) case, we need to extend the environment+--      prior to analysing the body, but we also need the fvs from the+--      body to analyse the RHSs. No way to do this without some+--      knot-tying.++-- | This makes sure that only local, non-global free vars make it into the set.+mkFreeVarSet :: Env -> [Id] -> DIdSet+mkFreeVarSet env = mkDVarSet . filter (`elemVarSet` locals env)++args :: Env -> [StgArg] -> DIdSet+args env = mkFreeVarSet env . mapMaybe f+  where+    f (StgVarArg occ) = Just occ+    f _               = Nothing++binding :: Env -> DIdSet -> StgBinding -> (CgStgBinding, DIdSet)+binding env body_fv (StgNonRec bndr r) = (StgNonRec bndr r', fvs)+  where+    -- See Note [Tacking local binders]+    (r', rhs_fvs) = rhs env r+    fvs = delDVarSet body_fv bndr `unionDVarSet` rhs_fvs+binding env body_fv (StgRec pairs) = (StgRec pairs', fvs)+  where+    -- See Note [Tacking local binders]+    bndrs = map fst pairs+    (rhss, rhs_fvss) = mapAndUnzip (rhs env . snd) pairs+    pairs' = zip bndrs rhss+    fvs = delDVarSetList (unionDVarSets (body_fv:rhs_fvss)) bndrs++expr :: Env -> StgExpr -> (CgStgExpr, DIdSet)+expr env = go+  where+    go (StgApp occ as)+      = (StgApp occ as, unionDVarSet (args env as) (mkFreeVarSet env [occ]))+    go (StgLit lit) = (StgLit lit, emptyDVarSet)+    go (StgConApp dc as tys) = (StgConApp dc as tys, args env as)+    go (StgOpApp op as ty) = (StgOpApp op as ty, args env as)+    go StgLam{} = pprPanic "StgFVs: StgLam" empty+    go (StgCase scrut bndr ty alts) = (StgCase scrut' bndr ty alts', fvs)+      where+        (scrut', scrut_fvs) = go scrut+        -- See Note [Tacking local binders]+        (alts', alt_fvss) = mapAndUnzip (alt (addLocals [bndr] env)) alts+        alt_fvs = unionDVarSets alt_fvss+        fvs = delDVarSet (unionDVarSet scrut_fvs alt_fvs) bndr+    go (StgLet ext bind body) = go_bind (StgLet ext) bind body+    go (StgLetNoEscape ext bind body) = go_bind (StgLetNoEscape ext) bind body+    go (StgTick tick e) = (StgTick tick e', fvs')+      where+        (e', fvs) = go e+        fvs' = unionDVarSet (tickish tick) fvs+        tickish (Breakpoint _ ids) = mkDVarSet ids+        tickish _                  = emptyDVarSet++    go_bind dc bind body = (dc bind' body', fvs)+      where+        -- See Note [Tacking local binders]+        env' = addLocals (boundIds bind) env+        (body', body_fvs) = expr env' body+        (bind', fvs) = binding env' body_fvs bind++rhs :: Env -> StgRhs -> (CgStgRhs, DIdSet)+rhs env (StgRhsClosure _ ccs uf bndrs body)+  = (StgRhsClosure fvs ccs uf bndrs body', fvs)+  where+    -- See Note [Tacking local binders]+    (body', body_fvs) = expr (addLocals bndrs env) body+    fvs = delDVarSetList body_fvs bndrs+rhs env (StgRhsCon ccs dc as) = (StgRhsCon ccs dc as, args env as)++alt :: Env -> StgAlt -> (CgStgAlt, DIdSet)+alt env (con, bndrs, e) = ((con, bndrs, e'), fvs)+  where+    -- See Note [Tacking local binders]+    (e', rhs_fvs) = expr (addLocals bndrs env) e+    fvs = delDVarSetList rhs_fvs bndrs
+ compiler/stgSyn/StgLint.hs view
@@ -0,0 +1,397 @@+{- |+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++A lint pass to check basic STG invariants:++- Variables should be defined before used.++- Let bindings should not have unboxed types (unboxed bindings should only+  appear in case), except when they're join points (see Note [CoreSyn let/app+  invariant] and #14117).++- If linting after unarisation, invariants listed in Note [Post-unarisation+  invariants].++Because we don't have types and coercions in STG we can't really check types+here.++Some history:++StgLint used to check types, but it never worked and so it was disabled in 2000+with this note:++    WARNING:+    ~~~~~~~~++    This module has suffered bit-rot; it is likely to yield lint errors+    for Stg code that is currently perfectly acceptable for code+    generation.  Solution: don't use it!  (KSW 2000-05).++Since then there were some attempts at enabling it again, as summarised in+#14787. It's finally decided that we remove all type checking and only look for+basic properties listed above.+-}++{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, TypeFamilies #-}++module StgLint ( lintStgTopBindings ) where++import GhcPrelude++import StgSyn++import DynFlags+import Bag              ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )+import BasicTypes       ( TopLevelFlag(..), isTopLevel )+import CostCentre       ( isCurrentCCS )+import Id               ( Id, idType, isJoinId, idName )+import VarSet+import DataCon+import CoreSyn          ( AltCon(..) )+import Name             ( getSrcLoc, nameIsLocalOrFrom )+import ErrUtils         ( MsgDoc, Severity(..), mkLocMessage )+import Type+import RepType+import SrcLoc+import Outputable+import Module           ( Module )+import qualified ErrUtils as Err+import Control.Applicative ((<|>))+import Control.Monad++lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)+                   => DynFlags+                   -> Module -- ^ module being compiled+                   -> Bool   -- ^ have we run Unarise yet?+                   -> String -- ^ who produced the STG?+                   -> [GenStgTopBinding a]+                   -> IO ()++lintStgTopBindings dflags this_mod unarised whodunnit binds+  = {-# SCC "StgLint" #-}+    case initL this_mod unarised top_level_binds (lint_binds binds) of+      Nothing  ->+        return ()+      Just msg -> do+        putLogMsg dflags NoReason Err.SevDump noSrcSpan+          (defaultDumpStyle dflags)+          (vcat [ text "*** Stg Lint ErrMsgs: in" <+>+                        text whodunnit <+> text "***",+                  msg,+                  text "*** Offending Program ***",+                  pprGenStgTopBindings binds,+                  text "*** End of Offense ***"])+        Err.ghcExit dflags 1+  where+    -- Bring all top-level binds into scope because CoreToStg does not generate+    -- bindings in dependency order (so we may see a use before its definition).+    top_level_binds = mkVarSet (bindersOfTopBinds binds)++    lint_binds :: [GenStgTopBinding a] -> LintM ()++    lint_binds [] = return ()+    lint_binds (bind:binds) = do+        binders <- lint_bind bind+        addInScopeVars binders $+            lint_binds binds++    lint_bind (StgTopLifted bind) = lintStgBinds TopLevel bind+    lint_bind (StgTopStringLit v _) = return [v]++lintStgArg :: StgArg -> LintM ()+lintStgArg (StgLitArg _) = return ()+lintStgArg (StgVarArg v) = lintStgVar v++lintStgVar :: Id -> LintM ()+lintStgVar id = checkInScope id++lintStgBinds+    :: (OutputablePass a, BinderP a ~ Id)+    => TopLevelFlag -> GenStgBinding a -> LintM [Id] -- Returns the binders+lintStgBinds top_lvl (StgNonRec binder rhs) = do+    lint_binds_help top_lvl (binder,rhs)+    return [binder]++lintStgBinds top_lvl (StgRec pairs)+  = addInScopeVars binders $ do+        mapM_ (lint_binds_help top_lvl) pairs+        return binders+  where+    binders = [b | (b,_) <- pairs]++lint_binds_help+    :: (OutputablePass a, BinderP a ~ Id)+    => TopLevelFlag+    -> (Id, GenStgRhs a)+    -> LintM ()+lint_binds_help top_lvl (binder, rhs)+  = addLoc (RhsOf binder) $ do+        when (isTopLevel top_lvl) (checkNoCurrentCCS rhs)+        lintStgRhs rhs+        -- Check binder doesn't have unlifted type or it's a join point+        checkL (isJoinId binder || not (isUnliftedType (idType binder)))+               (mkUnliftedTyMsg binder rhs)++-- | Top-level bindings can't inherit the cost centre stack from their+-- (static) allocation site.+checkNoCurrentCCS+    :: (OutputablePass a, BinderP a ~ Id)+    => GenStgRhs a+    -> LintM ()+checkNoCurrentCCS rhs@(StgRhsClosure _ ccs _ _ _)+  | isCurrentCCS ccs+  = addErrL (text "Top-level StgRhsClosure with CurrentCCS" $$ ppr rhs)+checkNoCurrentCCS rhs@(StgRhsCon ccs _ _)+  | isCurrentCCS ccs+  = addErrL (text "Top-level StgRhsCon with CurrentCCS" $$ ppr rhs)+checkNoCurrentCCS _+  = return ()++lintStgRhs :: (OutputablePass a, BinderP a ~ Id) => GenStgRhs a -> LintM ()++lintStgRhs (StgRhsClosure _ _ _ [] expr)+  = lintStgExpr expr++lintStgRhs (StgRhsClosure _ _ _ binders expr)+  = addLoc (LambdaBodyOf binders) $+      addInScopeVars binders $+        lintStgExpr expr++lintStgRhs rhs@(StgRhsCon _ con args) = do+    when (isUnboxedTupleCon con || isUnboxedSumCon con) $+      addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$+               ppr rhs)+    mapM_ lintStgArg args+    mapM_ checkPostUnariseConArg args++lintStgExpr :: (OutputablePass a, BinderP a ~ Id) => GenStgExpr a -> LintM ()++lintStgExpr (StgLit _) = return ()++lintStgExpr (StgApp fun args) = do+    lintStgVar fun+    mapM_ lintStgArg args++lintStgExpr app@(StgConApp con args _arg_tys) = do+    -- unboxed sums should vanish during unarise+    lf <- getLintFlags+    when (lf_unarised lf && isUnboxedSumCon con) $+      addErrL (text "Unboxed sum after unarise:" $$+               ppr app)+    mapM_ lintStgArg args+    mapM_ checkPostUnariseConArg args++lintStgExpr (StgOpApp _ args _) =+    mapM_ lintStgArg args++lintStgExpr lam@(StgLam _ _) =+    addErrL (text "Unexpected StgLam" <+> ppr lam)++lintStgExpr (StgLet _ binds body) = do+    binders <- lintStgBinds NotTopLevel binds+    addLoc (BodyOfLetRec binders) $+      addInScopeVars binders $+        lintStgExpr body++lintStgExpr (StgLetNoEscape _ binds body) = do+    binders <- lintStgBinds NotTopLevel binds+    addLoc (BodyOfLetRec binders) $+      addInScopeVars binders $+        lintStgExpr body++lintStgExpr (StgTick _ expr) = lintStgExpr expr++lintStgExpr (StgCase scrut bndr alts_type alts) = do+    lintStgExpr scrut++    lf <- getLintFlags+    let in_scope = stgCaseBndrInScope alts_type (lf_unarised lf)++    addInScopeVars [bndr | in_scope] (mapM_ lintAlt alts)++lintAlt+    :: (OutputablePass a, BinderP a ~ Id)+    => (AltCon, [Id], GenStgExpr a) -> LintM ()++lintAlt (DEFAULT, _, rhs) =+    lintStgExpr rhs++lintAlt (LitAlt _, _, rhs) =+    lintStgExpr rhs++lintAlt (DataAlt _, bndrs, rhs) = do+    mapM_ checkPostUnariseBndr bndrs+    addInScopeVars bndrs (lintStgExpr rhs)++{-+************************************************************************+*                                                                      *+Utilities+*                                                                      *+************************************************************************+-}++bindersOf :: BinderP a ~ Id => GenStgBinding a -> [Id]+bindersOf (StgNonRec binder _) = [binder]+bindersOf (StgRec pairs)       = [binder | (binder, _) <- pairs]++bindersOfTop :: BinderP a ~ Id => GenStgTopBinding a -> [Id]+bindersOfTop (StgTopLifted bind) = bindersOf bind+bindersOfTop (StgTopStringLit binder _) = [binder]++bindersOfTopBinds :: BinderP a ~ Id => [GenStgTopBinding a] -> [Id]+bindersOfTopBinds = foldr ((++) . bindersOfTop) []++{-+************************************************************************+*                                                                      *+The Lint monad+*                                                                      *+************************************************************************+-}++newtype LintM a = LintM+    { unLintM :: Module+              -> LintFlags+              -> [LintLocInfo]     -- Locations+              -> IdSet             -- Local vars in scope+              -> Bag MsgDoc        -- Error messages so far+              -> (a, Bag MsgDoc)   -- Result and error messages (if any)+    }++data LintFlags = LintFlags { lf_unarised :: !Bool+                             -- ^ have we run the unariser yet?+                           }++data LintLocInfo+  = RhsOf Id            -- The variable bound+  | LambdaBodyOf [Id]   -- The lambda-binder+  | BodyOfLetRec [Id]   -- One of the binders++dumpLoc :: LintLocInfo -> (SrcSpan, SDoc)+dumpLoc (RhsOf v) =+  (srcLocSpan (getSrcLoc v), text " [RHS of " <> pp_binders [v] <> char ']' )+dumpLoc (LambdaBodyOf bs) =+  (srcLocSpan (getSrcLoc (head bs)), text " [in body of lambda with binders " <> pp_binders bs <> char ']' )++dumpLoc (BodyOfLetRec bs) =+  (srcLocSpan (getSrcLoc (head bs)), text " [in body of letrec with binders " <> pp_binders bs <> char ']' )+++pp_binders :: [Id] -> SDoc+pp_binders bs+  = sep (punctuate comma (map pp_binder bs))+  where+    pp_binder b+      = hsep [ppr b, dcolon, ppr (idType b)]++initL :: Module -> Bool -> IdSet -> LintM a -> Maybe MsgDoc+initL this_mod unarised locals (LintM m) = do+  let (_, errs) = m this_mod (LintFlags unarised) [] locals emptyBag+  if isEmptyBag errs then+      Nothing+  else+      Just (vcat (punctuate blankLine (bagToList errs)))++instance Functor LintM where+      fmap = liftM++instance Applicative LintM where+      pure a = LintM $ \_mod _lf _loc _scope errs -> (a, errs)+      (<*>) = ap+      (*>)  = thenL_++instance Monad LintM where+    (>>=) = thenL+    (>>)  = (*>)++thenL :: LintM a -> (a -> LintM b) -> LintM b+thenL m k = LintM $ \mod lf loc scope errs+  -> case unLintM m mod lf loc scope errs of+      (r, errs') -> unLintM (k r) mod lf loc scope errs'++thenL_ :: LintM a -> LintM b -> LintM b+thenL_ m k = LintM $ \mod lf loc scope errs+  -> case unLintM m mod lf loc scope errs of+      (_, errs') -> unLintM k mod lf loc scope errs'++checkL :: Bool -> MsgDoc -> LintM ()+checkL True  _   = return ()+checkL False msg = addErrL msg++-- Case alts shouldn't have unboxed sum, unboxed tuple, or void binders.+checkPostUnariseBndr :: Id -> LintM ()+checkPostUnariseBndr bndr = do+    lf <- getLintFlags+    when (lf_unarised lf) $+      forM_ (checkPostUnariseId bndr) $ \unexpected ->+        addErrL $+          text "After unarisation, binder " <>+          ppr bndr <> text " has " <> text unexpected <> text " type " <>+          ppr (idType bndr)++-- Arguments shouldn't have sum, tuple, or void types.+checkPostUnariseConArg :: StgArg -> LintM ()+checkPostUnariseConArg arg = case arg of+    StgLitArg _ ->+      return ()+    StgVarArg id -> do+      lf <- getLintFlags+      when (lf_unarised lf) $+        forM_ (checkPostUnariseId id) $ \unexpected ->+          addErrL $+            text "After unarisation, arg " <>+            ppr id <> text " has " <> text unexpected <> text " type " <>+            ppr (idType id)++-- Post-unarisation args and case alt binders should not have unboxed tuple,+-- unboxed sum, or void types. Return what the binder is if it is one of these.+checkPostUnariseId :: Id -> Maybe String+checkPostUnariseId id =+    let+      id_ty = idType id+      is_sum, is_tuple, is_void :: Maybe String+      is_sum = guard (isUnboxedSumType id_ty) >> return "unboxed sum"+      is_tuple = guard (isUnboxedTupleType id_ty) >> return "unboxed tuple"+      is_void = guard (isVoidTy id_ty) >> return "void"+    in+      is_sum <|> is_tuple <|> is_void++addErrL :: MsgDoc -> LintM ()+addErrL msg = LintM $ \_mod _lf loc _scope errs -> ((), addErr errs msg loc)++addErr :: Bag MsgDoc -> MsgDoc -> [LintLocInfo] -> Bag MsgDoc+addErr errs_so_far msg locs+  = errs_so_far `snocBag` mk_msg locs+  where+    mk_msg (loc:_) = let (l,hdr) = dumpLoc loc+                     in  mkLocMessage SevWarning l (hdr $$ msg)+    mk_msg []      = msg++addLoc :: LintLocInfo -> LintM a -> LintM a+addLoc extra_loc m = LintM $ \mod lf loc scope errs+   -> unLintM m mod lf (extra_loc:loc) scope errs++addInScopeVars :: [Id] -> LintM a -> LintM a+addInScopeVars ids m = LintM $ \mod lf loc scope errs+ -> let+        new_set = mkVarSet ids+    in unLintM m mod lf loc (scope `unionVarSet` new_set) errs++getLintFlags :: LintM LintFlags+getLintFlags = LintM $ \_mod lf _loc _scope errs -> (lf, errs)++checkInScope :: Id -> LintM ()+checkInScope id = LintM $ \mod _lf loc scope errs+ -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then+        ((), addErr errs (hsep [ppr id, dcolon, ppr (idType id),+                                text "is out of scope"]) loc)+    else+        ((), errs)++mkUnliftedTyMsg :: OutputablePass a => Id -> GenStgRhs a -> SDoc+mkUnliftedTyMsg binder rhs+  = (text "Let(rec) binder" <+> quotes (ppr binder) <+>+     text "has unlifted type" <+> quotes (ppr (idType binder)))+    $$+    (text "RHS:" <+> ppr rhs)
+ compiler/stgSyn/StgSubst.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE CPP #-}++module StgSubst where++#include "HsVersions.h"++import GhcPrelude++import Id+import VarEnv+import Control.Monad.Trans.State.Strict+import Outputable+import Util++-- | A renaming substitution from 'Id's to 'Id's. Like 'RnEnv2', but not+-- maintaining pairs of substitutions. Like @"CoreSubst".'CoreSubst.Subst'@, but+-- with the domain being 'Id's instead of entire 'CoreExpr'.+data Subst = Subst InScopeSet IdSubstEnv++type IdSubstEnv = IdEnv Id++-- | @emptySubst = 'mkEmptySubst' 'emptyInScopeSet'@+emptySubst :: Subst+emptySubst = mkEmptySubst emptyInScopeSet++-- | Constructs a new 'Subst' assuming the variables in the given 'InScopeSet'+-- are in scope.+mkEmptySubst :: InScopeSet -> Subst+mkEmptySubst in_scope = Subst in_scope emptyVarEnv++-- | Substitutes an 'Id' for another one according to the 'Subst' given in a way+-- that avoids shadowing the 'InScopeSet', returning the result and an updated+-- 'Subst' that should be used by subsequent substitutions.+substBndr :: Id -> Subst -> (Id, Subst)+substBndr id (Subst in_scope env)+  = (new_id, Subst new_in_scope new_env)+  where+    new_id = uniqAway in_scope id+    no_change = new_id == id -- in case nothing shadowed+    new_in_scope = in_scope `extendInScopeSet` new_id+    new_env+      | no_change = delVarEnv env id+      | otherwise = extendVarEnv env id new_id++-- | @substBndrs = runState . traverse (state . substBndr)@+substBndrs :: Traversable f => f Id -> Subst -> (f Id, Subst)+substBndrs = runState . traverse (state . substBndr)++-- | Substitutes an occurrence of an identifier for its counterpart recorded+-- in the 'Subst'.+lookupIdSubst :: HasCallStack => Id -> Subst -> Id+lookupIdSubst id (Subst in_scope env)+  | not (isLocalId id) = id+  | Just id' <- lookupVarEnv env id = id'+  | Just id' <- lookupInScope in_scope id = id'+  | otherwise = WARN( True, text "StgSubst.lookupIdSubst" <+> ppr id $$ ppr in_scope)+                id++-- | Substitutes an occurrence of an identifier for its counterpart recorded+-- in the 'Subst'. Does not generate a debug warning if the identifier to+-- to substitute wasn't in scope.+noWarnLookupIdSubst :: HasCallStack => Id -> Subst -> Id+noWarnLookupIdSubst id (Subst in_scope env)+  | not (isLocalId id) = id+  | Just id' <- lookupVarEnv env id = id'+  | Just id' <- lookupInScope in_scope id = id'+  | otherwise = id++-- | Add the 'Id' to the in-scope set and remove any existing substitutions for+-- it.+extendInScope :: Id -> Subst -> Subst+extendInScope id (Subst in_scope env) = Subst (in_scope `extendInScopeSet` id) env++-- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the+-- in-scope set is such that TyCORep Note [The substitution invariant]+-- holds after extending the substitution like this.+extendSubst :: Id -> Id -> Subst -> Subst+extendSubst id new_id (Subst in_scope env)+  = ASSERT2( new_id `elemInScopeSet` in_scope, ppr id <+> ppr new_id $$ ppr in_scope )+    Subst in_scope (extendVarEnv env id new_id)
+ compiler/stgSyn/StgSyn.hs view
@@ -0,0 +1,892 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[StgSyn]{Shared term graph (STG) syntax for spineless-tagless code generation}++This data type represents programs just before code generation (conversion to+@Cmm@): basically, what we have is a stylised form of @CoreSyntax@, the style+being one that happens to be ideally suited to spineless tagless code+generation.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds #-}++module StgSyn (+        StgArg(..),++        GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),+        GenStgAlt, AltType(..),++        StgPass(..), BinderP, XRhsClosure, XLet, XLetNoEscape,+        NoExtSilent, noExtSilent,+        OutputablePass,++        UpdateFlag(..), isUpdatable,++        -- a set of synonyms for the vanilla parameterisation+        StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt,++        -- a set of synonyms for the code gen parameterisation+        CgStgTopBinding, CgStgBinding, CgStgExpr, CgStgRhs, CgStgAlt,++        -- a set of synonyms for the lambda lifting parameterisation+        LlStgTopBinding, LlStgBinding, LlStgExpr, LlStgRhs, LlStgAlt,++        -- a set of synonyms to distinguish in- and out variants+        InStgArg,  InStgTopBinding,  InStgBinding,  InStgExpr,  InStgRhs,  InStgAlt,+        OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt,++        -- StgOp+        StgOp(..),++        -- utils+        topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,+        isDllConApp,+        stgArgType,+        stripStgTicksTop,+        stgCaseBndrInScope,++        pprStgBinding, pprGenStgTopBindings, pprStgTopBindings+    ) where++#include "HsVersions.h"++import GhcPrelude++import CoreSyn     ( AltCon, Tickish )+import CostCentre  ( CostCentreStack )+import Data.ByteString ( ByteString )+import Data.Data   ( Data )+import Data.List   ( intersperse )+import DataCon+import DynFlags+import FastString+import ForeignCall ( ForeignCall )+import Id+import IdInfo      ( mayHaveCafRefs )+import VarSet+import Literal     ( Literal, literalType )+import Module      ( Module )+import Outputable+import Packages    ( isDllName )+import Platform+import PprCore     ( {- instances -} )+import PrimOp      ( PrimOp, PrimCall )+import TyCon       ( PrimRep(..), TyCon )+import Type        ( Type )+import RepType     ( typePrimRep1 )+import Unique      ( Unique )+import Util++import Data.List.NonEmpty ( NonEmpty, toList )++{-+************************************************************************+*                                                                      *+\subsection{@GenStgBinding@}+*                                                                      *+************************************************************************++As usual, expressions are interesting; other things are boring. Here+are the boring things [except note the @GenStgRhs@], parameterised+with respect to binder and occurrence information (just as in+@CoreSyn@):+-}++-- | A top-level binding.+data GenStgTopBinding pass+-- See Note [CoreSyn top-level string literals]+  = StgTopLifted (GenStgBinding pass)+  | StgTopStringLit Id ByteString++data GenStgBinding pass+  = StgNonRec (BinderP pass) (GenStgRhs pass)+  | StgRec    [(BinderP pass, GenStgRhs pass)]++{-+************************************************************************+*                                                                      *+\subsection{@StgArg@}+*                                                                      *+************************************************************************+-}++data StgArg+  = StgVarArg  Id+  | StgLitArg  Literal++-- | Does this constructor application refer to+-- anything in a different *Windows* DLL?+-- If so, we can't allocate it statically+isDllConApp :: DynFlags -> Module -> DataCon -> [StgArg] -> Bool+isDllConApp dflags this_mod con args+ | platformOS (targetPlatform dflags) == OSMinGW32+    = isDllName dflags this_mod (dataConName con) || any is_dll_arg args+ | otherwise = False+  where+    -- NB: typePrimRep1 is legit because any free variables won't have+    -- unlifted type (there are no unlifted things at top level)+    is_dll_arg :: StgArg -> Bool+    is_dll_arg (StgVarArg v) =  isAddrRep (typePrimRep1 (idType v))+                             && isDllName dflags this_mod (idName v)+    is_dll_arg _             = False++-- True of machine addresses; these are the things that don't+-- work across DLLs. The key point here is that VoidRep comes+-- out False, so that a top level nullary GADT constructor is+-- False for isDllConApp+--    data T a where+--      T1 :: T Int+-- gives+--    T1 :: forall a. (a~Int) -> T a+-- and hence the top-level binding+--    $WT1 :: T Int+--    $WT1 = T1 Int (Coercion (Refl Int))+-- The coercion argument here gets VoidRep+isAddrRep :: PrimRep -> Bool+isAddrRep AddrRep     = True+isAddrRep LiftedRep   = True+isAddrRep UnliftedRep = True+isAddrRep _           = False++-- | Type of an @StgArg@+--+-- Very half baked because we have lost the type arguments.+stgArgType :: StgArg -> Type+stgArgType (StgVarArg v)   = idType v+stgArgType (StgLitArg lit) = literalType lit+++-- | Strip ticks of a given type from an STG expression+stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p)+stripStgTicksTop p = go []+   where go ts (StgTick t e) | p t = go (t:ts) e+         go ts other               = (reverse ts, other)++-- | Given an alt type and whether the program is unarised, return whether the+-- case binder is in scope.+--+-- Case binders of unboxed tuple or unboxed sum type always dead after the+-- unariser has run. See Note [Post-unarisation invariants].+stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool+stgCaseBndrInScope alt_ty unarised =+    case alt_ty of+      AlgAlt _      -> True+      PrimAlt _     -> True+      MultiValAlt _ -> not unarised+      PolyAlt       -> True++{-+************************************************************************+*                                                                      *+\subsection{STG expressions}+*                                                                      *+************************************************************************++The @GenStgExpr@ data type is parameterised on binder and occurrence+info, as before.++************************************************************************+*                                                                      *+\subsubsection{@GenStgExpr@ application}+*                                                                      *+************************************************************************++An application is of a function to a list of atoms [not expressions].+Operationally, we want to push the arguments on the stack and call the+function. (If the arguments were expressions, we would have to build+their closures first.)++There is no constructor for a lone variable; it would appear as+@StgApp var []@.+-}++data GenStgExpr pass+  = StgApp+        Id       -- function+        [StgArg] -- arguments; may be empty++{-+************************************************************************+*                                                                      *+\subsubsection{@StgConApp@ and @StgPrimApp@---saturated applications}+*                                                                      *+************************************************************************++There are specialised forms of application, for constructors,+primitives, and literals.+-}++  | StgLit      Literal++        -- StgConApp is vital for returning unboxed tuples or sums+        -- which can't be let-bound first+  | StgConApp   DataCon+                [StgArg] -- Saturated+                [Type]   -- See Note [Types in StgConApp] in UnariseStg++  | StgOpApp    StgOp    -- Primitive op or foreign call+                [StgArg] -- Saturated.+                Type     -- Result type+                         -- We need to know this so that we can+                         -- assign result registers++{-+************************************************************************+*                                                                      *+\subsubsection{@StgLam@}+*                                                                      *+************************************************************************++StgLam is used *only* during CoreToStg's work. Before CoreToStg has+finished it encodes (\x -> e) as (let f = \x -> e in f)+TODO: Encode this via an extension to GenStgExpr à la TTG.+-}++  | StgLam+        (NonEmpty (BinderP pass))+        StgExpr    -- Body of lambda++{-+************************************************************************+*                                                                      *+\subsubsection{@GenStgExpr@: case-expressions}+*                                                                      *+************************************************************************++This has the same boxed/unboxed business as Core case expressions.+-}++  | StgCase+        (GenStgExpr pass) -- the thing to examine+        (BinderP pass) -- binds the result of evaluating the scrutinee+        AltType+        [GenStgAlt pass]+                    -- The DEFAULT case is always *first*+                    -- if it is there at all++{-+************************************************************************+*                                                                      *+\subsubsection{@GenStgExpr@: @let(rec)@-expressions}+*                                                                      *+************************************************************************++The various forms of let(rec)-expression encode most of the+interesting things we want to do.+\begin{enumerate}+\item+\begin{verbatim}+let-closure x = [free-vars] [args] expr+in e+\end{verbatim}+is equivalent to+\begin{verbatim}+let x = (\free-vars -> \args -> expr) free-vars+\end{verbatim}+\tr{args} may be empty (and is for most closures).  It isn't under+circumstances like this:+\begin{verbatim}+let x = (\y -> y+z)+\end{verbatim}+This gets mangled to+\begin{verbatim}+let-closure x = [z] [y] (y+z)+\end{verbatim}+The idea is that we compile code for @(y+z)@ in an environment in which+@z@ is bound to an offset from \tr{Node}, and @y@ is bound to an+offset from the stack pointer.++(A let-closure is an @StgLet@ with a @StgRhsClosure@ RHS.)++\item+\begin{verbatim}+let-constructor x = Constructor [args]+in e+\end{verbatim}++(A let-constructor is an @StgLet@ with a @StgRhsCon@ RHS.)++\item+Letrec-expressions are essentially the same deal as+let-closure/let-constructor, so we use a common structure and+distinguish between them with an @is_recursive@ boolean flag.++\item+\begin{verbatim}+let-unboxed u = an arbitrary arithmetic expression in unboxed values+in e+\end{verbatim}+All the stuff on the RHS must be fully evaluated.+No function calls either!++(We've backed away from this toward case-expressions with+suitably-magical alts ...)++\item+~[Advanced stuff here! Not to start with, but makes pattern matching+generate more efficient code.]++\begin{verbatim}+let-escapes-not fail = expr+in e'+\end{verbatim}+Here the idea is that @e'@ guarantees not to put @fail@ in a data structure,+or pass it to another function. All @e'@ will ever do is tail-call @fail@.+Rather than build a closure for @fail@, all we need do is to record the stack+level at the moment of the @let-escapes-not@; then entering @fail@ is just+a matter of adjusting the stack pointer back down to that point and entering+the code for it.++Another example:+\begin{verbatim}+f x y = let z = huge-expression in+        if y==1 then z else+        if y==2 then z else+        1+\end{verbatim}++(A let-escapes-not is an @StgLetNoEscape@.)++\item+We may eventually want:+\begin{verbatim}+let-literal x = Literal+in e+\end{verbatim}+\end{enumerate}++And so the code for let(rec)-things:+-}++  | StgLet+        (XLet pass)+        (GenStgBinding pass)    -- right hand sides (see below)+        (GenStgExpr pass)       -- body++  | StgLetNoEscape+        (XLetNoEscape pass)+        (GenStgBinding pass)    -- right hand sides (see below)+        (GenStgExpr pass)       -- body++{-+%************************************************************************+%*                                                                      *+\subsubsection{@GenStgExpr@: @hpc@, @scc@ and other debug annotations}+%*                                                                      *+%************************************************************************++Finally for @hpc@ expressions we introduce a new STG construct.+-}++  | StgTick+    (Tickish Id)+    (GenStgExpr pass)       -- sub expression++-- END of GenStgExpr++{-+************************************************************************+*                                                                      *+\subsection{STG right-hand sides}+*                                                                      *+************************************************************************++Here's the rest of the interesting stuff for @StgLet@s; the first+flavour is for closures:+-}++data GenStgRhs pass+  = StgRhsClosure+        (XRhsClosure pass) -- ^ Extension point for non-global free var+                           --   list just before 'CodeGen'.+        CostCentreStack    -- ^ CCS to be attached (default is CurrentCCS)+        !UpdateFlag        -- ^ 'ReEntrant' | 'Updatable' | 'SingleEntry'+        [BinderP pass]     -- ^ arguments; if empty, then not a function;+                           --   as above, order is important.+        (GenStgExpr pass)  -- ^ body++{-+An example may be in order.  Consider:+\begin{verbatim}+let t = \x -> \y -> ... x ... y ... p ... q in e+\end{verbatim}+Pulling out the free vars and stylising somewhat, we get the equivalent:+\begin{verbatim}+let t = (\[p,q] -> \[x,y] -> ... x ... y ... p ...q) p q+\end{verbatim}+Stg-operationally, the @[x,y]@ are on the stack, the @[p,q]@ are+offsets from @Node@ into the closure, and the code ptr for the closure+will be exactly that in parentheses above.++The second flavour of right-hand-side is for constructors (simple but important):+-}++  | StgRhsCon+        CostCentreStack -- CCS to be attached (default is CurrentCCS).+                        -- Top-level (static) ones will end up with+                        -- DontCareCCS, because we don't count static+                        -- data in heap profiles, and we don't set CCCS+                        -- from static closure.+        DataCon         -- Constructor. Never an unboxed tuple or sum, as those+                        -- are not allocated.+        [StgArg]        -- Args++-- | Used as a data type index for the stgSyn AST+data StgPass+  = Vanilla+  | LiftLams+  | CodeGen++-- | Like 'HsExpression.NoExt', but with an 'Outputable' instance that returns+-- 'empty'.+data NoExtSilent = NoExtSilent+  deriving (Data, Eq, Ord)++instance Outputable NoExtSilent where+  ppr _ = empty++-- | Used when constructing a term with an unused extension point that should+-- not appear in pretty-printed output at all.+noExtSilent :: NoExtSilent+noExtSilent = NoExtSilent+-- TODO: Maybe move this to HsExtensions? I'm not sure about the implications+-- on build time...++-- TODO: Do we really want to the extension point type families to have a closed+-- domain?+type family BinderP (pass :: StgPass)+type instance BinderP 'Vanilla = Id+type instance BinderP 'CodeGen = Id++type family XRhsClosure (pass :: StgPass)+type instance XRhsClosure 'Vanilla = NoExtSilent+-- | Code gen needs to track non-global free vars+type instance XRhsClosure 'CodeGen = DIdSet++type family XLet (pass :: StgPass)+type instance XLet 'Vanilla = NoExtSilent+type instance XLet 'CodeGen = NoExtSilent++type family XLetNoEscape (pass :: StgPass)+type instance XLetNoEscape 'Vanilla = NoExtSilent+type instance XLetNoEscape 'CodeGen = NoExtSilent++stgRhsArity :: StgRhs -> Int+stgRhsArity (StgRhsClosure _ _ _ bndrs _)+  = ASSERT( all isId bndrs ) length bndrs+  -- The arity never includes type parameters, but they should have gone by now+stgRhsArity (StgRhsCon _ _ _) = 0++-- Note [CAF consistency]+-- ~~~~~~~~~~~~~~~~~~~~~~+--+-- `topStgBindHasCafRefs` is only used by an assert (`consistentCafInfo` in+-- `CoreToStg`) to make sure CAF-ness predicted by `TidyPgm` is consistent with+-- reality.+--+-- Specifically, if the RHS mentions any Id that itself is marked+-- `MayHaveCafRefs`; or if the binding is a top-level updateable thunk; then the+-- `Id` for the binding should be marked `MayHaveCafRefs`. The potential trouble+-- is that `TidyPgm` computed the CAF info on the `Id` but some transformations+-- have taken place since then.++topStgBindHasCafRefs :: GenStgTopBinding pass -> Bool+topStgBindHasCafRefs (StgTopLifted (StgNonRec _ rhs))+  = topRhsHasCafRefs rhs+topStgBindHasCafRefs (StgTopLifted (StgRec binds))+  = any topRhsHasCafRefs (map snd binds)+topStgBindHasCafRefs StgTopStringLit{}+  = False++topRhsHasCafRefs :: GenStgRhs pass -> Bool+topRhsHasCafRefs (StgRhsClosure _ _ upd _ body)+  = -- See Note [CAF consistency]+    isUpdatable upd || exprHasCafRefs body+topRhsHasCafRefs (StgRhsCon _ _ args)+  = any stgArgHasCafRefs args++exprHasCafRefs :: GenStgExpr pass -> Bool+exprHasCafRefs (StgApp f args)+  = stgIdHasCafRefs f || any stgArgHasCafRefs args+exprHasCafRefs StgLit{}+  = False+exprHasCafRefs (StgConApp _ args _)+  = any stgArgHasCafRefs args+exprHasCafRefs (StgOpApp _ args _)+  = any stgArgHasCafRefs args+exprHasCafRefs (StgLam _ body)+  = exprHasCafRefs body+exprHasCafRefs (StgCase scrt _ _ alts)+  = exprHasCafRefs scrt || any altHasCafRefs alts+exprHasCafRefs (StgLet _ bind body)+  = bindHasCafRefs bind || exprHasCafRefs body+exprHasCafRefs (StgLetNoEscape _ bind body)+  = bindHasCafRefs bind || exprHasCafRefs body+exprHasCafRefs (StgTick _ expr)+  = exprHasCafRefs expr++bindHasCafRefs :: GenStgBinding pass -> Bool+bindHasCafRefs (StgNonRec _ rhs)+  = rhsHasCafRefs rhs+bindHasCafRefs (StgRec binds)+  = any rhsHasCafRefs (map snd binds)++rhsHasCafRefs :: GenStgRhs pass -> Bool+rhsHasCafRefs (StgRhsClosure _ _ _ _ body)+  = exprHasCafRefs body+rhsHasCafRefs (StgRhsCon _ _ args)+  = any stgArgHasCafRefs args++altHasCafRefs :: GenStgAlt pass -> Bool+altHasCafRefs (_, _, rhs) = exprHasCafRefs rhs++stgArgHasCafRefs :: StgArg -> Bool+stgArgHasCafRefs (StgVarArg id)+  = stgIdHasCafRefs id+stgArgHasCafRefs _+  = False++stgIdHasCafRefs :: Id -> Bool+stgIdHasCafRefs id =+  -- We are looking for occurrences of an Id that is bound at top level, and may+  -- have CAF refs. At this point (after TidyPgm) top-level Ids (whether+  -- imported or defined in this module) are GlobalIds, so the test is easy.+  isGlobalId id && mayHaveCafRefs (idCafInfo id)++{-+************************************************************************+*                                                                      *+\subsection[Stg-case-alternatives]{STG case alternatives}+*                                                                      *+************************************************************************++Very like in @CoreSyntax@ (except no type-world stuff).++The type constructor is guaranteed not to be abstract; that is, we can+see its representation. This is important because the code generator+uses it to determine return conventions etc. But it's not trivial+where there's a module loop involved, because some versions of a type+constructor might not have all the constructors visible. So+mkStgAlgAlts (in CoreToStg) ensures that it gets the TyCon from the+constructors or literals (which are guaranteed to have the Real McCoy)+rather than from the scrutinee type.+-}++type GenStgAlt pass+  = (AltCon,          -- alts: data constructor,+     [BinderP pass],  -- constructor's parameters,+     GenStgExpr pass) -- ...right-hand side.++data AltType+  = PolyAlt             -- Polymorphic (a lifted type variable)+  | MultiValAlt Int     -- Multi value of this arity (unboxed tuple or sum)+                        -- the arity could indeed be 1 for unary unboxed tuple+                        -- or enum-like unboxed sums+  | AlgAlt      TyCon   -- Algebraic data type; the AltCons will be DataAlts+  | PrimAlt     PrimRep -- Primitive data type; the AltCons (if any) will be LitAlts++{-+************************************************************************+*                                                                      *+\subsection[Stg]{The Plain STG parameterisation}+*                                                                      *+************************************************************************++This happens to be the only one we use at the moment.+-}++type StgTopBinding = GenStgTopBinding 'Vanilla+type StgBinding    = GenStgBinding    'Vanilla+type StgExpr       = GenStgExpr       'Vanilla+type StgRhs        = GenStgRhs        'Vanilla+type StgAlt        = GenStgAlt        'Vanilla++type LlStgTopBinding = GenStgTopBinding 'LiftLams+type LlStgBinding    = GenStgBinding    'LiftLams+type LlStgExpr       = GenStgExpr       'LiftLams+type LlStgRhs        = GenStgRhs        'LiftLams+type LlStgAlt        = GenStgAlt        'LiftLams++type CgStgTopBinding = GenStgTopBinding 'CodeGen+type CgStgBinding    = GenStgBinding    'CodeGen+type CgStgExpr       = GenStgExpr       'CodeGen+type CgStgRhs        = GenStgRhs        'CodeGen+type CgStgAlt        = GenStgAlt        'CodeGen++{- Many passes apply a substitution, and it's very handy to have type+   synonyms to remind us whether or not the substitution has been applied.+   See CoreSyn for precedence in Core land+-}++type InStgTopBinding  = StgTopBinding+type InStgBinding     = StgBinding+type InStgArg         = StgArg+type InStgExpr        = StgExpr+type InStgRhs         = StgRhs+type InStgAlt         = StgAlt+type OutStgTopBinding = StgTopBinding+type OutStgBinding    = StgBinding+type OutStgArg        = StgArg+type OutStgExpr       = StgExpr+type OutStgRhs        = StgRhs+type OutStgAlt        = StgAlt++{-++************************************************************************+*                                                                      *+\subsubsection[UpdateFlag-datatype]{@UpdateFlag@}+*                                                                      *+************************************************************************++This is also used in @LambdaFormInfo@ in the @ClosureInfo@ module.++A @ReEntrant@ closure may be entered multiple times, but should not be+updated or blackholed. An @Updatable@ closure should be updated after+evaluation (and may be blackholed during evaluation). A @SingleEntry@+closure will only be entered once, and so need not be updated but may+safely be blackholed.+-}++data UpdateFlag = ReEntrant | Updatable | SingleEntry++instance Outputable UpdateFlag where+    ppr u = char $ case u of+                       ReEntrant   -> 'r'+                       Updatable   -> 'u'+                       SingleEntry -> 's'++isUpdatable :: UpdateFlag -> Bool+isUpdatable ReEntrant   = False+isUpdatable SingleEntry = False+isUpdatable Updatable   = True++{-+************************************************************************+*                                                                      *+\subsubsection{StgOp}+*                                                                      *+************************************************************************++An StgOp allows us to group together PrimOps and ForeignCalls.+It's quite useful to move these around together, notably+in StgOpApp and COpStmt.+-}++data StgOp+  = StgPrimOp  PrimOp++  | StgPrimCallOp PrimCall++  | StgFCallOp ForeignCall Unique+        -- The Unique is occasionally needed by the C pretty-printer+        -- (which lacks a unique supply), notably when generating a+        -- typedef for foreign-export-dynamic++{-+************************************************************************+*                                                                      *+\subsection[Stg-pretty-printing]{Pretty-printing}+*                                                                      *+************************************************************************++Robin Popplestone asked for semi-colon separators on STG binds; here's+hoping he likes terminators instead...  Ditto for case alternatives.+-}++type OutputablePass pass =+  ( Outputable (XLet pass)+  , Outputable (XLetNoEscape pass)+  , Outputable (XRhsClosure pass)+  , OutputableBndr (BinderP pass)+  )++pprGenStgTopBinding+  :: OutputablePass pass => GenStgTopBinding pass -> SDoc+pprGenStgTopBinding (StgTopStringLit bndr str)+  = hang (hsep [pprBndr LetBind bndr, equals])+        4 (pprHsBytes str <> semi)+pprGenStgTopBinding (StgTopLifted bind)+  = pprGenStgBinding bind++pprGenStgBinding+  :: OutputablePass pass => GenStgBinding pass -> SDoc++pprGenStgBinding (StgNonRec bndr rhs)+  = hang (hsep [pprBndr LetBind bndr, equals])+        4 (ppr rhs <> semi)++pprGenStgBinding (StgRec pairs)+  = vcat [ text "Rec {"+         , vcat (map ppr_bind pairs)+         , text "end Rec }" ]+  where+    ppr_bind (bndr, expr)+      = hang (hsep [pprBndr LetBind bndr, equals])+             4 (ppr expr <> semi)++pprGenStgTopBindings+  :: (OutputablePass pass) => [GenStgTopBinding pass] -> SDoc+pprGenStgTopBindings binds+  = vcat $ intersperse blankLine (map pprGenStgTopBinding binds)++pprStgBinding :: StgBinding -> SDoc+pprStgBinding = pprGenStgBinding++pprStgTopBindings :: [StgTopBinding] -> SDoc+pprStgTopBindings = pprGenStgTopBindings++instance Outputable StgArg where+    ppr = pprStgArg++instance OutputablePass pass => Outputable (GenStgTopBinding pass) where+    ppr = pprGenStgTopBinding++instance OutputablePass pass => Outputable (GenStgBinding pass) where+    ppr = pprGenStgBinding++instance OutputablePass pass => Outputable (GenStgExpr pass) where+    ppr = pprStgExpr++instance OutputablePass pass => Outputable (GenStgRhs pass) where+    ppr rhs = pprStgRhs rhs++pprStgArg :: StgArg -> SDoc+pprStgArg (StgVarArg var) = ppr var+pprStgArg (StgLitArg con) = ppr con++pprStgExpr :: OutputablePass pass => GenStgExpr pass -> SDoc+-- special case+pprStgExpr (StgLit lit)     = ppr lit++-- general case+pprStgExpr (StgApp func args)+  = hang (ppr func) 4 (sep (map (ppr) args))++pprStgExpr (StgConApp con args _)+  = hsep [ ppr con, brackets (interppSP args) ]++pprStgExpr (StgOpApp op args _)+  = hsep [ pprStgOp op, brackets (interppSP args)]++pprStgExpr (StgLam bndrs body)+  = sep [ char '\\' <+> ppr_list (map (pprBndr LambdaBind) (toList bndrs))+            <+> text "->",+         pprStgExpr body ]+  where ppr_list = brackets . fsep . punctuate comma++-- special case: let v = <very specific thing>+--               in+--               let ...+--               in+--               ...+--+-- Very special!  Suspicious! (SLPJ)++{-+pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))+                        expr@(StgLet _ _))+  = ($$)+      (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "),+                          ppr cc,+                          pp_binder_info bi,+                          text " [", whenPprDebug (interppSP free_vars), ptext (sLit "] \\"),+                          ppr upd_flag, text " [",+                          interppSP args, char ']'])+            8 (sep [hsep [ppr rhs, text "} in"]]))+      (ppr expr)+-}++-- special case: let ... in let ...++pprStgExpr (StgLet ext bind expr@StgLet{})+  = ($$)+      (sep [hang (text "let" <+> ppr ext <+> text "{")+                2 (hsep [pprGenStgBinding bind, text "} in"])])+      (ppr expr)++-- general case+pprStgExpr (StgLet ext bind expr)+  = sep [hang (text "let" <+> ppr ext <+> text "{") 2 (pprGenStgBinding bind),+           hang (text "} in ") 2 (ppr expr)]++pprStgExpr (StgLetNoEscape ext bind expr)+  = sep [hang (text "let-no-escape" <+> ppr ext <+> text "{")+                2 (pprGenStgBinding bind),+           hang (text "} in ")+                2 (ppr expr)]++pprStgExpr (StgTick tickish expr)+  = sdocWithDynFlags $ \dflags ->+    if gopt Opt_SuppressTicks dflags+    then pprStgExpr expr+    else sep [ ppr tickish, pprStgExpr expr ]+++-- Don't indent for a single case alternative.+pprStgExpr (StgCase expr bndr alt_type [alt])+  = sep [sep [text "case",+           nest 4 (hsep [pprStgExpr expr,+             whenPprDebug (dcolon <+> ppr alt_type)]),+           text "of", pprBndr CaseBind bndr, char '{'],+           pprStgAlt False alt,+           char '}']++pprStgExpr (StgCase expr bndr alt_type alts)+  = sep [sep [text "case",+           nest 4 (hsep [pprStgExpr expr,+             whenPprDebug (dcolon <+> ppr alt_type)]),+           text "of", pprBndr CaseBind bndr, char '{'],+           nest 2 (vcat (map (pprStgAlt True) alts)),+           char '}']+++pprStgAlt :: OutputablePass pass => Bool -> GenStgAlt pass -> SDoc+pprStgAlt indent (con, params, expr)+  | indent    = hang altPattern 4 (ppr expr <> semi)+  | otherwise = sep [altPattern, ppr expr <> semi]+    where+      altPattern = (hsep [ppr con, sep (map (pprBndr CasePatBind) params), text "->"])+++pprStgOp :: StgOp -> SDoc+pprStgOp (StgPrimOp  op)   = ppr op+pprStgOp (StgPrimCallOp op)= ppr op+pprStgOp (StgFCallOp op _) = ppr op++instance Outputable AltType where+  ppr PolyAlt         = text "Polymorphic"+  ppr (MultiValAlt n) = text "MultiAlt" <+> ppr n+  ppr (AlgAlt tc)     = text "Alg"    <+> ppr tc+  ppr (PrimAlt tc)    = text "Prim"   <+> ppr tc++pprStgRhs :: OutputablePass pass => GenStgRhs pass -> SDoc++-- special case+pprStgRhs (StgRhsClosure ext cc upd_flag [{-no args-}] (StgApp func []))+  = sdocWithDynFlags $ \dflags ->+    hsep [ ppr cc,+           if not $ gopt Opt_SuppressStgExts dflags+             then ppr ext else empty,+           text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ]++-- general case+pprStgRhs (StgRhsClosure ext cc upd_flag args body)+  = sdocWithDynFlags $ \dflags ->+    hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,+                if not $ gopt Opt_SuppressStgExts dflags+                  then ppr ext else empty,+                char '\\' <> ppr upd_flag, brackets (interppSP args)])+         4 (ppr body)++pprStgRhs (StgRhsCon cc con args)+  = hcat [ ppr cc,+           space, ppr con, text "! ", brackets (interppSP args)]
+ compiler/stranal/DmdAnal.hs view
@@ -0,0 +1,1571 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998+++                        -----------------+                        A demand analysis+                        -----------------+-}++{-# LANGUAGE CPP #-}++module DmdAnal ( dmdAnalProgram ) where++#include "HsVersions.h"++import GhcPrelude++import DynFlags+import WwLib            ( findTypeShape, deepSplitProductType_maybe )+import Demand   -- All of it+import CoreSyn+import CoreSeq          ( seqBinds )+import Outputable+import VarEnv+import BasicTypes+import Data.List+import DataCon+import Id+import CoreUtils        ( exprIsHNF, exprType, exprIsTrivial, exprOkForSpeculation )+import TyCon+import Type+import Coercion         ( Coercion, coVarsOfCo )+import FamInstEnv+import Util+import Maybes           ( isJust )+import TysWiredIn+import TysPrim          ( realWorldStatePrimTy )+import ErrUtils         ( dumpIfSet_dyn )+import Name             ( getName, stableNameCmp )+import Data.Function    ( on )+import UniqSet++{-+************************************************************************+*                                                                      *+\subsection{Top level stuff}+*                                                                      *+************************************************************************+-}++dmdAnalProgram :: DynFlags -> FamInstEnvs -> CoreProgram -> IO CoreProgram+dmdAnalProgram dflags fam_envs binds+  = do {+        let { binds_plus_dmds = do_prog binds } ;+        dumpIfSet_dyn dflags Opt_D_dump_str_signatures+                      "Strictness signatures" $+            dumpStrSig binds_plus_dmds ;+        -- See Note [Stamp out space leaks in demand analysis]+        seqBinds binds_plus_dmds `seq` return binds_plus_dmds+    }+  where+    do_prog :: CoreProgram -> CoreProgram+    do_prog binds = snd $ mapAccumL dmdAnalTopBind (emptyAnalEnv dflags fam_envs) binds++-- Analyse a (group of) top-level binding(s)+dmdAnalTopBind :: AnalEnv+               -> CoreBind+               -> (AnalEnv, CoreBind)+dmdAnalTopBind env (NonRec id rhs)+  = (extendAnalEnv TopLevel env id2 (idStrictness id2), NonRec id2 rhs2)+  where+    ( _, _,   rhs1) = dmdAnalRhsLetDown TopLevel Nothing env             cleanEvalDmd id rhs+    ( _, id2, rhs2) = dmdAnalRhsLetDown TopLevel Nothing (nonVirgin env) cleanEvalDmd id rhs1+        -- Do two passes to improve CPR information+        -- See Note [CPR for thunks]+        -- See Note [Optimistic CPR in the "virgin" case]+        -- See Note [Initial CPR for strict binders]++dmdAnalTopBind env (Rec pairs)+  = (env', Rec pairs')+  where+    (env', _, pairs')  = dmdFix TopLevel env cleanEvalDmd pairs+                -- We get two iterations automatically+                -- c.f. the NonRec case above++{- Note [Stamp out space leaks in demand analysis]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The demand analysis pass outputs a new copy of the Core program in+which binders have been annotated with demand and strictness+information. It's tiresome to ensure that this information is fully+evaluated everywhere that we produce it, so we just run a single+seqBinds over the output before returning it, to ensure that there are+no references holding on to the input Core program.++This makes a ~30% reduction in peak memory usage when compiling+DynFlags (cf #9675 and #13426).++This is particularly important when we are doing late demand analysis,+since we don't do a seqBinds at any point thereafter. Hence code+generation would hold on to an extra copy of the Core program, via+unforced thunks in demand or strictness information; and it is the+most memory-intensive part of the compilation process, so this added+seqBinds makes a big difference in peak memory usage.+-}+++{-+************************************************************************+*                                                                      *+\subsection{The analyser itself}+*                                                                      *+************************************************************************++Note [Ensure demand is strict]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important not to analyse e with a lazy demand because+a) When we encounter   case s of (a,b) ->+        we demand s with U(d1d2)... but if the overall demand is lazy+        that is wrong, and we'd need to reduce the demand on s,+        which is inconvenient+b) More important, consider+        f (let x = R in x+x), where f is lazy+   We still want to mark x as demanded, because it will be when we+   enter the let.  If we analyse f's arg with a Lazy demand, we'll+   just mark x as Lazy+c) The application rule wouldn't be right either+   Evaluating (f x) in a L demand does *not* cause+   evaluation of f in a C(L) demand!+-}++-- If e is complicated enough to become a thunk, its contents will be evaluated+-- at most once, so oneify it.+dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand+dmdTransformThunkDmd e+  | exprIsTrivial e = id+  | otherwise       = oneifyDmd++-- Do not process absent demands+-- Otherwise act like in a normal demand analysis+-- See ↦* relation in the Cardinality Analysis paper+dmdAnalStar :: AnalEnv+            -> Demand   -- This one takes a *Demand*+            -> CoreExpr -- Should obey the let/app invariatn+            -> (BothDmdArg, CoreExpr)+dmdAnalStar env dmd e+  | (dmd_shell, cd) <- toCleanDmd dmd+  , (dmd_ty, e')    <- dmdAnal env cd e+  = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )+    -- The argument 'e' should satisfy the let/app invariant+    -- See Note [Analysing with absent demand] in Demand.hs+    (postProcessDmdType dmd_shell dmd_ty, e')++-- Main Demand Analsysis machinery+dmdAnal, dmdAnal' :: AnalEnv+        -> CleanDemand         -- The main one takes a *CleanDemand*+        -> CoreExpr -> (DmdType, CoreExpr)++-- The CleanDemand is always strict and not absent+--    See Note [Ensure demand is strict]++dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $+                  dmdAnal' env d e++dmdAnal' _ _ (Lit lit)     = (nopDmdType, Lit lit)+dmdAnal' _ _ (Type ty)     = (nopDmdType, Type ty)      -- Doesn't happen, in fact+dmdAnal' _ _ (Coercion co)+  = (unitDmdType (coercionDmdEnv co), Coercion co)++dmdAnal' env dmd (Var var)+  = (dmdTransform env var dmd, Var var)++dmdAnal' env dmd (Cast e co)+  = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co)+  where+    (dmd_ty, e') = dmdAnal env dmd e++dmdAnal' env dmd (Tick t e)+  = (dmd_ty, Tick t e')+  where+    (dmd_ty, e') = dmdAnal env dmd e++dmdAnal' env dmd (App fun (Type ty))+  = (fun_ty, App fun' (Type ty))+  where+    (fun_ty, fun') = dmdAnal env dmd fun++-- Lots of the other code is there to make this+-- beautiful, compositional, application rule :-)+dmdAnal' env dmd (App fun arg)+  = -- This case handles value arguments (type args handled above)+    -- Crucially, coercions /are/ handled here, because they are+    -- value arguments (#10288)+    let+        call_dmd          = mkCallDmd dmd+        (fun_ty, fun')    = dmdAnal env call_dmd fun+        (arg_dmd, res_ty) = splitDmdTy fun_ty+        (arg_ty, arg')    = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg+    in+--    pprTrace "dmdAnal:app" (vcat+--         [ text "dmd =" <+> ppr dmd+--         , text "expr =" <+> ppr (App fun arg)+--         , text "fun dmd_ty =" <+> ppr fun_ty+--         , text "arg dmd =" <+> ppr arg_dmd+--         , text "arg dmd_ty =" <+> ppr arg_ty+--         , text "res dmd_ty =" <+> ppr res_ty+--         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])+    (res_ty `bothDmdType` arg_ty, App fun' arg')++dmdAnal' env dmd (Lam var body)+  | isTyVar var+  = let+        (body_ty, body') = dmdAnal env dmd body+    in+    (body_ty, Lam var body')++  | otherwise+  = let (body_dmd, defer_and_use) = peelCallDmd dmd+          -- body_dmd: a demand to analyze the body++        env'             = extendSigsWithLam env var+        (body_ty, body') = dmdAnal env' body_dmd body+        (lam_ty, var')   = annotateLamIdBndr env notArgOfDfun body_ty var+    in+    (postProcessUnsat defer_and_use lam_ty, Lam var' body')++dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])+  -- Only one alternative with a product constructor+  | let tycon = dataConTyCon dc+  , isJust (isDataProductTyCon_maybe tycon)+  , Just rec_tc' <- checkRecTc (ae_rec_tc env) tycon+  = let+        env_w_tc                 = env { ae_rec_tc = rec_tc' }+        env_alt                  = extendEnvForProdAlt env_w_tc scrut case_bndr dc bndrs+        (rhs_ty, rhs')           = dmdAnal env_alt dmd rhs+        (alt_ty1, dmds)          = findBndrsDmds env rhs_ty bndrs+        (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr+        id_dmds                  = addCaseBndrDmd case_bndr_dmd dmds+        alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2+                | otherwise                   = alt_ty2++        -- Compute demand on the scrutinee+        -- See Note [Demand on scrutinee of a product case]+        scrut_dmd          = mkProdDmd id_dmds+        (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut+        res_ty             = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty+        case_bndr'         = setIdDemandInfo case_bndr case_bndr_dmd+        bndrs'             = setBndrsDemandInfo bndrs id_dmds+    in+--    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut+--                                   , text "dmd" <+> ppr dmd+--                                   , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr')+--                                   , text "id_dmds" <+> ppr id_dmds+--                                   , text "scrut_dmd" <+> ppr scrut_dmd+--                                   , text "scrut_ty" <+> ppr scrut_ty+--                                   , text "alt_ty" <+> ppr alt_ty2+--                                   , text "res_ty" <+> ppr res_ty ]) $+    (res_ty, Case scrut' case_bndr' ty [(DataAlt dc, bndrs', rhs')])++dmdAnal' env dmd (Case scrut case_bndr ty alts)+  = let      -- Case expression with multiple alternatives+        (alt_tys, alts')     = mapAndUnzip (dmdAnalAlt env dmd case_bndr) alts+        (scrut_ty, scrut')   = dmdAnal env cleanEvalDmd scrut+        (alt_ty, case_bndr') = annotateBndr env (foldr lubDmdType botDmdType alt_tys) case_bndr+                               -- NB: Base case is botDmdType, for empty case alternatives+                               --     This is a unit for lubDmdType, and the right result+                               --     when there really are no alternatives+        res_ty               = alt_ty `bothDmdType` toBothDmdArg scrut_ty+    in+--    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut+--                                   , text "scrut_ty" <+> ppr scrut_ty+--                                   , text "alt_tys" <+> ppr alt_tys+--                                   , text "alt_ty" <+> ppr alt_ty+--                                   , text "res_ty" <+> ppr res_ty ]) $+    (res_ty, Case scrut' case_bndr' ty alts')++-- Let bindings can be processed in two ways:+-- Down (RHS before body) or Up (body before RHS).+-- The following case handle the up variant.+--+-- It is very simple. For  let x = rhs in body+--   * Demand-analyse 'body' in the current environment+--   * Find the demand, 'rhs_dmd' placed on 'x' by 'body'+--   * Demand-analyse 'rhs' in 'rhs_dmd'+--+-- This is used for a non-recursive local let without manifest lambdas.+-- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.+dmdAnal' env dmd (Let (NonRec id rhs) body)+  | useLetUp id+  = (final_ty, Let (NonRec id' rhs') body')+  where+    (body_ty, body')   = dmdAnal env dmd body+    (body_ty', id_dmd) = findBndrDmd env notArgOfDfun body_ty id+    id'                = setIdDemandInfo id id_dmd++    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs+    final_ty           = body_ty' `bothDmdType` rhs_ty++dmdAnal' env dmd (Let (NonRec id rhs) body)+  = (body_ty2, Let (NonRec id2 rhs') body')+  where+    (lazy_fv, id1, rhs') = dmdAnalRhsLetDown NotTopLevel Nothing env dmd id rhs+    env1                 = extendAnalEnv NotTopLevel env id1 (idStrictness id1)+    (body_ty, body')     = dmdAnal env1 dmd body+    (body_ty1, id2)      = annotateBndr env body_ty id1+    body_ty2             = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]++        -- If the actual demand is better than the vanilla call+        -- demand, you might think that we might do better to re-analyse+        -- the RHS with the stronger demand.+        -- But (a) That seldom happens, because it means that *every* path in+        --         the body of the let has to use that stronger demand+        -- (b) It often happens temporarily in when fixpointing, because+        --     the recursive function at first seems to place a massive demand.+        --     But we don't want to go to extra work when the function will+        --     probably iterate to something less demanding.+        -- In practice, all the times the actual demand on id2 is more than+        -- the vanilla call demand seem to be due to (b).  So we don't+        -- bother to re-analyse the RHS.++dmdAnal' env dmd (Let (Rec pairs) body)+  = let+        (env', lazy_fv, pairs') = dmdFix NotTopLevel env dmd pairs+        (body_ty, body')        = dmdAnal env' dmd body+        body_ty1                = deleteFVs body_ty (map fst pairs)+        body_ty2                = addLazyFVs body_ty1 lazy_fv -- see Note [Lazy and unleashable free variables]+    in+    body_ty2 `seq`+    (body_ty2,  Let (Rec pairs') body')++io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool+-- See Note [IO hack in the demand analyser]+io_hack_reqd scrut con bndrs+  | (bndr:_) <- bndrs+  , con == tupleDataCon Unboxed 2+  , idType bndr `eqType` realWorldStatePrimTy+  , (fun, _) <- collectArgs scrut+  = case fun of+      Var f -> not (isPrimOpId f)+      _     -> True+  | otherwise+  = False++dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var)+dmdAnalAlt env dmd case_bndr (con,bndrs,rhs)+  | null bndrs    -- Literals, DEFAULT, and nullary constructors+  , (rhs_ty, rhs') <- dmdAnal env dmd rhs+  = (rhs_ty, (con, [], rhs'))++  | otherwise     -- Non-nullary data constructors+  , (rhs_ty, rhs') <- dmdAnal env dmd rhs+  , (alt_ty, dmds) <- findBndrsDmds env rhs_ty bndrs+  , let case_bndr_dmd = findIdDemand alt_ty case_bndr+        id_dmds       = addCaseBndrDmd case_bndr_dmd dmds+  = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs'))+++{- Note [IO hack in the demand analyser]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's a hack here for I/O operations.  Consider++     case foo x s of { (# s', r #) -> y }++Is this strict in 'y'? Often not! If foo x s performs some observable action+(including raising an exception with raiseIO#, modifying a mutable variable, or+even ending the program normally), then we must not force 'y' (which may fail+to terminate) until we have performed foo x s.++Hackish solution: spot the IO-like situation and add a virtual branch,+as if we had+     case foo x s of+        (# s, r #) -> y+        other      -> return ()+So the 'y' isn't necessarily going to be evaluated++A more complete example (#148, #1592) where this shows up is:+     do { let len = <expensive> ;+        ; when (...) (exitWith ExitSuccess)+        ; print len }++However, consider+  f x s = case getMaskingState# s of+            (# s, r #) ->+          case x of I# x2 -> ...++Here it is terribly sad to make 'f' lazy in 's'.  After all,+getMaskingState# is not going to diverge or throw an exception!  This+situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle+(on an MVar not an Int), and made a material difference.++So if the scrutinee is a primop call, we *don't* apply the+state hack:+  - If it is a simple, terminating one like getMaskingState,+    applying the hack is over-conservative.+  - If the primop is raise# then it returns bottom, so+    the case alternatives are already discarded.+  - If the primop can raise a non-IO exception, like+    divide by zero or seg-fault (eg writing an array+    out of bounds) then we don't mind evaluating 'x' first.++Note [Demand on the scrutinee of a product case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When figuring out the demand on the scrutinee of a product case,+we use the demands of the case alternative, i.e. id_dmds.+But note that these include the demand on the case binder;+see Note [Demand on case-alternative binders] in Demand.hs.+This is crucial. Example:+   f x = case x of y { (a,b) -> k y a }+If we just take scrut_demand = U(L,A), then we won't pass x to the+worker, so the worker will rebuild+     x = (a, absent-error)+and that'll crash.++Note [Aggregated demand for cardinality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use different strategies for strictness and usage/cardinality to+"unleash" demands captured on free variables by bindings. Let us+consider the example:++f1 y = let {-# NOINLINE h #-}+           h = y+       in  (h, h)++We are interested in obtaining cardinality demand U1 on |y|, as it is+used only in a thunk, and, therefore, is not going to be updated any+more. Therefore, the demand on |y|, captured and unleashed by usage of+|h| is U1. However, if we unleash this demand every time |h| is used,+and then sum up the effects, the ultimate demand on |y| will be U1 ++U1 = U. In order to avoid it, we *first* collect the aggregate demand+on |h| in the body of let-expression, and only then apply the demand+transformer:++transf[x](U) = {y |-> U1}++so the resulting demand on |y| is U1.++The situation is, however, different for strictness, where this+aggregating approach exhibits worse results because of the nature of+|both| operation for strictness. Consider the example:++f y c =+  let h x = y |seq| x+   in case of+        True  -> h True+        False -> y++It is clear that |f| is strict in |y|, however, the suggested analysis+will infer from the body of |let| that |h| is used lazily (as it is+used in one branch only), therefore lazy demand will be put on its+free variable |y|. Conversely, if the demand on |h| is unleashed right+on the spot, we will get the desired result, namely, that |f| is+strict in |y|.+++************************************************************************+*                                                                      *+                    Demand transformer+*                                                                      *+************************************************************************+-}++dmdTransform :: AnalEnv         -- The strictness environment+             -> Id              -- The function+             -> CleanDemand     -- The demand on the function+             -> DmdType         -- The demand type of the function in this context+        -- Returned DmdEnv includes the demand on+        -- this function plus demand on its free variables++dmdTransform env var dmd+  | isDataConWorkId var                          -- Data constructor+  = dmdTransformDataConSig (idArity var) (idStrictness var) dmd++  | gopt Opt_DmdTxDictSel (ae_dflags env),+    Just _ <- isClassOpId_maybe var -- Dictionary component selector+  = dmdTransformDictSelSig (idStrictness var) dmd++  | isGlobalId var                               -- Imported function+  = let res = dmdTransformSig (idStrictness var) dmd in+--    pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])+    res++  | Just (sig, top_lvl) <- lookupSigEnv env var  -- Local letrec bound thing+  , let fn_ty = dmdTransformSig sig dmd+  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $+    if isTopLevel top_lvl+    then fn_ty   -- Don't record top level things+    else addVarDmd fn_ty var (mkOnceUsedDmd dmd)++  | otherwise                                    -- Local non-letrec-bound thing+  = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))++{-+************************************************************************+*                                                                      *+\subsection{Bindings}+*                                                                      *+************************************************************************+-}++-- Recursive bindings+dmdFix :: TopLevelFlag+       -> AnalEnv                            -- Does not include bindings for this binding+       -> CleanDemand+       -> [(Id,CoreExpr)]+       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with stricness info++dmdFix top_lvl env let_dmd orig_pairs+  = loop 1 initial_pairs+  where+    bndrs = map fst orig_pairs++    -- See Note [Initialising strictness]+    initial_pairs | ae_virgin env = [(setIdStrictness id botSig, rhs) | (id, rhs) <- orig_pairs ]+                  | otherwise     = orig_pairs++    -- If fixed-point iteration does not yield a result we use this instead+    -- See Note [Safe abortion in the fixed-point iteration]+    abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])+    abort = (env, lazy_fv', zapped_pairs)+      where (lazy_fv, pairs') = step True (zapIdStrictness orig_pairs)+            -- Note [Lazy and unleashable free variables]+            non_lazy_fvs = plusVarEnvList $ map (strictSigDmdEnv . idStrictness . fst) pairs'+            lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_fvs+            zapped_pairs = zapIdStrictness pairs'++    -- The fixed-point varies the idStrictness field of the binders, and terminates if that+    -- annotation does not change any more.+    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, DmdEnv, [(Id,CoreExpr)])+    loop n pairs+      | found_fixpoint = (final_anal_env, lazy_fv, pairs')+      | n == 10        = abort+      | otherwise      = loop (n+1) pairs'+      where+        found_fixpoint    = map (idStrictness . fst) pairs' == map (idStrictness . fst) pairs+        first_round       = n == 1+        (lazy_fv, pairs') = step first_round pairs+        final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')++    step :: Bool -> [(Id, CoreExpr)] -> (DmdEnv, [(Id, CoreExpr)])+    step first_round pairs = (lazy_fv, pairs')+      where+        -- In all but the first iteration, delete the virgin flag+        start_env | first_round = env+                  | otherwise   = nonVirgin env++        start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyDmdEnv)++        ((_,lazy_fv), pairs') = mapAccumL my_downRhs start pairs+                -- mapAccumL: Use the new signature to do the next pair+                -- The occurrence analyser has arranged them in a good order+                -- so this can significantly reduce the number of iterations needed++        my_downRhs (env, lazy_fv) (id,rhs)+          = ((env', lazy_fv'), (id', rhs'))+          where+            (lazy_fv1, id', rhs') = dmdAnalRhsLetDown top_lvl (Just bndrs) env let_dmd id rhs+            lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1+            env'                  = extendAnalEnv top_lvl env id (idStrictness id')+++    zapIdStrictness :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]+    zapIdStrictness pairs = [(setIdStrictness id nopSig, rhs) | (id, rhs) <- pairs ]++{-+Note [Safe abortion in the fixed-point iteration]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Fixed-point iteration may fail to terminate. But we cannot simply give up and+return the environment and code unchanged! We still need to do one additional+round, for two reasons:++ * To get information on used free variables (both lazy and strict!)+   (see Note [Lazy and unleashable free variables])+ * To ensure that all expressions have been traversed at least once, and any left-over+   strictness annotations have been updated.++This final iteration does not add the variables to the strictness signature+environment, which effectively assigns them 'nopSig' (see "getStrictness")++-}++-- Let bindings can be processed in two ways:+-- Down (RHS before body) or Up (body before RHS).+-- dmdAnalRhsLetDown implements the Down variant:+--  * assuming a demand of <L,U>+--  * looking at the definition+--  * determining a strictness signature+--+-- It is used for toplevel definition, recursive definitions and local+-- non-recursive definitions that have manifest lambdas.+-- Local non-recursive definitions without a lambda are handled with LetUp.+--+-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.+dmdAnalRhsLetDown :: TopLevelFlag+           -> Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive+           -> AnalEnv -> CleanDemand+           -> Id -> CoreExpr+           -> (DmdEnv, Id, CoreExpr)+-- Process the RHS of the binding, add the strictness signature+-- to the Id, and augment the environment with the signature as well.+dmdAnalRhsLetDown top_lvl rec_flag env let_dmd id rhs+  = (lazy_fv, id', rhs')+  where+    rhs_arity      = idArity id+    rhs_dmd+      -- See Note [Demand analysis for join points]+      -- See Note [idArity for join points] in SimplUtils+      -- rhs_arity matches the join arity of the join point+      | isJoinId id+      = mkCallDmds rhs_arity let_dmd+      | otherwise+      -- NB: rhs_arity+      -- See Note [Demand signatures are computed for a threshold demand based on idArity]+      = mkRhsDmd env rhs_arity rhs+    (DmdType rhs_fv rhs_dmds rhs_res, rhs')+                   = dmdAnal env rhs_dmd rhs+    sig            = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_res')+    id'            = set_idStrictness env id sig+        -- See Note [NOINLINE and strictness]+++    -- See Note [Aggregated demand for cardinality]+    rhs_fv1 = case rec_flag of+                Just bs -> reuseEnv (delVarEnvList rhs_fv bs)+                Nothing -> rhs_fv++    -- See Note [Lazy and unleashable free variables]+    (lazy_fv, sig_fv) = splitFVs is_thunk rhs_fv1++    rhs_res'  = trimCPRInfo trim_all trim_sums rhs_res+    trim_all  = is_thunk && not_strict+    trim_sums = not (isTopLevel top_lvl) -- See Note [CPR for sum types]++    -- See Note [CPR for thunks]+    is_thunk = not (exprIsHNF rhs) && not (isJoinId id)+    not_strict+       =  isTopLevel top_lvl  -- Top level and recursive things don't+       || isJust rec_flag     -- get their demandInfo set at all+       || not (isStrictDmd (idDemandInfo id) || ae_virgin env)+          -- See Note [Optimistic CPR in the "virgin" case]++-- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for+-- unleashing on the given function's @rhs@, by creating a call demand of+-- @rhs_arity@ with a body demand appropriate for possible product types.+-- See Note [Product demands for function body].+-- For example, a call of the form @mkRhsDmd _ 2 (\x y -> (x, y))@ returns a+-- clean usage demand of @C1(C1(U(U,U)))@.+mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand+mkRhsDmd env rhs_arity rhs =+  case peelTsFuns rhs_arity (findTypeShape (ae_fam_envs env) (exprType rhs)) of+    Just (TsProd tss) -> mkCallDmds rhs_arity (cleanEvalProdDmd (length tss))+    _                 -> mkCallDmds rhs_arity cleanEvalDmd++-- | If given the let-bound 'Id', 'useLetUp' determines whether we should+-- process the binding up (body before rhs) or down (rhs before body).+--+-- We use LetDown if there is a chance to get a useful strictness signature to+-- unleash at call sites. LetDown is generally more precise than LetUp if we can+-- correctly guess how it will be used in the body, that is, for which incoming+-- demand the strictness signature should be computed, which allows us to+-- unleash higher-order demands on arguments at call sites. This is mostly the+-- case when+--+--   * The binding takes any arguments before performing meaningful work (cf.+--     'idArity'), in which case we are interested to see how it uses them.+--   * The binding is a join point, hence acting like a function, not a value.+--     As a big plus, we know *precisely* how it will be used in the body; since+--     it's always tail-called, we can directly unleash the incoming demand of+--     the let binding on its RHS when computing a strictness signature. See+--     [Demand analysis for join points].+--+-- Thus, if the binding is not a join point and its arity is 0, we have a thunk+-- and use LetUp, implying that we have no usable demand signature available+-- when we analyse the let body.+--+-- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free+-- vars at most once, regardless of how many times it was forced in the body.+-- This makes a real difference wrt. usage demands. The other reason is being+-- able to unleash a more precise product demand on its RHS once we know how the+-- thunk was used in the let body.+--+-- Characteristic examples, always assuming a single evaluation:+--+--   * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that+--     the expression uses @y@ at most once.+--   * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that+--     @b@ is absent.+--   * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that+--     the expression uses @y@ strictly, because we have @f@'s demand signature+--     available at the call site.+--   * @join exit = 2*y in if a then exit else if b then exit else 3*y@ =>+--     LetDown. Compared to LetUp, we find out that the expression uses @y@+--     strictly, because we can unleash @exit@'s signature at each call site.+--   * For a more convincing example with join points, see Note [Demand analysis+--     for join points].+--+useLetUp :: Var -> Bool+useLetUp f = idArity f == 0 && not (isJoinId f)++{- Note [Demand analysis for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   g :: (Int,Int) -> Int+   g (p,q) = p+q++   f :: T -> Int -> Int+   f x p = g (join j y = (p,y)+              in case x of+                   A -> j 3+                   B -> j 4+                   C -> (p,7))++If j was a vanilla function definition, we'd analyse its body with+evalDmd, and think that it was lazy in p.  But for join points we can+do better!  We know that j's body will (if called at all) be evaluated+with the demand that consumes the entire join-binding, in this case+the argument demand from g.  Whizzo!  g evaluates both components of+its argument pair, so p will certainly be evaluated if j is called.++For f to be strict in p, we need /all/ paths to evaluate p; in this+case the C branch does so too, so we are fine.  So, as usual, we need+to transport demands on free variables to the call site(s).  Compare+Note [Lazy and unleashable free variables].++The implementation is easy.  When analysing a join point, we can+analyse its body with the demand from the entire join-binding (written+let_dmd here).++Another win for join points!  #13543.++Note [Demand signatures are computed for a threshold demand based on idArity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We compute demand signatures assuming idArity incoming arguments to approximate+behavior for when we have a call site with at least that many arguments. idArity+is /at least/ the number of manifest lambdas, but might be higher for PAPs and+trivial RHS (see Note [Demand analysis for trivial right-hand sides]).++Because idArity of a function varies independently of its cardinality properties+(cf. Note [idArity varies independently of dmdTypeDepth]), we implicitly encode+the arity for when a demand signature is sound to unleash in its 'dmdTypeDepth'+(cf. Note [Understanding DmdType and StrictSig] in Demand). It is unsound to+unleash a demand signature when the incoming number of arguments is less than+that. See Note [What are demand signatures?] for more details on soundness.++Why idArity arguments? Because that's a conservative estimate of how many+arguments we must feed a function before it does anything interesting with them.+Also it elegantly subsumes the trivial RHS and PAP case.++There might be functions for which we might want to analyse for more incoming+arguments than idArity. Example:++  f x =+    if expensive+      then \y -> ... y ...+      else \y -> ... y ...++We'd analyse `f` under a unary call demand C(S), corresponding to idArity+being 1. That's enough to look under the manifest lambda and find out how a+unary call would use `x`, but not enough to look into the lambdas in the if+branches.++On the other hand, if we analysed for call demand C(C(S)), we'd get useful+strictness info for `y` (and more precise info on `x`) and possibly CPR+information, but++  * We would no longer be able to unleash the signature at unary call sites+  * Performing the worker/wrapper split based on this information would be+    implicitly eta-expanding `f`, playing fast and loose with divergence and+    even being unsound in the presence of newtypes, so we refrain from doing so.+    Also see Note [Don't eta expand in w/w] in WorkWrap.++Since we only compute one signature, we do so for arity 1. Computing multiple+signatures for different arities (i.e., polyvariance) would be entirely+possible, if it weren't for the additional runtime and implementation+complexity.++Note [idArity varies independently of dmdTypeDepth]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to check in CoreLint that dmdTypeDepth <= idArity for a let-bound+identifier. But that means we would have to zap demand signatures every time we+reset or decrease arity. That's an unnecessary dependency, because++  * The demand signature captures a semantic property that is independent of+    what the binding's current arity is+  * idArity is analysis information itself, thus volatile+  * We already *have* dmdTypeDepth, wo why not just use it to encode the+    threshold for when to unleash the signature+    (cf. Note [Understanding DmdType and StrictSig] in Demand)++Consider the following expression, for example:++    (let go x y = `x` seq ... in go) |> co++`go` might have a strictness signature of `<S><L>`. The simplifier will identify+`go` as a nullary join point through `joinPointBinding_maybe` and float the+coercion into the binding, leading to an arity decrease:++    join go = (\x y -> `x` seq ...) |> co in go++With the CoreLint check, we would have to zap `go`'s perfectly viable strictness+signature.++Note [What are demand signatures?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Demand analysis interprets expressions in the abstract domain of demand+transformers. Given an incoming demand we put an expression under, its abstract+transformer gives us back a demand type denoting how other things (like+arguments and free vars) were used when the expression was evaluated.+Here's an example:++  f x y =+    if x + expensive+      then \z -> z + y * ...+      else \z -> z * ...++The abstract transformer (let's call it F_e) of the if expression (let's call it+e) would transform an incoming head demand <S,HU> into a demand type like+{x-><S,1*U>,y-><L,U>}<L,U>. In pictures:++     Demand ---F_e---> DmdType+     <S,HU>            {x-><S,1*U>,y-><L,U>}<L,U>++Let's assume that the demand transformers we compute for an expression are+correct wrt. to some concrete semantics for Core. How do demand signatures fit+in? They are strange beasts, given that they come with strict rules when to+it's sound to unleash them.++Fortunately, we can formalise the rules with Galois connections. Consider+f's strictness signature, {}<S,1*U><L,U>. It's a single-point approximation of+the actual abstract transformer of f's RHS for arity 2. So, what happens is that+we abstract *once more* from the abstract domain we already are in, replacing+the incoming Demand by a simple lattice with two elements denoting incoming+arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom+element). Here's the diagram:++     A_2 -----f_f----> DmdType+      ^                   |+      | α               γ |+      |                   v+     Demand ---F_f---> DmdType++With+  α(C1(C1(_))) = >=2 -- example for usage demands, but similar for strictness+  α(_)         =  <2+  γ(ty)        =  ty+and F_f being the abstract transformer of f's RHS and f_f being the abstracted+abstract transformer computable from our demand signature simply by++  f_f(>=2) = {}<S,1*U><L,U>+  f_f(<2)  = postProcessUnsat {}<S,1*U><L,U>++where postProcessUnsat makes a proper top element out of the given demand type.++Note [Demand analysis for trivial right-hand sides]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    foo = plusInt |> co+where plusInt is an arity-2 function with known strictness.  Clearly+we want plusInt's strictness to propagate to foo!  But because it has+no manifest lambdas, it won't do so automatically, and indeed 'co' might+have type (Int->Int->Int) ~ T.++Fortunately, CoreArity gives 'foo' arity 2, which is enough for LetDown to+forward plusInt's demand signature, and all is well (see Note [Newtype arity] in+CoreArity)! A small example is the test case NewtypeArity.+++Note [Product demands for function body]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This example comes from shootout/binary_trees:++    Main.check' = \ b z ds. case z of z' { I# ip ->+                                case ds_d13s of+                                  Main.Nil -> z'+                                  Main.Node s14k s14l s14m ->+                                    Main.check' (not b)+                                      (Main.check' b+                                         (case b {+                                            False -> I# (-# s14h s14k);+                                            True  -> I# (+# s14h s14k)+                                          })+                                         s14l)+                                     s14m   }   }   }++Here we *really* want to unbox z, even though it appears to be used boxed in+the Nil case.  Partly the Nil case is not a hot path.  But more specifically,+the whole function gets the CPR property if we do.++So for the demand on the body of a RHS we use a product demand if it's+a product type.++************************************************************************+*                                                                      *+\subsection{Strictness signatures and types}+*                                                                      *+************************************************************************+-}++unitDmdType :: DmdEnv -> DmdType+unitDmdType dmd_env = DmdType dmd_env [] topRes++coercionDmdEnv :: Coercion -> DmdEnv+coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co)+                    -- The VarSet from coVarsOfCo is really a VarEnv Var++addVarDmd :: DmdType -> Var -> Demand -> DmdType+addVarDmd (DmdType fv ds res) var dmd+  = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res++addLazyFVs :: DmdType -> DmdEnv -> DmdType+addLazyFVs dmd_ty lazy_fvs+  = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs+        -- Using bothDmdType (rather than just both'ing the envs)+        -- is vital.  Consider+        --      let f = \x -> (x,y)+        --      in  error (f 3)+        -- Here, y is treated as a lazy-fv of f, but we must `bothDmd` that L+        -- demand with the bottom coming up from 'error'+        --+        -- I got a loop in the fixpointer without this, due to an interaction+        -- with the lazy_fv filtering in dmdAnalRhsLetDown.  Roughly, it was+        --      letrec f n x+        --          = letrec g y = x `fatbar`+        --                         letrec h z = z + ...g...+        --                         in h (f (n-1) x)+        --      in ...+        -- In the initial iteration for f, f=Bot+        -- Suppose h is found to be strict in z, but the occurrence of g in its RHS+        -- is lazy.  Now consider the fixpoint iteration for g, esp the demands it+        -- places on its free variables.  Suppose it places none.  Then the+        --      x `fatbar` ...call to h...+        -- will give a x->V demand for x.  That turns into a L demand for x,+        -- which floats out of the defn for h.  Without the modifyEnv, that+        -- L demand doesn't get both'd with the Bot coming up from the inner+        -- call to f.  So we just get an L demand for x for g.++{-+Note [Do not strictify the argument dictionaries of a dfun]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The typechecker can tie recursive knots involving dfuns, so we do the+conservative thing and refrain from strictifying a dfun's argument+dictionaries.+-}++setBndrsDemandInfo :: [Var] -> [Demand] -> [Var]+setBndrsDemandInfo (b:bs) (d:ds)+  | isTyVar b = b : setBndrsDemandInfo bs (d:ds)+  | otherwise = setIdDemandInfo b d : setBndrsDemandInfo bs ds+setBndrsDemandInfo [] ds = ASSERT( null ds ) []+setBndrsDemandInfo bs _  = pprPanic "setBndrsDemandInfo" (ppr bs)++annotateBndr :: AnalEnv -> DmdType -> Var -> (DmdType, Var)+-- The returned env has the var deleted+-- The returned var is annotated with demand info+-- according to the result demand of the provided demand type+-- No effect on the argument demands+annotateBndr env dmd_ty var+  | isId var  = (dmd_ty', setIdDemandInfo var dmd)+  | otherwise = (dmd_ty, var)+  where+    (dmd_ty', dmd) = findBndrDmd env False dmd_ty var++annotateLamIdBndr :: AnalEnv+                  -> DFunFlag   -- is this lambda at the top of the RHS of a dfun?+                  -> DmdType    -- Demand type of body+                  -> Id         -- Lambda binder+                  -> (DmdType,  -- Demand type of lambda+                      Id)       -- and binder annotated with demand++annotateLamIdBndr env arg_of_dfun dmd_ty id+-- For lambdas we add the demand to the argument demands+-- Only called for Ids+  = ASSERT( isId id )+    -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $+    (final_ty, setIdDemandInfo id dmd)+  where+      -- Watch out!  See note [Lambda-bound unfoldings]+    final_ty = case maybeUnfoldingTemplate (idUnfolding id) of+                 Nothing  -> main_ty+                 Just unf -> main_ty `bothDmdType` unf_ty+                          where+                             (unf_ty, _) = dmdAnalStar env dmd unf++    main_ty = addDemand dmd dmd_ty'+    (dmd_ty', dmd) = findBndrDmd env arg_of_dfun dmd_ty id++deleteFVs :: DmdType -> [Var] -> DmdType+deleteFVs (DmdType fvs dmds res) bndrs+  = DmdType (delVarEnvList fvs bndrs) dmds res++{-+Note [CPR for sum types]+~~~~~~~~~~~~~~~~~~~~~~~~+At the moment we do not do CPR for let-bindings that+   * non-top level+   * bind a sum type+Reason: I found that in some benchmarks we were losing let-no-escapes,+which messed it all up.  Example+   let j = \x. ....+   in case y of+        True  -> j False+        False -> j True+If we w/w this we get+   let j' = \x. ....+   in case y of+        True  -> case j' False of { (# a #) -> Just a }+        False -> case j' True of { (# a #) -> Just a }+Notice that j' is not a let-no-escape any more.++However this means in turn that the *enclosing* function+may be CPR'd (via the returned Justs).  But in the case of+sums, there may be Nothing alternatives; and that messes+up the sum-type CPR.++Conclusion: only do this for products.  It's still not+guaranteed OK for products, but sums definitely lose sometimes.++Note [CPR for thunks]+~~~~~~~~~~~~~~~~~~~~~+If the rhs is a thunk, we usually forget the CPR info, because+it is presumably shared (else it would have been inlined, and+so we'd lose sharing if w/w'd it into a function).  E.g.++        let r = case expensive of+                  (a,b) -> (b,a)+        in ...++If we marked r as having the CPR property, then we'd w/w into++        let $wr = \() -> case expensive of+                            (a,b) -> (# b, a #)+            r = case $wr () of+                  (# b,a #) -> (b,a)+        in ...++But now r is a thunk, which won't be inlined, so we are no further ahead.+But consider++        f x = let r = case expensive of (a,b) -> (b,a)+              in if foo r then r else (x,x)++Does f have the CPR property?  Well, no.++However, if the strictness analyser has figured out (in a previous+iteration) that it's strict, then we DON'T need to forget the CPR info.+Instead we can retain the CPR info and do the thunk-splitting transform+(see WorkWrap.splitThunk).++This made a big difference to PrelBase.modInt, which had something like+        modInt = \ x -> let r = ... -> I# v in+                        ...body strict in r...+r's RHS isn't a value yet; but modInt returns r in various branches, so+if r doesn't have the CPR property then neither does modInt+Another case I found in practice (in Complex.magnitude), looks like this:+                let k = if ... then I# a else I# b+                in ... body strict in k ....+(For this example, it doesn't matter whether k is returned as part of+the overall result; but it does matter that k's RHS has the CPR property.)+Left to itself, the simplifier will make a join point thus:+                let $j k = ...body strict in k...+                if ... then $j (I# a) else $j (I# b)+With thunk-splitting, we get instead+                let $j x = let k = I#x in ...body strict in k...+                in if ... then $j a else $j b+This is much better; there's a good chance the I# won't get allocated.++The difficulty with this is that we need the strictness type to+look at the body... but we now need the body to calculate the demand+on the variable, so we can decide whether its strictness type should+have a CPR in it or not.  Simple solution:+        a) use strictness info from the previous iteration+        b) make sure we do at least 2 iterations, by doing a second+           round for top-level non-recs.  Top level recs will get at+           least 2 iterations except for totally-bottom functions+           which aren't very interesting anyway.++NB: strictly_demanded is never true of a top-level Id, or of a recursive Id.++Note [Optimistic CPR in the "virgin" case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Demand and strictness info are initialized by top elements. However,+this prevents from inferring a CPR property in the first pass of the+analyser, so we keep an explicit flag ae_virgin in the AnalEnv+datatype.++We can't start with 'not-demanded' (i.e., top) because then consider+        f x = let+                  t = ... I# x+              in+              if ... then t else I# y else f x'++In the first iteration we'd have no demand info for x, so assume+not-demanded; then we'd get TopRes for f's CPR info.  Next iteration+we'd see that t was demanded, and so give it the CPR property, but by+now f has TopRes, so it will stay TopRes.  Instead, by checking the+ae_virgin flag at the first time round, we say 'yes t is demanded' the+first time.++However, this does mean that for non-recursive bindings we must+iterate twice to be sure of not getting over-optimistic CPR info,+in the case where t turns out to be not-demanded.  This is handled+by dmdAnalTopBind.+++Note [NOINLINE and strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The strictness analyser used to have a HACK which ensured that NOINLNE+things were not strictness-analysed.  The reason was unsafePerformIO.+Left to itself, the strictness analyser would discover this strictness+for unsafePerformIO:+        unsafePerformIO:  C(U(AV))+But then consider this sub-expression+        unsafePerformIO (\s -> let r = f x in+                               case writeIORef v r s of (# s1, _ #) ->+                               (# s1, r #)+The strictness analyser will now find that r is sure to be eval'd,+and may then hoist it out.  This makes tests/lib/should_run/memo002+deadlock.++Solving this by making all NOINLINE things have no strictness info is overkill.+In particular, it's overkill for runST, which is perfectly respectable.+Consider+        f x = runST (return x)+This should be strict in x.++So the new plan is to define unsafePerformIO using the 'lazy' combinator:++        unsafePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r)++Remember, 'lazy' is a wired-in identity-function Id, of type a->a, which is+magically NON-STRICT, and is inlined after strictness analysis.  So+unsafePerformIO will look non-strict, and that's what we want.++Now we don't need the hack in the strictness analyser.  HOWEVER, this+decision does mean that even a NOINLINE function is not entirely+opaque: some aspect of its implementation leaks out, notably its+strictness.  For example, if you have a function implemented by an+error stub, but which has RULES, you may want it not to be eliminated+in favour of error!++Note [Lazy and unleashable free variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We put the strict and once-used FVs in the DmdType of the Id, so+that at its call sites we unleash demands on its strict fvs.+An example is 'roll' in imaginary/wheel-sieve2+Something like this:+        roll x = letrec+                     go y = if ... then roll (x-1) else x+1+                 in+                 go ms+We want to see that roll is strict in x, which is because+go is called.   So we put the DmdEnv for x in go's DmdType.++Another example:++        f :: Int -> Int -> Int+        f x y = let t = x+1+            h z = if z==0 then t else+                  if z==1 then x+1 else+                  x + h (z-1)+        in h y++Calling h does indeed evaluate x, but we can only see+that if we unleash a demand on x at the call site for t.++Incidentally, here's a place where lambda-lifting h would+lose the cigar --- we couldn't see the joint strictness in t/x++        ON THE OTHER HAND++We don't want to put *all* the fv's from the RHS into the+DmdType. Because++ * it makes the strictness signatures larger, and hence slows down fixpointing++and++ * it is useless information at the call site anyways:+   For lazy, used-many times fv's we will never get any better result than+   that, no matter how good the actual demand on the function at the call site+   is (unless it is always absent, but then the whole binder is useless).++Therefore we exclude lazy multiple-used fv's from the environment in the+DmdType.++But now the signature lies! (Missing variables are assumed to be absent.) To+make up for this, the code that analyses the binding keeps the demand on those+variable separate (usually called "lazy_fv") and adds it to the demand of the+whole binding later.++What if we decide _not_ to store a strictness signature for a binding at all, as+we do when aborting a fixed-point iteration? The we risk losing the information+that the strict variables are being used. In that case, we take all free variables+mentioned in the (unsound) strictness signature, conservatively approximate the+demand put on them (topDmd), and add that to the "lazy_fv" returned by "dmdFix".+++Note [Lambda-bound unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We allow a lambda-bound variable to carry an unfolding, a facility that is used+exclusively for join points; see Note [Case binders and join points].  If so,+we must be careful to demand-analyse the RHS of the unfolding!  Example+   \x. \y{=Just x}. <body>+Then if <body> uses 'y', then transitively it uses 'x', and we must not+forget that fact, otherwise we might make 'x' absent when it isn't.+++************************************************************************+*                                                                      *+\subsection{Strictness signatures}+*                                                                      *+************************************************************************+-}++type DFunFlag = Bool  -- indicates if the lambda being considered is in the+                      -- sequence of lambdas at the top of the RHS of a dfun+notArgOfDfun :: DFunFlag+notArgOfDfun = False++data AnalEnv+  = AE { ae_dflags :: DynFlags+       , ae_sigs   :: SigEnv+       , ae_virgin :: Bool    -- True on first iteration only+                              -- See Note [Initialising strictness]+       , ae_rec_tc :: RecTcChecker+       , ae_fam_envs :: FamInstEnvs+ }++        -- We use the se_env to tell us whether to+        -- record info about a variable in the DmdEnv+        -- We do so if it's a LocalId, but not top-level+        --+        -- The DmdEnv gives the demand on the free vars of the function+        -- when it is given enough args to satisfy the strictness signature++type SigEnv = VarEnv (StrictSig, TopLevelFlag)++instance Outputable AnalEnv where+  ppr (AE { ae_sigs = env, ae_virgin = virgin })+    = text "AE" <+> braces (vcat+         [ text "ae_virgin =" <+> ppr virgin+         , text "ae_sigs =" <+> ppr env ])++emptyAnalEnv :: DynFlags -> FamInstEnvs -> AnalEnv+emptyAnalEnv dflags fam_envs+    = AE { ae_dflags = dflags+         , ae_sigs = emptySigEnv+         , ae_virgin = True+         , ae_rec_tc = initRecTc+         , ae_fam_envs = fam_envs+         }++emptySigEnv :: SigEnv+emptySigEnv = emptyVarEnv++-- | Extend an environment with the strictness IDs attached to the id+extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv+extendAnalEnvs top_lvl env vars+  = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }++extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv+extendSigEnvs top_lvl sigs vars+  = extendVarEnvList sigs [ (var, (idStrictness var, top_lvl)) | var <- vars]++extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> StrictSig -> AnalEnv+extendAnalEnv top_lvl env var sig+  = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig }++extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> StrictSig -> SigEnv+extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)++lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag)+lookupSigEnv env id = lookupVarEnv (ae_sigs env) id++nonVirgin :: AnalEnv -> AnalEnv+nonVirgin env = env { ae_virgin = False }++extendSigsWithLam :: AnalEnv -> Id -> AnalEnv+-- Extend the AnalEnv when we meet a lambda binder+extendSigsWithLam env id+  | isId id+  , isStrictDmd (idDemandInfo id) || ae_virgin env+       -- See Note [Optimistic CPR in the "virgin" case]+       -- See Note [Initial CPR for strict binders]+  , Just (dc,_,_,_) <- deepSplitProductType_maybe (ae_fam_envs env) $ idType id+  = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc))++  | otherwise+  = env++extendEnvForProdAlt :: AnalEnv -> CoreExpr -> Id -> DataCon -> [Var] -> AnalEnv+-- See Note [CPR in a product case alternative]+extendEnvForProdAlt env scrut case_bndr dc bndrs+  = foldl' do_con_arg env1 ids_w_strs+  where+    env1 = extendAnalEnv NotTopLevel env case_bndr case_bndr_sig++    ids_w_strs    = filter isId bndrs `zip` dataConRepStrictness dc+    case_bndr_sig = cprProdSig (dataConRepArity dc)+    fam_envs      = ae_fam_envs env++    do_con_arg env (id, str)+       | let is_strict = isStrictDmd (idDemandInfo id) || isMarkedStrict str+       , ae_virgin env || (is_var_scrut && is_strict)  -- See Note [CPR in a product case alternative]+       , Just (dc,_,_,_) <- deepSplitProductType_maybe fam_envs $ idType id+       = extendAnalEnv NotTopLevel env id (cprProdSig (dataConRepArity dc))+       | otherwise+       = env++    is_var_scrut = is_var scrut+    is_var (Cast e _) = is_var e+    is_var (Var v)    = isLocalId v+    is_var _          = False++findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> (DmdType, [Demand])+-- Return the demands on the Ids in the [Var]+findBndrsDmds env dmd_ty bndrs+  = go dmd_ty bndrs+  where+    go dmd_ty []  = (dmd_ty, [])+    go dmd_ty (b:bs)+      | isId b    = let (dmd_ty1, dmds) = go dmd_ty bs+                        (dmd_ty2, dmd)  = findBndrDmd env False dmd_ty1 b+                    in (dmd_ty2, dmd : dmds)+      | otherwise = go dmd_ty bs++findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)+-- See Note [Trimming a demand to a type] in Demand.hs+findBndrDmd env arg_of_dfun dmd_ty id+  = (dmd_ty', dmd')+  where+    dmd' = killUsageDemand (ae_dflags env) $+           strictify $+           trimToType starting_dmd (findTypeShape fam_envs id_ty)++    (dmd_ty', starting_dmd) = peelFV dmd_ty id++    id_ty = idType id++    strictify dmd+      | gopt Opt_DictsStrict (ae_dflags env)+             -- We never want to strictify a recursive let. At the moment+             -- annotateBndr is only call for non-recursive lets; if that+             -- changes, we need a RecFlag parameter and another guard here.+      , not arg_of_dfun -- See Note [Do not strictify the argument dictionaries of a dfun]+      = strictifyDictDmd id_ty dmd+      | otherwise+      = dmd++    fam_envs = ae_fam_envs env++set_idStrictness :: AnalEnv -> Id -> StrictSig -> Id+set_idStrictness env id sig+  = setIdStrictness id (killUsageSig (ae_dflags env) sig)++dumpStrSig :: CoreProgram -> SDoc+dumpStrSig binds = vcat (map printId ids)+  where+  ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds)+  getIds (NonRec i _) = [ i ]+  getIds (Rec bs)     = map fst bs+  printId id | isExportedId id = ppr id <> colon <+> pprIfaceStrictSig (idStrictness id)+             | otherwise       = empty++{- Note [CPR in a product case alternative]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a case alternative for a product type, we want to give some of the+binders the CPR property.  Specifically++ * The case binder; inside the alternative, the case binder always has+   the CPR property, meaning that a case on it will successfully cancel.+   Example:+        f True  x = case x of y { I# x' -> if x' ==# 3+                                           then y+                                           else I# 8 }+        f False x = I# 3++   By giving 'y' the CPR property, we ensure that 'f' does too, so we get+        f b x = case fw b x of { r -> I# r }+        fw True  x = case x of y { I# x' -> if x' ==# 3 then x' else 8 }+        fw False x = 3++   Of course there is the usual risk of re-boxing: we have 'x' available+   boxed and unboxed, but we return the unboxed version for the wrapper to+   box.  If the wrapper doesn't cancel with its caller, we'll end up+   re-boxing something that we did have available in boxed form.++ * Any strict binders with product type, can use+   Note [Initial CPR for strict binders].  But we can go a little+   further. Consider++      data T = MkT !Int Int++      f2 (MkT x y) | y>0       = f2 (MkT x (y-1))+                   | otherwise = x++   For $wf2 we are going to unbox the MkT *and*, since it is strict, the+   first argument of the MkT; see Note [Add demands for strict constructors]+   in WwLib. But then we don't want box it up again when returning it! We want+   'f2' to have the CPR property, so we give 'x' the CPR property.++ * It's a bit delicate because if this case is scrutinising something other+   than an argument the original function, we really don't have the unboxed+   version available.  E.g+      g v = case foo v of+              MkT x y | y>0       -> ...+                      | otherwise -> x+   Here we don't have the unboxed 'x' available.  Hence the+   is_var_scrut test when making use of the strictness annotation.+   Slightly ad-hoc, because even if the scrutinee *is* a variable it+   might not be a onre of the arguments to the original function, or a+   sub-component thereof.  But it's simple, and nothing terrible+   happens if we get it wrong.  e.g. #10694.+++Note [Initial CPR for strict binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+CPR is initialized for a lambda binder in an optimistic manner, i.e,+if the binder is used strictly and at least some of its components as+a product are used, which is checked by the value of the absence+demand.++If the binder is marked demanded with a strict demand, then give it a+CPR signature. Here's a concrete example ('f1' in test T10482a),+assuming h is strict:++  f1 :: Int -> Int+  f1 x = case h x of+          A -> x+          B -> f1 (x-1)+          C -> x+1++If we notice that 'x' is used strictly, we can give it the CPR+property; and hence f1 gets the CPR property too.  It's sound (doesn't+change strictness) to give it the CPR property because by the time 'x'+is returned (case A above), it'll have been evaluated (by the wrapper+of 'h' in the example).++Moreover, if f itself is strict in x, then we'll pass x unboxed to+f1, and so the boxed version *won't* be available; in that case it's+very helpful to give 'x' the CPR property.++Note that++  * We only want to do this for something that definitely+    has product type, else we may get over-optimistic CPR results+    (e.g. from \x -> x!).++  * See Note [CPR examples]++Note [CPR examples]+~~~~~~~~~~~~~~~~~~~~+Here are some examples (stranal/should_compile/T10482a) of the+usefulness of Note [CPR in a product case alternative].  The main+point: all of these functions can have the CPR property.++    ------- f1 -----------+    -- x is used strictly by h, so it'll be available+    -- unboxed before it is returned in the True branch++    f1 :: Int -> Int+    f1 x = case h x x of+            True  -> x+            False -> f1 (x-1)+++    ------- f2 -----------+    -- x is a strict field of MkT2, so we'll pass it unboxed+    -- to $wf2, so it's available unboxed.  This depends on+    -- the case expression analysing (a subcomponent of) one+    -- of the original arguments to the function, so it's+    -- a bit more delicate.++    data T2 = MkT2 !Int Int++    f2 :: T2 -> Int+    f2 (MkT2 x y) | y>0       = f2 (MkT2 x (y-1))+                  | otherwise = x+++    ------- f3 -----------+    -- h is strict in x, so x will be unboxed before it+    -- is rerturned in the otherwise case.++    data T3 = MkT3 Int Int++    f1 :: T3 -> Int+    f1 (MkT3 x y) | h x y     = f3 (MkT3 x (y-1))+                  | otherwise = x+++    ------- f4 -----------+    -- Just like f2, but MkT4 can't unbox its strict+    -- argument automatically, as f2 can++    data family Foo a+    newtype instance Foo Int = Foo Int++    data T4 a = MkT4 !(Foo a) Int++    f4 :: T4 Int -> Int+    f4 (MkT4 x@(Foo v) y) | y>0       = f4 (MkT4 x (y-1))+                          | otherwise = v+++Note [Initialising strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See section 9.2 (Finding fixpoints) of the paper.++Our basic plan is to initialise the strictness of each Id in a+recursive group to "bottom", and find a fixpoint from there.  However,+this group B might be inside an *enclosing* recursive group A, in+which case we'll do the entire fixpoint shebang on for each iteration+of A. This can be illustrated by the following example:++Example:++  f [] = []+  f (x:xs) = let g []     = f xs+                 g (y:ys) = y+1 : g ys+              in g (h x)++At each iteration of the fixpoint for f, the analyser has to find a+fixpoint for the enclosed function g. In the meantime, the demand+values for g at each iteration for f are *greater* than those we+encountered in the previous iteration for f. Therefore, we can begin+the fixpoint for g not with the bottom value but rather with the+result of the previous analysis. I.e., when beginning the fixpoint+process for g, we can start from the demand signature computed for g+previously and attached to the binding occurrence of g.++To speed things up, we initialise each iteration of A (the enclosing+one) from the result of the last one, which is neatly recorded in each+binder.  That way we make use of earlier iterations of the fixpoint+algorithm. (Cunning plan.)++But on the *first* iteration we want to *ignore* the current strictness+of the Id, and start from "bottom".  Nowadays the Id can have a current+strictness, because interface files record strictness for nested bindings.+To know when we are in the first iteration, we look at the ae_virgin+field of the AnalEnv.+++Note [Final Demand Analyser run]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some of the information that the demand analyser determines is not always+preserved by the simplifier.  For example, the simplifier will happily rewrite+  \y [Demand=1*U] let x = y in x + x+to+  \y [Demand=1*U] y + y+which is quite a lie.++The once-used information is (currently) only used by the code+generator, though.  So:++ * We zap the used-once info in the worker-wrapper;+   see Note [Zapping Used Once info in WorkWrap] in WorkWrap. If it's+   not reliable, it's better not to have it at all.++ * Just before TidyCore, we add a pass of the demand analyser,+      but WITHOUT subsequent worker/wrapper and simplifier,+   right before TidyCore.  See SimplCore.getCoreToDo.++   This way, correct information finds its way into the module interface+   (strictness signatures!) and the code generator (single-entry thunks!)++Note that, in contrast, the single-call information (C1(..)) /can/ be+relied upon, as the simplifier tends to be very careful about not+duplicating actual function calls.++Also see #11731.+-}
+ compiler/stranal/WorkWrap.hs view
@@ -0,0 +1,760 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section[WorkWrap]{Worker/wrapper-generating back-end of strictness analyser}+-}++{-# LANGUAGE CPP #-}+module WorkWrap ( wwTopBinds ) where++import GhcPrelude++import CoreArity        ( manifestArity )+import CoreSyn+import CoreUnfold       ( certainlyWillInline, mkWwInlineRule, mkWorkerUnfolding )+import CoreUtils        ( exprType, exprIsHNF )+import CoreFVs          ( exprFreeVars )+import Var+import Id+import IdInfo+import Type+import UniqSupply+import BasicTypes+import DynFlags+import Demand+import WwLib+import Util+import Outputable+import FamInstEnv+import MonadUtils++#include "HsVersions.h"++{-+We take Core bindings whose binders have:++\begin{enumerate}++\item Strictness attached (by the front-end of the strictness+analyser), and / or++\item Constructed Product Result information attached by the CPR+analysis pass.++\end{enumerate}++and we return some ``plain'' bindings which have been+worker/wrapper-ified, meaning:++\begin{enumerate}++\item Functions have been split into workers and wrappers where+appropriate.  If a function has both strictness and CPR properties+then only one worker/wrapper doing both transformations is produced;++\item Binders' @IdInfos@ have been updated to reflect the existence of+these workers/wrappers (this is where we get STRICTNESS and CPR pragma+info for exported values).+\end{enumerate}+-}++wwTopBinds :: DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram++wwTopBinds dflags fam_envs us top_binds+  = initUs_ us $ do+    top_binds' <- mapM (wwBind dflags fam_envs) top_binds+    return (concat top_binds')++{-+************************************************************************+*                                                                      *+\subsection[wwBind-wwExpr]{@wwBind@ and @wwExpr@}+*                                                                      *+************************************************************************++@wwBind@ works on a binding, trying each \tr{(binder, expr)} pair in+turn.  Non-recursive case first, then recursive...+-}++wwBind  :: DynFlags+        -> FamInstEnvs+        -> CoreBind+        -> UniqSM [CoreBind]    -- returns a WwBinding intermediate form;+                                -- the caller will convert to Expr/Binding,+                                -- as appropriate.++wwBind dflags fam_envs (NonRec binder rhs) = do+    new_rhs <- wwExpr dflags fam_envs rhs+    new_pairs <- tryWW dflags fam_envs NonRecursive binder new_rhs+    return [NonRec b e | (b,e) <- new_pairs]+      -- Generated bindings must be non-recursive+      -- because the original binding was.++wwBind dflags fam_envs (Rec pairs)+  = return . Rec <$> concatMapM do_one pairs+  where+    do_one (binder, rhs) = do new_rhs <- wwExpr dflags fam_envs rhs+                              tryWW dflags fam_envs Recursive binder new_rhs++{-+@wwExpr@ basically just walks the tree, looking for appropriate+annotations that can be used. Remember it is @wwBind@ that does the+matching by looking for strict arguments of the correct type.+@wwExpr@ is a version that just returns the ``Plain'' Tree.+-}++wwExpr :: DynFlags -> FamInstEnvs -> CoreExpr -> UniqSM CoreExpr++wwExpr _      _ e@(Type {}) = return e+wwExpr _      _ e@(Coercion {}) = return e+wwExpr _      _ e@(Lit  {}) = return e+wwExpr _      _ e@(Var  {}) = return e++wwExpr dflags fam_envs (Lam binder expr)+  = Lam new_binder <$> wwExpr dflags fam_envs expr+  where new_binder | isId binder = zapIdUsedOnceInfo binder+                   | otherwise   = binder+  -- See Note [Zapping Used Once info in WorkWrap]++wwExpr dflags fam_envs (App f a)+  = App <$> wwExpr dflags fam_envs f <*> wwExpr dflags fam_envs a++wwExpr dflags fam_envs (Tick note expr)+  = Tick note <$> wwExpr dflags fam_envs expr++wwExpr dflags fam_envs (Cast expr co) = do+    new_expr <- wwExpr dflags fam_envs expr+    return (Cast new_expr co)++wwExpr dflags fam_envs (Let bind expr)+  = mkLets <$> wwBind dflags fam_envs bind <*> wwExpr dflags fam_envs expr++wwExpr dflags fam_envs (Case expr binder ty alts) = do+    new_expr <- wwExpr dflags fam_envs expr+    new_alts <- mapM ww_alt alts+    let new_binder = zapIdUsedOnceInfo binder+      -- See Note [Zapping Used Once info in WorkWrap]+    return (Case new_expr new_binder ty new_alts)+  where+    ww_alt (con, binders, rhs) = do+        new_rhs <- wwExpr dflags fam_envs rhs+        let new_binders = [ if isId b then zapIdUsedOnceInfo b else b+                          | b <- binders ]+           -- See Note [Zapping Used Once info in WorkWrap]+        return (con, new_binders, new_rhs)++{-+************************************************************************+*                                                                      *+\subsection[tryWW]{@tryWW@: attempt a worker/wrapper pair}+*                                                                      *+************************************************************************++@tryWW@ just accumulates arguments, converts strictness info from the+front-end into the proper form, then calls @mkWwBodies@ to do+the business.++The only reason this is monadised is for the unique supply.++Note [Don't w/w INLINE things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very important to refrain from w/w-ing an INLINE function (ie one+with a stable unfolding) because the wrapper will then overwrite the+old stable unfolding with the wrapper code.++Furthermore, if the programmer has marked something as INLINE,+we may lose by w/w'ing it.++If the strictness analyser is run twice, this test also prevents+wrappers (which are INLINEd) from being re-done.  (You can end up with+several liked-named Ids bouncing around at the same time---absolute+mischief.)++Notice that we refrain from w/w'ing an INLINE function even if it is+in a recursive group.  It might not be the loop breaker.  (We could+test for loop-breaker-hood, but I'm not sure that ever matters.)++Note [Worker-wrapper for INLINABLE functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+  {-# INLINABLE f #-}+  f :: Ord a => [a] -> Int -> a+  f x y = ....f....++where f is strict in y, we might get a more efficient loop by w/w'ing+f.  But that would make a new unfolding which would overwrite the old+one! So the function would no longer be INLNABLE, and in particular+will not be specialised at call sites in other modules.++This comes in practice (#6056).++Solution: do the w/w for strictness analysis, but transfer the Stable+unfolding to the *worker*.  So we will get something like this:++  {-# INLINE[0] f #-}+  f :: Ord a => [a] -> Int -> a+  f d x y = case y of I# y' -> fw d x y'++  {-# INLINABLE[0] fw #-}+  fw :: Ord a => [a] -> Int# -> a+  fw d x y' = let y = I# y' in ...f...++How do we "transfer the unfolding"? Easy: by using the old one, wrapped+in work_fn! See CoreUnfold.mkWorkerUnfolding.++Note [Worker-wrapper for NOINLINE functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to disable worker/wrapper for NOINLINE things, but it turns out+this can cause unnecessary reboxing of values. Consider++  {-# NOINLINE f #-}+  f :: Int -> a+  f x = error (show x)++  g :: Bool -> Bool -> Int -> Int+  g True  True  p = f p+  g False True  p = p + 1+  g b     False p = g b True p++the strictness analysis will discover f and g are strict, but because f+has no wrapper, the worker for g will rebox p. So we get++  $wg x y p# =+    let p = I# p# in  -- Yikes! Reboxing!+    case x of+      False ->+        case y of+          False -> $wg False True p#+          True -> +# p# 1#+      True ->+        case y of+          False -> $wg True True p#+          True -> case f p of { }++  g x y p = case p of (I# p#) -> $wg x y p#++Now, in this case the reboxing will float into the True branch, and so+the allocation will only happen on the error path. But it won't float+inwards if there are multiple branches that call (f p), so the reboxing+will happen on every call of g. Disaster.++Solution: do worker/wrapper even on NOINLINE things; but move the+NOINLINE pragma to the worker.++(See #13143 for a real-world example.)++It is crucial that we do this for *all* NOINLINE functions. #10069+demonstrates what happens when we promise to w/w a (NOINLINE) leaf function, but+fail to deliver:++  data C = C Int# Int#++  {-# NOINLINE c1 #-}+  c1 :: C -> Int#+  c1 (C _ n) = n++  {-# NOINLINE fc #-}+  fc :: C -> Int#+  fc c = 2 *# c1 c++Failing to w/w `c1`, but still w/wing `fc` leads to the following code:++  c1 :: C -> Int#+  c1 (C _ n) = n++  $wfc :: Int# -> Int#+  $wfc n = let c = C 0# n in 2 #* c1 c++  fc :: C -> Int#+  fc (C _ n) = $wfc n++Yikes! The reboxed `C` in `$wfc` can't cancel out, so we are in a bad place.+This generalises to any function that derives its strictness signature from+its callees, so we have to make sure that when a function announces particular+strictness properties, we have to w/w them accordingly, even if it means+splitting a NOINLINE function.++Note [Worker activation]+~~~~~~~~~~~~~~~~~~~~~~~~+Follows on from Note [Worker-wrapper for INLINABLE functions]++It is *vital* that if the worker gets an INLINABLE pragma (from the+original function), then the worker has the same phase activation as+the wrapper (or later).  That is necessary to allow the wrapper to+inline into the worker's unfolding: see SimplUtils+Note [Simplifying inside stable unfoldings].++If the original is NOINLINE, it's important that the work inherit the+original activation. Consider++  {-# NOINLINE expensive #-}+  expensive x = x + 1++  f y = let z = expensive y in ...++If expensive's worker inherits the wrapper's activation,+we'll get this (because of the compromise in point (2) of+Note [Wrapper activation])++  {-# NOINLINE[0] $wexpensive #-}+  $wexpensive x = x + 1+  {-# INLINE[0] expensive #-}+  expensive x = $wexpensive x++  f y = let z = expensive y in ...++and $wexpensive will be immediately inlined into expensive, followed by+expensive into f. This effectively removes the original NOINLINE!++Otherwise, nothing is lost by giving the worker the same activation as the+wrapper, because the worker won't have any chance of inlining until the+wrapper does; there's no point in giving it an earlier activation.++Note [Don't w/w inline small non-loop-breaker things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, we refrain from w/w-ing *small* functions, which are not+loop breakers, because they'll inline anyway.  But we must take care:+it may look small now, but get to be big later after other inlining+has happened.  So we take the precaution of adding an INLINE pragma to+any such functions.++I made this change when I observed a big function at the end of+compilation with a useful strictness signature but no w-w.  (It was+small during demand analysis, we refrained from w/w, and then got big+when something was inlined in its rhs.) When I measured it on nofib,+it didn't make much difference; just a few percent improved allocation+on one benchmark (bspt/Euclid.space).  But nothing got worse.++There is an infelicity though.  We may get something like+      f = g val+==>+      g x = case gw x of r -> I# r++      f {- InlineStable, Template = g val -}+      f = case gw x of r -> I# r++The code for f duplicates that for g, without any real benefit. It+won't really be executed, because calls to f will go via the inlining.++Note [Don't CPR join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++There's no point in doing CPR on a join point. If the whole function is getting+CPR'd, then the case expression around the worker function will get pushed into+the join point by the simplifier, which will have the same effect that CPR would+have - the result will be returned in an unboxed tuple.++  f z = let join j x y = (x+1, y+1)+        in case z of A -> j 1 2+                     B -> j 2 3++  =>++  f z = case $wf z of (# a, b #) -> (a, b)+  $wf z = case (let join j x y = (x+1, y+1)+                in case z of A -> j 1 2+                             B -> j 2 3) of (a, b) -> (# a, b #)++  =>++  f z = case $wf z of (# a, b #) -> (a, b)+  $wf z = let join j x y = (# x+1, y+1 #)+          in case z of A -> j 1 2+                       B -> j 2 3++Doing CPR on a join point would be tricky anyway, as the worker could not be+a join point because it would not be tail-called. However, doing the *argument*+part of W/W still works for join points, since the wrapper body will make a tail+call:++  f z = let join j x y = x + y+        in ...++  =>++  f z = let join $wj x# y# = x# +# y#+                 j x y = case x of I# x# ->+                         case y of I# y# ->+                         $wj x# y#+        in ...++Note [Wrapper activation]+~~~~~~~~~~~~~~~~~~~~~~~~~+When should the wrapper inlining be active?++1. It must not be active earlier than the current Activation of the+   Id++2. It should be active at some point, despite (1) because of+   Note [Worker-wrapper for NOINLINE functions]++3. For ordinary functions with no pragmas we want to inline the+   wrapper as early as possible (#15056).  Suppose another module+   defines    f x = g x x+   and suppose there is some RULE for (g True True).  Then if we have+   a call (f True), we'd expect to inline 'f' and the RULE will fire.+   But if f is w/w'd (which it might be), we want the inlining to+   occur just as if it hadn't been.++   (This only matters if f's RHS is big enough to w/w, but small+   enough to inline given the call site, but that can happen.)++4. We do not want to inline the wrapper before specialisation.+         module Foo where+           f :: Num a => a -> Int -> a+           f n 0 = n              -- Strict in the Int, hence wrapper+           f n x = f (n+n) (x-1)++           g :: Int -> Int+           g x = f x x            -- Provokes a specialisation for f++         module Bar where+           import Foo++           h :: Int -> Int+           h x = f 3 x++   In module Bar we want to give specialisations a chance to fire+   before inlining f's wrapper.++Reminder: Note [Don't w/w INLINE things], so we don't need to worry+          about INLINE things here.++Conclusion:+  - If the user said NOINLINE[n], respect that+  - If the user said NOINLINE, inline the wrapper as late as+    poss (phase 0). This is a compromise driven by (2) above+  - Otherwise inline wrapper in phase 2.  That allows the+    'gentle' simplification pass to apply specialisation rules++Historical note: At one stage I tried making the wrapper inlining+always-active, and that had a very bad effect on nofib/imaginary/x2n1;+a wrapper was inlined before the specialisation fired.++Note [Wrapper NoUserInline]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+The use an inl_inline of NoUserInline on the wrapper distinguishes+this pragma from one that was given by the user. In particular, CSE+will not happen if there is a user-specified pragma, but should happen+for w/w’ed things (#14186).+-}++tryWW   :: DynFlags+        -> FamInstEnvs+        -> RecFlag+        -> Id                           -- The fn binder+        -> CoreExpr                     -- The bound rhs; its innards+                                        --   are already ww'd+        -> UniqSM [(Id, CoreExpr)]      -- either *one* or *two* pairs;+                                        -- if one, then no worker (only+                                        -- the orig "wrapper" lives on);+                                        -- if two, then a worker and a+                                        -- wrapper.+tryWW dflags fam_envs is_rec fn_id rhs+  -- See Note [Worker-wrapper for NOINLINE functions]++  | Just stable_unf <- certainlyWillInline dflags fn_info+  = return [ (fn_id `setIdUnfolding` stable_unf, rhs) ]+        -- See Note [Don't w/w INLINE things]+        -- See Note [Don't w/w inline small non-loop-breaker things]++  | is_fun && is_eta_exp+  = splitFun dflags fam_envs new_fn_id fn_info wrap_dmds res_info rhs++  | is_thunk                                   -- See Note [Thunk splitting]+  = splitThunk dflags fam_envs is_rec new_fn_id rhs++  | otherwise+  = return [ (new_fn_id, rhs) ]++  where+    fn_info      = idInfo fn_id+    (wrap_dmds, res_info) = splitStrictSig (strictnessInfo fn_info)++    new_fn_id = zapIdUsedOnceInfo (zapIdUsageEnvInfo fn_id)+        -- See Note [Zapping DmdEnv after Demand Analyzer] and+        -- See Note [Zapping Used Once info in WorkWrap]++    is_fun     = notNull wrap_dmds || isJoinId fn_id+    -- See Note [Don't eta expand in w/w]+    is_eta_exp = length wrap_dmds == manifestArity rhs+    is_thunk   = not is_fun && not (exprIsHNF rhs) && not (isJoinId fn_id)+                            && not (isUnliftedType (idType fn_id))++{-+Note [Zapping DmdEnv after Demand Analyzer]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the worker-wrapper pass we zap the DmdEnv.  Why?+ (a) it is never used again+ (b) it wastes space+ (c) it becomes incorrect as things are cloned, because+     we don't push the substitution into it++Why here?+ * Because we don’t want to do it in the Demand Analyzer, as we never know+   there when we are doing the last pass.+ * We want them to be still there at the end of DmdAnal, so that+   -ddump-str-anal contains them.+ * We don’t want a second pass just for that.+ * WorkWrap looks at all bindings anyway.++We also need to do it in TidyCore.tidyLetBndr to clean up after the+final, worker/wrapper-less run of the demand analyser (see+Note [Final Demand Analyser run] in DmdAnal).++Note [Zapping Used Once info in WorkWrap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the worker-wrapper pass we zap the used once info in demands and in+strictness signatures.++Why?+ * The simplifier may happen to transform code in a way that invalidates the+   data (see #11731 for an example).+ * It is not used in later passes, up to code generation.++So as the data is useless and possibly wrong, we want to remove it. The most+convenient place to do that is the worker wrapper phase, as it runs after every+run of the demand analyser besides the very last one (which is the one where we+want to _keep_ the info for the code generator).++We do not do it in the demand analyser for the same reasons outlined in+Note [Zapping DmdEnv after Demand Analyzer] above.++Note [Don't eta expand in w/w]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A binding where the manifestArity of the RHS is less than idArity of the binder+means CoreArity didn't eta expand that binding. When this happens, it does so+for a reason (see Note [exprArity invariant] in CoreArity) and we probably have+a PAP, cast or trivial expression as RHS.++Performing the worker/wrapper split will implicitly eta-expand the binding to+idArity, overriding CoreArity's decision. Other than playing fast and loose with+divergence, it's also broken for newtypes:++  f = (\xy.blah) |> co+    where+      co :: (Int -> Int -> Char) ~ T++Then idArity is 2 (despite the type T), and it can have a StrictSig based on a+threshold of 2. But we can't w/w it without a type error.++The situation is less grave for PAPs, but the implicit eta expansion caused a+compiler allocation regression in T15164, where huge recursive instance method+groups, mostly consisting of PAPs, got w/w'd. This caused great churn in the+simplifier, when simply waiting for the PAPs to inline arrived at the same+output program.++Note there is the worry here that such PAPs and trivial RHSs might not *always*+be inlined. That would lead to reboxing, because the analysis tacitly assumes+that we W/W'd for idArity and will propagate analysis information under that+assumption. So far, this doesn't seem to matter in practice.+See https://gitlab.haskell.org/ghc/ghc/merge_requests/312#note_192064.+-}+++---------------------+splitFun :: DynFlags -> FamInstEnvs -> Id -> IdInfo -> [Demand] -> DmdResult -> CoreExpr+         -> UniqSM [(Id, CoreExpr)]+splitFun dflags fam_envs fn_id fn_info wrap_dmds res_info rhs+  = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) ) do+    -- The arity should match the signature+    stuff <- mkWwBodies dflags fam_envs rhs_fvs fn_id wrap_dmds use_res_info+    case stuff of+      Just (work_demands, join_arity, wrap_fn, work_fn) -> do+        work_uniq <- getUniqueM+        let work_rhs = work_fn rhs+            work_act = case fn_inline_spec of  -- See Note [Worker activation]+                          NoInline -> fn_act+                          _        -> wrap_act++            work_prag = InlinePragma { inl_src = SourceText "{-# INLINE"+                                     , inl_inline = fn_inline_spec+                                     , inl_sat    = Nothing+                                     , inl_act    = work_act+                                     , inl_rule   = FunLike }+              -- inl_inline: copy from fn_id; see Note [Worker-wrapper for INLINABLE functions]+              -- inl_act:    see Note [Worker activation]+              -- inl_rule:   it does not make sense for workers to be constructorlike.++            work_join_arity | isJoinId fn_id = Just join_arity+                            | otherwise      = Nothing+              -- worker is join point iff wrapper is join point+              -- (see Note [Don't CPR join points])++            work_id  = mkWorkerId work_uniq fn_id (exprType work_rhs)+                        `setIdOccInfo` occInfo fn_info+                                -- Copy over occurrence info from parent+                                -- Notably whether it's a loop breaker+                                -- Doesn't matter much, since we will simplify next, but+                                -- seems right-er to do so++                        `setInlinePragma` work_prag++                        `setIdUnfolding` mkWorkerUnfolding dflags work_fn fn_unfolding+                                -- See Note [Worker-wrapper for INLINABLE functions]++                        `setIdStrictness` mkClosedStrictSig work_demands work_res_info+                                -- Even though we may not be at top level,+                                -- it's ok to give it an empty DmdEnv++                        `setIdDemandInfo` worker_demand++                        `setIdArity` work_arity+                                -- Set the arity so that the Core Lint check that the+                                -- arity is consistent with the demand type goes+                                -- through+                        `asJoinId_maybe` work_join_arity++            work_arity = length work_demands++            -- See Note [Demand on the Worker]+            single_call = saturatedByOneShots arity (demandInfo fn_info)+            worker_demand | single_call = mkWorkerDemand work_arity+                          | otherwise   = topDmd++            wrap_rhs  = wrap_fn work_id+            wrap_act  = case fn_act of  -- See Note [Wrapper activation]+                           ActiveAfter {} -> fn_act+                           NeverActive    -> activeDuringFinal+                           _              -> activeAfterInitial+            wrap_prag = InlinePragma { inl_src    = SourceText "{-# INLINE"+                                     , inl_inline = NoUserInline+                                     , inl_sat    = Nothing+                                     , inl_act    = wrap_act+                                     , inl_rule   = rule_match_info }+                -- inl_act:    see Note [Wrapper activation]+                -- inl_inline: see Note [Wrapper NoUserInline]+                -- inl_rule:   RuleMatchInfo is (and must be) unaffected++            wrap_id   = fn_id `setIdUnfolding`  mkWwInlineRule dflags wrap_rhs arity+                              `setInlinePragma` wrap_prag+                              `setIdOccInfo`    noOccInfo+                                -- Zap any loop-breaker-ness, to avoid bleating from Lint+                                -- about a loop breaker with an INLINE rule++++        return $ [(work_id, work_rhs), (wrap_id, wrap_rhs)]+            -- Worker first, because wrapper mentions it++      Nothing -> return [(fn_id, rhs)]+  where+    rhs_fvs         = exprFreeVars rhs+    fn_inl_prag     = inlinePragInfo fn_info+    fn_inline_spec  = inl_inline fn_inl_prag+    fn_act          = inl_act fn_inl_prag+    rule_match_info = inlinePragmaRuleMatchInfo fn_inl_prag+    fn_unfolding    = unfoldingInfo fn_info+    arity           = arityInfo fn_info+                    -- The arity is set by the simplifier using exprEtaExpandArity+                    -- So it may be more than the number of top-level-visible lambdas++    use_res_info  | isJoinId fn_id = topRes -- Note [Don't CPR join points]+                  | otherwise      = res_info+    work_res_info | isJoinId fn_id = res_info -- Worker remains CPR-able+                  | otherwise+                  = case returnsCPR_maybe res_info of+                       Just _  -> topRes    -- Cpr stuff done by wrapper; kill it here+                       Nothing -> res_info  -- Preserve exception/divergence+++{-+Note [Demand on the worker]+~~~~~~~~~~~~~~~~~~~~~~~~~~~++If the original function is called once, according to its demand info, then+so is the worker. This is important so that the occurrence analyser can+attach OneShot annotations to the worker’s lambda binders.+++Example:++  -- Original function+  f [Demand=<L,1*C1(U)>] :: (a,a) -> a+  f = \p -> ...++  -- Wrapper+  f [Demand=<L,1*C1(U)>] :: a -> a -> a+  f = \p -> case p of (a,b) -> $wf a b++  -- Worker+  $wf [Demand=<L,1*C1(C1(U))>] :: Int -> Int+  $wf = \a b -> ...++We need to check whether the original function is called once, with+sufficiently many arguments. This is done using saturatedByOneShots, which+takes the arity of the original function (resp. the wrapper) and the demand on+the original function.++The demand on the worker is then calculated using mkWorkerDemand, and always of+the form [Demand=<L,1*(C1(...(C1(U))))>]+++Note [Do not split void functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this rather common form of binding:+        $j = \x:Void# -> ...no use of x...++Since x is not used it'll be marked as absent.  But there is no point+in w/w-ing because we'll simply add (\y:Void#), see WwLib.mkWorerArgs.++If x has a more interesting type (eg Int, or Int#), there *is* a point+in w/w so that we don't pass the argument at all.++Note [Thunk splitting]+~~~~~~~~~~~~~~~~~~~~~~+Suppose x is used strictly (never mind whether it has the CPR+property).++      let+        x* = x-rhs+      in body++splitThunk transforms like this:++      let+        x* = case x-rhs of { I# a -> I# a }+      in body++Now simplifier will transform to++      case x-rhs of+        I# a -> let x* = I# a+                in body++which is what we want. Now suppose x-rhs is itself a case:++        x-rhs = case e of { T -> I# a; F -> I# b }++The join point will abstract over a, rather than over (which is+what would have happened before) which is fine.++Notice that x certainly has the CPR property now!++In fact, splitThunk uses the function argument w/w splitting+function, so that if x's demand is deeper (say U(U(L,L),L))+then the splitting will go deeper too.+-}++-- See Note [Thunk splitting]+-- splitThunk converts the *non-recursive* binding+--      x = e+-- into+--      x = let x = e+--          in case x of+--               I# y -> let x = I# y in x }+-- See comments above. Is it not beautifully short?+-- Moreover, it works just as well when there are+-- several binders, and if the binders are lifted+-- E.g.     x = e+--     -->  x = let x = e in+--              case x of (a,b) -> let x = (a,b)  in x++splitThunk :: DynFlags -> FamInstEnvs -> RecFlag -> Var -> Expr Var -> UniqSM [(Var, Expr Var)]+splitThunk dflags fam_envs is_rec fn_id rhs+  = ASSERT(not (isJoinId fn_id))+    do { (useful,_, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False [fn_id]+       ; let res = [ (fn_id, Let (NonRec fn_id rhs) (wrap_fn (work_fn (Var fn_id)))) ]+       ; if useful then ASSERT2( isNonRec is_rec, ppr fn_id ) -- The thunk must be non-recursive+                   return res+                   else return [(fn_id, rhs)] }
+ compiler/stranal/WwLib.hs view
@@ -0,0 +1,1192 @@+{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section[WwLib]{A library for the ``worker\/wrapper'' back-end to the strictness analyser}+-}++{-# LANGUAGE CPP #-}++module WwLib ( mkWwBodies, mkWWstr, mkWorkerArgs+             , deepSplitProductType_maybe, findTypeShape+             , isWorkerSmallEnough+ ) where++#include "HsVersions.h"++import GhcPrelude++import CoreSyn+import CoreUtils        ( exprType, mkCast )+import Id+import IdInfo           ( JoinArity )+import DataCon+import Demand+import MkCore           ( mkAbsentErrorApp, mkCoreUbxTup+                        , mkCoreApp, mkCoreLet )+import MkId             ( voidArgId, voidPrimId )+import TysWiredIn       ( tupleDataCon )+import TysPrim          ( voidPrimTy )+import Literal          ( absentLiteralOf, rubbishLit )+import VarEnv           ( mkInScopeSet )+import VarSet           ( VarSet )+import Type+import RepType          ( isVoidTy, typePrimRep )+import Coercion+import FamInstEnv+import BasicTypes       ( Boxity(..) )+import TyCon+import UniqSupply+import Unique+import Maybes+import Util+import Outputable+import DynFlags+import FastString+import ListSetOps++{-+************************************************************************+*                                                                      *+\subsection[mkWrapperAndWorker]{@mkWrapperAndWorker@}+*                                                                      *+************************************************************************++Here's an example.  The original function is:++\begin{verbatim}+g :: forall a . Int -> [a] -> a++g = \/\ a -> \ x ys ->+        case x of+          0 -> head ys+          _ -> head (tail ys)+\end{verbatim}++From this, we want to produce:+\begin{verbatim}+-- wrapper (an unfolding)+g :: forall a . Int -> [a] -> a++g = \/\ a -> \ x ys ->+        case x of+          I# x# -> $wg a x# ys+            -- call the worker; don't forget the type args!++-- worker+$wg :: forall a . Int# -> [a] -> a++$wg = \/\ a -> \ x# ys ->+        let+            x = I# x#+        in+            case x of               -- note: body of g moved intact+              0 -> head ys+              _ -> head (tail ys)+\end{verbatim}++Something we have to be careful about:  Here's an example:++\begin{verbatim}+-- "f" strictness: U(P)U(P)+f (I# a) (I# b) = a +# b++g = f   -- "g" strictness same as "f"+\end{verbatim}++\tr{f} will get a worker all nice and friendly-like; that's good.+{\em But we don't want a worker for \tr{g}}, even though it has the+same strictness as \tr{f}.  Doing so could break laziness, at best.++Consequently, we insist that the number of strictness-info items is+exactly the same as the number of lambda-bound arguments.  (This is+probably slightly paranoid, but OK in practice.)  If it isn't the+same, we ``revise'' the strictness info, so that we won't propagate+the unusable strictness-info into the interfaces.+++************************************************************************+*                                                                      *+\subsection{The worker wrapper core}+*                                                                      *+************************************************************************++@mkWwBodies@ is called when doing the worker\/wrapper split inside a module.+-}++type WwResult+  = ([Demand],              -- Demands for worker (value) args+     JoinArity,             -- Number of worker (type OR value) args+     Id -> CoreExpr,        -- Wrapper body, lacking only the worker Id+     CoreExpr -> CoreExpr)  -- Worker body, lacking the original function rhs++mkWwBodies :: DynFlags+           -> FamInstEnvs+           -> VarSet         -- Free vars of RHS+                             -- See Note [Freshen WW arguments]+           -> Id             -- The original function+           -> [Demand]       -- Strictness of original function+           -> DmdResult      -- Info about function result+           -> UniqSM (Maybe WwResult)++-- wrap_fn_args E       = \x y -> E+-- work_fn_args E       = E x y++-- wrap_fn_str E        = case x of { (a,b) ->+--                        case a of { (a1,a2) ->+--                        E a1 a2 b y }}+-- work_fn_str E        = \a1 a2 b y ->+--                        let a = (a1,a2) in+--                        let x = (a,b) in+--                        E++mkWwBodies dflags fam_envs rhs_fvs fun_id demands res_info+  = do  { let empty_subst = mkEmptyTCvSubst (mkInScopeSet rhs_fvs)+                -- See Note [Freshen WW arguments]++        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)+             <- mkWWargs empty_subst fun_ty demands+        ; (useful1, work_args, wrap_fn_str, work_fn_str)+             <- mkWWstr dflags fam_envs has_inlineable_prag wrap_args++        -- Do CPR w/w.  See Note [Always do CPR w/w]+        ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)+              <- mkWWcpr (gopt Opt_CprAnal dflags) fam_envs res_ty res_info++        ; let (work_lam_args, work_call_args) = mkWorkerArgs dflags work_args cpr_res_ty+              worker_args_dmds = [idDemandInfo v | v <- work_call_args, isId v]+              wrapper_body = wrap_fn_args . wrap_fn_cpr . wrap_fn_str . applyToVars work_call_args . Var+              worker_body = mkLams work_lam_args. work_fn_str . work_fn_cpr . work_fn_args++        ; if isWorkerSmallEnough dflags work_args+             && not (too_many_args_for_join_point wrap_args)+             && ((useful1 && not only_one_void_argument) || useful2)+          then return (Just (worker_args_dmds, length work_call_args,+                       wrapper_body, worker_body))+          else return Nothing+        }+        -- We use an INLINE unconditionally, even if the wrapper turns out to be+        -- something trivial like+        --      fw = ...+        --      f = __inline__ (coerce T fw)+        -- The point is to propagate the coerce to f's call sites, so even though+        -- f's RHS is now trivial (size 1) we still want the __inline__ to prevent+        -- fw from being inlined into f's RHS+  where+    fun_ty        = idType fun_id+    mb_join_arity = isJoinId_maybe fun_id+    has_inlineable_prag = isStableUnfolding (realIdUnfolding fun_id)+                          -- See Note [Do not unpack class dictionaries]++    -- Note [Do not split void functions]+    only_one_void_argument+      | [d] <- demands+      , Just (arg_ty1, _) <- splitFunTy_maybe fun_ty+      , isAbsDmd d && isVoidTy arg_ty1+      = True+      | otherwise+      = False++    -- Note [Join points returning functions]+    too_many_args_for_join_point wrap_args+      | Just join_arity <- mb_join_arity+      , wrap_args `lengthExceeds` join_arity+      = WARN(True, text "Unable to worker/wrapper join point with arity " <+>+                     int join_arity <+> text "but" <+>+                     int (length wrap_args) <+> text "args")+        True+      | otherwise+      = False++-- See Note [Limit w/w arity]+isWorkerSmallEnough :: DynFlags -> [Var] -> Bool+isWorkerSmallEnough dflags vars = count isId vars <= maxWorkerArgs dflags+    -- We count only Free variables (isId) to skip Type, Kind+    -- variables which have no runtime representation.++{-+Note [Always do CPR w/w]+~~~~~~~~~~~~~~~~~~~~~~~~+At one time we refrained from doing CPR w/w for thunks, on the grounds that+we might duplicate work.  But that is already handled by the demand analyser,+which doesn't give the CPR proprety if w/w might waste work: see+Note [CPR for thunks] in DmdAnal.++And if something *has* been given the CPR property and we don't w/w, it's+a disaster, because then the enclosing function might say it has the CPR+property, but now doesn't and there a cascade of disaster.  A good example+is #5920.++Note [Limit w/w arity]+~~~~~~~~~~~~~~~~~~~~~~~~+Guard against high worker arity as it generates a lot of stack traffic.+A simplified example is #11565#comment:6++Current strategy is very simple: don't perform w/w transformation at all+if the result produces a wrapper with arity higher than -fmax-worker-args=.++It is a bit all or nothing, consider++        f (x,y) (a,b,c,d,e ... , z) = rhs++Currently we will remove all w/w ness entirely. But actually we could+w/w on the (x,y) pair... it's the huge product that is the problem.++Could we instead refrain from w/w on an arg-by-arg basis? Yes, that'd+solve f. But we can get a lot of args from deeply-nested products:++        g (a, (b, (c, (d, ...)))) = rhs++This is harder to spot on an arg-by-arg basis. Previously mkWwStr was+given some "fuel" saying how many arguments it could add; when we ran+out of fuel it would stop w/wing.+Still not very clever because it had a left-right bias.++************************************************************************+*                                                                      *+\subsection{Making wrapper args}+*                                                                      *+************************************************************************++During worker-wrapper stuff we may end up with an unlifted thing+which we want to let-bind without losing laziness.  So we+add a void argument.  E.g.++        f = /\a -> \x y z -> E::Int#    -- E does not mention x,y,z+==>+        fw = /\ a -> \void -> E+        f  = /\ a -> \x y z -> fw realworld++We use the state-token type which generates no code.+-}++mkWorkerArgs :: DynFlags -> [Var]+             -> Type    -- Type of body+             -> ([Var], -- Lambda bound args+                 [Var]) -- Args at call site+mkWorkerArgs dflags args res_ty+    | any isId args || not needsAValueLambda+    = (args, args)+    | otherwise+    = (args ++ [voidArgId], args ++ [voidPrimId])+    where+      -- See "Making wrapper args" section above+      needsAValueLambda =+        lifted+        -- We may encounter a levity-polymorphic result, in which case we+        -- conservatively assume that we have laziness that needs preservation.+        -- See #15186.+        || not (gopt Opt_FunToThunk dflags)+           -- see Note [Protecting the last value argument]++      -- Might the result be lifted?+      lifted =+        case isLiftedType_maybe res_ty of+          Just lifted -> lifted+          Nothing     -> True++{-+Note [Protecting the last value argument]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the user writes (\_ -> E), they might be intentionally disallowing+the sharing of E. Since absence analysis and worker-wrapper are keen+to remove such unused arguments, we add in a void argument to prevent+the function from becoming a thunk.++The user can avoid adding the void argument with the -ffun-to-thunk+flag. However, this can create sharing, which may be bad in two ways. 1) It can+create a space leak. 2) It can prevent inlining *under a lambda*. If w/w+removes the last argument from a function f, then f now looks like a thunk, and+so f can't be inlined *under a lambda*.++Note [Join points and beta-redexes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Originally, the worker would invoke the original function by calling it with+arguments, thus producing a beta-redex for the simplifier to munch away:++  \x y z -> e => (\x y z -> e) wx wy wz++Now that we have special rules about join points, however, this is Not Good if+the original function is itself a join point, as then it may contain invocations+of other join points:++  join j1 x = ...+  join j2 y = if y == 0 then 0 else j1 y++  =>++  join j1 x = ...+  join $wj2 y# = let wy = I# y# in (\y -> if y == 0 then 0 else jump j1 y) wy+  join j2 y = case y of I# y# -> jump $wj2 y#++There can't be an intervening lambda between a join point's declaration and its+occurrences, so $wj2 here is wrong. But of course, this is easy enough to fix:++  ...+  let join $wj2 y# = let wy = I# y# in let y = wy in if y == 0 then 0 else j1 y+  ...++Hence we simply do the beta-reduction here. (This would be harder if we had to+worry about hygiene, but luckily wy is freshly generated.)++Note [Join points returning functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++It is crucial that the arity of a join point depends on its *callers,* not its+own syntax. What this means is that a join point can have "extra lambdas":++f :: Int -> Int -> (Int, Int) -> Int+f x y = join j (z, w) = \(u, v) -> ...+        in jump j (x, y)++Typically this happens with functions that are seen as computing functions,+rather than being curried. (The real-life example was GraphOps.addConflicts.)++When we create the wrapper, it *must* be in "eta-contracted" form so that the+jump has the right number of arguments:++f x y = join $wj z' w' = \u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...+             j (z, w)  = jump $wj z w++(See Note [Join points and beta-redexes] for where the lets come from.) If j+were a function, we would instead say++f x y = let $wj = \z' w' u' v' -> let {z = z'; w = w'; u = u'; v = v'} in ...+            j (z, w) (u, v) = $wj z w u v++Notice that the worker ends up with the same lambdas; it's only the wrapper we+have to be concerned about.++FIXME Currently the functionality to produce "eta-contracted" wrappers is+unimplemented; we simply give up.++************************************************************************+*                                                                      *+\subsection{Coercion stuff}+*                                                                      *+************************************************************************++We really want to "look through" coerces.+Reason: I've seen this situation:++        let f = coerce T (\s -> E)+        in \x -> case x of+                    p -> coerce T' f+                    q -> \s -> E2+                    r -> coerce T' f++If only we w/w'd f, we'd get+        let f = coerce T (\s -> fw s)+            fw = \s -> E+        in ...++Now we'll inline f to get++        let fw = \s -> E+        in \x -> case x of+                    p -> fw+                    q -> \s -> E2+                    r -> fw++Now we'll see that fw has arity 1, and will arity expand+the \x to get what we want.+-}++-- mkWWargs just does eta expansion+-- is driven off the function type and arity.+-- It chomps bites off foralls, arrows, newtypes+-- and keeps repeating that until it's satisfied the supplied arity++mkWWargs :: TCvSubst            -- Freshening substitution to apply to the type+                                --   See Note [Freshen WW arguments]+         -> Type                -- The type of the function+         -> [Demand]     -- Demands and one-shot info for value arguments+         -> UniqSM  ([Var],            -- Wrapper args+                     CoreExpr -> CoreExpr,      -- Wrapper fn+                     CoreExpr -> CoreExpr,      -- Worker fn+                     Type)                      -- Type of wrapper body++mkWWargs subst fun_ty demands+  | null demands+  = return ([], id, id, substTy subst fun_ty)++  | (dmd:demands') <- demands+  , Just (arg_ty, fun_ty') <- splitFunTy_maybe fun_ty+  = do  { uniq <- getUniqueM+        ; let arg_ty' = substTy subst arg_ty+              id = mk_wrap_arg uniq arg_ty' dmd+        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)+              <- mkWWargs subst fun_ty' demands'+        ; return (id : wrap_args,+                  Lam id . wrap_fn_args,+                  apply_or_bind_then work_fn_args (varToCoreExpr id),+                  res_ty) }++  | Just (tv, fun_ty') <- splitForAllTy_maybe fun_ty+  = do  { uniq <- getUniqueM+        ; let (subst', tv') = cloneTyVarBndr subst tv uniq+                -- See Note [Freshen WW arguments]+        ; (wrap_args, wrap_fn_args, work_fn_args, res_ty)+             <- mkWWargs subst' fun_ty' demands+        ; return (tv' : wrap_args,+                  Lam tv' . wrap_fn_args,+                  apply_or_bind_then work_fn_args (mkTyArg (mkTyVarTy tv')),+                  res_ty) }++  | Just (co, rep_ty) <- topNormaliseNewType_maybe fun_ty+        -- The newtype case is for when the function has+        -- a newtype after the arrow (rare)+        --+        -- It's also important when we have a function returning (say) a pair+        -- wrapped in a  newtype, at least if CPR analysis can look+        -- through such newtypes, which it probably can since they are+        -- simply coerces.++  = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty)+            <-  mkWWargs subst rep_ty demands+       ; let co' = substCo subst co+       ; return (wrap_args,+                  \e -> Cast (wrap_fn_args e) (mkSymCo co'),+                  \e -> work_fn_args (Cast e co'),+                  res_ty) }++  | otherwise+  = WARN( True, ppr fun_ty )                    -- Should not happen: if there is a demand+    return ([], id, id, substTy subst fun_ty)   -- then there should be a function arrow+  where+    -- See Note [Join points and beta-redexes]+    apply_or_bind_then k arg (Lam bndr body)+      = mkCoreLet (NonRec bndr arg) (k body)    -- Important that arg is fresh!+    apply_or_bind_then k arg fun+      = k $ mkCoreApp (text "mkWWargs") fun arg+applyToVars :: [Var] -> CoreExpr -> CoreExpr+applyToVars vars fn = mkVarApps fn vars++mk_wrap_arg :: Unique -> Type -> Demand -> Id+mk_wrap_arg uniq ty dmd+  = mkSysLocalOrCoVar (fsLit "w") uniq ty+       `setIdDemandInfo` dmd++{- Note [Freshen WW arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Wen we do a worker/wrapper split, we must not in-scope names as the arguments+of the worker, else we'll get name capture.  E.g.++   -- y1 is in scope from further out+   f x = ..y1..++If we accidentally choose y1 as a worker argument disaster results:++   fww y1 y2 = let x = (y1,y2) in ...y1...++To avoid this:++  * We use a fresh unique for both type-variable and term-variable binders+    Originally we lacked this freshness for type variables, and that led+    to the very obscure #12562.  (A type variable in the worker shadowed+    an outer term-variable binding.)++  * Because of this cloning we have to substitute in the type/kind of the+    new binders.  That's why we carry the TCvSubst through mkWWargs.++    So we need a decent in-scope set, just in case that type/kind+    itself has foralls.  We get this from the free vars of the RHS of the+    function since those are the only variables that might be captured.+    It's a lazy thunk, which will only be poked if the type/kind has a forall.++    Another tricky case was when f :: forall a. a -> forall a. a->a+    (i.e. with shadowing), and then the worker used the same 'a' twice.++************************************************************************+*                                                                      *+\subsection{Strictness stuff}+*                                                                      *+************************************************************************+-}++mkWWstr :: DynFlags+        -> FamInstEnvs+        -> Bool    -- True <=> INLINEABLE pragma on this function defn+                   -- See Note [Do not unpack class dictionaries]+        -> [Var]                                -- Wrapper args; have their demand info on them+                                                --  *Includes type variables*+        -> UniqSM (Bool,                        -- Is this useful+                   [Var],                       -- Worker args+                   CoreExpr -> CoreExpr,        -- Wrapper body, lacking the worker call+                                                -- and without its lambdas+                                                -- This fn adds the unboxing++                   CoreExpr -> CoreExpr)        -- Worker body, lacking the original body of the function,+                                                -- and lacking its lambdas.+                                                -- This fn does the reboxing+mkWWstr dflags fam_envs has_inlineable_prag args+  = go args+  where+    go_one arg = mkWWstr_one dflags fam_envs has_inlineable_prag arg++    go []           = return (False, [], nop_fn, nop_fn)+    go (arg : args) = do { (useful1, args1, wrap_fn1, work_fn1) <- go_one arg+                         ; (useful2, args2, wrap_fn2, work_fn2) <- go args+                         ; return ( useful1 || useful2+                                  , args1 ++ args2+                                  , wrap_fn1 . wrap_fn2+                                  , work_fn1 . work_fn2) }++{-+Note [Unpacking arguments with product and polymorphic demands]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The argument is unpacked in a case if it has a product type and has a+strict *and* used demand put on it. I.e., arguments, with demands such+as the following ones:++   <S,U(U, L)>+   <S(L,S),U>++will be unpacked, but++   <S,U> or <B,U>++will not, because the pieces aren't used. This is quite important otherwise+we end up unpacking massive tuples passed to the bottoming function. Example:++        f :: ((Int,Int) -> String) -> (Int,Int) -> a+        f g pr = error (g pr)++        main = print (f fst (1, error "no"))++Does 'main' print "error 1" or "error no"?  We don't really want 'f'+to unbox its second argument.  This actually happened in GHC's onwn+source code, in Packages.applyPackageFlag, which ended up un-boxing+the enormous DynFlags tuple, and being strict in the+as-yet-un-filled-in pkgState files.+-}++----------------------+-- mkWWstr_one wrap_arg = (useful, work_args, wrap_fn, work_fn)+--   *  wrap_fn assumes wrap_arg is in scope,+--        brings into scope work_args (via cases)+--   * work_fn assumes work_args are in scope, a+--        brings into scope wrap_arg (via lets)+-- See Note [How to do the worker/wrapper split]+mkWWstr_one :: DynFlags -> FamInstEnvs+            -> Bool    -- True <=> INLINEABLE pragma on this function defn+                       -- See Note [Do not unpack class dictionaries]+            -> Var+            -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)+mkWWstr_one dflags fam_envs has_inlineable_prag arg+  | isTyVar arg+  = return (False, [arg],  nop_fn, nop_fn)++  | isAbsDmd dmd+  , Just work_fn <- mk_absent_let dflags arg+     -- Absent case.  We can't always handle absence for arbitrary+     -- unlifted types, so we need to choose just the cases we can+     -- (that's what mk_absent_let does)+  = return (True, [], nop_fn, work_fn)++  | isStrictDmd dmd+  , Just cs <- splitProdDmd_maybe dmd+      -- See Note [Unpacking arguments with product and polymorphic demands]+  , not (has_inlineable_prag && isClassPred arg_ty)+      -- See Note [Do not unpack class dictionaries]+  , Just stuff@(_, _, inst_con_arg_tys, _) <- deepSplitProductType_maybe fam_envs arg_ty+  , cs `equalLength` inst_con_arg_tys+      -- See Note [mkWWstr and unsafeCoerce]+  = unbox_one dflags fam_envs arg cs stuff++  | isSeqDmd dmd   -- For seqDmd, splitProdDmd_maybe will return Nothing, but+                   -- it should behave like <S, U(AAAA)>, for some suitable arity+  , Just stuff@(_, _, inst_con_arg_tys, _) <- deepSplitProductType_maybe fam_envs arg_ty+  , let abs_dmds = map (const absDmd) inst_con_arg_tys+  = unbox_one dflags fam_envs arg abs_dmds stuff++  | otherwise   -- Other cases+  = return (False, [arg], nop_fn, nop_fn)++  where+    arg_ty = idType arg+    dmd    = idDemandInfo arg++unbox_one :: DynFlags -> FamInstEnvs -> Var+          -> [Demand]+          -> (DataCon, [Type], [(Type, StrictnessMark)], Coercion)+          -> UniqSM (Bool, [Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr)+unbox_one dflags fam_envs arg cs+          (data_con, inst_tys, inst_con_arg_tys, co)+  = do { (uniq1:uniqs) <- getUniquesM+        ; let   -- See Note [Add demands for strict constructors]+                cs'       = addDataConStrictness data_con cs+                unpk_args = zipWith3 mk_ww_arg uniqs inst_con_arg_tys cs'+                unbox_fn  = mkUnpackCase (Var arg) co uniq1+                                         data_con unpk_args+                arg_no_unf = zapStableUnfolding arg+                             -- See Note [Zap unfolding when beta-reducing]+                             -- in Simplify.hs; and see #13890+                rebox_fn   = Let (NonRec arg_no_unf con_app)+                con_app    = mkConApp2 data_con inst_tys unpk_args `mkCast` mkSymCo co+         ; (_, worker_args, wrap_fn, work_fn) <- mkWWstr dflags fam_envs False unpk_args+         ; return (True, worker_args, unbox_fn . wrap_fn, work_fn . rebox_fn) }+                           -- Don't pass the arg, rebox instead+  where+    mk_ww_arg uniq ty sub_dmd = setIdDemandInfo (mk_ww_local uniq ty) sub_dmd++----------------------+nop_fn :: CoreExpr -> CoreExpr+nop_fn body = body++addDataConStrictness :: DataCon -> [Demand] -> [Demand]+-- See Note [Add demands for strict constructors]+addDataConStrictness con ds+  = ASSERT2( equalLength strs ds, ppr con $$ ppr strs $$ ppr ds )+    zipWith add ds strs+  where+    strs = dataConRepStrictness con+    add dmd str | isMarkedStrict str = strictifyDmd dmd+                | otherwise          = dmd++{- Note [How to do the worker/wrapper split]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The worker-wrapper transformation, mkWWstr_one, takes into account+several possibilities to decide if the function is worthy for+splitting:++1. If an argument is absent, it would be silly to pass it to+   the worker.  Hence the isAbsDmd case.  This case must come+   first because a demand like <S,A> or <B,A> is possible.+   E.g. <B,A> comes from a function like+       f x = error "urk"+   and <S,A> can come from Note [Add demands for strict constructors]++2. If the argument is evaluated strictly, and we can split the+   product demand (splitProdDmd_maybe), then unbox it and w/w its+   pieces.  For example++    f :: (Int, Int) -> Int+    f p = (case p of (a,b) -> a) + 1+  is split to+    f :: (Int, Int) -> Int+    f p = case p of (a,b) -> $wf a++    $wf :: Int -> Int+    $wf a = a + 1++  and+    g :: Bool -> (Int, Int) -> Int+    g c p = case p of (a,b) ->+               if c then a else b+  is split to+   g c p = case p of (a,b) -> $gw c a b+   $gw c a b = if c then a else b++2a But do /not/ split if the components are not used; that is, the+   usage is just 'Used' rather than 'UProd'. In this case+   splitProdDmd_maybe returns Nothing.  Otherwise we risk decomposing+   a massive tuple which is barely used.  Example:++        f :: ((Int,Int) -> String) -> (Int,Int) -> a+        f g pr = error (g pr)++        main = print (f fst (1, error "no"))++   Here, f does not take 'pr' apart, and it's stupid to do so.+   Imagine that it had millions of fields. This actually happened+   in GHC itself where the tuple was DynFlags++3. A plain 'seqDmd', which is head-strict with usage UHead, can't+   be split by splitProdDmd_maybe.  But we want it to behave just+   like U(AAAA) for suitable number of absent demands. So we have+   a special case for it, with arity coming from the data constructor.++Note [Worker-wrapper for bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used not to split if the result is bottom.+[Justification:  there's no efficiency to be gained.]++But it's sometimes bad not to make a wrapper.  Consider+        fw = \x# -> let x = I# x# in case e of+                                        p1 -> error_fn x+                                        p2 -> error_fn x+                                        p3 -> the real stuff+The re-boxing code won't go away unless error_fn gets a wrapper too.+[We don't do reboxing now, but in general it's better to pass an+unboxed thing to f, and have it reboxed in the error cases....]++Note [Add demands for strict constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this program (due to Roman):++    data X a = X !a++    foo :: X Int -> Int -> Int+    foo (X a) n = go 0+     where+       go i | i < n     = a + go (i+1)+            | otherwise = 0++We want the worker for 'foo' too look like this:++    $wfoo :: Int# -> Int# -> Int#++with the first argument unboxed, so that it is not eval'd each time+around the 'go' loop (which would otherwise happen, since 'foo' is not+strict in 'a').  It is sound for the wrapper to pass an unboxed arg+because X is strict, so its argument must be evaluated.  And if we+*don't* pass an unboxed argument, we can't even repair it by adding a+`seq` thus:++    foo (X a) n = a `seq` go 0++because the seq is discarded (very early) since X is strict!++So here's what we do++* We leave the demand-analysis alone.  The demand on 'a' in the+  definition of 'foo' is <L, U(U)>; the strictness info is Lazy+  because foo's body may or may not evaluate 'a'; but the usage info+  says that 'a' is unpacked and its content is used.++* During worker/wrapper, if we unpack a strict constructor (as we do+  for 'foo'), we use 'addDataConStrictness' to bump up the strictness on+  the strict arguments of the data constructor.++* That in turn means that, if the usage info supports doing so+  (i.e. splitProdDmd_maybe returns Just), we will unpack that argument+  -- even though the original demand (e.g. on 'a') was lazy.++* What does "bump up the strictness" mean?  Just add a head-strict+  demand to the strictness!  Even for a demand like <L,A> we can+  safely turn it into <S,A>; remember case (1) of+  Note [How to do the worker/wrapper split].++The net effect is that the w/w transformation is more aggressive about+unpacking the strict arguments of a data constructor, when that+eagerness is supported by the usage info.++There is the usual danger of reboxing, which as usual we ignore. But+if X is monomorphic, and has an UNPACK pragma, then this optimisation+is even more important.  We don't want the wrapper to rebox an unboxed+argument, and pass an Int to $wfoo!++This works in nested situations like++    data family Bar a+    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)+    newtype instance Bar Int = Bar Int++    foo :: Bar ((Int, Int), Int) -> Int -> Int+    foo f k = case f of BarPair x y ->+              case burble of+                 True -> case x of+                           BarPair p q -> ...+                 False -> ...++The extra eagerness lets us produce a worker of type:+     $wfoo :: Int# -> Int# -> Int# -> Int -> Int+     $wfoo p# q# y# = ...++even though the `case x` is only lazily evaluated.++--------- Historical note ------------+We used to add data-con strictness demands when demand analysing case+expression. However, it was noticed in #15696 that this misses some cases. For+instance, consider the program (from T10482)++    data family Bar a+    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)+    newtype instance Bar Int = Bar Int++    foo :: Bar ((Int, Int), Int) -> Int -> Int+    foo f k =+      case f of+        BarPair x y -> case burble of+                          True -> case x of+                                    BarPair p q -> ...+                          False -> ...++We really should be able to assume that `p` is already evaluated since it came+from a strict field of BarPair. This strictness would allow us to produce a+worker of type:++    $wfoo :: Int# -> Int# -> Int# -> Int -> Int+    $wfoo p# q# y# = ...++even though the `case x` is only lazily evaluated++Indeed before we fixed #15696 this would happen since we would float the inner+`case x` through the `case burble` to get:++    foo f k =+      case f of+        BarPair x y -> case x of+                          BarPair p q -> case burble of+                                          True -> ...+                                          False -> ...++However, after fixing #15696 this could no longer happen (for the reasons+discussed in ticket:15696#comment:76). This means that the demand placed on `f`+would then be significantly weaker (since the False branch of the case on+`burble` is not strict in `p` or `q`).++Consequently, we now instead account for data-con strictness in mkWWstr_one,+applying the strictness demands to the final result of DmdAnal. The result is+that we get the strict demand signature we wanted even if we can't float+the case on `x` up through the case on `burble`.+++Note [mkWWstr and unsafeCoerce]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+By using unsafeCoerce, it is possible to make the number of demands fail to+match the number of constructor arguments; this happened in #8037.+If so, the worker/wrapper split doesn't work right and we get a Core Lint+bug.  The fix here is simply to decline to do w/w if that happens.++Note [Record evaluated-ness in worker/wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++   data T = MkT !Int Int++   f :: T -> T+   f x = e++and f's is strict, and has the CPR property.  The we are going to generate+this w/w split++   f x = case x of+           MkT x1 x2 -> case $wf x1 x2 of+                           (# r1, r2 #) -> MkT r1 r2++   $wfw x1 x2 = let x = MkT x1 x2 in+                case e of+                  MkT r1 r2 -> (# r1, r2 #)++Note that++* In the worker $wf, inside 'e' we can be sure that x1 will be+  evaluated (it came from unpacking the argument MkT.  But that's no+  immediately apparent in $wf++* In the wrapper 'f', which we'll inline at call sites, we can be sure+  that 'r1' has been evaluated (because it came from unpacking the result+  MkT.  But that is not immediately apparent from the wrapper code.++Missing these facts isn't unsound, but it loses possible future+opportunities for optimisation.++Solution: use setCaseBndrEvald when creating+ (A) The arg binders x1,x2 in mkWstr_one+         See #13077, test T13077+ (B) The result binders r1,r2 in mkWWcpr_help+         See Trace #13077, test T13077a+         And #13027 comment:20, item (4)+to record that the relevant binder is evaluated.+++************************************************************************+*                                                                      *+         Type scrutiny that is specific to demand analysis+*                                                                      *+************************************************************************++Note [Do not unpack class dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+   f :: Ord a => [a] -> Int -> a+   {-# INLINABLE f #-}+and we worker/wrapper f, we'll get a worker with an INLINABLE pragma+(see Note [Worker-wrapper for INLINABLE functions] in WorkWrap), which+can still be specialised by the type-class specialiser, something like+   fw :: Ord a => [a] -> Int# -> a++BUT if f is strict in the Ord dictionary, we might unpack it, to get+   fw :: (a->a->Bool) -> [a] -> Int# -> a+and the type-class specialiser can't specialise that.  An example is+#6056.++But in any other situation a dictionary is just an ordinary value,+and can be unpacked.  So we track the INLINABLE pragma, and switch+off the unpacking in mkWWstr_one (see the isClassPred test).++Historical note: #14955 describes how I got this fix wrong+the first time.+-}++deepSplitProductType_maybe+    :: FamInstEnvs -> Type+    -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)+-- If    deepSplitProductType_maybe ty = Just (dc, tys, arg_tys, co)+-- then  dc @ tys (args::arg_tys) :: rep_ty+--       co :: ty ~ rep_ty+-- Why do we return the strictness of the data-con arguments?+-- Answer: see Note [Record evaluated-ness in worker/wrapper]+deepSplitProductType_maybe fam_envs ty+  | let (co, ty1) = topNormaliseType_maybe fam_envs ty+                    `orElse` (mkRepReflCo ty, ty)+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1+  , Just con <- isDataProductTyCon_maybe tc+  , let arg_tys = dataConInstArgTys con tc_args+        strict_marks = dataConRepStrictness con+  = Just (con, tc_args, zipEqual "dspt" arg_tys strict_marks, co)+deepSplitProductType_maybe _ _ = Nothing++deepSplitCprType_maybe+    :: FamInstEnvs -> ConTag -> Type+    -> Maybe (DataCon, [Type], [(Type, StrictnessMark)], Coercion)+-- If    deepSplitCprType_maybe n ty = Just (dc, tys, arg_tys, co)+-- then  dc @ tys (args::arg_tys) :: rep_ty+--       co :: ty ~ rep_ty+-- Why do we return the strictness of the data-con arguments?+-- Answer: see Note [Record evaluated-ness in worker/wrapper]+deepSplitCprType_maybe fam_envs con_tag ty+  | let (co, ty1) = topNormaliseType_maybe fam_envs ty+                    `orElse` (mkRepReflCo ty, ty)+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1+  , isDataTyCon tc+  , let cons = tyConDataCons tc+  , cons `lengthAtLeast` con_tag -- This might not be true if we import the+                                 -- type constructor via a .hs-bool file (#8743)+  , let con = cons `getNth` (con_tag - fIRST_TAG)+        arg_tys = dataConInstArgTys con tc_args+        strict_marks = dataConRepStrictness con+  = Just (con, tc_args, zipEqual "dsct" arg_tys strict_marks, co)+deepSplitCprType_maybe _ _ _ = Nothing++findTypeShape :: FamInstEnvs -> Type -> TypeShape+-- Uncover the arrow and product shape of a type+-- The data type TypeShape is defined in Demand+-- See Note [Trimming a demand to a type] in Demand+findTypeShape fam_envs ty+  | Just (tc, tc_args)  <- splitTyConApp_maybe ty+  , Just con <- isDataProductTyCon_maybe tc+  = TsProd (map (findTypeShape fam_envs) $ dataConInstArgTys con tc_args)++  | Just (_, res) <- splitFunTy_maybe ty+  = TsFun (findTypeShape fam_envs res)++  | Just (_, ty') <- splitForAllTy_maybe ty+  = findTypeShape fam_envs ty'++  | Just (_, ty') <- topNormaliseType_maybe fam_envs ty+  = findTypeShape fam_envs ty'++  | otherwise+  = TsUnk++{-+************************************************************************+*                                                                      *+\subsection{CPR stuff}+*                                                                      *+************************************************************************+++@mkWWcpr@ takes the worker/wrapper pair produced from the strictness+info and adds in the CPR transformation.  The worker returns an+unboxed tuple containing non-CPR components.  The wrapper takes this+tuple and re-produces the correct structured output.++The non-CPR results appear ordered in the unboxed tuple as if by a+left-to-right traversal of the result structure.+-}++mkWWcpr :: Bool+        -> FamInstEnvs+        -> Type                              -- function body type+        -> DmdResult                         -- CPR analysis results+        -> UniqSM (Bool,                     -- Is w/w'ing useful?+                   CoreExpr -> CoreExpr,     -- New wrapper+                   CoreExpr -> CoreExpr,     -- New worker+                   Type)                     -- Type of worker's body++mkWWcpr opt_CprAnal fam_envs body_ty res+    -- CPR explicitly turned off (or in -O0)+  | not opt_CprAnal = return (False, id, id, body_ty)+    -- CPR is turned on by default for -O and O2+  | otherwise+  = case returnsCPR_maybe res of+       Nothing      -> return (False, id, id, body_ty)  -- No CPR info+       Just con_tag | Just stuff <- deepSplitCprType_maybe fam_envs con_tag body_ty+                    -> mkWWcpr_help stuff+                    |  otherwise+                       -- See Note [non-algebraic or open body type warning]+                    -> WARN( True, text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )+                       return (False, id, id, body_ty)++mkWWcpr_help :: (DataCon, [Type], [(Type,StrictnessMark)], Coercion)+             -> UniqSM (Bool, CoreExpr -> CoreExpr, CoreExpr -> CoreExpr, Type)++mkWWcpr_help (data_con, inst_tys, arg_tys, co)+  | [arg1@(arg_ty1, _)] <- arg_tys+  , isUnliftedType arg_ty1+        -- Special case when there is a single result of unlifted type+        --+        -- Wrapper:     case (..call worker..) of x -> C x+        -- Worker:      case (   ..body..    ) of C x -> x+  = do { (work_uniq : arg_uniq : _) <- getUniquesM+       ; let arg       = mk_ww_local arg_uniq arg1+             con_app   = mkConApp2 data_con inst_tys [arg] `mkCast` mkSymCo co++       ; return ( True+                , \ wkr_call -> Case wkr_call arg (exprType con_app) [(DEFAULT, [], con_app)]+                , \ body     -> mkUnpackCase body co work_uniq data_con [arg] (varToCoreExpr arg)+                                -- varToCoreExpr important here: arg can be a coercion+                                -- Lacking this caused #10658+                , arg_ty1 ) }++  | otherwise   -- The general case+        -- Wrapper: case (..call worker..) of (# a, b #) -> C a b+        -- Worker:  case (   ...body...  ) of C a b -> (# a, b #)+  = do { (work_uniq : wild_uniq : uniqs) <- getUniquesM+       ; let wrap_wild   = mk_ww_local wild_uniq (ubx_tup_ty,MarkedStrict)+             args        = zipWith mk_ww_local uniqs arg_tys+             ubx_tup_ty  = exprType ubx_tup_app+             ubx_tup_app = mkCoreUbxTup (map fst arg_tys) (map varToCoreExpr args)+             con_app     = mkConApp2 data_con inst_tys args `mkCast` mkSymCo co++       ; return (True+                , \ wkr_call -> Case wkr_call wrap_wild (exprType con_app)  [(DataAlt (tupleDataCon Unboxed (length arg_tys)), args, con_app)]+                , \ body     -> mkUnpackCase body co work_uniq data_con args ubx_tup_app+                , ubx_tup_ty ) }++mkUnpackCase ::  CoreExpr -> Coercion -> Unique -> DataCon -> [Id] -> CoreExpr -> CoreExpr+-- (mkUnpackCase e co uniq Con args body)+--      returns+-- case e |> co of bndr { Con args -> body }++mkUnpackCase (Tick tickish e) co uniq con args body   -- See Note [Profiling and unpacking]+  = Tick tickish (mkUnpackCase e co uniq con args body)+mkUnpackCase scrut co uniq boxing_con unpk_args body+  = Case casted_scrut bndr (exprType body)+         [(DataAlt boxing_con, unpk_args, body)]+  where+    casted_scrut = scrut `mkCast` co+    bndr = mk_ww_local uniq (exprType casted_scrut, MarkedStrict)++{-+Note [non-algebraic or open body type warning]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++There are a few cases where the W/W transformation is told that something+returns a constructor, but the type at hand doesn't really match this. One+real-world example involves unsafeCoerce:+  foo = IO a+  foo = unsafeCoerce c_exit+  foreign import ccall "c_exit" c_exit :: IO ()+Here CPR will tell you that `foo` returns a () constructor for sure, but trying+to create a worker/wrapper for type `a` obviously fails.+(This was a real example until ee8e792  in libraries/base.)++It does not seem feasible to avoid all such cases already in the analyser (and+after all, the analysis is not really wrong), so we simply do nothing here in+mkWWcpr. But we still want to emit warning with -DDEBUG, to hopefully catch+other cases where something went avoidably wrong.+++Note [Profiling and unpacking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the original function looked like+        f = \ x -> {-# SCC "foo" #-} E++then we want the CPR'd worker to look like+        \ x -> {-# SCC "foo" #-} (case E of I# x -> x)+and definitely not+        \ x -> case ({-# SCC "foo" #-} E) of I# x -> x)++This transform doesn't move work or allocation+from one cost centre to another.++Later [SDM]: presumably this is because we want the simplifier to+eliminate the case, and the scc would get in the way?  I'm ok with+including the case itself in the cost centre, since it is morally+part of the function (post transformation) anyway.+++************************************************************************+*                                                                      *+\subsection{Utilities}+*                                                                      *+************************************************************************++Note [Absent errors]+~~~~~~~~~~~~~~~~~~~~+We make a new binding for Ids that are marked absent, thus+   let x = absentError "x :: Int"+The idea is that this binding will never be used; but if it+buggily is used we'll get a runtime error message.++Coping with absence for *unlifted* types is important; see, for+example, #4306 and #15627.  In the UnliftedRep case, we can+use LitRubbish, which we need to apply to the required type.+For the unlifted types of singleton kind like Float#, Addr#, etc. we+also find a suitable literal, using Literal.absentLiteralOf.  We don't+have literals for every primitive type, so the function is partial.++Note: I did try the experiment of using an error thunk for unlifted+things too, relying on the simplifier to drop it as dead code.+But this is fragile++ - It fails when profiling is on, which disables various optimisations++ - It fails when reboxing happens. E.g.+      data T = MkT Int Int#+      f p@(MkT a _) = ...g p....+   where g is /lazy/ in 'p', but only uses the first component.  Then+   'f' is /strict/ in 'p', and only uses the first component.  So we only+   pass that component to the worker for 'f', which reconstructs 'p' to+   pass it to 'g'.  Alas we can't say+       ...f (MkT a (absentError Int# "blah"))...+   bacause `MkT` is strict in its Int# argument, so we get an absentError+   exception when we shouldn't.  Very annoying!++So absentError is only used for lifted types.+-}++-- | Tries to find a suitable dummy RHS to bind the given absent identifier to.+--+-- If @mk_absent_let _ id == Just wrap@, then @wrap e@ will wrap a let binding+-- for @id@ with that RHS around @e@. Otherwise, there could no suitable RHS be+-- found (currently only happens for bindings of 'VecRep' representation).+mk_absent_let :: DynFlags -> Id -> Maybe (CoreExpr -> CoreExpr)+mk_absent_let dflags arg+  -- The lifted case: Bind 'absentError'+  -- See Note [Absent errors]+  | not (isUnliftedType arg_ty)+  = Just (Let (NonRec lifted_arg abs_rhs))+  -- The 'UnliftedRep' (because polymorphic) case: Bind @__RUBBISH \@arg_ty@+  -- See Note [Absent errors]+  | [UnliftedRep] <- typePrimRep arg_ty+  = Just (Let (NonRec arg unlifted_rhs))+  -- The monomorphic unlifted cases: Bind to some literal, if possible+  -- See Note [Absent errors]+  | Just tc <- tyConAppTyCon_maybe arg_ty+  , Just lit <- absentLiteralOf tc+  = Just (Let (NonRec arg (Lit lit)))+  | arg_ty `eqType` voidPrimTy+  = Just (Let (NonRec arg (Var voidPrimId)))+  | otherwise+  = WARN( True, text "No absent value for" <+> ppr arg_ty )+    Nothing -- Can happen for 'State#' and things of 'VecRep'+  where+    lifted_arg   = arg `setIdStrictness` botSig+              -- Note in strictness signature that this is bottoming+              -- (for the sake of the "empty case scrutinee not known to+              -- diverge for sure lint" warning)+    arg_ty       = idType arg+    abs_rhs      = mkAbsentErrorApp arg_ty msg+    msg          = showSDoc (gopt_set dflags Opt_SuppressUniques)+                          (ppr arg <+> ppr (idType arg))+              -- We need to suppress uniques here because otherwise they'd+              -- end up in the generated code as strings. This is bad for+              -- determinism, because with different uniques the strings+              -- will have different lengths and hence different costs for+              -- the inliner leading to different inlining.+              -- See also Note [Unique Determinism] in Unique+    unlifted_rhs = mkTyApps (Lit rubbishLit) [arg_ty]++mk_ww_local :: Unique -> (Type, StrictnessMark) -> Id+-- The StrictnessMark comes form the data constructor and says+-- whether this field is strict+-- See Note [Record evaluated-ness in worker/wrapper]+mk_ww_local uniq (ty,str)+  = setCaseBndrEvald str $+    mkSysLocalOrCoVar (fsLit "ww") uniq ty
+ compiler/typecheck/ClsInst.hs view
@@ -0,0 +1,699 @@+{-# LANGUAGE CPP #-}++module ClsInst (+     matchGlobalInst,+     ClsInstResult(..),+     InstanceWhat(..), safeOverlap,+     AssocInstInfo(..), isNotAssociated+  ) where++#include "HsVersions.h"++import GhcPrelude++import TcEnv+import TcRnMonad+import TcType+import TcMType+import TcEvidence+import RnEnv( addUsedGRE )+import RdrName( lookupGRE_FieldLabel )+import InstEnv+import Inst( instDFunType )+import FamInst( tcGetFamInstEnvs, tcInstNewTyCon_maybe, tcLookupDataFamInst )++import TysWiredIn+import TysPrim( eqPrimTyCon, eqReprPrimTyCon )+import PrelNames++import Id+import Type+import MkCore ( mkStringExprFS, mkNaturalExpr )++import Name   ( Name )+import VarEnv ( VarEnv )+import DataCon+import TyCon+import Class+import DynFlags+import Outputable+import Util( splitAtList, fstOf3 )+import Data.Maybe++{- *******************************************************************+*                                                                    *+              A helper for associated types within+              class instance declarations+*                                                                    *+**********************************************************************-}++-- | Extra information about the parent instance declaration, needed+-- when type-checking associated types. The 'Class' is the enclosing+-- class, the [TyVar] are the /scoped/ type variable of the instance decl.+-- The @VarEnv Type@ maps class variables to their instance types.+data AssocInstInfo+  = NotAssociated+  | InClsInst { ai_class    :: Class+              , ai_tyvars   :: [TyVar]      -- ^ The /scoped/ tyvars of the instance+                                            -- Why scoped?  See bind_me in+                                            -- TcValidity.checkConsistentFamInst+              , ai_inst_env :: VarEnv Type  -- ^ Maps /class/ tyvars to their instance types+                -- See Note [Matching in the consistent-instantation check]+    }++isNotAssociated :: AssocInstInfo -> Bool+isNotAssociated NotAssociated  = True+isNotAssociated (InClsInst {}) = False+++{- *******************************************************************+*                                                                    *+                       Class lookup+*                                                                    *+**********************************************************************-}++-- | Indicates if Instance met the Safe Haskell overlapping instances safety+-- check.+--+-- See Note [Safe Haskell Overlapping Instances] in TcSimplify+-- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify+type SafeOverlapping = Bool++data ClsInstResult+  = NoInstance   -- Definitely no instance++  | OneInst { cir_new_theta :: [TcPredType]+            , cir_mk_ev     :: [EvExpr] -> EvTerm+            , cir_what      :: InstanceWhat }++  | NotSure      -- Multiple matches and/or one or more unifiers++data InstanceWhat+  = BuiltinInstance+  | LocalInstance+  | TopLevInstance { iw_dfun_id   :: DFunId+                   , iw_safe_over :: SafeOverlapping }++instance Outputable ClsInstResult where+  ppr NoInstance = text "NoInstance"+  ppr NotSure    = text "NotSure"+  ppr (OneInst { cir_new_theta = ev+               , cir_what = what })+    = text "OneInst" <+> vcat [ppr ev, ppr what]++instance Outputable InstanceWhat where+  ppr BuiltinInstance = text "built-in instance"+  ppr LocalInstance   = text "locally-quantified instance"+  ppr (TopLevInstance { iw_safe_over = so })+     = text "top-level instance" <+> (text $ if so then "[safe]" else "[unsafe]")++safeOverlap :: InstanceWhat -> Bool+safeOverlap (TopLevInstance { iw_safe_over = so }) = so+safeOverlap _                                      = True++matchGlobalInst :: DynFlags+                -> Bool      -- True <=> caller is the short-cut solver+                             -- See Note [Shortcut solving: overlap]+                -> Class -> [Type] -> TcM ClsInstResult+matchGlobalInst dflags short_cut clas tys+  | cls_name == knownNatClassName+  = matchKnownNat    dflags short_cut clas tys+  | cls_name == knownSymbolClassName+  = matchKnownSymbol dflags short_cut clas tys+  | isCTupleClass clas                = matchCTuple          clas tys+  | cls_name == typeableClassName     = matchTypeable        clas tys+  | clas `hasKey` heqTyConKey         = matchHeteroEquality       tys+  | clas `hasKey` eqTyConKey          = matchHomoEquality         tys+  | clas `hasKey` coercibleTyConKey   = matchCoercible            tys+  | cls_name == hasFieldClassName     = matchHasField dflags short_cut clas tys+  | otherwise                         = matchInstEnv dflags short_cut clas tys+  where+    cls_name = className clas+++{- ********************************************************************+*                                                                     *+                   Looking in the instance environment+*                                                                     *+***********************************************************************-}+++matchInstEnv :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult+matchInstEnv dflags short_cut_solver clas tys+   = do { instEnvs <- tcGetInstEnvs+        ; let safeOverlapCheck = safeHaskell dflags `elem` [Sf_Safe, Sf_Trustworthy]+              (matches, unify, unsafeOverlaps) = lookupInstEnv True instEnvs clas tys+              safeHaskFail = safeOverlapCheck && not (null unsafeOverlaps)+        ; traceTc "matchInstEnv" $+            vcat [ text "goal:" <+> ppr clas <+> ppr tys+                 , text "matches:" <+> ppr matches+                 , text "unify:" <+> ppr unify ]+        ; case (matches, unify, safeHaskFail) of++            -- Nothing matches+            ([], [], _)+                -> do { traceTc "matchClass not matching" (ppr pred)+                      ; return NoInstance }++            -- A single match (& no safe haskell failure)+            ([(ispec, inst_tys)], [], False)+                | short_cut_solver      -- Called from the short-cut solver+                , isOverlappable ispec+                -- If the instance has OVERLAPPABLE or OVERLAPS or INCOHERENT+                -- then don't let the short-cut solver choose it, because a+                -- later instance might overlap it.  #14434 is an example+                -- See Note [Shortcut solving: overlap]+                -> do { traceTc "matchClass: ignoring overlappable" (ppr pred)+                      ; return NotSure }++                | otherwise+                -> do { let dfun_id = instanceDFunId ispec+                      ; traceTc "matchClass success" $+                        vcat [text "dict" <+> ppr pred,+                              text "witness" <+> ppr dfun_id+                                             <+> ppr (idType dfun_id) ]+                                -- Record that this dfun is needed+                      ; match_one (null unsafeOverlaps) dfun_id inst_tys }++            -- More than one matches (or Safe Haskell fail!). Defer any+            -- reactions of a multitude until we learn more about the reagent+            _   -> do { traceTc "matchClass multiple matches, deferring choice" $+                        vcat [text "dict" <+> ppr pred,+                              text "matches" <+> ppr matches]+                      ; return NotSure } }+   where+     pred = mkClassPred clas tys++match_one :: SafeOverlapping -> DFunId -> [DFunInstType] -> TcM ClsInstResult+             -- See Note [DFunInstType: instantiating types] in InstEnv+match_one so dfun_id mb_inst_tys+  = do { traceTc "match_one" (ppr dfun_id $$ ppr mb_inst_tys)+       ; (tys, theta) <- instDFunType dfun_id mb_inst_tys+       ; traceTc "match_one 2" (ppr dfun_id $$ ppr tys $$ ppr theta)+       ; return $ OneInst { cir_new_theta = theta+                          , cir_mk_ev     = evDFunApp dfun_id tys+                          , cir_what      = TopLevInstance { iw_dfun_id = dfun_id+                                                           , iw_safe_over = so } } }+++{- Note [Shortcut solving: overlap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+  instance {-# OVERLAPPABLE #-} C a where ...+and we are typechecking+  f :: C a => a -> a+  f = e  -- Gives rise to [W] C a++We don't want to solve the wanted constraint with the overlappable+instance; rather we want to use the supplied (C a)! That was the whole+point of it being overlappable!  #14434 wwas an example.++Alas even if the instance has no overlap flag, thus+  instance C a where ...+there is nothing to stop it being overlapped. GHC provides no way to+declare an instance as "final" so it can't be overlapped.  But really+only final instances are OK for short-cut solving.  Sigh. #15135+was a puzzling example.+-}+++{- ********************************************************************+*                                                                     *+                   Class lookup for CTuples+*                                                                     *+***********************************************************************-}++matchCTuple :: Class -> [Type] -> TcM ClsInstResult+matchCTuple clas tys   -- (isCTupleClass clas) holds+  = return (OneInst { cir_new_theta = tys+                    , cir_mk_ev     = tuple_ev+                    , cir_what      = BuiltinInstance })+            -- The dfun *is* the data constructor!+  where+     data_con = tyConSingleDataCon (classTyCon clas)+     tuple_ev = evDFunApp (dataConWrapId data_con) tys++{- ********************************************************************+*                                                                     *+                   Class lookup for Literals+*                                                                     *+***********************************************************************-}++{-+Note [KnownNat & KnownSymbol and EvLit]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A part of the type-level literals implementation are the classes+"KnownNat" and "KnownSymbol", which provide a "smart" constructor for+defining singleton values.  Here is the key stuff from GHC.TypeLits++  class KnownNat (n :: Nat) where+    natSing :: SNat n++  newtype SNat (n :: Nat) = SNat Integer++Conceptually, this class has infinitely many instances:++  instance KnownNat 0       where natSing = SNat 0+  instance KnownNat 1       where natSing = SNat 1+  instance KnownNat 2       where natSing = SNat 2+  ...++In practice, we solve `KnownNat` predicates in the type-checker+(see typecheck/TcInteract.hs) because we can't have infinitely many instances.+The evidence (aka "dictionary") for `KnownNat` is of the form `EvLit (EvNum n)`.++We make the following assumptions about dictionaries in GHC:+  1. The "dictionary" for classes with a single method---like `KnownNat`---is+     a newtype for the type of the method, so using a evidence amounts+     to a coercion, and+  2. Newtypes use the same representation as their definition types.++So, the evidence for `KnownNat` is just a value of the representation type,+wrapped in two newtype constructors: one to make it into a `SNat` value,+and another to make it into a `KnownNat` dictionary.++Also note that `natSing` and `SNat` are never actually exposed from the+library---they are just an implementation detail.  Instead, users see+a more convenient function, defined in terms of `natSing`:++  natVal :: KnownNat n => proxy n -> Integer++The reason we don't use this directly in the class is that it is simpler+and more efficient to pass around an integer rather than an entire function,+especially when the `KnowNat` evidence is packaged up in an existential.++The story for kind `Symbol` is analogous:+  * class KnownSymbol+  * newtype SSymbol+  * Evidence: a Core literal (e.g. mkNaturalExpr)+++Note [Fabricating Evidence for Literals in Backpack]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Let `T` be a type of kind `Nat`. When solving for a purported instance+of `KnownNat T`, ghc tries to resolve the type `T` to an integer `n`,+in which case the evidence `EvLit (EvNum n)` is generated on the+fly. It might appear that this is sufficient as users cannot define+their own instances of `KnownNat`. However, for backpack module this+would not work (see issue #15379). Consider the signature `Abstract`++> signature Abstract where+>   data T :: Nat+>   instance KnownNat T++and a module `Util` that depends on it:++> module Util where+>  import Abstract+>  printT :: IO ()+>  printT = do print $ natVal (Proxy :: Proxy T)++Clearly, we need to "use" the dictionary associated with `KnownNat T`+in the module `Util`, but it is too early for the compiler to produce+a real dictionary as we still have not fixed what `T` is. Only when we+mixin a concrete module++> module Concrete where+>   type T = 42++do we really get hold of the underlying integer. So the strategy that+we follow is the following++1. If T is indeed available as a type alias for an integer constant,+   generate the dictionary on the fly, failing which++2. Look up the type class environment for the evidence.++Finally actual code gets generate for Util only when a module like+Concrete gets "mixed-in" in place of the signature Abstract. As a+result all things, including the typeclass instances, in Concrete gets+reexported. So `KnownNat` gets resolved the normal way post-Backpack.++A similar generation works for `KnownSymbol` as well++-}++matchKnownNat :: DynFlags+              -> Bool      -- True <=> caller is the short-cut solver+                           -- See Note [Shortcut solving: overlap]+              -> Class -> [Type] -> TcM ClsInstResult+matchKnownNat _ _ clas [ty]     -- clas = KnownNat+  | Just n <- isNumLitTy ty = do+        et <- mkNaturalExpr n+        makeLitDict clas ty et+matchKnownNat df sc clas tys = matchInstEnv df sc clas tys+ -- See Note [Fabricating Evidence for Literals in Backpack] for why+ -- this lookup into the instance environment is required.++matchKnownSymbol :: DynFlags+                 -> Bool      -- True <=> caller is the short-cut solver+                              -- See Note [Shortcut solving: overlap]+                 -> Class -> [Type] -> TcM ClsInstResult+matchKnownSymbol _ _ clas [ty]  -- clas = KnownSymbol+  | Just s <- isStrLitTy ty = do+        et <- mkStringExprFS s+        makeLitDict clas ty et+matchKnownSymbol df sc clas tys = matchInstEnv df sc clas tys+ -- See Note [Fabricating Evidence for Literals in Backpack] for why+ -- this lookup into the instance environment is required.++makeLitDict :: Class -> Type -> EvExpr -> TcM ClsInstResult+-- makeLitDict adds a coercion that will convert the literal into a dictionary+-- of the appropriate type.  See Note [KnownNat & KnownSymbol and EvLit]+-- in TcEvidence.  The coercion happens in 2 steps:+--+--     Integer -> SNat n     -- representation of literal to singleton+--     SNat n  -> KnownNat n -- singleton to dictionary+--+--     The process is mirrored for Symbols:+--     String    -> SSymbol n+--     SSymbol n -> KnownSymbol n+makeLitDict clas ty et+    | Just (_, co_dict) <- tcInstNewTyCon_maybe (classTyCon clas) [ty]+          -- co_dict :: KnownNat n ~ SNat n+    , [ meth ]   <- classMethods clas+    , Just tcRep <- tyConAppTyCon_maybe -- SNat+                      $ funResultTy         -- SNat n+                      $ dropForAlls         -- KnownNat n => SNat n+                      $ idType meth         -- forall n. KnownNat n => SNat n+    , Just (_, co_rep) <- tcInstNewTyCon_maybe tcRep [ty]+          -- SNat n ~ Integer+    , let ev_tm = mkEvCast et (mkTcSymCo (mkTcTransCo co_dict co_rep))+    = return $ OneInst { cir_new_theta = []+                       , cir_mk_ev     = \_ -> ev_tm+                       , cir_what      = BuiltinInstance }++    | otherwise+    = pprPanic "makeLitDict" $+      text "Unexpected evidence for" <+> ppr (className clas)+      $$ vcat (map (ppr . idType) (classMethods clas))++{- ********************************************************************+*                                                                     *+                   Class lookup for Typeable+*                                                                     *+***********************************************************************-}++-- | Assumes that we've checked that this is the 'Typeable' class,+-- and it was applied to the correct argument.+matchTypeable :: Class -> [Type] -> TcM ClsInstResult+matchTypeable clas [k,t]  -- clas = Typeable+  -- For the first two cases, See Note [No Typeable for polytypes or qualified types]+  | isForAllTy k                      = return NoInstance   -- Polytype+  | isJust (tcSplitPredFunTy_maybe t) = return NoInstance   -- Qualified type++  -- Now cases that do work+  | k `eqType` typeNatKind                 = doTyLit knownNatClassName         t+  | k `eqType` typeSymbolKind              = doTyLit knownSymbolClassName      t+  | tcIsConstraintKind t                   = doTyConApp clas t constraintKindTyCon []+  | Just (arg,ret) <- splitFunTy_maybe t   = doFunTy    clas t arg ret+  | Just (tc, ks) <- splitTyConApp_maybe t -- See Note [Typeable (T a b c)]+  , onlyNamedBndrsApplied tc ks            = doTyConApp clas t tc ks+  | Just (f,kt)   <- splitAppTy_maybe t    = doTyApp    clas t f kt++matchTypeable _ _ = return NoInstance++-- | Representation for a type @ty@ of the form @arg -> ret@.+doFunTy :: Class -> Type -> Type -> Type -> TcM ClsInstResult+doFunTy clas ty arg_ty ret_ty+  = return $ OneInst { cir_new_theta = preds+                     , cir_mk_ev     = mk_ev+                     , cir_what      = BuiltinInstance }+  where+    preds = map (mk_typeable_pred clas) [arg_ty, ret_ty]+    mk_ev [arg_ev, ret_ev] = evTypeable ty $+                             EvTypeableTrFun (EvExpr arg_ev) (EvExpr ret_ev)+    mk_ev _ = panic "TcInteract.doFunTy"+++-- | Representation for type constructor applied to some kinds.+-- 'onlyNamedBndrsApplied' has ensured that this application results in a type+-- of monomorphic kind (e.g. all kind variables have been instantiated).+doTyConApp :: Class -> Type -> TyCon -> [Kind] -> TcM ClsInstResult+doTyConApp clas ty tc kind_args+  | Just _ <- tyConRepName_maybe tc+  = return $ OneInst { cir_new_theta = (map (mk_typeable_pred clas) kind_args)+                     , cir_mk_ev     = mk_ev+                     , cir_what      = BuiltinInstance }+  | otherwise+  = return NoInstance+  where+    mk_ev kinds = evTypeable ty $ EvTypeableTyCon tc (map EvExpr kinds)++-- | Representation for TyCon applications of a concrete kind. We just use the+-- kind itself, but first we must make sure that we've instantiated all kind-+-- polymorphism, but no more.+onlyNamedBndrsApplied :: TyCon -> [KindOrType] -> Bool+onlyNamedBndrsApplied tc ks+ = all isNamedTyConBinder used_bndrs &&+   not (any isNamedTyConBinder leftover_bndrs)+ where+   bndrs                        = tyConBinders tc+   (used_bndrs, leftover_bndrs) = splitAtList ks bndrs++doTyApp :: Class -> Type -> Type -> KindOrType -> TcM ClsInstResult+-- Representation for an application of a type to a type-or-kind.+--  This may happen when the type expression starts with a type variable.+--  Example (ignoring kind parameter):+--    Typeable (f Int Char)                      -->+--    (Typeable (f Int), Typeable Char)          -->+--    (Typeable f, Typeable Int, Typeable Char)  --> (after some simp. steps)+--    Typeable f+doTyApp clas ty f tk+  | isForAllTy (tcTypeKind f)+  = return NoInstance -- We can't solve until we know the ctr.+  | otherwise+  = return $ OneInst { cir_new_theta = map (mk_typeable_pred clas) [f, tk]+                     , cir_mk_ev     = mk_ev+                     , cir_what      = BuiltinInstance }+  where+    mk_ev [t1,t2] = evTypeable ty $ EvTypeableTyApp (EvExpr t1) (EvExpr t2)+    mk_ev _ = panic "doTyApp"+++-- Emit a `Typeable` constraint for the given type.+mk_typeable_pred :: Class -> Type -> PredType+mk_typeable_pred clas ty = mkClassPred clas [ tcTypeKind ty, ty ]++  -- Typeable is implied by KnownNat/KnownSymbol. In the case of a type literal+  -- we generate a sub-goal for the appropriate class.+  -- See Note [Typeable for Nat and Symbol]+doTyLit :: Name -> Type -> TcM ClsInstResult+doTyLit kc t = do { kc_clas <- tcLookupClass kc+                  ; let kc_pred    = mkClassPred kc_clas [ t ]+                        mk_ev [ev] = evTypeable t $ EvTypeableTyLit (EvExpr ev)+                        mk_ev _    = panic "doTyLit"+                  ; return (OneInst { cir_new_theta = [kc_pred]+                                    , cir_mk_ev     = mk_ev+                                    , cir_what      = BuiltinInstance }) }++{- Note [Typeable (T a b c)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For type applications we always decompose using binary application,+via doTyApp, until we get to a *kind* instantiation.  Example+   Proxy :: forall k. k -> *++To solve Typeable (Proxy (* -> *) Maybe) we+  - First decompose with doTyApp,+    to get (Typeable (Proxy (* -> *))) and Typeable Maybe+  - Then solve (Typeable (Proxy (* -> *))) with doTyConApp++If we attempt to short-cut by solving it all at once, via+doTyConApp++(this note is sadly truncated FIXME)+++Note [No Typeable for polytypes or qualified types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not support impredicative typeable, such as+   Typeable (forall a. a->a)+   Typeable (Eq a => a -> a)+   Typeable (() => Int)+   Typeable (((),()) => Int)++See #9858.  For forall's the case is clear: we simply don't have+a TypeRep for them.  For qualified but not polymorphic types, like+(Eq a => a -> a), things are murkier.  But:++ * We don't need a TypeRep for these things.  TypeReps are for+   monotypes only.++ * Perhaps we could treat `=>` as another type constructor for `Typeable`+   purposes, and thus support things like `Eq Int => Int`, however,+   at the current state of affairs this would be an odd exception as+   no other class works with impredicative types.+   For now we leave it off, until we have a better story for impredicativity.+++Note [Typeable for Nat and Symbol]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have special Typeable instances for Nat and Symbol.  Roughly we+have this instance, implemented here by doTyLit:+      instance KnownNat n => Typeable (n :: Nat) where+         typeRep = typeNatTypeRep @n+where+   Data.Typeable.Internals.typeNatTypeRep :: KnownNat a => TypeRep a++Ultimately typeNatTypeRep uses 'natSing' from KnownNat to get a+runtime value 'n'; it turns it into a string with 'show' and uses+that to whiz up a TypeRep TyCon for 'n', with mkTypeLitTyCon.+See #10348.++Because of this rule it's inadvisable (see #15322) to have a constraint+    f :: (Typeable (n :: Nat)) => blah+in a function signature; it gives rise to overlap problems just as+if you'd written+    f :: Eq [a] => blah+-}++{- ********************************************************************+*                                                                     *+                   Class lookup for lifted equality+*                                                                     *+***********************************************************************-}++-- See also Note [The equality types story] in TysPrim+matchHeteroEquality :: [Type] -> TcM ClsInstResult+-- Solves (t1 ~~ t2)+matchHeteroEquality args+  = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon args ]+                    , cir_mk_ev     = evDataConApp heqDataCon args+                    , cir_what      = BuiltinInstance })++matchHomoEquality :: [Type] -> TcM ClsInstResult+-- Solves (t1 ~ t2)+matchHomoEquality args@[k,t1,t2]+  = return (OneInst { cir_new_theta = [ mkTyConApp eqPrimTyCon [k,k,t1,t2] ]+                    , cir_mk_ev     = evDataConApp eqDataCon args+                    , cir_what      = BuiltinInstance })+matchHomoEquality args = pprPanic "matchHomoEquality" (ppr args)++-- See also Note [The equality types story] in TysPrim+matchCoercible :: [Type] -> TcM ClsInstResult+matchCoercible args@[k, t1, t2]+  = return (OneInst { cir_new_theta = [ mkTyConApp eqReprPrimTyCon args' ]+                    , cir_mk_ev     = evDataConApp coercibleDataCon args+                    , cir_what      = BuiltinInstance })+  where+    args' = [k, k, t1, t2]+matchCoercible args = pprPanic "matchLiftedCoercible" (ppr args)+++{- ********************************************************************+*                                                                     *+              Class lookup for overloaded record fields+*                                                                     *+***********************************************************************-}++{-+Note [HasField instances]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++    data T y = MkT { foo :: [y] }++and `foo` is in scope.  Then GHC will automatically solve a constraint like++    HasField "foo" (T Int) b++by emitting a new wanted++    T alpha -> [alpha] ~# T Int -> b++and building a HasField dictionary out of the selector function `foo`,+appropriately cast.++The HasField class is defined (in GHC.Records) thus:++    class HasField (x :: k) r a | x r -> a where+      getField :: r -> a++Since this is a one-method class, it is represented as a newtype.+Hence we can solve `HasField "foo" (T Int) b` by taking an expression+of type `T Int -> b` and casting it using the newtype coercion.+Note that++    foo :: forall y . T y -> [y]++so the expression we construct is++    foo @alpha |> co++where++    co :: (T alpha -> [alpha]) ~# HasField "foo" (T Int) b++is built from++    co1 :: (T alpha -> [alpha]) ~# (T Int -> b)++which is the new wanted, and++    co2 :: (T Int -> b) ~# HasField "foo" (T Int) b++which can be derived from the newtype coercion.++If `foo` is not in scope, or has a higher-rank or existentially+quantified type, then the constraint is not solved automatically, but+may be solved by a user-supplied HasField instance.  Similarly, if we+encounter a HasField constraint where the field is not a literal+string, or does not belong to the type, then we fall back on the+normal constraint solver behaviour.+-}++-- See Note [HasField instances]+matchHasField :: DynFlags -> Bool -> Class -> [Type] -> TcM ClsInstResult+matchHasField dflags short_cut clas tys+  = do { fam_inst_envs <- tcGetFamInstEnvs+       ; rdr_env       <- getGlobalRdrEnv+       ; case tys of+           -- We are matching HasField {k} x r a...+           [_k_ty, x_ty, r_ty, a_ty]+               -- x should be a literal string+             | Just x <- isStrLitTy x_ty+               -- r should be an applied type constructor+             , Just (tc, args) <- tcSplitTyConApp_maybe r_ty+               -- use representation tycon (if data family); it has the fields+             , let r_tc = fstOf3 (tcLookupDataFamInst fam_inst_envs tc args)+               -- x should be a field of r+             , Just fl <- lookupTyConFieldLabel x r_tc+               -- the field selector should be in scope+             , Just gre <- lookupGRE_FieldLabel rdr_env fl++             -> do { sel_id <- tcLookupId (flSelector fl)+                   ; (tv_prs, preds, sel_ty) <- tcInstType newMetaTyVars sel_id++                         -- The first new wanted constraint equates the actual+                         -- type of the selector with the type (r -> a) within+                         -- the HasField x r a dictionary.  The preds will+                         -- typically be empty, but if the datatype has a+                         -- "stupid theta" then we have to include it here.+                   ; let theta = mkPrimEqPred sel_ty (mkVisFunTy r_ty a_ty) : preds++                         -- Use the equality proof to cast the selector Id to+                         -- type (r -> a), then use the newtype coercion to cast+                         -- it to a HasField dictionary.+                         mk_ev (ev1:evs) = evSelector sel_id tvs evs `evCast` co+                           where+                             co = mkTcSubCo (evTermCoercion (EvExpr ev1))+                                      `mkTcTransCo` mkTcSymCo co2+                         mk_ev [] = panic "matchHasField.mk_ev"++                         Just (_, co2) = tcInstNewTyCon_maybe (classTyCon clas)+                                                              tys++                         tvs = mkTyVarTys (map snd tv_prs)++                     -- The selector must not be "naughty" (i.e. the field+                     -- cannot have an existentially quantified type), and+                     -- it must not be higher-rank.+                   ; if not (isNaughtyRecordSelector sel_id) && isTauTy sel_ty+                     then do { addUsedGRE True gre+                             ; return OneInst { cir_new_theta = theta+                                              , cir_mk_ev     = mk_ev+                                              , cir_what      = BuiltinInstance } }+                     else matchInstEnv dflags short_cut clas tys }++           _ -> matchInstEnv dflags short_cut clas tys }
+ compiler/typecheck/FamInst.hs view
@@ -0,0 +1,955 @@+-- The @FamInst@ type: family instance heads++{-# LANGUAGE CPP, GADTs #-}++module FamInst (+        FamInstEnvs, tcGetFamInstEnvs,+        checkFamInstConsistency, tcExtendLocalFamInstEnv,+        tcLookupDataFamInst, tcLookupDataFamInst_maybe,+        tcInstNewTyCon_maybe, tcTopNormaliseNewTypeTF_maybe,+        newFamInst,++        -- * Injectivity+        makeInjectivityErrors, injTyVarsOfType, injTyVarsOfTypes+    ) where++import GhcPrelude++import HscTypes+import FamInstEnv+import InstEnv( roughMatchTcs )+import Coercion+import CoreLint+import TcEvidence+import LoadIface+import TcRnMonad+import SrcLoc+import TyCon+import TcType+import CoAxiom+import DynFlags+import Module+import Outputable+import Util+import RdrName+import DataCon ( dataConName )+import Maybes+import Type+import TyCoRep+import TcMType+import Name+import Pair+import Panic+import VarSet+import Bag( Bag, unionBags, unitBag )+import Control.Monad++#include "HsVersions.h"++{- Note [The type family instance consistency story]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++To preserve type safety we must ensure that for any given module, all+the type family instances used either in that module or in any module+it directly or indirectly imports are consistent. For example, consider++  module F where+    type family F a++  module A where+    import F( F )+    type instance F Int = Bool+    f :: F Int -> Bool+    f x = x++  module B where+    import F( F )+    type instance F Int = Char+    g :: Char -> F Int+    g x = x++  module Bad where+    import A( f )+    import B( g )+    bad :: Char -> Int+    bad c = f (g c)++Even though module Bad never mentions the type family F at all, by+combining the functions f and g that were type checked in contradictory+type family instance environments, the function bad is able to coerce+from one type to another. So when we type check Bad we must verify that+the type family instances defined in module A are consistent with those+defined in module B.++How do we ensure that we maintain the necessary consistency?++* Call a module which defines at least one type family instance a+  "family instance module". This flag `mi_finsts` is recorded in the+  interface file.++* For every module we calculate the set of all of its direct and+  indirect dependencies that are family instance modules. This list+  `dep_finsts` is also recorded in the interface file so we can compute+  this list for a module from the lists for its direct dependencies.++* When type checking a module M we check consistency of all the type+  family instances that are either provided by its `dep_finsts` or+  defined in the module M itself. This is a pairwise check, i.e., for+  every pair of instances we must check that they are consistent.++  - For family instances coming from `dep_finsts`, this is checked in+    checkFamInstConsistency, called from tcRnImports. See Note+    [Checking family instance consistency] for details on this check+    (and in particular how we avoid having to do all these checks for+    every module we compile).++  - That leaves checking the family instances defined in M itself+    against instances defined in either M or its `dep_finsts`. This is+    checked in `tcExtendLocalFamInstEnv'.++There are four subtle points in this scheme which have not been+addressed yet.++* We have checked consistency of the family instances *defined* by M+  or its imports, but this is not by definition the same thing as the+  family instances *used* by M or its imports.  Specifically, we need to+  ensure when we use a type family instance while compiling M that this+  instance was really defined from either M or one of its imports,+  rather than being an instance that we happened to know about from+  reading an interface file in the course of compiling an unrelated+  module. Otherwise, we'll end up with no record of the fact that M+  depends on this family instance and type safety will be compromised.+  See #13102.++* It can also happen that M uses a function defined in another module+  which is not transitively imported by M. Examples include the+  desugaring of various overloaded constructs, and references inserted+  by Template Haskell splices. If that function's definition makes use+  of type family instances which are not checked against those visible+  from M, type safety can again be compromised. See #13251.++* When a module C imports a boot module B.hs-boot, we check that C's+  type family instances are compatible with those visible from+  B.hs-boot. However, C will eventually be linked against a different+  module B.hs, which might define additional type family instances which+  are inconsistent with C's. This can also lead to loss of type safety.+  See #9562.++* The call to checkFamConsistency for imported functions occurs very+  early (in tcRnImports) and that causes problems if the imported+  instances use type declared in the module being compiled.+  See Note [Loading your own hi-boot file] in LoadIface.+-}++{-+************************************************************************+*                                                                      *+                 Making a FamInst+*                                                                      *+************************************************************************+-}++-- All type variables in a FamInst must be fresh. This function+-- creates the fresh variables and applies the necessary substitution+-- It is defined here to avoid a dependency from FamInstEnv on the monad+-- code.++newFamInst :: FamFlavor -> CoAxiom Unbranched -> TcM FamInst+-- Freshen the type variables of the FamInst branches+newFamInst flavor axiom@(CoAxiom { co_ax_tc = fam_tc })+  = ASSERT2( tyCoVarsOfTypes lhs `subVarSet` tcv_set, text "lhs" <+> pp_ax )+    ASSERT2( lhs_kind `eqType` rhs_kind, text "kind" <+> pp_ax $$ ppr lhs_kind $$ ppr rhs_kind )+    -- We used to have an assertion that the tyvars of the RHS were bound+    -- by tcv_set, but in error situations like  F Int = a that isn't+    -- true; a later check in checkValidFamInst rejects it+    do { (subst, tvs') <- freshenTyVarBndrs tvs+       ; (subst, cvs') <- freshenCoVarBndrsX subst cvs+       ; dflags <- getDynFlags+       ; let lhs'     = substTys subst lhs+             rhs'     = substTy  subst rhs+             tcvs'    = tvs' ++ cvs'+       ; ifErrsM (return ()) $ -- Don't lint when there are errors, because+                               -- errors might mean TcTyCons.+                               -- See Note [Recover from validity error] in TcTyClsDecls+         when (gopt Opt_DoCoreLinting dflags) $+           -- Check that the types involved in this instance are well formed.+           -- Do /not/ expand type synonyms, for the reasons discussed in+           -- Note [Linting type synonym applications].+           case lintTypes dflags tcvs' (rhs':lhs') of+             Nothing       -> pure ()+             Just fail_msg -> pprPanic "Core Lint error" (vcat [ fail_msg+                                                               , ppr fam_tc+                                                               , ppr subst+                                                               , ppr tvs'+                                                               , ppr cvs'+                                                               , ppr lhs'+                                                               , ppr rhs' ])+       ; return (FamInst { fi_fam      = tyConName fam_tc+                         , fi_flavor   = flavor+                         , fi_tcs      = roughMatchTcs lhs+                         , fi_tvs      = tvs'+                         , fi_cvs      = cvs'+                         , fi_tys      = lhs'+                         , fi_rhs      = rhs'+                         , fi_axiom    = axiom }) }+  where+    lhs_kind = tcTypeKind (mkTyConApp fam_tc lhs)+    rhs_kind = tcTypeKind rhs+    tcv_set  = mkVarSet (tvs ++ cvs)+    pp_ax    = pprCoAxiom axiom+    CoAxBranch { cab_tvs = tvs+               , cab_cvs = cvs+               , cab_lhs = lhs+               , cab_rhs = rhs } = coAxiomSingleBranch axiom+++{-+************************************************************************+*                                                                      *+        Optimised overlap checking for family instances+*                                                                      *+************************************************************************++Note [Checking family instance consistency]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For any two family instance modules that we import directly or indirectly, we+check whether the instances in the two modules are consistent, *unless* we can+be certain that the instances of the two modules have already been checked for+consistency during the compilation of modules that we import.++Why do we need to check?  Consider+   module X1 where                module X2 where+    data T1                         data T2+    type instance F T1 b = Int      type instance F a T2 = Char+    f1 :: F T1 a -> Int             f2 :: Char -> F a T2+    f1 x = x                        f2 x = x++Now if we import both X1 and X2 we could make (f2 . f1) :: Int -> Char.+Notice that neither instance is an orphan.++How do we know which pairs of modules have already been checked? For each+module M we directly import, we look up the family instance modules that M+imports (directly or indirectly), say F1, ..., FN. For any two modules+among M, F1, ..., FN, we know that the family instances defined in those+two modules are consistent--because we checked that when we compiled M.++For every other pair of family instance modules we import (directly or+indirectly), we check that they are consistent now. (So that we can be+certain that the modules in our `HscTypes.dep_finsts' are consistent.)++There is some fancy footwork regarding hs-boot module loops, see+Note [Don't check hs-boot type family instances too early]++Note [Checking family instance optimization]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As explained in Note [Checking family instance consistency]+we need to ensure that every pair of transitive imports that define type family+instances is consistent.++Let's define df(A) = transitive imports of A that define type family instances++ A, if A defines type family instances++Then for every direct import A, df(A) is already consistent.++Let's name the current module M.++We want to make sure that df(M) is consistent.+df(M) = df(D_1) U df(D_2) U ... U df(D_i) where D_1 .. D_i are direct imports.++We perform the check iteratively, maintaining a set of consistent modules 'C'+and trying to add df(D_i) to it.++The key part is how to ensure that the union C U df(D_i) is consistent.++Let's consider two modules: A and B from C U df(D_i).+There are nine possible ways to choose A and B from C U df(D_i):++             | A in C only      | A in C and B in df(D_i) | A in df(D_i) only+--------------------------------------------------------------------------------+B in C only  | Already checked  | Already checked         | Needs to be checked+             | when checking C  | when checking C         |+--------------------------------------------------------------------------------+B in C and   | Already checked  | Already checked         | Already checked when+B in df(D_i) | when checking C  | when checking C         | checking df(D_i)+--------------------------------------------------------------------------------+B in df(D_i) | Needs to be      | Already checked         | Already checked when+only         | checked          | when checking df(D_i)   | checking df(D_i)++That means to ensure that C U df(D_i) is consistent we need to check every+module from C - df(D_i) against every module from df(D_i) - C and+every module from df(D_i) - C against every module from C - df(D_i).+But since the checks are symmetric it suffices to pick A from C - df(D_i)+and B from df(D_i) - C.++In other words these are the modules we need to check:+  [ (m1, m2) | m1 <- C, m1 not in df(D_i)+             , m2 <- df(D_i), m2 not in C ]++One final thing to note here is that if there's lot of overlap between+subsequent df(D_i)'s then we expect those set differences to be small.+That situation should be pretty common in practice, there's usually+a set of utility modules that every module imports directly or indirectly.++This is basically the idea from #13092, comment:14.+-}++-- This function doesn't check ALL instances for consistency,+-- only ones that aren't involved in recursive knot-tying+-- loops; see Note [Don't check hs-boot type family instances too early].+-- We don't need to check the current module, this is done in+-- tcExtendLocalFamInstEnv.+-- See Note [The type family instance consistency story].+checkFamInstConsistency :: [Module] -> TcM ()+checkFamInstConsistency directlyImpMods+  = do { dflags     <- getDynFlags+       ; (eps, hpt) <- getEpsAndHpt+       ; traceTc "checkFamInstConsistency" (ppr directlyImpMods)+       ; let { -- Fetch the iface of a given module.  Must succeed as+               -- all directly imported modules must already have been loaded.+               modIface mod =+                 case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of+                   Nothing    -> panicDoc "FamInst.checkFamInstConsistency"+                                          (ppr mod $$ pprHPT hpt)+                   Just iface -> iface++               -- Which family instance modules were checked for consistency+               -- when we compiled `mod`?+               -- Itself (if a family instance module) and its dep_finsts.+               -- This is df(D_i) from+               -- Note [Checking family instance optimization]+             ; modConsistent :: Module -> [Module]+             ; modConsistent mod =+                 if mi_finsts (modIface mod) then mod:deps else deps+                 where+                 deps = dep_finsts . mi_deps . modIface $ mod++             ; hmiModule     = mi_module . hm_iface+             ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv+                               . md_fam_insts . hm_details+             ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi)+                                           | hmi <- eltsHpt hpt]++             }++       ; checkMany hpt_fam_insts modConsistent directlyImpMods+       }+  where+    -- See Note [Checking family instance optimization]+    checkMany+      :: ModuleEnv FamInstEnv   -- home package family instances+      -> (Module -> [Module])   -- given A, modules checked when A was checked+      -> [Module]               -- modules to process+      -> TcM ()+    checkMany hpt_fam_insts modConsistent mods = go [] emptyModuleSet mods+      where+      go :: [Module] -- list of consistent modules+         -> ModuleSet -- set of consistent modules, same elements as the+                      -- list above+         -> [Module] -- modules to process+         -> TcM ()+      go _ _ [] = return ()+      go consistent consistent_set (mod:mods) = do+        sequence_+          [ check hpt_fam_insts m1 m2+          | m1 <- to_check_from_mod+            -- loop over toCheckFromMod first, it's usually smaller,+            -- it may even be empty+          , m2 <- to_check_from_consistent+          ]+        go consistent' consistent_set' mods+        where+        mod_deps_consistent =  modConsistent mod+        mod_deps_consistent_set = mkModuleSet mod_deps_consistent+        consistent' = to_check_from_mod ++ consistent+        consistent_set' =+          extendModuleSetList consistent_set to_check_from_mod+        to_check_from_consistent =+          filterOut (`elemModuleSet` mod_deps_consistent_set) consistent+        to_check_from_mod =+          filterOut (`elemModuleSet` consistent_set) mod_deps_consistent+        -- Why don't we just minusModuleSet here?+        -- We could, but doing so means one of two things:+        --+        --   1. When looping over the cartesian product we convert+        --   a set into a non-deterministicly ordered list. Which+        --   happens to be fine for interface file determinism+        --   in this case, today, because the order only+        --   determines the order of deferred checks. But such+        --   invariants are hard to keep.+        --+        --   2. When looping over the cartesian product we convert+        --   a set into a deterministically ordered list - this+        --   adds some additional cost of sorting for every+        --   direct import.+        --+        --   That also explains why we need to keep both 'consistent'+        --   and 'consistentSet'.+        --+        --   See also Note [ModuleEnv performance and determinism].+    check hpt_fam_insts m1 m2+      = do { env1' <- getFamInsts hpt_fam_insts m1+           ; env2' <- getFamInsts hpt_fam_insts m2+           -- We're checking each element of env1 against env2.+           -- The cost of that is dominated by the size of env1, because+           -- for each instance in env1 we look it up in the type family+           -- environment env2, and lookup is cheap.+           -- The code below ensures that env1 is the smaller environment.+           ; let sizeE1 = famInstEnvSize env1'+                 sizeE2 = famInstEnvSize env2'+                 (env1, env2) = if sizeE1 < sizeE2 then (env1', env2')+                                                   else (env2', env1')+           -- Note [Don't check hs-boot type family instances too early]+           -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+           -- Family instance consistency checking involves checking that+           -- the family instances of our imported modules are consistent with+           -- one another; this might lead you to think that this process+           -- has nothing to do with the module we are about to typecheck.+           -- Not so!  Consider the following case:+           --+           --   -- A.hs-boot+           --   type family F a+           --+           --   -- B.hs+           --   import {-# SOURCE #-} A+           --   type instance F Int = Bool+           --+           --   -- A.hs+           --   import B+           --   type family F a+           --+           -- When typechecking A, we are NOT allowed to poke the TyThing+           -- for F until we have typechecked the family.  Thus, we+           -- can't do consistency checking for the instance in B+           -- (checkFamInstConsistency is called during renaming).+           -- Failing to defer the consistency check lead to #11062.+           --+           -- Additionally, we should also defer consistency checking when+           -- type from the hs-boot file of the current module occurs on+           -- the left hand side, as we will poke its TyThing when checking+           -- for overlap.+           --+           --   -- F.hs+           --   type family F a+           --+           --   -- A.hs-boot+           --   import F+           --   data T+           --+           --   -- B.hs+           --   import {-# SOURCE #-} A+           --   import F+           --   type instance F T = Int+           --+           --   -- A.hs+           --   import B+           --   data T = MkT+           --+           -- In fact, it is even necessary to defer for occurrences in+           -- the RHS, because we may test for *compatibility* in event+           -- of an overlap.+           --+           -- Why don't we defer ALL of the checks to later?  Well, many+           -- instances aren't involved in the recursive loop at all.  So+           -- we might as well check them immediately; and there isn't+           -- a good time to check them later in any case: every time+           -- we finish kind-checking a type declaration and add it to+           -- a context, we *then* consistency check all of the instances+           -- which mentioned that type.  We DO want to check instances+           -- as quickly as possible, so that we aren't typechecking+           -- values with inconsistent axioms in scope.+           --+           -- See also Note [Tying the knot]+           -- for why we are doing this at all.+           ; let check_now = famInstEnvElts env1+           ; mapM_ (checkForConflicts (emptyFamInstEnv, env2))           check_now+           ; mapM_ (checkForInjectivityConflicts (emptyFamInstEnv,env2)) check_now+ }++getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv+getFamInsts hpt_fam_insts mod+  | Just env <- lookupModuleEnv hpt_fam_insts mod = return env+  | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod)+                   ; eps <- getEps+                   ; return (expectJust "checkFamInstConsistency" $+                             lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }+  where+    doc = ppr mod <+> text "is a family-instance module"++{-+************************************************************************+*                                                                      *+        Lookup+*                                                                      *+************************************************************************++-}++-- | If @co :: T ts ~ rep_ty@ then:+--+-- > instNewTyCon_maybe T ts = Just (rep_ty, co)+--+-- Checks for a newtype, and for being saturated+-- Just like Coercion.instNewTyCon_maybe, but returns a TcCoercion+tcInstNewTyCon_maybe :: TyCon -> [TcType] -> Maybe (TcType, TcCoercion)+tcInstNewTyCon_maybe = instNewTyCon_maybe++-- | Like 'tcLookupDataFamInst_maybe', but returns the arguments back if+-- there is no data family to unwrap.+-- Returns a Representational coercion+tcLookupDataFamInst :: FamInstEnvs -> TyCon -> [TcType]+                    -> (TyCon, [TcType], Coercion)+tcLookupDataFamInst fam_inst_envs tc tc_args+  | Just (rep_tc, rep_args, co)+      <- tcLookupDataFamInst_maybe fam_inst_envs tc tc_args+  = (rep_tc, rep_args, co)+  | otherwise+  = (tc, tc_args, mkRepReflCo (mkTyConApp tc tc_args))++tcLookupDataFamInst_maybe :: FamInstEnvs -> TyCon -> [TcType]+                          -> Maybe (TyCon, [TcType], Coercion)+-- ^ Converts a data family type (eg F [a]) to its representation type (eg FList a)+-- and returns a coercion between the two: co :: F [a] ~R FList a.+tcLookupDataFamInst_maybe fam_inst_envs tc tc_args+  | isDataFamilyTyCon tc+  , match : _ <- lookupFamInstEnv fam_inst_envs tc tc_args+  , FamInstMatch { fim_instance = rep_fam@(FamInst { fi_axiom = ax+                                                   , fi_cvs   = cvs })+                 , fim_tys      = rep_args+                 , fim_cos      = rep_cos } <- match+  , let rep_tc = dataFamInstRepTyCon rep_fam+        co     = mkUnbranchedAxInstCo Representational ax rep_args+                                      (mkCoVarCos cvs)+  = ASSERT( null rep_cos ) -- See Note [Constrained family instances] in FamInstEnv+    Just (rep_tc, rep_args, co)++  | otherwise+  = Nothing++-- | 'tcTopNormaliseNewTypeTF_maybe' gets rid of top-level newtypes,+-- potentially looking through newtype /instances/.+--+-- It is only used by the type inference engine (specifically, when+-- solving representational equality), and hence it is careful to unwrap+-- only if the relevant data constructor is in scope.  That's why+-- it get a GlobalRdrEnv argument.+--+-- It is careful not to unwrap data/newtype instances if it can't+-- continue unwrapping.  Such care is necessary for proper error+-- messages.+--+-- It does not look through type families.+-- It does not normalise arguments to a tycon.+--+-- If the result is Just (rep_ty, (co, gres), rep_ty), then+--    co : ty ~R rep_ty+--    gres are the GREs for the data constructors that+--                          had to be in scope+tcTopNormaliseNewTypeTF_maybe :: FamInstEnvs+                              -> GlobalRdrEnv+                              -> Type+                              -> Maybe ((Bag GlobalRdrElt, TcCoercion), Type)+tcTopNormaliseNewTypeTF_maybe faminsts rdr_env ty+-- cf. FamInstEnv.topNormaliseType_maybe and Coercion.topNormaliseNewType_maybe+  = topNormaliseTypeX stepper plus ty+  where+    plus :: (Bag GlobalRdrElt, TcCoercion) -> (Bag GlobalRdrElt, TcCoercion)+         -> (Bag GlobalRdrElt, TcCoercion)+    plus (gres1, co1) (gres2, co2) = ( gres1 `unionBags` gres2+                                     , co1 `mkTransCo` co2 )++    stepper :: NormaliseStepper (Bag GlobalRdrElt, TcCoercion)+    stepper = unwrap_newtype `composeSteppers` unwrap_newtype_instance++    -- For newtype instances we take a double step or nothing, so that+    -- we don't return the representation type of the newtype instance,+    -- which would lead to terrible error messages+    unwrap_newtype_instance rec_nts tc tys+      | Just (tc', tys', co) <- tcLookupDataFamInst_maybe faminsts tc tys+      = mapStepResult (\(gres, co1) -> (gres, co `mkTransCo` co1)) $+        unwrap_newtype rec_nts tc' tys'+      | otherwise = NS_Done++    unwrap_newtype rec_nts tc tys+      | Just con <- newTyConDataCon_maybe tc+      , Just gre <- lookupGRE_Name rdr_env (dataConName con)+           -- This is where we check that the+           -- data constructor is in scope+      = mapStepResult (\co -> (unitBag gre, co)) $+        unwrapNewTypeStepper rec_nts tc tys++      | otherwise+      = NS_Done++{-+************************************************************************+*                                                                      *+        Extending the family instance environment+*                                                                      *+************************************************************************+-}++-- Add new locally-defined family instances, checking consistency with+-- previous locally-defined family instances as well as all instances+-- available from imported modules. This requires loading all of our+-- imports that define family instances (if we haven't loaded them already).+tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a++-- If we weren't actually given any instances to add, then we don't want+-- to go to the bother of loading family instance module dependencies.+tcExtendLocalFamInstEnv [] thing_inside = thing_inside++-- Otherwise proceed...+tcExtendLocalFamInstEnv fam_insts thing_inside+ = do { -- Load family-instance modules "below" this module, so that+        -- allLocalFamInst can check for consistency with them+        -- See Note [The type family instance consistency story]+        loadDependentFamInstModules fam_insts++        -- Now add the instances one by one+      ; env <- getGblEnv+      ; (inst_env', fam_insts') <- foldlM addLocalFamInst+                                       (tcg_fam_inst_env env, tcg_fam_insts env)+                                       fam_insts++      ; let env' = env { tcg_fam_insts    = fam_insts'+                       , tcg_fam_inst_env = inst_env' }+      ; setGblEnv env' thing_inside+      }++loadDependentFamInstModules :: [FamInst] -> TcM ()+-- Load family-instance modules "below" this module, so that+-- allLocalFamInst can check for consistency with them+-- See Note [The type family instance consistency story]+loadDependentFamInstModules fam_insts+ = do { env <- getGblEnv+      ; let this_mod = tcg_mod env+            imports  = tcg_imports env++            want_module mod  -- See Note [Home package family instances]+              | mod == this_mod = False+              | home_fams_only  = moduleUnitId mod == moduleUnitId this_mod+              | otherwise       = True+            home_fams_only = all (nameIsHomePackage this_mod . fi_fam) fam_insts++      ; loadModuleInterfaces (text "Loading family-instance modules") $+        filter want_module (imp_finsts imports) }++{- Note [Home package family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Optimization: If we're only defining type family instances+for type families *defined in the home package*, then we+only have to load interface files that belong to the home+package. The reason is that there's no recursion between+packages, so modules in other packages can't possibly define+instances for our type families.++(Within the home package, we could import a module M that+imports us via an hs-boot file, and thereby defines an+instance of a type family defined in this module. So we can't+apply the same logic to avoid reading any interface files at+all, when we define an instances for type family defined in+the current module.+-}++-- Check that the proposed new instance is OK,+-- and then add it to the home inst env+-- This must be lazy in the fam_inst arguments, see Note [Lazy axiom match]+-- in FamInstEnv.hs+addLocalFamInst :: (FamInstEnv,[FamInst])+                -> FamInst+                -> TcM (FamInstEnv, [FamInst])+addLocalFamInst (home_fie, my_fis) fam_inst+        -- home_fie includes home package and this module+        -- my_fies is just the ones from this module+  = do { traceTc "addLocalFamInst" (ppr fam_inst)++           -- Unlike the case of class instances, don't override existing+           -- instances in GHCi; it's unsound. See #7102.++       ; mod <- getModule+       ; traceTc "alfi" (ppr mod)++           -- Fetch imported instances, so that we report+           -- overlaps correctly.+           -- Really we ought to only check consistency with+           -- those instances which are transitively imported+           -- by the current module, rather than every instance+           -- we've ever seen. Fixing this is part of #13102.+       ; eps <- getEps+       ; let inst_envs = (eps_fam_inst_env eps, home_fie)+             home_fie' = extendFamInstEnv home_fie fam_inst++           -- Check for conflicting instance decls and injectivity violations+       ; no_conflict    <- checkForConflicts            inst_envs fam_inst+       ; injectivity_ok <- checkForInjectivityConflicts inst_envs fam_inst++       ; if no_conflict && injectivity_ok then+            return (home_fie', fam_inst : my_fis)+         else+            return (home_fie,  my_fis) }++{-+************************************************************************+*                                                                      *+        Checking an instance against conflicts with an instance env+*                                                                      *+************************************************************************++Check whether a single family instance conflicts with those in two instance+environments (one for the EPS and one for the HPT).+-}++checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool+checkForConflicts inst_envs fam_inst+  = do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst+       ; traceTc "checkForConflicts" $+         vcat [ ppr (map fim_instance conflicts)+              , ppr fam_inst+              -- , ppr inst_envs+         ]+       ; reportConflictInstErr fam_inst conflicts+       ; return (null conflicts) }++-- | Check whether a new open type family equation can be added without+-- violating injectivity annotation supplied by the user. Returns True when+-- this is possible and False if adding this equation would violate injectivity+-- annotation.+checkForInjectivityConflicts :: FamInstEnvs -> FamInst -> TcM Bool+checkForInjectivityConflicts instEnvs famInst+    | isTypeFamilyTyCon tycon+    -- type family is injective in at least one argument+    , Injective inj <- tyConInjectivityInfo tycon = do+    { let axiom = coAxiomSingleBranch fi_ax+          conflicts = lookupFamInstEnvInjectivityConflicts inj instEnvs famInst+          -- see Note [Verifying injectivity annotation] in FamInstEnv+          errs = makeInjectivityErrors fi_ax axiom inj conflicts+    ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err) errs+    ; return (null errs)+    }++    -- if there was no injectivity annotation or tycon does not represent a+    -- type family we report no conflicts+    | otherwise = return True+    where tycon = famInstTyCon famInst+          fi_ax = fi_axiom famInst++-- | Build a list of injectivity errors together with their source locations.+makeInjectivityErrors+   :: CoAxiom br   -- ^ Type family for which we generate errors+   -> CoAxBranch   -- ^ Currently checked equation (represented by axiom)+   -> [Bool]       -- ^ Injectivity annotation+   -> [CoAxBranch] -- ^ List of injectivity conflicts+   -> [(SDoc, SrcSpan)]+makeInjectivityErrors fi_ax axiom inj conflicts+  = ASSERT2( any id inj, text "No injective type variables" )+    let lhs             = coAxBranchLHS axiom+        rhs             = coAxBranchRHS axiom+        fam_tc          = coAxiomTyCon fi_ax+        are_conflicts   = not $ null conflicts+        unused_inj_tvs  = unusedInjTvsInRHS fam_tc inj lhs rhs+        inj_tvs_unused  = not $ and (isEmptyVarSet <$> unused_inj_tvs)+        tf_headed       = isTFHeaded rhs+        bare_variables  = bareTvInRHSViolated lhs rhs+        wrong_bare_rhs  = not $ null bare_variables++        err_builder herald eqns+                        = ( hang herald+                               2 (vcat (map (pprCoAxBranchUser fam_tc) eqns))+                          , coAxBranchSpan (head eqns) )+        errorIf p f     = if p then [f err_builder axiom] else []+     in    errorIf are_conflicts  (conflictInjInstErr     conflicts     )+        ++ errorIf inj_tvs_unused (unusedInjectiveVarsErr unused_inj_tvs)+        ++ errorIf tf_headed       tfHeadedErr+        ++ errorIf wrong_bare_rhs (bareVariableInRHSErr   bare_variables)+++-- | Return a list of type variables that the function is injective in and that+-- do not appear on injective positions in the RHS of a family instance+-- declaration. The returned Pair includes invisible vars followed by visible ones+unusedInjTvsInRHS :: TyCon -> [Bool] -> [Type] -> Type -> Pair TyVarSet+-- INVARIANT: [Bool] list contains at least one True value+-- See Note [Verifying injectivity annotation]. This function implements fourth+-- check described there.+-- In theory, instead of implementing this whole check in this way, we could+-- attempt to unify equation with itself.  We would reject exactly the same+-- equations but this method gives us more precise error messages by returning+-- precise names of variables that are not mentioned in the RHS.+unusedInjTvsInRHS tycon injList lhs rhs =+  (`minusVarSet` injRhsVars) <$> injLHSVars+    where+      inj_pairs :: [(Type, ArgFlag)]+      -- All the injective arguments, paired with their visibility+      inj_pairs = ASSERT2( injList `equalLength` lhs+                         , ppr tycon $$ ppr injList $$ ppr lhs )+                  filterByList injList (lhs `zip` tyConArgFlags tycon lhs)++      -- set of type and kind variables in which type family is injective+      invis_lhs, vis_lhs :: [Type]+      (invis_lhs, vis_lhs) = partitionInvisibles inj_pairs++      invis_vars = tyCoVarsOfTypes invis_lhs+      Pair invis_vars' vis_vars = splitVisVarsOfTypes vis_lhs+      injLHSVars+        = Pair (invis_vars `minusVarSet` vis_vars `unionVarSet` invis_vars')+               vis_vars++      -- set of type variables appearing in the RHS on an injective position.+      -- For all returned variables we assume their associated kind variables+      -- also appear in the RHS.+      injRhsVars = injTyVarsOfType rhs++injTyVarsOfType :: TcTauType -> TcTyVarSet+-- Collect all type variables that are either arguments to a type+--   constructor or to /injective/ type families.+-- Determining the overall type determines thes variables+--+-- E.g.   Suppose F is injective in its second arg, but not its first+--        then injVarOfType (Either a (F [b] (a,c))) = {a,c}+--        Determining the overall type determines a,c but not b.+injTyVarsOfType ty+  | Just ty' <- coreView ty -- #12430+  = injTyVarsOfType ty'+injTyVarsOfType (TyVarTy v)+  = unitVarSet v `unionVarSet` injTyVarsOfType (tyVarKind v)+injTyVarsOfType (TyConApp tc tys)+  | isTypeFamilyTyCon tc+   = case tyConInjectivityInfo tc of+        NotInjective  -> emptyVarSet+        Injective inj -> injTyVarsOfTypes (filterByList inj tys)+  | otherwise+  = injTyVarsOfTypes tys+injTyVarsOfType (LitTy {})+  = emptyVarSet+injTyVarsOfType (FunTy _ arg res)+  = injTyVarsOfType arg `unionVarSet` injTyVarsOfType res+injTyVarsOfType (AppTy fun arg)+  = injTyVarsOfType fun `unionVarSet` injTyVarsOfType arg+-- No forall types in the RHS of a type family+injTyVarsOfType (CastTy ty _)   = injTyVarsOfType ty+injTyVarsOfType (CoercionTy {}) = emptyVarSet+injTyVarsOfType (ForAllTy {})    =+    panic "unusedInjTvsInRHS.injTyVarsOfType"++injTyVarsOfTypes :: [Type] -> VarSet+injTyVarsOfTypes tys = mapUnionVarSet injTyVarsOfType tys++-- | Is type headed by a type family application?+isTFHeaded :: Type -> Bool+-- See Note [Verifying injectivity annotation]. This function implements third+-- check described there.+isTFHeaded ty | Just ty' <- coreView ty+              = isTFHeaded ty'+isTFHeaded ty | (TyConApp tc args) <- ty+              , isTypeFamilyTyCon tc+              = args `lengthIs` tyConArity tc+isTFHeaded _  = False+++-- | If a RHS is a bare type variable return a set of LHS patterns that are not+-- bare type variables.+bareTvInRHSViolated :: [Type] -> Type -> [Type]+-- See Note [Verifying injectivity annotation]. This function implements second+-- check described there.+bareTvInRHSViolated pats rhs | isTyVarTy rhs+   = filter (not . isTyVarTy) pats+bareTvInRHSViolated _ _ = []+++-- | Type of functions that use error message and a list of axioms to build full+-- error message (with a source location) for injective type families.+type InjErrorBuilder = SDoc -> [CoAxBranch] -> (SDoc, SrcSpan)++-- | Build injecivity error herald common to all injectivity errors.+injectivityErrorHerald :: Bool -> SDoc+injectivityErrorHerald isSingular =+  text "Type family equation" <> s isSingular <+> text "violate" <>+  s (not isSingular) <+> text "injectivity annotation" <>+  if isSingular then dot else colon+  -- Above is an ugly hack.  We want this: "sentence. herald:" (note the dot and+  -- colon).  But if herald is empty we want "sentence:" (note the colon).  We+  -- can't test herald for emptiness so we rely on the fact that herald is empty+  -- only when isSingular is False.  If herald is non empty it must end with a+  -- colon.+    where+      s False = text "s"+      s True  = empty++-- | Build error message for a pair of equations violating an injectivity+-- annotation.+conflictInjInstErr :: [CoAxBranch] -> InjErrorBuilder -> CoAxBranch+                   -> (SDoc, SrcSpan)+conflictInjInstErr conflictingEqns errorBuilder tyfamEqn+  | confEqn : _ <- conflictingEqns+  = errorBuilder (injectivityErrorHerald False) [confEqn, tyfamEqn]+  | otherwise+  = panic "conflictInjInstErr"++-- | Build error message for equation with injective type variables unused in+-- the RHS.+unusedInjectiveVarsErr :: Pair TyVarSet -> InjErrorBuilder -> CoAxBranch+                       -> (SDoc, SrcSpan)+unusedInjectiveVarsErr (Pair invis_vars vis_vars) errorBuilder tyfamEqn+  = let (doc, loc) = errorBuilder (injectivityErrorHerald True $$ msg)+                                  [tyfamEqn]+    in (pprWithExplicitKindsWhen has_kinds doc, loc)+    where+      tvs = invis_vars `unionVarSet` vis_vars+      has_types = not $ isEmptyVarSet vis_vars+      has_kinds = not $ isEmptyVarSet invis_vars++      doc = sep [ what <+> text "variable" <>+                  pluralVarSet tvs <+> pprVarSet tvs (pprQuotedList . scopedSort)+                , text "cannot be inferred from the right-hand side." ]+      what = case (has_types, has_kinds) of+               (True, True)   -> text "Type and kind"+               (True, False)  -> text "Type"+               (False, True)  -> text "Kind"+               (False, False) -> pprPanic "mkUnusedInjectiveVarsErr" $ ppr tvs+      msg = doc $$ text "In the type family equation:"++-- | Build error message for equation that has a type family call at the top+-- level of RHS+tfHeadedErr :: InjErrorBuilder -> CoAxBranch+            -> (SDoc, SrcSpan)+tfHeadedErr errorBuilder famInst+  = errorBuilder (injectivityErrorHerald True $$+                  text "RHS of injective type family equation cannot" <+>+                  text "be a type family:") [famInst]++-- | Build error message for equation that has a bare type variable in the RHS+-- but LHS pattern is not a bare type variable.+bareVariableInRHSErr :: [Type] -> InjErrorBuilder -> CoAxBranch+                     -> (SDoc, SrcSpan)+bareVariableInRHSErr tys errorBuilder famInst+  = errorBuilder (injectivityErrorHerald True $$+                  text "RHS of injective type family equation is a bare" <+>+                  text "type variable" $$+                  text "but these LHS type and kind patterns are not bare" <+>+                  text "variables:" <+> pprQuotedList tys) [famInst]+++reportConflictInstErr :: FamInst -> [FamInstMatch] -> TcRn ()+reportConflictInstErr _ []+  = return ()  -- No conflicts+reportConflictInstErr fam_inst (match1 : _)+  | FamInstMatch { fim_instance = conf_inst } <- match1+  , let sorted  = sortWith getSpan [fam_inst, conf_inst]+        fi1     = head sorted+        span    = coAxBranchSpan (coAxiomSingleBranch (famInstAxiom fi1))+  = setSrcSpan span $ addErr $+    hang (text "Conflicting family instance declarations:")+       2 (vcat [ pprCoAxBranchUser (coAxiomTyCon ax) (coAxiomSingleBranch ax)+               | fi <- sorted+               , let ax = famInstAxiom fi ])+ where+   getSpan = getSrcLoc . famInstAxiom+   -- The sortWith just arranges that instances are dislayed in order+   -- of source location, which reduced wobbling in error messages,+   -- and is better for users++tcGetFamInstEnvs :: TcM FamInstEnvs+-- Gets both the external-package inst-env+-- and the home-pkg inst env (includes module being compiled)+tcGetFamInstEnvs+  = do { eps <- getEps; env <- getGblEnv+       ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }
+ compiler/typecheck/FunDeps.hs view
@@ -0,0 +1,675 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 2000+++FunDeps - functional dependencies++It's better to read it as: "if we know these, then we're going to know these"+-}++{-# LANGUAGE CPP #-}++module FunDeps (+        FunDepEqn(..), pprEquation,+        improveFromInstEnv, improveFromAnother,+        checkInstCoverage, checkFunDeps,+        pprFundeps+    ) where++#include "HsVersions.h"++import GhcPrelude++import Name+import Var+import Class+import Type+import TcType( transSuperClasses )+import CoAxiom( TypeEqn )+import Unify+import FamInst( injTyVarsOfTypes )+import InstEnv+import VarSet+import VarEnv+import Outputable+import ErrUtils( Validity(..), allValid )+import SrcLoc+import Util++import Pair             ( Pair(..) )+import Data.List        ( nubBy )+import Data.Maybe+import Data.Foldable    ( fold )++{-+************************************************************************+*                                                                      *+\subsection{Generate equations from functional dependencies}+*                                                                      *+************************************************************************+++Each functional dependency with one variable in the RHS is responsible+for generating a single equality. For instance:+     class C a b | a -> b+The constraints ([Wanted] C Int Bool) and [Wanted] C Int alpha+will generate the following FunDepEqn+     FDEqn { fd_qtvs = []+           , fd_eqs  = [Pair Bool alpha]+           , fd_pred1 = C Int Bool+           , fd_pred2 = C Int alpha+           , fd_loc = ... }+However notice that a functional dependency may have more than one variable+in the RHS which will create more than one pair of types in fd_eqs. Example:+     class C a b c | a -> b c+     [Wanted] C Int alpha alpha+     [Wanted] C Int Bool beta+Will generate:+     FDEqn { fd_qtvs = []+           , fd_eqs  = [Pair Bool alpha, Pair alpha beta]+           , fd_pred1 = C Int Bool+           , fd_pred2 = C Int alpha+           , fd_loc = ... }++INVARIANT: Corresponding types aren't already equal+That is, there exists at least one non-identity equality in FDEqs.++Assume:+       class C a b c | a -> b c+       instance C Int x x+And:   [Wanted] C Int Bool alpha+We will /match/ the LHS of fundep equations, producing a matching substitution+and create equations for the RHS sides. In our last example we'd have generated:+      ({x}, [fd1,fd2])+where+       fd1 = FDEq 1 Bool x+       fd2 = FDEq 2 alpha x+To ``execute'' the equation, make fresh type variable for each tyvar in the set,+instantiate the two types with these fresh variables, and then unify or generate+a new constraint. In the above example we would generate a new unification+variable 'beta' for x and produce the following constraints:+     [Wanted] (Bool ~ beta)+     [Wanted] (alpha ~ beta)++Notice the subtle difference between the above class declaration and:+       class C a b c | a -> b, a -> c+where we would generate:+      ({x},[fd1]),({x},[fd2])+This means that the template variable would be instantiated to different+unification variables when producing the FD constraints.++Finally, the position parameters will help us rewrite the wanted constraint ``on the spot''+-}++data FunDepEqn loc+  = FDEqn { fd_qtvs :: [TyVar]   -- Instantiate these type and kind vars+                                 --   to fresh unification vars,+                                 -- Non-empty only for FunDepEqns arising from instance decls++          , fd_eqs   :: [TypeEqn]  -- Make these pairs of types equal+          , fd_pred1 :: PredType   -- The FunDepEqn arose from+          , fd_pred2 :: PredType   --  combining these two constraints+          , fd_loc   :: loc  }++{-+Given a bunch of predicates that must hold, such as++        C Int t1, C Int t2, C Bool t3, ?x::t4, ?x::t5++improve figures out what extra equations must hold.+For example, if we have++        class C a b | a->b where ...++then improve will return++        [(t1,t2), (t4,t5)]++NOTA BENE:++  * improve does not iterate.  It's possible that when we make+    t1=t2, for example, that will in turn trigger a new equation.+    This would happen if we also had+        C t1 t7, C t2 t8+    If t1=t2, we also get t7=t8.++    improve does *not* do this extra step.  It relies on the caller+    doing so.++  * The equations unify types that are not already equal.  So there+    is no effect iff the result of improve is empty+-}++instFD :: FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type+-- (instFD fd tvs tys) returns fd instantiated with (tvs -> tys)+instFD (ls,rs) tvs tys+  = (map lookup ls, map lookup rs)+  where+    env       = zipVarEnv tvs tys+    lookup tv = lookupVarEnv_NF env tv++zipAndComputeFDEqs :: (Type -> Type -> Bool) -- Discard this FDEq if true+                   -> [Type] -> [Type]+                   -> [TypeEqn]+-- Create a list of (Type,Type) pairs from two lists of types,+-- making sure that the types are not already equal+zipAndComputeFDEqs discard (ty1:tys1) (ty2:tys2)+ | discard ty1 ty2 = zipAndComputeFDEqs discard tys1 tys2+ | otherwise       = Pair ty1 ty2 : zipAndComputeFDEqs discard tys1 tys2+zipAndComputeFDEqs _ _ _ = []++-- Improve a class constraint from another class constraint+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+improveFromAnother :: loc+                   -> PredType -- Template item (usually given, or inert)+                   -> PredType -- Workitem [that can be improved]+                   -> [FunDepEqn loc]+-- Post: FDEqs always oriented from the other to the workitem+--       Equations have empty quantified variables+improveFromAnother loc pred1 pred2+  | Just (cls1, tys1) <- getClassPredTys_maybe pred1+  , Just (cls2, tys2) <- getClassPredTys_maybe pred2+  , cls1 == cls2+  = [ FDEqn { fd_qtvs = [], fd_eqs = eqs, fd_pred1 = pred1, fd_pred2 = pred2, fd_loc = loc }+    | let (cls_tvs, cls_fds) = classTvsFds cls1+    , fd <- cls_fds+    , let (ltys1, rs1) = instFD fd cls_tvs tys1+          (ltys2, rs2) = instFD fd cls_tvs tys2+    , eqTypes ltys1 ltys2               -- The LHSs match+    , let eqs = zipAndComputeFDEqs eqType rs1 rs2+    , not (null eqs) ]++improveFromAnother _ _ _ = []+++-- Improve a class constraint from instance declarations+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++instance Outputable (FunDepEqn a) where+  ppr = pprEquation++pprEquation :: FunDepEqn a -> SDoc+pprEquation (FDEqn { fd_qtvs = qtvs, fd_eqs = pairs })+  = vcat [text "forall" <+> braces (pprWithCommas ppr qtvs),+          nest 2 (vcat [ ppr t1 <+> text "~" <+> ppr t2+                       | Pair t1 t2 <- pairs])]++improveFromInstEnv :: InstEnvs+                   -> (PredType -> SrcSpan -> loc)+                   -> PredType+                   -> [FunDepEqn loc] -- Needs to be a FunDepEqn because+                                      -- of quantified variables+-- Post: Equations oriented from the template (matching instance) to the workitem!+improveFromInstEnv inst_env mk_loc pred+  | Just (cls, tys) <- ASSERT2( isClassPred pred, ppr pred )+                       getClassPredTys_maybe pred+  , let (cls_tvs, cls_fds) = classTvsFds cls+        instances          = classInstances inst_env cls+        rough_tcs          = roughMatchTcs tys+  = [ FDEqn { fd_qtvs = meta_tvs, fd_eqs = eqs+            , fd_pred1 = p_inst, fd_pred2 = pred+            , fd_loc = mk_loc p_inst (getSrcSpan (is_dfun ispec)) }+    | fd <- cls_fds             -- Iterate through the fundeps first,+                                -- because there often are none!+    , let trimmed_tcs = trimRoughMatchTcs cls_tvs fd rough_tcs+                -- Trim the rough_tcs based on the head of the fundep.+                -- Remember that instanceCantMatch treats both arguments+                -- symmetrically, so it's ok to trim the rough_tcs,+                -- rather than trimming each inst_tcs in turn+    , ispec <- instances+    , (meta_tvs, eqs) <- improveClsFD cls_tvs fd ispec+                                      tys trimmed_tcs -- NB: orientation+    , let p_inst = mkClassPred cls (is_tys ispec)+    ]+improveFromInstEnv _ _ _ = []+++improveClsFD :: [TyVar] -> FunDep TyVar    -- One functional dependency from the class+             -> ClsInst                    -- An instance template+             -> [Type] -> [Maybe Name]     -- Arguments of this (C tys) predicate+             -> [([TyCoVar], [TypeEqn])]   -- Empty or singleton++improveClsFD clas_tvs fd+             (ClsInst { is_tvs = qtvs, is_tys = tys_inst, is_tcs = rough_tcs_inst })+             tys_actual rough_tcs_actual++-- Compare instance      {a,b}    C sx sp sy sq+--         with wanted     [W] C tx tp ty tq+--         for fundep (x,y -> p,q)  from class  (C x p y q)+-- If (sx,sy) unifies with (tx,ty), take the subst S++-- 'qtvs' are the quantified type variables, the ones which can be instantiated+-- to make the types match.  For example, given+--      class C a b | a->b where ...+--      instance C (Maybe x) (Tree x) where ..+--+-- and a wanted constraint of form (C (Maybe t1) t2),+-- then we will call checkClsFD with+--+--      is_qtvs = {x}, is_tys = [Maybe x,  Tree x]+--                     tys_actual = [Maybe t1, t2]+--+-- We can instantiate x to t1, and then we want to force+--      (Tree x) [t1/x]  ~   t2++  | instanceCantMatch rough_tcs_inst rough_tcs_actual+  = []          -- Filter out ones that can't possibly match,++  | otherwise+  = ASSERT2( equalLength tys_inst tys_actual &&+             equalLength tys_inst clas_tvs+            , ppr tys_inst <+> ppr tys_actual )++    case tcMatchTyKis ltys1 ltys2 of+        Nothing  -> []+        Just subst | isJust (tcMatchTyKisX subst rtys1 rtys2)+                        -- Don't include any equations that already hold.+                        -- Reason: then we know if any actual improvement has happened,+                        --         in which case we need to iterate the solver+                        -- In making this check we must taking account of the fact that any+                        -- qtvs that aren't already instantiated can be instantiated to anything+                        -- at all+                        -- NB: We can't do this 'is-useful-equation' check element-wise+                        --     because of:+                        --           class C a b c | a -> b c+                        --           instance C Int x x+                        --           [Wanted] C Int alpha Int+                        -- We would get that  x -> alpha  (isJust) and x -> Int (isJust)+                        -- so we would produce no FDs, which is clearly wrong.+                  -> []++                  | null fdeqs+                  -> []++                  | otherwise+                  -> -- pprTrace "iproveClsFD" (vcat+                     --  [ text "is_tvs =" <+> ppr qtvs+                     --  , text "tys_inst =" <+> ppr tys_inst+                     --  , text "tys_actual =" <+> ppr tys_actual+                     --  , text "ltys1 =" <+> ppr ltys1+                     --  , text "ltys2 =" <+> ppr ltys2+                     --  , text "subst =" <+> ppr subst ]) $+                     [(meta_tvs, fdeqs)]+                        -- We could avoid this substTy stuff by producing the eqn+                        -- (qtvs, ls1++rs1, ls2++rs2)+                        -- which will re-do the ls1/ls2 unification when the equation is+                        -- executed.  What we're doing instead is recording the partial+                        -- work of the ls1/ls2 unification leaving a smaller unification problem+                  where+                    rtys1' = map (substTyUnchecked subst) rtys1++                    fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' rtys2+                        -- Don't discard anything!+                        -- We could discard equal types but it's an overkill to call+                        -- eqType again, since we know for sure that /at least one/+                        -- equation in there is useful)++                    meta_tvs = [ setVarType tv (substTyUnchecked subst (varType tv))+                               | tv <- qtvs, tv `notElemTCvSubst` subst ]+                        -- meta_tvs are the quantified type variables+                        -- that have not been substituted out+                        --+                        -- Eg.  class C a b | a -> b+                        --      instance C Int [y]+                        -- Given constraint C Int z+                        -- we generate the equation+                        --      ({y}, [y], z)+                        --+                        -- But note (a) we get them from the dfun_id, so they are *in order*+                        --              because the kind variables may be mentioned in the+                        --              type variabes' kinds+                        --          (b) we must apply 'subst' to the kinds, in case we have+                        --              matched out a kind variable, but not a type variable+                        --              whose kind mentions that kind variable!+                        --          #6015, #6068+  where+    (ltys1, rtys1) = instFD fd clas_tvs tys_inst+    (ltys2, rtys2) = instFD fd clas_tvs tys_actual++{-+%************************************************************************+%*                                                                      *+        The Coverage condition for instance declarations+*                                                                      *+************************************************************************++Note [Coverage condition]+~~~~~~~~~~~~~~~~~~~~~~~~~+Example+      class C a b | a -> b+      instance theta => C t1 t2++For the coverage condition, we check+   (normal)    fv(t2) `subset` fv(t1)+   (liberal)   fv(t2) `subset` oclose(fv(t1), theta)++The liberal version  ensures the self-consistency of the instance, but+it does not guarantee termination. Example:++   class Mul a b c | a b -> c where+        (.*.) :: a -> b -> c++   instance Mul Int Int Int where (.*.) = (*)+   instance Mul Int Float Float where x .*. y = fromIntegral x * y+   instance Mul a b c => Mul a [b] [c] where x .*. v = map (x.*.) v++In the third instance, it's not the case that fv([c]) `subset` fv(a,[b]).+But it is the case that fv([c]) `subset` oclose( theta, fv(a,[b]) )++But it is a mistake to accept the instance because then this defn:+        f = \ b x y -> if b then x .*. [y] else y+makes instance inference go into a loop, because it requires the constraint+        Mul a [b] b+-}++checkInstCoverage :: Bool   -- Be liberal+                  -> Class -> [PredType] -> [Type]+                  -> Validity+-- "be_liberal" flag says whether to use "liberal" coverage of+--              See Note [Coverage Condition] below+--+-- Return values+--    Nothing  => no problems+--    Just msg => coverage problem described by msg++checkInstCoverage be_liberal clas theta inst_taus+  = allValid (map fundep_ok fds)+  where+    (tyvars, fds) = classTvsFds clas+    fundep_ok fd+       | and (isEmptyVarSet <$> undetermined_tvs) = IsValid+       | otherwise                                = NotValid msg+       where+         (ls,rs) = instFD fd tyvars inst_taus+         ls_tvs = tyCoVarsOfTypes ls+         rs_tvs = splitVisVarsOfTypes rs++         undetermined_tvs | be_liberal = liberal_undet_tvs+                          | otherwise  = conserv_undet_tvs++         closed_ls_tvs = oclose theta ls_tvs+         liberal_undet_tvs = (`minusVarSet` closed_ls_tvs) <$> rs_tvs+         conserv_undet_tvs = (`minusVarSet` ls_tvs)        <$> rs_tvs++         undet_set = fold undetermined_tvs++         msg = pprWithExplicitKindsWhen+                 (isEmptyVarSet $ pSnd undetermined_tvs) $+               vcat [ -- text "ls_tvs" <+> ppr ls_tvs+                      -- , text "closed ls_tvs" <+> ppr (closeOverKinds ls_tvs)+                      -- , text "theta" <+> ppr theta+                      -- , text "oclose" <+> ppr (oclose theta (closeOverKinds ls_tvs))+                      -- , text "rs_tvs" <+> ppr rs_tvs+                      sep [ text "The"+                            <+> ppWhen be_liberal (text "liberal")+                            <+> text "coverage condition fails in class"+                            <+> quotes (ppr clas)+                          , nest 2 $ text "for functional dependency:"+                            <+> quotes (pprFunDep fd) ]+                    , sep [ text "Reason: lhs type"<>plural ls <+> pprQuotedList ls+                          , nest 2 $+                            (if isSingleton ls+                             then text "does not"+                             else text "do not jointly")+                            <+> text "determine rhs type"<>plural rs+                            <+> pprQuotedList rs ]+                    , text "Un-determined variable" <> pluralVarSet undet_set <> colon+                            <+> pprVarSet undet_set (pprWithCommas ppr)+                    , ppWhen (not be_liberal &&+                              and (isEmptyVarSet <$> liberal_undet_tvs)) $+                      text "Using UndecidableInstances might help" ]++{- Note [Closing over kinds in coverage]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have a fundep  (a::k) -> b+Then if 'a' is instantiated to (x y), where x:k2->*, y:k2,+then fixing x really fixes k2 as well, and so k2 should be added to+the lhs tyvars in the fundep check.++Example (#8391), using liberal coverage+      data Foo a = ...  -- Foo :: forall k. k -> *+      class Bar a b | a -> b+      instance Bar a (Foo a)++    In the instance decl, (a:k) does fix (Foo k a), but only if we notice+    that (a:k) fixes k.  #10109 is another example.++Here is a more subtle example, from HList-0.4.0.0 (#10564)++  class HasFieldM (l :: k) r (v :: Maybe *)+        | l r -> v where ...+  class HasFieldM1 (b :: Maybe [*]) (l :: k) r v+        | b l r -> v where ...+  class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k])+        | e1 l -> r++  data Label :: k -> *+  type family LabelsOf (a :: [*]) ::  *++  instance (HMemberM (Label {k} (l::k)) (LabelsOf xs) b,+            HasFieldM1 b l (r xs) v)+         => HasFieldM l (r xs) v where++Is the instance OK? Does {l,r,xs} determine v?  Well:++  * From the instance constraint HMemberM (Label k l) (LabelsOf xs) b,+    plus the fundep "| el l -> r" in class HMameberM,+    we get {l,k,xs} -> b++  * Note the 'k'!! We must call closeOverKinds on the seed set+    ls_tvs = {l,r,xs}, BEFORE doing oclose, else the {l,k,xs}->b+    fundep won't fire.  This was the reason for #10564.++  * So starting from seeds {l,r,xs,k} we do oclose to get+    first {l,r,xs,k,b}, via the HMemberM constraint, and then+    {l,r,xs,k,b,v}, via the HasFieldM1 constraint.++  * And that fixes v.++However, we must closeOverKinds whenever augmenting the seed set+in oclose!  Consider #10109:++  data Succ a   -- Succ :: forall k. k -> *+  class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab+  instance (Add a b ab) => Add (Succ {k1} (a :: k1))+                               b+                               (Succ {k3} (ab :: k3})++We start with seed set {a:k1,b:k2} and closeOverKinds to {a,k1,b,k2}.+Now use the fundep to extend to {a,k1,b,k2,ab}.  But we need to+closeOverKinds *again* now to {a,k1,b,k2,ab,k3}, so that we fix all+the variables free in (Succ {k3} ab).++Bottom line:+  * closeOverKinds on initial seeds (done automatically+    by tyCoVarsOfTypes in checkInstCoverage)+  * and closeOverKinds whenever extending those seeds (in oclose)++Note [The liberal coverage condition]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(oclose preds tvs) closes the set of type variables tvs,+wrt functional dependencies in preds.  The result is a superset+of the argument set.  For example, if we have+        class C a b | a->b where ...+then+        oclose [C (x,y) z, C (x,p) q] {x,y} = {x,y,z}+because if we know x and y then that fixes z.++We also use equality predicates in the predicates; if we have an+assumption `t1 ~ t2`, then we use the fact that if we know `t1` we+also know `t2` and the other way.+  eg    oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x}++oclose is used (only) when checking the coverage condition for+an instance declaration++Note [Equality superclasses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+  class (a ~ [b]) => C a b++Remember from Note [The equality types story] in TysPrim, that+  * (a ~~ b) is a superclass of (a ~ b)+  * (a ~# b) is a superclass of (a ~~ b)++So when oclose expands superclasses we'll get a (a ~# [b]) superclass.+But that's an EqPred not a ClassPred, and we jolly well do want to+account for the mutual functional dependencies implied by (t1 ~# t2).+Hence the EqPred handling in oclose.  See #10778.++Note [Care with type functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#12803)+  class C x y | x -> y+  type family F a b+  type family G c d = r | r -> d++Now consider+  oclose (C (F a b) (G c d)) {a,b}++Knowing {a,b} fixes (F a b) regardless of the injectivity of F.+But knowing (G c d) fixes only {d}, because G is only injective+in its second parameter.++Hence the tyCoVarsOfTypes/injTyVarsOfTypes dance in tv_fds.+-}++oclose :: [PredType] -> TyCoVarSet -> TyCoVarSet+-- See Note [The liberal coverage condition]+oclose preds fixed_tvs+  | null tv_fds = fixed_tvs -- Fast escape hatch for common case.+  | otherwise   = fixVarSet extend fixed_tvs+  where+    extend fixed_tvs = foldl' add fixed_tvs tv_fds+       where+          add fixed_tvs (ls,rs)+            | ls `subVarSet` fixed_tvs = fixed_tvs `unionVarSet` closeOverKinds rs+            | otherwise                = fixed_tvs+            -- closeOverKinds: see Note [Closing over kinds in coverage]++    tv_fds  :: [(TyCoVarSet,TyCoVarSet)]+    tv_fds  = [ (tyCoVarsOfTypes ls, injTyVarsOfTypes rs)+                  -- See Note [Care with type functions]+              | pred <- preds+              , pred' <- pred : transSuperClasses pred+                   -- Look for fundeps in superclasses too+              , (ls, rs) <- determined pred' ]++    determined :: PredType -> [([Type],[Type])]+    determined pred+       = case classifyPredType pred of+            EqPred NomEq t1 t2 -> [([t1],[t2]), ([t2],[t1])]+               -- See Note [Equality superclasses]+            ClassPred cls tys  -> [ instFD fd cls_tvs tys+                                  | let (cls_tvs, cls_fds) = classTvsFds cls+                                  , fd <- cls_fds ]+            _ -> []+++{- *********************************************************************+*                                                                      *+        Check that a new instance decl is OK wrt fundeps+*                                                                      *+************************************************************************++Here is the bad case:+        class C a b | a->b where ...+        instance C Int Bool where ...+        instance C Int Char where ...++The point is that a->b, so Int in the first parameter must uniquely+determine the second.  In general, given the same class decl, and given++        instance C s1 s2 where ...+        instance C t1 t2 where ...++Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2).++Matters are a little more complicated if there are free variables in+the s2/t2.++        class D a b c | a -> b+        instance D a b => D [(a,a)] [b] Int+        instance D a b => D [a]     [b] Bool++The instance decls don't overlap, because the third parameter keeps+them separate.  But we want to make sure that given any constraint+        D s1 s2 s3+if s1 matches++Note [Bogus consistency check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In checkFunDeps we check that a new ClsInst is consistent with all the+ClsInsts in the environment.++The bogus aspect is discussed in #10675. Currenty it if the two+types are *contradicatory*, using (isNothing . tcUnifyTys).  But all+the papers say we should check if the two types are *equal* thus+   not (substTys subst rtys1 `eqTypes` substTys subst rtys2)+For now I'm leaving the bogus form because that's the way it has+been for years.+-}++checkFunDeps :: InstEnvs -> ClsInst -> [ClsInst]+-- The Consistency Check.+-- Check whether adding DFunId would break functional-dependency constraints+-- Used only for instance decls defined in the module being compiled+-- Returns a list of the ClsInst in InstEnvs that are inconsistent+-- with the proposed new ClsInst+checkFunDeps inst_envs (ClsInst { is_tvs = qtvs1, is_cls = cls+                                , is_tys = tys1, is_tcs = rough_tcs1 })+  | null fds+  = []+  | otherwise+  = nubBy eq_inst $+    [ ispec | ispec <- cls_insts+            , fd    <- fds+            , is_inconsistent fd ispec ]+  where+    cls_insts      = classInstances inst_envs cls+    (cls_tvs, fds) = classTvsFds cls+    qtv_set1       = mkVarSet qtvs1++    is_inconsistent fd (ClsInst { is_tvs = qtvs2, is_tys = tys2, is_tcs = rough_tcs2 })+      | instanceCantMatch trimmed_tcs rough_tcs2+      = False+      | otherwise+      = case tcUnifyTyKis bind_fn ltys1 ltys2 of+          Nothing         -> False+          Just subst+            -> isNothing $   -- Bogus legacy test (#10675)+                             -- See Note [Bogus consistency check]+               tcUnifyTyKis bind_fn (substTysUnchecked subst rtys1) (substTysUnchecked subst rtys2)++      where+        trimmed_tcs    = trimRoughMatchTcs cls_tvs fd rough_tcs1+        (ltys1, rtys1) = instFD fd cls_tvs tys1+        (ltys2, rtys2) = instFD fd cls_tvs tys2+        qtv_set2       = mkVarSet qtvs2+        bind_fn tv | tv `elemVarSet` qtv_set1 = BindMe+                   | tv `elemVarSet` qtv_set2 = BindMe+                   | otherwise                = Skolem++    eq_inst i1 i2 = instanceDFunId i1 == instanceDFunId i2+        -- A single instance may appear twice in the un-nubbed conflict list+        -- because it may conflict with more than one fundep.  E.g.+        --      class C a b c | a -> b, a -> c+        --      instance C Int Bool Bool+        --      instance C Int Char Char+        -- The second instance conflicts with the first by *both* fundeps++trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name]+-- Computing rough_tcs for a particular fundep+--     class C a b c | a -> b where ...+-- For each instance .... => C ta tb tc+-- we want to match only on the type ta; so our+-- rough-match thing must similarly be filtered.+-- Hence, we Nothing-ise the tb and tc types right here+--+-- Result list is same length as input list, just with more Nothings+trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs+  = zipWith select clas_tvs mb_tcs+  where+    select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc+                         | otherwise           = Nothing
+ compiler/typecheck/Inst.hs view
@@ -0,0 +1,843 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++The @Inst@ type: dictionaries or method instances+-}++{-# LANGUAGE CPP, MultiWayIf, TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}++module Inst (+       deeplySkolemise,+       topInstantiate, topInstantiateInferred, deeplyInstantiate,+       instCall, instDFunType, instStupidTheta, instTyVarsWith,+       newWanted, newWanteds,++       tcInstInvisibleTyBinders, tcInstInvisibleTyBinder,++       newOverloadedLit, mkOverLit,++       newClsInst,+       tcGetInsts, tcGetInstEnvs, getOverlapFlag,+       tcExtendLocalInstEnv,+       instCallConstraints, newMethodFromName,+       tcSyntaxName,++       -- Simple functions over evidence variables+       tyCoVarsOfWC,+       tyCoVarsOfCt, tyCoVarsOfCts,+    ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-}   TcExpr( tcPolyExpr, tcSyntaxOp )+import {-# SOURCE #-}   TcUnify( unifyType, unifyKind )++import BasicTypes ( IntegralLit(..), SourceText(..) )+import FastString+import HsSyn+import TcHsSyn+import TcRnMonad+import TcEnv+import TcEvidence+import InstEnv+import TysWiredIn  ( heqDataCon, eqDataCon )+import CoreSyn     ( isOrphan )+import FunDeps+import TcMType+import Type+import TyCoRep+import TcType+import HscTypes+import Class( Class )+import MkId( mkDictFunId )+import CoreSyn( Expr(..) )  -- For the Coercion constructor+import Id+import Name+import Var      ( EvVar, tyVarName, VarBndr(..) )+import DataCon+import VarEnv+import PrelNames+import SrcLoc+import DynFlags+import Util+import Outputable+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad( unless )++{-+************************************************************************+*                                                                      *+                Creating and emittind constraints+*                                                                      *+************************************************************************+-}++newMethodFromName+  :: CtOrigin              -- ^ why do we need this?+  -> Name                  -- ^ name of the method+  -> [TcRhoType]           -- ^ types with which to instantiate the class+  -> TcM (HsExpr GhcTcId)+-- ^ Used when 'Name' is the wired-in name for a wired-in class method,+-- so the caller knows its type for sure, which should be of form+--+-- > forall a. C a => <blah>+--+-- 'newMethodFromName' is supposed to instantiate just the outer+-- type variable and constraint++newMethodFromName origin name ty_args+  = do { id <- tcLookupId name+              -- Use tcLookupId not tcLookupGlobalId; the method is almost+              -- always a class op, but with -XRebindableSyntax GHC is+              -- meant to find whatever thing is in scope, and that may+              -- be an ordinary function.++       ; let ty = piResultTys (idType id) ty_args+             (theta, _caller_knows_this) = tcSplitPhiTy ty+       ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta )+                 instCall origin ty_args theta++       ; return (mkHsWrap wrap (HsVar noExt (noLoc id))) }++{-+************************************************************************+*                                                                      *+        Deep instantiation and skolemisation+*                                                                      *+************************************************************************++Note [Deep skolemisation]+~~~~~~~~~~~~~~~~~~~~~~~~~+deeplySkolemise decomposes and skolemises a type, returning a type+with all its arrows visible (ie not buried under foralls)++Examples:++  deeplySkolemise (Int -> forall a. Ord a => blah)+    =  ( wp, [a], [d:Ord a], Int -> blah )+    where wp = \x:Int. /\a. \(d:Ord a). <hole> x++  deeplySkolemise  (forall a. Ord a => Maybe a -> forall b. Eq b => blah)+    =  ( wp, [a,b], [d1:Ord a,d2:Eq b], Maybe a -> blah )+    where wp = /\a.\(d1:Ord a).\(x:Maybe a)./\b.\(d2:Ord b). <hole> x++In general,+  if      deeplySkolemise ty = (wrap, tvs, evs, rho)+    and   e :: rho+  then    wrap e :: ty+    and   'wrap' binds tvs, evs++ToDo: this eta-abstraction plays fast and loose with termination,+      because it can introduce extra lambdas.  Maybe add a `seq` to+      fix this+-}++deeplySkolemise :: TcSigmaType+                -> TcM ( HsWrapper+                       , [(Name,TyVar)]     -- All skolemised variables+                       , [EvVar]            -- All "given"s+                       , TcRhoType )++deeplySkolemise ty+  = go init_subst ty+  where+    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))++    go subst ty+      | Just (arg_tys, tvs, theta, ty') <- tcDeepSplitSigmaTy_maybe ty+      = do { let arg_tys' = substTys subst arg_tys+           ; ids1           <- newSysLocalIds (fsLit "dk") arg_tys'+           ; (subst', tvs1) <- tcInstSkolTyVarsX subst tvs+           ; ev_vars1       <- newEvVars (substTheta subst' theta)+           ; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty'+           ; let tv_prs1 = map tyVarName tvs `zip` tvs1+           ; return ( mkWpLams ids1+                      <.> mkWpTyLams tvs1+                      <.> mkWpLams ev_vars1+                      <.> wrap+                      <.> mkWpEvVarApps ids1+                    , tv_prs1  ++ tvs_prs2+                    , ev_vars1 ++ ev_vars2+                    , mkVisFunTys arg_tys' rho ) }++      | otherwise+      = return (idHsWrapper, [], [], substTy subst ty)+        -- substTy is a quick no-op on an empty substitution++-- | Instantiate all outer type variables+-- and any context. Never looks through arrows.+topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)+-- if    topInstantiate ty = (wrap, rho)+-- and   e :: ty+-- then  wrap e :: rho  (that is, wrap :: ty "->" rho)+topInstantiate = top_instantiate True++-- | Instantiate all outer 'Inferred' binders+-- and any context. Never looks through arrows or specified type variables.+-- Used for visible type application.+topInstantiateInferred :: CtOrigin -> TcSigmaType+                       -> TcM (HsWrapper, TcSigmaType)+-- if    topInstantiate ty = (wrap, rho)+-- and   e :: ty+-- then  wrap e :: rho+topInstantiateInferred = top_instantiate False++top_instantiate :: Bool   -- True  <=> instantiate *all* variables+                          -- False <=> instantiate only the inferred ones+                -> CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)+top_instantiate inst_all orig ty+  | not (null binders && null theta)+  = do { let (inst_bndrs, leave_bndrs) = span should_inst binders+             (inst_theta, leave_theta)+               | null leave_bndrs = (theta, [])+               | otherwise        = ([], theta)+             in_scope    = mkInScopeSet (tyCoVarsOfType ty)+             empty_subst = mkEmptyTCvSubst in_scope+             inst_tvs    = binderVars inst_bndrs+       ; (subst, inst_tvs') <- mapAccumLM newMetaTyVarX empty_subst inst_tvs+       ; let inst_theta' = substTheta subst inst_theta+             sigma'      = substTy subst (mkForAllTys leave_bndrs $+                                          mkPhiTy leave_theta rho)+             inst_tv_tys' = mkTyVarTys inst_tvs'++       ; wrap1 <- instCall orig inst_tv_tys' inst_theta'+       ; traceTc "Instantiating"+                 (vcat [ text "all tyvars?" <+> ppr inst_all+                       , text "origin" <+> pprCtOrigin orig+                       , text "type" <+> debugPprType ty+                       , text "theta" <+> ppr theta+                       , text "leave_bndrs" <+> ppr leave_bndrs+                       , text "with" <+> vcat (map debugPprType inst_tv_tys')+                       , text "theta:" <+>  ppr inst_theta' ])++       ; (wrap2, rho2) <-+           if null leave_bndrs++         -- account for types like forall a. Num a => forall b. Ord b => ...+           then top_instantiate inst_all orig sigma'++         -- but don't loop if there were any un-inst'able tyvars+           else return (idHsWrapper, sigma')++       ; return (wrap2 <.> wrap1, rho2) }++  | otherwise = return (idHsWrapper, ty)+  where+    (binders, phi) = tcSplitForAllVarBndrs ty+    (theta, rho)   = tcSplitPhiTy phi++    should_inst bndr+      | inst_all  = True+      | otherwise = binderArgFlag bndr == Inferred++deeplyInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)+--   Int -> forall a. a -> a  ==>  (\x:Int. [] x alpha) :: Int -> alpha+-- In general if+-- if    deeplyInstantiate ty = (wrap, rho)+-- and   e :: ty+-- then  wrap e :: rho+-- That is, wrap :: ty ~> rho+--+-- If you don't need the HsWrapper returned from this function, consider+-- using tcSplitNestedSigmaTys in TcType, which is a pure alternative that+-- only computes the returned TcRhoType.++deeplyInstantiate orig ty =+  deeply_instantiate orig+                     (mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty)))+                     ty++deeply_instantiate :: CtOrigin+                   -> TCvSubst+                   -> TcSigmaType -> TcM (HsWrapper, TcRhoType)+-- Internal function to deeply instantiate that builds on an existing subst.+-- It extends the input substitution and applies the final subtitution to+-- the types on return.  See #12549.++deeply_instantiate orig subst ty+  | Just (arg_tys, tvs, theta, rho) <- tcDeepSplitSigmaTy_maybe ty+  = do { (subst', tvs') <- newMetaTyVarsX subst tvs+       ; let arg_tys' = substTys   subst' arg_tys+             theta'   = substTheta subst' theta+       ; ids1  <- newSysLocalIds (fsLit "di") arg_tys'+       ; wrap1 <- instCall orig (mkTyVarTys tvs') theta'+       ; traceTc "Instantiating (deeply)" (vcat [ text "origin" <+> pprCtOrigin orig+                                                , text "type" <+> ppr ty+                                                , text "with" <+> ppr tvs'+                                                , text "args:" <+> ppr ids1+                                                , text "theta:" <+>  ppr theta'+                                                , text "subst:" <+> ppr subst'])+       ; (wrap2, rho2) <- deeply_instantiate orig subst' rho+       ; return (mkWpLams ids1+                    <.> wrap2+                    <.> wrap1+                    <.> mkWpEvVarApps ids1,+                 mkVisFunTys arg_tys' rho2) }++  | otherwise+  = do { let ty' = substTy subst ty+       ; traceTc "deeply_instantiate final subst"+                 (vcat [ text "origin:"   <+> pprCtOrigin orig+                       , text "type:"     <+> ppr ty+                       , text "new type:" <+> ppr ty'+                       , text "subst:"    <+> ppr subst ])+      ; return (idHsWrapper, ty') }+++instTyVarsWith :: CtOrigin -> [TyVar] -> [TcType] -> TcM TCvSubst+-- Use this when you want to instantiate (forall a b c. ty) with+-- types [ta, tb, tc], but when the kinds of 'a' and 'ta' might+-- not yet match (perhaps because there are unsolved constraints; #14154)+-- If they don't match, emit a kind-equality to promise that they will+-- eventually do so, and thus make a kind-homongeneous substitution.+instTyVarsWith orig tvs tys+  = go empty_subst tvs tys+  where+    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes tys))++    go subst [] []+      = return subst+    go subst (tv:tvs) (ty:tys)+      | tv_kind `tcEqType` ty_kind+      = go (extendTCvSubst subst tv ty) tvs tys+      | otherwise+      = do { co <- emitWantedEq orig KindLevel Nominal ty_kind tv_kind+           ; go (extendTCvSubst subst tv (ty `mkCastTy` co)) tvs tys }+      where+        tv_kind = substTy subst (tyVarKind tv)+        ty_kind = tcTypeKind ty++    go _ _ _ = pprPanic "instTysWith" (ppr tvs $$ ppr tys)++{-+************************************************************************+*                                                                      *+            Instantiating a call+*                                                                      *+************************************************************************++Note [Handling boxed equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The solver deals entirely in terms of unboxed (primitive) equality.+There should never be a boxed Wanted equality. Ever. But, what if+we are calling `foo :: forall a. (F a ~ Bool) => ...`? That equality+is boxed, so naive treatment here would emit a boxed Wanted equality.++So we simply check for this case and make the right boxing of evidence.++-}++----------------+instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper+-- Instantiate the constraints of a call+--      (instCall o tys theta)+-- (a) Makes fresh dictionaries as necessary for the constraints (theta)+-- (b) Throws these dictionaries into the LIE+-- (c) Returns an HsWrapper ([.] tys dicts)++instCall orig tys theta+  = do  { dict_app <- instCallConstraints orig theta+        ; return (dict_app <.> mkWpTyApps tys) }++----------------+instCallConstraints :: CtOrigin -> TcThetaType -> TcM HsWrapper+-- Instantiates the TcTheta, puts all constraints thereby generated+-- into the LIE, and returns a HsWrapper to enclose the call site.++instCallConstraints orig preds+  | null preds+  = return idHsWrapper+  | otherwise+  = do { evs <- mapM go preds+       ; traceTc "instCallConstraints" (ppr evs)+       ; return (mkWpEvApps evs) }+  where+    go :: TcPredType -> TcM EvTerm+    go pred+     | Just (Nominal, ty1, ty2) <- getEqPredTys_maybe pred -- Try short-cut #1+     = do  { co <- unifyType Nothing ty1 ty2+           ; return (evCoercion co) }++       -- Try short-cut #2+     | Just (tc, args@[_, _, ty1, ty2]) <- splitTyConApp_maybe pred+     , tc `hasKey` heqTyConKey+     = do { co <- unifyType Nothing ty1 ty2+          ; return (evDFunApp (dataConWrapId heqDataCon) args [Coercion co]) }++     | otherwise+     = emitWanted orig pred++instDFunType :: DFunId -> [DFunInstType]+             -> TcM ( [TcType]      -- instantiated argument types+                    , TcThetaType ) -- instantiated constraint+-- See Note [DFunInstType: instantiating types] in InstEnv+instDFunType dfun_id dfun_inst_tys+  = do { (subst, inst_tys) <- go empty_subst dfun_tvs dfun_inst_tys+       ; return (inst_tys, substTheta subst dfun_theta) }+  where+    dfun_ty = idType dfun_id+    (dfun_tvs, dfun_theta, _) = tcSplitSigmaTy dfun_ty+    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType dfun_ty))+                  -- With quantified constraints, the+                  -- type of a dfun may not be closed++    go :: TCvSubst -> [TyVar] -> [DFunInstType] -> TcM (TCvSubst, [TcType])+    go subst [] [] = return (subst, [])+    go subst (tv:tvs) (Just ty : mb_tys)+      = do { (subst', tys) <- go (extendTvSubstAndInScope subst tv ty)+                                 tvs+                                 mb_tys+           ; return (subst', ty : tys) }+    go subst (tv:tvs) (Nothing : mb_tys)+      = do { (subst', tv') <- newMetaTyVarX subst tv+           ; (subst'', tys) <- go subst' tvs mb_tys+           ; return (subst'', mkTyVarTy tv' : tys) }+    go _ _ _ = pprPanic "instDFunTypes" (ppr dfun_id $$ ppr dfun_inst_tys)++----------------+instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()+-- Similar to instCall, but only emit the constraints in the LIE+-- Used exclusively for the 'stupid theta' of a data constructor+instStupidTheta orig theta+  = do  { _co <- instCallConstraints orig theta -- Discard the coercion+        ; return () }+++{- *********************************************************************+*                                                                      *+         Instantiating Kinds+*                                                                      *+********************************************************************* -}++-- | Instantiates up to n invisible binders+-- Returns the instantiating types, and body kind+tcInstInvisibleTyBinders :: Int -> TcKind -> TcM ([TcType], TcKind)++tcInstInvisibleTyBinders 0 kind+  = return ([], kind)+tcInstInvisibleTyBinders n ty+  = go n empty_subst ty+  where+    empty_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfType ty))++    go n subst kind+      | n > 0+      , Just (bndr, body) <- tcSplitPiTy_maybe kind+      , isInvisibleBinder bndr+      = do { (subst', arg) <- tcInstInvisibleTyBinder subst bndr+           ; (args, inner_ty) <- go (n-1) subst' body+           ; return (arg:args, inner_ty) }+      | otherwise+      = return ([], substTy subst kind)++-- | Used only in *types*+tcInstInvisibleTyBinder :: TCvSubst -> TyBinder -> TcM (TCvSubst, TcType)+tcInstInvisibleTyBinder subst (Named (Bndr tv _))+  = do { (subst', tv') <- newMetaTyVarX subst tv+       ; return (subst', mkTyVarTy tv') }++tcInstInvisibleTyBinder subst (Anon af ty)+  | Just (mk, k1, k2) <- get_eq_tys_maybe (substTy subst ty)+    -- Equality is the *only* constraint currently handled in types.+    -- See Note [Constraints in kinds] in TyCoRep+  = ASSERT( af == InvisArg )+    do { co <- unifyKind Nothing k1 k2+       ; arg' <- mk co+       ; return (subst, arg') }++  | otherwise  -- This should never happen+               -- See TyCoRep Note [Constraints in kinds]+  = pprPanic "tcInvisibleTyBinder" (ppr ty)++-------------------------------+get_eq_tys_maybe :: Type+                 -> Maybe ( Coercion -> TcM Type+                             -- given a coercion proving t1 ~# t2, produce the+                             -- right instantiation for the TyBinder at hand+                          , Type  -- t1+                          , Type  -- t2+                          )+-- See Note [Constraints in kinds] in TyCoRep+get_eq_tys_maybe ty+  -- Lifted heterogeneous equality (~~)+  | Just (tc, [_, _, k1, k2]) <- splitTyConApp_maybe ty+  , tc `hasKey` heqTyConKey+  = Just (\co -> mkHEqBoxTy co k1 k2, k1, k2)++  -- Lifted homogeneous equality (~)+  | Just (tc, [_, k1, k2]) <- splitTyConApp_maybe ty+  , tc `hasKey` eqTyConKey+  = Just (\co -> mkEqBoxTy co k1 k2, k1, k2)++  | otherwise+  = Nothing++-- | This takes @a ~# b@ and returns @a ~~ b@.+mkHEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type+-- monadic just for convenience with mkEqBoxTy+mkHEqBoxTy co ty1 ty2+  = return $+    mkTyConApp (promoteDataCon heqDataCon) [k1, k2, ty1, ty2, mkCoercionTy co]+  where k1 = tcTypeKind ty1+        k2 = tcTypeKind ty2++-- | This takes @a ~# b@ and returns @a ~ b@.+mkEqBoxTy :: TcCoercion -> Type -> Type -> TcM Type+mkEqBoxTy co ty1 ty2+  = return $+    mkTyConApp (promoteDataCon eqDataCon) [k, ty1, ty2, mkCoercionTy co]+  where k = tcTypeKind ty1++{-+************************************************************************+*                                                                      *+                Literals+*                                                                      *+************************************************************************++-}++{-+In newOverloadedLit we convert directly to an Int or Integer if we+know that's what we want.  This may save some time, by not+temporarily generating overloaded literals, but it won't catch all+cases (the rest are caught in lookupInst).++-}++newOverloadedLit :: HsOverLit GhcRn+                 -> ExpRhoType+                 -> TcM (HsOverLit GhcTcId)+newOverloadedLit+  lit@(OverLit { ol_val = val, ol_ext = rebindable }) res_ty+  | not rebindable+    -- all built-in overloaded lits are tau-types, so we can just+    -- tauify the ExpType+  = do { res_ty <- expTypeToType res_ty+       ; dflags <- getDynFlags+       ; case shortCutLit dflags val res_ty of+        -- Do not generate a LitInst for rebindable syntax.+        -- Reason: If we do, tcSimplify will call lookupInst, which+        --         will call tcSyntaxName, which does unification,+        --         which tcSimplify doesn't like+           Just expr -> return (lit { ol_witness = expr+                                    , ol_ext = OverLitTc False res_ty })+           Nothing   -> newNonTrivialOverloadedLit orig lit+                                                   (mkCheckExpType res_ty) }++  | otherwise+  = newNonTrivialOverloadedLit orig lit res_ty+  where+    orig = LiteralOrigin lit+newOverloadedLit XOverLit{} _ = panic "newOverloadedLit"++-- Does not handle things that 'shortCutLit' can handle. See also+-- newOverloadedLit in TcUnify+newNonTrivialOverloadedLit :: CtOrigin+                           -> HsOverLit GhcRn+                           -> ExpRhoType+                           -> TcM (HsOverLit GhcTcId)+newNonTrivialOverloadedLit orig+  lit@(OverLit { ol_val = val, ol_witness = HsVar _ (L _ meth_name)+               , ol_ext = rebindable }) res_ty+  = do  { hs_lit <- mkOverLit val+        ; let lit_ty = hsLitType hs_lit+        ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name)+                                      [synKnownType lit_ty] res_ty $+                      \_ -> return ()+        ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit]+        ; res_ty <- readExpType res_ty+        ; return (lit { ol_witness = witness+                      , ol_ext = OverLitTc rebindable res_ty }) }+newNonTrivialOverloadedLit _ lit _+  = pprPanic "newNonTrivialOverloadedLit" (ppr lit)++------------+mkOverLit ::OverLitVal -> TcM (HsLit GhcTc)+mkOverLit (HsIntegral i)+  = do  { integer_ty <- tcMetaTy integerTyConName+        ; return (HsInteger (il_text i)+                            (il_value i) integer_ty) }++mkOverLit (HsFractional r)+  = do  { rat_ty <- tcMetaTy rationalTyConName+        ; return (HsRat noExt r rat_ty) }++mkOverLit (HsIsString src s) = return (HsString src s)++{-+************************************************************************+*                                                                      *+                Re-mappable syntax++     Used only for arrow syntax -- find a way to nuke this+*                                                                      *+************************************************************************++Suppose we are doing the -XRebindableSyntax thing, and we encounter+a do-expression.  We have to find (>>) in the current environment, which is+done by the rename. Then we have to check that it has the same type as+Control.Monad.(>>).  Or, more precisely, a compatible type. One 'customer' had+this:++  (>>) :: HB m n mn => m a -> n b -> mn b++So the idea is to generate a local binding for (>>), thus:++        let then72 :: forall a b. m a -> m b -> m b+            then72 = ...something involving the user's (>>)...+        in+        ...the do-expression...++Now the do-expression can proceed using then72, which has exactly+the expected type.++In fact tcSyntaxName just generates the RHS for then72, because we only+want an actual binding in the do-expression case. For literals, we can+just use the expression inline.+-}++tcSyntaxName :: CtOrigin+             -> TcType                 -- ^ Type to instantiate it at+             -> (Name, HsExpr GhcRn)   -- ^ (Standard name, user name)+             -> TcM (Name, HsExpr GhcTcId)+                                       -- ^ (Standard name, suitable expression)+-- USED ONLY FOR CmdTop (sigh) ***+-- See Note [CmdSyntaxTable] in HsExpr++tcSyntaxName orig ty (std_nm, HsVar _ (L _ user_nm))+  | std_nm == user_nm+  = do rhs <- newMethodFromName orig std_nm [ty]+       return (std_nm, rhs)++tcSyntaxName orig ty (std_nm, user_nm_expr) = do+    std_id <- tcLookupId std_nm+    let+        -- C.f. newMethodAtLoc+        ([tv], _, tau) = tcSplitSigmaTy (idType std_id)+        sigma1         = substTyWith [tv] [ty] tau+        -- Actually, the "tau-type" might be a sigma-type in the+        -- case of locally-polymorphic methods.++    addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $ do++        -- Check that the user-supplied thing has the+        -- same type as the standard one.+        -- Tiresome jiggling because tcCheckSigma takes a located expression+     span <- getSrcSpanM+     expr <- tcPolyExpr (L span user_nm_expr) sigma1+     return (std_nm, unLoc expr)++syntaxNameCtxt :: HsExpr GhcRn -> CtOrigin -> Type -> TidyEnv+               -> TcRn (TidyEnv, SDoc)+syntaxNameCtxt name orig ty tidy_env+  = do { inst_loc <- getCtLocM orig (Just TypeLevel)+       ; let msg = vcat [ text "When checking that" <+> quotes (ppr name)+                          <+> text "(needed by a syntactic construct)"+                        , nest 2 (text "has the required type:"+                                  <+> ppr (tidyType tidy_env ty))+                        , nest 2 (pprCtLoc inst_loc) ]+       ; return (tidy_env, msg) }++{-+************************************************************************+*                                                                      *+                Instances+*                                                                      *+************************************************************************+-}++getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag+-- Construct the OverlapFlag from the global module flags,+-- but if the overlap_mode argument is (Just m),+--     set the OverlapMode to 'm'+getOverlapFlag overlap_mode+  = do  { dflags <- getDynFlags+        ; let overlap_ok    = xopt LangExt.OverlappingInstances dflags+              incoherent_ok = xopt LangExt.IncoherentInstances  dflags+              use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags+                                  , overlapMode   = x }+              default_oflag | incoherent_ok = use (Incoherent NoSourceText)+                            | overlap_ok    = use (Overlaps NoSourceText)+                            | otherwise     = use (NoOverlap NoSourceText)++              final_oflag = setOverlapModeMaybe default_oflag overlap_mode+        ; return final_oflag }++tcGetInsts :: TcM [ClsInst]+-- Gets the local class instances.+tcGetInsts = fmap tcg_insts getGblEnv++newClsInst :: Maybe OverlapMode -> Name -> [TyVar] -> ThetaType+           -> Class -> [Type] -> TcM ClsInst+newClsInst overlap_mode dfun_name tvs theta clas tys+  = do { (subst, tvs') <- freshenTyVarBndrs tvs+             -- Be sure to freshen those type variables,+             -- so they are sure not to appear in any lookup+       ; let tys' = substTys subst tys++             dfun = mkDictFunId dfun_name tvs theta clas tys+             -- The dfun uses the original 'tvs' because+             -- (a) they don't need to be fresh+             -- (b) they may be mentioned in the ib_binds field of+             --     an InstInfo, and in TcEnv.pprInstInfoDetails it's+             --     helpful to use the same names++       ; oflag <- getOverlapFlag overlap_mode+       ; let inst = mkLocalInstance dfun oflag tvs' clas tys'+       ; warnIfFlag Opt_WarnOrphans+                    (isOrphan (is_orphan inst))+                    (instOrphWarn inst)+       ; return inst }++instOrphWarn :: ClsInst -> SDoc+instOrphWarn inst+  = hang (text "Orphan instance:") 2 (pprInstanceHdr inst)+    $$ text "To avoid this"+    $$ nest 4 (vcat possibilities)+  where+    possibilities =+      text "move the instance declaration to the module of the class or of the type, or" :+      text "wrap the type with a newtype and declare the instance on the new type." :+      []++tcExtendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a+  -- Add new locally-defined instances+tcExtendLocalInstEnv dfuns thing_inside+ = do { traceDFuns dfuns+      ; env <- getGblEnv+      ; (inst_env', cls_insts') <- foldlM addLocalInst+                                          (tcg_inst_env env, tcg_insts env)+                                          dfuns+      ; let env' = env { tcg_insts    = cls_insts'+                       , tcg_inst_env = inst_env' }+      ; setGblEnv env' thing_inside }++addLocalInst :: (InstEnv, [ClsInst]) -> ClsInst -> TcM (InstEnv, [ClsInst])+-- Check that the proposed new instance is OK,+-- and then add it to the home inst env+-- If overwrite_inst, then we can overwrite a direct match+addLocalInst (home_ie, my_insts) ispec+   = do {+             -- Load imported instances, so that we report+             -- duplicates correctly++             -- 'matches'  are existing instance declarations that are less+             --            specific than the new one+             -- 'dups'     are those 'matches' that are equal to the new one+         ; isGHCi <- getIsGHCi+         ; eps    <- getEps+         ; tcg_env <- getGblEnv++           -- In GHCi, we *override* any identical instances+           -- that are also defined in the interactive context+           -- See Note [Override identical instances in GHCi]+         ; let home_ie'+                 | isGHCi    = deleteFromInstEnv home_ie ispec+                 | otherwise = home_ie++               global_ie = eps_inst_env eps+               inst_envs = InstEnvs { ie_global  = global_ie+                                    , ie_local   = home_ie'+                                    , ie_visible = tcVisibleOrphanMods tcg_env }++             -- Check for inconsistent functional dependencies+         ; let inconsistent_ispecs = checkFunDeps inst_envs ispec+         ; unless (null inconsistent_ispecs) $+           funDepErr ispec inconsistent_ispecs++             -- Check for duplicate instance decls.+         ; let (_tvs, cls, tys) = instanceHead ispec+               (matches, _, _)  = lookupInstEnv False inst_envs cls tys+               dups             = filter (identicalClsInstHead ispec) (map fst matches)+         ; unless (null dups) $+           dupInstErr ispec (head dups)++         ; return (extendInstEnv home_ie' ispec, ispec : my_insts) }++{-+Note [Signature files and type class instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Instances in signature files do not have an effect when compiling:+when you compile a signature against an implementation, you will+see the instances WHETHER OR NOT the instance is declared in+the file (this is because the signatures go in the EPS and we+can't filter them out easily.)  This is also why we cannot+place the instance in the hi file: it would show up as a duplicate,+and we don't have instance reexports anyway.++However, you might find them useful when typechecking against+a signature: the instance is a way of indicating to GHC that+some instance exists, in case downstream code uses it.++Implementing this is a little tricky.  Consider the following+situation (sigof03):++ module A where+     instance C T where ...++ module ASig where+     instance C T++When compiling ASig, A.hi is loaded, which brings its instances+into the EPS.  When we process the instance declaration in ASig,+we should ignore it for the purpose of doing a duplicate check,+since it's not actually a duplicate. But don't skip the check+entirely, we still want this to fail (tcfail221):++ module ASig where+     instance C T+     instance C T++Note that in some situations, the interface containing the type+class instances may not have been loaded yet at all.  The usual+situation when A imports another module which provides the+instances (sigof02m):++ module A(module B) where+     import B++See also Note [Signature lazy interface loading].  We can't+rely on this, however, since sometimes we'll have spurious+type class instances in the EPS, see #9422 (sigof02dm)++************************************************************************+*                                                                      *+        Errors and tracing+*                                                                      *+************************************************************************+-}++traceDFuns :: [ClsInst] -> TcRn ()+traceDFuns ispecs+  = traceTc "Adding instances:" (vcat (map pp ispecs))+  where+    pp ispec = hang (ppr (instanceDFunId ispec) <+> colon)+                  2 (ppr ispec)+        -- Print the dfun name itself too++funDepErr :: ClsInst -> [ClsInst] -> TcRn ()+funDepErr ispec ispecs+  = addClsInstsErr (text "Functional dependencies conflict between instance declarations:")+                    (ispec : ispecs)++dupInstErr :: ClsInst -> ClsInst -> TcRn ()+dupInstErr ispec dup_ispec+  = addClsInstsErr (text "Duplicate instance declarations:")+                    [ispec, dup_ispec]++addClsInstsErr :: SDoc -> [ClsInst] -> TcRn ()+addClsInstsErr herald ispecs+  = setSrcSpan (getSrcSpan (head sorted)) $+    addErr (hang herald 2 (pprInstances sorted))+ where+   sorted = sortWith getSrcLoc ispecs+   -- The sortWith just arranges that instances are dislayed in order+   -- of source location, which reduced wobbling in error messages,+   -- and is better for users
+ compiler/typecheck/TcAnnotations.hs view
@@ -0,0 +1,79 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1993-1998++\section[TcAnnotations]{Typechecking annotations}+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module TcAnnotations ( tcAnnotations, annCtxt ) where++import GhcPrelude++import {-# SOURCE #-} TcSplice ( runAnnotation )+import Module+import DynFlags+import Control.Monad ( when )++import HsSyn+import Name+import Annotations+import TcRnMonad+import SrcLoc+import Outputable++-- Some platforms don't support the external interpreter, and+-- compilation on those platforms shouldn't fail just due to+-- annotations+#ifndef GHCI+tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation]+tcAnnotations anns = do+  dflags <- getDynFlags+  case gopt Opt_ExternalInterpreter dflags of+    True  -> tcAnnotations' anns+    False -> warnAnns anns+warnAnns :: [LAnnDecl GhcRn] -> TcM [Annotation]+--- No GHCI; emit a warning (not an error) and ignore. cf #4268+warnAnns [] = return []+warnAnns anns@(L loc _ : _)+  = do { setSrcSpan loc $ addWarnTc NoReason $+             (text "Ignoring ANN annotation" <> plural anns <> comma+             <+> text "because this is a stage-1 compiler without -fexternal-interpreter or doesn't support GHCi")+       ; return [] }+#else+tcAnnotations :: [LAnnDecl GhcRn] -> TcM [Annotation]+tcAnnotations = tcAnnotations'+#endif++tcAnnotations' :: [LAnnDecl GhcRn] -> TcM [Annotation]+tcAnnotations' anns = mapM tcAnnotation anns++tcAnnotation :: LAnnDecl GhcRn -> TcM Annotation+tcAnnotation (L loc ann@(HsAnnotation _ _ provenance expr)) = do+    -- Work out what the full target of this annotation was+    mod <- getModule+    let target = annProvenanceToTarget mod provenance++    -- Run that annotation and construct the full Annotation data structure+    setSrcSpan loc $ addErrCtxt (annCtxt ann) $ do+      -- See #10826 -- Annotations allow one to bypass Safe Haskell.+      dflags <- getDynFlags+      when (safeLanguageOn dflags) $ failWithTc safeHsErr+      runAnnotation target expr+    where+      safeHsErr = vcat [ text "Annotations are not compatible with Safe Haskell."+                  , text "See https://gitlab.haskell.org/ghc/ghc/issues/10826" ]+tcAnnotation (L _ (XAnnDecl _)) = panic "tcAnnotation"++annProvenanceToTarget :: Module -> AnnProvenance Name+                      -> AnnTarget Name+annProvenanceToTarget _   (ValueAnnProvenance (L _ name)) = NamedTarget name+annProvenanceToTarget _   (TypeAnnProvenance (L _ name))  = NamedTarget name+annProvenanceToTarget mod ModuleAnnProvenance             = ModuleTarget mod++annCtxt :: (OutputableBndrId (GhcPass p)) => AnnDecl (GhcPass p) -> SDoc+annCtxt ann+  = hang (text "In the annotation:") 2 (ppr ann)
+ compiler/typecheck/TcArrows.hs view
@@ -0,0 +1,440 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++Typecheck arrow notation+-}++{-# LANGUAGE RankNTypes, TupleSections #-}+{-# LANGUAGE TypeFamilies #-}++module TcArrows ( tcProc ) where++import GhcPrelude++import {-# SOURCE #-}   TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, tcPolyExpr )++import HsSyn+import TcMatches+import TcHsSyn( hsLPatType )+import TcType+import TcMType+import TcBinds+import TcPat+import TcUnify+import TcRnMonad+import TcEnv+import TcEvidence+import Id( mkLocalId )+import Inst+import Name+import TysWiredIn+import VarSet+import TysPrim+import BasicTypes( Arity )+import SrcLoc+import Outputable+import Util++import Control.Monad++{-+Note [Arrow overview]+~~~~~~~~~~~~~~~~~~~~~+Here's a summary of arrows and how they typecheck.  First, here's+a cut-down syntax:++  expr ::= ....+        |  proc pat cmd++  cmd ::= cmd exp                    -- Arrow application+       |  \pat -> cmd                -- Arrow abstraction+       |  (| exp cmd1 ... cmdn |)    -- Arrow form, n>=0+       |  ... -- If, case in the usual way++  cmd_type ::= carg_type --> type++  carg_type ::= ()+             |  (type, carg_type)++Note that+ * The 'exp' in an arrow form can mention only+   "arrow-local" variables++ * An "arrow-local" variable is bound by an enclosing+   cmd binding form (eg arrow abstraction)++ * A cmd_type is here written with a funny arrow "-->",+   The bit on the left is a carg_type (command argument type)+   which itself is a nested tuple, finishing with ()++ * The arrow-tail operator (e1 -< e2) means+       (| e1 <<< arr snd |) e2+++************************************************************************+*                                                                      *+                Proc+*                                                                      *+************************************************************************+-}++tcProc :: InPat GhcRn -> LHsCmdTop GhcRn        -- proc pat -> expr+       -> ExpRhoType                            -- Expected type of whole proc expression+       -> TcM (OutPat GhcTcId, LHsCmdTop GhcTcId, TcCoercion)++tcProc pat cmd exp_ty+  = newArrowScope $+    do  { exp_ty <- expTypeToType exp_ty  -- no higher-rank stuff with arrows+        ; (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty+        ; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1+        ; let cmd_env = CmdEnv { cmd_arr = arr_ty }+        ; (pat', cmd') <- tcPat ProcExpr pat (mkCheckExpType arg_ty) $+                          tcCmdTop cmd_env cmd (unitTy, res_ty)+        ; let res_co = mkTcTransCo co+                         (mkTcAppCo co1 (mkTcNomReflCo res_ty))+        ; return (pat', cmd', res_co) }++{-+************************************************************************+*                                                                      *+                Commands+*                                                                      *+************************************************************************+-}++-- See Note [Arrow overview]+type CmdType    = (CmdArgType, TcTauType)    -- cmd_type+type CmdArgType = TcTauType                  -- carg_type, a nested tuple++data CmdEnv+  = CmdEnv {+        cmd_arr :: TcType -- arrow type constructor, of kind *->*->*+    }++mkCmdArrTy :: CmdEnv -> TcTauType -> TcTauType -> TcTauType+mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2]++---------------------------------------+tcCmdTop :: CmdEnv+         -> LHsCmdTop GhcRn+         -> CmdType+         -> TcM (LHsCmdTop GhcTcId)++tcCmdTop env (L loc (HsCmdTop names cmd)) cmd_ty@(cmd_stk, res_ty)+  = setSrcSpan loc $+    do  { cmd'   <- tcCmd env cmd cmd_ty+        ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names+        ; return (L loc $ HsCmdTop (CmdTopTc cmd_stk res_ty names') cmd') }+tcCmdTop _ (L _ XCmdTop{}) _ = panic "tcCmdTop"++----------------------------------------+tcCmd  :: CmdEnv -> LHsCmd GhcRn -> CmdType -> TcM (LHsCmd GhcTcId)+        -- The main recursive function+tcCmd env (L loc cmd) res_ty+  = setSrcSpan loc $ do+        { cmd' <- tc_cmd env cmd res_ty+        ; return (L loc cmd') }++tc_cmd :: CmdEnv -> HsCmd GhcRn  -> CmdType -> TcM (HsCmd GhcTcId)+tc_cmd env (HsCmdPar x cmd) res_ty+  = do  { cmd' <- tcCmd env cmd res_ty+        ; return (HsCmdPar x cmd') }++tc_cmd env (HsCmdLet x (L l binds) (L body_loc body)) res_ty+  = do  { (binds', body') <- tcLocalBinds binds         $+                             setSrcSpan body_loc        $+                             tc_cmd env body res_ty+        ; return (HsCmdLet x (L l binds') (L body_loc body')) }++tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)+  = addErrCtxt (cmdCtxt in_cmd) $ do+      (scrut', scrut_ty) <- tcInferRho scrut+      matches' <- tcMatchesCase match_ctxt scrut_ty matches (mkCheckExpType res_ty)+      return (HsCmdCase x scrut' matches')+  where+    match_ctxt = MC { mc_what = CaseAlt,+                      mc_body = mc_body }+    mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'+                              ; tcCmd env body (stk, res_ty') }++tc_cmd env (HsCmdIf x Nothing pred b1 b2) res_ty    -- Ordinary 'if'+  = do  { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)+        ; b1'   <- tcCmd env b1 res_ty+        ; b2'   <- tcCmd env b2 res_ty+        ; return (HsCmdIf x Nothing pred' b1' b2')+    }++tc_cmd env (HsCmdIf x (Just fun) pred b1 b2) res_ty -- Rebindable syntax for if+  = do  { pred_ty <- newOpenFlexiTyVarTy+        -- For arrows, need ifThenElse :: forall r. T -> r -> r -> r+        -- because we're going to apply it to the environment, not+        -- the return value.+        ; (_, [r_tv]) <- tcInstSkolTyVars [alphaTyVar]+        ; let r_ty = mkTyVarTy r_tv+        ; checkTc (not (r_tv `elemVarSet` tyCoVarsOfType pred_ty))+                  (text "Predicate type of `ifThenElse' depends on result type")+        ; (pred', fun')+            <- tcSyntaxOp IfOrigin fun (map synKnownType [pred_ty, r_ty, r_ty])+                                       (mkCheckExpType r_ty) $ \ _ ->+               tcMonoExpr pred (mkCheckExpType pred_ty)++        ; b1'   <- tcCmd env b1 res_ty+        ; b2'   <- tcCmd env b2 res_ty+        ; return (HsCmdIf x (Just fun') pred' b1' b2')+    }++-------------------------------------------+--              Arrow application+--          (f -< a)   or   (f -<< a)+--+--   D   |- fun :: a t1 t2+--   D,G |- arg :: t1+--  ------------------------+--   D;G |-a  fun -< arg :: stk --> t2+--+--   D,G |- fun :: a t1 t2+--   D,G |- arg :: t1+--  ------------------------+--   D;G |-a  fun -<< arg :: stk --> t2+--+-- (plus -<< requires ArrowApply)++tc_cmd env cmd@(HsCmdArrApp _ fun arg ho_app lr) (_, res_ty)+  = addErrCtxt (cmdCtxt cmd)    $+    do  { arg_ty <- newOpenFlexiTyVarTy+        ; let fun_ty = mkCmdArrTy env arg_ty res_ty+        ; fun' <- select_arrow_scope (tcMonoExpr fun (mkCheckExpType fun_ty))++        ; arg' <- tcMonoExpr arg (mkCheckExpType arg_ty)++        ; return (HsCmdArrApp fun_ty fun' arg' ho_app lr) }+  where+       -- Before type-checking f, use the environment of the enclosing+       -- proc for the (-<) case.+       -- Local bindings, inside the enclosing proc, are not in scope+       -- inside f.  In the higher-order case (-<<), they are.+       -- See Note [Escaping the arrow scope] in TcRnTypes+    select_arrow_scope tc = case ho_app of+        HsHigherOrderApp -> tc+        HsFirstOrderApp  -> escapeArrowScope tc++-------------------------------------------+--              Command application+--+-- D,G |-  exp : t+-- D;G |-a cmd : (t,stk) --> res+-- -----------------------------+-- D;G |-a cmd exp : stk --> res++tc_cmd env cmd@(HsCmdApp x fun arg) (cmd_stk, res_ty)+  = addErrCtxt (cmdCtxt cmd)    $+    do  { arg_ty <- newOpenFlexiTyVarTy+        ; fun'   <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)+        ; arg'   <- tcMonoExpr arg (mkCheckExpType arg_ty)+        ; return (HsCmdApp x fun' arg') }++-------------------------------------------+--              Lambda+--+-- D;G,x:t |-a cmd : stk --> res+-- ------------------------------+-- D;G |-a (\x.cmd) : (t,stk) --> res++tc_cmd env+       (HsCmdLam x (MG { mg_alts = L l [L mtch_loc+                                   (match@(Match { m_pats = pats, m_grhss = grhss }))],+                         mg_origin = origin }))+       (cmd_stk, res_ty)+  = addErrCtxt (pprMatchInCtxt match)        $+    do  { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk++                -- Check the patterns, and the GRHSs inside+        ; (pats', grhss') <- setSrcSpan mtch_loc                                 $+                             tcPats LambdaExpr pats (map mkCheckExpType arg_tys) $+                             tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)++        ; let match' = L mtch_loc (Match { m_ext = noExt+                                         , m_ctxt = LambdaExpr, m_pats = pats'+                                         , m_grhss = grhss' })+              arg_tys = map hsLPatType pats'+              cmd' = HsCmdLam x (MG { mg_alts = L l [match']+                                    , mg_ext = MatchGroupTc arg_tys res_ty+                                    , mg_origin = origin })+        ; return (mkHsCmdWrap (mkWpCastN co) cmd') }+  where+    n_pats     = length pats+    match_ctxt = (LambdaExpr :: HsMatchContext Name)    -- Maybe KappaExpr?+    pg_ctxt    = PatGuard match_ctxt++    tc_grhss (GRHSs x grhss (L l binds)) stk_ty res_ty+        = do { (binds', grhss') <- tcLocalBinds binds $+                                   mapM (wrapLocM (tc_grhs stk_ty res_ty)) grhss+             ; return (GRHSs x grhss' (L l binds')) }+    tc_grhss (XGRHSs _) _ _ = panic "tc_grhss"++    tc_grhs stk_ty res_ty (GRHS x guards body)+        = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $+                                  \ res_ty -> tcCmd env body+                                                (stk_ty, checkingExpType "tc_grhs" res_ty)+             ; return (GRHS x guards' rhs') }+    tc_grhs _ _ (XGRHS _) = panic "tc_grhs"++-------------------------------------------+--              Do notation++tc_cmd env (HsCmdDo _ (L l stmts) ) (cmd_stk, res_ty)+  = do  { co <- unifyType Nothing unitTy cmd_stk  -- Expecting empty argument stack+        ; stmts' <- tcStmts ArrowExpr (tcArrDoStmt env) stmts res_ty+        ; return (mkHsCmdWrap (mkWpCastN co) (HsCmdDo res_ty (L l stmts') )) }+++-----------------------------------------------------------------+--      Arrow ``forms''       (| e c1 .. cn |)+--+--      D; G |-a1 c1 : stk1 --> r1+--      ...+--      D; G |-an cn : stkn --> rn+--      D |-  e :: forall e. a1 (e, stk1) t1+--                                ...+--                        -> an (e, stkn) tn+--                        -> a  (e, stk) t+--      e \not\in (stk, stk1, ..., stkm, t, t1, ..., tn)+--      ----------------------------------------------+--      D; G |-a  (| e c1 ... cn |)  :  stk --> t++tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)+  = addErrCtxt (cmdCtxt cmd)    $+    do  { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args+                              -- We use alphaTyVar for 'w'+        ; let e_ty = mkInvForAllTy alphaTyVar $+                     mkVisFunTys cmd_tys $+                     mkCmdArrTy env (mkPairTy alphaTy cmd_stk) res_ty+        ; expr' <- tcPolyExpr expr e_ty+        ; return (HsCmdArrForm x expr' f fixity cmd_args') }++  where+    tc_cmd_arg :: LHsCmdTop GhcRn -> TcM (LHsCmdTop GhcTcId, TcType)+    tc_cmd_arg cmd+       = do { arr_ty <- newFlexiTyVarTy arrowTyConKind+            ; stk_ty <- newFlexiTyVarTy liftedTypeKind+            ; res_ty <- newFlexiTyVarTy liftedTypeKind+            ; let env' = env { cmd_arr = arr_ty }+            ; cmd' <- tcCmdTop env' cmd (stk_ty, res_ty)+            ; return (cmd',  mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) }++tc_cmd _ (XCmd {}) _ = panic "tc_cmd"++-----------------------------------------------------------------+--              Base case for illegal commands+-- This is where expressions that aren't commands get rejected++tc_cmd _ cmd _+  = failWithTc (vcat [text "The expression", nest 2 (ppr cmd),+                      text "was found where an arrow command was expected"])+++matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType)+matchExpectedCmdArgs 0 ty+  = return (mkTcNomReflCo ty, [], ty)+matchExpectedCmdArgs n ty+  = do { (co1, [ty1, ty2]) <- matchExpectedTyConApp pairTyCon ty+       ; (co2, tys, res_ty) <- matchExpectedCmdArgs (n-1) ty2+       ; return (mkTcTyConAppCo Nominal pairTyCon [co1, co2], ty1:tys, res_ty) }++{-+************************************************************************+*                                                                      *+                Stmts+*                                                                      *+************************************************************************+-}++--------------------------------+--      Mdo-notation+-- The distinctive features here are+--      (a) RecStmts, and+--      (b) no rebindable syntax++tcArrDoStmt :: CmdEnv -> TcCmdStmtChecker+tcArrDoStmt env _ (LastStmt x rhs noret _) res_ty thing_inside+  = do  { rhs' <- tcCmd env rhs (unitTy, res_ty)+        ; thing <- thing_inside (panic "tcArrDoStmt")+        ; return (LastStmt x rhs' noret noSyntaxExpr, thing) }++tcArrDoStmt env _ (BodyStmt _ rhs _ _) res_ty thing_inside+  = do  { (rhs', elt_ty) <- tc_arr_rhs env rhs+        ; thing          <- thing_inside res_ty+        ; return (BodyStmt elt_ty rhs' noSyntaxExpr noSyntaxExpr, thing) }++tcArrDoStmt env ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside+  = do  { (rhs', pat_ty) <- tc_arr_rhs env rhs+        ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $+                            thing_inside res_ty+        ; return (mkTcBindStmt pat' rhs', thing) }++tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names+                            , recS_rec_ids = rec_names }) res_ty thing_inside+  = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names+        ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind+        ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys+        ; tcExtendIdEnv tup_ids $ do+        { (stmts', tup_rets)+                <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty   $ \ _res_ty' ->+                        -- ToDo: res_ty not really right+                   zipWithM tcCheckId tup_names (map mkCheckExpType tup_elt_tys)++        ; thing <- thing_inside res_ty+                -- NB:  The rec_ids for the recursive things+                --      already scope over this part. This binding may shadow+                --      some of them with polymorphic things with the same Name+                --      (see note [RecStmt] in HsExpr)++        ; let rec_ids = takeList rec_names tup_ids+        ; later_ids <- tcLookupLocalIds later_names++        ; let rec_rets = takeList rec_names tup_rets+        ; let ret_table = zip tup_ids tup_rets+        ; let later_rets = [r | i <- later_ids, (j, r) <- ret_table, i == j]++        ; return (emptyRecStmtId { recS_stmts = stmts'+                                 , recS_later_ids = later_ids+                                 , recS_rec_ids = rec_ids+                                 , recS_ext = unitRecStmtTc+                                     { recS_later_rets = later_rets+                                     , recS_rec_rets = rec_rets+                                     , recS_ret_ty = res_ty} }, thing)+        }}++tcArrDoStmt _ _ stmt _ _+  = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt)++tc_arr_rhs :: CmdEnv -> LHsCmd GhcRn -> TcM (LHsCmd GhcTcId, TcType)+tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind+                        ; rhs' <- tcCmd env rhs (unitTy, ty)+                        ; return (rhs', ty) }++{-+************************************************************************+*                                                                      *+                Helpers+*                                                                      *+************************************************************************+-}++mkPairTy :: Type -> Type -> Type+mkPairTy t1 t2 = mkTyConApp pairTyCon [t1,t2]++arrowTyConKind :: Kind          --  *->*->*+arrowTyConKind = mkVisFunTys [liftedTypeKind, liftedTypeKind] liftedTypeKind++{-+************************************************************************+*                                                                      *+                Errors+*                                                                      *+************************************************************************+-}++cmdCtxt :: HsCmd GhcRn -> SDoc+cmdCtxt cmd = text "In the command:" <+> ppr cmd
+ compiler/typecheck/TcBackpack.hs view
@@ -0,0 +1,1000 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+module TcBackpack (+    findExtraSigImports',+    findExtraSigImports,+    implicitRequirements',+    implicitRequirements,+    checkUnitId,+    tcRnCheckUnitId,+    tcRnMergeSignatures,+    mergeSignatures,+    tcRnInstantiateSignature,+    instantiateSignature,+) where++import GhcPrelude++import BasicTypes (defaultFixity)+import Packages+import TcRnExports+import DynFlags+import HsSyn+import RdrName+import TcRnMonad+import TcTyDecls+import InstEnv+import FamInstEnv+import Inst+import TcIface+import TcMType+import TcType+import TcSimplify+import LoadIface+import RnNames+import ErrUtils+import Id+import Module+import Name+import NameEnv+import NameSet+import Avail+import SrcLoc+import HscTypes+import Outputable+import Type+import FastString+import RnFixity ( lookupFixityRn )+import Maybes+import TcEnv+import Var+import IfaceSyn+import PrelNames+import qualified Data.Map as Map++import Finder+import UniqDSet+import NameShape+import TcErrors+import TcUnify+import RnModIface+import Util++import Control.Monad+import Data.List (find)++import {-# SOURCE #-} TcRnDriver++#include "HsVersions.h"++fixityMisMatch :: TyThing -> Fixity -> Fixity -> SDoc+fixityMisMatch real_thing real_fixity sig_fixity =+    vcat [ppr real_thing <+> text "has conflicting fixities in the module",+          text "and its hsig file",+          text "Main module:" <+> ppr_fix real_fixity,+          text "Hsig file:" <+> ppr_fix sig_fixity]+  where+    ppr_fix f =+        ppr f <+>+        (if f == defaultFixity+            then parens (text "default")+            else empty)++checkHsigDeclM :: ModIface -> TyThing -> TyThing -> TcRn ()+checkHsigDeclM sig_iface sig_thing real_thing = do+    let name = getName real_thing+    -- TODO: Distinguish between signature merging and signature+    -- implementation cases.+    checkBootDeclM False sig_thing real_thing+    real_fixity <- lookupFixityRn name+    let sig_fixity = case mi_fix_fn sig_iface (occName name) of+                        Nothing -> defaultFixity+                        Just f -> f+    when (real_fixity /= sig_fixity) $+      addErrAt (nameSrcSpan name)+        (fixityMisMatch real_thing real_fixity sig_fixity)++-- | Given a 'ModDetails' of an instantiated signature (note that the+-- 'ModDetails' must be knot-tied consistently with the actual implementation)+-- and a 'GlobalRdrEnv' constructed from the implementor of this interface,+-- verify that the actual implementation actually matches the original+-- interface.+--+-- Note that it is already assumed that the implementation *exports*+-- a sufficient set of entities, since otherwise the renaming and then+-- typechecking of the signature 'ModIface' would have failed.+checkHsigIface :: TcGblEnv -> GlobalRdrEnv -> ModIface -> ModDetails -> TcRn ()+checkHsigIface tcg_env gr sig_iface+  ModDetails { md_insts = sig_insts, md_fam_insts = sig_fam_insts,+               md_types = sig_type_env, md_exports = sig_exports   } = do+    traceTc "checkHsigIface" $ vcat+        [ ppr sig_type_env, ppr sig_insts, ppr sig_exports ]+    mapM_ check_export (map availName sig_exports)+    unless (null sig_fam_insts) $+        panic ("TcRnDriver.checkHsigIface: Cannot handle family " +++               "instances in hsig files yet...")+    -- Delete instances so we don't look them up when+    -- checking instance satisfiability+    -- TODO: this should not be necessary+    tcg_env <- getGblEnv+    setGblEnv tcg_env { tcg_inst_env = emptyInstEnv,+                        tcg_fam_inst_env = emptyFamInstEnv,+                        tcg_insts = [],+                        tcg_fam_insts = [] } $ do+    mapM_ check_inst sig_insts+    failIfErrsM+  where+    -- NB: the Names in sig_type_env are bogus.  Let's say we have H.hsig+    -- in package p that defines T; and we implement with himpl:H.  Then the+    -- Name is p[himpl:H]:H.T, NOT himplH:H.T.  That's OK but we just+    -- have to look up the right name.+    sig_type_occ_env = mkOccEnv+                     . map (\t -> (nameOccName (getName t), t))+                     $ nameEnvElts sig_type_env+    dfun_names = map getName sig_insts+    check_export name+      -- Skip instances, we'll check them later+      -- TODO: Actually this should never happen, because DFuns are+      -- never exported...+      | name `elem` dfun_names = return ()+      -- See if we can find the type directly in the hsig ModDetails+      -- TODO: need to special case wired in names+      | Just sig_thing <- lookupOccEnv sig_type_occ_env (nameOccName name) = do+        -- NB: We use tcLookupImported_maybe because we want to EXCLUDE+        -- tcg_env (TODO: but maybe this isn't relevant anymore).+        r <- tcLookupImported_maybe name+        case r of+          Failed err -> addErr err+          Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing++      -- The hsig did NOT define this function; that means it must+      -- be a reexport.  In this case, make sure the 'Name' of the+      -- reexport matches the 'Name exported here.+      | [GRE { gre_name = name' }] <- lookupGlobalRdrEnv gr (nameOccName name) =+        when (name /= name') $ do+            -- See Note [Error reporting bad reexport]+            -- TODO: Actually this error swizzle doesn't work+            let p (L _ ie) = name `elem` ieNames ie+                loc = case tcg_rn_exports tcg_env of+                       Just es | Just e <- find p (map fst es)+                         -- TODO: maybe we can be a little more+                         -- precise here and use the Located+                         -- info for the *specific* name we matched.+                         -> getLoc e+                       _ -> nameSrcSpan name+            dflags <- getDynFlags+            addErrAt loc+                (badReexportedBootThing dflags False name name')+      -- This should actually never happen, but whatever...+      | otherwise =+        addErrAt (nameSrcSpan name)+            (missingBootThing False name "exported by")++-- Note [Error reporting bad reexport]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- NB: You want to be a bit careful about what location you report on reexports.+-- If the name was declared in the hsig file, 'nameSrcSpan name' is indeed the+-- correct source location.  However, if it was *reexported*, obviously the name+-- is not going to have the right location.  In this case, we need to grovel in+-- tcg_rn_exports to figure out where the reexport came from.++++-- | Checks if a 'ClsInst' is "defined". In general, for hsig files we can't+-- assume that the implementing file actually implemented the instances (they+-- may be reexported from elsewhere).  Where should we look for the instances?+-- We do the same as we would otherwise: consult the EPS.  This isn't perfect+-- (we might conclude the module exports an instance when it doesn't, see+-- #9422), but we will never refuse to compile something.+check_inst :: ClsInst -> TcM ()+check_inst sig_inst = do+    -- TODO: This could be very well generalized to support instance+    -- declarations in boot files.+    tcg_env <- getGblEnv+    -- NB: Have to tug on the interface, not necessarily+    -- tugged... but it didn't work?+    mapM_ tcLookupImported_maybe (nameSetElemsStable (orphNamesOfClsInst sig_inst))+    -- Based off of 'simplifyDeriv'+    let ty = idType (instanceDFunId sig_inst)+        skol_info = InstSkol+        -- Based off of tcSplitDFunTy+        (tvs, theta, pred) =+           case tcSplitForAllTys ty of { (tvs, rho)   ->+           case splitFunTys rho     of { (theta, pred) ->+           (tvs, theta, pred) }}+        origin = InstProvidedOrigin (tcg_semantic_mod tcg_env) sig_inst+    (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize+    (tclvl,cts) <- pushTcLevelM $ do+       wanted <- newWanted origin+                           (Just TypeLevel)+                           (substTy skol_subst pred)+       givens <- forM theta $ \given -> do+           loc <- getCtLocM origin (Just TypeLevel)+           let given_pred = substTy skol_subst given+           new_ev <- newEvVar given_pred+           return CtGiven { ctev_pred = given_pred+                          -- Doesn't matter, make something up+                          , ctev_evar = new_ev+                          , ctev_loc = loc+                          }+       return $ wanted : givens+    unsolved <- simplifyWantedsTcM cts++    (implic, _) <- buildImplicationFor tclvl skol_info tvs_skols [] unsolved+    reportAllUnsolved (mkImplicWC implic)++-- | Return this list of requirement interfaces that need to be merged+-- to form @mod_name@, or @[]@ if this is not a requirement.+requirementMerges :: DynFlags -> ModuleName -> [IndefModule]+requirementMerges dflags mod_name =+    fromMaybe [] (Map.lookup mod_name (requirementContext (pkgState dflags)))++-- | For a module @modname@ of type 'HscSource', determine the list+-- of extra "imports" of other requirements which should be considered part of+-- the import of the requirement, because it transitively depends on those+-- requirements by imports of modules from other packages.  The situation+-- is something like this:+--+--      unit p where+--          signature A+--          signature B+--              import A+--+--      unit q where+--          dependency p[A=<A>,B=<B>]+--          signature A+--          signature B+--+-- Although q's B does not directly import A, we still have to make sure we+-- process A first, because the merging process will cause B to indirectly+-- import A.  This function finds the TRANSITIVE closure of all such imports+-- we need to make.+findExtraSigImports' :: HscEnv+                     -> HscSource+                     -> ModuleName+                     -> IO (UniqDSet ModuleName)+findExtraSigImports' hsc_env HsigFile modname =+    fmap unionManyUniqDSets (forM reqs $ \(IndefModule iuid mod_name) ->+        (initIfaceLoad hsc_env+            . withException+            $ moduleFreeHolesPrecise (text "findExtraSigImports")+                (mkModule (IndefiniteUnitId iuid) mod_name)))+  where+    reqs = requirementMerges (hsc_dflags hsc_env) modname++findExtraSigImports' _ _ _ = return emptyUniqDSet++-- | 'findExtraSigImports', but in a convenient form for "GhcMake" and+-- "TcRnDriver".+findExtraSigImports :: HscEnv -> HscSource -> ModuleName+                    -> IO [(Maybe FastString, Located ModuleName)]+findExtraSigImports hsc_env hsc_src modname = do+    extra_requirements <- findExtraSigImports' hsc_env hsc_src modname+    return [ (Nothing, noLoc mod_name)+           | mod_name <- uniqDSetToList extra_requirements ]++-- A version of 'implicitRequirements'' which is more friendly+-- for "GhcMake" and "TcRnDriver".+implicitRequirements :: HscEnv+                     -> [(Maybe FastString, Located ModuleName)]+                     -> IO [(Maybe FastString, Located ModuleName)]+implicitRequirements hsc_env normal_imports+  = do mns <- implicitRequirements' hsc_env normal_imports+       return [ (Nothing, noLoc mn) | mn <- mns ]++-- Given a list of 'import M' statements in a module, figure out+-- any extra implicit requirement imports they may have.  For+-- example, if they 'import M' and M resolves to p[A=<B>], then+-- they actually also import the local requirement B.+implicitRequirements' :: HscEnv+                     -> [(Maybe FastString, Located ModuleName)]+                     -> IO [ModuleName]+implicitRequirements' hsc_env normal_imports+  = fmap concat $+    forM normal_imports $ \(mb_pkg, L _ imp) -> do+        found <- findImportedModule hsc_env imp mb_pkg+        case found of+            Found _ mod | thisPackage dflags /= moduleUnitId mod ->+                return (uniqDSetToList (moduleFreeHoles mod))+            _ -> return []+  where dflags = hsc_dflags hsc_env++-- | Given a 'UnitId', make sure it is well typed.  This is because+-- unit IDs come from Cabal, which does not know if things are well-typed or+-- not; a component may have been filled with implementations for the holes+-- that don't actually fulfill the requirements.+--+-- INVARIANT: the UnitId is NOT a InstalledUnitId+checkUnitId :: UnitId -> TcM ()+checkUnitId uid = do+    case splitUnitIdInsts uid of+      (_, Just indef) ->+        let insts = indefUnitIdInsts indef in+        forM_ insts $ \(mod_name, mod) ->+            -- NB: direct hole instantiations are well-typed by construction+            -- (because we FORCE things to be merged in), so don't check them+            when (not (isHoleModule mod)) $ do+                checkUnitId (moduleUnitId mod)+                _ <- mod `checkImplements` IndefModule indef mod_name+                return ()+      _ -> return () -- if it's hashed, must be well-typed++-- | Top-level driver for signature instantiation (run when compiling+-- an @hsig@ file.)+tcRnCheckUnitId ::+    HscEnv -> UnitId ->+    IO (Messages, Maybe ())+tcRnCheckUnitId hsc_env uid =+   withTiming (pure dflags)+              (text "Check unit id" <+> ppr uid)+              (const ()) $+   initTc hsc_env+          HsigFile -- bogus+          False+          mAIN -- bogus+          (realSrcLocSpan (mkRealSrcLoc (fsLit loc_str) 0 0)) -- bogus+    $ checkUnitId uid+  where+   dflags = hsc_dflags hsc_env+   loc_str = "Command line argument: -unit-id " ++ showSDoc dflags (ppr uid)++-- TODO: Maybe lcl_iface0 should be pre-renamed to the right thing? Unclear...++-- | Top-level driver for signature merging (run after typechecking+-- an @hsig@ file).+tcRnMergeSignatures :: HscEnv -> HsParsedModule -> TcGblEnv {- from local sig -} -> ModIface+                    -> IO (Messages, Maybe TcGblEnv)+tcRnMergeSignatures hsc_env hpm orig_tcg_env iface =+  withTiming (pure dflags)+             (text "Signature merging" <+> brackets (ppr this_mod))+             (const ()) $+  initTc hsc_env HsigFile False this_mod real_loc $+    mergeSignatures hpm orig_tcg_env iface+ where+  dflags   = hsc_dflags hsc_env+  this_mod = mi_module iface+  real_loc = tcg_top_loc orig_tcg_env++thinModIface :: [AvailInfo] -> ModIface -> ModIface+thinModIface avails iface =+    iface {+        mi_exports = avails,+        -- mi_fixities = ...,+        -- mi_warns = ...,+        -- mi_anns = ...,+        -- TODO: The use of nameOccName here is a bit dodgy, because+        -- perhaps there might be two IfaceTopBndr that are the same+        -- OccName but different Name.  Requires better understanding+        -- of invariants here.+        mi_decls = exported_decls ++ non_exported_decls ++ dfun_decls+        -- mi_insts = ...,+        -- mi_fam_insts = ...,+    }+  where+    decl_pred occs decl = nameOccName (ifName decl) `elemOccSet` occs+    filter_decls occs = filter (decl_pred occs . snd) (mi_decls iface)++    exported_occs = mkOccSet [ occName n+                             | a <- avails+                             , n <- availNames a ]+    exported_decls = filter_decls exported_occs++    non_exported_occs = mkOccSet [ occName n+                                 | (_, d) <- exported_decls+                                 , n <- ifaceDeclNeverExportedRefs d ]+    non_exported_decls = filter_decls non_exported_occs++    dfun_pred IfaceId{ ifIdDetails = IfDFunId } = True+    dfun_pred _ = False+    dfun_decls = filter (dfun_pred . snd) (mi_decls iface)++-- | The list of 'Name's of *non-exported* 'IfaceDecl's which this+-- 'IfaceDecl' may refer to.  A non-exported 'IfaceDecl' should be kept+-- after thinning if an *exported* 'IfaceDecl' (or 'mi_insts', perhaps)+-- refers to it; we can't decide to keep it by looking at the exports+-- of a module after thinning.  Keep this synchronized with+-- 'rnIfaceDecl'.+ifaceDeclNeverExportedRefs :: IfaceDecl -> [Name]+ifaceDeclNeverExportedRefs d@IfaceFamily{} =+    case ifFamFlav d of+        IfaceClosedSynFamilyTyCon (Just (n, _))+            -> [n]+        _   -> []+ifaceDeclNeverExportedRefs _ = []+++-- Note [Blank hsigs for all requirements]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- One invariant that a client of GHC must uphold is that there+-- must be an hsig file for every requirement (according to+-- @-this-unit-id@); this ensures that for every interface+-- file (hi), there is a source file (hsig), which helps grease+-- the wheels of recompilation avoidance which assumes that+-- source files always exist.++{-+inheritedSigPvpWarning :: WarningTxt+inheritedSigPvpWarning =+    WarningTxt (noLoc NoSourceText) [noLoc (StringLiteral NoSourceText (fsLit msg))]+  where+    msg = "Inherited requirements from non-signature libraries (libraries " +++          "with modules) should not be used, as this mode of use is not " +++          "compatible with PVP-style version bounds.  Instead, copy the " +++          "declaration to the local hsig file or move the signature to a " +++          "library of its own and add that library as a dependency."+-}++-- Note [Handling never-exported TyThings under Backpack]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--   DEFINITION: A "never-exported TyThing" is a TyThing whose 'Name' will+--   never be mentioned in the export list of a module (mi_avails).+--   Unlike implicit TyThings (Note [Implicit TyThings]), non-exported+--   TyThings DO have a standalone IfaceDecl declaration in their+--   interface file.+--+-- Originally, Backpack was designed under the assumption that anything+-- you could declare in a module could also be exported; thus, merging+-- the export lists of two signatures is just merging the declarations+-- of two signatures writ small.  Of course, in GHC Haskell, there are a+-- few important things which are not explicitly exported but still can+-- be used:  in particular, dictionary functions for instances, Typeable+-- TyCon bindings, and coercion axioms for type families also count.+--+-- When handling these non-exported things, there two primary things+-- we need to watch out for:+--+--  * Signature matching/merging is done by comparing each+--    of the exported entities of a signature and a module.  These exported+--    entities may refer to non-exported TyThings which must be tested for+--    consistency.  For example, an instance (ClsInst) will refer to a+--    non-exported DFunId.  In this case, 'checkBootDeclM' directly compares the+--    embedded 'DFunId' in 'is_dfun'.+--+--    For this to work at all, we must ensure that pointers in 'is_dfun' refer+--    to DISTINCT 'DFunId's, even though the 'Name's (may) be the same.+--    Unfortunately, this is the OPPOSITE of how we treat most other references+--    to 'Name's, so this case needs to be handled specially.+--+--    The details are in the documentation for 'typecheckIfacesForMerging'.+--    and the Note [Resolving never-exported Names in TcIface].+--+--  * When we rename modules and signatures, we use the export lists to+--    decide how the declarations should be renamed.  However, this+--    means we don't get any guidance for how to rename non-exported+--    entities.  Fortunately, we only need to rename these entities+--    *consistently*, so that 'typecheckIfacesForMerging' can wire them+--    up as needed.+--+--    The details are in Note [rnIfaceNeverExported] in 'RnModIface'.+--+-- The root cause for all of these complications is the fact that these+-- logically "implicit" entities are defined indirectly in an interface+-- file.  #13151 gives a proposal to make these *truly* implicit.++merge_msg :: ModuleName -> [IndefModule] -> SDoc+merge_msg mod_name [] =+    text "while checking the local signature" <+> ppr mod_name <+>+    text "for consistency"+merge_msg mod_name reqs =+  hang (text "while merging the signatures from" <> colon)+   2 (vcat [ bullet <+> ppr req | req <- reqs ] $$+      bullet <+> text "...and the local signature for" <+> ppr mod_name)++-- | Given a local 'ModIface', merge all inherited requirements+-- from 'requirementMerges' into this signature, producing+-- a final 'TcGblEnv' that matches the local signature and+-- all required signatures.+mergeSignatures :: HsParsedModule -> TcGblEnv -> ModIface -> TcRn TcGblEnv+mergeSignatures+  (HsParsedModule { hpm_module = L loc (HsModule { hsmodExports = mb_exports }),+                    hpm_src_files = src_files })+  orig_tcg_env lcl_iface0 = setSrcSpan loc $ do+    -- The lcl_iface0 is the ModIface for the local hsig+    -- file, which is guaranteed to exist, see+    -- Note [Blank hsigs for all requirements]+    hsc_env <- getTopEnv+    dflags  <- getDynFlags++    -- Copy over some things from the original TcGblEnv that+    -- we want to preserve+    updGblEnv (\env -> env {+        -- Renamed imports/declarations are often used+        -- by programs that use the GHC API, e.g., Haddock.+        -- These won't get filled by the merging process (since+        -- we don't actually rename the parsed module again) so+        -- we need to take them directly from the previous+        -- typechecking.+        --+        -- NB: the export declarations aren't in their final+        -- form yet.  We'll fill those in when we reprocess+        -- the export declarations.+        tcg_rn_imports = tcg_rn_imports orig_tcg_env,+        tcg_rn_decls   = tcg_rn_decls   orig_tcg_env,+        -- Annotations+        tcg_ann_env    = tcg_ann_env    orig_tcg_env,+        -- Documentation header+        tcg_doc_hdr    = tcg_doc_hdr orig_tcg_env+        -- tcg_dus?+        -- tcg_th_used           = tcg_th_used orig_tcg_env,+        -- tcg_th_splice_used    = tcg_th_splice_used orig_tcg_env+        -- tcg_th_top_level_locs = tcg_th_top_level_locs orig_tcg_env+       }) $ do+    tcg_env <- getGblEnv++    let outer_mod = tcg_mod tcg_env+        inner_mod = tcg_semantic_mod tcg_env+        mod_name = moduleName (tcg_mod tcg_env)++    -- STEP 1: Figure out all of the external signature interfaces+    -- we are going to merge in.+    let reqs = requirementMerges dflags mod_name++    addErrCtxt (merge_msg mod_name reqs) $ do++    -- STEP 2: Read in the RAW forms of all of these interfaces+    ireq_ifaces0 <- forM reqs $ \(IndefModule iuid mod_name) ->+        let m = mkModule (IndefiniteUnitId iuid) mod_name+            im = fst (splitModuleInsts m)+        in fmap fst+         . withException+         $ findAndReadIface (text "mergeSignatures") im m False++    -- STEP 3: Get the unrenamed exports of all these interfaces,+    -- thin it according to the export list, and do shaping on them.+    let extend_ns nsubst as = liftIO $ extendNameShape hsc_env nsubst as+        -- This function gets run on every inherited interface, and+        -- it's responsible for:+        --+        --  1. Merging the exports of the interface into @nsubst@,+        --  2. Adding these exports to the "OK to import" set (@oks@)+        --  if they came from a package with no exposed modules+        --  (this means we won't report a PVP error in this case), and+        --  3. Thinning the interface according to an explicit export+        --  list.+        --+        gen_subst (nsubst,oks,ifaces) (imod@(IndefModule iuid _), ireq_iface) = do+            let insts = indefUnitIdInsts iuid+                isFromSignaturePackage =+                    let inst_uid = fst (splitUnitIdInsts (IndefiniteUnitId iuid))+                        pkg = getInstalledPackageDetails dflags inst_uid+                    in null (exposedModules pkg)+            -- 3(a). Rename the exports according to how the dependency+            -- was instantiated.  The resulting export list will be accurate+            -- except for exports *from the signature itself* (which may+            -- be subsequently updated by exports from other signatures in+            -- the merge.+            as1 <- tcRnModExports insts ireq_iface+            -- 3(b). Thin the interface if it comes from a signature package.+            (thinned_iface, as2) <- case mb_exports of+                    Just (L loc _)+                      -- Check if the package containing this signature is+                      -- a signature package (i.e., does not expose any+                      -- modules.)  If so, we can thin it.+                      | isFromSignaturePackage+                      -> setSrcSpan loc $ do+                        -- Suppress missing errors; they might be used to refer+                        -- to entities from other signatures we are merging in.+                        -- If an identifier truly doesn't exist in any of the+                        -- signatures that are merged in, we will discover this+                        -- when we run exports_from_avail on the final merged+                        -- export list.+                        (mb_r, msgs) <- tryTc $ do+                            -- Suppose that we have written in a signature:+                            --  signature A ( module A ) where {- empty -}+                            -- If I am also inheriting a signature from a+                            -- signature package, does 'module A' scope over+                            -- all of its exports?+                            --+                            -- There are two possible interpretations:+                            --+                            --  1. For non self-reexports, a module reexport+                            --  is interpreted only in terms of the local+                            --  signature module, and not any of the inherited+                            --  ones.  The reason for this is because after+                            --  typechecking, module exports are completely+                            --  erased from the interface of a file, so we+                            --  have no way of "interpreting" a module reexport.+                            --  Thus, it's only useful for the local signature+                            --  module (where we have a useful GlobalRdrEnv.)+                            --+                            --  2. On the other hand, a common idiom when+                            --  you want to "export everything, plus a reexport"+                            --  in modules is to say module A ( module A, reex ).+                            --  This applies to signature modules too; and in+                            --  particular, you probably still want the entities+                            --  from the inherited signatures to be preserved+                            --  too.+                            --+                            -- We think it's worth making a special case for+                            -- self reexports to make use case (2) work.  To+                            -- do this, we take the exports of the inherited+                            -- signature @as1@, and bundle them into a+                            -- GlobalRdrEnv where we treat them as having come+                            -- from the import @import A@.  Thus, we will+                            -- pick them up if they are referenced explicitly+                            -- (@foo@) or even if we do a module reexport+                            -- (@module A@).+                            let ispec = ImpSpec ImpDeclSpec{+                                            -- NB: This needs to be mod name+                                            -- of the local signature, not+                                            -- the (original) module name of+                                            -- the inherited signature,+                                            -- because we need module+                                            -- LocalSig (from the local+                                            -- export list) to match it!+                                            is_mod  = mod_name,+                                            is_as   = mod_name,+                                            is_qual = False,+                                            is_dloc = loc+                                          } ImpAll+                                rdr_env = mkGlobalRdrEnv (gresFromAvails (Just ispec) as1)+                            setGblEnv tcg_env {+                                tcg_rdr_env = rdr_env+                            } $ exports_from_avail mb_exports rdr_env+                                    -- NB: tcg_imports is also empty!+                                    emptyImportAvails+                                    (tcg_semantic_mod tcg_env)+                        case mb_r of+                            Just (_, as2) -> return (thinModIface as2 ireq_iface, as2)+                            Nothing -> addMessages msgs >> failM+                    -- We can't think signatures from non signature packages+                    _ -> return (ireq_iface, as1)+            -- 3(c). Only identifiers from signature packages are "ok" to+            -- import (that is, they are safe from a PVP perspective.)+            -- (NB: This code is actually dead right now.)+            let oks' | isFromSignaturePackage+                     = extendOccSetList oks (exportOccs as2)+                     | otherwise+                     = oks+            -- 3(d). Extend the name substitution (performing shaping)+            mb_r <- extend_ns nsubst as2+            case mb_r of+                Left err -> failWithTc err+                Right nsubst' -> return (nsubst',oks',(imod, thinned_iface):ifaces)+        nsubst0 = mkNameShape (moduleName inner_mod) (mi_exports lcl_iface0)+        ok_to_use0 = mkOccSet (exportOccs (mi_exports lcl_iface0))+    -- Process each interface, getting the thinned interfaces as well as+    -- the final, full set of exports @nsubst@ and the exports which are+    -- "ok to use" (we won't attach 'inheritedSigPvpWarning' to them.)+    (nsubst, ok_to_use, rev_thinned_ifaces)+        <- foldM gen_subst (nsubst0, ok_to_use0, []) (zip reqs ireq_ifaces0)+    let thinned_ifaces = reverse rev_thinned_ifaces+        exports        = nameShapeExports nsubst+        rdr_env        = mkGlobalRdrEnv (gresFromAvails Nothing exports)+        _warn_occs     = filter (not . (`elemOccSet` ok_to_use)) (exportOccs exports)+        warns          = NoWarnings+        {-+        -- TODO: Warnings are transitive, but this is not what we want here:+        -- if a module reexports an entity from a signature, that should be OK.+        -- Not supported in current warning framework+        warns | null warn_occs = NoWarnings+              | otherwise = WarnSome $ map (\o -> (o, inheritedSigPvpWarning)) warn_occs+        -}+    setGblEnv tcg_env {+        -- The top-level GlobalRdrEnv is quite interesting.  It consists+        -- of two components:+        --  1. First, we reuse the GlobalRdrEnv of the local signature.+        --     This is very useful, because it means that if we have+        --     to print a message involving some entity that the local+        --     signature imported, we'll qualify it accordingly.+        --  2. Second, we need to add all of the declarations we are+        --     going to merge in (as they need to be in scope for the+        --     final test of the export list.)+        tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env orig_tcg_env,+        -- Inherit imports from the local signature, so that module+        -- rexports are picked up correctly+        tcg_imports = tcg_imports orig_tcg_env,+        tcg_exports = exports,+        tcg_dus     = usesOnly (availsToNameSetWithSelectors exports),+        tcg_warns   = warns+        } $ do+    tcg_env <- getGblEnv++    -- Make sure we didn't refer to anything that doesn't actually exist+    -- pprTrace "mergeSignatures: exports_from_avail" (ppr exports) $ return ()+    (mb_lies, _) <- exports_from_avail mb_exports rdr_env+                        (tcg_imports tcg_env) (tcg_semantic_mod tcg_env)++    {- -- NB: This is commented out, because warns above is disabled.+    -- If you tried to explicitly export an identifier that has a warning+    -- attached to it, that's probably a mistake.  Warn about it.+    case mb_lies of+      Nothing -> return ()+      Just lies ->+        forM_ (concatMap (\(L loc x) -> map (L loc) (ieNames x)) lies) $ \(L loc n) ->+          setSrcSpan loc $+            unless (nameOccName n `elemOccSet` ok_to_use) $+                addWarn NoReason $ vcat [+                    text "Exported identifier" <+> quotes (ppr n) <+> text "will cause warnings if used.",+                    parens (text "To suppress this warning, remove" <+> quotes (ppr n) <+> text "from the export list of this signature.")+                    ]+    -}++    failIfErrsM++    -- Save the exports+    setGblEnv tcg_env { tcg_rn_exports = mb_lies } $ do+    tcg_env <- getGblEnv++    -- STEP 4: Rename the interfaces+    ext_ifaces <- forM thinned_ifaces $ \((IndefModule iuid _), ireq_iface) ->+        tcRnModIface (indefUnitIdInsts iuid) (Just nsubst) ireq_iface+    lcl_iface <- tcRnModIface (thisUnitIdInsts dflags) (Just nsubst) lcl_iface0+    let ifaces = lcl_iface : ext_ifaces++    -- STEP 4.1: Merge fixities (we'll verify shortly) tcg_fix_env+    let fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)+                            | (occ, f) <- concatMap mi_fixities ifaces+                            , rdr_elt <- lookupGlobalRdrEnv rdr_env occ ]++    -- STEP 5: Typecheck the interfaces+    let type_env_var = tcg_type_env_var tcg_env++    -- typecheckIfacesForMerging does two things:+    --      1. It merges the all of the ifaces together, and typechecks the+    --      result to type_env.+    --      2. It typechecks each iface individually, but with their 'Name's+    --      resolving to the merged type_env from (1).+    -- See typecheckIfacesForMerging for more details.+    (type_env, detailss) <- initIfaceTcRn $+                            typecheckIfacesForMerging inner_mod ifaces type_env_var+    let infos = zip ifaces detailss++    -- Test for cycles+    checkSynCycles (thisPackage dflags) (typeEnvTyCons type_env) []++    -- NB on type_env: it contains NO dfuns.  DFuns are recorded inside+    -- detailss, and given a Name that doesn't correspond to anything real.  See+    -- also Note [Signature merging DFuns]++    -- Add the merged type_env to TcGblEnv, so that it gets serialized+    -- out when we finally write out the interface.+    --+    -- NB: Why do we set tcg_tcs/tcg_patsyns/tcg_type_env directly,+    -- rather than use tcExtendGlobalEnv (the normal method to add newly+    -- defined types to TcGblEnv?)  tcExtendGlobalEnv adds these+    -- TyThings to 'tcg_type_env_var', which is consulted when+    -- we read in interfaces to tie the knot.  But *these TyThings themselves+    -- come from interface*, so that would result in deadlock.  Don't+    -- update it!+    setGblEnv tcg_env {+        tcg_tcs = typeEnvTyCons type_env,+        tcg_patsyns = typeEnvPatSyns type_env,+        tcg_type_env = type_env,+        tcg_fix_env = fix_env+        } $ do+    tcg_env <- getGblEnv++    -- STEP 6: Check for compatibility/merge things+    tcg_env <- (\x -> foldM x tcg_env infos)+             $ \tcg_env (iface, details) -> do++        let check_export name+              | Just sig_thing <- lookupTypeEnv (md_types details) name+              = case lookupTypeEnv type_env (getName sig_thing) of+                  Just thing -> checkHsigDeclM iface sig_thing thing+                  Nothing -> panic "mergeSignatures: check_export"+              -- Oops! We're looking for this export but it's+              -- not actually in the type environment of the signature's+              -- ModDetails.+              --+              -- NB: This case happens because the we're iterating+              -- over the union of all exports, so some interfaces+              -- won't have everything.  Note that md_exports is nonsense+              -- (it's the same as exports); maybe we should fix this+              -- eventually.+              | otherwise+              = return ()+        mapM_ check_export (map availName exports)++        -- Note [Signature merging instances]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        -- Merge instances into the global environment.  The algorithm here is+        -- dumb and simple: if an instance has exactly the same DFun type+        -- (tested by 'memberInstEnv') as an existing instance, we drop it;+        -- otherwise, we add it even, even if this would cause overlap.+        --+        -- Why don't we deduplicate instances with identical heads?  There's no+        -- good choice if they have premises:+        --+        --      instance K1 a => K (T a)+        --      instance K2 a => K (T a)+        --+        -- Why not eagerly error in this case?  The overlapping head does not+        -- necessarily mean that the instances are unimplementable: in fact,+        -- they may be implemented without overlap (if, for example, the+        -- implementing module has 'instance K (T a)'; both are implemented in+        -- this case.)  The implements test just checks that the wanteds are+        -- derivable assuming the givens.+        --+        -- Still, overlapping instances with hypotheses like above are going+        -- to be a bad deal, because instance resolution when we're typechecking+        -- against the merged signature is going to have a bad time when+        -- there are overlapping heads like this: we never backtrack, so it+        -- may be difficult to see that a wanted is derivable.  For now,+        -- we hope that we get lucky / the overlapping instances never+        -- get used, but it is not a very good situation to be in.+        --+        let merge_inst (insts, inst_env) inst+                | memberInstEnv inst_env inst -- test DFun Type equality+                = (insts, inst_env)+                | otherwise+                -- NB: is_dfun_name inst is still nonsense here,+                -- see Note [Signature merging DFuns]+                = (inst:insts, extendInstEnv inst_env inst)+            (insts, inst_env) = foldl' merge_inst+                                    (tcg_insts tcg_env, tcg_inst_env tcg_env)+                                    (md_insts details)+            -- This is a HACK to prevent calculateAvails from including imp_mod+            -- in the listing.  We don't want it because a module is NOT+            -- supposed to include itself in its dep_orphs/dep_finsts.  See #13214+            iface' = iface { mi_orphan = False, mi_finsts = False }+            avails = plusImportAvails (tcg_imports tcg_env) $+                        calculateAvails dflags iface' False False ImportedBySystem+        return tcg_env {+            tcg_inst_env = inst_env,+            tcg_insts    = insts,+            tcg_imports  = avails,+            tcg_merged   =+                if outer_mod == mi_module iface+                    -- Don't add ourselves!+                    then tcg_merged tcg_env+                    else (mi_module iface, mi_mod_hash iface) : tcg_merged tcg_env+            }++    -- Note [Signature merging DFuns]+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    -- Once we know all of instances which will be defined by this merged+    -- signature, we go through each of the DFuns and rename them with a fresh,+    -- new, unique DFun Name, and add these DFuns to tcg_type_env (thus fixing+    -- up the "bogus" names that were setup in 'typecheckIfacesForMerging'.+    --+    -- We can't do this fixup earlier, because we need a way to identify each+    -- source DFun (from each of the signatures we are merging in) so that+    -- when we have a ClsInst, we can pull up the correct DFun to check if+    -- the types match.+    --+    -- See also Note [rnIfaceNeverExported] in RnModIface+    dfun_insts <- forM (tcg_insts tcg_env) $ \inst -> do+        n <- newDFunName (is_cls inst) (is_tys inst) (nameSrcSpan (is_dfun_name inst))+        let dfun = setVarName (is_dfun inst) n+        return (dfun, inst { is_dfun_name = n, is_dfun = dfun })+    tcg_env <- return tcg_env {+            tcg_insts = map snd dfun_insts,+            tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) (map fst dfun_insts)+        }++    addDependentFiles src_files++    return tcg_env++-- | Top-level driver for signature instantiation (run when compiling+-- an @hsig@ file.)+tcRnInstantiateSignature ::+    HscEnv -> Module -> RealSrcSpan ->+    IO (Messages, Maybe TcGblEnv)+tcRnInstantiateSignature hsc_env this_mod real_loc =+   withTiming (pure dflags)+              (text "Signature instantiation"<+>brackets (ppr this_mod))+              (const ()) $+   initTc hsc_env HsigFile False this_mod real_loc $ instantiateSignature+  where+   dflags = hsc_dflags hsc_env++exportOccs :: [AvailInfo] -> [OccName]+exportOccs = concatMap (map occName . availNames)++impl_msg :: Module -> IndefModule -> SDoc+impl_msg impl_mod (IndefModule req_uid req_mod_name) =+  text "while checking that" <+> ppr impl_mod <+>+  text "implements signature" <+> ppr req_mod_name <+>+  text "in" <+> ppr req_uid++-- | Check if module implements a signature.  (The signature is+-- always un-hashed, which is why its components are specified+-- explicitly.)+checkImplements :: Module -> IndefModule -> TcRn TcGblEnv+checkImplements impl_mod req_mod@(IndefModule uid mod_name) =+  addErrCtxt (impl_msg impl_mod req_mod) $ do+    let insts = indefUnitIdInsts uid++    -- STEP 1: Load the implementing interface, and make a RdrEnv+    -- for its exports.  Also, add its 'ImportAvails' to 'tcg_imports',+    -- so that we treat all orphan instances it provides as visible+    -- when we verify that all instances are checked (see #12945), and so that+    -- when we eventually write out the interface we record appropriate+    -- dependency information.+    impl_iface <- initIfaceTcRn $+        loadSysInterface (text "checkImplements 1") impl_mod+    let impl_gr = mkGlobalRdrEnv+                    (gresFromAvails Nothing (mi_exports impl_iface))+        nsubst = mkNameShape (moduleName impl_mod) (mi_exports impl_iface)++    -- Load all the orphans, so the subsequent 'checkHsigIface' sees+    -- all the instances it needs to+    loadModuleInterfaces (text "Loading orphan modules (from implementor of hsig)")+                         (dep_orphs (mi_deps impl_iface))++    dflags <- getDynFlags+    let avails = calculateAvails dflags+                    impl_iface False{- safe -} False{- boot -} ImportedBySystem+        fix_env = mkNameEnv [ (gre_name rdr_elt, FixItem occ f)+                            | (occ, f) <- mi_fixities impl_iface+                            , rdr_elt <- lookupGlobalRdrEnv impl_gr occ ]+    updGblEnv (\tcg_env -> tcg_env {+        -- Setting tcg_rdr_env to treat all exported entities from+        -- the implementing module as in scope improves error messages,+        -- as it reduces the amount of qualification we need.  Unfortunately,+        -- we still end up qualifying references to external modules+        -- (see bkpfail07 for an example); we'd need to record more+        -- information in ModIface to solve this.+        tcg_rdr_env = tcg_rdr_env tcg_env `plusGlobalRdrEnv` impl_gr,+        tcg_imports = tcg_imports tcg_env `plusImportAvails` avails,+        -- This is here so that when we call 'lookupFixityRn' for something+        -- directly implemented by the module, we grab the right thing+        tcg_fix_env = fix_env+        }) $ do++    -- STEP 2: Load the *unrenamed, uninstantiated* interface for+    -- the ORIGINAL signature.  We are going to eventually rename it,+    -- but we must proceed slowly, because it is NOT known if the+    -- instantiation is correct.+    let sig_mod = mkModule (IndefiniteUnitId uid) mod_name+        isig_mod = fst (splitModuleInsts sig_mod)+    mb_isig_iface <- findAndReadIface (text "checkImplements 2") isig_mod sig_mod False+    isig_iface <- case mb_isig_iface of+        Succeeded (iface, _) -> return iface+        Failed err -> failWithTc $+            hang (text "Could not find hi interface for signature" <+>+                  quotes (ppr isig_mod) <> colon) 4 err++    -- STEP 3: Check that the implementing interface exports everything+    -- we need.  (Notice we IGNORE the Modules in the AvailInfos.)+    forM_ (exportOccs (mi_exports isig_iface)) $ \occ ->+        case lookupGlobalRdrEnv impl_gr occ of+            [] -> addErr $ quotes (ppr occ)+                    <+> text "is exported by the hsig file, but not"+                    <+> text "exported by the implementing module"+                    <+> quotes (ppr impl_mod)+            _ -> return ()+    failIfErrsM++    -- STEP 4: Now that the export is complete, rename the interface...+    sig_iface <- tcRnModIface insts (Just nsubst) isig_iface++    -- STEP 5: ...and typecheck it.  (Note that in both cases, the nsubst+    -- lets us determine how top-level identifiers should be handled.)+    sig_details <- initIfaceTcRn $ typecheckIfaceForInstantiate nsubst sig_iface++    -- STEP 6: Check that it's sufficient+    tcg_env <- getGblEnv+    checkHsigIface tcg_env impl_gr sig_iface sig_details++    -- STEP 7: Return the updated 'TcGblEnv' with the signature exports,+    -- so we write them out.+    return tcg_env {+        tcg_exports = mi_exports sig_iface+        }++-- | Given 'tcg_mod', instantiate a 'ModIface' from the indefinite+-- library to use the actual implementations of the relevant entities,+-- checking that the implementation matches the signature.+instantiateSignature :: TcRn TcGblEnv+instantiateSignature = do+    tcg_env <- getGblEnv+    dflags <- getDynFlags+    let outer_mod = tcg_mod tcg_env+        inner_mod = tcg_semantic_mod tcg_env+    -- TODO: setup the local RdrEnv so the error messages look a little better.+    -- But this information isn't stored anywhere. Should we RETYPECHECK+    -- the local one just to get the information?  Hmm...+    MASSERT( moduleUnitId outer_mod == thisPackage dflags )+    inner_mod `checkImplements`+        IndefModule+            (newIndefUnitId (thisComponentId dflags)+                            (thisUnitIdInsts dflags))+            (moduleName outer_mod)
+ compiler/typecheck/TcBinds.hs view
@@ -0,0 +1,1738 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[TcBinds]{TcBinds}+-}++{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module TcBinds ( tcLocalBinds, tcTopBinds, tcValBinds,+                 tcHsBootSigs, tcPolyCheck,+                 addTypecheckedBinds,+                 chooseInferredQuantifiers,+                 badBootDeclErr ) where++import GhcPrelude++import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )+import {-# SOURCE #-} TcExpr  ( tcMonoExpr )+import {-# SOURCE #-} TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind )+import CoreSyn (Tickish (..))+import CostCentre (mkUserCC, CCFlavour(DeclCC))+import DynFlags+import FastString+import HsSyn+import HscTypes( isHsBootOrSig )+import TcSigs+import TcRnMonad+import TcEnv+import TcUnify+import TcSimplify+import TcEvidence+import TcHsType+import TcPat+import TcMType+import FamInstEnv( normaliseType )+import FamInst( tcGetFamInstEnvs )+import TyCon+import TcType+import Type( mkStrLitTy, tidyOpenType, splitTyConApp_maybe, mkCastTy)+import TysPrim+import TysWiredIn( mkBoxedTupleTy )+import Id+import Var+import VarSet+import VarEnv( TidyEnv )+import Module+import Name+import NameSet+import NameEnv+import SrcLoc+import Bag+import ErrUtils+import Digraph+import Maybes+import Util+import BasicTypes+import Outputable+import PrelNames( ipClassName )+import TcValidity (checkValidType)+import UniqFM+import UniqSet+import qualified GHC.LanguageExtensions as LangExt+import ConLike++import Control.Monad++#include "HsVersions.h"++{- *********************************************************************+*                                                                      *+               A useful helper function+*                                                                      *+********************************************************************* -}++addTypecheckedBinds :: TcGblEnv -> [LHsBinds GhcTc] -> TcGblEnv+addTypecheckedBinds tcg_env binds+  | isHsBootOrSig (tcg_src tcg_env) = tcg_env+    -- Do not add the code for record-selector bindings+    -- when compiling hs-boot files+  | otherwise = tcg_env { tcg_binds = foldr unionBags+                                            (tcg_binds tcg_env)+                                            binds }++{-+************************************************************************+*                                                                      *+\subsection{Type-checking bindings}+*                                                                      *+************************************************************************++@tcBindsAndThen@ typechecks a @HsBinds@.  The "and then" part is because+it needs to know something about the {\em usage} of the things bound,+so that it can create specialisations of them.  So @tcBindsAndThen@+takes a function which, given an extended environment, E, typechecks+the scope of the bindings returning a typechecked thing and (most+important) an LIE.  It is this LIE which is then used as the basis for+specialising the things bound.++@tcBindsAndThen@ also takes a "combiner" which glues together the+bindings and the "thing" to make a new "thing".++The real work is done by @tcBindWithSigsAndThen@.++Recursive and non-recursive binds are handled in essentially the same+way: because of uniques there are no scoping issues left.  The only+difference is that non-recursive bindings can bind primitive values.++Even for non-recursive binding groups we add typings for each binder+to the LVE for the following reason.  When each individual binding is+checked the type of its LHS is unified with that of its RHS; and+type-checking the LHS of course requires that the binder is in scope.++At the top-level the LIE is sure to contain nothing but constant+dictionaries, which we resolve at the module level.++Note [Polymorphic recursion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The game plan for polymorphic recursion in the code above is++        * Bind any variable for which we have a type signature+          to an Id with a polymorphic type.  Then when type-checking+          the RHSs we'll make a full polymorphic call.++This fine, but if you aren't a bit careful you end up with a horrendous+amount of partial application and (worse) a huge space leak. For example:++        f :: Eq a => [a] -> [a]+        f xs = ...f...++If we don't take care, after typechecking we get++        f = /\a -> \d::Eq a -> let f' = f a d+                               in+                               \ys:[a] -> ...f'...++Notice the stupid construction of (f a d), which is of course+identical to the function we're executing.  In this case, the+polymorphic recursion isn't being used (but that's a very common case).+This can lead to a massive space leak, from the following top-level defn+(post-typechecking)++        ff :: [Int] -> [Int]+        ff = f Int dEqInt++Now (f dEqInt) evaluates to a lambda that has f' as a free variable; but+f' is another thunk which evaluates to the same thing... and you end+up with a chain of identical values all hung onto by the CAF ff.++        ff = f Int dEqInt++           = let f' = f Int dEqInt in \ys. ...f'...++           = let f' = let f' = f Int dEqInt in \ys. ...f'...+                      in \ys. ...f'...++Etc.++NOTE: a bit of arity anaysis would push the (f a d) inside the (\ys...),+which would make the space leak go away in this case++Solution: when typechecking the RHSs we always have in hand the+*monomorphic* Ids for each binding.  So we just need to make sure that+if (Method f a d) shows up in the constraints emerging from (...f...)+we just use the monomorphic Id.  We achieve this by adding monomorphic Ids+to the "givens" when simplifying constraints.  That's what the "lies_avail"+is doing.++Then we get++        f = /\a -> \d::Eq a -> letrec+                                 fm = \ys:[a] -> ...fm...+                               in+                               fm+-}++tcTopBinds :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]+           -> TcM (TcGblEnv, TcLclEnv)+-- The TcGblEnv contains the new tcg_binds and tcg_spects+-- The TcLclEnv has an extended type envt for the new bindings+tcTopBinds binds sigs+  = do  { -- Pattern synonym bindings populate the global environment+          (binds', (tcg_env, tcl_env)) <- tcValBinds TopLevel binds sigs $+            do { gbl <- getGblEnv+               ; lcl <- getLclEnv+               ; return (gbl, lcl) }+        ; specs <- tcImpPrags sigs   -- SPECIALISE prags for imported Ids++        ; complete_matches <- setEnvs (tcg_env, tcl_env) $ tcCompleteSigs sigs+        ; traceTc "complete_matches" (ppr binds $$ ppr sigs)+        ; traceTc "complete_matches" (ppr complete_matches)++        ; let { tcg_env' = tcg_env { tcg_imp_specs+                                      = specs ++ tcg_imp_specs tcg_env+                                   , tcg_complete_matches+                                      = complete_matches+                                          ++ tcg_complete_matches tcg_env }+                           `addTypecheckedBinds` map snd binds' }++        ; return (tcg_env', tcl_env) }+        -- The top level bindings are flattened into a giant+        -- implicitly-mutually-recursive LHsBinds+++-- Note [Typechecking Complete Matches]+-- Much like when a user bundled a pattern synonym, the result types of+-- all the constructors in the match pragma must be consistent.+--+-- If we allowed pragmas with inconsistent types then it would be+-- impossible to ever match every constructor in the list and so+-- the pragma would be useless.++++++-- This is only used in `tcCompleteSig`. We fold over all the conlikes,+-- this accumulator keeps track of the first `ConLike` with a concrete+-- return type. After fixing the return type, all other constructors with+-- a fixed return type must agree with this.+--+-- The fields of `Fixed` cache the first conlike and its return type so+-- that that we can compare all the other conlikes to it. The conlike is+-- stored for error messages.+--+-- `Nothing` in the case that the type is fixed by a type signature+data CompleteSigType = AcceptAny | Fixed (Maybe ConLike) TyCon++tcCompleteSigs  :: [LSig GhcRn] -> TcM [CompleteMatch]+tcCompleteSigs sigs =+  let+      doOne :: Sig GhcRn -> TcM (Maybe CompleteMatch)+      doOne c@(CompleteMatchSig _ _ lns mtc)+        = fmap Just $ do+           addErrCtxt (text "In" <+> ppr c) $+            case mtc of+              Nothing -> infer_complete_match+              Just tc -> check_complete_match tc+        where++          checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns)++          infer_complete_match = do+            (res, cls) <- checkCLTypes AcceptAny+            case res of+              AcceptAny -> failWithTc ambiguousError+              Fixed _ tc  -> return $ mkMatch cls tc++          check_complete_match tc_name = do+            ty_con <- tcLookupLocatedTyCon tc_name+            (_, cls) <- checkCLTypes (Fixed Nothing ty_con)+            return $ mkMatch cls ty_con++          mkMatch :: [ConLike] -> TyCon -> CompleteMatch+          mkMatch cls ty_con = CompleteMatch {+            completeMatchConLikes = map conLikeName cls,+            completeMatchTyCon = tyConName ty_con+            }+      doOne _ = return Nothing++      ambiguousError :: SDoc+      ambiguousError =+        text "A type signature must be provided for a set of polymorphic"+          <+> text "pattern synonyms."+++      -- See note [Typechecking Complete Matches]+      checkCLType :: (CompleteSigType, [ConLike]) -> Located Name+                  -> TcM (CompleteSigType, [ConLike])+      checkCLType (cst, cs) n = do+        cl <- addLocM tcLookupConLike n+        let   (_,_,_,_,_,_, res_ty) = conLikeFullSig cl+              res_ty_con = fst <$> splitTyConApp_maybe res_ty+        case (cst, res_ty_con) of+          (AcceptAny, Nothing) -> return (AcceptAny, cl:cs)+          (AcceptAny, Just tc) -> return (Fixed (Just cl) tc, cl:cs)+          (Fixed mfcl tc, Nothing)  -> return (Fixed mfcl tc, cl:cs)+          (Fixed mfcl tc, Just tc') ->+            if tc == tc'+              then return (Fixed mfcl tc, cl:cs)+              else case mfcl of+                     Nothing ->+                      addErrCtxt (text "In" <+> ppr cl) $+                        failWithTc typeSigErrMsg+                     Just cl -> failWithTc (errMsg cl)+             where+              typeSigErrMsg :: SDoc+              typeSigErrMsg =+                text "Couldn't match expected type"+                      <+> quotes (ppr tc)+                      <+> text "with"+                      <+> quotes (ppr tc')++              errMsg :: ConLike -> SDoc+              errMsg fcl =+                text "Cannot form a group of complete patterns from patterns"+                  <+> quotes (ppr fcl) <+> text "and" <+> quotes (ppr cl)+                  <+> text "as they match different type constructors"+                  <+> parens (quotes (ppr tc)+                               <+> text "resp."+                               <+> quotes (ppr tc'))+  in  mapMaybeM (addLocM doOne) sigs++tcHsBootSigs :: [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn] -> TcM [Id]+-- A hs-boot file has only one BindGroup, and it only has type+-- signatures in it.  The renamer checked all this+tcHsBootSigs binds sigs+  = do  { checkTc (null binds) badBootDeclErr+        ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) }+  where+    tc_boot_sig (TypeSig _ lnames hs_ty) = mapM f lnames+      where+        f (dL->L _ name)+          = do { sigma_ty <- tcHsSigWcType (FunSigCtxt name False) hs_ty+               ; return (mkVanillaGlobal name sigma_ty) }+        -- Notice that we make GlobalIds, not LocalIds+    tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s)++badBootDeclErr :: MsgDoc+badBootDeclErr = text "Illegal declarations in an hs-boot file"++------------------------+tcLocalBinds :: HsLocalBinds GhcRn -> TcM thing+             -> TcM (HsLocalBinds GhcTcId, thing)++tcLocalBinds (EmptyLocalBinds x) thing_inside+  = do  { thing <- thing_inside+        ; return (EmptyLocalBinds x, thing) }++tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside+  = do  { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside+        ; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) }+tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds"++tcLocalBinds (HsIPBinds x (IPBinds _ ip_binds)) thing_inside+  = do  { ipClass <- tcLookupClass ipClassName+        ; (given_ips, ip_binds') <-+            mapAndUnzipM (wrapLocSndM (tc_ip_bind ipClass)) ip_binds++        -- If the binding binds ?x = E, we  must now+        -- discharge any ?x constraints in expr_lie+        -- See Note [Implicit parameter untouchables]+        ; (ev_binds, result) <- checkConstraints (IPSkol ips)+                                  [] given_ips thing_inside++        ; return (HsIPBinds x (IPBinds ev_binds ip_binds') , result) }+  where+    ips = [ip | (dL->L _ (IPBind _ (Left (dL->L _ ip)) _)) <- ip_binds]++        -- I wonder if we should do these one at at time+        -- Consider     ?x = 4+        --              ?y = ?x + 1+    tc_ip_bind ipClass (IPBind _ (Left (dL->L _ ip)) expr)+       = do { ty <- newOpenFlexiTyVarTy+            ; let p = mkStrLitTy $ hsIPNameFS ip+            ; ip_id <- newDict ipClass [ p, ty ]+            ; expr' <- tcMonoExpr expr (mkCheckExpType ty)+            ; let d = toDict ipClass p ty `fmap` expr'+            ; return (ip_id, (IPBind noExt (Right ip_id) d)) }+    tc_ip_bind _ (IPBind _ (Right {}) _) = panic "tc_ip_bind"+    tc_ip_bind _ (XIPBind _) = panic "tc_ip_bind"++    -- Coerces a `t` into a dictionry for `IP "x" t`.+    -- co : t -> IP "x" t+    toDict ipClass x ty = mkHsWrap $ mkWpCastR $+                          wrapIP $ mkClassPred ipClass [x,ty]++tcLocalBinds (HsIPBinds _ (XHsIPBinds _ )) _ = panic "tcLocalBinds"+tcLocalBinds (XHsLocalBindsLR _)           _ = panic "tcLocalBinds"++{- Note [Implicit parameter untouchables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We add the type variables in the types of the implicit parameters+as untouchables, not so much because we really must not unify them,+but rather because we otherwise end up with constraints like this+    Num alpha, Implic { wanted = alpha ~ Int }+The constraint solver solves alpha~Int by unification, but then+doesn't float that solved constraint out (it's not an unsolved+wanted).  Result disaster: the (Num alpha) is again solved, this+time by defaulting.  No no no.++However [Oct 10] this is all handled automatically by the+untouchable-range idea.+-}++tcValBinds :: TopLevelFlag+           -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]+           -> TcM thing+           -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)++tcValBinds top_lvl binds sigs thing_inside+  = do  {   -- Typecheck the signatures+            -- It's easier to do so now, once for all the SCCs together+            -- because a single signature  f,g :: <type>+            -- might relate to more than one SCC+        ; (poly_ids, sig_fn) <- tcAddPatSynPlaceholders patsyns $+                                tcTySigs sigs++                -- Extend the envt right away with all the Ids+                -- declared with complete type signatures+                -- Do not extend the TcBinderStack; instead+                -- we extend it on a per-rhs basis in tcExtendForRhs+        ; tcExtendSigIds top_lvl poly_ids $ do+            { (binds', (extra_binds', thing)) <- tcBindGroups top_lvl sig_fn prag_fn binds $ do+                   { thing <- thing_inside+                     -- See Note [Pattern synonym builders don't yield dependencies]+                     --     in RnBinds+                   ; patsyn_builders <- mapM tcPatSynBuilderBind patsyns+                   ; let extra_binds = [ (NonRecursive, builder) | builder <- patsyn_builders ]+                   ; return (extra_binds, thing) }+            ; return (binds' ++ extra_binds', thing) }}+  where+    patsyns = getPatSynBinds binds+    prag_fn = mkPragEnv sigs (foldr (unionBags . snd) emptyBag binds)++------------------------+tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv+             -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing+             -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)+-- Typecheck a whole lot of value bindings,+-- one strongly-connected component at a time+-- Here a "strongly connected component" has the strightforward+-- meaning of a group of bindings that mention each other,+-- ignoring type signatures (that part comes later)++tcBindGroups _ _ _ [] thing_inside+  = do  { thing <- thing_inside+        ; return ([], thing) }++tcBindGroups top_lvl sig_fn prag_fn (group : groups) thing_inside+  = do  { -- See Note [Closed binder groups]+          type_env <- getLclTypeEnv+        ; let closed = isClosedBndrGroup type_env (snd group)+        ; (group', (groups', thing))+                <- tc_group top_lvl sig_fn prag_fn group closed $+                   tcBindGroups top_lvl sig_fn prag_fn groups thing_inside+        ; return (group' ++ groups', thing) }++-- Note [Closed binder groups]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+--  A mutually recursive group is "closed" if all of the free variables of+--  the bindings are closed. For example+--+-- >  h = \x -> let f = ...g...+-- >                g = ....f...x...+-- >             in ...+--+-- Here @g@ is not closed because it mentions @x@; and hence neither is @f@+-- closed.+--+-- So we need to compute closed-ness on each strongly connected components,+-- before we sub-divide it based on what type signatures it has.+--++------------------------+tc_group :: forall thing.+            TopLevelFlag -> TcSigFun -> TcPragEnv+         -> (RecFlag, LHsBinds GhcRn) -> IsGroupClosed -> TcM thing+         -> TcM ([(RecFlag, LHsBinds GhcTcId)], thing)++-- Typecheck one strongly-connected component of the original program.+-- We get a list of groups back, because there may+-- be specialisations etc as well++tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) closed thing_inside+        -- A single non-recursive binding+        -- We want to keep non-recursive things non-recursive+        -- so that we desugar unlifted bindings correctly+  = do { let bind = case bagToList binds of+                 [bind] -> bind+                 []     -> panic "tc_group: empty list of binds"+                 _      -> panic "tc_group: NonRecursive binds is not a singleton bag"+       ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind closed+                                     thing_inside+       ; return ( [(NonRecursive, bind')], thing) }++tc_group top_lvl sig_fn prag_fn (Recursive, binds) closed thing_inside+  =     -- To maximise polymorphism, we do a new+        -- strongly-connected-component analysis, this time omitting+        -- any references to variables with type signatures.+        -- (This used to be optional, but isn't now.)+        -- See Note [Polymorphic recursion] in HsBinds.+    do  { traceTc "tc_group rec" (pprLHsBinds binds)+        ; when hasPatSyn $ recursivePatSynErr binds+        ; (binds1, thing) <- go sccs+        ; return ([(Recursive, binds1)], thing) }+                -- Rec them all together+  where+    hasPatSyn = anyBag (isPatSyn . unLoc) binds+    isPatSyn PatSynBind{} = True+    isPatSyn _ = False++    sccs :: [SCC (LHsBind GhcRn)]+    sccs = stronglyConnCompFromEdgedVerticesUniq (mkEdges sig_fn binds)++    go :: [SCC (LHsBind GhcRn)] -> TcM (LHsBinds GhcTcId, thing)+    go (scc:sccs) = do  { (binds1, ids1) <- tc_scc scc+                        ; (binds2, thing) <- tcExtendLetEnv top_lvl sig_fn+                                                            closed ids1 $+                                             go sccs+                        ; return (binds1 `unionBags` binds2, thing) }+    go []         = do  { thing <- thing_inside; return (emptyBag, thing) }++    tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]+    tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds++    tc_sub_group rec_tc binds =+      tcPolyBinds sig_fn prag_fn Recursive rec_tc closed binds++recursivePatSynErr :: OutputableBndrId (GhcPass p) =>+                      LHsBinds (GhcPass p) -> TcM a+recursivePatSynErr binds+  = failWithTc $+    hang (text "Recursive pattern synonym definition with following bindings:")+       2 (vcat $ map pprLBind . bagToList $ binds)+  where+    pprLoc loc  = parens (text "defined at" <+> ppr loc)+    pprLBind (dL->L loc bind) = pprWithCommas ppr (collectHsBindBinders bind)+                                <+> pprLoc loc++tc_single :: forall thing.+            TopLevelFlag -> TcSigFun -> TcPragEnv+          -> LHsBind GhcRn -> IsGroupClosed -> TcM thing+          -> TcM (LHsBinds GhcTcId, thing)+tc_single _top_lvl sig_fn _prag_fn+          (dL->L _ (PatSynBind _ psb@PSB{ psb_id = (dL->L _ name) }))+          _ thing_inside+  = do { (aux_binds, tcg_env) <- tcPatSynDecl psb (sig_fn name)+       ; thing <- setGblEnv tcg_env thing_inside+       ; return (aux_binds, thing)+       }++tc_single top_lvl sig_fn prag_fn lbind closed thing_inside+  = do { (binds1, ids) <- tcPolyBinds sig_fn prag_fn+                                      NonRecursive NonRecursive+                                      closed+                                      [lbind]+       ; thing <- tcExtendLetEnv top_lvl sig_fn closed ids thing_inside+       ; return (binds1, thing) }++------------------------+type BKey = Int -- Just number off the bindings++mkEdges :: TcSigFun -> LHsBinds GhcRn -> [Node BKey (LHsBind GhcRn)]+-- See Note [Polymorphic recursion] in HsBinds.+mkEdges sig_fn binds+  = [ DigraphNode bind key [key | n <- nonDetEltsUniqSet (bind_fvs (unLoc bind)),+                         Just key <- [lookupNameEnv key_map n], no_sig n ]+    | (bind, key) <- keyd_binds+    ]+    -- It's OK to use nonDetEltsUFM here as stronglyConnCompFromEdgedVertices+    -- is still deterministic even if the edges are in nondeterministic order+    -- as explained in Note [Deterministic SCC] in Digraph.+  where+    bind_fvs (FunBind { fun_ext = fvs }) = fvs+    bind_fvs (PatBind { pat_ext = fvs }) = fvs+    bind_fvs _                           = emptyNameSet++    no_sig :: Name -> Bool+    no_sig n = not (hasCompleteSig sig_fn n)++    keyd_binds = bagToList binds `zip` [0::BKey ..]++    key_map :: NameEnv BKey     -- Which binding it comes from+    key_map = mkNameEnv [(bndr, key) | (dL->L _ bind, key) <- keyd_binds+                                     , bndr <- collectHsBindBinders bind ]++------------------------+tcPolyBinds :: TcSigFun -> TcPragEnv+            -> RecFlag         -- Whether the group is really recursive+            -> RecFlag         -- Whether it's recursive after breaking+                               -- dependencies based on type signatures+            -> IsGroupClosed   -- Whether the group is closed+            -> [LHsBind GhcRn]  -- None are PatSynBind+            -> TcM (LHsBinds GhcTcId, [TcId])++-- Typechecks a single bunch of values bindings all together,+-- and generalises them.  The bunch may be only part of a recursive+-- group, because we use type signatures to maximise polymorphism+--+-- Returns a list because the input may be a single non-recursive binding,+-- in which case the dependency order of the resulting bindings is+-- important.+--+-- Knows nothing about the scope of the bindings+-- None of the bindings are pattern synonyms++tcPolyBinds sig_fn prag_fn rec_group rec_tc closed bind_list+  = setSrcSpan loc                              $+    recoverM (recoveryCode binder_names sig_fn) $ do+        -- Set up main recover; take advantage of any type sigs++    { traceTc "------------------------------------------------" Outputable.empty+    ; traceTc "Bindings for {" (ppr binder_names)+    ; dflags   <- getDynFlags+    ; let plan = decideGeneralisationPlan dflags bind_list closed sig_fn+    ; traceTc "Generalisation plan" (ppr plan)+    ; result@(_, poly_ids) <- case plan of+         NoGen              -> tcPolyNoGen rec_tc prag_fn sig_fn bind_list+         InferGen mn        -> tcPolyInfer rec_tc prag_fn sig_fn mn bind_list+         CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind++    ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group+                                            , vcat [ppr id <+> ppr (idType id) | id <- poly_ids]+                                          ])++    ; return result }+  where+    binder_names = collectHsBindListBinders bind_list+    loc = foldr1 combineSrcSpans (map getLoc bind_list)+         -- The mbinds have been dependency analysed and+         -- may no longer be adjacent; so find the narrowest+         -- span that includes them all++--------------+-- If typechecking the binds fails, then return with each+-- signature-less binder given type (forall a.a), to minimise+-- subsequent error messages+recoveryCode :: [Name] -> TcSigFun -> TcM (LHsBinds GhcTcId, [Id])+recoveryCode binder_names sig_fn+  = do  { traceTc "tcBindsWithSigs: error recovery" (ppr binder_names)+        ; let poly_ids = map mk_dummy binder_names+        ; return (emptyBag, poly_ids) }+  where+    mk_dummy name+      | Just sig <- sig_fn name+      , Just poly_id <- completeSigPolyId_maybe sig+      = poly_id+      | otherwise+      = mkLocalId name forall_a_a++forall_a_a :: TcType+-- At one point I had (forall r (a :: TYPE r). a), but of course+-- that type is ill-formed: its mentions 'r' which escapes r's scope.+-- Another alternative would be (forall (a :: TYPE kappa). a), where+-- kappa is a unification variable. But I don't think we need that+-- complication here. I'm going to just use (forall (a::*). a).+-- See #15276+forall_a_a = mkSpecForAllTys [alphaTyVar] alphaTy++{- *********************************************************************+*                                                                      *+                         tcPolyNoGen+*                                                                      *+********************************************************************* -}++tcPolyNoGen     -- No generalisation whatsoever+  :: RecFlag       -- Whether it's recursive after breaking+                   -- dependencies based on type signatures+  -> TcPragEnv -> TcSigFun+  -> [LHsBind GhcRn]+  -> TcM (LHsBinds GhcTcId, [TcId])++tcPolyNoGen rec_tc prag_fn tc_sig_fn bind_list+  = do { (binds', mono_infos) <- tcMonoBinds rec_tc tc_sig_fn+                                             (LetGblBndr prag_fn)+                                             bind_list+       ; mono_ids' <- mapM tc_mono_info mono_infos+       ; return (binds', mono_ids') }+  where+    tc_mono_info (MBI { mbi_poly_name = name, mbi_mono_id = mono_id })+      = do { _specs <- tcSpecPrags mono_id (lookupPragEnv prag_fn name)+           ; return mono_id }+           -- NB: tcPrags generates error messages for+           --     specialisation pragmas for non-overloaded sigs+           -- Indeed that is why we call it here!+           -- So we can safely ignore _specs+++{- *********************************************************************+*                                                                      *+                         tcPolyCheck+*                                                                      *+********************************************************************* -}++tcPolyCheck :: TcPragEnv+            -> TcIdSigInfo     -- Must be a complete signature+            -> LHsBind GhcRn   -- Must be a FunBind+            -> TcM (LHsBinds GhcTcId, [TcId])+-- There is just one binding,+--   it is a Funbind+--   it has a complete type signature,+tcPolyCheck prag_fn+            (CompleteSig { sig_bndr  = poly_id+                         , sig_ctxt  = ctxt+                         , sig_loc   = sig_loc })+            (dL->L loc (FunBind { fun_id = (dL->L nm_loc name)+                                , fun_matches = matches }))+  = setSrcSpan sig_loc $+    do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)+       ; (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id+                -- See Note [Instantiate sig with fresh variables]++       ; mono_name <- newNameAt (nameOccName name) nm_loc+       ; ev_vars   <- newEvVars theta+       ; let mono_id   = mkLocalId mono_name tau+             skol_info = SigSkol ctxt (idType poly_id) tv_prs+             skol_tvs  = map snd tv_prs++       ; (ev_binds, (co_fn, matches'))+            <- checkConstraints skol_info skol_tvs ev_vars $+               tcExtendBinderStack [TcIdBndr mono_id NotTopLevel]  $+               tcExtendNameTyVarEnv tv_prs $+               setSrcSpan loc           $+               tcMatchesFun (cL nm_loc mono_name) matches (mkCheckExpType tau)++       ; let prag_sigs = lookupPragEnv prag_fn name+       ; spec_prags <- tcSpecPrags poly_id prag_sigs+       ; poly_id    <- addInlinePrags poly_id prag_sigs++       ; mod <- getModule+       ; tick <- funBindTicks nm_loc mono_id mod prag_sigs+       ; let bind' = FunBind { fun_id      = cL nm_loc mono_id+                             , fun_matches = matches'+                             , fun_co_fn   = co_fn+                             , fun_ext     = placeHolderNamesTc+                             , fun_tick    = tick }++             export = ABE { abe_ext = noExt+                          , abe_wrap = idHsWrapper+                          , abe_poly  = poly_id+                          , abe_mono  = mono_id+                          , abe_prags = SpecPrags spec_prags }++             abs_bind = cL loc $+                        AbsBinds { abs_ext = noExt+                                 , abs_tvs      = skol_tvs+                                 , abs_ev_vars  = ev_vars+                                 , abs_ev_binds = [ev_binds]+                                 , abs_exports  = [export]+                                 , abs_binds    = unitBag (cL loc bind')+                                 , abs_sig      = True }++       ; return (unitBag abs_bind, [poly_id]) }++tcPolyCheck _prag_fn sig bind+  = pprPanic "tcPolyCheck" (ppr sig $$ ppr bind)++funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn]+             -> TcM [Tickish TcId]+funBindTicks loc fun_id mod sigs+  | (mb_cc_str : _) <- [ cc_name | (dL->L _ (SCCFunSig _ _ _ cc_name)) <- sigs ]+      -- this can only be a singleton list, as duplicate pragmas are rejected+      -- by the renamer+  , let cc_str+          | Just cc_str <- mb_cc_str+          = sl_fs $ unLoc cc_str+          | otherwise+          = getOccFS (Var.varName fun_id)+        cc_name = moduleNameFS (moduleName mod) `appendFS` consFS '.' cc_str+  = do+      flavour <- DeclCC <$> getCCIndexM cc_name+      let cc = mkUserCC cc_name mod loc flavour+      return [ProfNote cc True True]+  | otherwise+  = return []++{- Note [Instantiate sig with fresh variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's vital to instantiate a type signature with fresh variables.+For example:+      type T = forall a. [a] -> [a]+      f :: T;+      f = g where { g :: T; g = <rhs> }++ We must not use the same 'a' from the defn of T at both places!!+(Instantiation is only necessary because of type synonyms.  Otherwise,+it's all cool; each signature has distinct type variables from the renamer.)+-}+++{- *********************************************************************+*                                                                      *+                         tcPolyInfer+*                                                                      *+********************************************************************* -}++tcPolyInfer+  :: RecFlag       -- Whether it's recursive after breaking+                   -- dependencies based on type signatures+  -> TcPragEnv -> TcSigFun+  -> Bool         -- True <=> apply the monomorphism restriction+  -> [LHsBind GhcRn]+  -> TcM (LHsBinds GhcTcId, [TcId])+tcPolyInfer rec_tc prag_fn tc_sig_fn mono bind_list+  = do { (tclvl, wanted, (binds', mono_infos))+             <- pushLevelAndCaptureConstraints  $+                tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list++       ; let name_taus  = [ (mbi_poly_name info, idType (mbi_mono_id info))+                          | info <- mono_infos ]+             sigs       = [ sig | MBI { mbi_sig = Just sig } <- mono_infos ]+             infer_mode = if mono then ApplyMR else NoRestrictions++       ; mapM_ (checkOverloadedSig mono) sigs++       ; traceTc "simplifyInfer call" (ppr tclvl $$ ppr name_taus $$ ppr wanted)+       ; (qtvs, givens, ev_binds, residual, insoluble)+                 <- simplifyInfer tclvl infer_mode sigs name_taus wanted+       ; emitConstraints residual++       ; let inferred_theta = map evVarPred givens+       ; exports <- checkNoErrs $+                    mapM (mkExport prag_fn insoluble qtvs inferred_theta) mono_infos++       ; loc <- getSrcSpanM+       ; let poly_ids = map abe_poly exports+             abs_bind = cL loc $+                        AbsBinds { abs_ext = noExt+                                 , abs_tvs = qtvs+                                 , abs_ev_vars = givens, abs_ev_binds = [ev_binds]+                                 , abs_exports = exports, abs_binds = binds'+                                 , abs_sig = False }++       ; traceTc "Binding:" (ppr (poly_ids `zip` map idType poly_ids))+       ; return (unitBag abs_bind, poly_ids) }+         -- poly_ids are guaranteed zonked by mkExport++--------------+mkExport :: TcPragEnv+         -> Bool                        -- True <=> there was an insoluble type error+                                        --          when typechecking the bindings+         -> [TyVar] -> TcThetaType      -- Both already zonked+         -> MonoBindInfo+         -> TcM (ABExport GhcTc)+-- Only called for generalisation plan InferGen, not by CheckGen or NoGen+--+-- mkExport generates exports with+--      zonked type variables,+--      zonked poly_ids+-- The former is just because no further unifications will change+-- the quantified type variables, so we can fix their final form+-- right now.+-- The latter is needed because the poly_ids are used to extend the+-- type environment; see the invariant on TcEnv.tcExtendIdEnv++-- Pre-condition: the qtvs and theta are already zonked++mkExport prag_fn insoluble qtvs theta+         mono_info@(MBI { mbi_poly_name = poly_name+                        , mbi_sig       = mb_sig+                        , mbi_mono_id   = mono_id })+  = do  { mono_ty <- zonkTcType (idType mono_id)+        ; poly_id <- mkInferredPolyId insoluble qtvs theta poly_name mb_sig mono_ty++        -- NB: poly_id has a zonked type+        ; poly_id <- addInlinePrags poly_id prag_sigs+        ; spec_prags <- tcSpecPrags poly_id prag_sigs+                -- tcPrags requires a zonked poly_id++        -- See Note [Impedance matching]+        -- NB: we have already done checkValidType, including an ambiguity check,+        --     on the type; either when we checked the sig or in mkInferredPolyId+        ; let poly_ty     = idType poly_id+              sel_poly_ty = mkInfSigmaTy qtvs theta mono_ty+                -- This type is just going into tcSubType,+                -- so Inferred vs. Specified doesn't matter++        ; wrap <- if sel_poly_ty `eqType` poly_ty  -- NB: eqType ignores visibility+                  then return idHsWrapper  -- Fast path; also avoids complaint when we infer+                                           -- an ambiguous type and have AllowAmbiguousType+                                           -- e..g infer  x :: forall a. F a -> Int+                  else addErrCtxtM (mk_impedance_match_msg mono_info sel_poly_ty poly_ty) $+                       tcSubType_NC sig_ctxt sel_poly_ty poly_ty++        ; warn_missing_sigs <- woptM Opt_WarnMissingLocalSignatures+        ; when warn_missing_sigs $+              localSigWarn Opt_WarnMissingLocalSignatures poly_id mb_sig++        ; return (ABE { abe_ext = noExt+                      , abe_wrap = wrap+                        -- abe_wrap :: idType poly_id ~ (forall qtvs. theta => mono_ty)+                      , abe_poly  = poly_id+                      , abe_mono  = mono_id+                      , abe_prags = SpecPrags spec_prags }) }+  where+    prag_sigs = lookupPragEnv prag_fn poly_name+    sig_ctxt  = InfSigCtxt poly_name++mkInferredPolyId :: Bool  -- True <=> there was an insoluble error when+                          --          checking the binding group for this Id+                 -> [TyVar] -> TcThetaType+                 -> Name -> Maybe TcIdSigInst -> TcType+                 -> TcM TcId+mkInferredPolyId insoluble qtvs inferred_theta poly_name mb_sig_inst mono_ty+  | Just (TISI { sig_inst_sig = sig })  <- mb_sig_inst+  , CompleteSig { sig_bndr = poly_id } <- sig+  = return poly_id++  | otherwise  -- Either no type sig or partial type sig+  = checkNoErrs $  -- The checkNoErrs ensures that if the type is ambiguous+                   -- we don't carry on to the impedance matching, and generate+                   -- a duplicate ambiguity error.  There is a similar+                   -- checkNoErrs for complete type signatures too.+    do { fam_envs <- tcGetFamInstEnvs+       ; let (_co, mono_ty') = normaliseType fam_envs Nominal mono_ty+               -- Unification may not have normalised the type,+               -- (see Note [Lazy flattening] in TcFlatten) so do it+               -- here to make it as uncomplicated as possible.+               -- Example: f :: [F Int] -> Bool+               -- should be rewritten to f :: [Char] -> Bool, if possible+               --+               -- We can discard the coercion _co, because we'll reconstruct+               -- it in the call to tcSubType below++       ; (binders, theta') <- chooseInferredQuantifiers inferred_theta+                                (tyCoVarsOfType mono_ty') qtvs mb_sig_inst++       ; let inferred_poly_ty = mkForAllTys binders (mkPhiTy theta' mono_ty')++       ; traceTc "mkInferredPolyId" (vcat [ppr poly_name, ppr qtvs, ppr theta'+                                          , ppr inferred_poly_ty])+       ; unless insoluble $+         addErrCtxtM (mk_inf_msg poly_name inferred_poly_ty) $+         checkValidType (InfSigCtxt poly_name) inferred_poly_ty+         -- See Note [Validity of inferred types]+         -- If we found an insoluble error in the function definition, don't+         -- do this check; otherwise (#14000) we may report an ambiguity+         -- error for a rather bogus type.++       ; return (mkLocalIdOrCoVar poly_name inferred_poly_ty) }+++chooseInferredQuantifiers :: TcThetaType   -- inferred+                          -> TcTyVarSet    -- tvs free in tau type+                          -> [TcTyVar]     -- inferred quantified tvs+                          -> Maybe TcIdSigInst+                          -> TcM ([TyVarBinder], TcThetaType)+chooseInferredQuantifiers inferred_theta tau_tvs qtvs Nothing+  = -- No type signature (partial or complete) for this binder,+    do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta tau_tvs)+                        -- Include kind variables!  #7916+             my_theta = pickCapturedPreds free_tvs inferred_theta+             binders  = [ mkTyVarBinder Inferred tv+                        | tv <- qtvs+                        , tv `elemVarSet` free_tvs ]+       ; return (binders, my_theta) }++chooseInferredQuantifiers inferred_theta tau_tvs qtvs+                          (Just (TISI { sig_inst_sig   = sig  -- Always PartialSig+                                      , sig_inst_wcx   = wcx+                                      , sig_inst_theta = annotated_theta+                                      , sig_inst_skols = annotated_tvs }))+  = -- Choose quantifiers for a partial type signature+    do { psig_qtv_prs <- zonkTyVarTyVarPairs annotated_tvs++            -- Check whether the quantified variables of the+            -- partial signature have been unified together+            -- See Note [Quantified variables in partial type signatures]+       ; mapM_ report_dup_tyvar_tv_err  (findDupTyVarTvs psig_qtv_prs)++            -- Check whether a quantified variable of the partial type+            -- signature is not actually quantified.  How can that happen?+            -- See Note [Quantification and partial signatures] Wrinkle 4+            --     in TcSimplify+       ; mapM_ report_mono_sig_tv_err [ n | (n,tv) <- psig_qtv_prs+                                          , not (tv `elem` qtvs) ]++       ; let psig_qtvs = mkVarSet (map snd psig_qtv_prs)++       ; annotated_theta      <- zonkTcTypes annotated_theta+       ; (free_tvs, my_theta) <- choose_psig_context psig_qtvs annotated_theta wcx++       ; let keep_me    = free_tvs `unionVarSet` psig_qtvs+             final_qtvs = [ mkTyVarBinder vis tv+                          | tv <- qtvs -- Pulling from qtvs maintains original order+                          , tv `elemVarSet` keep_me+                          , let vis | tv `elemVarSet` psig_qtvs = Specified+                                    | otherwise                 = Inferred ]++       ; return (final_qtvs, my_theta) }+  where+    report_dup_tyvar_tv_err (n1,n2)+      | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig+      = addErrTc (hang (text "Couldn't match" <+> quotes (ppr n1)+                        <+> text "with" <+> quotes (ppr n2))+                     2 (hang (text "both bound by the partial type signature:")+                           2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))++      | otherwise -- Can't happen; by now we know it's a partial sig+      = pprPanic "report_tyvar_tv_err" (ppr sig)++    report_mono_sig_tv_err n+      | PartialSig { psig_name = fn_name, psig_hs_ty = hs_ty } <- sig+      = addErrTc (hang (text "Can't quantify over" <+> quotes (ppr n))+                     2 (hang (text "bound by the partial type signature:")+                           2 (ppr fn_name <+> dcolon <+> ppr hs_ty)))+      | otherwise -- Can't happen; by now we know it's a partial sig+      = pprPanic "report_mono_sig_tv_err" (ppr sig)++    choose_psig_context :: VarSet -> TcThetaType -> Maybe TcType+                        -> TcM (VarSet, TcThetaType)+    choose_psig_context _ annotated_theta Nothing+      = do { let free_tvs = closeOverKinds (tyCoVarsOfTypes annotated_theta+                                            `unionVarSet` tau_tvs)+           ; return (free_tvs, annotated_theta) }++    choose_psig_context psig_qtvs annotated_theta (Just wc_var_ty)+      = do { let free_tvs = closeOverKinds (growThetaTyVars inferred_theta seed_tvs)+                            -- growThetaVars just like the no-type-sig case+                            -- Omitting this caused #12844+                 seed_tvs = tyCoVarsOfTypes annotated_theta  -- These are put there+                            `unionVarSet` tau_tvs            --       by the user++           ; let keep_me  = psig_qtvs `unionVarSet` free_tvs+                 my_theta = pickCapturedPreds keep_me inferred_theta++           -- Fill in the extra-constraints wildcard hole with inferred_theta,+           -- so that the Hole constraint we have already emitted+           -- (in tcHsPartialSigType) can report what filled it in.+           -- NB: my_theta already includes all the annotated constraints+           ; let inferred_diff = [ pred+                                 | pred <- my_theta+                                 , all (not . (`eqType` pred)) annotated_theta ]+           ; ctuple <- mk_ctuple inferred_diff++           ; case tcGetCastedTyVar_maybe wc_var_ty of+               -- We know that wc_co must have type kind(wc_var) ~ Constraint, as it+               -- comes from the checkExpectedKind in TcHsType.tcWildCardOcc. So, to+               -- make the kinds work out, we reverse the cast here.+               Just (wc_var, wc_co) -> writeMetaTyVar wc_var (ctuple `mkCastTy` mkTcSymCo wc_co)+               Nothing              -> pprPanic "chooseInferredQuantifiers 1" (ppr wc_var_ty)++           ; traceTc "completeTheta" $+                vcat [ ppr sig+                     , ppr annotated_theta, ppr inferred_theta+                     , ppr inferred_diff ]+           ; return (free_tvs, my_theta) }++    mk_ctuple preds = return (mkBoxedTupleTy preds)+       -- Hack alert!  See TcHsType:+       -- Note [Extra-constraint holes in partial type signatures]+++mk_impedance_match_msg :: MonoBindInfo+                       -> TcType -> TcType+                       -> TidyEnv -> TcM (TidyEnv, SDoc)+-- This is a rare but rather awkward error messages+mk_impedance_match_msg (MBI { mbi_poly_name = name, mbi_sig = mb_sig })+                       inf_ty sig_ty tidy_env+ = do { (tidy_env1, inf_ty) <- zonkTidyTcType tidy_env  inf_ty+      ; (tidy_env2, sig_ty) <- zonkTidyTcType tidy_env1 sig_ty+      ; let msg = vcat [ text "When checking that the inferred type"+                       , nest 2 $ ppr name <+> dcolon <+> ppr inf_ty+                       , text "is as general as its" <+> what <+> text "signature"+                       , nest 2 $ ppr name <+> dcolon <+> ppr sig_ty ]+      ; return (tidy_env2, msg) }+  where+    what = case mb_sig of+             Nothing                     -> text "inferred"+             Just sig | isPartialSig sig -> text "(partial)"+                      | otherwise        -> empty+++mk_inf_msg :: Name -> TcType -> TidyEnv -> TcM (TidyEnv, SDoc)+mk_inf_msg poly_name poly_ty tidy_env+ = do { (tidy_env1, poly_ty) <- zonkTidyTcType tidy_env poly_ty+      ; let msg = vcat [ text "When checking the inferred type"+                       , nest 2 $ ppr poly_name <+> dcolon <+> ppr poly_ty ]+      ; return (tidy_env1, msg) }+++-- | Warn the user about polymorphic local binders that lack type signatures.+localSigWarn :: WarningFlag -> Id -> Maybe TcIdSigInst -> TcM ()+localSigWarn flag id mb_sig+  | Just _ <- mb_sig               = return ()+  | not (isSigmaTy (idType id))    = return ()+  | otherwise                      = warnMissingSignatures flag msg id+  where+    msg = text "Polymorphic local binding with no type signature:"++warnMissingSignatures :: WarningFlag -> SDoc -> Id -> TcM ()+warnMissingSignatures flag msg id+  = do  { env0 <- tcInitTidyEnv+        ; let (env1, tidy_ty) = tidyOpenType env0 (idType id)+        ; addWarnTcM (Reason flag) (env1, mk_msg tidy_ty) }+  where+    mk_msg ty = sep [ msg, nest 2 $ pprPrefixName (idName id) <+> dcolon <+> ppr ty ]++checkOverloadedSig :: Bool -> TcIdSigInst -> TcM ()+-- Example:+--   f :: Eq a => a -> a+--   K f = e+-- The MR applies, but the signature is overloaded, and it's+-- best to complain about this directly+-- c.f #11339+checkOverloadedSig monomorphism_restriction_applies sig+  | not (null (sig_inst_theta sig))+  , monomorphism_restriction_applies+  , let orig_sig = sig_inst_sig sig+  = setSrcSpan (sig_loc orig_sig) $+    failWith $+    hang (text "Overloaded signature conflicts with monomorphism restriction")+       2 (ppr orig_sig)+  | otherwise+  = return ()++{- Note [Partial type signatures and generalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If /any/ of the signatures in the gropu is a partial type signature+   f :: _ -> Int+then we *always* use the InferGen plan, and hence tcPolyInfer.+We do this even for a local binding with -XMonoLocalBinds, when+we normally use NoGen.++Reasons:+  * The TcSigInfo for 'f' has a unification variable for the '_',+    whose TcLevel is one level deeper than the current level.+    (See pushTcLevelM in tcTySig.)  But NoGen doesn't increase+    the TcLevel like InferGen, so we lose the level invariant.++  * The signature might be   f :: forall a. _ -> a+    so it really is polymorphic.  It's not clear what it would+    mean to use NoGen on this, and indeed the ASSERT in tcLhs,+    in the (Just sig) case, checks that if there is a signature+    then we are using LetLclBndr, and hence a nested AbsBinds with+    increased TcLevel++It might be possible to fix these difficulties somehow, but there+doesn't seem much point.  Indeed, adding a partial type signature is a+way to get per-binding inferred generalisation.++We apply the MR if /all/ of the partial signatures lack a context.+In particular (#11016):+   f2 :: (?loc :: Int) => _+   f2 = ?loc+It's stupid to apply the MR here.  This test includes an extra-constraints+wildcard; that is, we don't apply the MR if you write+   f3 :: _ => blah++Note [Quantified variables in partial type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f :: forall a. a -> a -> _+  f x y = g x y+  g :: forall b. b -> b -> _+  g x y = [x, y]++Here, 'f' and 'g' are mutually recursive, and we end up unifying 'a' and 'b'+together, which is fine.  So we bind 'a' and 'b' to TyVarTvs, which can then+unify with each other.++But now consider:+  f :: forall a b. a -> b -> _+  f x y = [x, y]++We want to get an error from this, because 'a' and 'b' get unified.+So we make a test, one per parital signature, to check that the+explicitly-quantified type variables have not been unified together.+#14449 showed this up.+++Note [Validity of inferred types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to check inferred type for validity, in case it uses language+extensions that are not turned on.  The principle is that if the user+simply adds the inferred type to the program source, it'll compile fine.+See #8883.++Examples that might fail:+ - the type might be ambiguous++ - an inferred theta that requires type equalities e.g. (F a ~ G b)+                                or multi-parameter type classes+ - an inferred type that includes unboxed tuples+++Note [Impedance matching]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f 0 x = x+   f n x = g [] (not x)++   g [] y = f 10 y+   g _  y = f 9  y++After typechecking we'll get+  f_mono_ty :: a -> Bool -> Bool+  g_mono_ty :: [b] -> Bool -> Bool+with constraints+  (Eq a, Num a)++Note that f is polymorphic in 'a' and g in 'b'; and these are not linked.+The types we really want for f and g are+   f :: forall a. (Eq a, Num a) => a -> Bool -> Bool+   g :: forall b. [b] -> Bool -> Bool++We can get these by "impedance matching":+   tuple :: forall a b. (Eq a, Num a) => (a -> Bool -> Bool, [b] -> Bool -> Bool)+   tuple a b d1 d1 = let ...bind f_mono, g_mono in (f_mono, g_mono)++   f a d1 d2 = case tuple a Any d1 d2 of (f, g) -> f+   g b = case tuple Integer b dEqInteger dNumInteger of (f,g) -> g++Suppose the shared quantified tyvars are qtvs and constraints theta.+Then we want to check that+     forall qtvs. theta => f_mono_ty   is more polymorphic than   f's polytype+and the proof is the impedance matcher.++Notice that the impedance matcher may do defaulting.  See #7173.++It also cleverly does an ambiguity check; for example, rejecting+   f :: F a -> F a+where F is a non-injective type function.+-}+++{-+Note [SPECIALISE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~+There is no point in a SPECIALISE pragma for a non-overloaded function:+   reverse :: [a] -> [a]+   {-# SPECIALISE reverse :: [Int] -> [Int] #-}++But SPECIALISE INLINE *can* make sense for GADTS:+   data Arr e where+     ArrInt :: !Int -> ByteArray# -> Arr Int+     ArrPair :: !Int -> Arr e1 -> Arr e2 -> Arr (e1, e2)++   (!:) :: Arr e -> Int -> e+   {-# SPECIALISE INLINE (!:) :: Arr Int -> Int -> Int #-}+   {-# SPECIALISE INLINE (!:) :: Arr (a, b) -> Int -> (a, b) #-}+   (ArrInt _ ba)     !: (I# i) = I# (indexIntArray# ba i)+   (ArrPair _ a1 a2) !: i      = (a1 !: i, a2 !: i)++When (!:) is specialised it becomes non-recursive, and can usefully+be inlined.  Scary!  So we only warn for SPECIALISE *without* INLINE+for a non-overloaded function.++************************************************************************+*                                                                      *+                         tcMonoBinds+*                                                                      *+************************************************************************++@tcMonoBinds@ deals with a perhaps-recursive group of HsBinds.+The signatures have been dealt with already.+-}++data MonoBindInfo = MBI { mbi_poly_name :: Name+                        , mbi_sig       :: Maybe TcIdSigInst+                        , mbi_mono_id   :: TcId }++tcMonoBinds :: RecFlag  -- Whether the binding is recursive for typechecking purposes+                        -- i.e. the binders are mentioned in their RHSs, and+                        --      we are not rescued by a type signature+            -> TcSigFun -> LetBndrSpec+            -> [LHsBind GhcRn]+            -> TcM (LHsBinds GhcTcId, [MonoBindInfo])+tcMonoBinds is_rec sig_fn no_gen+           [ dL->L b_loc (FunBind { fun_id = (dL->L nm_loc name)+                                  , fun_matches = matches+                                  , fun_ext = fvs })]+                             -- Single function binding,+  | NonRecursive <- is_rec   -- ...binder isn't mentioned in RHS+  , Nothing <- sig_fn name   -- ...with no type signature+  =     -- Note [Single function non-recursive binding special-case]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        -- In this very special case we infer the type of the+        -- right hand side first (it may have a higher-rank type)+        -- and *then* make the monomorphic Id for the LHS+        -- e.g.         f = \(x::forall a. a->a) -> <body>+        --      We want to infer a higher-rank type for f+    setSrcSpan b_loc    $+    do  { ((co_fn, matches'), rhs_ty)+            <- tcInferInst $ \ exp_ty ->+                  -- tcInferInst: see TcUnify,+                  -- Note [Deep instantiation of InferResult] in TcUnify+               tcExtendBinderStack [TcIdBndr_ExpType name exp_ty NotTopLevel] $+                  -- We extend the error context even for a non-recursive+                  -- function so that in type error messages we show the+                  -- type of the thing whose rhs we are type checking+               tcMatchesFun (cL nm_loc name) matches exp_ty++        ; mono_id <- newLetBndr no_gen name rhs_ty+        ; return (unitBag $ cL b_loc $+                     FunBind { fun_id = cL nm_loc mono_id,+                               fun_matches = matches', fun_ext = fvs,+                               fun_co_fn = co_fn, fun_tick = [] },+                  [MBI { mbi_poly_name = name+                       , mbi_sig       = Nothing+                       , mbi_mono_id   = mono_id }]) }++tcMonoBinds _ sig_fn no_gen binds+  = do  { tc_binds <- mapM (wrapLocM (tcLhs sig_fn no_gen)) binds++        -- Bring the monomorphic Ids, into scope for the RHSs+        ; let mono_infos = getMonoBindInfo tc_binds+              rhs_id_env = [ (name, mono_id)+                           | MBI { mbi_poly_name = name+                                 , mbi_sig       = mb_sig+                                 , mbi_mono_id   = mono_id } <- mono_infos+                           , case mb_sig of+                               Just sig -> isPartialSig sig+                               Nothing  -> True ]+                -- A monomorphic binding for each term variable that lacks+                -- a complete type sig.  (Ones with a sig are already in scope.)++        ; traceTc "tcMonoBinds" $ vcat [ ppr n <+> ppr id <+> ppr (idType id)+                                       | (n,id) <- rhs_id_env]+        ; binds' <- tcExtendRecIds rhs_id_env $+                    mapM (wrapLocM tcRhs) tc_binds++        ; return (listToBag binds', mono_infos) }+++------------------------+-- tcLhs typechecks the LHS of the bindings, to construct the environment in which+-- we typecheck the RHSs.  Basically what we are doing is this: for each binder:+--      if there's a signature for it, use the instantiated signature type+--      otherwise invent a type variable+-- You see that quite directly in the FunBind case.+--+-- But there's a complication for pattern bindings:+--      data T = MkT (forall a. a->a)+--      MkT f = e+-- Here we can guess a type variable for the entire LHS (which will be refined to T)+-- but we want to get (f::forall a. a->a) as the RHS environment.+-- The simplest way to do this is to typecheck the pattern, and then look up the+-- bound mono-ids.  Then we want to retain the typechecked pattern to avoid re-doing+-- it; hence the TcMonoBind data type in which the LHS is done but the RHS isn't++data TcMonoBind         -- Half completed; LHS done, RHS not done+  = TcFunBind  MonoBindInfo  SrcSpan (MatchGroup GhcRn (LHsExpr GhcRn))+  | TcPatBind [MonoBindInfo] (LPat GhcTcId) (GRHSs GhcRn (LHsExpr GhcRn))+              TcSigmaType++tcLhs :: TcSigFun -> LetBndrSpec -> HsBind GhcRn -> TcM TcMonoBind+-- Only called with plan InferGen (LetBndrSpec = LetLclBndr)+--                    or NoGen    (LetBndrSpec = LetGblBndr)+-- CheckGen is used only for functions with a complete type signature,+--          and tcPolyCheck doesn't use tcMonoBinds at all++tcLhs sig_fn no_gen (FunBind { fun_id = (dL->L nm_loc name)+                             , fun_matches = matches })+  | Just (TcIdSig sig) <- sig_fn name+  = -- There is a type signature.+    -- It must be partial; if complete we'd be in tcPolyCheck!+    --    e.g.   f :: _ -> _+    --           f x = ...g...+    --           Just g = ...f...+    -- Hence always typechecked with InferGen+    do { mono_info <- tcLhsSigId no_gen (name, sig)+       ; return (TcFunBind mono_info nm_loc matches) }++  | otherwise  -- No type signature+  = do { mono_ty <- newOpenFlexiTyVarTy+       ; mono_id <- newLetBndr no_gen name mono_ty+       ; let mono_info = MBI { mbi_poly_name = name+                             , mbi_sig       = Nothing+                             , mbi_mono_id   = mono_id }+       ; return (TcFunBind mono_info nm_loc matches) }++tcLhs sig_fn no_gen (PatBind { pat_lhs = pat, pat_rhs = grhss })+  = -- See Note [Typechecking pattern bindings]+    do  { sig_mbis <- mapM (tcLhsSigId no_gen) sig_names++        ; let inst_sig_fun = lookupNameEnv $ mkNameEnv $+                             [ (mbi_poly_name mbi, mbi_mono_id mbi)+                             | mbi <- sig_mbis ]++            -- See Note [Existentials in pattern bindings]+        ; ((pat', nosig_mbis), pat_ty)+            <- addErrCtxt (patMonoBindsCtxt pat grhss) $+               tcInferNoInst $ \ exp_ty ->+               tcLetPat inst_sig_fun no_gen pat exp_ty $+               mapM lookup_info nosig_names++        ; let mbis = sig_mbis ++ nosig_mbis++        ; traceTc "tcLhs" (vcat [ ppr id <+> dcolon <+> ppr (idType id)+                                | mbi <- mbis, let id = mbi_mono_id mbi ]+                           $$ ppr no_gen)++        ; return (TcPatBind mbis pat' grhss pat_ty) }+  where+    bndr_names = collectPatBinders pat+    (nosig_names, sig_names) = partitionWith find_sig bndr_names++    find_sig :: Name -> Either Name (Name, TcIdSigInfo)+    find_sig name = case sig_fn name of+                      Just (TcIdSig sig) -> Right (name, sig)+                      _                  -> Left name++      -- After typechecking the pattern, look up the binder+      -- names that lack a signature, which the pattern has brought+      -- into scope.+    lookup_info :: Name -> TcM MonoBindInfo+    lookup_info name+      = do { mono_id <- tcLookupId name+           ; return (MBI { mbi_poly_name = name+                         , mbi_sig       = Nothing+                         , mbi_mono_id   = mono_id }) }++tcLhs _ _ other_bind = pprPanic "tcLhs" (ppr other_bind)+        -- AbsBind, VarBind impossible++-------------------+tcLhsSigId :: LetBndrSpec -> (Name, TcIdSigInfo) -> TcM MonoBindInfo+tcLhsSigId no_gen (name, sig)+  = do { inst_sig <- tcInstSig sig+       ; mono_id <- newSigLetBndr no_gen name inst_sig+       ; return (MBI { mbi_poly_name = name+                     , mbi_sig       = Just inst_sig+                     , mbi_mono_id   = mono_id }) }++------------+newSigLetBndr :: LetBndrSpec -> Name -> TcIdSigInst -> TcM TcId+newSigLetBndr (LetGblBndr prags) name (TISI { sig_inst_sig = id_sig })+  | CompleteSig { sig_bndr = poly_id } <- id_sig+  = addInlinePrags poly_id (lookupPragEnv prags name)+newSigLetBndr no_gen name (TISI { sig_inst_tau = tau })+  = newLetBndr no_gen name tau++-------------------+tcRhs :: TcMonoBind -> TcM (HsBind GhcTcId)+tcRhs (TcFunBind info@(MBI { mbi_sig = mb_sig, mbi_mono_id = mono_id })+                 loc matches)+  = tcExtendIdBinderStackForRhs [info]  $+    tcExtendTyVarEnvForRhs mb_sig       $+    do  { traceTc "tcRhs: fun bind" (ppr mono_id $$ ppr (idType mono_id))+        ; (co_fn, matches') <- tcMatchesFun (cL loc (idName mono_id))+                                 matches (mkCheckExpType $ idType mono_id)+        ; return ( FunBind { fun_id = cL loc mono_id+                           , fun_matches = matches'+                           , fun_co_fn = co_fn+                           , fun_ext = placeHolderNamesTc+                           , fun_tick = [] } ) }++tcRhs (TcPatBind infos pat' grhss pat_ty)+  = -- When we are doing pattern bindings we *don't* bring any scoped+    -- type variables into scope unlike function bindings+    -- Wny not?  They are not completely rigid.+    -- That's why we have the special case for a single FunBind in tcMonoBinds+    tcExtendIdBinderStackForRhs infos        $+    do  { traceTc "tcRhs: pat bind" (ppr pat' $$ ppr pat_ty)+        ; grhss' <- addErrCtxt (patMonoBindsCtxt pat' grhss) $+                    tcGRHSsPat grhss pat_ty+        ; return ( PatBind { pat_lhs = pat', pat_rhs = grhss'+                           , pat_ext = NPatBindTc placeHolderNamesTc pat_ty+                           , pat_ticks = ([],[]) } )}++tcExtendTyVarEnvForRhs :: Maybe TcIdSigInst -> TcM a -> TcM a+tcExtendTyVarEnvForRhs Nothing thing_inside+  = thing_inside+tcExtendTyVarEnvForRhs (Just sig) thing_inside+  = tcExtendTyVarEnvFromSig sig thing_inside++tcExtendTyVarEnvFromSig :: TcIdSigInst -> TcM a -> TcM a+tcExtendTyVarEnvFromSig sig_inst thing_inside+  | TISI { sig_inst_skols = skol_prs, sig_inst_wcs = wcs } <- sig_inst+  = tcExtendNameTyVarEnv wcs $+    tcExtendNameTyVarEnv skol_prs $+    thing_inside++tcExtendIdBinderStackForRhs :: [MonoBindInfo] -> TcM a -> TcM a+-- Extend the TcBinderStack for the RHS of the binding, with+-- the monomorphic Id.  That way, if we have, say+--     f = \x -> blah+-- and something goes wrong in 'blah', we get a "relevant binding"+-- looking like  f :: alpha -> beta+-- This applies if 'f' has a type signature too:+--    f :: forall a. [a] -> [a]+--    f x = True+-- We can't unify True with [a], and a relevant binding is f :: [a] -> [a]+-- If we had the *polymorphic* version of f in the TcBinderStack, it+-- would not be reported as relevant, because its type is closed+tcExtendIdBinderStackForRhs infos thing_inside+  = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel+                        | MBI { mbi_mono_id = mono_id } <- infos ]+                        thing_inside+    -- NotTopLevel: it's a monomorphic binding++---------------------+getMonoBindInfo :: [Located TcMonoBind] -> [MonoBindInfo]+getMonoBindInfo tc_binds+  = foldr (get_info . unLoc) [] tc_binds+  where+    get_info (TcFunBind info _ _)    rest = info : rest+    get_info (TcPatBind infos _ _ _) rest = infos ++ rest+++{- Note [Typechecking pattern bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Look at:+   - typecheck/should_compile/ExPat+   - #12427, typecheck/should_compile/T12427{a,b}++  data T where+    MkT :: Integral a => a -> Int -> T++and suppose t :: T.  Which of these pattern bindings are ok?++  E1. let { MkT p _ = t } in <body>++  E2. let { MkT _ q = t } in <body>++  E3. let { MkT (toInteger -> r) _ = t } in <body>++* (E1) is clearly wrong because the existential 'a' escapes.+  What type could 'p' possibly have?++* (E2) is fine, despite the existential pattern, because+  q::Int, and nothing escapes.++* Even (E3) is fine.  The existential pattern binds a dictionary+  for (Integral a) which the view pattern can use to convert the+  a-valued field to an Integer, so r :: Integer.++An easy way to see all three is to imagine the desugaring.+For (E2) it would look like+    let q = case t of MkT _ q' -> q'+    in <body>+++We typecheck pattern bindings as follows.  First tcLhs does this:++  1. Take each type signature q :: ty, partial or complete, and+     instantiate it (with tcLhsSigId) to get a MonoBindInfo.  This+     gives us a fresh "mono_id" qm :: instantiate(ty), where qm has+     a fresh name.++     Any fresh unification variables in instantiate(ty) born here, not+     deep under implications as would happen if we allocated them when+     we encountered q during tcPat.++  2. Build a little environment mapping "q" -> "qm" for those Ids+     with signatures (inst_sig_fun)++  3. Invoke tcLetPat to typecheck the pattern.++     - We pass in the current TcLevel.  This is captured by+       TcPat.tcLetPat, and put into the pc_lvl field of PatCtxt, in+       PatEnv.++     - When tcPat finds an existential constructor, it binds fresh+       type variables and dictionaries as usual, increments the TcLevel,+       and emits an implication constraint.++     - When we come to a binder (TcPat.tcPatBndr), it looks it up+       in the little environment (the pc_sig_fn field of PatCtxt).++         Success => There was a type signature, so just use it,+                    checking compatibility with the expected type.++         Failure => No type sigature.+             Infer case: (happens only outside any constructor pattern)+                         use a unification variable+                         at the outer level pc_lvl++             Check case: use promoteTcType to promote the type+                         to the outer level pc_lvl.  This is the+                         place where we emit a constraint that'll blow+                         up if existential capture takes place++       Result: the type of the binder is always at pc_lvl. This is+       crucial.++  4. Throughout, when we are making up an Id for the pattern-bound variables+     (newLetBndr), we have two cases:++     - If we are generalising (generalisation plan is InferGen or+       CheckGen), then the let_bndr_spec will be LetLclBndr.  In that case+       we want to bind a cloned, local version of the variable, with the+       type given by the pattern context, *not* by the signature (even if+       there is one; see #7268). The mkExport part of the+       generalisation step will do the checking and impedance matching+       against the signature.++     - If for some some reason we are not generalising (plan = NoGen), the+       LetBndrSpec will be LetGblBndr.  In that case we must bind the+       global version of the Id, and do so with precisely the type given+       in the signature.  (Then we unify with the type from the pattern+       context type.)+++And that's it!  The implication constraints check for the skolem+escape.  It's quite simple and neat, and more expressive than before+e.g. GHC 8.0 rejects (E2) and (E3).++Example for (E1), starting at level 1.  We generate+     p :: beta:1, with constraints (forall:3 a. Integral a => a ~ beta)+The (a~beta) can't float (because of the 'a'), nor be solved (because+beta is untouchable.)++Example for (E2), we generate+     q :: beta:1, with constraint (forall:3 a. Integral a => Int ~ beta)+The beta is untouchable, but floats out of the constraint and can+be solved absolutely fine.+++************************************************************************+*                                                                      *+                Generalisation+*                                                                      *+********************************************************************* -}++data GeneralisationPlan+  = NoGen               -- No generalisation, no AbsBinds++  | InferGen            -- Implicit generalisation; there is an AbsBinds+       Bool             --   True <=> apply the MR; generalise only unconstrained type vars++  | CheckGen (LHsBind GhcRn) TcIdSigInfo+                        -- One FunBind with a signature+                        -- Explicit generalisation++-- A consequence of the no-AbsBinds choice (NoGen) is that there is+-- no "polymorphic Id" and "monmomorphic Id"; there is just the one++instance Outputable GeneralisationPlan where+  ppr NoGen          = text "NoGen"+  ppr (InferGen b)   = text "InferGen" <+> ppr b+  ppr (CheckGen _ s) = text "CheckGen" <+> ppr s++decideGeneralisationPlan+   :: DynFlags -> [LHsBind GhcRn] -> IsGroupClosed -> TcSigFun+   -> GeneralisationPlan+decideGeneralisationPlan dflags lbinds closed sig_fn+  | has_partial_sigs                         = InferGen (and partial_sig_mrs)+  | Just (bind, sig) <- one_funbind_with_sig = CheckGen bind sig+  | do_not_generalise closed                 = NoGen+  | otherwise                                = InferGen mono_restriction+  where+    binds = map unLoc lbinds++    partial_sig_mrs :: [Bool]+    -- One for each partial signature (so empty => no partial sigs)+    -- The Bool is True if the signature has no constraint context+    --      so we should apply the MR+    -- See Note [Partial type signatures and generalisation]+    partial_sig_mrs+      = [ null theta+        | TcIdSig (PartialSig { psig_hs_ty = hs_ty })+            <- mapMaybe sig_fn (collectHsBindListBinders lbinds)+        , let (_, dL->L _ theta, _) = splitLHsSigmaTy (hsSigWcType hs_ty) ]++    has_partial_sigs   = not (null partial_sig_mrs)++    mono_restriction  = xopt LangExt.MonomorphismRestriction dflags+                     && any restricted binds++    do_not_generalise (IsGroupClosed _ True) = False+        -- The 'True' means that all of the group's+        -- free vars have ClosedTypeId=True; so we can ignore+        -- -XMonoLocalBinds, and generalise anyway+    do_not_generalise _ = xopt LangExt.MonoLocalBinds dflags++    -- With OutsideIn, all nested bindings are monomorphic+    -- except a single function binding with a signature+    one_funbind_with_sig+      | [lbind@(dL->L _ (FunBind { fun_id = v }))] <- lbinds+      , Just (TcIdSig sig) <- sig_fn (unLoc v)+      = Just (lbind, sig)+      | otherwise+      = Nothing++    -- The Haskell 98 monomorphism restriction+    restricted (PatBind {})                              = True+    restricted (VarBind { var_id = v })                  = no_sig v+    restricted (FunBind { fun_id = v, fun_matches = m }) = restricted_match m+                                                           && no_sig (unLoc v)+    restricted b = pprPanic "isRestrictedGroup/unrestricted" (ppr b)++    restricted_match mg = matchGroupArity mg == 0+        -- No args => like a pattern binding+        -- Some args => a function binding++    no_sig n = not (hasCompleteSig sig_fn n)++isClosedBndrGroup :: TcTypeEnv -> Bag (LHsBind GhcRn) -> IsGroupClosed+isClosedBndrGroup type_env binds+  = IsGroupClosed fv_env type_closed+  where+    type_closed = allUFM (nameSetAll is_closed_type_id) fv_env++    fv_env :: NameEnv NameSet+    fv_env = mkNameEnv $ concatMap (bindFvs . unLoc) binds++    bindFvs :: HsBindLR GhcRn GhcRn -> [(Name, NameSet)]+    bindFvs (FunBind { fun_id = (dL->L _ f)+                     , fun_ext = fvs })+       = let open_fvs = get_open_fvs fvs+         in [(f, open_fvs)]+    bindFvs (PatBind { pat_lhs = pat, pat_ext = fvs })+       = let open_fvs = get_open_fvs fvs+         in [(b, open_fvs) | b <- collectPatBinders pat]+    bindFvs _+       = []++    get_open_fvs fvs = filterNameSet (not . is_closed) fvs++    is_closed :: Name -> ClosedTypeId+    is_closed name+      | Just thing <- lookupNameEnv type_env name+      = case thing of+          AGlobal {}                     -> True+          ATcId { tct_info = ClosedLet } -> True+          _                              -> False++      | otherwise+      = True  -- The free-var set for a top level binding mentions+++    is_closed_type_id :: Name -> Bool+    -- We're already removed Global and ClosedLet Ids+    is_closed_type_id name+      | Just thing <- lookupNameEnv type_env name+      = case thing of+          ATcId { tct_info = NonClosedLet _ cl } -> cl+          ATcId { tct_info = NotLetBound }       -> False+          ATyVar {}                              -> False+               -- In-scope type variables are not closed!+          _ -> pprPanic "is_closed_id" (ppr name)++      | otherwise+      = True   -- The free-var set for a top level binding mentions+               -- imported things too, so that we can report unused imports+               -- These won't be in the local type env.+               -- Ditto class method etc from the current module+++{- *********************************************************************+*                                                                      *+               Error contexts and messages+*                                                                      *+********************************************************************* -}++-- This one is called on LHS, when pat and grhss are both Name+-- and on RHS, when pat is TcId and grhss is still Name+patMonoBindsCtxt :: (OutputableBndrId (GhcPass p), Outputable body)+                 => LPat (GhcPass p) -> GRHSs GhcRn body -> SDoc+patMonoBindsCtxt pat grhss+  = hang (text "In a pattern binding:") 2 (pprPatBind pat grhss)
+ compiler/typecheck/TcCanonical.hs view
@@ -0,0 +1,2465 @@+{-# LANGUAGE CPP #-}++module TcCanonical(+     canonicalize,+     unifyDerived,+     makeSuperClasses, maybeSym,+     StopOrContinue(..), stopWith, continueWith,+     solveCallStack    -- For TcSimplify+  ) where++#include "HsVersions.h"++import GhcPrelude++import TcRnTypes+import TcUnify( swapOverTyVars, metaTyVarUpdateOK )+import TcType+import Type+import TcFlatten+import TcSMonad+import TcEvidence+import TcEvTerm+import Class+import TyCon+import TyCoRep   -- cleverly decomposes types, good for completeness checking+import Coercion+import CoreSyn+import Id( idType, mkTemplateLocals )+import FamInstEnv ( FamInstEnvs )+import FamInst ( tcTopNormaliseNewTypeTF_maybe )+import Var+import VarEnv( mkInScopeSet )+import VarSet( delVarSetList )+import Outputable+import DynFlags( DynFlags )+import NameSet+import RdrName+import HsTypes( HsIPName(..) )++import Pair+import Util+import Bag+import MonadUtils+import Control.Monad+import Data.Maybe ( isJust )+import Data.List  ( zip4 )+import BasicTypes++import Data.Bifunctor ( bimap )++{-+************************************************************************+*                                                                      *+*                      The Canonicaliser                               *+*                                                                      *+************************************************************************++Note [Canonicalization]+~~~~~~~~~~~~~~~~~~~~~~~++Canonicalization converts a simple constraint to a canonical form. It is+unary (i.e. treats individual constraints one at a time).++Constraints originating from user-written code come into being as+CNonCanonicals (except for CHoleCans, arising from holes). We know nothing+about these constraints. So, first:++     Classify CNonCanoncal constraints, depending on whether they+     are equalities, class predicates, or other.++Then proceed depending on the shape of the constraint. Generally speaking,+each constraint gets flattened and then decomposed into one of several forms+(see type Ct in TcRnTypes).++When an already-canonicalized constraint gets kicked out of the inert set,+it must be recanonicalized. But we know a bit about its shape from the+last time through, so we can skip the classification step.++-}++-- Top-level canonicalization+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++canonicalize :: Ct -> TcS (StopOrContinue Ct)+canonicalize (CNonCanonical { cc_ev = ev })+  = {-# SCC "canNC" #-}+    case classifyPredType pred of+      ClassPred cls tys     -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys)+                                  canClassNC ev cls tys+      EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)+                                  canEqNC    ev eq_rel ty1 ty2+      IrredPred {}          -> do traceTcS "canEvNC:irred" (ppr pred)+                                  canIrred ev+      ForAllPred _ _ pred   -> do traceTcS "canEvNC:forall" (ppr pred)+                                  canForAll ev (isClassPred pred)+  where+    pred = ctEvPred ev++canonicalize (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc }))+  = canForAll ev pend_sc++canonicalize (CIrredCan { cc_ev = ev })+  | EqPred eq_rel ty1 ty2 <- classifyPredType (ctEvPred ev)+  = -- For insolubles (all of which are equalities, do /not/ flatten the arguments+    -- In #14350 doing so led entire-unnecessary and ridiculously large+    -- type function expansion.  Instead, canEqNC just applies+    -- the substitution to the predicate, and may do decomposition;+    --    e.g. a ~ [a], where [G] a ~ [Int], can decompose+    canEqNC ev eq_rel ty1 ty2++  | otherwise+  = canIrred ev++canonicalize (CDictCan { cc_ev = ev, cc_class  = cls+                       , cc_tyargs = xis, cc_pend_sc = pend_sc })+  = {-# SCC "canClass" #-}+    canClass ev cls xis pend_sc++canonicalize (CTyEqCan { cc_ev = ev+                       , cc_tyvar  = tv+                       , cc_rhs    = xi+                       , cc_eq_rel = eq_rel })+  = {-# SCC "canEqLeafTyVarEq" #-}+    canEqNC ev eq_rel (mkTyVarTy tv) xi+      -- NB: Don't use canEqTyVar because that expects flattened types,+      -- and tv and xi may not be flat w.r.t. an updated inert set++canonicalize (CFunEqCan { cc_ev = ev+                        , cc_fun    = fn+                        , cc_tyargs = xis1+                        , cc_fsk    = fsk })+  = {-# SCC "canEqLeafFunEq" #-}+    canCFunEqCan ev fn xis1 fsk++canonicalize (CHoleCan { cc_ev = ev, cc_hole = hole })+  = canHole ev hole++{-+************************************************************************+*                                                                      *+*                      Class Canonicalization+*                                                                      *+************************************************************************+-}++canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct)+-- "NC" means "non-canonical"; that is, we have got here+-- from a NonCanonical constraint, not from a CDictCan+-- Precondition: EvVar is class evidence+canClassNC ev cls tys+  | isGiven ev  -- See Note [Eagerly expand given superclasses]+  = do { sc_cts <- mkStrictSuperClasses ev [] [] cls tys+       ; emitWork sc_cts+       ; canClass ev cls tys False }++  | isWanted ev+  , Just ip_name <- isCallStackPred cls tys+  , OccurrenceOf func <- ctLocOrigin loc+  -- If we're given a CallStack constraint that arose from a function+  -- call, we need to push the current call-site onto the stack instead+  -- of solving it directly from a given.+  -- See Note [Overview of implicit CallStacks] in TcEvidence+  -- and Note [Solving CallStack constraints] in TcSMonad+  = do { -- First we emit a new constraint that will capture the+         -- given CallStack.+       ; let new_loc = setCtLocOrigin loc (IPOccOrigin (HsIPName ip_name))+                            -- We change the origin to IPOccOrigin so+                            -- this rule does not fire again.+                            -- See Note [Overview of implicit CallStacks]++       ; new_ev <- newWantedEvVarNC new_loc pred++         -- Then we solve the wanted by pushing the call-site+         -- onto the newly emitted CallStack+       ; let ev_cs = EvCsPushCall func (ctLocSpan loc) (ctEvExpr new_ev)+       ; solveCallStack ev ev_cs++       ; canClass new_ev cls tys False }++  | otherwise+  = canClass ev cls tys (has_scs cls)++  where+    has_scs cls = not (null (classSCTheta cls))+    loc  = ctEvLoc ev+    pred = ctEvPred ev++solveCallStack :: CtEvidence -> EvCallStack -> TcS ()+-- Also called from TcSimplify when defaulting call stacks+solveCallStack ev ev_cs = do+  -- We're given ev_cs :: CallStack, but the evidence term should be a+  -- dictionary, so we have to coerce ev_cs to a dictionary for+  -- `IP ip CallStack`. See Note [Overview of implicit CallStacks]+  cs_tm <- evCallStack ev_cs+  let ev_tm = mkEvCast cs_tm (wrapIP (ctEvPred ev))+  setEvBindIfWanted ev ev_tm++canClass :: CtEvidence+         -> Class -> [Type]+         -> Bool            -- True <=> un-explored superclasses+         -> TcS (StopOrContinue Ct)+-- Precondition: EvVar is class evidence++canClass ev cls tys pend_sc+  =   -- all classes do *nominal* matching+    ASSERT2( ctEvRole ev == Nominal, ppr ev $$ ppr cls $$ ppr tys )+    do { (xis, cos, _kind_co) <- flattenArgsNom ev cls_tc tys+       ; MASSERT( isTcReflCo _kind_co )+       ; let co = mkTcTyConAppCo Nominal cls_tc cos+             xi = mkClassPred cls xis+             mk_ct new_ev = CDictCan { cc_ev = new_ev+                                     , cc_tyargs = xis+                                     , cc_class = cls+                                     , cc_pend_sc = pend_sc }+       ; mb <- rewriteEvidence ev xi co+       ; traceTcS "canClass" (vcat [ ppr ev+                                   , ppr xi, ppr mb ])+       ; return (fmap mk_ct mb) }+  where+    cls_tc = classTyCon cls++{- Note [The superclass story]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to add superclass constraints for two reasons:++* For givens [G], they give us a route to proof.  E.g.+    f :: Ord a => a -> Bool+    f x = x == x+  We get a Wanted (Eq a), which can only be solved from the superclass+  of the Given (Ord a).++* For wanteds [W], and deriveds [WD], [D], they may give useful+  functional dependencies.  E.g.+     class C a b | a -> b where ...+     class C a b => D a b where ...+  Now a [W] constraint (D Int beta) has (C Int beta) as a superclass+  and that might tell us about beta, via C's fundeps.  We can get this+  by generating a [D] (C Int beta) constraint.  It's derived because+  we don't actually have to cough up any evidence for it; it's only there+  to generate fundep equalities.++See Note [Why adding superclasses can help].++For these reasons we want to generate superclass constraints for both+Givens and Wanteds. But:++* (Minor) they are often not needed, so generating them aggressively+  is a waste of time.++* (Major) if we want recursive superclasses, there would be an infinite+  number of them.  Here is a real-life example (#10318);++     class (Frac (Frac a) ~ Frac a,+            Fractional (Frac a),+            IntegralDomain (Frac a))+         => IntegralDomain a where+      type Frac a :: *++  Notice that IntegralDomain has an associated type Frac, and one+  of IntegralDomain's superclasses is another IntegralDomain constraint.++So here's the plan:++1. Eagerly generate superclasses for given (but not wanted)+   constraints; see Note [Eagerly expand given superclasses].+   This is done using mkStrictSuperClasses in canClassNC, when+   we take a non-canonical Given constraint and cannonicalise it.++   However stop if you encounter the same class twice.  That is,+   mkStrictSuperClasses expands eagerly, but has a conservative+   termination condition: see Note [Expanding superclasses] in TcType.++2. Solve the wanteds as usual, but do no further expansion of+   superclasses for canonical CDictCans in solveSimpleGivens or+   solveSimpleWanteds; Note [Danger of adding superclasses during solving]++   However, /do/ continue to eagerly expand superlasses for new /given/+   /non-canonical/ constraints (canClassNC does this).  As #12175+   showed, a type-family application can expand to a class constraint,+   and we want to see its superclasses for just the same reason as+   Note [Eagerly expand given superclasses].++3. If we have any remaining unsolved wanteds+        (see Note [When superclasses help] in TcRnTypes)+   try harder: take both the Givens and Wanteds, and expand+   superclasses again.  See the calls to expandSuperClasses in+   TcSimplify.simpl_loop and solveWanteds.++   This may succeed in generating (a finite number of) extra Givens,+   and extra Deriveds. Both may help the proof.++3a An important wrinkle: only expand Givens from the current level.+   Two reasons:+      - We only want to expand it once, and that is best done at+        the level it is bound, rather than repeatedly at the leaves+        of the implication tree+      - We may be inside a type where we can't create term-level+        evidence anyway, so we can't superclass-expand, say,+        (a ~ b) to get (a ~# b).  This happened in #15290.++4. Go round to (2) again.  This loop (2,3,4) is implemented+   in TcSimplify.simpl_loop.++The cc_pend_sc flag in a CDictCan records whether the superclasses of+this constraint have been expanded.  Specifically, in Step 3 we only+expand superclasses for constraints with cc_pend_sc set to true (i.e.+isPendingScDict holds).++Why do we do this?  Two reasons:++* To avoid repeated work, by repeatedly expanding the superclasses of+  same constraint,++* To terminate the above loop, at least in the -XNoRecursiveSuperClasses+  case.  If there are recursive superclasses we could, in principle,+  expand forever, always encountering new constraints.++When we take a CNonCanonical or CIrredCan, but end up classifying it+as a CDictCan, we set the cc_pend_sc flag to False.++Note [Superclass loops]+~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+  class C a => D a+  class D a => C a++Then, when we expand superclasses, we'll get back to the self-same+predicate, so we have reached a fixpoint in expansion and there is no+point in fruitlessly expanding further.  This case just falls out from+our strategy.  Consider+  f :: C a => a -> Bool+  f x = x==x+Then canClassNC gets the [G] d1: C a constraint, and eager emits superclasses+G] d2: D a, [G] d3: C a (psc).  (The "psc" means it has its sc_pend flag set.)+When processing d3 we find a match with d1 in the inert set, and we always+keep the inert item (d1) if possible: see Note [Replacement vs keeping] in+TcInteract.  So d3 dies a quick, happy death.++Note [Eagerly expand given superclasses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In step (1) of Note [The superclass story], why do we eagerly expand+Given superclasses by one layer?  (By "one layer" we mean expand transitively+until you meet the same class again -- the conservative criterion embodied+in expandSuperClasses.  So a "layer" might be a whole stack of superclasses.)+We do this eagerly for Givens mainly because of some very obscure+cases like this:++   instance Bad a => Eq (T a)++   f :: (Ord (T a)) => blah+   f x = ....needs Eq (T a), Ord (T a)....++Here if we can't satisfy (Eq (T a)) from the givens we'll use the+instance declaration; but then we are stuck with (Bad a).  Sigh.+This is really a case of non-confluent proofs, but to stop our users+complaining we expand one layer in advance.++Note [Instance and Given overlap] in TcInteract.++We also want to do this if we have++   f :: F (T a) => blah++where+   type instance F (T a) = Ord (T a)++So we may need to do a little work on the givens to expose the+class that has the superclasses.  That's why the superclass+expansion for Givens happens in canClassNC.++Note [Why adding superclasses can help]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Examples of how adding superclasses can help:++    --- Example 1+        class C a b | a -> b+    Suppose we want to solve+         [G] C a b+         [W] C a beta+    Then adding [D] beta~b will let us solve it.++    -- Example 2 (similar but using a type-equality superclass)+        class (F a ~ b) => C a b+    And try to sllve:+         [G] C a b+         [W] C a beta+    Follow the superclass rules to add+         [G] F a ~ b+         [D] F a ~ beta+    Now we get [D] beta ~ b, and can solve that.++    -- Example (tcfail138)+      class L a b | a -> b+      class (G a, L a b) => C a b++      instance C a b' => G (Maybe a)+      instance C a b  => C (Maybe a) a+      instance L (Maybe a) a++    When solving the superclasses of the (C (Maybe a) a) instance, we get+      [G] C a b, and hance by superclasses, [G] G a, [G] L a b+      [W] G (Maybe a)+    Use the instance decl to get+      [W] C a beta+    Generate its derived superclass+      [D] L a beta.  Now using fundeps, combine with [G] L a b to get+      [D] beta ~ b+    which is what we want.++Note [Danger of adding superclasses during solving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here's a serious, but now out-dated example, from #4497:++   class Num (RealOf t) => Normed t+   type family RealOf x++Assume the generated wanted constraint is:+   [W] RealOf e ~ e+   [W] Normed e++If we were to be adding the superclasses during simplification we'd get:+   [W] RealOf e ~ e+   [W] Normed e+   [D] RealOf e ~ fuv+   [D] Num fuv+==>+   e := fuv, Num fuv, Normed fuv, RealOf fuv ~ fuv++While looks exactly like our original constraint. If we add the+superclass of (Normed fuv) again we'd loop.  By adding superclasses+definitely only once, during canonicalisation, this situation can't+happen.++Mind you, now that Wanteds cannot rewrite Derived, I think this particular+situation can't happen.+  -}++makeSuperClasses :: [Ct] -> TcS [Ct]+-- Returns strict superclasses, transitively, see Note [The superclasses story]+-- See Note [The superclass story]+-- The loop-breaking here follows Note [Expanding superclasses] in TcType+-- Specifically, for an incoming (C t) constraint, we return all of (C t)'s+--    superclasses, up to /and including/ the first repetition of C+--+-- Example:  class D a => C a+--           class C [a] => D a+-- makeSuperClasses (C x) will return (D x, C [x])+--+-- NB: the incoming constraints have had their cc_pend_sc flag already+--     flipped to False, by isPendingScDict, so we are /obliged/ to at+--     least produce the immediate superclasses+makeSuperClasses cts = concatMapM go cts+  where+    go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })+      = mkStrictSuperClasses ev [] [] cls tys+    go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev }))+      = ASSERT2( isClassPred pred, ppr pred )  -- The cts should all have+                                               -- class pred heads+        mkStrictSuperClasses ev tvs theta cls tys+      where+        (tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)+    go ct = pprPanic "makeSuperClasses" (ppr ct)++mkStrictSuperClasses+    :: CtEvidence+    -> [TyVar] -> ThetaType  -- These two args are non-empty only when taking+                             -- superclasses of a /quantified/ constraint+    -> Class -> [Type] -> TcS [Ct]+-- Return constraints for the strict superclasses of+--   ev :: forall as. theta => cls tys+mkStrictSuperClasses ev tvs theta cls tys+  = mk_strict_superclasses (unitNameSet (className cls))+                           ev tvs theta cls tys++mk_strict_superclasses :: NameSet -> CtEvidence+                       -> [TyVar] -> ThetaType+                       -> Class -> [Type] -> TcS [Ct]+-- Always return the immediate superclasses of (cls tys);+-- and expand their superclasses, provided none of them are in rec_clss+-- nor are repeated+mk_strict_superclasses rec_clss ev tvs theta cls tys+  | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev+  = concatMapM (do_one_given evar (mk_given_loc loc)) $+    classSCSelIds cls+  where+    dict_ids  = mkTemplateLocals theta+    size      = sizeTypes tys++    do_one_given evar given_loc sel_id+      | isUnliftedType sc_pred+      , not (null tvs && null theta)+      = -- See Note [Equality superclasses in quantified constraints]+        return []+      | otherwise+      = do { given_ev <- newGivenEvVar given_loc $+                         (given_ty, mk_sc_sel evar sel_id)+           ; mk_superclasses rec_clss given_ev tvs theta sc_pred }+      where+        sc_pred  = funResultTy (piResultTys (idType sel_id) tys)+        given_ty = mkInfSigmaTy tvs theta sc_pred++    mk_sc_sel evar sel_id+      = EvExpr $ mkLams tvs $ mkLams dict_ids $+        Var sel_id `mkTyApps` tys `App`+        (evId evar `mkTyApps` mkTyVarTys tvs `mkVarApps` dict_ids)++    mk_given_loc loc+       | isCTupleClass cls+       = loc   -- For tuple predicates, just take them apart, without+               -- adding their (large) size into the chain.  When we+               -- get down to a base predicate, we'll include its size.+               -- #10335++       | GivenOrigin skol_info <- ctLocOrigin loc+         -- See Note [Solving superclass constraints] in TcInstDcls+         -- for explantation of this transformation for givens+       = case skol_info of+            InstSkol -> loc { ctl_origin = GivenOrigin (InstSC size) }+            InstSC n -> loc { ctl_origin = GivenOrigin (InstSC (n `max` size)) }+            _        -> loc++       | otherwise  -- Probably doesn't happen, since this function+       = loc        -- is only used for Givens, but does no harm++mk_strict_superclasses rec_clss ev tvs theta cls tys+  | all noFreeVarsOfType tys+  = return [] -- Wanteds with no variables yield no deriveds.+              -- See Note [Improvement from Ground Wanteds]++  | otherwise -- Wanted/Derived case, just add Derived superclasses+              -- that can lead to improvement.+  = ASSERT2( null tvs && null theta, ppr tvs $$ ppr theta )+    concatMapM do_one_derived (immSuperClasses cls tys)+  where+    loc = ctEvLoc ev++    do_one_derived sc_pred+      = do { sc_ev <- newDerivedNC loc sc_pred+           ; mk_superclasses rec_clss sc_ev [] [] sc_pred }++mk_superclasses :: NameSet -> CtEvidence+                -> [TyVar] -> ThetaType -> PredType -> TcS [Ct]+-- Return this constraint, plus its superclasses, if any+mk_superclasses rec_clss ev tvs theta pred+  | ClassPred cls tys <- classifyPredType pred+  = mk_superclasses_of rec_clss ev tvs theta cls tys++  | otherwise   -- Superclass is not a class predicate+  = return [mkNonCanonical ev]++mk_superclasses_of :: NameSet -> CtEvidence+                   -> [TyVar] -> ThetaType -> Class -> [Type]+                   -> TcS [Ct]+-- Always return this class constraint,+-- and expand its superclasses+mk_superclasses_of rec_clss ev tvs theta cls tys+  | loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys)+                    ; return [this_ct] }  -- cc_pend_sc of this_ct = True+  | otherwise  = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys+                                                          , ppr (isCTupleClass cls)+                                                          , ppr rec_clss+                                                          ])+                    ; sc_cts <- mk_strict_superclasses rec_clss' ev tvs theta cls tys+                    ; return (this_ct : sc_cts) }+                                   -- cc_pend_sc of this_ct = False+  where+    cls_nm     = className cls+    loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss+                 -- Tuples never contribute to recursion, and can be nested+    rec_clss'  = rec_clss `extendNameSet` cls_nm++    this_ct | null tvs, null theta+            = CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys+                       , cc_pend_sc = loop_found }+                 -- NB: If there is a loop, we cut off, so we have not+                 --     added the superclasses, hence cc_pend_sc = True+            | otherwise+            = CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys+                             , qci_ev = ev+                             , qci_pend_sc = loop_found })+++{- Note [Equality superclasses in quantified constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#15359, #15593, #15625)+  f :: (forall a. theta => a ~ b) => stuff++It's a bit odd to have a local, quantified constraint for `(a~b)`,+but some people want such a thing (see the tickets). And for+Coercible it is definitely useful+  f :: forall m. (forall p q. Coercible p q => Coercible (m p) (m q)))+                 => stuff++Moreover it's not hard to arrange; we just need to look up /equality/+constraints in the quantified-constraint environment, which we do in+TcInteract.doTopReactOther.++There is a wrinkle though, in the case where 'theta' is empty, so+we have+  f :: (forall a. a~b) => stuff++Now, potentially, the superclass machinery kicks in, in+makeSuperClasses, giving us a a second quantified constrait+       (forall a. a ~# b)+BUT this is an unboxed value!  And nothing has prepared us for+dictionary "functions" that are unboxed.  Actually it does just+about work, but the simplier ends up with stuff like+   case (/\a. eq_sel d) of df -> ...(df @Int)...+and fails to simplify that any further.  And it doesn't satisfy+isPredTy any more.++So for now we simply decline to take superclasses in the quantified+case.  Instead we have a special case in TcInteract.doTopReactOther,+which looks for primitive equalities specially in the quantified+constraints.++See also Note [Evidence for quantified constraints] in Type.+++************************************************************************+*                                                                      *+*                      Irreducibles canonicalization+*                                                                      *+************************************************************************+-}++canIrred :: CtEvidence -> TcS (StopOrContinue Ct)+-- Precondition: ty not a tuple and no other evidence form+canIrred ev+  = do { let pred = ctEvPred ev+       ; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred)+       ; (xi,co) <- flatten FM_FlattenAll ev pred -- co :: xi ~ pred+       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->+    do { -- Re-classify, in case flattening has improved its shape+       ; case classifyPredType (ctEvPred new_ev) of+           ClassPred cls tys     -> canClassNC new_ev cls tys+           EqPred eq_rel ty1 ty2 -> canEqNC new_ev eq_rel ty1 ty2+           _                     -> continueWith $+                                    mkIrredCt new_ev } }++canHole :: CtEvidence -> Hole -> TcS (StopOrContinue Ct)+canHole ev hole+  = do { let pred = ctEvPred ev+       ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred+       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->+    do { updInertIrreds (`snocCts` (CHoleCan { cc_ev = new_ev+                                             , cc_hole = hole }))+       ; stopWith new_ev "Emit insoluble hole" } }+++{- *********************************************************************+*                                                                      *+*                      Quantified predicates+*                                                                      *+********************************************************************* -}++{- Note [Quantified constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The -XQuantifiedConstraints extension allows type-class contexts like this:++  data Rose f x = Rose x (f (Rose f x))++  instance (Eq a, forall b. Eq b => Eq (f b))+        => Eq (Rose f a)  where+    (Rose x1 rs1) == (Rose x2 rs2) = x1==x2 && rs1 == rs2++Note the (forall b. Eq b => Eq (f b)) in the instance contexts.+This quantified constraint is needed to solve the+ [W] (Eq (f (Rose f x)))+constraint which arises form the (==) definition.++The wiki page is+  https://gitlab.haskell.org/ghc/ghc/wikis/quantified-constraints+which in turn contains a link to the GHC Proposal where the change+is specified, and a Haskell Symposium paper about it.++We implement two main extensions to the design in the paper:++ 1. We allow a variable in the instance head, e.g.+      f :: forall m a. (forall b. m b) => D (m a)+    Notice the 'm' in the head of the quantified constraint, not+    a class.++ 2. We suport superclasses to quantified constraints.+    For example (contrived):+      f :: (Ord b, forall b. Ord b => Ord (m b)) => m a -> m a -> Bool+      f x y = x==y+    Here we need (Eq (m a)); but the quantifed constraint deals only+    with Ord.  But we can make it work by using its superclass.++Here are the moving parts+  * Language extension {-# LANGUAGE QuantifiedConstraints #-}+    and add it to ghc-boot-th:GHC.LanguageExtensions.Type.Extension++  * A new form of evidence, EvDFun, that is used to discharge+    such wanted constraints++  * checkValidType gets some changes to accept forall-constraints+    only in the right places.++  * Type.PredTree gets a new constructor ForAllPred, and+    and classifyPredType analyses a PredType to decompose+    the new forall-constraints++  * TcSMonad.InertCans gets an extra field, inert_insts,+    which holds all the Given forall-constraints.  In effect,+    such Given constraints are like local instance decls.++  * When trying to solve a class constraint, via+    TcInteract.matchInstEnv, use the InstEnv from inert_insts+    so that we include the local Given forall-constraints+    in the lookup.  (See TcSMonad.getInstEnvs.)++  * TcCanonical.canForAll deals with solving a+    forall-constraint.  See+       Note [Solving a Wanted forall-constraint]++  * We augment the kick-out code to kick out an inert+    forall constraint if it can be rewritten by a new+    type equality; see TcSMonad.kick_out_rewritable++Note that a quantified constraint is never /inferred/+(by TcSimplify.simplifyInfer).  A function can only have a+quantified constraint in its type if it is given an explicit+type signature.++Note that we implement+-}++canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct)+-- We have a constraint (forall as. blah => C tys)+canForAll ev pend_sc+  = do { -- First rewrite it to apply the current substitution+         -- Do not bother with type-family reductions; we can't+         -- do them under a forall anyway (c.f. Flatten.flatten_one+         -- on a forall type)+         let pred = ctEvPred ev+       ; (xi,co) <- flatten FM_SubstOnly ev pred -- co :: xi ~ pred+       ; rewriteEvidence ev xi co `andWhenContinue` \ new_ev ->++    do { -- Now decompose into its pieces and solve it+         -- (It takes a lot less code to flatten before decomposing.)+       ; case classifyPredType (ctEvPred new_ev) of+           ForAllPred tv_bndrs theta pred+              -> solveForAll new_ev tv_bndrs theta pred pend_sc+           _  -> pprPanic "canForAll" (ppr new_ev)+    } }++solveForAll :: CtEvidence -> [TyVarBinder] -> TcThetaType -> PredType -> Bool+            -> TcS (StopOrContinue Ct)+solveForAll ev tv_bndrs theta pred pend_sc+  | CtWanted { ctev_dest = dest } <- ev+  = -- See Note [Solving a Wanted forall-constraint]+    do { let skol_info = QuantCtxtSkol+             empty_subst = mkEmptyTCvSubst $ mkInScopeSet $+                           tyCoVarsOfTypes (pred:theta) `delVarSetList` tvs+       ; (subst, skol_tvs) <- tcInstSkolTyVarsX empty_subst tvs+       ; given_ev_vars <- mapM newEvVar (substTheta subst theta)++       ; (w_id, ev_binds)+             <- checkConstraintsTcS skol_info skol_tvs given_ev_vars $+                do { wanted_ev <- newWantedEvVarNC loc $+                                  substTy subst pred+                   ; return ( ctEvEvId wanted_ev+                            , unitBag (mkNonCanonical wanted_ev)) }++      ; setWantedEvTerm dest $+        EvFun { et_tvs = skol_tvs, et_given = given_ev_vars+              , et_binds = ev_binds, et_body = w_id }++      ; stopWith ev "Wanted forall-constraint" }++  | isGiven ev   -- See Note [Solving a Given forall-constraint]+  = do { addInertForAll qci+       ; stopWith ev "Given forall-constraint" }++  | otherwise+  = stopWith ev "Derived forall-constraint"+  where+    loc = ctEvLoc ev+    tvs = binderVars tv_bndrs+    qci = QCI { qci_ev = ev, qci_tvs = tvs+              , qci_pred = pred, qci_pend_sc = pend_sc }++{- Note [Solving a Wanted forall-constraint]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Solving a wanted forall (quantified) constraint+  [W] df :: forall ab. (Eq a, Ord b) => C x a b+is delightfully easy.   Just build an implication constraint+    forall ab. (g1::Eq a, g2::Ord b) => [W] d :: C x a+and discharge df thus:+    df = /\ab. \g1 g2. let <binds> in d+where <binds> is filled in by solving the implication constraint.+All the machinery is to hand; there is little to do.++Note [Solving a Given forall-constraint]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For a Given constraint+  [G] df :: forall ab. (Eq a, Ord b) => C x a b+we just add it to TcS's local InstEnv of known instances,+via addInertForall.  Then, if we look up (C x Int Bool), say,+we'll find a match in the InstEnv.+++************************************************************************+*                                                                      *+*        Equalities+*                                                                      *+************************************************************************++Note [Canonicalising equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In order to canonicalise an equality, we look at the structure of the+two types at hand, looking for similarities. A difficulty is that the+types may look dissimilar before flattening but similar after flattening.+However, we don't just want to jump in and flatten right away, because+this might be wasted effort. So, after looking for similarities and failing,+we flatten and then try again. Of course, we don't want to loop, so we+track whether or not we've already flattened.++It is conceivable to do a better job at tracking whether or not a type+is flattened, but this is left as future work. (Mar '15)+++Note [FunTy and decomposing tycon applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When can_eq_nc' attempts to decompose a tycon application we haven't yet zonked.+This means that we may very well have a FunTy containing a type of some unknown+kind. For instance, we may have,++    FunTy (a :: k) Int++Where k is a unification variable. tcRepSplitTyConApp_maybe panics in the event+that it sees such a type as it cannot determine the RuntimeReps which the (->)+is applied to. Consequently, it is vital that we instead use+tcRepSplitTyConApp_maybe', which simply returns Nothing in such a case.++When this happens can_eq_nc' will fail to decompose, zonk, and try again.+Zonking should fill the variable k, meaning that decomposition will succeed the+second time around.+-}++canEqNC :: CtEvidence -> EqRel -> Type -> Type -> TcS (StopOrContinue Ct)+canEqNC ev eq_rel ty1 ty2+  = do { result <- zonk_eq_types ty1 ty2+       ; case result of+           Left (Pair ty1' ty2') -> can_eq_nc False ev eq_rel ty1' ty1 ty2' ty2+           Right ty              -> canEqReflexive ev eq_rel ty }++can_eq_nc+   :: Bool            -- True => both types are flat+   -> CtEvidence+   -> EqRel+   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp+   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp+   -> TcS (StopOrContinue Ct)+can_eq_nc flat ev eq_rel ty1 ps_ty1 ty2 ps_ty2+  = do { traceTcS "can_eq_nc" $+         vcat [ ppr flat, ppr ev, ppr eq_rel, ppr ty1, ppr ps_ty1, ppr ty2, ppr ps_ty2 ]+       ; rdr_env <- getGlobalRdrEnvTcS+       ; fam_insts <- getFamInstEnvs+       ; can_eq_nc' flat rdr_env fam_insts ev eq_rel ty1 ps_ty1 ty2 ps_ty2 }++can_eq_nc'+   :: Bool           -- True => both input types are flattened+   -> GlobalRdrEnv   -- needed to see which newtypes are in scope+   -> FamInstEnvs    -- needed to unwrap data instances+   -> CtEvidence+   -> EqRel+   -> Type -> Type    -- LHS, after and before type-synonym expansion, resp+   -> Type -> Type    -- RHS, after and before type-synonym expansion, resp+   -> TcS (StopOrContinue Ct)++-- Expand synonyms first; see Note [Type synonyms and canonicalization]+can_eq_nc' flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2+  | Just ty1' <- tcView ty1 = can_eq_nc' flat rdr_env envs ev eq_rel ty1' ps_ty1 ty2  ps_ty2+  | Just ty2' <- tcView ty2 = can_eq_nc' flat rdr_env envs ev eq_rel ty1  ps_ty1 ty2' ps_ty2++-- need to check for reflexivity in the ReprEq case.+-- See Note [Eager reflexivity check]+-- Check only when flat because the zonk_eq_types check in canEqNC takes+-- care of the non-flat case.+can_eq_nc' True _rdr_env _envs ev ReprEq ty1 _ ty2 _+  | ty1 `tcEqType` ty2+  = canEqReflexive ev ReprEq ty1++-- When working with ReprEq, unwrap newtypes.+-- See Note [Unwrap newtypes first]+can_eq_nc' _flat rdr_env envs ev eq_rel ty1 ps_ty1 ty2 ps_ty2+  | ReprEq <- eq_rel+  , Just stuff1 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty1+  = can_eq_newtype_nc ev NotSwapped ty1 stuff1 ty2 ps_ty2++  | ReprEq <- eq_rel+  , Just stuff2 <- tcTopNormaliseNewTypeTF_maybe envs rdr_env ty2+  = can_eq_newtype_nc ev IsSwapped  ty2 stuff2 ty1 ps_ty1++-- Then, get rid of casts+can_eq_nc' flat _rdr_env _envs ev eq_rel (CastTy ty1 co1) _ ty2 ps_ty2+  = canEqCast flat ev eq_rel NotSwapped ty1 co1 ty2 ps_ty2+can_eq_nc' flat _rdr_env _envs ev eq_rel ty1 ps_ty1 (CastTy ty2 co2) _+  = canEqCast flat ev eq_rel IsSwapped ty2 co2 ty1 ps_ty1++-- NB: pattern match on True: we want only flat types sent to canEqTyVar.+-- See also Note [No top-level newtypes on RHS of representational equalities]+can_eq_nc' True _rdr_env _envs ev eq_rel (TyVarTy tv1) ps_ty1 ty2 ps_ty2+  = canEqTyVar ev eq_rel NotSwapped tv1 ps_ty1 ty2 ps_ty2+can_eq_nc' True _rdr_env _envs ev eq_rel ty1 ps_ty1 (TyVarTy tv2) ps_ty2+  = canEqTyVar ev eq_rel IsSwapped tv2 ps_ty2 ty1 ps_ty1++----------------------+-- Otherwise try to decompose+----------------------++-- Literals+can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1@(LitTy l1) _ (LitTy l2) _+ | l1 == l2+  = do { setEvBindIfWanted ev (evCoercion $ mkReflCo (eqRelRole eq_rel) ty1)+       ; stopWith ev "Equal LitTy" }++-- Try to decompose type constructor applications+-- Including FunTy (s -> t)+can_eq_nc' _flat _rdr_env _envs ev eq_rel ty1 _ ty2 _+    --- See Note [FunTy and decomposing type constructor applications].+  | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1+  , Just (tc2, tys2) <- repSplitTyConApp_maybe ty2+  , not (isTypeFamilyTyCon tc1)+  , not (isTypeFamilyTyCon tc2)+  = canTyConApp ev eq_rel tc1 tys1 tc2 tys2++can_eq_nc' _flat _rdr_env _envs ev eq_rel+           s1@(ForAllTy {}) _ s2@(ForAllTy {}) _+  = can_eq_nc_forall ev eq_rel s1 s2++-- See Note [Canonicalising type applications] about why we require flat types+can_eq_nc' True _rdr_env _envs ev eq_rel (AppTy t1 s1) _ ty2 _+  | NomEq <- eq_rel+  , Just (t2, s2) <- tcSplitAppTy_maybe ty2+  = can_eq_app ev t1 s1 t2 s2+can_eq_nc' True _rdr_env _envs ev eq_rel ty1 _ (AppTy t2 s2) _+  | NomEq <- eq_rel+  , Just (t1, s1) <- tcSplitAppTy_maybe ty1+  = can_eq_app ev t1 s1 t2 s2++-- No similarity in type structure detected. Flatten and try again.+can_eq_nc' False rdr_env envs ev eq_rel _ ps_ty1 _ ps_ty2+  = do { (xi1, co1) <- flatten FM_FlattenAll ev ps_ty1+       ; (xi2, co2) <- flatten FM_FlattenAll ev ps_ty2+       ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2+       ; can_eq_nc' True rdr_env envs new_ev eq_rel xi1 xi1 xi2 xi2 }++-- We've flattened and the types don't match. Give up.+can_eq_nc' True _rdr_env _envs ev eq_rel _ ps_ty1 _ ps_ty2+  = do { traceTcS "can_eq_nc' catch-all case" (ppr ps_ty1 $$ ppr ps_ty2)+       ; case eq_rel of -- See Note [Unsolved equalities]+            ReprEq -> continueWith (mkIrredCt ev)+            NomEq  -> continueWith (mkInsolubleCt ev) }+          -- No need to call canEqFailure/canEqHardFailure because they+          -- flatten, and the types involved here are already flat++{- Note [Unsolved equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have an unsolved equality like+  (a b ~R# Int)+that is not necessarily insoluble!  Maybe 'a' will turn out to be a newtype.+So we want to make it a potentially-soluble Irred not an insoluble one.+Missing this point is what caused #15431+-}++---------------------------------+can_eq_nc_forall :: CtEvidence -> EqRel+                 -> Type -> Type    -- LHS and RHS+                 -> TcS (StopOrContinue Ct)+-- (forall as. phi1) ~ (forall bs. phi2)+-- Check for length match of as, bs+-- Then build an implication constraint: forall as. phi1 ~ phi2[as/bs]+-- But remember also to unify the kinds of as and bs+--  (this is the 'go' loop), and actually substitute phi2[as |> cos / bs]+-- Remember also that we might have forall z (a:z). blah+--  so we must proceed one binder at a time (#13879)++can_eq_nc_forall ev eq_rel s1 s2+ | CtWanted { ctev_loc = loc, ctev_dest = orig_dest } <- ev+ = do { let free_tvs       = tyCoVarsOfTypes [s1,s2]+            (bndrs1, phi1) = tcSplitForAllVarBndrs s1+            (bndrs2, phi2) = tcSplitForAllVarBndrs s2+      ; if not (equalLength bndrs1 bndrs2)+        then do { traceTcS "Forall failure" $+                     vcat [ ppr s1, ppr s2, ppr bndrs1, ppr bndrs2+                          , ppr (map binderArgFlag bndrs1)+                          , ppr (map binderArgFlag bndrs2) ]+                ; canEqHardFailure ev s1 s2 }+        else+   do { traceTcS "Creating implication for polytype equality" $ ppr ev+      ; let empty_subst1 = mkEmptyTCvSubst $ mkInScopeSet free_tvs+      ; (subst1, skol_tvs) <- tcInstSkolTyVarsX empty_subst1 $+                              binderVars bndrs1++      ; let skol_info = UnifyForAllSkol phi1+            phi1' = substTy subst1 phi1++            -- Unify the kinds, extend the substitution+            go :: [TcTyVar] -> TCvSubst -> [TyVarBinder]+               -> TcS (TcCoercion, Cts)+            go (skol_tv:skol_tvs) subst (bndr2:bndrs2)+              = do { let tv2 = binderVar bndr2+                   ; (kind_co, wanteds1) <- unify loc Nominal (tyVarKind skol_tv)+                                                  (substTy subst (tyVarKind tv2))+                   ; let subst' = extendTvSubst subst tv2+                                       (mkCastTy (mkTyVarTy skol_tv) kind_co)+                   ; (co, wanteds2) <- go skol_tvs subst' bndrs2+                   ; return ( mkTcForAllCo skol_tv kind_co co+                            , wanteds1 `unionBags` wanteds2 ) }++            -- Done: unify phi1 ~ phi2+            go [] subst bndrs2+              = ASSERT( null bndrs2 )+                unify loc (eqRelRole eq_rel) phi1' (substTyUnchecked subst phi2)++            go _ _ _ = panic "cna_eq_nc_forall"  -- case (s:ss) []++            empty_subst2 = mkEmptyTCvSubst (getTCvInScope subst1)++      ; all_co <- checkTvConstraintsTcS skol_info skol_tvs $+                  go skol_tvs empty_subst2 bndrs2++      ; setWantedEq orig_dest all_co+      ; stopWith ev "Deferred polytype equality" } }++ | otherwise+ = do { traceTcS "Omitting decomposition of given polytype equality" $+        pprEq s1 s2    -- See Note [Do not decompose given polytype equalities]+      ; stopWith ev "Discard given polytype equality" }++ where+    unify :: CtLoc -> Role -> TcType -> TcType -> TcS (TcCoercion, Cts)+    -- This version returns the wanted constraint rather+    -- than putting it in the work list+    unify loc role ty1 ty2+      | ty1 `tcEqType` ty2+      = return (mkTcReflCo role ty1, emptyBag)+      | otherwise+      = do { (wanted, co) <- newWantedEq loc role ty1 ty2+           ; return (co, unitBag (mkNonCanonical wanted)) }++---------------------------------+-- | Compare types for equality, while zonking as necessary. Gives up+-- as soon as it finds that two types are not equal.+-- This is quite handy when some unification has made two+-- types in an inert Wanted to be equal. We can discover the equality without+-- flattening, which is sometimes very expensive (in the case of type functions).+-- In particular, this function makes a ~20% improvement in test case+-- perf/compiler/T5030.+--+-- Returns either the (partially zonked) types in the case of+-- inequality, or the one type in the case of equality. canEqReflexive is+-- a good next step in the 'Right' case. Returning 'Left' is always safe.+--+-- NB: This does *not* look through type synonyms. In fact, it treats type+-- synonyms as rigid constructors. In the future, it might be convenient+-- to look at only those arguments of type synonyms that actually appear+-- in the synonym RHS. But we're not there yet.+zonk_eq_types :: TcType -> TcType -> TcS (Either (Pair TcType) TcType)+zonk_eq_types = go+  where+    go (TyVarTy tv1) (TyVarTy tv2) = tyvar_tyvar tv1 tv2+    go (TyVarTy tv1) ty2           = tyvar NotSwapped tv1 ty2+    go ty1 (TyVarTy tv2)           = tyvar IsSwapped  tv2 ty1++    -- We handle FunTys explicitly here despite the fact that they could also be+    -- treated as an application. Why? Well, for one it's cheaper to just look+    -- at two types (the argument and result types) than four (the argument,+    -- result, and their RuntimeReps). Also, we haven't completely zonked yet,+    -- so we may run into an unzonked type variable while trying to compute the+    -- RuntimeReps of the argument and result types. This can be observed in+    -- testcase tc269.+    go ty1 ty2+      | Just (arg1, res1) <- split1+      , Just (arg2, res2) <- split2+      = do { res_a <- go arg1 arg2+           ; res_b <- go res1 res2+           ; return $ combine_rev mkVisFunTy res_b res_a+           }+      | isJust split1 || isJust split2+      = bale_out ty1 ty2+      where+        split1 = tcSplitFunTy_maybe ty1+        split2 = tcSplitFunTy_maybe ty2++    go ty1 ty2+      | Just (tc1, tys1) <- repSplitTyConApp_maybe ty1+      , Just (tc2, tys2) <- repSplitTyConApp_maybe ty2+      = if tc1 == tc2 && tys1 `equalLength` tys2+          -- Crucial to check for equal-length args, because+          -- we cannot assume that the two args to 'go' have+          -- the same kind.  E.g go (Proxy *      (Maybe Int))+          --                        (Proxy (*->*) Maybe)+          -- We'll call (go (Maybe Int) Maybe)+          -- See #13083+        then tycon tc1 tys1 tys2+        else bale_out ty1 ty2++    go ty1 ty2+      | Just (ty1a, ty1b) <- tcRepSplitAppTy_maybe ty1+      , Just (ty2a, ty2b) <- tcRepSplitAppTy_maybe ty2+      = do { res_a <- go ty1a ty2a+           ; res_b <- go ty1b ty2b+           ; return $ combine_rev mkAppTy res_b res_a }++    go ty1@(LitTy lit1) (LitTy lit2)+      | lit1 == lit2+      = return (Right ty1)++    go ty1 ty2 = bale_out ty1 ty2+      -- We don't handle more complex forms here++    bale_out ty1 ty2 = return $ Left (Pair ty1 ty2)++    tyvar :: SwapFlag -> TcTyVar -> TcType+          -> TcS (Either (Pair TcType) TcType)+      -- Try to do as little as possible, as anything we do here is redundant+      -- with flattening. In particular, no need to zonk kinds. That's why+      -- we don't use the already-defined zonking functions+    tyvar swapped tv ty+      = case tcTyVarDetails tv of+          MetaTv { mtv_ref = ref }+            -> do { cts <- readTcRef ref+                  ; case cts of+                      Flexi        -> give_up+                      Indirect ty' -> do { trace_indirect tv ty'+                                         ; unSwap swapped go ty' ty } }+          _ -> give_up+      where+        give_up = return $ Left $ unSwap swapped Pair (mkTyVarTy tv) ty++    tyvar_tyvar tv1 tv2+      | tv1 == tv2 = return (Right (mkTyVarTy tv1))+      | otherwise  = do { (ty1', progress1) <- quick_zonk tv1+                        ; (ty2', progress2) <- quick_zonk tv2+                        ; if progress1 || progress2+                          then go ty1' ty2'+                          else return $ Left (Pair (TyVarTy tv1) (TyVarTy tv2)) }++    trace_indirect tv ty+       = traceTcS "Following filled tyvar (zonk_eq_types)"+                  (ppr tv <+> equals <+> ppr ty)++    quick_zonk tv = case tcTyVarDetails tv of+      MetaTv { mtv_ref = ref }+        -> do { cts <- readTcRef ref+              ; case cts of+                  Flexi        -> return (TyVarTy tv, False)+                  Indirect ty' -> do { trace_indirect tv ty'+                                     ; return (ty', True) } }+      _ -> return (TyVarTy tv, False)++      -- This happens for type families, too. But recall that failure+      -- here just means to try harder, so it's OK if the type function+      -- isn't injective.+    tycon :: TyCon -> [TcType] -> [TcType]+          -> TcS (Either (Pair TcType) TcType)+    tycon tc tys1 tys2+      = do { results <- zipWithM go tys1 tys2+           ; return $ case combine_results results of+               Left tys  -> Left (mkTyConApp tc <$> tys)+               Right tys -> Right (mkTyConApp tc tys) }++    combine_results :: [Either (Pair TcType) TcType]+                    -> Either (Pair [TcType]) [TcType]+    combine_results = bimap (fmap reverse) reverse .+                      foldl' (combine_rev (:)) (Right [])++      -- combine (in reverse) a new result onto an already-combined result+    combine_rev :: (a -> b -> c)+                -> Either (Pair b) b+                -> Either (Pair a) a+                -> Either (Pair c) c+    combine_rev f (Left list) (Left elt) = Left (f <$> elt     <*> list)+    combine_rev f (Left list) (Right ty) = Left (f <$> pure ty <*> list)+    combine_rev f (Right tys) (Left elt) = Left (f <$> elt     <*> pure tys)+    combine_rev f (Right tys) (Right ty) = Right (f ty tys)++{- See Note [Unwrap newtypes first]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  newtype N m a = MkN (m a)+Then N will get a conservative, Nominal role for its second parameter 'a',+because it appears as an argument to the unknown 'm'. Now consider+  [W] N Maybe a  ~R#  N Maybe b++If we decompose, we'll get+  [W] a ~N# b++But if instead we unwrap we'll get+  [W] Maybe a ~R# Maybe b+which in turn gives us+  [W] a ~R# b+which is easier to satisfy.++Bottom line: unwrap newtypes before decomposing them!+c.f. #9123 comment:52,53 for a compelling example.++Note [Newtypes can blow the stack]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++  newtype X = MkX (Int -> X)+  newtype Y = MkY (Int -> Y)++and now wish to prove++  [W] X ~R Y++This Wanted will loop, expanding out the newtypes ever deeper looking+for a solid match or a solid discrepancy. Indeed, there is something+appropriate to this looping, because X and Y *do* have the same representation,+in the limit -- they're both (Fix ((->) Int)). However, no finitely-sized+coercion will ever witness it. This loop won't actually cause GHC to hang,+though, because we check our depth when unwrapping newtypes.++Note [Eager reflexivity check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++  newtype X = MkX (Int -> X)++and++  [W] X ~R X++Naively, we would start unwrapping X and end up in a loop. Instead,+we do this eager reflexivity check. This is necessary only for representational+equality because the flattener technology deals with the similar case+(recursive type families) for nominal equality.++Note that this check does not catch all cases, but it will catch the cases+we're most worried about, types like X above that are actually inhabited.++Here's another place where this reflexivity check is key:+Consider trying to prove (f a) ~R (f a). The AppTys in there can't+be decomposed, because representational equality isn't congruent with respect+to AppTy. So, when canonicalising the equality above, we get stuck and+would normally produce a CIrredCan. However, we really do want to+be able to solve (f a) ~R (f a). So, in the representational case only,+we do a reflexivity check.++(This would be sound in the nominal case, but unnecessary, and I [Richard+E.] am worried that it would slow down the common case.)+-}++------------------------+-- | We're able to unwrap a newtype. Update the bits accordingly.+can_eq_newtype_nc :: CtEvidence           -- ^ :: ty1 ~ ty2+                  -> SwapFlag+                  -> TcType                                    -- ^ ty1+                  -> ((Bag GlobalRdrElt, TcCoercion), TcType)  -- ^ :: ty1 ~ ty1'+                  -> TcType               -- ^ ty2+                  -> TcType               -- ^ ty2, with type synonyms+                  -> TcS (StopOrContinue Ct)+can_eq_newtype_nc ev swapped ty1 ((gres, co), ty1') ty2 ps_ty2+  = do { traceTcS "can_eq_newtype_nc" $+         vcat [ ppr ev, ppr swapped, ppr co, ppr gres, ppr ty1', ppr ty2 ]++         -- check for blowing our stack:+         -- See Note [Newtypes can blow the stack]+       ; checkReductionDepth (ctEvLoc ev) ty1+       ; addUsedGREs (bagToList gres)+           -- we have actually used the newtype constructor here, so+           -- make sure we don't warn about importing it!++       ; new_ev <- rewriteEqEvidence ev swapped ty1' ps_ty2+                                     (mkTcSymCo co) (mkTcReflCo Representational ps_ty2)+       ; can_eq_nc False new_ev ReprEq ty1' ty1' ty2 ps_ty2 }++---------+-- ^ Decompose a type application.+-- All input types must be flat. See Note [Canonicalising type applications]+-- Nominal equality only!+can_eq_app :: CtEvidence       -- :: s1 t1 ~N s2 t2+           -> Xi -> Xi         -- s1 t1+           -> Xi -> Xi         -- s2 t2+           -> TcS (StopOrContinue Ct)++-- AppTys only decompose for nominal equality, so this case just leads+-- to an irreducible constraint; see typecheck/should_compile/T10494+-- See Note [Decomposing equality], note {4}+can_eq_app ev s1 t1 s2 t2+  | CtDerived { ctev_loc = loc } <- ev+  = do { unifyDeriveds loc [Nominal, Nominal] [s1, t1] [s2, t2]+       ; stopWith ev "Decomposed [D] AppTy" }+  | CtWanted { ctev_dest = dest, ctev_loc = loc } <- ev+  = do { co_s <- unifyWanted loc Nominal s1 s2+       ; let arg_loc+               | isNextArgVisible s1 = loc+               | otherwise           = updateCtLocOrigin loc toInvisibleOrigin+       ; co_t <- unifyWanted arg_loc Nominal t1 t2+       ; let co = mkAppCo co_s co_t+       ; setWantedEq dest co+       ; stopWith ev "Decomposed [W] AppTy" }++    -- If there is a ForAll/(->) mismatch, the use of the Left coercion+    -- below is ill-typed, potentially leading to a panic in splitTyConApp+    -- Test case: typecheck/should_run/Typeable1+    -- We could also include this mismatch check above (for W and D), but it's slow+    -- and we'll get a better error message not doing it+  | s1k `mismatches` s2k+  = canEqHardFailure ev (s1 `mkAppTy` t1) (s2 `mkAppTy` t2)++  | CtGiven { ctev_evar = evar, ctev_loc = loc } <- ev+  = do { let co   = mkTcCoVarCo evar+             co_s = mkTcLRCo CLeft  co+             co_t = mkTcLRCo CRight co+       ; evar_s <- newGivenEvVar loc ( mkTcEqPredLikeEv ev s1 s2+                                     , evCoercion co_s )+       ; evar_t <- newGivenEvVar loc ( mkTcEqPredLikeEv ev t1 t2+                                     , evCoercion co_t )+       ; emitWorkNC [evar_t]+       ; canEqNC evar_s NomEq s1 s2 }++  where+    s1k = tcTypeKind s1+    s2k = tcTypeKind s2++    k1 `mismatches` k2+      =  isForAllTy k1 && not (isForAllTy k2)+      || not (isForAllTy k1) && isForAllTy k2++-----------------------+-- | Break apart an equality over a casted type+-- looking like   (ty1 |> co1) ~ ty2   (modulo a swap-flag)+canEqCast :: Bool         -- are both types flat?+          -> CtEvidence+          -> EqRel+          -> SwapFlag+          -> TcType -> Coercion   -- LHS (res. RHS), ty1 |> co1+          -> TcType -> TcType     -- RHS (res. LHS), ty2 both normal and pretty+          -> TcS (StopOrContinue Ct)+canEqCast flat ev eq_rel swapped ty1 co1 ty2 ps_ty2+  = do { traceTcS "Decomposing cast" (vcat [ ppr ev+                                           , ppr ty1 <+> text "|>" <+> ppr co1+                                           , ppr ps_ty2 ])+       ; new_ev <- rewriteEqEvidence ev swapped ty1 ps_ty2+                                     (mkTcGReflRightCo role ty1 co1)+                                     (mkTcReflCo role ps_ty2)+       ; can_eq_nc flat new_ev eq_rel ty1 ty1 ty2 ps_ty2 }+  where+    role = eqRelRole eq_rel++------------------------+canTyConApp :: CtEvidence -> EqRel+            -> TyCon -> [TcType]+            -> TyCon -> [TcType]+            -> TcS (StopOrContinue Ct)+-- See Note [Decomposing TyConApps]+canTyConApp ev eq_rel tc1 tys1 tc2 tys2+  | tc1 == tc2+  , tys1 `equalLength` tys2+  = do { inerts <- getTcSInerts+       ; if can_decompose inerts+         then do { traceTcS "canTyConApp"+                       (ppr ev $$ ppr eq_rel $$ ppr tc1 $$ ppr tys1 $$ ppr tys2)+                 ; canDecomposableTyConAppOK ev eq_rel tc1 tys1 tys2+                 ; stopWith ev "Decomposed TyConApp" }+         else canEqFailure ev eq_rel ty1 ty2 }++  -- See Note [Skolem abstract data] (at tyConSkolem)+  | tyConSkolem tc1 || tyConSkolem tc2+  = do { traceTcS "canTyConApp: skolem abstract" (ppr tc1 $$ ppr tc2)+       ; continueWith (mkIrredCt ev) }++  -- Fail straight away for better error messages+  -- See Note [Use canEqFailure in canDecomposableTyConApp]+  | eq_rel == ReprEq && not (isGenerativeTyCon tc1 Representational &&+                             isGenerativeTyCon tc2 Representational)+  = canEqFailure ev eq_rel ty1 ty2+  | otherwise+  = canEqHardFailure ev ty1 ty2+  where+    ty1 = mkTyConApp tc1 tys1+    ty2 = mkTyConApp tc2 tys2++    loc  = ctEvLoc ev+    pred = ctEvPred ev++     -- See Note [Decomposing equality]+    can_decompose inerts+      =  isInjectiveTyCon tc1 (eqRelRole eq_rel)+      || (ctEvFlavour ev /= Given && isEmptyBag (matchableGivens loc pred inerts))++{-+Note [Use canEqFailure in canDecomposableTyConApp]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must use canEqFailure, not canEqHardFailure here, because there is+the possibility of success if working with a representational equality.+Here is one case:++  type family TF a where TF Char = Bool+  data family DF a+  newtype instance DF Bool = MkDF Int++Suppose we are canonicalising (Int ~R DF (TF a)), where we don't yet+know `a`. This is *not* a hard failure, because we might soon learn+that `a` is, in fact, Char, and then the equality succeeds.++Here is another case:++  [G] Age ~R Int++where Age's constructor is not in scope. We don't want to report+an "inaccessible code" error in the context of this Given!++For example, see typecheck/should_compile/T10493, repeated here:++  import Data.Ord (Down)  -- no constructor++  foo :: Coercible (Down Int) Int => Down Int -> Int+  foo = coerce++That should compile, but only because we use canEqFailure and not+canEqHardFailure.++Note [Decomposing equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have a constraint (of any flavour and role) that looks like+T tys1 ~ T tys2, what can we conclude about tys1 and tys2? The answer,+of course, is "it depends". This Note spells it all out.++In this Note, "decomposition" refers to taking the constraint+  [fl] (T tys1 ~X T tys2)+(for some flavour fl and some role X) and replacing it with+  [fls'] (tys1 ~Xs' tys2)+where that notation indicates a list of new constraints, where the+new constraints may have different flavours and different roles.++The key property to consider is injectivity. When decomposing a Given the+decomposition is sound if and only if T is injective in all of its type+arguments. When decomposing a Wanted, the decomposition is sound (assuming the+correct roles in the produced equality constraints), but it may be a guess --+that is, an unforced decision by the constraint solver. Decomposing Wanteds+over injective TyCons does not entail guessing. But sometimes we want to+decompose a Wanted even when the TyCon involved is not injective! (See below.)++So, in broad strokes, we want this rule:++(*) Decompose a constraint (T tys1 ~X T tys2) if and only if T is injective+at role X.++Pursuing the details requires exploring three axes:+* Flavour: Given vs. Derived vs. Wanted+* Role: Nominal vs. Representational+* TyCon species: datatype vs. newtype vs. data family vs. type family vs. type variable++(So a type variable isn't a TyCon, but it's convenient to put the AppTy case+in the same table.)++Right away, we can say that Derived behaves just as Wanted for the purposes+of decomposition. The difference between Derived and Wanted is the handling of+evidence. Since decomposition in these cases isn't a matter of soundness but of+guessing, we want the same behavior regardless of evidence.++Here is a table (discussion following) detailing where decomposition of+   (T s1 ... sn) ~r (T t1 .. tn)+is allowed.  The first four lines (Data types ... type family) refer+to TyConApps with various TyCons T; the last line is for AppTy, where+there is presumably a type variable at the head, so it's actually+   (s s1 ... sn) ~r (t t1 .. tn)++NOMINAL               GIVEN                       WANTED++Datatype               YES                         YES+Newtype                YES                         YES+Data family            YES                         YES+Type family            YES, in injective args{1}   YES, in injective args{1}+Type variable          YES                         YES++REPRESENTATIONAL      GIVEN                       WANTED++Datatype               YES                         YES+Newtype                NO{2}                      MAYBE{2}+Data family            NO{3}                      MAYBE{3}+Type family             NO                          NO+Type variable          NO{4}                       NO{4}++{1}: Type families can be injective in some, but not all, of their arguments,+so we want to do partial decomposition. This is quite different than the way+other decomposition is done, where the decomposed equalities replace the original+one. We thus proceed much like we do with superclasses: emitting new Givens+when "decomposing" a partially-injective type family Given and new Deriveds+when "decomposing" a partially-injective type family Wanted. (As of the time of+writing, 13 June 2015, the implementation of injective type families has not+been merged, but it should be soon. Please delete this parenthetical if the+implementation is indeed merged.)++{2}: See Note [Decomposing newtypes at representational role]++{3}: Because of the possibility of newtype instances, we must treat+data families like newtypes. See also Note [Decomposing newtypes at+representational role]. See #10534 and test case+typecheck/should_fail/T10534.++{4}: Because type variables can stand in for newtypes, we conservatively do not+decompose AppTys over representational equality.++In the implementation of can_eq_nc and friends, we don't directly pattern+match using lines like in the tables above, as those tables don't cover+all cases (what about PrimTyCon? tuples?). Instead we just ask about injectivity,+boiling the tables above down to rule (*). The exceptions to rule (*) are for+injective type families, which are handled separately from other decompositions,+and the MAYBE entries above.++Note [Decomposing newtypes at representational role]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This note discusses the 'newtype' line in the REPRESENTATIONAL table+in Note [Decomposing equality]. (At nominal role, newtypes are fully+decomposable.)++Here is a representative example of why representational equality over+newtypes is tricky:++  newtype Nt a = Mk Bool         -- NB: a is not used in the RHS,+  type role Nt representational  -- but the user gives it an R role anyway++If we have [W] Nt alpha ~R Nt beta, we *don't* want to decompose to+[W] alpha ~R beta, because it's possible that alpha and beta aren't+representationally equal. Here's another example.++  newtype Nt a = MkNt (Id a)+  type family Id a where Id a = a++  [W] Nt Int ~R Nt Age++Because of its use of a type family, Nt's parameter will get inferred to have+a nominal role. Thus, decomposing the wanted will yield [W] Int ~N Age, which+is unsatisfiable. Unwrapping, though, leads to a solution.++Conclusion:+ * Unwrap newtypes before attempting to decompose them.+   This is done in can_eq_nc'.++It all comes from the fact that newtypes aren't necessarily injective+w.r.t. representational equality.++Furthermore, as explained in Note [NthCo and newtypes] in TyCoRep, we can't use+NthCo on representational coercions over newtypes. NthCo comes into play+only when decomposing givens.++Conclusion:+ * Do not decompose [G] N s ~R N t++Is it sensible to decompose *Wanted* constraints over newtypes?  Yes!+It's the only way we could ever prove (IO Int ~R IO Age), recalling+that IO is a newtype.++However we must be careful.  Consider++  type role Nt representational++  [G] Nt a ~R Nt b       (1)+  [W] NT alpha ~R Nt b   (2)+  [W] alpha ~ a          (3)++If we focus on (3) first, we'll substitute in (2), and now it's+identical to the given (1), so we succeed.  But if we focus on (2)+first, and decompose it, we'll get (alpha ~R b), which is not soluble.+This is exactly like the question of overlapping Givens for class+constraints: see Note [Instance and Given overlap] in TcInteract.++Conclusion:+  * Decompose [W] N s ~R N t  iff there no given constraint that could+    later solve it.+-}++canDecomposableTyConAppOK :: CtEvidence -> EqRel+                          -> TyCon -> [TcType] -> [TcType]+                          -> TcS ()+-- Precondition: tys1 and tys2 are the same length, hence "OK"+canDecomposableTyConAppOK ev eq_rel tc tys1 tys2+  = ASSERT( tys1 `equalLength` tys2 )+    case ev of+     CtDerived {}+        -> unifyDeriveds loc tc_roles tys1 tys2++     CtWanted { ctev_dest = dest }+                   -- new_locs and tc_roles are both infinite, so+                   -- we are guaranteed that cos has the same length+                   -- as tys1 and tys2+        -> do { cos <- zipWith4M unifyWanted new_locs tc_roles tys1 tys2+              ; setWantedEq dest (mkTyConAppCo role tc cos) }++     CtGiven { ctev_evar = evar }+        -> do { let ev_co = mkCoVarCo evar+              ; given_evs <- newGivenEvVars loc $+                             [ ( mkPrimEqPredRole r ty1 ty2+                               , evCoercion $ mkNthCo r i ev_co )+                             | (r, ty1, ty2, i) <- zip4 tc_roles tys1 tys2 [0..]+                             , r /= Phantom+                             , not (isCoercionTy ty1) && not (isCoercionTy ty2) ]+              ; emitWorkNC given_evs }+  where+    loc        = ctEvLoc ev+    role       = eqRelRole eq_rel++      -- infinite, as tyConRolesX returns an infinite tail of Nominal+    tc_roles   = tyConRolesX role tc++      -- Add nuances to the location during decomposition:+      --  * if the argument is a kind argument, remember this, so that error+      --    messages say "kind", not "type". This is determined based on whether+      --    the corresponding tyConBinder is named (that is, dependent)+      --  * if the argument is invisible, note this as well, again by+      --    looking at the corresponding binder+      -- For oversaturated tycons, we need the (repeat loc) tail, which doesn't+      -- do either of these changes. (Forgetting to do so led to #16188)+      --+      -- NB: infinite in length+    new_locs = [ new_loc+               | bndr <- tyConBinders tc+               , let new_loc0 | isNamedTyConBinder bndr = toKindLoc loc+                              | otherwise               = loc+                     new_loc  | isVisibleTyConBinder bndr+                              = updateCtLocOrigin new_loc0 toInvisibleOrigin+                              | otherwise+                              = new_loc0 ]+               ++ repeat loc++-- | Call when canonicalizing an equality fails, but if the equality is+-- representational, there is some hope for the future.+-- Examples in Note [Use canEqFailure in canDecomposableTyConApp]+canEqFailure :: CtEvidence -> EqRel+             -> TcType -> TcType -> TcS (StopOrContinue Ct)+canEqFailure ev NomEq ty1 ty2+  = canEqHardFailure ev ty1 ty2+canEqFailure ev ReprEq ty1 ty2+  = do { (xi1, co1) <- flatten FM_FlattenAll ev ty1+       ; (xi2, co2) <- flatten FM_FlattenAll ev ty2+            -- We must flatten the types before putting them in the+            -- inert set, so that we are sure to kick them out when+            -- new equalities become available+       ; traceTcS "canEqFailure with ReprEq" $+         vcat [ ppr ev, ppr ty1, ppr ty2, ppr xi1, ppr xi2 ]+       ; new_ev <- rewriteEqEvidence ev NotSwapped xi1 xi2 co1 co2+       ; continueWith (mkIrredCt new_ev) }++-- | Call when canonicalizing an equality fails with utterly no hope.+canEqHardFailure :: CtEvidence+                 -> TcType -> TcType -> TcS (StopOrContinue Ct)+-- See Note [Make sure that insolubles are fully rewritten]+canEqHardFailure ev ty1 ty2+  = do { (s1, co1) <- flatten FM_SubstOnly ev ty1+       ; (s2, co2) <- flatten FM_SubstOnly ev ty2+       ; new_ev <- rewriteEqEvidence ev NotSwapped s1 s2 co1 co2+       ; continueWith (mkInsolubleCt new_ev) }++{-+Note [Decomposing TyConApps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we see (T s1 t1 ~ T s2 t2), then we can just decompose to+  (s1 ~ s2, t1 ~ t2)+and push those back into the work list.  But if+  s1 = K k1    s2 = K k2+then we will just decomopose s1~s2, and it might be better to+do so on the spot.  An important special case is where s1=s2,+and we get just Refl.++So canDecomposableTyCon is a fast-path decomposition that uses+unifyWanted etc to short-cut that work.++Note [Canonicalising type applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given (s1 t1) ~ ty2, how should we proceed?+The simple things is to see if ty2 is of form (s2 t2), and+decompose.  By this time s1 and s2 can't be saturated type+function applications, because those have been dealt with+by an earlier equation in can_eq_nc, so it is always sound to+decompose.++However, over-eager decomposition gives bad error messages+for things like+   a b ~ Maybe c+   e f ~ p -> q+Suppose (in the first example) we already know a~Array.  Then if we+decompose the application eagerly, yielding+   a ~ Maybe+   b ~ c+we get an error        "Can't match Array ~ Maybe",+but we'd prefer to get "Can't match Array b ~ Maybe c".++So instead can_eq_wanted_app flattens the LHS and RHS, in the hope of+replacing (a b) by (Array b), before using try_decompose_app to+decompose it.++Note [Make sure that insolubles are fully rewritten]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When an equality fails, we still want to rewrite the equality+all the way down, so that it accurately reflects+ (a) the mutable reference substitution in force at start of solving+ (b) any ty-binds in force at this point in solving+See Note [Rewrite insolubles] in TcSMonad.+And if we don't do this there is a bad danger that+TcSimplify.applyTyVarDefaulting will find a variable+that has in fact been substituted.++Note [Do not decompose Given polytype equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider [G] (forall a. t1 ~ forall a. t2).  Can we decompose this?+No -- what would the evidence look like?  So instead we simply discard+this given evidence.+++Note [Combining insoluble constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As this point we have an insoluble constraint, like Int~Bool.++ * If it is Wanted, delete it from the cache, so that subsequent+   Int~Bool constraints give rise to separate error messages++ * But if it is Derived, DO NOT delete from cache.  A class constraint+   may get kicked out of the inert set, and then have its functional+   dependency Derived constraints generated a second time. In that+   case we don't want to get two (or more) error messages by+   generating two (or more) insoluble fundep constraints from the same+   class constraint.++Note [No top-level newtypes on RHS of representational equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we're in this situation:++ work item:  [W] c1 : a ~R b+     inert:  [G] c2 : b ~R Id a++where+  newtype Id a = Id a++We want to make sure canEqTyVar sees [W] a ~R a, after b is flattened+and the Id newtype is unwrapped. This is assured by requiring only flat+types in canEqTyVar *and* having the newtype-unwrapping check above+the tyvar check in can_eq_nc.++Note [Occurs check error]+~~~~~~~~~~~~~~~~~~~~~~~~~+If we have an occurs check error, are we necessarily hosed? Say our+tyvar is tv1 and the type it appears in is xi2. Because xi2 is function+free, then if we're computing w.r.t. nominal equality, then, yes, we're+hosed. Nothing good can come from (a ~ [a]). If we're computing w.r.t.+representational equality, this is a little subtler. Once again, (a ~R [a])+is a bad thing, but (a ~R N a) for a newtype N might be just fine. This+means also that (a ~ b a) might be fine, because `b` might become a newtype.++So, we must check: does tv1 appear in xi2 under any type constructor+that is generative w.r.t. representational equality? That's what+isInsolubleOccursCheck does.++See also #10715, which induced this addition.++Note [canCFunEqCan]+~~~~~~~~~~~~~~~~~~~+Flattening the arguments to a type family can change the kind of the type+family application. As an easy example, consider (Any k) where (k ~ Type)+is in the inert set. The original (Any k :: k) becomes (Any Type :: Type).+The problem here is that the fsk in the CFunEqCan will have the old kind.++The solution is to come up with a new fsk/fmv of the right kind. For+givens, this is easy: just introduce a new fsk and update the flat-cache+with the new one. For wanteds, we want to solve the old one if favor of+the new one, so we use dischargeFmv. This also kicks out constraints+from the inert set; this behavior is correct, as the kind-change may+allow more constraints to be solved.++We use `isTcReflexiveCo`, to ensure that we only use the hetero-kinded case+if we really need to.  Of course `flattenArgsNom` should return `Refl`+whenever possible, but #15577 was an infinite loop because even+though the coercion was homo-kinded, `kind_co` was not `Refl`, so we+made a new (identical) CFunEqCan, and then the entire process repeated.+-}++canCFunEqCan :: CtEvidence+             -> TyCon -> [TcType]   -- LHS+             -> TcTyVar             -- RHS+             -> TcS (StopOrContinue Ct)+-- ^ Canonicalise a CFunEqCan.  We know that+--     the arg types are already flat,+-- and the RHS is a fsk, which we must *not* substitute.+-- So just substitute in the LHS+canCFunEqCan ev fn tys fsk+  = do { (tys', cos, kind_co) <- flattenArgsNom ev fn tys+                        -- cos :: tys' ~ tys++       ; let lhs_co  = mkTcTyConAppCo Nominal fn cos+                        -- :: F tys' ~ F tys+             new_lhs = mkTyConApp fn tys'++             flav    = ctEvFlavour ev+       ; (ev', fsk')+           <- if isTcReflexiveCo kind_co   -- See Note [canCFunEqCan]+              then do { traceTcS "canCFunEqCan: refl" (ppr new_lhs)+                      ; let fsk_ty = mkTyVarTy fsk+                      ; ev' <- rewriteEqEvidence ev NotSwapped new_lhs fsk_ty+                                                 lhs_co (mkTcNomReflCo fsk_ty)+                      ; return (ev', fsk) }+              else do { traceTcS "canCFunEqCan: non-refl" $+                        vcat [ text "Kind co:" <+> ppr kind_co+                             , text "RHS:" <+> ppr fsk <+> dcolon <+> ppr (tyVarKind fsk)+                             , text "LHS:" <+> hang (ppr (mkTyConApp fn tys))+                                                  2 (dcolon <+> ppr (tcTypeKind (mkTyConApp fn tys)))+                             , text "New LHS" <+> hang (ppr new_lhs)+                                                     2 (dcolon <+> ppr (tcTypeKind new_lhs)) ]+                      ; (ev', new_co, new_fsk)+                          <- newFlattenSkolem flav (ctEvLoc ev) fn tys'+                      ; let xi = mkTyVarTy new_fsk `mkCastTy` kind_co+                               -- sym lhs_co :: F tys ~ F tys'+                               -- new_co     :: F tys' ~ new_fsk+                               -- co         :: F tys ~ (new_fsk |> kind_co)+                            co = mkTcSymCo lhs_co `mkTcTransCo`+                                 mkTcCoherenceRightCo Nominal+                                                      (mkTyVarTy new_fsk)+                                                      kind_co+                                                      new_co++                      ; traceTcS "Discharging fmv/fsk due to hetero flattening" (ppr ev)+                      ; dischargeFunEq ev fsk co xi+                      ; return (ev', new_fsk) }++       ; extendFlatCache fn tys' (ctEvCoercion ev', mkTyVarTy fsk', ctEvFlavour ev')+       ; continueWith (CFunEqCan { cc_ev = ev', cc_fun = fn+                                 , cc_tyargs = tys', cc_fsk = fsk' }) }++---------------------+canEqTyVar :: CtEvidence          -- ev :: lhs ~ rhs+           -> EqRel -> SwapFlag+           -> TcTyVar               -- tv1+           -> TcType                -- lhs: pretty lhs, already flat+           -> TcType -> TcType      -- rhs: already flat+           -> TcS (StopOrContinue Ct)+canEqTyVar ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2+  | k1 `tcEqType` k2+  = canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 xi2 ps_xi2++  -- So the LHS and RHS don't have equal kinds+  -- Note [Flattening] in TcFlatten gives us (F2), which says that+  -- flattening is always homogeneous (doesn't change kinds). But+  -- perhaps by flattening the kinds of the two sides of the equality+  -- at hand makes them equal. So let's try that.+  | otherwise+  = do { (flat_k1, k1_co) <- flattenKind loc flav k1  -- k1_co :: flat_k1 ~N kind(xi1)+       ; (flat_k2, k2_co) <- flattenKind loc flav k2  -- k2_co :: flat_k2 ~N kind(xi2)+       ; traceTcS "canEqTyVar tried flattening kinds"+                  (vcat [ sep [ parens (ppr tv1 <+> dcolon <+> ppr k1)+                              , text "~"+                              , parens (ppr xi2 <+> dcolon <+> ppr k2) ]+                        , ppr flat_k1+                        , ppr k1_co+                        , ppr flat_k2+                        , ppr k2_co ])++         -- We know the LHS is a tyvar. So let's dump all the coercions on the RHS+         -- If flat_k1 == flat_k2, let's dump all the coercions on the RHS and+         -- then call canEqTyVarHomo. If they don't equal, just rewriteEqEvidence+         -- (as an optimization, so that we don't have to flatten the kinds again)+         -- and then emit a kind equality in canEqTyVarHetero.+         -- See Note [Equalities with incompatible kinds]++       ; let role = eqRelRole eq_rel+       ; if flat_k1 `tcEqType` flat_k2+         then do { let rhs_kind_co = mkTcSymCo k2_co `mkTcTransCo` k1_co+                         -- :: kind(xi2) ~N kind(xi1)++                       new_rhs     = xi2 `mkCastTy` rhs_kind_co+                       ps_rhs      = ps_xi2 `mkCastTy` rhs_kind_co+                       rhs_co      = mkTcGReflLeftCo role xi2 rhs_kind_co++                 ; new_ev <- rewriteEqEvidence ev swapped xi1 new_rhs+                                               (mkTcReflCo role xi1) rhs_co+                       -- NB: rewriteEqEvidence executes a swap, if any, so we're+                       -- NotSwapped now.+                 ; canEqTyVarHomo new_ev eq_rel NotSwapped tv1 ps_ty1 new_rhs ps_rhs }+         else+    do { let sym_k1_co = mkTcSymCo k1_co  -- :: kind(xi1) ~N flat_k1+             sym_k2_co = mkTcSymCo k2_co  -- :: kind(xi2) ~N flat_k2++             new_lhs = xi1 `mkCastTy` sym_k1_co  -- :: flat_k1+             new_rhs = xi2 `mkCastTy` sym_k2_co  -- :: flat_k2+             ps_rhs  = ps_xi2 `mkCastTy` sym_k2_co++             lhs_co = mkTcGReflLeftCo role xi1 sym_k1_co+             rhs_co = mkTcGReflLeftCo role xi2 sym_k2_co+               -- lhs_co :: (xi1 |> sym k1_co) ~ xi1+               -- rhs_co :: (xi2 |> sym k2_co) ~ xi2++       ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co+         -- no longer swapped, due to rewriteEqEvidence+       ; canEqTyVarHetero new_ev eq_rel tv1 sym_k1_co flat_k1 ps_ty1+                                        new_rhs flat_k2 ps_rhs } }+  where+    xi1 = mkTyVarTy tv1++    k1 = tyVarKind tv1+    k2 = tcTypeKind xi2++    loc  = ctEvLoc ev+    flav = ctEvFlavour ev++canEqTyVarHetero :: CtEvidence   -- :: (tv1 |> co1 :: ki1) ~ (xi2 :: ki2)+                 -> EqRel+                 -> TcTyVar -> TcCoercionN -> TcKind  -- tv1 |> co1 :: ki1+                 -> TcType            -- pretty tv1 (*without* the coercion)+                 -> TcType -> TcKind  -- xi2 :: ki2+                 -> TcType            -- pretty xi2+                 -> TcS (StopOrContinue Ct)+canEqTyVarHetero ev eq_rel tv1 co1 ki1 ps_tv1 xi2 ki2 ps_xi2+  -- See Note [Equalities with incompatible kinds]+  | CtGiven { ctev_evar = evar } <- ev+    -- unswapped: tm :: (lhs :: ki1) ~ (rhs :: ki2)+    -- swapped  : tm :: (rhs :: ki2) ~ (lhs :: ki1)+  = do { let kind_co = mkTcKindCo (mkTcCoVarCo evar)+       ; kind_ev <- newGivenEvVar kind_loc (kind_pty, evCoercion kind_co)+       ; let  -- kind_ev :: (ki1 :: *) ~ (ki2 :: *)   (whether swapped or not)+              -- co1     :: kind(tv1) ~N ki1+              -- homo_co :: ki2 ~N kind(tv1)+             homo_co = mkTcSymCo (ctEvCoercion kind_ev) `mkTcTransCo` mkTcSymCo co1+             rhs'    = mkCastTy xi2 homo_co     -- :: kind(tv1)+             ps_rhs' = mkCastTy ps_xi2 homo_co  -- :: kind(tv1)+             rhs_co  = mkTcGReflLeftCo role xi2 homo_co+               -- rhs_co :: (xi2 |> homo_co :: kind(tv1)) ~ xi2++             lhs'   = mkTyVarTy tv1       -- :: kind(tv1)+             lhs_co = mkTcGReflRightCo role lhs' co1+               -- lhs_co :: (tv1 :: kind(tv1)) ~ (tv1 |> co1 :: ki1)++       ; traceTcS "Hetero equality gives rise to given kind equality"+           (ppr kind_ev <+> dcolon <+> ppr kind_pty)+       ; emitWorkNC [kind_ev]+       ; type_ev <- rewriteEqEvidence ev NotSwapped lhs' rhs' lhs_co rhs_co+       ; canEqTyVarHomo type_ev eq_rel NotSwapped tv1 ps_tv1 rhs' ps_rhs' }++  -- See Note [Equalities with incompatible kinds]+  | otherwise   -- Wanted and Derived+                -- NB: all kind equalities are Nominal+  = do { emitNewDerivedEq kind_loc Nominal ki1 ki2+             -- kind_ev :: (ki1 :: *) ~ (ki2 :: *)+       ; traceTcS "Hetero equality gives rise to derived kind equality" $+           ppr ev+       ; continueWith (mkIrredCt ev) }++  where+    kind_pty = mkHeteroPrimEqPred liftedTypeKind liftedTypeKind ki1 ki2+    kind_loc = mkKindLoc (mkTyVarTy tv1 `mkCastTy` co1) xi2 loc++    loc  = ctev_loc ev+    role = eqRelRole eq_rel++-- guaranteed that tcTypeKind lhs == tcTypeKind rhs+canEqTyVarHomo :: CtEvidence+               -> EqRel -> SwapFlag+               -> TcTyVar                -- lhs: tv1+               -> TcType                 -- pretty lhs+               -> TcType -> TcType       -- rhs (might not be flat)+               -> TcS (StopOrContinue Ct)+canEqTyVarHomo ev eq_rel swapped tv1 ps_ty1 ty2 _+  | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2+  , tv1 == tv2+  = canEqReflexive ev eq_rel (mkTyVarTy tv1)+    -- we don't need to check co because it must be reflexive++  | Just (tv2, co2) <- tcGetCastedTyVar_maybe ty2+  , swapOverTyVars tv1 tv2+  = do { traceTcS "canEqTyVar swapOver" (ppr tv1 $$ ppr tv2 $$ ppr swapped)+         -- FM_Avoid commented out: see Note [Lazy flattening] in TcFlatten+         -- let fmode = FE { fe_ev = ev, fe_mode = FM_Avoid tv1' True }+         -- Flatten the RHS less vigorously, to avoid gratuitous flattening+         -- True <=> xi2 should not itself be a type-function application++       ; let role    = eqRelRole eq_rel+             sym_co2 = mkTcSymCo co2+             ty1     = mkTyVarTy tv1+             new_lhs = ty1 `mkCastTy` sym_co2+             lhs_co  = mkTcGReflLeftCo role ty1 sym_co2++             new_rhs = mkTyVarTy tv2+             rhs_co  = mkTcGReflRightCo role new_rhs co2++       ; new_ev <- rewriteEqEvidence ev swapped new_lhs new_rhs lhs_co rhs_co++       ; dflags <- getDynFlags+       ; canEqTyVar2 dflags new_ev eq_rel IsSwapped tv2 (ps_ty1 `mkCastTy` sym_co2) }++canEqTyVarHomo ev eq_rel swapped tv1 _ _ ps_ty2+  = do { dflags <- getDynFlags+       ; canEqTyVar2 dflags ev eq_rel swapped tv1 ps_ty2 }++-- The RHS here is either not a casted tyvar, or it's a tyvar but we want+-- to rewrite the LHS to the RHS (as per swapOverTyVars)+canEqTyVar2 :: DynFlags+            -> CtEvidence   -- lhs ~ rhs (or, if swapped, orhs ~ olhs)+            -> EqRel+            -> SwapFlag+            -> TcTyVar                  -- lhs = tv, flat+            -> TcType                   -- rhs+            -> TcS (StopOrContinue Ct)+-- LHS is an inert type variable,+-- and RHS is fully rewritten, but with type synonyms+-- preserved as much as possible+canEqTyVar2 dflags ev eq_rel swapped tv1 rhs+  | Just rhs' <- metaTyVarUpdateOK dflags tv1 rhs  -- No occurs check+     -- Must do the occurs check even on tyvar/tyvar+     -- equalities, in case have  x ~ (y :: ..x...)+     -- #12593+  = do { new_ev <- rewriteEqEvidence ev swapped lhs rhs' rewrite_co1 rewrite_co2+       ; continueWith (CTyEqCan { cc_ev = new_ev, cc_tyvar = tv1+                                , cc_rhs = rhs', cc_eq_rel = eq_rel }) }++  | otherwise  -- For some reason (occurs check, or forall) we can't unify+               -- We must not use it for further rewriting!+  = do { traceTcS "canEqTyVar2 can't unify" (ppr tv1 $$ ppr rhs)+       ; new_ev <- rewriteEqEvidence ev swapped lhs rhs rewrite_co1 rewrite_co2+       ; if isInsolubleOccursCheck eq_rel tv1 rhs+         then continueWith (mkInsolubleCt new_ev)+             -- If we have a ~ [a], it is not canonical, and in particular+             -- we don't want to rewrite existing inerts with it, otherwise+             -- we'd risk divergence in the constraint solver++         else continueWith (mkIrredCt new_ev) }+             -- A representational equality with an occurs-check problem isn't+             -- insoluble! For example:+             --   a ~R b a+             -- We might learn that b is the newtype Id.+             -- But, the occurs-check certainly prevents the equality from being+             -- canonical, and we might loop if we were to use it in rewriting.+  where+    role = eqRelRole eq_rel++    lhs = mkTyVarTy tv1++    rewrite_co1  = mkTcReflCo role lhs+    rewrite_co2  = mkTcReflCo role rhs++-- | Solve a reflexive equality constraint+canEqReflexive :: CtEvidence    -- ty ~ ty+               -> EqRel+               -> TcType        -- ty+               -> TcS (StopOrContinue Ct)   -- always Stop+canEqReflexive ev eq_rel ty+  = do { setEvBindIfWanted ev (evCoercion $+                               mkTcReflCo (eqRelRole eq_rel) ty)+       ; stopWith ev "Solved by reflexivity" }++{-+Note [Canonical orientation for tyvar/tyvar equality constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have a ~ b where both 'a' and 'b' are TcTyVars, which way+round should be oriented in the CTyEqCan?  The rules, implemented by+canEqTyVarTyVar, are these++ * If either is a flatten-meta-variables, it goes on the left.++ * Put a meta-tyvar on the left if possible+       alpha[3] ~ r++ * If both are meta-tyvars, put the more touchable one (deepest level+   number) on the left, so there is the best chance of unifying it+        alpha[3] ~ beta[2]++ * If both are meta-tyvars and both at the same level, put a TyVarTv+   on the right if possible+        alpha[2] ~ beta[2](sig-tv)+   That way, when we unify alpha := beta, we don't lose the TyVarTv flag.++ * Put a meta-tv with a System Name on the left if possible so it+   gets eliminated (improves error messages)++ * If one is a flatten-skolem, put it on the left so that it is+   substituted out  Note [Eliminate flat-skols] in TcUinfy+        fsk ~ a++Note [Equalities with incompatible kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What do we do when we have an equality++  (tv :: k1) ~ (rhs :: k2)++where k1 and k2 differ? This Note explores this treacherous area.++First off, the question above is slightly the wrong question. Flattening+a tyvar will flatten its kind (Note [Flattening] in TcFlatten); flattening+the kind might introduce a cast. So we might have a casted tyvar on the+left. We thus revise our test case to++  (tv |> co :: k1) ~ (rhs :: k2)++We must proceed differently here depending on whether we have a Wanted+or a Given. Consider this:++ [W] w :: (alpha :: k) ~ (Int :: Type)++where k is a skolem. One possible way forward is this:++ [W] co :: k ~ Type+ [W] w :: (alpha :: k) ~ (Int |> sym co :: k)++The next step will be to unify++  alpha := Int |> sym co++Now, consider what error we'll report if we can't solve the "co"+wanted. Its CtOrigin is the w wanted... which now reads (after zonking)+Int ~ Int. The user thus sees that GHC can't solve Int ~ Int, which+is embarrassing. See #11198 for more tales of destruction.++The reason for this odd behavior is much the same as+Note [Wanteds do not rewrite Wanteds] in TcRnTypes: note that the+new `co` is a Wanted.++   The solution is then not to use `co` to "rewrite" -- that is, cast+   -- `w`, but instead to keep `w` heterogeneous and+   irreducible. Given that we're not using `co`, there is no reason to+   collect evidence for it, so `co` is born a Derived, with a CtOrigin+   of KindEqOrigin.++When the Derived is solved (by unification), the original wanted (`w`)+will get kicked out.++Note that, if we had [G] co1 :: k ~ Type available, then none of this code would+trigger, because flattening would have rewritten k to Type. That is,+`w` would look like [W] (alpha |> co1 :: Type) ~ (Int :: Type), and the tyvar+case will trigger, correctly rewriting alpha to (Int |> sym co1).++Successive canonicalizations of the same Wanted may produce+duplicate Deriveds. Similar duplications can happen with fundeps, and there+seems to be no easy way to avoid. I expect this case to be rare.++For Givens, this problem doesn't bite, so a heterogeneous Given gives+rise to a Given kind equality. No Deriveds here. We thus homogenise+the Given (see the "homo_co" in the Given case in canEqTyVar) and+carry on with a homogeneous equality constraint.++Separately, I (Richard E) spent some time pondering what to do in the case+that we have [W] (tv |> co1 :: k1) ~ (tv |> co2 :: k2) where k1 and k2+differ. Note that the tv is the same. (This case is handled as the first+case in canEqTyVarHomo.) At one point, I thought we could solve this limited+form of heterogeneous Wanted, but I then reconsidered and now treat this case+just like any other heterogeneous Wanted.++Note [Type synonyms and canonicalization]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We treat type synonym applications as xi types, that is, they do not+count as type function applications.  However, we do need to be a bit+careful with type synonyms: like type functions they may not be+generative or injective.  However, unlike type functions, they are+parametric, so there is no problem in expanding them whenever we see+them, since we do not need to know anything about their arguments in+order to expand them; this is what justifies not having to treat them+as specially as type function applications.  The thing that causes+some subtleties is that we prefer to leave type synonym applications+*unexpanded* whenever possible, in order to generate better error+messages.++If we encounter an equality constraint with type synonym applications+on both sides, or a type synonym application on one side and some sort+of type application on the other, we simply must expand out the type+synonyms in order to continue decomposing the equality constraint into+primitive equality constraints.  For example, suppose we have++  type F a = [Int]++and we encounter the equality++  F a ~ [b]++In order to continue we must expand F a into [Int], giving us the+equality++  [Int] ~ [b]++which we can then decompose into the more primitive equality+constraint++  Int ~ b.++However, if we encounter an equality constraint with a type synonym+application on one side and a variable on the other side, we should+NOT (necessarily) expand the type synonym, since for the purpose of+good error messages we want to leave type synonyms unexpanded as much+as possible.  Hence the ps_ty1, ps_ty2 argument passed to canEqTyVar.++-}++{-+************************************************************************+*                                                                      *+                  Evidence transformation+*                                                                      *+************************************************************************+-}++data StopOrContinue a+  = ContinueWith a    -- The constraint was not solved, although it may have+                      --   been rewritten++  | Stop CtEvidence   -- The (rewritten) constraint was solved+         SDoc         -- Tells how it was solved+                      -- Any new sub-goals have been put on the work list++instance Functor StopOrContinue where+  fmap f (ContinueWith x) = ContinueWith (f x)+  fmap _ (Stop ev s)      = Stop ev s++instance Outputable a => Outputable (StopOrContinue a) where+  ppr (Stop ev s)      = text "Stop" <> parens s <+> ppr ev+  ppr (ContinueWith w) = text "ContinueWith" <+> ppr w++continueWith :: a -> TcS (StopOrContinue a)+continueWith = return . ContinueWith++stopWith :: CtEvidence -> String -> TcS (StopOrContinue a)+stopWith ev s = return (Stop ev (text s))++andWhenContinue :: TcS (StopOrContinue a)+                -> (a -> TcS (StopOrContinue b))+                -> TcS (StopOrContinue b)+andWhenContinue tcs1 tcs2+  = do { r <- tcs1+       ; case r of+           Stop ev s       -> return (Stop ev s)+           ContinueWith ct -> tcs2 ct }+infixr 0 `andWhenContinue`    -- allow chaining with ($)++rewriteEvidence :: CtEvidence   -- old evidence+                -> TcPredType   -- new predicate+                -> TcCoercion   -- Of type :: new predicate ~ <type of old evidence>+                -> TcS (StopOrContinue CtEvidence)+-- Returns Just new_ev iff either (i)  'co' is reflexivity+--                             or (ii) 'co' is not reflexivity, and 'new_pred' not cached+-- In either case, there is nothing new to do with new_ev+{-+     rewriteEvidence old_ev new_pred co+Main purpose: create new evidence for new_pred;+              unless new_pred is cached already+* Returns a new_ev : new_pred, with same wanted/given/derived flag as old_ev+* If old_ev was wanted, create a binding for old_ev, in terms of new_ev+* If old_ev was given, AND not cached, create a binding for new_ev, in terms of old_ev+* Returns Nothing if new_ev is already cached++        Old evidence    New predicate is               Return new evidence+        flavour                                        of same flavor+        -------------------------------------------------------------------+        Wanted          Already solved or in inert     Nothing+        or Derived      Not                            Just new_evidence++        Given           Already in inert               Nothing+                        Not                            Just new_evidence++Note [Rewriting with Refl]+~~~~~~~~~~~~~~~~~~~~~~~~~~+If the coercion is just reflexivity then you may re-use the same+variable.  But be careful!  Although the coercion is Refl, new_pred+may reflect the result of unification alpha := ty, so new_pred might+not _look_ the same as old_pred, and it's vital to proceed from now on+using new_pred.++qThe flattener preserves type synonyms, so they should appear in new_pred+as well as in old_pred; that is important for good error messages.+ -}+++rewriteEvidence old_ev@(CtDerived {}) new_pred _co+  = -- If derived, don't even look at the coercion.+    -- This is very important, DO NOT re-order the equations for+    -- rewriteEvidence to put the isTcReflCo test first!+    -- Why?  Because for *Derived* constraints, c, the coercion, which+    -- was produced by flattening, may contain suspended calls to+    -- (ctEvExpr c), which fails for Derived constraints.+    -- (Getting this wrong caused #7384.)+    continueWith (old_ev { ctev_pred = new_pred })++rewriteEvidence old_ev new_pred co+  | isTcReflCo co -- See Note [Rewriting with Refl]+  = continueWith (old_ev { ctev_pred = new_pred })++rewriteEvidence ev@(CtGiven { ctev_evar = old_evar, ctev_loc = loc }) new_pred co+  = do { new_ev <- newGivenEvVar loc (new_pred, new_tm)+       ; continueWith new_ev }+  where+    -- mkEvCast optimises ReflCo+    new_tm = mkEvCast (evId old_evar) (tcDowngradeRole Representational+                                                       (ctEvRole ev)+                                                       (mkTcSymCo co))++rewriteEvidence ev@(CtWanted { ctev_dest = dest+                             , ctev_loc = loc }) new_pred co+  = do { mb_new_ev <- newWanted loc new_pred+       ; MASSERT( tcCoercionRole co == ctEvRole ev )+       ; setWantedEvTerm dest+            (mkEvCast (getEvExpr mb_new_ev)+                      (tcDowngradeRole Representational (ctEvRole ev) co))+       ; case mb_new_ev of+            Fresh  new_ev -> continueWith new_ev+            Cached _      -> stopWith ev "Cached wanted" }+++rewriteEqEvidence :: CtEvidence         -- Old evidence :: olhs ~ orhs (not swapped)+                                        --              or orhs ~ olhs (swapped)+                  -> SwapFlag+                  -> TcType -> TcType   -- New predicate  nlhs ~ nrhs+                                        -- Should be zonked, because we use tcTypeKind on nlhs/nrhs+                  -> TcCoercion         -- lhs_co, of type :: nlhs ~ olhs+                  -> TcCoercion         -- rhs_co, of type :: nrhs ~ orhs+                  -> TcS CtEvidence     -- Of type nlhs ~ nrhs+-- For (rewriteEqEvidence (Given g olhs orhs) False nlhs nrhs lhs_co rhs_co)+-- we generate+-- If not swapped+--      g1 : nlhs ~ nrhs = lhs_co ; g ; sym rhs_co+-- If 'swapped'+--      g1 : nlhs ~ nrhs = lhs_co ; Sym g ; sym rhs_co+--+-- For (Wanted w) we do the dual thing.+-- New  w1 : nlhs ~ nrhs+-- If not swapped+--      w : olhs ~ orhs = sym lhs_co ; w1 ; rhs_co+-- If swapped+--      w : orhs ~ olhs = sym rhs_co ; sym w1 ; lhs_co+--+-- It's all a form of rewwriteEvidence, specialised for equalities+rewriteEqEvidence old_ev swapped nlhs nrhs lhs_co rhs_co+  | CtDerived {} <- old_ev  -- Don't force the evidence for a Derived+  = return (old_ev { ctev_pred = new_pred })++  | NotSwapped <- swapped+  , isTcReflCo lhs_co      -- See Note [Rewriting with Refl]+  , isTcReflCo rhs_co+  = return (old_ev { ctev_pred = new_pred })++  | CtGiven { ctev_evar = old_evar } <- old_ev+  = do { let new_tm = evCoercion (lhs_co+                                  `mkTcTransCo` maybeSym swapped (mkTcCoVarCo old_evar)+                                  `mkTcTransCo` mkTcSymCo rhs_co)+       ; newGivenEvVar loc' (new_pred, new_tm) }++  | CtWanted { ctev_dest = dest } <- old_ev+  = do { (new_ev, hole_co) <- newWantedEq loc' (ctEvRole old_ev) nlhs nrhs+       ; let co = maybeSym swapped $+                  mkSymCo lhs_co+                  `mkTransCo` hole_co+                  `mkTransCo` rhs_co+       ; setWantedEq dest co+       ; traceTcS "rewriteEqEvidence" (vcat [ppr old_ev, ppr nlhs, ppr nrhs, ppr co])+       ; return new_ev }++  | otherwise+  = panic "rewriteEvidence"+  where+    new_pred = mkTcEqPredLikeEv old_ev nlhs nrhs++      -- equality is like a type class. Bumping the depth is necessary because+      -- of recursive newtypes, where "reducing" a newtype can actually make+      -- it bigger. See Note [Newtypes can blow the stack].+    loc      = ctEvLoc old_ev+    loc'     = bumpCtLocDepth loc++{- Note [unifyWanted and unifyDerived]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When decomposing equalities we often create new wanted constraints for+(s ~ t).  But what if s=t?  Then it'd be faster to return Refl right away.+Similar remarks apply for Derived.++Rather than making an equality test (which traverses the structure of the+type, perhaps fruitlessly), unifyWanted traverses the common structure, and+bales out when it finds a difference by creating a new Wanted constraint.+But where it succeeds in finding common structure, it just builds a coercion+to reflect it.+-}++unifyWanted :: CtLoc -> Role+            -> TcType -> TcType -> TcS Coercion+-- Return coercion witnessing the equality of the two types,+-- emitting new work equalities where necessary to achieve that+-- Very good short-cut when the two types are equal, or nearly so+-- See Note [unifyWanted and unifyDerived]+-- The returned coercion's role matches the input parameter+unifyWanted loc Phantom ty1 ty2+  = do { kind_co <- unifyWanted loc Nominal (tcTypeKind ty1) (tcTypeKind ty2)+       ; return (mkPhantomCo kind_co ty1 ty2) }++unifyWanted loc role orig_ty1 orig_ty2+  = go orig_ty1 orig_ty2+  where+    go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2+    go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2'++    go (FunTy _ s1 t1) (FunTy _ s2 t2)+      = do { co_s <- unifyWanted loc role s1 s2+           ; co_t <- unifyWanted loc role t1 t2+           ; return (mkFunCo role co_s co_t) }+    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      | tc1 == tc2, tys1 `equalLength` tys2+      , isInjectiveTyCon tc1 role -- don't look under newtypes at Rep equality+      = do { cos <- zipWith3M (unifyWanted loc)+                              (tyConRolesX role tc1) tys1 tys2+           ; return (mkTyConAppCo role tc1 cos) }++    go ty1@(TyVarTy tv) ty2+      = do { mb_ty <- isFilledMetaTyVar_maybe tv+           ; case mb_ty of+                Just ty1' -> go ty1' ty2+                Nothing   -> bale_out ty1 ty2}+    go ty1 ty2@(TyVarTy tv)+      = do { mb_ty <- isFilledMetaTyVar_maybe tv+           ; case mb_ty of+                Just ty2' -> go ty1 ty2'+                Nothing   -> bale_out ty1 ty2 }++    go ty1@(CoercionTy {}) (CoercionTy {})+      = return (mkReflCo role ty1) -- we just don't care about coercions!++    go ty1 ty2 = bale_out ty1 ty2++    bale_out ty1 ty2+       | ty1 `tcEqType` ty2 = return (mkTcReflCo role ty1)+        -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)+       | otherwise = emitNewWantedEq loc role orig_ty1 orig_ty2++unifyDeriveds :: CtLoc -> [Role] -> [TcType] -> [TcType] -> TcS ()+-- See Note [unifyWanted and unifyDerived]+unifyDeriveds loc roles tys1 tys2 = zipWith3M_ (unify_derived loc) roles tys1 tys2++unifyDerived :: CtLoc -> Role -> Pair TcType -> TcS ()+-- See Note [unifyWanted and unifyDerived]+unifyDerived loc role (Pair ty1 ty2) = unify_derived loc role ty1 ty2++unify_derived :: CtLoc -> Role -> TcType -> TcType -> TcS ()+-- Create new Derived and put it in the work list+-- Should do nothing if the two types are equal+-- See Note [unifyWanted and unifyDerived]+unify_derived _   Phantom _        _        = return ()+unify_derived loc role    orig_ty1 orig_ty2+  = go orig_ty1 orig_ty2+  where+    go ty1 ty2 | Just ty1' <- tcView ty1 = go ty1' ty2+    go ty1 ty2 | Just ty2' <- tcView ty2 = go ty1 ty2'++    go (FunTy _ s1 t1) (FunTy _ s2 t2)+      = do { unify_derived loc role s1 s2+           ; unify_derived loc role t1 t2 }+    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      | tc1 == tc2, tys1 `equalLength` tys2+      , isInjectiveTyCon tc1 role+      = unifyDeriveds loc (tyConRolesX role tc1) tys1 tys2+    go ty1@(TyVarTy tv) ty2+      = do { mb_ty <- isFilledMetaTyVar_maybe tv+           ; case mb_ty of+                Just ty1' -> go ty1' ty2+                Nothing   -> bale_out ty1 ty2 }+    go ty1 ty2@(TyVarTy tv)+      = do { mb_ty <- isFilledMetaTyVar_maybe tv+           ; case mb_ty of+                Just ty2' -> go ty1 ty2'+                Nothing   -> bale_out ty1 ty2 }+    go ty1 ty2 = bale_out ty1 ty2++    bale_out ty1 ty2+       | ty1 `tcEqType` ty2 = return ()+        -- Check for equality; e.g. a ~ a, or (m a) ~ (m a)+       | otherwise = emitNewDerivedEq loc role orig_ty1 orig_ty2++maybeSym :: SwapFlag -> TcCoercion -> TcCoercion+maybeSym IsSwapped  co = mkTcSymCo co+maybeSym NotSwapped co = co
+ compiler/typecheck/TcClassDcl.hs view
@@ -0,0 +1,551 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Typechecking class declarations+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}++module TcClassDcl ( tcClassSigs, tcClassDecl2,+                    findMethodBind, instantiateMethod,+                    tcClassMinimalDef,+                    HsSigFun, mkHsSigFun,+                    tcMkDeclCtxt, tcAddDeclCtxt, badMethodErr,+                    instDeclCtxt1, instDeclCtxt2, instDeclCtxt3,+                    tcATDefault+                  ) where++#include "HsVersions.h"++import GhcPrelude++import HsSyn+import TcEnv+import TcSigs+import TcEvidence ( idHsWrapper )+import TcBinds+import TcUnify+import TcHsType+import TcMType+import Type     ( getClassPredTys_maybe, piResultTys )+import TcType+import TcRnMonad+import DriverPhases (HscSource(..))+import BuildTyCl( TcMethInfo )+import Class+import Coercion ( pprCoAxiom )+import DynFlags+import FamInst+import FamInstEnv+import Id+import Name+import NameEnv+import NameSet+import Var+import VarEnv+import Outputable+import SrcLoc+import TyCon+import Maybes+import BasicTypes+import Bag+import FastString+import BooleanFormula+import Util++import Control.Monad+import Data.List ( mapAccumL, partition )++{-+Dictionary handling+~~~~~~~~~~~~~~~~~~~+Every class implicitly declares a new data type, corresponding to dictionaries+of that class. So, for example:++        class (D a) => C a where+          op1 :: a -> a+          op2 :: forall b. Ord b => a -> b -> b++would implicitly declare++        data CDict a = CDict (D a)+                             (a -> a)+                             (forall b. Ord b => a -> b -> b)++(We could use a record decl, but that means changing more of the existing apparatus.+One step at at time!)++For classes with just one superclass+method, we use a newtype decl instead:++        class C a where+          op :: forallb. a -> b -> b++generates++        newtype CDict a = CDict (forall b. a -> b -> b)++Now DictTy in Type is just a form of type synomym:+        DictTy c t = TyConTy CDict `AppTy` t++Death to "ExpandingDicts".+++************************************************************************+*                                                                      *+                Type-checking the class op signatures+*                                                                      *+************************************************************************+-}++illegalHsigDefaultMethod :: Name -> SDoc+illegalHsigDefaultMethod n =+    text "Illegal default method(s) in class definition of" <+> ppr n <+> text "in hsig file"++tcClassSigs :: Name                -- Name of the class+            -> [LSig GhcRn]+            -> LHsBinds GhcRn+            -> TcM [TcMethInfo]    -- Exactly one for each method+tcClassSigs clas sigs def_methods+  = do { traceTc "tcClassSigs 1" (ppr clas)++       ; gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs+       ; let gen_dm_env :: NameEnv (SrcSpan, Type)+             gen_dm_env = mkNameEnv gen_dm_prs++       ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs++       ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ]+       ; sequence_ [ failWithTc (badMethodErr clas n)+                   | n <- dm_bind_names, not (n `elemNameSet` op_names) ]+                   -- Value binding for non class-method (ie no TypeSig)++       ; tcg_env <- getGblEnv+       ; if tcg_src tcg_env == HsigFile+            then+               -- Error if we have value bindings+               -- (Generic signatures without value bindings indicate+               -- that a default of this form is expected to be+               -- provided.)+               when (not (null def_methods)) $+                failWithTc (illegalHsigDefaultMethod clas)+            else+               -- Error for each generic signature without value binding+               sequence_ [ failWithTc (badGenericMethod clas n)+                         | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ]++       ; traceTc "tcClassSigs 2" (ppr clas)+       ; return op_info }+  where+    vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig _ False nm ty) <- sigs]+    gen_sigs     = [L loc (nm,ty) | L loc (ClassOpSig _ True  nm ty) <- sigs]+    dm_bind_names :: [Name] -- These ones have a value binding in the class decl+    dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods]++    skol_info = TyConSkol ClassFlavour clas++    tc_sig :: NameEnv (SrcSpan, Type) -> ([Located Name], LHsSigType GhcRn)+           -> TcM [TcMethInfo]+    tc_sig gen_dm_env (op_names, op_hs_ty)+      = do { traceTc "ClsSig 1" (ppr op_names)+           ; op_ty <- tcClassSigType skol_info op_names op_hs_ty+                   -- Class tyvars already in scope++           ; traceTc "ClsSig 2" (ppr op_names)+           ; return [ (op_name, op_ty, f op_name) | L _ op_name <- op_names ] }+           where+             f nm | Just lty <- lookupNameEnv gen_dm_env nm = Just (GenericDM lty)+                  | nm `elem` dm_bind_names                 = Just VanillaDM+                  | otherwise                               = Nothing++    tc_gen_sig (op_names, gen_hs_ty)+      = do { gen_op_ty <- tcClassSigType skol_info op_names gen_hs_ty+           ; return [ (op_name, (loc, gen_op_ty)) | L loc op_name <- op_names ] }++{-+************************************************************************+*                                                                      *+                Class Declarations+*                                                                      *+************************************************************************+-}++tcClassDecl2 :: LTyClDecl GhcRn          -- The class declaration+             -> TcM (LHsBinds GhcTcId)++tcClassDecl2 (L _ (ClassDecl {tcdLName = class_name, tcdSigs = sigs,+                                tcdMeths = default_binds}))+  = recoverM (return emptyLHsBinds)     $+    setSrcSpan (getLoc class_name)      $+    do  { clas <- tcLookupLocatedClass class_name++        -- We make a separate binding for each default method.+        -- At one time I used a single AbsBinds for all of them, thus+        -- AbsBind [d] [dm1, dm2, dm3] { dm1 = ...; dm2 = ...; dm3 = ... }+        -- But that desugars into+        --      ds = \d -> (..., ..., ...)+        --      dm1 = \d -> case ds d of (a,b,c) -> a+        -- And since ds is big, it doesn't get inlined, so we don't get good+        -- default methods.  Better to make separate AbsBinds for each+        ; let (tyvars, _, _, op_items) = classBigSig clas+              prag_fn     = mkPragEnv sigs default_binds+              sig_fn      = mkHsSigFun sigs+              clas_tyvars = snd (tcSuperSkolTyVars tyvars)+              pred        = mkClassPred clas (mkTyVarTys clas_tyvars)+        ; this_dict <- newEvVar pred++        ; let tc_item = tcDefMeth clas clas_tyvars this_dict+                                  default_binds sig_fn prag_fn+        ; dm_binds <- tcExtendTyVarEnv clas_tyvars $+                      mapM tc_item op_items++        ; return (unionManyBags dm_binds) }++tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d)++tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds GhcRn+          -> HsSigFun -> TcPragEnv -> ClassOpItem+          -> TcM (LHsBinds GhcTcId)+-- Generate code for default methods+-- This is incompatible with Hugs, which expects a polymorphic+-- default method for every class op, regardless of whether or not+-- the programmer supplied an explicit default decl for the class.+-- (If necessary we can fix that, but we don't have a convenient Id to hand.)++tcDefMeth _ _ _ _ _ prag_fn (sel_id, Nothing)+  = do { -- No default method+         mapM_ (addLocM (badDmPrag sel_id))+               (lookupPragEnv prag_fn (idName sel_id))+       ; return emptyBag }++tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn+          (sel_id, Just (dm_name, dm_spec))+  | Just (L bind_loc dm_bind, bndr_loc, prags) <- findMethodBind sel_name binds_in prag_fn+  = do { -- First look up the default method; it should be there!+         -- It can be the orinary default method+         -- or the generic-default method.  E.g of the latter+         --      class C a where+         --        op :: a -> a -> Bool+         --        default op :: Eq a => a -> a -> Bool+         --        op x y = x==y+         -- The default method we generate is+         --    $gm :: (C a, Eq a) => a -> a -> Bool+         --    $gm x y = x==y++         global_dm_id  <- tcLookupId dm_name+       ; global_dm_id  <- addInlinePrags global_dm_id prags+       ; local_dm_name <- newNameAt (getOccName sel_name) bndr_loc+            -- Base the local_dm_name on the selector name, because+            -- type errors from tcInstanceMethodBody come from here++       ; spec_prags <- discardConstraints $+                       tcSpecPrags global_dm_id prags+       ; warnTc NoReason+                (not (null spec_prags))+                (text "Ignoring SPECIALISE pragmas on default method"+                 <+> quotes (ppr sel_name))++       ; let hs_ty = hs_sig_fn sel_name+                     `orElse` pprPanic "tc_dm" (ppr sel_name)+             -- We need the HsType so that we can bring the right+             -- type variables into scope+             --+             -- Eg.   class C a where+             --          op :: forall b. Eq b => a -> [b] -> a+             --          gen_op :: a -> a+             --          generic gen_op :: D a => a -> a+             -- The "local_dm_ty" is precisely the type in the above+             -- type signatures, ie with no "forall a. C a =>" prefix++             local_dm_ty = instantiateMethod clas global_dm_id (mkTyVarTys tyvars)++             lm_bind     = dm_bind { fun_id = L bind_loc local_dm_name }+                             -- Substitute the local_meth_name for the binder+                             -- NB: the binding is always a FunBind++             warn_redundant = case dm_spec of+                                GenericDM {} -> True+                                VanillaDM    -> False+                -- For GenericDM, warn if the user specifies a signature+                -- with redundant constraints; but not for VanillaDM, where+                -- the default method may well be 'error' or something++             ctxt = FunSigCtxt sel_name warn_redundant++       ; let local_dm_id = mkLocalId local_dm_name local_dm_ty+             local_dm_sig = CompleteSig { sig_bndr = local_dm_id+                                        , sig_ctxt  = ctxt+                                        , sig_loc   = getLoc (hsSigType hs_ty) }++       ; (ev_binds, (tc_bind, _))+               <- checkConstraints (TyConSkol ClassFlavour (getName clas)) tyvars [this_dict] $+                  tcPolyCheck no_prag_fn local_dm_sig+                              (L bind_loc lm_bind)++       ; let export = ABE { abe_ext   = noExt+                          , abe_poly  = global_dm_id+                          , abe_mono  = local_dm_id+                          , abe_wrap  = idHsWrapper+                          , abe_prags = IsDefaultMethod }+             full_bind = AbsBinds { abs_ext      = noExt+                                  , abs_tvs      = tyvars+                                  , abs_ev_vars  = [this_dict]+                                  , abs_exports  = [export]+                                  , abs_ev_binds = [ev_binds]+                                  , abs_binds    = tc_bind+                                  , abs_sig      = True }++       ; return (unitBag (L bind_loc full_bind)) }++  | otherwise = pprPanic "tcDefMeth" (ppr sel_id)+  where+    sel_name = idName sel_id+    no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;+                                -- they are all for meth_id++---------------+tcClassMinimalDef :: Name -> [LSig GhcRn] -> [TcMethInfo] -> TcM ClassMinimalDef+tcClassMinimalDef _clas sigs op_info+  = case findMinimalDef sigs of+      Nothing -> return defMindef+      Just mindef -> do+        -- Warn if the given mindef does not imply the default one+        -- That is, the given mindef should at least ensure that the+        -- class ops without default methods are required, since we+        -- have no way to fill them in otherwise+        tcg_env <- getGblEnv+        -- However, only do this test when it's not an hsig file,+        -- since you can't write a default implementation.+        when (tcg_src tcg_env /= HsigFile) $+            whenIsJust (isUnsatisfied (mindef `impliesAtom`) defMindef) $+                       (\bf -> addWarnTc NoReason (warningMinimalDefIncomplete bf))+        return mindef+  where+    -- By default require all methods without a default implementation+    defMindef :: ClassMinimalDef+    defMindef = mkAnd [ noLoc (mkVar name)+                      | (name, _, Nothing) <- op_info ]++instantiateMethod :: Class -> TcId -> [TcType] -> TcType+-- Take a class operation, say+--      op :: forall ab. C a => forall c. Ix c => (b,c) -> a+-- Instantiate it at [ty1,ty2]+-- Return the "local method type":+--      forall c. Ix x => (ty2,c) -> ty1+instantiateMethod clas sel_id inst_tys+  = ASSERT( ok_first_pred ) local_meth_ty+  where+    rho_ty = piResultTys (idType sel_id) inst_tys+    (first_pred, local_meth_ty) = tcSplitPredFunTy_maybe rho_ty+                `orElse` pprPanic "tcInstanceMethod" (ppr sel_id)++    ok_first_pred = case getClassPredTys_maybe first_pred of+                      Just (clas1, _tys) -> clas == clas1+                      Nothing -> False+              -- The first predicate should be of form (C a b)+              -- where C is the class in question+++---------------------------+type HsSigFun = Name -> Maybe (LHsSigType GhcRn)++mkHsSigFun :: [LSig GhcRn] -> HsSigFun+mkHsSigFun sigs = lookupNameEnv env+  where+    env = mkHsSigEnv get_classop_sig sigs++    get_classop_sig :: LSig GhcRn -> Maybe ([Located Name], LHsSigType GhcRn)+    get_classop_sig  (L _ (ClassOpSig _ _ ns hs_ty)) = Just (ns, hs_ty)+    get_classop_sig  _                               = Nothing++---------------------------+findMethodBind  :: Name                 -- Selector+                -> LHsBinds GhcRn       -- A group of bindings+                -> TcPragEnv+                -> Maybe (LHsBind GhcRn, SrcSpan, [LSig GhcRn])+                -- Returns the binding, the binding+                -- site of the method binder, and any inline or+                -- specialisation pragmas+findMethodBind sel_name binds prag_fn+  = foldlBag mplus Nothing (mapBag f binds)+  where+    prags    = lookupPragEnv prag_fn sel_name++    f bind@(L _ (FunBind { fun_id = L bndr_loc op_name }))+      | op_name == sel_name+             = Just (bind, bndr_loc, prags)+    f _other = Nothing++---------------------------+findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef+findMinimalDef = firstJusts . map toMinimalDef+  where+    toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef+    toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = Just (fmap unLoc bf)+    toMinimalDef _                               = Nothing++{-+Note [Polymorphic methods]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    class Foo a where+        op :: forall b. Ord b => a -> b -> b -> b+    instance Foo c => Foo [c] where+        op = e++When typechecking the binding 'op = e', we'll have a meth_id for op+whose type is+      op :: forall c. Foo c => forall b. Ord b => [c] -> b -> b -> b++So tcPolyBinds must be capable of dealing with nested polytypes;+and so it is. See TcBinds.tcMonoBinds (with type-sig case).++Note [Silly default-method bind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we pass the default method binding to the type checker, it must+look like    op2 = e+not          $dmop2 = e+otherwise the "$dm" stuff comes out error messages.  But we want the+"$dm" to come out in the interface file.  So we typecheck the former,+and wrap it in a let, thus+          $dmop2 = let op2 = e in op2+This makes the error messages right.+++************************************************************************+*                                                                      *+                Error messages+*                                                                      *+************************************************************************+-}++tcMkDeclCtxt :: TyClDecl GhcRn -> SDoc+tcMkDeclCtxt decl = hsep [text "In the", pprTyClDeclFlavour decl,+                      text "declaration for", quotes (ppr (tcdName decl))]++tcAddDeclCtxt :: TyClDecl GhcRn -> TcM a -> TcM a+tcAddDeclCtxt decl thing_inside+  = addErrCtxt (tcMkDeclCtxt decl) thing_inside++badMethodErr :: Outputable a => a -> Name -> SDoc+badMethodErr clas op+  = hsep [text "Class", quotes (ppr clas),+          text "does not have a method", quotes (ppr op)]++badGenericMethod :: Outputable a => a -> Name -> SDoc+badGenericMethod clas op+  = hsep [text "Class", quotes (ppr clas),+          text "has a generic-default signature without a binding", quotes (ppr op)]++{-+badGenericInstanceType :: LHsBinds Name -> SDoc+badGenericInstanceType binds+  = vcat [text "Illegal type pattern in the generic bindings",+          nest 2 (ppr binds)]++missingGenericInstances :: [Name] -> SDoc+missingGenericInstances missing+  = text "Missing type patterns for" <+> pprQuotedList missing++dupGenericInsts :: [(TyCon, InstInfo a)] -> SDoc+dupGenericInsts tc_inst_infos+  = vcat [text "More than one type pattern for a single generic type constructor:",+          nest 2 (vcat (map ppr_inst_ty tc_inst_infos)),+          text "All the type patterns for a generic type constructor must be identical"+    ]+  where+    ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst)+-}+badDmPrag :: TcId -> Sig GhcRn -> TcM ()+badDmPrag sel_id prag+  = addErrTc (text "The" <+> hsSigDoc prag <+> ptext (sLit "for default method")+              <+> quotes (ppr sel_id)+              <+> text "lacks an accompanying binding")++warningMinimalDefIncomplete :: ClassMinimalDef -> SDoc+warningMinimalDefIncomplete mindef+  = vcat [ text "The MINIMAL pragma does not require:"+         , nest 2 (pprBooleanFormulaNice mindef)+         , text "but there is no default implementation." ]++instDeclCtxt1 :: LHsSigType GhcRn -> SDoc+instDeclCtxt1 hs_inst_ty+  = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))++instDeclCtxt2 :: Type -> SDoc+instDeclCtxt2 dfun_ty+  = instDeclCtxt3 cls tys+  where+    (_,_,cls,tys) = tcSplitDFunTy dfun_ty++instDeclCtxt3 :: Class -> [Type] -> SDoc+instDeclCtxt3 cls cls_tys+  = inst_decl_ctxt (ppr (mkClassPred cls cls_tys))++inst_decl_ctxt :: SDoc -> SDoc+inst_decl_ctxt doc = hang (text "In the instance declaration for")+                        2 (quotes doc)++tcATDefault :: SrcSpan+            -> TCvSubst+            -> NameSet+            -> ClassATItem+            -> TcM [FamInst]+-- ^ Construct default instances for any associated types that+-- aren't given a user definition+-- Returns [] or singleton+tcATDefault loc inst_subst defined_ats (ATI fam_tc defs)+  -- User supplied instances ==> everything is OK+  | tyConName fam_tc `elemNameSet` defined_ats+  = return []++  -- No user instance, have defaults ==> instantiate them+   -- Example:   class C a where { type F a b :: *; type F a b = () }+   --            instance C [x]+   -- Then we want to generate the decl:   type F [x] b = ()+  | Just (rhs_ty, _loc) <- defs+  = do { let (subst', pat_tys') = mapAccumL subst_tv inst_subst+                                            (tyConTyVars fam_tc)+             rhs'     = substTyUnchecked subst' rhs_ty+             tcv' = tyCoVarsOfTypesList pat_tys'+             (tv', cv') = partition isTyVar tcv'+             tvs'     = scopedSort tv'+             cvs'     = scopedSort cv'+       ; rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc)) pat_tys'+       ; let axiom = mkSingleCoAxiom Nominal rep_tc_name tvs' [] cvs'+                                     fam_tc pat_tys' rhs'+           -- NB: no validity check. We check validity of default instances+           -- in the class definition. Because type instance arguments cannot+           -- be type family applications and cannot be polytypes, the+           -- validity check is redundant.++       ; traceTc "mk_deflt_at_instance" (vcat [ ppr fam_tc, ppr rhs_ty+                                              , pprCoAxiom axiom ])+       ; fam_inst <- newFamInst SynFamilyInst axiom+       ; return [fam_inst] }++   -- No defaults ==> generate a warning+  | otherwise  -- defs = Nothing+  = do { warnMissingAT (tyConName fam_tc)+       ; return [] }+  where+    subst_tv subst tc_tv+      | Just ty <- lookupVarEnv (getTvSubstEnv subst) tc_tv+      = (subst, ty)+      | otherwise+      = (extendTvSubst subst tc_tv ty', ty')+      where+        ty' = mkTyVarTy (updateTyVarKind (substTyUnchecked subst) tc_tv)++warnMissingAT :: Name -> TcM ()+warnMissingAT name+  = do { warn <- woptM Opt_WarnMissingMethods+       ; traceTc "warn" (ppr name <+> ppr warn)+       ; hsc_src <- fmap tcg_src getGblEnv+       -- Warn only if -Wmissing-methods AND not a signature+       ; warnTc (Reason Opt_WarnMissingMethods) (warn && hsc_src /= HsigFile)+                (text "No explicit" <+> text "associated type"+                    <+> text "or default declaration for"+                    <+> quotes (ppr name)) }
+ compiler/typecheck/TcDefaults.hs view
@@ -0,0 +1,110 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1993-1998++\section[TcDefaults]{Typechecking \tr{default} declarations}+-}+{-# LANGUAGE TypeFamilies #-}++module TcDefaults ( tcDefaults ) where++import GhcPrelude++import HsSyn+import Class+import TcRnMonad+import TcEnv+import TcHsType+import TcHsSyn+import TcSimplify+import TcValidity+import TcType+import PrelNames+import SrcLoc+import Outputable+import FastString+import qualified GHC.LanguageExtensions as LangExt++tcDefaults :: [LDefaultDecl GhcRn]+           -> TcM (Maybe [Type])    -- Defaulting types to heave+                                    -- into Tc monad for later use+                                    -- in Disambig.++tcDefaults []+  = getDeclaredDefaultTys       -- No default declaration, so get the+                                -- default types from the envt;+                                -- i.e. use the current ones+                                -- (the caller will put them back there)+        -- It's important not to return defaultDefaultTys here (which+        -- we used to do) because in a TH program, tcDefaults [] is called+        -- repeatedly, once for each group of declarations between top-level+        -- splices.  We don't want to carefully set the default types in+        -- one group, only for the next group to ignore them and install+        -- defaultDefaultTys++tcDefaults [L _ (DefaultDecl _ [])]+  = return (Just [])            -- Default declaration specifying no types++tcDefaults [L locn (DefaultDecl _ mono_tys)]+  = setSrcSpan locn                     $+    addErrCtxt defaultDeclCtxt          $+    do  { ovl_str   <- xoptM LangExt.OverloadedStrings+        ; ext_deflt <- xoptM LangExt.ExtendedDefaultRules+        ; num_class    <- tcLookupClass numClassName+        ; deflt_str <- if ovl_str+                       then mapM tcLookupClass [isStringClassName]+                       else return []+        ; deflt_interactive <- if ext_deflt+                               then mapM tcLookupClass interactiveClassNames+                               else return []+        ; let deflt_clss = num_class : deflt_str ++ deflt_interactive++        ; tau_tys <- mapAndReportM (tc_default_ty deflt_clss) mono_tys++        ; return (Just tau_tys) }++tcDefaults decls@(L locn (DefaultDecl _ _) : _)+  = setSrcSpan locn $+    failWithTc (dupDefaultDeclErr decls)+tcDefaults (L _ (XDefaultDecl _):_) = panic "tcDefaults"+++tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type+tc_default_ty deflt_clss hs_ty+ = do   { (ty, _kind) <- solveEqualities $+                         tcLHsType hs_ty+        ; ty <- zonkTcTypeToType ty   -- establish Type invariants+        ; checkValidType DefaultDeclCtxt ty++        -- Check that the type is an instance of at least one of the deflt_clss+        ; oks <- mapM (check_instance ty) deflt_clss+        ; checkTc (or oks) (badDefaultTy ty deflt_clss)+        ; return ty }++check_instance :: Type -> Class -> TcM Bool+  -- Check that ty is an instance of cls+  -- We only care about whether it worked or not; return a boolean+check_instance ty cls+  = do  { (_, success) <- discardErrs $+                          askNoErrs $+                          simplifyDefault [mkClassPred cls [ty]]+        ; return success }++defaultDeclCtxt :: SDoc+defaultDeclCtxt = text "When checking the types in a default declaration"++dupDefaultDeclErr :: [Located (DefaultDecl GhcRn)] -> SDoc+dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things)+  = hang (text "Multiple default declarations")+       2 (vcat (map pp dup_things))+  where+    pp (L locn (DefaultDecl _ _))+      = text "here was another default declaration" <+> ppr locn+    pp (L _ (XDefaultDecl _)) = panic "dupDefaultDeclErr"+dupDefaultDeclErr (L _ (XDefaultDecl _) : _) = panic "dupDefaultDeclErr"+dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"++badDefaultTy :: Type -> [Class] -> SDoc+badDefaultTy ty deflt_clss+  = hang (text "The default type" <+> quotes (ppr ty) <+> ptext (sLit "is not an instance of"))+       2 (foldr1 (\a b -> a <+> text "or" <+> b) (map (quotes. ppr) deflt_clss))
+ compiler/typecheck/TcDeriv.hs view
@@ -0,0 +1,2244 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Handles @deriving@ clauses on @data@ declarations.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}++module TcDeriv ( tcDeriving, DerivInfo(..), mkDerivInfos ) where++#include "HsVersions.h"++import GhcPrelude++import HsSyn+import DynFlags++import TcRnMonad+import FamInst+import TcDerivInfer+import TcDerivUtils+import TcValidity( allDistinctTyVars )+import TcClassDcl( instDeclCtxt3, tcATDefault, tcMkDeclCtxt )+import TcEnv+import TcGenDeriv                       -- Deriv stuff+import TcValidity( checkValidInstHead )+import InstEnv+import Inst+import FamInstEnv+import TcHsType+import TyCoRep++import RnNames( extendGlobalRdrEnvRn )+import RnBinds+import RnEnv+import RnUtils    ( bindLocalNamesFV )+import RnSource   ( addTcgDUs )+import Avail++import Unify( tcUnifyTy )+import Class+import Type+import ErrUtils+import DataCon+import Maybes+import RdrName+import Name+import NameSet+import TyCon+import TcType+import Var+import VarEnv+import VarSet+import PrelNames+import SrcLoc+import Util+import Outputable+import FastString+import Bag+import Pair+import FV (fvVarList, unionFV, mkFVs)+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Data.List++{-+************************************************************************+*                                                                      *+                Overview+*                                                                      *+************************************************************************++Overall plan+~~~~~~~~~~~~+1.  Convert the decls (i.e. data/newtype deriving clauses,+    plus standalone deriving) to [EarlyDerivSpec]++2.  Infer the missing contexts for the InferTheta's++3.  Add the derived bindings, generating InstInfos+-}++data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin])+                    | GivenTheta (DerivSpec ThetaType)+        -- InferTheta ds => the context for the instance should be inferred+        --      In this case ds_theta is the list of all the sets of+        --      constraints needed, such as (Eq [a], Eq a), together with a+        --      suitable CtLoc to get good error messages.+        --      The inference process is to reduce this to a+        --      simpler form (e.g. Eq a)+        --+        -- GivenTheta ds => the exact context for the instance is supplied+        --                  by the programmer; it is ds_theta+        -- See Note [Inferring the instance context] in TcDerivInfer++earlyDSLoc :: EarlyDerivSpec -> SrcSpan+earlyDSLoc (InferTheta spec) = ds_loc spec+earlyDSLoc (GivenTheta spec) = ds_loc spec++splitEarlyDerivSpec :: [EarlyDerivSpec]+                    -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])+splitEarlyDerivSpec [] = ([],[])+splitEarlyDerivSpec (InferTheta spec : specs) =+    case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)+splitEarlyDerivSpec (GivenTheta spec : specs) =+    case splitEarlyDerivSpec specs of (is, gs) -> (is, spec : gs)++instance Outputable EarlyDerivSpec where+  ppr (InferTheta spec) = ppr spec <+> text "(Infer)"+  ppr (GivenTheta spec) = ppr spec <+> text "(Given)"++{-+Note [Data decl contexts]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++        data (RealFloat a) => Complex a = !a :+ !a deriving( Read )++We will need an instance decl like:++        instance (Read a, RealFloat a) => Read (Complex a) where+          ...++The RealFloat in the context is because the read method for Complex is bound+to construct a Complex, and doing that requires that the argument type is+in RealFloat.++But this ain't true for Show, Eq, Ord, etc, since they don't construct+a Complex; they only take them apart.++Our approach: identify the offending classes, and add the data type+context to the instance decl.  The "offending classes" are++        Read, Enum?++FURTHER NOTE ADDED March 2002.  In fact, Haskell98 now requires that+pattern matching against a constructor from a data type with a context+gives rise to the constraints for that context -- or at least the thinned+version.  So now all classes are "offending".++Note [Newtype deriving]+~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+    class C a b+    instance C [a] Char+    newtype T = T Char deriving( C [a] )++Notice the free 'a' in the deriving.  We have to fill this out to+    newtype T = T Char deriving( forall a. C [a] )++And then translate it to:+    instance C [a] Char => C [a] T where ...+++Note [Newtype deriving superclasses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(See also #1220 for an interesting exchange on newtype+deriving and superclasses.)++The 'tys' here come from the partial application in the deriving+clause. The last arg is the new instance type.++We must pass the superclasses; the newtype might be an instance+of them in a different way than the representation type+E.g.            newtype Foo a = Foo a deriving( Show, Num, Eq )+Then the Show instance is not done via Coercible; it shows+        Foo 3 as "Foo 3"+The Num instance is derived via Coercible, but the Show superclass+dictionary must the Show instance for Foo, *not* the Show dictionary+gotten from the Num dictionary. So we must build a whole new dictionary+not just use the Num one.  The instance we want is something like:+     instance (Num a, Show (Foo a), Eq (Foo a)) => Num (Foo a) where+        (+) = ((+)@a)+        ...etc...+There may be a coercion needed which we get from the tycon for the newtype+when the dict is constructed in TcInstDcls.tcInstDecl2+++Note [Unused constructors and deriving clauses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See #3221.  Consider+   data T = T1 | T2 deriving( Show )+Are T1 and T2 unused?  Well, no: the deriving clause expands to mention+both of them.  So we gather defs/uses from deriving just like anything else.++-}++-- | Stuff needed to process a datatype's `deriving` clauses+data DerivInfo = DerivInfo { di_rep_tc  :: TyCon+                             -- ^ The data tycon for normal datatypes,+                             -- or the *representation* tycon for data families+                           , di_clauses :: [LHsDerivingClause GhcRn]+                           , di_ctxt    :: SDoc -- ^ error context+                           }++-- | Extract `deriving` clauses of proper data type (skips data families)+mkDerivInfos :: [LTyClDecl GhcRn] -> TcM [DerivInfo]+mkDerivInfos decls = concatMapM (mk_deriv . unLoc) decls+  where++    mk_deriv decl@(DataDecl { tcdLName = L _ data_name+                            , tcdDataDefn =+                                HsDataDefn { dd_derivs = L _ clauses } })+      = do { tycon <- tcLookupTyCon data_name+           ; return [DerivInfo { di_rep_tc = tycon, di_clauses = clauses+                               , di_ctxt = tcMkDeclCtxt decl }] }+    mk_deriv _ = return []++{-++************************************************************************+*                                                                      *+\subsection[TcDeriv-driver]{Top-level function for \tr{derivings}}+*                                                                      *+************************************************************************+-}++tcDeriving  :: [DerivInfo]       -- All `deriving` clauses+            -> [LDerivDecl GhcRn] -- All stand-alone deriving declarations+            -> TcM (TcGblEnv, Bag (InstInfo GhcRn), HsValBinds GhcRn)+tcDeriving deriv_infos deriv_decls+  = recoverM (do { g <- getGblEnv+                 ; return (g, emptyBag, emptyValBindsOut)}) $+    do  {       -- Fish the "deriving"-related information out of the TcEnv+                -- And make the necessary "equations".+          is_boot <- tcIsHsBootOrSig+        ; traceTc "tcDeriving" (ppr is_boot)++        ; early_specs <- makeDerivSpecs is_boot deriv_infos deriv_decls+        ; traceTc "tcDeriving 1" (ppr early_specs)++        ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs+        ; insts1 <- mapM genInst given_specs+        ; insts2 <- mapM genInst infer_specs++        ; dflags <- getDynFlags++        ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2)+        ; loc <- getSrcSpanM+        ; let (binds, famInsts) = genAuxBinds dflags loc+                                    (unionManyBags deriv_stuff)++        ; let mk_inst_infos1 = map fstOf3 insts1+        ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs++          -- We must put all the derived type family instances (from both+          -- infer_specs and given_specs) in the local instance environment+          -- before proceeding, or else simplifyInstanceContexts might+          -- get stuck if it has to reason about any of those family instances.+          -- See Note [Staging of tcDeriving]+        ; tcExtendLocalFamInstEnv (bagToList famInsts) $+          -- NB: only call tcExtendLocalFamInstEnv once, as it performs+          -- validity checking for all of the family instances you give it.+          -- If the family instances have errors, calling it twice will result+          -- in duplicate error messages!++     do {+        -- the stand-alone derived instances (@inst_infos1@) are used when+        -- inferring the contexts for "deriving" clauses' instances+        -- (@infer_specs@)+        ; final_specs <- extendLocalInstEnv (map iSpec inst_infos1) $+                         simplifyInstanceContexts infer_specs++        ; let mk_inst_infos2 = map fstOf3 insts2+        ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs+        ; let inst_infos = inst_infos1 ++ inst_infos2++        ; (inst_info, rn_binds, rn_dus) <-+            renameDeriv is_boot inst_infos binds++        ; unless (isEmptyBag inst_info) $+             liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"+                        (ddump_deriving inst_info rn_binds famInsts))++        ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))+                                          getGblEnv+        ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs)+        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } }+  where+    ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn+                   -> Bag FamInst             -- ^ Rep type family instances+                   -> SDoc+    ddump_deriving inst_infos extra_binds repFamInsts+      =    hang (text "Derived class instances:")+              2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))+                 $$ ppr extra_binds)+        $$ hangP "Derived type family instances:"+             (vcat (map pprRepTy (bagToList repFamInsts)))++    hangP s x = text "" $$ hang (ptext (sLit s)) 2 x++    -- Apply the suspended computations given by genInst calls.+    -- See Note [Staging of tcDeriving]+    apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)]+                     -> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]+    apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds))++-- Prints the representable type family instance+pprRepTy :: FamInst -> SDoc+pprRepTy fi@(FamInst { fi_tys = lhs })+  = text "type" <+> ppr (mkTyConApp (famInstTyCon fi) lhs) <+>+      equals <+> ppr rhs+  where rhs = famInstRHS fi++renameDeriv :: Bool+            -> [InstInfo GhcPs]+            -> Bag (LHsBind GhcPs, LSig GhcPs)+            -> TcM (Bag (InstInfo GhcRn), HsValBinds GhcRn, DefUses)+renameDeriv is_boot inst_infos bagBinds+  | is_boot     -- If we are compiling a hs-boot file, don't generate any derived bindings+                -- The inst-info bindings will all be empty, but it's easier to+                -- just use rn_inst_info to change the type appropriately+  = do  { (rn_inst_infos, fvs) <- mapAndUnzipM rn_inst_info inst_infos+        ; return ( listToBag rn_inst_infos+                 , emptyValBindsOut, usesOnly (plusFVs fvs)) }++  | otherwise+  = discardWarnings $+    -- Discard warnings about unused bindings etc+    setXOptM LangExt.EmptyCase $+    -- Derived decls (for empty types) can have+    --    case x of {}+    setXOptM LangExt.ScopedTypeVariables $+    setXOptM LangExt.KindSignatures $+    -- Derived decls (for newtype-deriving) can use ScopedTypeVariables &+    -- KindSignatures+    setXOptM LangExt.TypeApplications $+    -- GND/DerivingVia uses TypeApplications in generated code+    -- (See Note [Newtype-deriving instances] in TcGenDeriv)+    unsetXOptM LangExt.RebindableSyntax $+    -- See Note [Avoid RebindableSyntax when deriving]+    setXOptM LangExt.TemplateHaskellQuotes $+    -- DeriveLift makes uses of quotes+    do  {+        -- Bring the extra deriving stuff into scope+        -- before renaming the instances themselves+        ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))+        ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds+        ; let aux_val_binds = ValBinds noExt aux_binds (bagToList aux_sigs)+        ; rn_aux_lhs <- rnTopBindsLHS emptyFsEnv aux_val_binds+        ; let bndrs = collectHsValBinders rn_aux_lhs+        ; envs <- extendGlobalRdrEnvRn (map avail bndrs) emptyFsEnv ;+        ; setEnvs envs $+    do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs+        ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos+        ; return (listToBag rn_inst_infos, rn_aux,+                  dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }++  where+    rn_inst_info :: InstInfo GhcPs -> TcM (InstInfo GhcRn, FreeVars)+    rn_inst_info+      inst_info@(InstInfo { iSpec = inst+                          , iBinds = InstBindings+                            { ib_binds = binds+                            , ib_tyvars = tyvars+                            , ib_pragmas = sigs+                            , ib_extensions = exts -- Only for type-checking+                            , ib_derived = sa } })+        =  ASSERT( null sigs )+           bindLocalNamesFV tyvars $+           do { (rn_binds,_, fvs) <- rnMethodBinds False (is_cls_nm inst) [] binds []+              ; let binds' = InstBindings { ib_binds = rn_binds+                                          , ib_tyvars = tyvars+                                          , ib_pragmas = []+                                          , ib_extensions = exts+                                          , ib_derived = sa }+              ; return (inst_info { iBinds = binds' }, fvs) }++{-+Note [Newtype deriving and unused constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (see #1954):++  module Bug(P) where+  newtype P a = MkP (IO a) deriving Monad++If you compile with -Wunused-binds you do not expect the warning+"Defined but not used: data constructor MkP". Yet the newtype deriving+code does not explicitly mention MkP, but it should behave as if you+had written+  instance Monad P where+     return x = MkP (return x)+     ...etc...++So we want to signal a user of the data constructor 'MkP'.+This is the reason behind the [Name] part of the return type+of genInst.++Note [Staging of tcDeriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here's a tricky corner case for deriving (adapted from #2721):++    class C a where+      type T a+      foo :: a -> T a++    instance C Int where+      type T Int = Int+      foo = id++    newtype N = N Int deriving C++This will produce an instance something like this:++    instance C N where+      type T N = T Int+      foo = coerce (foo :: Int -> T Int) :: N -> T N++We must be careful in order to typecheck this code. When determining the+context for the instance (in simplifyInstanceContexts), we need to determine+that T N and T Int have the same representation, but to do that, the T N+instance must be in the local family instance environment. Otherwise, GHC+would be unable to conclude that T Int is representationally equivalent to+T Int, and simplifyInstanceContexts would get stuck.++Previously, tcDeriving would defer adding any derived type family instances to+the instance environment until the very end, which meant that+simplifyInstanceContexts would get called without all the type family instances+it needed in the environment in order to properly simplify instance like+the C N instance above.++To avoid this scenario, we carefully structure the order of events in+tcDeriving. We first call genInst on the standalone derived instance specs and+the instance specs obtained from deriving clauses. Note that the return type of+genInst is a triple:++    TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name)++The type family instances are in the BagDerivStuff. The first field of the+triple is a suspended computation which, given an instance context, produces+the rest of the instance. The fact that it is suspended is important, because+right now, we don't have ThetaTypes for the instances that use deriving clauses+(only the standalone-derived ones).++Now we can can collect the type family instances and extend the local instance+environment. At this point, it is safe to run simplifyInstanceContexts on the+deriving-clause instance specs, which gives us the ThetaTypes for the+deriving-clause instances. Now we can feed all the ThetaTypes to the+suspended computations and obtain our InstInfos, at which point+tcDeriving is done.++An alternative design would be to split up genInst so that the+family instances are generated separately from the InstInfos. But this would+require carving up a lot of the GHC deriving internals to accommodate the+change. On the other hand, we can keep all of the InstInfo and type family+instance logic together in genInst simply by converting genInst to+continuation-returning style, so we opt for that route.++Note [Why we don't pass rep_tc into deriveTyData]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Down in the bowels of mkEqnHelp, we need to convert the fam_tc back into+the rep_tc by means of a lookup. And yet we have the rep_tc right here!+Why look it up again? Answer: it's just easier this way.+We drop some number of arguments from the end of the datatype definition+in deriveTyData. The arguments are dropped from the fam_tc.+This action may drop a *different* number of arguments+passed to the rep_tc, depending on how many free variables, etc., the+dropped patterns have.++Also, this technique carries over the kind substitution from deriveTyData+nicely.++Note [Avoid RebindableSyntax when deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The RebindableSyntax extension interacts awkwardly with the derivation of+any stock class whose methods require the use of string literals. The Show+class is a simple example (see #12688):++  {-# LANGUAGE RebindableSyntax, OverloadedStrings #-}+  newtype Text = Text String+  fromString :: String -> Text+  fromString = Text++  data Foo = Foo deriving Show++This will generate code to the effect of:++  instance Show Foo where+    showsPrec _ Foo = showString "Foo"++But because RebindableSyntax and OverloadedStrings are enabled, the "Foo"+string literal is now of type Text, not String, which showString doesn't+accept! This causes the generated Show instance to fail to typecheck.++To avoid this kind of scenario, we simply turn off RebindableSyntax entirely+in derived code.++************************************************************************+*                                                                      *+                From HsSyn to DerivSpec+*                                                                      *+************************************************************************++@makeDerivSpecs@ fishes around to find the info about needed derived instances.+-}++makeDerivSpecs :: Bool+               -> [DerivInfo]+               -> [LDerivDecl GhcRn]+               -> TcM [EarlyDerivSpec]+makeDerivSpecs is_boot deriv_infos deriv_decls+  = do  { -- We carefully set up uses of recoverM to minimize error message+          -- cascades. See Note [Flattening deriving clauses].+        ; eqns1 <- sequenceA+                     [ recoverM (pure Nothing)+                                (deriveClause rep_tc (fmap unLoc dcs)+                                                      pred err_ctxt)+                     | DerivInfo { di_rep_tc = rep_tc, di_clauses = clauses+                                 , di_ctxt = err_ctxt } <- deriv_infos+                     , L _ (HsDerivingClause { deriv_clause_strategy = dcs+                                             , deriv_clause_tys = L _ preds })+                         <- clauses+                     , pred <- preds+                     ]+        ; eqns2 <- mapM (recoverM (pure Nothing) . deriveStandalone) deriv_decls+        ; let eqns = catMaybes (eqns1 ++ eqns2)++        ; if is_boot then   -- No 'deriving' at all in hs-boot files+              do { unless (null eqns) (add_deriv_err (head eqns))+                 ; return [] }+          else return eqns }+  where+    add_deriv_err eqn+       = setSrcSpan (earlyDSLoc eqn) $+         addErr (hang (text "Deriving not permitted in hs-boot file")+                    2 (text "Use an instance declaration instead"))++{-+Note [Flattening deriving clauses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider what happens if you run this program (from #10684) without+DeriveGeneric enabled:++    data A = A deriving (Show, Generic)+    data B = B A deriving (Show)++Naturally, you'd expect GHC to give an error to the effect of:++    Can't make a derived instance of `Generic A':+      You need -XDeriveGeneric to derive an instance for this class++And *only* that error, since the other two derived Show instances appear to be+independent of this derived Generic instance. Yet GHC also used to give this+additional error on the program above:++    No instance for (Show A)+      arising from the 'deriving' clause of a data type declaration+    When deriving the instance for (Show B)++This was happening because when GHC encountered any error within a single+data type's set of deriving clauses, it would call recoverM and move on+to the next data type's deriving clauses. One unfortunate consequence of+this design is that if A's derived Generic instance failed, so its derived+Show instance would be skipped entirely, leading to the "No instance for+(Show A)" error cascade.++The solution to this problem is to "flatten" the set of classes that are+derived for a particular data type via deriving clauses. That is, if+you have:++    newtype C = C D+      deriving (E, F, G)+      deriving anyclass (H, I, J)+      deriving newtype  (K, L, M)++Then instead of processing instances E through M under the scope of a single+recoverM, we flatten these deriving clauses into the list:++    [ E (Nothing)+    , F (Nothing)+    , G (Nothing)+    , H (Just anyclass)+    , I (Just anyclass)+    , J (Just anyclass)+    , K (Just newtype)+    , L (Just newtype)+    , M (Just newtype) ]++And then process each class individually, under its own recoverM scope. That+way, failure to derive one class doesn't cancel out other classes in the+same set of clause-derived classes.+-}++------------------------------------------------------------------+-- | Process a single class in a `deriving` clause.+deriveClause :: TyCon -> Maybe (DerivStrategy GhcRn)+             -> LHsSigType GhcRn -> SDoc+             -> TcM (Maybe EarlyDerivSpec)+deriveClause rep_tc mb_strat pred err_ctxt+  = addErrCtxt err_ctxt $+    deriveTyData tvs tc tys mb_strat pred+  where+    tvs = tyConTyVars rep_tc+    (tc, tys) = case tyConFamInstSig_maybe rep_tc of+                        -- data family:+                  Just (fam_tc, pats, _) -> (fam_tc, pats)+      -- NB: deriveTyData wants the *user-specified*+      -- name. See Note [Why we don't pass rep_tc into deriveTyData]++                  _ -> (rep_tc, mkTyVarTys tvs)     -- datatype++------------------------------------------------------------------+deriveStandalone :: LDerivDecl GhcRn -> TcM (Maybe EarlyDerivSpec)+-- Process a single standalone deriving declaration+--  e.g.   deriving instance Show a => Show (T a)+-- Rather like tcLocalInstDecl+--+-- This returns a Maybe because the user might try to derive Typeable, which is+-- a no-op nowadays.+deriveStandalone (L loc (DerivDecl _ deriv_ty mbl_deriv_strat overlap_mode))+  = setSrcSpan loc                   $+    addErrCtxt (standaloneCtxt deriv_ty)  $+    do { traceTc "Standalone deriving decl for" (ppr deriv_ty)+       ; let mb_deriv_strat = fmap unLoc mbl_deriv_strat+             ctxt           = TcType.InstDeclCtxt True+       ; traceTc "Deriving strategy (standalone deriving)" $+           vcat [ppr mb_deriv_strat, ppr deriv_ty]+       ; (mb_deriv_strat', tvs', (deriv_ctxt', cls, inst_tys'))+           <- tcDerivStrategy mb_deriv_strat $ do+                (tvs, deriv_ctxt, cls, inst_tys)+                  <- tcStandaloneDerivInstType ctxt deriv_ty+                pure (tvs, (deriv_ctxt, cls, inst_tys))+       ; checkTc (not (null inst_tys')) derivingNullaryErr+       ; let inst_ty' = last inst_tys'+         -- See Note [Unify kinds in deriving]+       ; (tvs, deriv_ctxt, inst_tys) <-+           case mb_deriv_strat' of+             -- Perform an additional unification with the kind of the `via`+             -- type and the result of the previous kind unification.+             Just (ViaStrategy via_ty) -> do+               let via_kind     = tcTypeKind via_ty+                   inst_ty_kind = tcTypeKind inst_ty'+                   mb_match     = tcUnifyTy inst_ty_kind via_kind++               checkTc (isJust mb_match)+                       (derivingViaKindErr cls inst_ty_kind+                                           via_ty via_kind)++               let Just kind_subst = mb_match+                   ki_subst_range  = getTCvSubstRangeFVs kind_subst+                   -- See Note [Unification of two kind variables in deriving]+                   unmapped_tkvs = filter (\v -> v `notElemTCvSubst` kind_subst+                                        && not (v `elemVarSet` ki_subst_range))+                                          tvs'+                   (subst, _)    = substTyVarBndrs kind_subst unmapped_tkvs+                   (final_deriv_ctxt, final_deriv_ctxt_tys)+                     = case deriv_ctxt' of+                         InferContext wc -> (InferContext wc, [])+                         SupplyContext theta ->+                           let final_theta = substTheta subst theta+                           in (SupplyContext final_theta, final_theta)+                   final_inst_tys   = substTys subst inst_tys'+                   final_tvs        = tyCoVarsOfTypesWellScoped $+                                      final_deriv_ctxt_tys ++ final_inst_tys+               pure (final_tvs, final_deriv_ctxt, final_inst_tys)++             _ -> pure (tvs', deriv_ctxt', inst_tys')+       ; let cls_tys = take (length inst_tys - 1) inst_tys+             inst_ty = last inst_tys+       ; traceTc "Standalone deriving;" $ vcat+              [ text "tvs:" <+> ppr tvs+              , text "mb_deriv_strat:" <+> ppr mb_deriv_strat'+              , text "deriv_ctxt:" <+> ppr deriv_ctxt+              , text "cls:" <+> ppr cls+              , text "tys:" <+> ppr inst_tys ]+                -- C.f. TcInstDcls.tcLocalInstDecl1+       ; traceTc "Standalone deriving:" $ vcat+              [ text "class:" <+> ppr cls+              , text "class types:" <+> ppr cls_tys+              , text "type:" <+> ppr inst_ty ]++       ; let bale_out msg = failWithTc (derivingThingErr False cls cls_tys+                              inst_ty mb_deriv_strat' msg)++       ; case tcSplitTyConApp_maybe inst_ty of+           Just (tc, tc_args)+              | className cls == typeableClassName+              -> do warnUselessTypeable+                    return Nothing++              | otherwise+              -> Just <$> mkEqnHelp (fmap unLoc overlap_mode)+                                    tvs cls cls_tys tc tc_args+                                    deriv_ctxt mb_deriv_strat'++           _  -> -- Complain about functions, primitive types, etc,+                 bale_out $+                 text "The last argument of the instance must be a data or newtype application"+        }+deriveStandalone (L _ (XDerivDecl _)) = panic "deriveStandalone"++-- Typecheck the type in a standalone deriving declaration.+--+-- This may appear dense, but it's mostly huffing and puffing to recognize+-- the special case of a type with an extra-constraints wildcard context, e.g.,+--+--   deriving instance _ => Eq (Foo a)+--+-- If there is such a wildcard, we typecheck this as if we had written+-- @deriving instance Eq (Foo a)@, and return @'InferContext' ('Just' loc)@,+-- as the 'DerivContext', where loc is the location of the wildcard used for+-- error reporting. This indicates that we should infer the context as if we+-- were deriving Eq via a deriving clause+-- (see Note [Inferring the instance context] in TcDerivInfer).+--+-- If there is no wildcard, then proceed as normal, and instead return+-- @'SupplyContext' theta@, where theta is the typechecked context.+--+-- Note that this will never return @'InferContext' 'Nothing'@, as that can+-- only happen with @deriving@ clauses.+tcStandaloneDerivInstType+  :: UserTypeCtxt -> LHsSigWcType GhcRn+  -> TcM ([TyVar], DerivContext, Class, [Type])+tcStandaloneDerivInstType ctxt+    (HsWC { hswc_body = deriv_ty@(HsIB { hsib_ext = vars+                                       , hsib_body   = deriv_ty_body })})+  | (tvs, theta, rho) <- splitLHsSigmaTy deriv_ty_body+  , L _ [wc_pred] <- theta+  , L wc_span (HsWildCardTy _) <- ignoreParens wc_pred+  = do dfun_ty <- tcHsClsInstType ctxt $+                  HsIB { hsib_ext = vars+                       , hsib_body+                           = L (getLoc deriv_ty_body) $+                             HsForAllTy { hst_fvf = ForallInvis+                                        , hst_bndrs = tvs+                                        , hst_xforall = noExt+                                        , hst_body  = rho }}+       let (tvs, _theta, cls, inst_tys) = tcSplitDFunTy dfun_ty+       pure (tvs, InferContext (Just wc_span), cls, inst_tys)+  | otherwise+  = do dfun_ty <- tcHsClsInstType ctxt deriv_ty+       let (tvs, theta, cls, inst_tys) = tcSplitDFunTy dfun_ty+       pure (tvs, SupplyContext theta, cls, inst_tys)++tcStandaloneDerivInstType _ (HsWC _ (XHsImplicitBndrs _))+  = panic "tcStandaloneDerivInstType"+tcStandaloneDerivInstType _ (XHsWildCardBndrs _)+  = panic "tcStandaloneDerivInstType"++warnUselessTypeable :: TcM ()+warnUselessTypeable+  = do { warn <- woptM Opt_WarnDerivingTypeable+       ; when warn $ addWarnTc (Reason Opt_WarnDerivingTypeable)+                   $ text "Deriving" <+> quotes (ppr typeableClassName) <+>+                     text "has no effect: all types now auto-derive Typeable" }++------------------------------------------------------------------+deriveTyData :: [TyVar] -> TyCon -> [Type]   -- LHS of data or data instance+                    -- Can be a data instance, hence [Type] args+                    -- and in that case the TyCon is the /family/ tycon+             -> Maybe (DerivStrategy GhcRn)  -- The optional deriving strategy+             -> LHsSigType GhcRn             -- The deriving predicate+             -> TcM (Maybe EarlyDerivSpec)+-- The deriving clause of a data or newtype declaration+-- I.e. not standalone deriving+--+-- This returns a Maybe because the user might try to derive Typeable, which is+-- a no-op nowadays.+deriveTyData tvs tc tc_args mb_deriv_strat deriv_pred+  = setSrcSpan (getLoc (hsSigType deriv_pred)) $+    -- Use loc of the 'deriving' item+    do  { (mb_deriv_strat', deriv_tvs, (cls, cls_tys, cls_arg_kinds))+                <- tcExtendTyVarEnv tvs $+                -- Deriving preds may (now) mention+                -- the type variables for the type constructor, hence tcExtendTyVarenv+                -- The "deriv_pred" is a LHsType to take account of the fact that for+                -- newtype deriving we allow deriving (forall a. C [a]).++                -- Typeable is special, because Typeable :: forall k. k -> Constraint+                -- so the argument kind 'k' is not decomposable by splitKindFunTys+                -- as is the case for all other derivable type classes+                     tcDerivStrategy mb_deriv_strat $+                     tcHsDeriv deriv_pred++        ; when (cls_arg_kinds `lengthIsNot` 1) $+            failWithTc (nonUnaryErr deriv_pred)+        ; let [cls_arg_kind] = cls_arg_kinds+        ; if className cls == typeableClassName+          then do warnUselessTypeable+                  return Nothing+          else++     do {  -- Given data T a b c = ... deriving( C d ),+           -- we want to drop type variables from T so that (C d (T a)) is well-kinded+          let (arg_kinds, _)  = splitFunTys cls_arg_kind+              n_args_to_drop  = length arg_kinds+              n_args_to_keep  = length tc_args - n_args_to_drop+                                -- See Note [tc_args and tycon arity]+              (tc_args_to_keep, args_to_drop)+                              = splitAt n_args_to_keep tc_args+              inst_ty_kind    = tcTypeKind (mkTyConApp tc tc_args_to_keep)++              -- Match up the kinds, and apply the resulting kind substitution+              -- to the types.  See Note [Unify kinds in deriving]+              -- We are assuming the tycon tyvars and the class tyvars are distinct+              mb_match        = tcUnifyTy inst_ty_kind cls_arg_kind+              enough_args     = n_args_to_keep >= 0++        -- Check that the result really is well-kinded+        ; checkTc (enough_args && isJust mb_match)+                  (derivingKindErr tc cls cls_tys cls_arg_kind enough_args)++        ; let propagate_subst kind_subst tkvs' cls_tys' tc_args'+                = (final_tkvs, final_cls_tys, final_tc_args)+                where+                  ki_subst_range  = getTCvSubstRangeFVs kind_subst+                  -- See Note [Unification of two kind variables in deriving]+                  unmapped_tkvs   = filter (\v -> v `notElemTCvSubst` kind_subst+                                         && not (v `elemVarSet` ki_subst_range))+                                           tkvs'+                  (subst, _)      = substTyVarBndrs kind_subst unmapped_tkvs+                  final_tc_args   = substTys subst tc_args'+                  final_cls_tys   = substTys subst cls_tys'+                  final_tkvs      = tyCoVarsOfTypesWellScoped $+                                    final_cls_tys ++ final_tc_args++        ; let tkvs = scopedSort $ fvVarList $+                     unionFV (tyCoFVsOfTypes tc_args_to_keep)+                             (FV.mkFVs deriv_tvs)+              Just kind_subst = mb_match+              (tkvs', final_cls_tys', final_tc_args')+                = propagate_subst kind_subst tkvs cls_tys tc_args_to_keep++          -- See Note [Unify kinds in deriving]+        ; (tkvs, final_cls_tys, final_tc_args, final_mb_deriv_strat) <-+            case mb_deriv_strat' of+              -- Perform an additional unification with the kind of the `via`+              -- type and the result of the previous kind unification.+              Just (ViaStrategy via_ty) -> do+                let final_via_ty   = via_ty+                    final_via_kind = tcTypeKind final_via_ty+                    final_inst_ty_kind+                              = tcTypeKind (mkTyConApp tc final_tc_args')+                    via_match = tcUnifyTy final_inst_ty_kind final_via_kind++                checkTc (isJust via_match)+                        (derivingViaKindErr cls final_inst_ty_kind+                                            final_via_ty final_via_kind)++                let Just via_subst = via_match+                    (final_tkvs, final_cls_tys, final_tc_args)+                      = propagate_subst via_subst tkvs'+                                        final_cls_tys' final_tc_args'+                pure ( final_tkvs, final_cls_tys, final_tc_args+                     , Just $ ViaStrategy $ substTy via_subst via_ty+                     )++              _ -> pure ( tkvs', final_cls_tys', final_tc_args'+                        , mb_deriv_strat' )++        ; traceTc "Deriving strategy (deriving clause)" $+            vcat [ppr final_mb_deriv_strat, ppr deriv_pred]++        ; traceTc "derivTyData1" (vcat [ pprTyVars tvs, ppr tc, ppr tc_args+                                       , ppr deriv_pred+                                       , pprTyVars (tyCoVarsOfTypesList tc_args)+                                       , ppr n_args_to_keep, ppr n_args_to_drop+                                       , ppr inst_ty_kind, ppr cls_arg_kind, ppr mb_match+                                       , ppr final_tc_args, ppr final_cls_tys ])++        ; traceTc "derivTyData2" (vcat [ ppr tkvs ])++        ; let final_tc_app = mkTyConApp tc final_tc_args+        ; checkTc (allDistinctTyVars (mkVarSet tkvs) args_to_drop)     -- (a, b, c)+                  (derivingEtaErr cls final_cls_tys final_tc_app)+                -- Check that+                --  (a) The args to drop are all type variables; eg reject:+                --              data instance T a Int = .... deriving( Monad )+                --  (b) The args to drop are all *distinct* type variables; eg reject:+                --              class C (a :: * -> * -> *) where ...+                --              data instance T a a = ... deriving( C )+                --  (c) The type class args, or remaining tycon args,+                --      do not mention any of the dropped type variables+                --              newtype T a s = ... deriving( ST s )+                --              newtype instance K a a = ... deriving( Monad )+                --+                -- It is vital that the implementation of allDistinctTyVars+                -- expand any type synonyms.+                -- See Note [Eta-reducing type synonyms]++        ; checkValidInstHead DerivClauseCtxt cls $+                             final_cls_tys ++ [final_tc_app]+                -- Check that we aren't deriving an instance of a magical+                -- type like (~) or Coercible (#14916).++        ; spec <- mkEqnHelp Nothing tkvs+                            cls final_cls_tys tc final_tc_args+                            (InferContext Nothing) final_mb_deriv_strat+        ; traceTc "derivTyData" (ppr spec)+        ; return $ Just spec } }+++{- Note [tc_args and tycon arity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You might wonder if we could use (tyConArity tc) at this point, rather+than (length tc_args).  But for data families the two can differ!  The+tc and tc_args passed into 'deriveTyData' come from 'deriveClause' which+in turn gets them from 'tyConFamInstSig_maybe' which in turn gets them+from DataFamInstTyCon:++| DataFamInstTyCon          -- See Note [Data type families]+      (CoAxiom Unbranched)+      TyCon   -- The family TyCon+      [Type]  -- Argument types (mentions the tyConTyVars of this TyCon)+              -- No shorter in length than the tyConTyVars of the family TyCon+              -- How could it be longer? See [Arity of data families] in FamInstEnv++Notice that the arg tys might not be the same as the family tycon arity+(= length tyConTyVars).++Note [Unify kinds in deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#8534)+    data T a b = MkT a deriving( Functor )+    -- where Functor :: (*->*) -> Constraint++So T :: forall k. * -> k -> *.   We want to get+    instance Functor (T * (a:*)) where ...+Notice the '*' argument to T.++Moreover, as well as instantiating T's kind arguments, we may need to instantiate+C's kind args.  Consider (#8865):+  newtype T a b = MkT (Either a b) deriving( Category )+where+  Category :: forall k. (k -> k -> *) -> Constraint+We need to generate the instance+  instance Category * (Either a) where ...+Notice the '*' argument to Category.++So we need to+ * drop arguments from (T a b) to match the number of+   arrows in the (last argument of the) class;+ * and then *unify* kind of the remaining type against the+   expected kind, to figure out how to instantiate C's and T's+   kind arguments.++In the two examples,+ * we unify   kind-of( T k (a:k) ) ~ kind-of( Functor )+         i.e.      (k -> *) ~ (* -> *)   to find k:=*.+         yielding  k:=*++ * we unify   kind-of( Either ) ~ kind-of( Category )+         i.e.      (* -> * -> *)  ~ (k -> k -> k)+         yielding  k:=*++Now we get a kind substitution.  We then need to:++  1. Remove the substituted-out kind variables from the quantified kind vars++  2. Apply the substitution to the kinds of quantified *type* vars+     (and extend the substitution to reflect this change)++  3. Apply that extended substitution to the non-dropped args (types and+     kinds) of the type and class++Forgetting step (2) caused #8893:+  data V a = V [a] deriving Functor+  data P (x::k->*) (a:k) = P (x a) deriving Functor+  data C (x::k->*) (a:k) = C (V (P x a)) deriving Functor++When deriving Functor for P, we unify k to *, but we then want+an instance   $df :: forall (x:*->*). Functor x => Functor (P * (x:*->*))+and similarly for C.  Notice the modified kind of x, both at binding+and occurrence sites.++This can lead to some surprising results when *visible* kind binder is+unified (in contrast to the above examples, in which only non-visible kind+binders were considered). Consider this example from #11732:++    data T k (a :: k) = MkT deriving Functor++Since unification yields k:=*, this results in a generated instance of:++    instance Functor (T *) where ...++which looks odd at first glance, since one might expect the instance head+to be of the form Functor (T k). Indeed, one could envision an alternative+generated instance of:++    instance (k ~ *) => Functor (T k) where++But this does not typecheck by design: kind equalities are not allowed to be+bound in types, only terms. But in essence, the two instance declarations are+entirely equivalent, since even though (T k) matches any kind k, the only+possibly value for k is *, since anything else is ill-typed. As a result, we can+just as comfortably use (T *).++Another way of thinking about is: deriving clauses often infer constraints.+For example:++    data S a = S a deriving Eq++infers an (Eq a) constraint in the derived instance. By analogy, when we+are deriving Functor, we might infer an equality constraint (e.g., k ~ *).+The only distinction is that GHC instantiates equality constraints directly+during the deriving process.++Another quirk of this design choice manifests when typeclasses have visible+kind parameters. Consider this code (also from #11732):++    class Cat k (cat :: k -> k -> *) where+      catId   :: cat a a+      catComp :: cat b c -> cat a b -> cat a c++    instance Cat * (->) where+      catId   = id+      catComp = (.)++    newtype Fun a b = Fun (a -> b) deriving (Cat k)++Even though we requested a derived instance of the form (Cat k Fun), the+kind unification will actually generate (Cat * Fun) (i.e., the same thing as if+the user wrote deriving (Cat *)).++What happens with DerivingVia, when you have yet another type? Consider:++  newtype Foo (a :: Type) = MkFoo (Proxy a)+    deriving Functor via Proxy++As before, we unify the kind of Foo (* -> *) with the kind of the argument to+Functor (* -> *). But that's not enough: the `via` type, Proxy, has the kind+(k -> *), which is more general than what we want. So we must additionally+unify (k -> *) with (* -> *).++Currently, all of this unification is implemented kludgily with the pure+unifier, which is rather tiresome. #14331 lays out a plan for how this+might be made cleaner.++Note [Unification of two kind variables in deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As a special case of the Note above, it is possible to derive an instance of+a poly-kinded typeclass for a poly-kinded datatype. For example:++    class Category (cat :: k -> k -> *) where+    newtype T (c :: k -> k -> *) a b = MkT (c a b) deriving Category++This case is suprisingly tricky. To see why, let's write out what instance GHC+will attempt to derive (using -fprint-explicit-kinds syntax):++    instance Category k1 (T k2 c) where ...++GHC will attempt to unify k1 and k2, which produces a substitution (kind_subst)+that looks like [k2 :-> k1]. Importantly, we need to apply this substitution to+the type variable binder for c, since its kind is (k2 -> k2 -> *).++We used to accomplish this by doing the following:++    unmapped_tkvs = filter (`notElemTCvSubst` kind_subst) all_tkvs+    (subst, _)    = substTyVarBndrs kind_subst unmapped_tkvs++Where all_tkvs contains all kind variables in the class and instance types (in+this case, all_tkvs = [k1,k2]). But since kind_subst only has one mapping,+this results in unmapped_tkvs being [k1], and as a consequence, k1 gets mapped+to another kind variable in subst! That is, subst = [k2 :-> k1, k1 :-> k_new].+This is bad, because applying that substitution yields the following instance:++   instance Category k_new (T k1 c) where ...++In other words, keeping k1 in unmapped_tvks taints the substitution, resulting+in an ill-kinded instance (this caused #11837).++To prevent this, we need to filter out any variable from all_tkvs which either++1. Appears in the domain of kind_subst. notElemTCvSubst checks this.+2. Appears in the range of kind_subst. To do this, we compute the free+   variable set of the range of kind_subst with getTCvSubstRangeFVs, and check+   if a kind variable appears in that set.++Note [Eta-reducing type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+One can instantiate a type in a data family instance with a type synonym that+mentions other type variables:++  type Const a b = a+  data family Fam (f :: * -> *) (a :: *)+  newtype instance Fam f (Const a f) = Fam (f a) deriving Functor++It is also possible to define kind synonyms, and they can mention other types in+a datatype declaration. For example,++  type Const a b = a+  newtype T f (a :: Const * f) = T (f a) deriving Functor++When deriving, we need to perform eta-reduction analysis to ensure that none of+the eta-reduced type variables are mentioned elsewhere in the declaration. But+we need to be careful, because if we don't expand through the Const type+synonym, we will mistakenly believe that f is an eta-reduced type variable and+fail to derive Functor, even though the code above is correct (see #11416,+where this was first noticed). For this reason, we expand the type synonyms in+the eta-reduced types before doing any analysis.+-}++mkEqnHelp :: Maybe OverlapMode+          -> [TyVar]+          -> Class -> [Type]+          -> TyCon -> [Type]+          -> DerivContext+               -- SupplyContext => context supplied (standalone deriving)+               -- InferContext  => context inferred (deriving on data decl, or+               --                  standalone deriving decl with a wildcard)+          -> Maybe (DerivStrategy GhcTc)+          -> TcRn EarlyDerivSpec+-- Make the EarlyDerivSpec for an instance+--      forall tvs. theta => cls (tys ++ [ty])+-- where the 'theta' is optional (that's the Maybe part)+-- Assumes that this declaration is well-kinded++mkEqnHelp overlap_mode tvs cls cls_tys tycon tc_args deriv_ctxt deriv_strat+  = do {      -- Find the instance of a data family+              -- Note [Looking up family instances for deriving]+         fam_envs <- tcGetFamInstEnvs+       ; let (rep_tc, rep_tc_args, _co) = tcLookupDataFamInst fam_envs tycon tc_args+              -- If it's still a data family, the lookup failed; i.e no instance exists+       ; when (isDataFamilyTyCon rep_tc)+              (bale_out (text "No family instance for" <+> quotes (pprTypeApp tycon tc_args)))+       ; is_boot <- tcIsHsBootOrSig+       ; when is_boot $+              bale_out (text "Cannot derive instances in hs-boot files"+                    $+$ text "Write an instance declaration instead")++       ; let deriv_env = DerivEnv+                         { denv_overlap_mode = overlap_mode+                         , denv_tvs          = tvs+                         , denv_cls          = cls+                         , denv_cls_tys      = cls_tys+                         , denv_tc           = tycon+                         , denv_tc_args      = tc_args+                         , denv_rep_tc       = rep_tc+                         , denv_rep_tc_args  = rep_tc_args+                         , denv_ctxt         = deriv_ctxt+                         , denv_strat        = deriv_strat }+       ; flip runReaderT deriv_env $+         if isNewTyCon rep_tc then mkNewTypeEqn else mkDataTypeEqn }+  where+     bale_out msg = failWithTc (derivingThingErr False cls cls_tys+                      (mkTyConApp tycon tc_args) deriv_strat msg)++{-+Note [Looking up family instances for deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcLookupFamInstExact is an auxiliary lookup wrapper which requires+that looked-up family instances exist.  If called with a vanilla+tycon, the old type application is simply returned.++If we have+  data instance F () = ... deriving Eq+  data instance F () = ... deriving Eq+then tcLookupFamInstExact will be confused by the two matches;+but that can't happen because tcInstDecls1 doesn't call tcDeriving+if there are any overlaps.++There are two other things that might go wrong with the lookup.+First, we might see a standalone deriving clause+   deriving Eq (F ())+when there is no data instance F () in scope.++Note that it's OK to have+  data instance F [a] = ...+  deriving Eq (F [(a,b)])+where the match is not exact; the same holds for ordinary data types+with standalone deriving declarations.++Note [Deriving, type families, and partial applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When there are no type families, it's quite easy:++    newtype S a = MkS [a]+    -- :CoS :: S  ~ []  -- Eta-reduced++    instance Eq [a] => Eq (S a)         -- by coercion sym (Eq (:CoS a)) : Eq [a] ~ Eq (S a)+    instance Monad [] => Monad S        -- by coercion sym (Monad :CoS)  : Monad [] ~ Monad S++When type familes are involved it's trickier:++    data family T a b+    newtype instance T Int a = MkT [a] deriving( Eq, Monad )+    -- :RT is the representation type for (T Int a)+    --  :Co:RT    :: :RT ~ []          -- Eta-reduced!+    --  :CoF:RT a :: T Int a ~ :RT a   -- Also eta-reduced!++    instance Eq [a] => Eq (T Int a)     -- easy by coercion+       -- d1 :: Eq [a]+       -- d2 :: Eq (T Int a) = d1 |> Eq (sym (:Co:RT a ; :coF:RT a))++    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???+       -- d1 :: Monad []+       -- d2 :: Monad (T Int) = d1 |> Monad (sym (:Co:RT ; :coF:RT))++Note the need for the eta-reduced rule axioms.  After all, we can+write it out+    instance Monad [] => Monad (T Int)  -- only if we can eta reduce???+      return x = MkT [x]+      ... etc ...++See Note [Eta reduction for data families] in FamInstEnv++%************************************************************************+%*                                                                      *+                Deriving data types+*                                                                      *+************************************************************************+-}++-- | Derive an instance for a data type (i.e., non-newtype).+mkDataTypeEqn :: DerivM EarlyDerivSpec+mkDataTypeEqn+  = do mb_strat <- asks denv_strat+       let bale_out msg = do err <- derivingThingErrM False msg+                             lift $ failWithTc err+       case mb_strat of+         Just StockStrategy    -> mk_eqn_stock    mk_originative_eqn bale_out+         Just AnyclassStrategy -> mk_eqn_anyclass mk_originative_eqn bale_out+         Just (ViaStrategy ty) -> mk_eqn_via ty+         -- GeneralizedNewtypeDeriving makes no sense for non-newtypes+         Just NewtypeStrategy  -> bale_out gndNonNewtypeErr+         -- Lacking a user-requested deriving strategy, we will try to pick+         -- between the stock or anyclass strategies+         Nothing -> mk_eqn_no_mechanism mk_originative_eqn bale_out++-- Derive an instance by way of an originative deriving strategy+-- (stock or anyclass).+--+-- See Note [Deriving strategies]+mk_originative_eqn+  :: DerivSpecMechanism -- Invariant: This will be DerivSpecStock or+                        -- DerivSpecAnyclass+  -> DerivM EarlyDerivSpec+mk_originative_eqn mechanism+  = do DerivEnv { denv_overlap_mode = overlap_mode+                , denv_tvs          = tvs+                , denv_tc           = tc+                , denv_tc_args      = tc_args+                , denv_rep_tc       = rep_tc+                , denv_cls          = cls+                , denv_cls_tys      = cls_tys+                , denv_ctxt         = deriv_ctxt } <- ask+       let inst_ty  = mkTyConApp tc tc_args+           inst_tys = cls_tys ++ [inst_ty]+       doDerivInstErrorChecks1 mechanism+       loc       <- lift getSrcSpanM+       dfun_name <- lift $ newDFunName' cls tc+       case deriv_ctxt of+        InferContext wildcard ->+          do { (inferred_constraints, tvs', inst_tys')+                 <- inferConstraints mechanism+             ; return $ InferTheta $ DS+                   { ds_loc = loc+                   , ds_name = dfun_name, ds_tvs = tvs'+                   , ds_cls = cls, ds_tys = inst_tys'+                   , ds_tc = rep_tc+                   , ds_theta = inferred_constraints+                   , ds_overlap = overlap_mode+                   , ds_standalone_wildcard = wildcard+                   , ds_mechanism = mechanism } }++        SupplyContext theta ->+            return $ GivenTheta $ DS+                   { ds_loc = loc+                   , ds_name = dfun_name, ds_tvs = tvs+                   , ds_cls = cls, ds_tys = inst_tys+                   , ds_tc = rep_tc+                   , ds_theta = theta+                   , ds_overlap = overlap_mode+                   , ds_standalone_wildcard = Nothing+                   , ds_mechanism = mechanism }++-- Derive an instance by way of a coerce-based deriving strategy+-- (newtype or via).+--+-- See Note [Deriving strategies]+mk_coerce_based_eqn+  :: (Type -> DerivSpecMechanism) -- Invariant: This will be DerivSpecNewtype+                                  -- or DerivSpecVia+  -> Type -- The type to coerce+  -> DerivM EarlyDerivSpec+mk_coerce_based_eqn mk_mechanism coerced_ty+  = do DerivEnv { denv_overlap_mode = overlap_mode+                , denv_tvs          = tvs+                , denv_tc           = tycon+                , denv_tc_args      = tc_args+                , denv_rep_tc       = rep_tycon+                , denv_cls          = cls+                , denv_cls_tys      = cls_tys+                , denv_ctxt         = deriv_ctxt } <- ask+       sa_wildcard <- isStandaloneWildcardDeriv+       let -- The following functions are polymorphic over the representation+           -- type, since we might either give it the underlying type of a+           -- newtype (for GeneralizedNewtypeDeriving) or a @via@ type+           -- (for DerivingVia).+           rep_tys ty  = cls_tys ++ [ty]+           rep_pred ty = mkClassPred cls (rep_tys ty)+           rep_pred_o ty = mkPredOrigin deriv_origin TypeLevel (rep_pred ty)+                   -- rep_pred is the representation dictionary, from where+                   -- we are going to get all the methods for the final+                   -- dictionary++           -- Next we figure out what superclass dictionaries to use+           -- See Note [Newtype deriving superclasses] above+           sc_preds   :: [PredOrigin]+           cls_tyvars = classTyVars cls+           inst_ty    = mkTyConApp tycon tc_args+           inst_tys   = cls_tys ++ [inst_ty]+           sc_preds   = map (mkPredOrigin deriv_origin TypeLevel) $+                        substTheta (zipTvSubst cls_tyvars inst_tys) $+                        classSCTheta cls+           deriv_origin = mkDerivOrigin sa_wildcard++           -- Next we collect constraints for the class methods+           -- If there are no methods, we don't need any constraints+           -- Otherwise we need (C rep_ty), for the representation methods,+           -- and constraints to coerce each individual method+           meth_preds :: Type -> [PredOrigin]+           meths = classMethods cls+           meth_preds ty+             | null meths = [] -- No methods => no constraints+                               -- (#12814)+             | otherwise = rep_pred_o ty : coercible_constraints ty+           coercible_constraints ty+             = [ mkPredOrigin (DerivOriginCoerce meth t1 t2 sa_wildcard)+                              TypeLevel (mkReprPrimEqPred t1 t2)+               | meth <- meths+               , let (Pair t1 t2) = mkCoerceClassMethEqn cls tvs+                                            inst_tys ty meth ]++           all_thetas :: Type -> [ThetaOrigin]+           all_thetas ty = [mkThetaOriginFromPreds $ meth_preds ty ++ sc_preds]++           inferred_thetas = all_thetas coerced_ty+       lift $ traceTc "newtype deriving:" $+         ppr tycon <+> ppr (rep_tys coerced_ty) <+> ppr inferred_thetas+       let mechanism = mk_mechanism coerced_ty+           bale_out msg = do err <- derivingThingErrMechanism mechanism msg+                             lift $ failWithTc err+       atf_coerce_based_error_checks cls bale_out+       doDerivInstErrorChecks1 mechanism+       dfun_name <- lift $ newDFunName' cls tycon+       loc       <- lift getSrcSpanM+       case deriv_ctxt of+        SupplyContext theta -> return $ GivenTheta $ DS+            { ds_loc = loc+            , ds_name = dfun_name, ds_tvs = tvs+            , ds_cls = cls, ds_tys = inst_tys+            , ds_tc = rep_tycon+            , ds_theta = theta+            , ds_overlap = overlap_mode+            , ds_standalone_wildcard = Nothing+            , ds_mechanism = mechanism }+        InferContext wildcard -> return $ InferTheta $ DS+            { ds_loc = loc+            , ds_name = dfun_name, ds_tvs = tvs+            , ds_cls = cls, ds_tys = inst_tys+            , ds_tc = rep_tycon+            , ds_theta = inferred_thetas+            , ds_overlap = overlap_mode+            , ds_standalone_wildcard = wildcard+            , ds_mechanism = mechanism }++-- Ensure that a class's associated type variables are suitable for+-- GeneralizedNewtypeDeriving or DerivingVia.+--+-- See Note [GND and associated type families]+atf_coerce_based_error_checks+  :: Class+  -> (SDoc -> DerivM ())+  -> DerivM ()+atf_coerce_based_error_checks cls bale_out+  = let cls_tyvars = classTyVars cls++        ats_look_sensible+           =  -- Check (a) from Note [GND and associated type families]+              no_adfs+              -- Check (b) from Note [GND and associated type families]+           && isNothing at_without_last_cls_tv+              -- Check (d) from Note [GND and associated type families]+           && isNothing at_last_cls_tv_in_kinds++        (adf_tcs, atf_tcs) = partition isDataFamilyTyCon at_tcs+        no_adfs            = null adf_tcs+               -- We cannot newtype-derive data family instances++        at_without_last_cls_tv+          = find (\tc -> last_cls_tv `notElem` tyConTyVars tc) atf_tcs+        at_last_cls_tv_in_kinds+          = find (\tc -> any (at_last_cls_tv_in_kind . tyVarKind)+                             (tyConTyVars tc)+                      || at_last_cls_tv_in_kind (tyConResKind tc)) atf_tcs+        at_last_cls_tv_in_kind kind+          = last_cls_tv `elemVarSet` exactTyCoVarsOfType kind+        at_tcs = classATs cls+        last_cls_tv = ASSERT( notNull cls_tyvars )+                      last cls_tyvars++        cant_derive_err+           = vcat [ ppUnless no_adfs adfs_msg+                  , maybe empty at_without_last_cls_tv_msg+                          at_without_last_cls_tv+                  , maybe empty at_last_cls_tv_in_kinds_msg+                          at_last_cls_tv_in_kinds+                  ]+        adfs_msg  = text "the class has associated data types"+        at_without_last_cls_tv_msg at_tc = hang+          (text "the associated type" <+> quotes (ppr at_tc)+           <+> text "is not parameterized over the last type variable")+          2 (text "of the class" <+> quotes (ppr cls))+        at_last_cls_tv_in_kinds_msg at_tc = hang+          (text "the associated type" <+> quotes (ppr at_tc)+           <+> text "contains the last type variable")+         2 (text "of the class" <+> quotes (ppr cls)+           <+> text "in a kind, which is not (yet) allowed")+    in unless ats_look_sensible $ bale_out cant_derive_err++mk_eqn_stock :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)+             -> (SDoc -> DerivM EarlyDerivSpec)+             -> DerivM EarlyDerivSpec+mk_eqn_stock go_for_it bale_out+  = do DerivEnv { denv_tc      = tc+                , denv_rep_tc  = rep_tc+                , denv_cls     = cls+                , denv_cls_tys = cls_tys+                , denv_ctxt    = deriv_ctxt } <- ask+       dflags <- getDynFlags+       case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys+                                           tc rep_tc of+         CanDeriveStock gen_fn -> go_for_it $ DerivSpecStock gen_fn+         StockClassError msg   -> bale_out msg+         _                     -> bale_out (nonStdErr cls)++mk_eqn_anyclass :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)+                -> (SDoc -> DerivM EarlyDerivSpec)+                -> DerivM EarlyDerivSpec+mk_eqn_anyclass go_for_it bale_out+  = do dflags <- getDynFlags+       case canDeriveAnyClass dflags of+         IsValid      -> go_for_it DerivSpecAnyClass+         NotValid msg -> bale_out msg++mk_eqn_newtype :: Type -- The newtype's representation type+               -> DerivM EarlyDerivSpec+mk_eqn_newtype = mk_coerce_based_eqn DerivSpecNewtype++mk_eqn_via :: Type -- The @via@ type+           -> DerivM EarlyDerivSpec+mk_eqn_via = mk_coerce_based_eqn DerivSpecVia++mk_eqn_no_mechanism :: (DerivSpecMechanism -> DerivM EarlyDerivSpec)+                    -> (SDoc -> DerivM EarlyDerivSpec)+                    -> DerivM EarlyDerivSpec+mk_eqn_no_mechanism go_for_it bale_out+  = do DerivEnv { denv_tc      = tc+                , denv_rep_tc  = rep_tc+                , denv_cls     = cls+                , denv_cls_tys = cls_tys+                , denv_ctxt    = deriv_ctxt } <- ask+       dflags <- getDynFlags++           -- See Note [Deriving instances for classes themselves]+       let dac_error msg+             | isClassTyCon rep_tc+             = quotes (ppr tc) <+> text "is a type class,"+                               <+> text "and can only have a derived instance"+                               $+$ text "if DeriveAnyClass is enabled"+             | otherwise+             = nonStdErr cls $$ msg++       case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys+                                           tc rep_tc of+           -- NB: pass the *representation* tycon to+           -- checkOriginativeSideConditions+           NonDerivableClass   msg -> bale_out (dac_error msg)+           StockClassError msg     -> bale_out msg+           CanDeriveStock gen_fn   -> go_for_it $ DerivSpecStock gen_fn+           CanDeriveAnyClass       -> go_for_it DerivSpecAnyClass++{-+************************************************************************+*                                                                      *+            GeneralizedNewtypeDeriving and DerivingVia+*                                                                      *+************************************************************************+-}++-- | Derive an instance for a newtype.+mkNewTypeEqn :: DerivM EarlyDerivSpec+mkNewTypeEqn+-- Want: instance (...) => cls (cls_tys ++ [tycon tc_args]) where ...+  = do DerivEnv { denv_tc           = tycon+                , denv_rep_tc       = rep_tycon+                , denv_rep_tc_args  = rep_tc_args+                , denv_cls          = cls+                , denv_cls_tys      = cls_tys+                , denv_ctxt         = deriv_ctxt+                , denv_strat        = mb_strat } <- ask+       dflags <- getDynFlags++       let newtype_deriving  = xopt LangExt.GeneralizedNewtypeDeriving dflags+           deriveAnyClass    = xopt LangExt.DeriveAnyClass             dflags+           bale_out        = bale_out' newtype_deriving+           bale_out' b msg = do err <- derivingThingErrM b msg+                                lift $ failWithTc err++           non_std     = nonStdErr cls+           suggest_gnd = text "Try GeneralizedNewtypeDeriving for GHC's"+                     <+> text "newtype-deriving extension"++           -- Here is the plan for newtype derivings.  We see+           --        newtype T a1...an = MkT (t ak+1...an)+           --          deriving (.., C s1 .. sm, ...)+           -- where t is a type,+           --       ak+1...an is a suffix of a1..an, and are all tyvars+           --       ak+1...an do not occur free in t, nor in the s1..sm+           --       (C s1 ... sm) is a  *partial applications* of class C+           --                      with the last parameter missing+           --       (T a1 .. ak) matches the kind of C's last argument+           --              (and hence so does t)+           -- The latter kind-check has been done by deriveTyData already,+           -- and tc_args are already trimmed+           --+           -- We generate the instance+           --       instance forall ({a1..ak} u fvs(s1..sm)).+           --                C s1 .. sm t => C s1 .. sm (T a1...ak)+           -- where T a1...ap is the partial application of+           --       the LHS of the correct kind and p >= k+           --+           --      NB: the variables below are:+           --              tc_tvs = [a1, ..., an]+           --              tyvars_to_keep = [a1, ..., ak]+           --              rep_ty = t ak .. an+           --              deriv_tvs = fvs(s1..sm) \ tc_tvs+           --              tys = [s1, ..., sm]+           --              rep_fn' = t+           --+           -- Running example: newtype T s a = MkT (ST s a) deriving( Monad )+           -- We generate the instance+           --      instance Monad (ST s) => Monad (T s) where++           nt_eta_arity = newTyConEtadArity rep_tycon+                   -- For newtype T a b = MkT (S a a b), the TyCon+                   -- machinery already eta-reduces the representation type, so+                   -- we know that+                   --      T a ~ S a a+                   -- That's convenient here, because we may have to apply+                   -- it to fewer than its original complement of arguments++           -- Note [Newtype representation]+           -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+           -- Need newTyConRhs (*not* a recursive representation finder)+           -- to get the representation type. For example+           --      newtype B = MkB Int+           --      newtype A = MkA B deriving( Num )+           -- We want the Num instance of B, *not* the Num instance of Int,+           -- when making the Num instance of A!+           rep_inst_ty = newTyConInstRhs rep_tycon rep_tc_args++           -------------------------------------------------------------------+           --  Figuring out whether we can only do this newtype-deriving thing++           -- See Note [Determining whether newtype-deriving is appropriate]+           might_be_newtype_derivable+              =  not (non_coercible_class cls)+              && eta_ok+--            && not (isRecursiveTyCon tycon)      -- Note [Recursive newtypes]++           -- Check that eta reduction is OK+           eta_ok = rep_tc_args `lengthAtLeast` nt_eta_arity+             -- The newtype can be eta-reduced to match the number+             --     of type argument actually supplied+             --        newtype T a b = MkT (S [a] b) deriving( Monad )+             --     Here the 'b' must be the same in the rep type (S [a] b)+             --     And the [a] must not mention 'b'.  That's all handled+             --     by nt_eta_rity.++           cant_derive_err = ppUnless eta_ok  eta_msg+           eta_msg = text "cannot eta-reduce the representation type enough"++       MASSERT( cls_tys `lengthIs` (classArity cls - 1) )+       case mb_strat of+         Just StockStrategy    -> mk_eqn_stock    mk_originative_eqn bale_out+         Just AnyclassStrategy -> mk_eqn_anyclass mk_originative_eqn bale_out+         Just NewtypeStrategy  ->+           -- Since the user explicitly asked for GeneralizedNewtypeDeriving,+           -- we don't need to perform all of the checks we normally would,+           -- such as if the class being derived is known to produce ill-roled+           -- coercions (e.g., Traversable), since we can just derive the+           -- instance and let it error if need be.+           -- See Note [Determining whether newtype-deriving is appropriate]+           if eta_ok && newtype_deriving+             then mk_eqn_newtype rep_inst_ty+             else bale_out (cant_derive_err $$+                            if newtype_deriving then empty else suggest_gnd)+         Just (ViaStrategy via_ty) ->+           -- NB: For DerivingVia, we don't need to any eta-reduction checking,+           -- since the @via@ type is already "eta-reduced".+           mk_eqn_via via_ty+         Nothing+           | might_be_newtype_derivable+             && ((newtype_deriving && not deriveAnyClass)+                  || std_class_via_coercible cls)+          -> mk_eqn_newtype rep_inst_ty+           | otherwise+          -> case checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys+                                                 tycon rep_tycon of+               StockClassError msg+                 -- There's a particular corner case where+                 --+                 -- 1. -XGeneralizedNewtypeDeriving and -XDeriveAnyClass are+                 --    both enabled at the same time+                 -- 2. We're deriving a particular stock derivable class+                 --    (such as Functor)+                 --+                 -- and the previous cases won't catch it. This fixes the bug+                 -- reported in #10598.+                 | might_be_newtype_derivable && newtype_deriving+                -> mk_eqn_newtype rep_inst_ty+                 -- Otherwise, throw an error for a stock class+                 | might_be_newtype_derivable && not newtype_deriving+                -> bale_out (msg $$ suggest_gnd)+                 | otherwise+                -> bale_out msg++               -- Must use newtype deriving or DeriveAnyClass+               NonDerivableClass _msg+                 -- Too hard, even with newtype deriving+                 | newtype_deriving           -> bale_out cant_derive_err+                 -- Try newtype deriving!+                 -- Here we suggest GeneralizedNewtypeDeriving even in cases+                 -- where it may not be applicable. See #9600.+                 | otherwise                  -> bale_out (non_std $$ suggest_gnd)++               -- DeriveAnyClass+               CanDeriveAnyClass -> do+                 -- If both DeriveAnyClass and GeneralizedNewtypeDeriving are+                 -- enabled, we take the diplomatic approach of defaulting to+                 -- DeriveAnyClass, but emitting a warning about the choice.+                 -- See Note [Deriving strategies]+                 when (newtype_deriving && deriveAnyClass) $+                   lift $ addWarnTc NoReason $ sep+                     [ text "Both DeriveAnyClass and"+                       <+> text "GeneralizedNewtypeDeriving are enabled"+                     , text "Defaulting to the DeriveAnyClass strategy"+                       <+> text "for instantiating" <+> ppr cls+                     , text "Use DerivingStrategies to pick"+                       <+> text "a different strategy"+                      ]+                 mk_originative_eqn DerivSpecAnyClass+               -- CanDeriveStock+               CanDeriveStock gen_fn -> mk_originative_eqn $+                                        DerivSpecStock gen_fn++{-+Note [Recursive newtypes]+~~~~~~~~~~~~~~~~~~~~~~~~~+Newtype deriving works fine, even if the newtype is recursive.+e.g.    newtype S1 = S1 [T1 ()]+        newtype T1 a = T1 (StateT S1 IO a ) deriving( Monad )+Remember, too, that type families are currently (conservatively) given+a recursive flag, so this also allows newtype deriving to work+for type famillies.++We used to exclude recursive types, because we had a rather simple+minded way of generating the instance decl:+   newtype A = MkA [A]+   instance Eq [A] => Eq A      -- Makes typechecker loop!+But now we require a simple context, so it's ok.++Note [Determining whether newtype-deriving is appropriate]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we see+  newtype NT = MkNT Foo+    deriving C+we have to decide how to perform the deriving. Do we do newtype deriving,+or do we do normal deriving? In general, we prefer to do newtype deriving+wherever possible. So, we try newtype deriving unless there's a glaring+reason not to.++"Glaring reasons not to" include trying to derive a class for which a+coercion-based instance doesn't make sense. These classes are listed in+the definition of non_coercible_class. They include Show (since it must+show the name of the datatype) and Traversable (since a coercion-based+Traversable instance is ill-roled).++However, non_coercible_class is ignored if the user explicitly requests+to derive an instance with GeneralizedNewtypeDeriving using the newtype+deriving strategy. In such a scenario, GHC will unquestioningly try to+derive the instance via coercions (even if the final generated code is+ill-roled!). See Note [Deriving strategies].++Note that newtype deriving might fail, even after we commit to it. This+is because the derived instance uses `coerce`, which must satisfy its+`Coercible` constraint. This is different than other deriving scenarios,+where we're sure that the resulting instance will type-check.++Note [GND and associated type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's possible to use GeneralizedNewtypeDeriving (GND) to derive instances for+classes with associated type families. A general recipe is:++    class C x y z where+      type T y z x+      op :: x -> [y] -> z++    newtype N a = MkN <rep-type> deriving( C )++    =====>++    instance C x y <rep-type> => C x y (N a) where+      type T y (N a) x = T y <rep-type> x+      op = coerce (op :: x -> [y] -> <rep-type>)++However, we must watch out for three things:++(a) The class must not contain any data families. If it did, we'd have to+    generate a fresh data constructor name for the derived data family+    instance, and it's not clear how to do this.++(b) Each associated type family's type variables must mention the last type+    variable of the class. As an example, you wouldn't be able to use GND to+    derive an instance of this class:++      class C a b where+        type T a++    But you would be able to derive an instance of this class:++      class C a b where+        type T b++    The difference is that in the latter T mentions the last parameter of C+    (i.e., it mentions b), but the former T does not. If you tried, e.g.,++      newtype Foo x = Foo x deriving (C a)++    with the former definition of C, you'd end up with something like this:++      instance C a (Foo x) where+        type T a = T ???++    This T family instance doesn't mention the newtype (or its representation+    type) at all, so we disallow such constructions with GND.++(c) UndecidableInstances might need to be enabled. Here's a case where it is+    most definitely necessary:++      class C a where+        type T a+      newtype Loop = Loop MkLoop deriving C++      =====>++      instance C Loop where+        type T Loop = T Loop++    Obviously, T Loop would send the typechecker into a loop. Unfortunately,+    you might even need UndecidableInstances even in cases where the+    typechecker would be guaranteed to terminate. For example:++      instance C Int where+        type C Int = Int+      newtype MyInt = MyInt Int deriving C++      =====>++      instance C MyInt where+        type T MyInt = T Int++    GHC's termination checker isn't sophisticated enough to conclude that the+    definition of T MyInt terminates, so UndecidableInstances is required.++(d) For the time being, we do not allow the last type variable of the class to+    appear in a /kind/ of an associated type family definition. For instance:++    class C a where+      type T1 a        -- OK+      type T2 (x :: a) -- Illegal: a appears in the kind of x+      type T3 y :: a   -- Illegal: a appears in the kind of (T3 y)++    The reason we disallow this is because our current approach to deriving+    associated type family instances—i.e., by unwrapping the newtype's type+    constructor as shown above—is ill-equipped to handle the scenario when+    the last type variable appears as an implicit argument. In the worst case,+    allowing the last variable to appear in a kind can result in improper Core+    being generated (see #14728).++    There is hope for this feature being added some day, as one could+    conceivably take a newtype axiom (which witnesses a coercion between a+    newtype and its representation type) at lift that through each associated+    type at the Core level. See #14728, comment:3 for a sketch of how this+    might work. Until then, we disallow this featurette wholesale.++The same criteria apply to DerivingVia.++************************************************************************+*                                                                      *+\subsection[TcDeriv-normal-binds]{Bindings for the various classes}+*                                                                      *+************************************************************************++After all the trouble to figure out the required context for the+derived instance declarations, all that's left is to chug along to+produce them.  They will then be shoved into @tcInstDecls2@, which+will do all its usual business.++There are lots of possibilities for code to generate.  Here are+various general remarks.++PRINCIPLES:+\begin{itemize}+\item+We want derived instances of @Eq@ and @Ord@ (both v common) to be+``you-couldn't-do-better-by-hand'' efficient.++\item+Deriving @Show@---also pretty common--- should also be reasonable good code.++\item+Deriving for the other classes isn't that common or that big a deal.+\end{itemize}++PRAGMATICS:++\begin{itemize}+\item+Deriving @Ord@ is done mostly with the 1.3 @compare@ method.++\item+Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too.++\item+We {\em normally} generate code only for the non-defaulted methods;+there are some exceptions for @Eq@ and (especially) @Ord@...++\item+Sometimes we use a @_con2tag_<tycon>@ function, which returns a data+constructor's numeric (@Int#@) tag.  These are generated by+@gen_tag_n_con_binds@, and the heuristic for deciding if one of+these is around is given by @hasCon2TagFun@.++The examples under the different sections below will make this+clearer.++\item+Much less often (really just for deriving @Ix@), we use a+@_tag2con_<tycon>@ function.  See the examples.++\item+We use the renamer!!!  Reason: we're supposed to be+producing @LHsBinds Name@ for the methods, but that means+producing correctly-uniquified code on the fly.  This is entirely+possible (the @TcM@ monad has a @UniqueSupply@), but it is painful.+So, instead, we produce @MonoBinds RdrName@ then heave 'em through+the renamer.  What a great hack!+\end{itemize}+-}++-- Generate the InstInfo for the required instance paired with the+--   *representation* tycon for that instance,+-- plus any auxiliary bindings required+--+-- Representation tycons differ from the tycon in the instance signature in+-- case of instances for indexed families.+--+genInst :: DerivSpec theta+        -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])+-- We must use continuation-returning style here to get the order in which we+-- typecheck family instances and derived instances right.+-- See Note [Staging of tcDeriving]+genInst spec@(DS { ds_tvs = tvs, ds_tc = rep_tycon+                 , ds_mechanism = mechanism, ds_tys = tys+                 , ds_cls = clas, ds_loc = loc+                 , ds_standalone_wildcard = wildcard })+  = do (meth_binds, deriv_stuff, unusedNames)+         <- set_span_and_ctxt $+            genDerivStuff mechanism loc clas rep_tycon tys tvs+       let mk_inst_info theta = set_span_and_ctxt $ do+             inst_spec <- newDerivClsInst theta spec+             doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism+             traceTc "newder" (ppr inst_spec)+             return $ InstInfo+                       { iSpec   = inst_spec+                       , iBinds  = InstBindings+                                     { ib_binds = meth_binds+                                     , ib_tyvars = map Var.varName tvs+                                     , ib_pragmas = []+                                     , ib_extensions = extensions+                                     , ib_derived = True } }+       return (mk_inst_info, deriv_stuff, unusedNames)+  where+    extensions :: [LangExt.Extension]+    extensions+      | isDerivSpecNewtype mechanism || isDerivSpecVia mechanism+        -- Both these flags are needed for higher-rank uses of coerce+        -- See Note [Newtype-deriving instances] in TcGenDeriv+      = [LangExt.ImpredicativeTypes, LangExt.RankNTypes]+      | otherwise+      = []++    set_span_and_ctxt :: TcM a -> TcM a+    set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)++doDerivInstErrorChecks1 :: DerivSpecMechanism -> DerivM ()+doDerivInstErrorChecks1 mechanism = do+    DerivEnv { denv_tc      = tc+             , denv_rep_tc  = rep_tc } <- ask+    standalone <- isStandaloneDeriv+    let anyclass_strategy = isDerivSpecAnyClass mechanism+        via_strategy      = isDerivSpecVia mechanism+        bale_out msg = do err <- derivingThingErrMechanism mechanism msg+                          lift $ failWithTc err++    -- For standalone deriving, check that all the data constructors are in+    -- scope...+    rdr_env <- lift getGlobalRdrEnv+    let data_con_names = map dataConName (tyConDataCons rep_tc)+        hidden_data_cons = not (isWiredInName (tyConName rep_tc)) &&+                           (isAbstractTyCon rep_tc ||+                            any not_in_scope data_con_names)+        not_in_scope dc  = isNothing (lookupGRE_Name rdr_env dc)++    lift $ addUsedDataCons rdr_env rep_tc++    -- ...however, we don't perform this check if we're using DeriveAnyClass,+    -- since it doesn't generate any code that requires use of a data+    -- constructor. Nor do we perform this check with @deriving via@, as it+    -- doesn't explicitly require the constructors to be in scope.+    unless (anyclass_strategy || via_strategy+            || not standalone || not hidden_data_cons) $+           bale_out $ derivingHiddenErr tc++doDerivInstErrorChecks2 :: Class -> ClsInst -> ThetaType -> Maybe SrcSpan+                        -> DerivSpecMechanism -> TcM ()+doDerivInstErrorChecks2 clas clas_inst theta wildcard mechanism+  = do { traceTc "doDerivInstErrorChecks2" (ppr clas_inst)+       ; dflags <- getDynFlags+       ; xpartial_sigs <- xoptM LangExt.PartialTypeSignatures+       ; wpartial_sigs <- woptM Opt_WarnPartialTypeSignatures++         -- Error if PartialTypeSignatures isn't enabled when a user tries+         -- to write @deriving instance _ => Eq (Foo a)@. Or, if that+         -- extension is enabled, give a warning if -Wpartial-type-signatures+         -- is enabled.+       ; case wildcard of+           Nothing -> pure ()+           Just span -> setSrcSpan span $ do+             checkTc xpartial_sigs (hang partial_sig_msg 2 pts_suggestion)+             warnTc (Reason Opt_WarnPartialTypeSignatures)+                    wpartial_sigs partial_sig_msg++         -- Check for Generic instances that are derived with an exotic+         -- deriving strategy like DAC+         -- See Note [Deriving strategies]+       ; when (exotic_mechanism && className clas `elem` genericClassNames) $+         do { failIfTc (safeLanguageOn dflags) gen_inst_err+            ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) } }+  where+    exotic_mechanism = not $ isDerivSpecStock mechanism++    partial_sig_msg = text "Found type wildcard" <+> quotes (char '_')+                  <+> text "standing for" <+> quotes (pprTheta theta)++    pts_suggestion+      = text "To use the inferred type, enable PartialTypeSignatures"++    gen_inst_err = text "Generic instances can only be derived in"+               <+> text "Safe Haskell using the stock strategy."++genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class+              -> TyCon -> [Type] -> [TyVar]+              -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name])+genDerivStuff mechanism loc clas tycon inst_tys tyvars+  = case mechanism of+      -- See Note [Bindings for Generalised Newtype Deriving]+      DerivSpecNewtype rhs_ty -> gen_newtype_or_via rhs_ty++      -- Try a stock deriver+      DerivSpecStock gen_fn -> gen_fn loc tycon inst_tys++      -- Try DeriveAnyClass+      DerivSpecAnyClass -> do+        let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)+            mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env+        dflags <- getDynFlags+        tyfam_insts <-+          -- canDeriveAnyClass should ensure that this code can't be reached+          -- unless -XDeriveAnyClass is enabled.+          ASSERT2( isValid (canDeriveAnyClass dflags)+                 , ppr "genDerivStuff: bad derived class" <+> ppr clas )+          mapM (tcATDefault loc mini_subst emptyNameSet)+               (classATItems clas)+        return ( emptyBag -- No method bindings are needed...+               , listToBag (map DerivFamInst (concat tyfam_insts))+               -- ...but we may need to generate binding for associated type+               -- family default instances.+               -- See Note [DeriveAnyClass and default family instances]+               , [] )++      -- Try DerivingVia+      DerivSpecVia via_ty -> gen_newtype_or_via via_ty+  where+    gen_newtype_or_via ty = do+      (binds, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty+      return (binds, faminsts, maybeToList unusedConName)++    unusedConName :: Maybe Name+    unusedConName+      | isDerivSpecNewtype mechanism+        -- See Note [Newtype deriving and unused constructors]+      = Just $ getName $ head $ tyConDataCons tycon+      | otherwise+      = Nothing++{-+Note [Bindings for Generalised Newtype Deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  class Eq a => C a where+     f :: a -> a+  newtype N a = MkN [a] deriving( C )+  instance Eq (N a) where ...++The 'deriving C' clause generates, in effect+  instance (C [a], Eq a) => C (N a) where+     f = coerce (f :: [a] -> [a])++This generates a cast for each method, but allows the superclasse to+be worked out in the usual way.  In this case the superclass (Eq (N+a)) will be solved by the explicit Eq (N a) instance.  We do *not*+create the superclasses by casting the superclass dictionaries for the+representation type.++See the paper "Safe zero-cost coercions for Haskell".++Note [DeriveAnyClass and default family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When a class has a associated type family with a default instance, e.g.:++  class C a where+    type T a+    type T a = Char++then there are a couple of scenarios in which a user would expect T a to+default to Char. One is when an instance declaration for C is given without+an implementation for T:++  instance C Int++Another scenario in which this can occur is when the -XDeriveAnyClass extension+is used:++  data Example = Example deriving (C, Generic)++In the latter case, we must take care to check if C has any associated type+families with default instances, because -XDeriveAnyClass will never provide+an implementation for them. We "fill in" the default instances using the+tcATDefault function from TcClassDcl (which is also used in TcInstDcls to+handle the empty instance declaration case).++Note [Deriving strategies]+~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC has a notion of deriving strategies, which allow the user to explicitly+request which approach to use when deriving an instance (enabled with the+-XDerivingStrategies language extension). For more information, refer to the+original issue (#10598) or the associated wiki page:+https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies++A deriving strategy can be specified in a deriving clause:++    newtype Foo = MkFoo Bar+      deriving newtype C++Or in a standalone deriving declaration:++    deriving anyclass instance C Foo++-XDerivingStrategies also allows the use of multiple deriving clauses per data+declaration so that a user can derive some instance with one deriving strategy+and other instances with another deriving strategy. For example:++    newtype Baz = Baz Quux+      deriving          (Eq, Ord)+      deriving stock    (Read, Show)+      deriving newtype  (Num, Floating)+      deriving anyclass C++Currently, the deriving strategies are:++* stock: Have GHC implement a "standard" instance for a data type, if possible+  (e.g., Eq, Ord, Generic, Data, Functor, etc.)++* anyclass: Use -XDeriveAnyClass++* newtype: Use -XGeneralizedNewtypeDeriving++* via: Use -XDerivingVia++The latter two strategies (newtype and via) are referred to as the+"coerce-based" strategies, since they generate code that relies on the `coerce`+function. The former two strategies (stock and anyclass), in contrast, are+referred to as the "originative" strategies, since they create "original"+instances instead of "reusing" old instances (by way of `coerce`).++If an explicit deriving strategy is not given, GHC has an algorithm it uses to+determine which strategy it will actually use. The algorithm is quite long,+so it lives in the Haskell wiki at+https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/deriving-strategies+("The deriving strategy resolution algorithm" section).++Internally, GHC uses the DerivStrategy datatype to denote a user-requested+deriving strategy, and it uses the DerivSpecMechanism datatype to denote what+GHC will use to derive the instance after taking the above steps. In other+words, GHC will always settle on a DerivSpecMechnism, even if the user did not+ask for a particular DerivStrategy (using the algorithm linked to above).++Note [Deriving instances for classes themselves]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Much of the code in TcDeriv assumes that deriving only works on data types.+But this assumption doesn't hold true for DeriveAnyClass, since it's perfectly+reasonable to do something like this:++  {-# LANGUAGE DeriveAnyClass #-}+  class C1 (a :: Constraint) where+  class C2 where+  deriving instance C1 C2+    -- This is equivalent to `instance C1 C2`++If DeriveAnyClass isn't enabled in the code above (i.e., it defaults to stock+deriving), we throw a special error message indicating that DeriveAnyClass is+the only way to go. We don't bother throwing this error if an explicit 'stock'+or 'newtype' keyword is used, since both options have their own perfectly+sensible error messages in the case of the above code (as C1 isn't a stock+derivable class, and C2 isn't a newtype).++************************************************************************+*                                                                      *+\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}+*                                                                      *+************************************************************************+-}++nonUnaryErr :: LHsSigType GhcRn -> SDoc+nonUnaryErr ct = quotes (ppr ct)+  <+> text "is not a unary constraint, as expected by a deriving clause"++nonStdErr :: Class -> SDoc+nonStdErr cls =+      quotes (ppr cls)+  <+> text "is not a stock derivable class (Eq, Show, etc.)"++gndNonNewtypeErr :: SDoc+gndNonNewtypeErr =+  text "GeneralizedNewtypeDeriving cannot be used on non-newtypes"++derivingNullaryErr :: MsgDoc+derivingNullaryErr = text "Cannot derive instances for nullary classes"++derivingKindErr :: TyCon -> Class -> [Type] -> Kind -> Bool -> MsgDoc+derivingKindErr tc cls cls_tys cls_kind enough_args+  = sep [ hang (text "Cannot derive well-kinded instance of form"+                      <+> quotes (pprClassPred cls cls_tys+                                    <+> parens (ppr tc <+> text "...")))+               2 gen1_suggestion+        , nest 2 (text "Class" <+> quotes (ppr cls)+                      <+> text "expects an argument of kind"+                      <+> quotes (pprKind cls_kind))+        ]+  where+    gen1_suggestion | cls `hasKey` gen1ClassKey && enough_args+                    = text "(Perhaps you intended to use PolyKinds)"+                    | otherwise = Outputable.empty++derivingViaKindErr :: Class -> Kind -> Type -> Kind -> MsgDoc+derivingViaKindErr cls cls_kind via_ty via_kind+  = hang (text "Cannot derive instance via" <+> quotes (pprType via_ty))+       2 (text "Class" <+> quotes (ppr cls)+               <+> text "expects an argument of kind"+               <+> quotes (pprKind cls_kind) <> char ','+      $+$ text "but" <+> quotes (pprType via_ty)+               <+> text "has kind" <+> quotes (pprKind via_kind))++derivingEtaErr :: Class -> [Type] -> Type -> MsgDoc+derivingEtaErr cls cls_tys inst_ty+  = sep [text "Cannot eta-reduce to an instance of form",+         nest 2 (text "instance (...) =>"+                <+> pprClassPred cls (cls_tys ++ [inst_ty]))]++derivingThingErr :: Bool -> Class -> [Type] -> Type+                 -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc+derivingThingErr newtype_deriving cls cls_tys inst_ty mb_strat why+  = derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat+                      (maybe empty derivStrategyName mb_strat) why++derivingThingErrM :: Bool -> MsgDoc -> DerivM MsgDoc+derivingThingErrM newtype_deriving why+  = do DerivEnv { denv_tc      = tc+                , denv_tc_args = tc_args+                , denv_cls     = cls+                , denv_cls_tys = cls_tys+                , denv_strat   = mb_strat } <- ask+       pure $ derivingThingErr newtype_deriving cls cls_tys+                               (mkTyConApp tc tc_args) mb_strat why++derivingThingErrMechanism :: DerivSpecMechanism -> MsgDoc -> DerivM MsgDoc+derivingThingErrMechanism mechanism why+  = do DerivEnv { denv_tc      = tc+                , denv_tc_args = tc_args+                , denv_cls     = cls+                , denv_cls_tys = cls_tys+                , denv_strat   = mb_strat } <- ask+       pure $ derivingThingErr' (isDerivSpecNewtype mechanism) cls cls_tys+                (mkTyConApp tc tc_args) mb_strat+                (derivStrategyName $ derivSpecMechanismToStrategy mechanism)+                why++derivingThingErr' :: Bool -> Class -> [Type] -> Type+                  -> Maybe (DerivStrategy GhcTc) -> MsgDoc -> MsgDoc -> MsgDoc+derivingThingErr' newtype_deriving cls cls_tys inst_ty mb_strat strat_msg why+  = sep [(hang (text "Can't make a derived instance of")+             2 (quotes (ppr pred) <+> via_mechanism)+          $$ nest 2 extra) <> colon,+         nest 2 why]+  where+    strat_used = isJust mb_strat+    extra | not strat_used, newtype_deriving+          = text "(even with cunning GeneralizedNewtypeDeriving)"+          | otherwise = empty+    pred = mkClassPred cls (cls_tys ++ [inst_ty])+    via_mechanism | strat_used+                  = text "with the" <+> strat_msg <+> text "strategy"+                  | otherwise+                  = empty++derivingHiddenErr :: TyCon -> SDoc+derivingHiddenErr tc+  = hang (text "The data constructors of" <+> quotes (ppr tc) <+> ptext (sLit "are not all in scope"))+       2 (text "so you cannot derive an instance for it")++standaloneCtxt :: LHsSigWcType GhcRn -> SDoc+standaloneCtxt ty = hang (text "In the stand-alone deriving instance for")+                       2 (quotes (ppr ty))
+ compiler/typecheck/TcDerivInfer.hs view
@@ -0,0 +1,973 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Functions for inferring (and simplifying) the context for derived instances.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}++module TcDerivInfer (inferConstraints, simplifyInstanceContexts) where++#include "HsVersions.h"++import GhcPrelude++import Bag+import BasicTypes+import Class+import DataCon+import ErrUtils+import Inst+import Outputable+import PrelNames+import TcDerivUtils+import TcEnv+import TcGenFunctor+import TcGenGenerics+import TcMType+import TcRnMonad+import TcType+import TyCon+import Type+import TcSimplify+import TcValidity (validDerivPred)+import TcUnify (buildImplicationFor, checkConstraints)+import Unify (tcUnifyTy)+import Util+import Var+import VarSet++import Control.Monad+import Control.Monad.Trans.Class  (lift)+import Control.Monad.Trans.Reader (ask)+import Data.List+import Data.Maybe++----------------------++inferConstraints :: DerivSpecMechanism+                 -> DerivM ([ThetaOrigin], [TyVar], [TcType])+-- inferConstraints figures out the constraints needed for the+-- instance declaration generated by a 'deriving' clause on a+-- data type declaration. It also returns the new in-scope type+-- variables and instance types, in case they were changed due to+-- the presence of functor-like constraints.+-- See Note [Inferring the instance context]++-- e.g. inferConstraints+--        C Int (T [a])    -- Class and inst_tys+--        :RTList a        -- Rep tycon and its arg tys+-- where T [a] ~R :RTList a+--+-- Generate a sufficiently large set of constraints that typechecking the+-- generated method definitions should succeed.   This set will be simplified+-- before being used in the instance declaration+inferConstraints mechanism+  = do { DerivEnv { denv_tc          = tc+                  , denv_tc_args     = tc_args+                  , denv_cls         = main_cls+                  , denv_cls_tys     = cls_tys } <- ask+       ; wildcard <- isStandaloneWildcardDeriv+       ; let is_anyclass = isDerivSpecAnyClass mechanism+             infer_constraints+               | is_anyclass = inferConstraintsDAC inst_tys+               | otherwise   = inferConstraintsDataConArgs inst_ty inst_tys++             inst_ty  = mkTyConApp tc tc_args+             inst_tys = cls_tys ++ [inst_ty]++             -- Constraints arising from superclasses+             -- See Note [Superclasses of derived instance]+             cls_tvs  = classTyVars main_cls+             sc_constraints = ASSERT2( equalLength cls_tvs inst_tys+                                     , ppr main_cls <+> ppr inst_tys )+                              [ mkThetaOrigin (mkDerivOrigin wildcard)+                                              TypeLevel [] [] [] $+                                substTheta cls_subst (classSCTheta main_cls) ]+             cls_subst = ASSERT( equalLength cls_tvs inst_tys )+                         zipTvSubst cls_tvs inst_tys++       ; (inferred_constraints, tvs', inst_tys') <- infer_constraints+       ; lift $ traceTc "inferConstraints" $ vcat+              [ ppr main_cls <+> ppr inst_tys'+              , ppr inferred_constraints+              ]+       ; return ( sc_constraints ++ inferred_constraints+                , tvs', inst_tys' ) }++-- | Like 'inferConstraints', but used only in the case of deriving strategies+-- where the constraints are inferred by inspecting the fields of each data+-- constructor (i.e., stock- and newtype-deriving).+inferConstraintsDataConArgs :: TcType -> [TcType]+                            -> DerivM ([ThetaOrigin], [TyVar], [TcType])+inferConstraintsDataConArgs inst_ty inst_tys+  = do DerivEnv { denv_tvs         = tvs+                , denv_rep_tc      = rep_tc+                , denv_rep_tc_args = rep_tc_args+                , denv_cls         = main_cls+                , denv_cls_tys     = cls_tys } <- ask+       wildcard <- isStandaloneWildcardDeriv++       let tc_binders = tyConBinders rep_tc+           choose_level bndr+             | isNamedTyConBinder bndr = KindLevel+             | otherwise               = TypeLevel+           t_or_ks = map choose_level tc_binders ++ repeat TypeLevel+              -- want to report *kind* errors when possible++              -- Constraints arising from the arguments of each constructor+           con_arg_constraints+             :: (CtOrigin -> TypeOrKind+                          -> Type+                          -> [([PredOrigin], Maybe TCvSubst)])+             -> ([ThetaOrigin], [TyVar], [TcType])+           con_arg_constraints get_arg_constraints+             = let (predss, mbSubsts) = unzip+                     [ preds_and_mbSubst+                     | data_con <- tyConDataCons rep_tc+                     , (arg_n, arg_t_or_k, arg_ty)+                         <- zip3 [1..] t_or_ks $+                            dataConInstOrigArgTys data_con all_rep_tc_args+                       -- No constraints for unlifted types+                       -- See Note [Deriving and unboxed types]+                     , not (isUnliftedType arg_ty)+                     , let orig = DerivOriginDC data_con arg_n wildcard+                     , preds_and_mbSubst+                         <- get_arg_constraints orig arg_t_or_k arg_ty+                     ]+                   preds = concat predss+                   -- If the constraints require a subtype to be of kind+                   -- (* -> *) (which is the case for functor-like+                   -- constraints), then we explicitly unify the subtype's+                   -- kinds with (* -> *).+                   -- See Note [Inferring the instance context]+                   subst        = foldl' composeTCvSubst+                                         emptyTCvSubst (catMaybes mbSubsts)+                   unmapped_tvs = filter (\v -> v `notElemTCvSubst` subst+                                             && not (v `isInScope` subst)) tvs+                   (subst', _)  = substTyVarBndrs subst unmapped_tvs+                   preds'       = map (substPredOrigin subst') preds+                   inst_tys'    = substTys subst' inst_tys+                   tvs'         = tyCoVarsOfTypesWellScoped inst_tys'+               in ([mkThetaOriginFromPreds preds'], tvs', inst_tys')++           is_generic  = main_cls `hasKey` genClassKey+           is_generic1 = main_cls `hasKey` gen1ClassKey+           -- is_functor_like: see Note [Inferring the instance context]+           is_functor_like = tcTypeKind inst_ty `tcEqKind` typeToTypeKind+                          || is_generic1++           get_gen1_constraints :: Class -> CtOrigin -> TypeOrKind -> Type+                                -> [([PredOrigin], Maybe TCvSubst)]+           get_gen1_constraints functor_cls orig t_or_k ty+              = mk_functor_like_constraints orig t_or_k functor_cls $+                get_gen1_constrained_tys last_tv ty++           get_std_constrained_tys :: CtOrigin -> TypeOrKind -> Type+                                   -> [([PredOrigin], Maybe TCvSubst)]+           get_std_constrained_tys orig t_or_k ty+               | is_functor_like+               = mk_functor_like_constraints orig t_or_k main_cls $+                 deepSubtypesContaining last_tv ty+               | otherwise+               = [( [mk_cls_pred orig t_or_k main_cls ty]+                  , Nothing )]++           mk_functor_like_constraints :: CtOrigin -> TypeOrKind+                                       -> Class -> [Type]+                                       -> [([PredOrigin], Maybe TCvSubst)]+           -- 'cls' is usually main_cls (Functor or Traversable etc), but if+           -- main_cls = Generic1, then 'cls' can be Functor; see+           -- get_gen1_constraints+           --+           -- For each type, generate two constraints,+           -- [cls ty, kind(ty) ~ (*->*)], and a kind substitution that results+           -- from unifying  kind(ty) with * -> *. If the unification is+           -- successful, it will ensure that the resulting instance is well+           -- kinded. If not, the second constraint will result in an error+           -- message which points out the kind mismatch.+           -- See Note [Inferring the instance context]+           mk_functor_like_constraints orig t_or_k cls+              = map $ \ty -> let ki = tcTypeKind ty in+                             ( [ mk_cls_pred orig t_or_k cls ty+                               , mkPredOrigin orig KindLevel+                                   (mkPrimEqPred ki typeToTypeKind) ]+                             , tcUnifyTy ki typeToTypeKind+                             )++           rep_tc_tvs      = tyConTyVars rep_tc+           last_tv         = last rep_tc_tvs+           -- When we first gather up the constraints to solve, most of them+           -- contain rep_tc_tvs, i.e., the type variables from the derived+           -- datatype's type constructor. We don't want these type variables+           -- to appear in the final instance declaration, so we must+           -- substitute each type variable with its counterpart in the derived+           -- instance. rep_tc_args lists each of these counterpart types in+           -- the same order as the type variables.+           all_rep_tc_args+             = rep_tc_args ++ map mkTyVarTy+                                  (drop (length rep_tc_args) rep_tc_tvs)++               -- Stupid constraints+           stupid_constraints+             = [ mkThetaOrigin deriv_origin TypeLevel [] [] [] $+                 substTheta tc_subst (tyConStupidTheta rep_tc) ]+           tc_subst = -- See the comment with all_rep_tc_args for an+                      -- explanation of this assertion+                      ASSERT( equalLength rep_tc_tvs all_rep_tc_args )+                      zipTvSubst rep_tc_tvs all_rep_tc_args++           -- Extra Data constraints+           -- The Data class (only) requires that for+           --    instance (...) => Data (T t1 t2)+           -- IF   t1:*, t2:*+           -- THEN (Data t1, Data t2) are among the (...) constraints+           -- Reason: when the IF holds, we generate a method+           --             dataCast2 f = gcast2 f+           --         and we need the Data constraints to typecheck the method+           extra_constraints = [mkThetaOriginFromPreds constrs]+             where+               constrs+                 | main_cls `hasKey` dataClassKey+                 , all (isLiftedTypeKind . tcTypeKind) rep_tc_args+                 = [ mk_cls_pred deriv_origin t_or_k main_cls ty+                   | (t_or_k, ty) <- zip t_or_ks rep_tc_args]+                 | otherwise+                 = []++           mk_cls_pred orig t_or_k cls ty+                -- Don't forget to apply to cls_tys' too+              = mkPredOrigin orig t_or_k (mkClassPred cls (cls_tys' ++ [ty]))+           cls_tys' | is_generic1 = []+                      -- In the awkward Generic1 case, cls_tys' should be+                      -- empty, since we are applying the class Functor.++                    | otherwise   = cls_tys++           deriv_origin = mkDerivOrigin wildcard++       if    -- Generic constraints are easy+          |  is_generic+           -> return ([], tvs, inst_tys)++             -- Generic1 needs Functor+             -- See Note [Getting base classes]+          |  is_generic1+           -> ASSERT( rep_tc_tvs `lengthExceeds` 0 )+              -- Generic1 has a single kind variable+              ASSERT( cls_tys `lengthIs` 1 )+              do { functorClass <- lift $ tcLookupClass functorClassName+                 ; pure $ con_arg_constraints+                        $ get_gen1_constraints functorClass }++             -- The others are a bit more complicated+          |  otherwise+           -> -- See the comment with all_rep_tc_args for an explanation of+              -- this assertion+              ASSERT2( equalLength rep_tc_tvs all_rep_tc_args+                     , ppr main_cls <+> ppr rep_tc+                       $$ ppr rep_tc_tvs $$ ppr all_rep_tc_args )+                do { let (arg_constraints, tvs', inst_tys')+                           = con_arg_constraints get_std_constrained_tys+                   ; lift $ traceTc "inferConstraintsDataConArgs" $ vcat+                          [ ppr main_cls <+> ppr inst_tys'+                          , ppr arg_constraints+                          ]+                   ; return ( stupid_constraints ++ extra_constraints+                                                 ++ arg_constraints+                            , tvs', inst_tys') }++typeToTypeKind :: Kind+typeToTypeKind = liftedTypeKind `mkVisFunTy` liftedTypeKind++-- | Like 'inferConstraints', but used only in the case of @DeriveAnyClass@,+-- which gathers its constraints based on the type signatures of the class's+-- methods instead of the types of the data constructor's field.+--+-- See Note [Gathering and simplifying constraints for DeriveAnyClass]+-- for an explanation of how these constraints are used to determine the+-- derived instance context.+inferConstraintsDAC :: [TcType] -> DerivM ([ThetaOrigin], [TyVar], [TcType])+inferConstraintsDAC inst_tys+  = do { DerivEnv { denv_tvs = tvs+                  , denv_cls = cls } <- ask+       ; wildcard <- isStandaloneWildcardDeriv++       ; let gen_dms = [ (sel_id, dm_ty)+                       | (sel_id, Just (_, GenericDM dm_ty)) <- classOpItems cls ]++             cls_tvs = classTyVars cls++             do_one_meth :: (Id, Type) -> TcM ThetaOrigin+               -- (Id,Type) are the selector Id and the generic default method type+               -- NB: the latter is /not/ quantified over the class variables+               -- See Note [Gathering and simplifying constraints for DeriveAnyClass]+             do_one_meth (sel_id, gen_dm_ty)+               = do { let (sel_tvs, _cls_pred, meth_ty)+                                   = tcSplitMethodTy (varType sel_id)+                          meth_ty' = substTyWith sel_tvs inst_tys meth_ty+                          (meth_tvs, meth_theta, meth_tau)+                                   = tcSplitNestedSigmaTys meth_ty'++                          gen_dm_ty' = substTyWith cls_tvs inst_tys gen_dm_ty+                          (dm_tvs, dm_theta, dm_tau)+                                     = tcSplitNestedSigmaTys gen_dm_ty'+                          tau_eq     = mkPrimEqPred meth_tau dm_tau+                    ; return (mkThetaOrigin (mkDerivOrigin wildcard) TypeLevel+                                meth_tvs dm_tvs meth_theta (tau_eq:dm_theta)) }++       ; theta_origins <- lift $ mapM do_one_meth gen_dms+       ; return (theta_origins, tvs, inst_tys) }++{- Note [Inferring the instance context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are two sorts of 'deriving', as represented by the two constructors+for DerivContext:++  * InferContext mb_wildcard: This can either be:+    - The deriving clause for a data type.+        (e.g, data T a = T1 a deriving( Eq ))+      In this case, mb_wildcard = Nothing.+    - A standalone declaration with an extra-constraints wildcard+        (e.g., deriving instance _ => Eq (Foo a))+      In this case, mb_wildcard = Just loc, where loc is the location+      of the extra-constraints wildcard.++    Here we must infer an instance context,+    and generate instance declaration+      instance Eq a => Eq (T a) where ...++  * SupplyContext theta: standalone deriving+      deriving instance Eq a => Eq (T a)+    Here we only need to fill in the bindings;+    the instance context (theta) is user-supplied++For the InferContext case, we must figure out the+instance context (inferConstraintsDataConArgs). Suppose we are inferring+the instance context for+    C t1 .. tn (T s1 .. sm)+There are two cases++  * (T s1 .. sm) :: *         (the normal case)+    Then we behave like Eq and guess (C t1 .. tn t)+    for each data constructor arg of type t.  More+    details below.++  * (T s1 .. sm) :: * -> *    (the functor-like case)+    Then we behave like Functor.++In both cases we produce a bunch of un-simplified constraints+and them simplify them in simplifyInstanceContexts; see+Note [Simplifying the instance context].++In the functor-like case, we may need to unify some kind variables with * in+order for the generated instance to be well-kinded. An example from+#10524:++  newtype Compose (f :: k2 -> *) (g :: k1 -> k2) (a :: k1)+    = Compose (f (g a)) deriving Functor++Earlier in the deriving pipeline, GHC unifies the kind of Compose f g+(k1 -> *) with the kind of Functor's argument (* -> *), so k1 := *. But this+alone isn't enough, since k2 wasn't unified with *:++  instance (Functor (f :: k2 -> *), Functor (g :: * -> k2)) =>+    Functor (Compose f g) where ...++The two Functor constraints are ill-kinded. To ensure this doesn't happen, we:++  1. Collect all of a datatype's subtypes which require functor-like+     constraints.+  2. For each subtype, create a substitution by unifying the subtype's kind+     with (* -> *).+  3. Compose all the substitutions into one, then apply that substitution to+     all of the in-scope type variables and the instance types.++Note [Getting base classes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Functor and Typeable are defined in package 'base', and that is not available+when compiling 'ghc-prim'.  So we must be careful that 'deriving' for stuff in+ghc-prim does not use Functor or Typeable implicitly via these lookups.++Note [Deriving and unboxed types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have some special hacks to support things like+   data T = MkT Int# deriving ( Show )++Specifically, we use TcGenDeriv.box to box the Int# into an Int+(which we know how to show), and append a '#'. Parentheses are not required+for unboxed values (`MkT -3#` is a valid expression).++Note [Superclasses of derived instance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, a derived instance decl needs the superclasses of the derived+class too.  So if we have+        data T a = ...deriving( Ord )+then the initial context for Ord (T a) should include Eq (T a).  Often this is+redundant; we'll also generate an Ord constraint for each constructor argument,+and that will probably generate enough constraints to make the Eq (T a) constraint+be satisfied too.  But not always; consider:++ data S a = S+ instance Eq (S a)+ instance Ord (S a)++ data T a = MkT (S a) deriving( Ord )+ instance Num a => Eq (T a)++The derived instance for (Ord (T a)) must have a (Num a) constraint!+Similarly consider:+        data T a = MkT deriving( Data )+Here there *is* no argument field, but we must nevertheless generate+a context for the Data instances:+        instance Typeable a => Data (T a) where ...+++************************************************************************+*                                                                      *+         Finding the fixed point of deriving equations+*                                                                      *+************************************************************************++Note [Simplifying the instance context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++        data T a b = C1 (Foo a) (Bar b)+                   | C2 Int (T b a)+                   | C3 (T a a)+                   deriving (Eq)++We want to come up with an instance declaration of the form++        instance (Ping a, Pong b, ...) => Eq (T a b) where+                x == y = ...++It is pretty easy, albeit tedious, to fill in the code "...".  The+trick is to figure out what the context for the instance decl is,+namely Ping, Pong and friends.++Let's call the context reqd for the T instance of class C at types+(a,b, ...)  C (T a b).  Thus:++        Eq (T a b) = (Ping a, Pong b, ...)++Now we can get a (recursive) equation from the data decl.  This part+is done by inferConstraintsDataConArgs.++        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1+                   u Eq (T b a) u Eq Int        -- From C2+                   u Eq (T a a)                 -- From C3+++Foo and Bar may have explicit instances for Eq, in which case we can+just substitute for them.  Alternatively, either or both may have+their Eq instances given by deriving clauses, in which case they+form part of the system of equations.++Now all we need do is simplify and solve the equations, iterating to+find the least fixpoint.  This is done by simplifyInstanceConstraints.+Notice that the order of the arguments can+switch around, as here in the recursive calls to T.++Let's suppose Eq (Foo a) = Eq a, and Eq (Bar b) = Ping b.++We start with:++        Eq (T a b) = {}         -- The empty set++Next iteration:+        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1+                   u Eq (T b a) u Eq Int        -- From C2+                   u Eq (T a a)                 -- From C3++        After simplification:+                   = Eq a u Ping b u {} u {} u {}+                   = Eq a u Ping b++Next iteration:++        Eq (T a b) = Eq (Foo a) u Eq (Bar b)    -- From C1+                   u Eq (T b a) u Eq Int        -- From C2+                   u Eq (T a a)                 -- From C3++        After simplification:+                   = Eq a u Ping b+                   u (Eq b u Ping a)+                   u (Eq a u Ping a)++                   = Eq a u Ping b u Eq b u Ping a++The next iteration gives the same result, so this is the fixpoint.  We+need to make a canonical form of the RHS to ensure convergence.  We do+this by simplifying the RHS to a form in which++        - the classes constrain only tyvars+        - the list is sorted by tyvar (major key) and then class (minor key)+        - no duplicates, of course++Note [Deterministic simplifyInstanceContexts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Canonicalisation uses nonDetCmpType which is nondeterministic. Sorting+with nonDetCmpType puts the returned lists in a nondeterministic order.+If we were to return them, we'd get class constraints in+nondeterministic order.++Consider:++  data ADT a b = Z a b deriving Eq++The generated code could be either:++  instance (Eq a, Eq b) => Eq (Z a b) where++Or:++  instance (Eq b, Eq a) => Eq (Z a b) where++To prevent the order from being nondeterministic we only+canonicalize when comparing and return them in the same order as+simplifyDeriv returned them.+See also Note [nonDetCmpType nondeterminism]+-}+++simplifyInstanceContexts :: [DerivSpec [ThetaOrigin]]+                         -> TcM [DerivSpec ThetaType]+-- Used only for deriving clauses or standalone deriving with an+-- extra-constraints wildcard (InferContext)+-- See Note [Simplifying the instance context]++simplifyInstanceContexts [] = return []++simplifyInstanceContexts infer_specs+  = do  { traceTc "simplifyInstanceContexts" $ vcat (map pprDerivSpec infer_specs)+        ; iterate_deriv 1 initial_solutions }+  where+    ------------------------------------------------------------------+        -- The initial solutions for the equations claim that each+        -- instance has an empty context; this solution is certainly+        -- in canonical form.+    initial_solutions :: [ThetaType]+    initial_solutions = [ [] | _ <- infer_specs ]++    ------------------------------------------------------------------+        -- iterate_deriv calculates the next batch of solutions,+        -- compares it with the current one; finishes if they are the+        -- same, otherwise recurses with the new solutions.+        -- It fails if any iteration fails+    iterate_deriv :: Int -> [ThetaType] -> TcM [DerivSpec ThetaType]+    iterate_deriv n current_solns+      | n > 20  -- Looks as if we are in an infinite loop+                -- This can happen if we have -XUndecidableInstances+                -- (See TcSimplify.tcSimplifyDeriv.)+      = pprPanic "solveDerivEqns: probable loop"+                 (vcat (map pprDerivSpec infer_specs) $$ ppr current_solns)+      | otherwise+      = do {      -- Extend the inst info from the explicit instance decls+                  -- with the current set of solutions, and simplify each RHS+             inst_specs <- zipWithM newDerivClsInst current_solns infer_specs+           ; new_solns <- checkNoErrs $+                          extendLocalInstEnv inst_specs $+                          mapM gen_soln infer_specs++           ; if (current_solns `eqSolution` new_solns) then+                return [ spec { ds_theta = soln }+                       | (spec, soln) <- zip infer_specs current_solns ]+             else+                iterate_deriv (n+1) new_solns }++    eqSolution a b = eqListBy (eqListBy eqType) (canSolution a) (canSolution b)+       -- Canonicalise for comparison+       -- See Note [Deterministic simplifyInstanceContexts]+    canSolution = map (sortBy nonDetCmpType)+    ------------------------------------------------------------------+    gen_soln :: DerivSpec [ThetaOrigin] -> TcM ThetaType+    gen_soln (DS { ds_loc = loc, ds_tvs = tyvars+                 , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs })+      = setSrcSpan loc  $+        addErrCtxt (derivInstCtxt the_pred) $+        do { theta <- simplifyDeriv the_pred tyvars deriv_rhs+                -- checkValidInstance tyvars theta clas inst_tys+                -- Not necessary; see Note [Exotic derived instance contexts]++           ; traceTc "TcDeriv" (ppr deriv_rhs $$ ppr theta)+                -- Claim: the result instance declaration is guaranteed valid+                -- Hence no need to call:+                --   checkValidInstance tyvars theta clas inst_tys+           ; return theta }+      where+        the_pred = mkClassPred clas inst_tys++derivInstCtxt :: PredType -> MsgDoc+derivInstCtxt pred+  = text "When deriving the instance for" <+> parens (ppr pred)++{-+***********************************************************************************+*                                                                                 *+*            Simplify derived constraints+*                                                                                 *+***********************************************************************************+-}++-- | Given @instance (wanted) => C inst_ty@, simplify 'wanted' as much+-- as possible. Fail if not possible.+simplifyDeriv :: PredType -- ^ @C inst_ty@, head of the instance we are+                          -- deriving.  Only used for SkolemInfo.+              -> [TyVar]  -- ^ The tyvars bound by @inst_ty@.+              -> [ThetaOrigin] -- ^ Given and wanted constraints+              -> TcM ThetaType -- ^ Needed constraints (after simplification),+                               -- i.e. @['PredType']@.+simplifyDeriv pred tvs thetas+  = do { (skol_subst, tvs_skols) <- tcInstSkolTyVars tvs -- Skolemize+                -- The constraint solving machinery+                -- expects *TcTyVars* not TyVars.+                -- We use *non-overlappable* (vanilla) skolems+                -- See Note [Overlap and deriving]++       ; let skol_set  = mkVarSet tvs_skols+             skol_info = DerivSkol pred+             doc = text "deriving" <+> parens (ppr pred)++             mk_given_ev :: PredType -> TcM EvVar+             mk_given_ev given =+               let given_pred = substTy skol_subst given+               in newEvVar given_pred++             emit_wanted_constraints :: [TyVar] -> [PredOrigin] -> TcM ()+             emit_wanted_constraints metas_to_be preds+               = do { -- We instantiate metas_to_be with fresh meta type+                      -- variables. Currently, these can only be type variables+                      -- quantified in generic default type signatures.+                      -- See Note [Gathering and simplifying constraints for+                      -- DeriveAnyClass]+                      (meta_subst, _meta_tvs) <- newMetaTyVars metas_to_be++                    -- Now make a constraint for each of the instantiated predicates+                    ; let wanted_subst = skol_subst `unionTCvSubst` meta_subst+                          mk_wanted_ct (PredOrigin wanted orig t_or_k)+                            = do { ev <- newWanted orig (Just t_or_k) $+                                         substTyUnchecked wanted_subst wanted+                                 ; return (mkNonCanonical ev) }+                    ; cts <- mapM mk_wanted_ct preds++                    -- And emit them into the monad+                    ; emitSimples (listToCts cts) }++             -- Create the implications we need to solve. For stock and newtype+             -- deriving, these implication constraints will be simple class+             -- constraints like (C a, Ord b).+             -- But with DeriveAnyClass, we make an implication constraint.+             -- See Note [Gathering and simplifying constraints for DeriveAnyClass]+             mk_wanteds :: ThetaOrigin -> TcM WantedConstraints+             mk_wanteds (ThetaOrigin { to_anyclass_skols  = ac_skols+                                     , to_anyclass_metas  = ac_metas+                                     , to_anyclass_givens = ac_givens+                                     , to_wanted_origins  = preds })+               = do { ac_given_evs <- mapM mk_given_ev ac_givens+                    ; (_, wanteds)+                        <- captureConstraints $+                           checkConstraints skol_info ac_skols ac_given_evs $+                              -- The checkConstraints bumps the TcLevel, and+                              -- wraps the wanted constraints in an implication,+                              -- when (but only when) necessary+                           emit_wanted_constraints ac_metas preds+                    ; pure wanteds }++       -- See [STEP DAC BUILD]+       -- Generate the implication constraints, one for each method, to solve+       -- with the skolemized variables.  Start "one level down" because+       -- we are going to wrap the result in an implication with tvs_skols,+       -- in step [DAC RESIDUAL]+       ; (tc_lvl, wanteds) <- pushTcLevelM $+                              mapM mk_wanteds thetas++       ; traceTc "simplifyDeriv inputs" $+         vcat [ pprTyVars tvs $$ ppr thetas $$ ppr wanteds, doc ]++       -- See [STEP DAC SOLVE]+       -- Simplify the constraints, starting at the same level at which+       -- they are generated (c.f. the call to runTcSWithEvBinds in+       -- simplifyInfer)+       ; solved_wanteds <- setTcLevel tc_lvl   $+                           runTcSDeriveds      $+                           solveWantedsAndDrop $+                           unionsWC wanteds++       -- It's not yet zonked!  Obviously zonk it before peering at it+       ; solved_wanteds <- zonkWC solved_wanteds++       -- See [STEP DAC HOIST]+       -- Split the resulting constraints into bad and good constraints,+       -- building an @unsolved :: WantedConstraints@ representing all+       -- the constraints we can't just shunt to the predicates.+       -- See Note [Exotic derived instance contexts]+       ; let residual_simple = approximateWC True solved_wanteds+             (bad, good) = partitionBagWith get_good residual_simple++             get_good :: Ct -> Either Ct PredType+             get_good ct | validDerivPred skol_set p+                         , isWantedCt ct+                         = Right p+                          -- TODO: This is wrong+                          -- NB re 'isWantedCt': residual_wanted may contain+                          -- unsolved CtDerived and we stick them into the+                          -- bad set so that reportUnsolved may decide what+                          -- to do with them+                         | otherwise+                         = Left ct+                           where p = ctPred ct++       ; traceTc "simplifyDeriv outputs" $+         vcat [ ppr tvs_skols, ppr residual_simple, ppr good, ppr bad ]++       -- Return the good unsolved constraints (unskolemizing on the way out.)+       ; let min_theta = mkMinimalBySCs id (bagToList good)+             -- An important property of mkMinimalBySCs (used above) is that in+             -- addition to removing constraints that are made redundant by+             -- superclass relationships, it also removes _duplicate_+             -- constraints.+             -- See Note [Gathering and simplifying constraints for+             --           DeriveAnyClass]+             subst_skol = zipTvSubst tvs_skols $ mkTyVarTys tvs+                          -- The reverse substitution (sigh)++       -- See [STEP DAC RESIDUAL]+       ; min_theta_vars <- mapM newEvVar min_theta+       ; (leftover_implic, _)+           <- buildImplicationFor tc_lvl skol_info tvs_skols+                                  min_theta_vars solved_wanteds+       -- This call to simplifyTop is purely for error reporting+       -- See Note [Error reporting for deriving clauses]+       -- See also Note [Exotic derived instance contexts], which are caught+       -- in this line of code.+       ; simplifyTopImplic leftover_implic++       ; return (substTheta subst_skol min_theta) }++{-+Note [Overlap and deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider some overlapping instances:+  instance Show a => Show [a] where ..+  instance Show [Char] where ...++Now a data type with deriving:+  data T a = MkT [a] deriving( Show )++We want to get the derived instance+  instance Show [a] => Show (T a) where...+and NOT+  instance Show a => Show (T a) where...+so that the (Show (T Char)) instance does the Right Thing++It's very like the situation when we're inferring the type+of a function+   f x = show [x]+and we want to infer+   f :: Show [a] => a -> String++BOTTOM LINE: use vanilla, non-overlappable skolems when inferring+             the context for the derived instance.+             Hence tcInstSkolTyVars not tcInstSuperSkolTyVars++Note [Gathering and simplifying constraints for DeriveAnyClass]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+DeriveAnyClass works quite differently from stock and newtype deriving in+the way it gathers and simplifies constraints to be used in a derived+instance's context. Stock and newtype deriving gather constraints by looking+at the data constructors of the data type for which we are deriving an+instance. But DeriveAnyClass doesn't need to know about a data type's+definition at all!++To see why, consider this example of DeriveAnyClass:++  class Foo a where+    bar :: forall b. Ix b => a -> b -> String+    default bar :: (Show a, Ix c) => a -> c -> String+    bar x y = show x ++ show (range (y,y))++    baz :: Eq a => a -> a -> Bool+    default baz :: (Ord a, Show a) => a -> a -> Bool+    baz x y = compare x y == EQ++Because 'bar' and 'baz' have default signatures, this generates a top-level+definition for these generic default methods++  $gdm_bar :: forall a. Foo a+           => forall c. (Show a, Ix c)+           => a -> c -> String+  $gdm_bar x y = show x ++ show (range (y,y))++(and similarly for baz).  Now consider a 'deriving' clause+  data Maybe s = ... deriving Foo++This derives an instance of the form:+  instance (CX) => Foo (Maybe s) where+    bar = $gdm_bar+    baz = $gdm_baz++Now it is GHC's job to fill in a suitable instance context (CX).  If+GHC were typechecking the binding+   bar = $gdm bar+it would+   * skolemise the expected type of bar+   * instantiate the type of $gdm_bar with meta-type variables+   * build an implication constraint++[STEP DAC BUILD]+So that's what we do.  We build the constraint (call it C1)++   forall[2] b. Ix b => (Show (Maybe s), Ix cc,+                        Maybe s -> b -> String+                            ~ Maybe s -> cc -> String)++Here:+* The level of this forall constraint is forall[2], because we are later+  going to wrap it in a forall[1] in [STEP DAC RESIDUAL]++* The 'b' comes from the quantified type variable in the expected type+  of bar (i.e., 'to_anyclass_skols' in 'ThetaOrigin'). The 'cc' is a unification+  variable that comes from instantiating the quantified type variable 'c' in+  $gdm_bar's type (i.e., 'to_anyclass_metas' in 'ThetaOrigin).++* The (Ix b) constraint comes from the context of bar's type+  (i.e., 'to_wanted_givens' in 'ThetaOrigin'). The (Show (Maybe s)) and (Ix cc)+  constraints come from the context of $gdm_bar's type+  (i.e., 'to_anyclass_givens' in 'ThetaOrigin').++* The equality constraint (Maybe s -> b -> String) ~ (Maybe s -> cc -> String)+  comes from marrying up the instantiated type of $gdm_bar with the specified+  type of bar. Notice that the type variables from the instance, 's' in this+  case, are global to this constraint.++Note that it is vital that we instantiate the `c` in $gdm_bar's type with a new+unification variable for each iteration of simplifyDeriv. If we re-use the same+unification variable across multiple iterations, then bad things can happen,+such as #14933.++Similarly for 'baz', givng the constraint C2++   forall[2]. Eq (Maybe s) => (Ord a, Show a,+                              Maybe s -> Maybe s -> Bool+                                ~ Maybe s -> Maybe s -> Bool)++In this case baz has no local quantification, so the implication+constraint has no local skolems and there are no unification+variables.++[STEP DAC SOLVE]+We can combine these two implication constraints into a single+constraint (C1, C2), and simplify, unifying cc:=b, to get:++   forall[2] b. Ix b => Show a+   /\+   forall[2]. Eq (Maybe s) => (Ord a, Show a)++[STEP DAC HOIST]+Let's call that (C1', C2').  Now we need to hoist the unsolved+constraints out of the implications to become our candidate for+(CX). That is done by approximateWC, which will return:++  (Show a, Ord a, Show a)++Now we can use mkMinimalBySCs to remove superclasses and duplicates, giving++  (Show a, Ord a)++And that's what GHC uses for CX.++[STEP DAC RESIDUAL]+In this case we have solved all the leftover constraints, but what if+we don't?  Simple!  We just form the final residual constraint++   forall[1] s. CX => (C1',C2')++and simplify that. In simple cases it'll succeed easily, because CX+literally contains the constraints in C1', C2', but if there is anything+more complicated it will be reported in a civilised way.++Note [Error reporting for deriving clauses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A suprisingly tricky aspect of deriving to get right is reporting sensible+error messages. In particular, if simplifyDeriv reaches a constraint that it+cannot solve, which might include:++1. Insoluble constraints+2. "Exotic" constraints (See Note [Exotic derived instance contexts])++Then we report an error immediately in simplifyDeriv.++Another possible choice is to punt and let another part of the typechecker+(e.g., simplifyInstanceContexts) catch the errors. But this tends to lead+to worse error messages, so we do it directly in simplifyDeriv.++simplifyDeriv checks for errors in a clever way. If the deriving machinery+infers the context (Foo a)--that is, if this instance is to be generated:++  instance Foo a => ...++Then we form an implication of the form:++  forall a. Foo a => <residual_wanted_constraints>++And pass it to the simplifier. If the context (Foo a) is enough to discharge+all the constraints in <residual_wanted_constraints>, then everything is+hunky-dory. But if <residual_wanted_constraints> contains, say, an insoluble+constraint, then (Foo a) won't be able to solve it, causing GHC to error.++Note [Exotic derived instance contexts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a 'derived' instance declaration, we *infer* the context.  It's a+bit unclear what rules we should apply for this; the Haskell report is+silent.  Obviously, constraints like (Eq a) are fine, but what about+        data T f a = MkT (f a) deriving( Eq )+where we'd get an Eq (f a) constraint.  That's probably fine too.++One could go further: consider+        data T a b c = MkT (Foo a b c) deriving( Eq )+        instance (C Int a, Eq b, Eq c) => Eq (Foo a b c)++Notice that this instance (just) satisfies the Paterson termination+conditions.  Then we *could* derive an instance decl like this:++        instance (C Int a, Eq b, Eq c) => Eq (T a b c)+even though there is no instance for (C Int a), because there just+*might* be an instance for, say, (C Int Bool) at a site where we+need the equality instance for T's.++However, this seems pretty exotic, and it's quite tricky to allow+this, and yet give sensible error messages in the (much more common)+case where we really want that instance decl for C.++So for now we simply require that the derived instance context+should have only type-variable constraints.++Here is another example:+        data Fix f = In (f (Fix f)) deriving( Eq )+Here, if we are prepared to allow -XUndecidableInstances we+could derive the instance+        instance Eq (f (Fix f)) => Eq (Fix f)+but this is so delicate that I don't think it should happen inside+'deriving'. If you want this, write it yourself!++NB: if you want to lift this condition, make sure you still meet the+termination conditions!  If not, the deriving mechanism generates+larger and larger constraints.  Example:+  data Succ a = S a+  data Seq a = Cons a (Seq (Succ a)) | Nil deriving Show++Note the lack of a Show instance for Succ.  First we'll generate+  instance (Show (Succ a), Show a) => Show (Seq a)+and then+  instance (Show (Succ (Succ a)), Show (Succ a), Show a) => Show (Seq a)+and so on.  Instead we want to complain of no instance for (Show (Succ a)).++The bottom line+~~~~~~~~~~~~~~~+Allow constraints which consist only of type variables, with no repeats.+-}
+ compiler/typecheck/TcDerivUtils.hs view
@@ -0,0 +1,976 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Error-checking and other utilities for @deriving@ clauses or declarations.+-}++{-# LANGUAGE TypeFamilies #-}++module TcDerivUtils (+        DerivM, DerivEnv(..),+        DerivSpec(..), pprDerivSpec,+        DerivSpecMechanism(..), derivSpecMechanismToStrategy, isDerivSpecStock,+        isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia,+        DerivContext(..), OriginativeDerivStatus(..),+        isStandaloneDeriv, isStandaloneWildcardDeriv, mkDerivOrigin,+        PredOrigin(..), ThetaOrigin(..), mkPredOrigin,+        mkThetaOrigin, mkThetaOriginFromPreds, substPredOrigin,+        checkOriginativeSideConditions, hasStockDeriving,+        canDeriveAnyClass,+        std_class_via_coercible, non_coercible_class,+        newDerivClsInst, extendLocalInstEnv+    ) where++import GhcPrelude++import Bag+import BasicTypes+import Class+import DataCon+import DynFlags+import ErrUtils+import HscTypes (lookupFixity, mi_fix)+import HsSyn+import Inst+import InstEnv+import LoadIface (loadInterfaceForName)+import Module (getModule)+import Name+import Outputable+import PrelNames+import SrcLoc+import TcGenDeriv+import TcGenFunctor+import TcGenGenerics+import TcRnMonad+import TcType+import THNames (liftClassKey)+import TyCon+import Type+import Util+import VarSet++import Control.Monad.Trans.Reader+import Data.Maybe+import qualified GHC.LanguageExtensions as LangExt+import ListSetOps (assocMaybe)++-- | To avoid having to manually plumb everything in 'DerivEnv' throughout+-- various functions in @TcDeriv@ and @TcDerivInfer@, we use 'DerivM', which+-- is a simple reader around 'TcRn'.+type DerivM = ReaderT DerivEnv TcRn++-- | Is GHC processing a standalone deriving declaration?+isStandaloneDeriv :: DerivM Bool+isStandaloneDeriv = asks (go . denv_ctxt)+  where+    go :: DerivContext -> Bool+    go (InferContext wildcard) = isJust wildcard+    go (SupplyContext {})      = True++-- | Is GHC processing a standalone deriving declaration with an+-- extra-constraints wildcard as the context?+-- (e.g., @deriving instance _ => Eq (Foo a)@)+isStandaloneWildcardDeriv :: DerivM Bool+isStandaloneWildcardDeriv = asks (go . denv_ctxt)+  where+    go :: DerivContext -> Bool+    go (InferContext wildcard) = isJust wildcard+    go (SupplyContext {})      = False++-- | @'mkDerivOrigin' wc@ returns 'StandAloneDerivOrigin' if @wc@ is 'True',+-- and 'DerivClauseOrigin' if @wc@ is 'False'. Useful for error-reporting.+mkDerivOrigin :: Bool -> CtOrigin+mkDerivOrigin standalone_wildcard+  | standalone_wildcard = StandAloneDerivOrigin+  | otherwise           = DerivClauseOrigin++-- | Contains all of the information known about a derived instance when+-- determining what its @EarlyDerivSpec@ should be.+data DerivEnv = DerivEnv+  { denv_overlap_mode :: Maybe OverlapMode+    -- ^ Is this an overlapping instance?+  , denv_tvs          :: [TyVar]+    -- ^ Universally quantified type variables in the instance+  , denv_cls          :: Class+    -- ^ Class for which we need to derive an instance+  , denv_cls_tys      :: [Type]+    -- ^ Other arguments to the class except the last+  , denv_tc           :: TyCon+    -- ^ Type constructor for which the instance is requested+    --   (last arguments to the type class)+  , denv_tc_args      :: [Type]+    -- ^ Arguments to the type constructor+  , denv_rep_tc       :: TyCon+    -- ^ The representation tycon for 'denv_tc'+    --   (for data family instances)+  , denv_rep_tc_args  :: [Type]+    -- ^ The representation types for 'denv_tc_args'+    --   (for data family instances)+  , denv_ctxt         :: DerivContext+    -- ^ @'SupplyContext' theta@ for standalone deriving (where @theta@ is the+    --   context of the instance).+    --   'InferContext' for @deriving@ clauses, or for standalone deriving that+    --   uses a wildcard constraint.+    --   See @Note [Inferring the instance context]@.+  , denv_strat        :: Maybe (DerivStrategy GhcTc)+    -- ^ 'Just' if user requests a particular deriving strategy.+    --   Otherwise, 'Nothing'.+  }++instance Outputable DerivEnv where+  ppr (DerivEnv { denv_overlap_mode = overlap_mode+                , denv_tvs          = tvs+                , denv_cls          = cls+                , denv_cls_tys      = cls_tys+                , denv_tc           = tc+                , denv_tc_args      = tc_args+                , denv_rep_tc       = rep_tc+                , denv_rep_tc_args  = rep_tc_args+                , denv_ctxt         = ctxt+                , denv_strat        = mb_strat })+    = hang (text "DerivEnv")+         2 (vcat [ text "denv_overlap_mode" <+> ppr overlap_mode+                 , text "denv_tvs"          <+> ppr tvs+                 , text "denv_cls"          <+> ppr cls+                 , text "denv_cls_tys"      <+> ppr cls_tys+                 , text "denv_tc"           <+> ppr tc+                 , text "denv_tc_args"      <+> ppr tc_args+                 , text "denv_rep_tc"       <+> ppr rep_tc+                 , text "denv_rep_tc_args"  <+> ppr rep_tc_args+                 , text "denv_ctxt"         <+> ppr ctxt+                 , text "denv_strat"        <+> ppr mb_strat ])++data DerivSpec theta = DS { ds_loc                 :: SrcSpan+                          , ds_name                :: Name         -- DFun name+                          , ds_tvs                 :: [TyVar]+                          , ds_theta               :: theta+                          , ds_cls                 :: Class+                          , ds_tys                 :: [Type]+                          , ds_tc                  :: TyCon+                          , ds_overlap             :: Maybe OverlapMode+                          , ds_standalone_wildcard :: Maybe SrcSpan+                              -- See Note [Inferring the instance context]+                              -- in TcDerivInfer+                          , ds_mechanism           :: DerivSpecMechanism }+        -- This spec implies a dfun declaration of the form+        --       df :: forall tvs. theta => C tys+        -- The Name is the name for the DFun we'll build+        -- The tyvars bind all the variables in the theta+        -- For type families, the tycon in+        --       in ds_tys is the *family* tycon+        --       in ds_tc is the *representation* type+        -- For non-family tycons, both are the same++        -- the theta is either the given and final theta, in standalone deriving,+        -- or the not-yet-simplified list of constraints together with their origin++        -- ds_mechanism specifies the means by which GHC derives the instance.+        -- See Note [Deriving strategies] in TcDeriv++{-+Example:++     newtype instance T [a] = MkT (Tree a) deriving( C s )+==>+     axiom T [a] = :RTList a+     axiom :RTList a = Tree a++     DS { ds_tvs = [a,s], ds_cls = C, ds_tys = [s, T [a]]+        , ds_tc = :RTList, ds_mechanism = DerivSpecNewtype (Tree a) }+-}++pprDerivSpec :: Outputable theta => DerivSpec theta -> SDoc+pprDerivSpec (DS { ds_loc = l, ds_name = n, ds_tvs = tvs, ds_cls = c,+                   ds_tys = tys, ds_theta = rhs,+                   ds_standalone_wildcard = wildcard, ds_mechanism = mech })+  = hang (text "DerivSpec")+       2 (vcat [ text "ds_loc                  =" <+> ppr l+               , text "ds_name                 =" <+> ppr n+               , text "ds_tvs                  =" <+> ppr tvs+               , text "ds_cls                  =" <+> ppr c+               , text "ds_tys                  =" <+> ppr tys+               , text "ds_theta                =" <+> ppr rhs+               , text "ds_standalone_wildcard  =" <+> ppr wildcard+               , text "ds_mechanism            =" <+> ppr mech ])++instance Outputable theta => Outputable (DerivSpec theta) where+  ppr = pprDerivSpec++-- What action to take in order to derive a class instance.+-- See Note [Deriving strategies] in TcDeriv+data DerivSpecMechanism+  = DerivSpecStock   -- "Standard" classes+      (SrcSpan -> TyCon+               -> [Type]+               -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))+      -- This function returns three things:+      --+      -- 1. @LHsBinds GhcPs@: The derived instance's function bindings+      --    (e.g., @compare (T x) (T y) = compare x y@)+      -- 2. @BagDerivStuff@: Auxiliary bindings needed to support the derived+      --    instance. As examples, derived 'Generic' instances require+      --    associated type family instances, and derived 'Eq' and 'Ord'+      --    instances require top-level @con2tag@ functions.+      --    See Note [Auxiliary binders] in TcGenDeriv.+      -- 3. @[Name]@: A list of Names for which @-Wunused-binds@ should be+      --    suppressed. This is used to suppress unused warnings for record+      --    selectors when deriving 'Read', 'Show', or 'Generic'.+      --    See Note [Deriving and unused record selectors].++  | DerivSpecNewtype -- -XGeneralizedNewtypeDeriving+      Type -- The newtype rep type++  | DerivSpecAnyClass -- -XDeriveAnyClass++  | DerivSpecVia -- -XDerivingVia+      Type -- The @via@ type++-- | Convert a 'DerivSpecMechanism' to its corresponding 'DerivStrategy'.+derivSpecMechanismToStrategy :: DerivSpecMechanism -> DerivStrategy GhcTc+derivSpecMechanismToStrategy DerivSpecStock{}   = StockStrategy+derivSpecMechanismToStrategy DerivSpecNewtype{} = NewtypeStrategy+derivSpecMechanismToStrategy DerivSpecAnyClass  = AnyclassStrategy+derivSpecMechanismToStrategy (DerivSpecVia t)   = ViaStrategy t++isDerivSpecStock, isDerivSpecNewtype, isDerivSpecAnyClass, isDerivSpecVia+  :: DerivSpecMechanism -> Bool+isDerivSpecStock (DerivSpecStock{}) = True+isDerivSpecStock _                  = False++isDerivSpecNewtype (DerivSpecNewtype{}) = True+isDerivSpecNewtype _                    = False++isDerivSpecAnyClass DerivSpecAnyClass = True+isDerivSpecAnyClass _                 = False++isDerivSpecVia (DerivSpecVia{}) = True+isDerivSpecVia _                = False++instance Outputable DerivSpecMechanism where+  ppr (DerivSpecStock{})   = text "DerivSpecStock"+  ppr (DerivSpecNewtype t) = text "DerivSpecNewtype" <> colon <+> ppr t+  ppr DerivSpecAnyClass    = text "DerivSpecAnyClass"+  ppr (DerivSpecVia t)     = text "DerivSpecVia" <> colon <+> ppr t++-- | Whether GHC is processing a @deriving@ clause or a standalone deriving+-- declaration.+data DerivContext+  = InferContext (Maybe SrcSpan) -- ^ @'InferContext mb_wildcard@ is either:+                                 --+                                 -- * A @deriving@ clause (in which case+                                 --   @mb_wildcard@ is 'Nothing').+                                 --+                                 -- * A standalone deriving declaration with+                                 --   an extra-constraints wildcard as the+                                 --   context (in which case @mb_wildcard@ is+                                 --   @'Just' loc@, where @loc@ is the location+                                 --   of the wildcard.+                                 --+                                 -- GHC should infer the context.++  | SupplyContext ThetaType      -- ^ @'SupplyContext' theta@ is a standalone+                                 -- deriving declaration, where @theta@ is the+                                 -- context supplied by the user.++instance Outputable DerivContext where+  ppr (InferContext standalone) = text "InferContext"  <+> ppr standalone+  ppr (SupplyContext theta)     = text "SupplyContext" <+> ppr theta++-- | Records whether a particular class can be derived by way of an+-- /originative/ deriving strategy (i.e., @stock@ or @anyclass@).+--+-- See @Note [Deriving strategies]@ in "TcDeriv".+data OriginativeDerivStatus+  = CanDeriveStock            -- Stock class, can derive+      (SrcSpan -> TyCon -> [Type]+               -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))+  | StockClassError SDoc      -- Stock class, but can't do it+  | CanDeriveAnyClass         -- See Note [Deriving any class]+  | NonDerivableClass SDoc    -- Cannot derive with either stock or anyclass++-- A stock class is one either defined in the Haskell report or for which GHC+-- otherwise knows how to generate code for (possibly requiring the use of a+-- language extension), such as Eq, Ord, Ix, Data, Generic, etc.)++-- | A 'PredType' annotated with the origin of the constraint 'CtOrigin',+-- and whether or the constraint deals in types or kinds.+data PredOrigin = PredOrigin PredType CtOrigin TypeOrKind++-- | A list of wanted 'PredOrigin' constraints ('to_wanted_origins') to+-- simplify when inferring a derived instance's context. These are used in all+-- deriving strategies, but in the particular case of @DeriveAnyClass@, we+-- need extra information. In particular, we need:+--+-- * 'to_anyclass_skols', the list of type variables bound by a class method's+--   regular type signature, which should be rigid.+--+-- * 'to_anyclass_metas', the list of type variables bound by a class method's+--   default type signature. These can be unified as necessary.+--+-- * 'to_anyclass_givens', the list of constraints from a class method's+--   regular type signature, which can be used to help solve constraints+--   in the 'to_wanted_origins'.+--+-- (Note that 'to_wanted_origins' will likely contain type variables from the+-- derived type class or data type, neither of which will appear in+-- 'to_anyclass_skols' or 'to_anyclass_metas'.)+--+-- For all other deriving strategies, it is always the case that+-- 'to_anyclass_skols', 'to_anyclass_metas', and 'to_anyclass_givens' are+-- empty.+--+-- Here is an example to illustrate this:+--+-- @+-- class Foo a where+--   bar :: forall b. Ix b => a -> b -> String+--   default bar :: forall y. (Show a, Ix y) => a -> y -> String+--   bar x y = show x ++ show (range (y, y))+--+--   baz :: Eq a => a -> a -> Bool+--   default baz :: Ord a => a -> a -> Bool+--   baz x y = compare x y == EQ+--+-- data Quux q = Quux deriving anyclass Foo+-- @+--+-- Then it would generate two 'ThetaOrigin's, one for each method:+--+-- @+-- [ ThetaOrigin { to_anyclass_skols  = [b]+--               , to_anyclass_metas  = [y]+--               , to_anyclass_givens = [Ix b]+--               , to_wanted_origins  = [ Show (Quux q), Ix y+--                                      , (Quux q -> b -> String) ~+--                                        (Quux q -> y -> String)+--                                      ] }+-- , ThetaOrigin { to_anyclass_skols  = []+--               , to_anyclass_metas  = []+--               , to_anyclass_givens = [Eq (Quux q)]+--               , to_wanted_origins  = [ Ord (Quux q)+--                                      , (Quux q -> Quux q -> Bool) ~+--                                        (Quux q -> Quux q -> Bool)+--                                      ] }+-- ]+-- @+--+-- (Note that the type variable @q@ is bound by the data type @Quux@, and thus+-- it appears in neither 'to_anyclass_skols' nor 'to_anyclass_metas'.)+--+-- See @Note [Gathering and simplifying constraints for DeriveAnyClass]@+-- in "TcDerivInfer" for an explanation of how 'to_wanted_origins' are+-- determined in @DeriveAnyClass@, as well as how 'to_anyclass_skols',+-- 'to_anyclass_metas', and 'to_anyclass_givens' are used.+data ThetaOrigin+  = ThetaOrigin { to_anyclass_skols  :: [TyVar]+                , to_anyclass_metas  :: [TyVar]+                , to_anyclass_givens :: ThetaType+                , to_wanted_origins  :: [PredOrigin] }++instance Outputable PredOrigin where+  ppr (PredOrigin ty _ _) = ppr ty -- The origin is not so interesting when debugging++instance Outputable ThetaOrigin where+  ppr (ThetaOrigin { to_anyclass_skols  = ac_skols+                   , to_anyclass_metas  = ac_metas+                   , to_anyclass_givens = ac_givens+                   , to_wanted_origins  = wanted_origins })+    = hang (text "ThetaOrigin")+         2 (vcat [ text "to_anyclass_skols  =" <+> ppr ac_skols+                 , text "to_anyclass_metas  =" <+> ppr ac_metas+                 , text "to_anyclass_givens =" <+> ppr ac_givens+                 , text "to_wanted_origins  =" <+> ppr wanted_origins ])++mkPredOrigin :: CtOrigin -> TypeOrKind -> PredType -> PredOrigin+mkPredOrigin origin t_or_k pred = PredOrigin pred origin t_or_k++mkThetaOrigin :: CtOrigin -> TypeOrKind+              -> [TyVar] -> [TyVar] -> ThetaType -> ThetaType+              -> ThetaOrigin+mkThetaOrigin origin t_or_k skols metas givens+  = ThetaOrigin skols metas givens . map (mkPredOrigin origin t_or_k)++-- A common case where the ThetaOrigin only contains wanted constraints, with+-- no givens or locally scoped type variables.+mkThetaOriginFromPreds :: [PredOrigin] -> ThetaOrigin+mkThetaOriginFromPreds = ThetaOrigin [] [] []++substPredOrigin :: HasCallStack => TCvSubst -> PredOrigin -> PredOrigin+substPredOrigin subst (PredOrigin pred origin t_or_k)+  = PredOrigin (substTy subst pred) origin t_or_k++{-+************************************************************************+*                                                                      *+                Class deriving diagnostics+*                                                                      *+************************************************************************++Only certain blessed classes can be used in a deriving clause (without the+assistance of GeneralizedNewtypeDeriving or DeriveAnyClass). These classes+are listed below in the definition of hasStockDeriving. The stockSideConditions+function determines the criteria that needs to be met in order for a particular+stock class to be able to be derived successfully.++A class might be able to be used in a deriving clause if -XDeriveAnyClass+is willing to support it. The canDeriveAnyClass function checks if this is the+case.+-}++hasStockDeriving+  :: Class -> Maybe (SrcSpan+                     -> TyCon+                     -> [Type]+                     -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))+hasStockDeriving clas+  = assocMaybe gen_list (getUnique clas)+  where+    gen_list+      :: [(Unique, SrcSpan+                   -> TyCon+                   -> [Type]+                   -> TcM (LHsBinds GhcPs, BagDerivStuff, [Name]))]+    gen_list = [ (eqClassKey,          simpleM gen_Eq_binds)+               , (ordClassKey,         simpleM gen_Ord_binds)+               , (enumClassKey,        simpleM gen_Enum_binds)+               , (boundedClassKey,     simple gen_Bounded_binds)+               , (ixClassKey,          simpleM gen_Ix_binds)+               , (showClassKey,        read_or_show gen_Show_binds)+               , (readClassKey,        read_or_show gen_Read_binds)+               , (dataClassKey,        simpleM gen_Data_binds)+               , (functorClassKey,     simple gen_Functor_binds)+               , (foldableClassKey,    simple gen_Foldable_binds)+               , (traversableClassKey, simple gen_Traversable_binds)+               , (liftClassKey,        simple gen_Lift_binds)+               , (genClassKey,         generic (gen_Generic_binds Gen0))+               , (gen1ClassKey,        generic (gen_Generic_binds Gen1)) ]++    simple gen_fn loc tc _+      = let (binds, deriv_stuff) = gen_fn loc tc+        in return (binds, deriv_stuff, [])++    simpleM gen_fn loc tc _+      = do { (binds, deriv_stuff) <- gen_fn loc tc+           ; return (binds, deriv_stuff, []) }++    read_or_show gen_fn loc tc _+      = do { fix_env <- getDataConFixityFun tc+           ; let (binds, deriv_stuff) = gen_fn fix_env loc tc+                 field_names          = all_field_names tc+           ; return (binds, deriv_stuff, field_names) }++    generic gen_fn _ tc inst_tys+      = do { (binds, faminst) <- gen_fn tc inst_tys+           ; let field_names = all_field_names tc+           ; return (binds, unitBag (DerivFamInst faminst), field_names) }++    -- See Note [Deriving and unused record selectors]+    all_field_names = map flSelector . concatMap dataConFieldLabels+                                     . tyConDataCons++{-+Note [Deriving and unused record selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (see #13919):++  module Main (main) where++  data Foo = MkFoo {bar :: String} deriving Show++  main :: IO ()+  main = print (Foo "hello")++Strictly speaking, the record selector `bar` is unused in this module, since+neither `main` nor the derived `Show` instance for `Foo` mention `bar`.+However, the behavior of `main` is affected by the presence of `bar`, since+it will print different output depending on whether `MkFoo` is defined using+record selectors or not. Therefore, we do not to issue a+"Defined but not used: ‘bar’" warning for this module, since removing `bar`+changes the program's behavior. This is the reason behind the [Name] part of+the return type of `hasStockDeriving`—it tracks all of the record selector+`Name`s for which -Wunused-binds should be suppressed.++Currently, the only three stock derived classes that require this are Read,+Show, and Generic, as their derived code all depend on the record selectors+of the derived data type's constructors.++See also Note [Newtype deriving and unused constructors] in TcDeriv for+another example of a similar trick.+-}++getDataConFixityFun :: TyCon -> TcM (Name -> Fixity)+-- If the TyCon is locally defined, we want the local fixity env;+-- but if it is imported (which happens for standalone deriving)+-- we need to get the fixity env from the interface file+-- c.f. RnEnv.lookupFixity, and #9830+getDataConFixityFun tc+  = do { this_mod <- getModule+       ; if nameIsLocalOrFrom this_mod name+         then do { fix_env <- getFixityEnv+                 ; return (lookupFixity fix_env) }+         else do { iface <- loadInterfaceForName doc name+                            -- Should already be loaded!+                 ; return (mi_fix iface . nameOccName) } }+  where+    name = tyConName tc+    doc = text "Data con fixities for" <+> ppr name++------------------------------------------------------------------+-- Check side conditions that dis-allow derivability for the originative+-- deriving strategies (stock and anyclass).+-- See Note [Deriving strategies] in TcDeriv for an explanation of what+-- "originative" means.+--+-- This is *apart* from the coerce-based strategies, newtype and via.+--+-- Here we get the representation tycon in case of family instances as it has+-- the data constructors - but we need to be careful to fall back to the+-- family tycon (with indexes) in error messages.++checkOriginativeSideConditions+  :: DynFlags -> DerivContext -> Class -> [TcType]+  -> TyCon -> TyCon+  -> OriginativeDerivStatus+checkOriginativeSideConditions dflags deriv_ctxt cls cls_tys tc rep_tc+    -- First, check if stock deriving is possible...+  | Just cond <- stockSideConditions deriv_ctxt cls+  = case (cond dflags tc rep_tc) of+        NotValid err -> StockClassError err  -- Class-specific error+        IsValid  | null (filterOutInvisibleTypes (classTyCon cls) cls_tys)+                   -- All stock derivable classes are unary in the sense that+                   -- there should be not types in cls_tys (i.e., no type args+                   -- other than last). Note that cls_types can contain+                   -- invisible types as well (e.g., for Generic1, which is+                   -- poly-kinded), so make sure those are not counted.+                 , Just gen_fn <- hasStockDeriving cls+                   -> CanDeriveStock gen_fn+                 | otherwise -> StockClassError (classArgsErr cls cls_tys)+                   -- e.g. deriving( Eq s )++    -- ...if not, try falling back on DeriveAnyClass.+  | NotValid err <- canDeriveAnyClass dflags+  = NonDerivableClass err  -- Neither anyclass nor stock work++  | otherwise+  = CanDeriveAnyClass   -- DeriveAnyClass should work++classArgsErr :: Class -> [Type] -> SDoc+classArgsErr cls cls_tys = quotes (ppr (mkClassPred cls cls_tys)) <+> text "is not a class"++-- Side conditions (whether the datatype must have at least one constructor,+-- required language extensions, etc.) for using GHC's stock deriving+-- mechanism on certain classes (as opposed to classes that require+-- GeneralizedNewtypeDeriving or DeriveAnyClass). Returns Nothing for a+-- class for which stock deriving isn't possible.+stockSideConditions :: DerivContext -> Class -> Maybe Condition+stockSideConditions deriv_ctxt cls+  | cls_key == eqClassKey          = Just (cond_std `andCond` cond_args cls)+  | cls_key == ordClassKey         = Just (cond_std `andCond` cond_args cls)+  | cls_key == showClassKey        = Just (cond_std `andCond` cond_args cls)+  | cls_key == readClassKey        = Just (cond_std `andCond` cond_args cls)+  | cls_key == enumClassKey        = Just (cond_std `andCond` cond_isEnumeration)+  | cls_key == ixClassKey          = Just (cond_std `andCond` cond_enumOrProduct cls)+  | cls_key == boundedClassKey     = Just (cond_std `andCond` cond_enumOrProduct cls)+  | cls_key == dataClassKey        = Just (checkFlag LangExt.DeriveDataTypeable `andCond`+                                           cond_vanilla `andCond`+                                           cond_args cls)+  | cls_key == functorClassKey     = Just (checkFlag LangExt.DeriveFunctor `andCond`+                                           cond_vanilla `andCond`+                                           cond_functorOK True False)+  | cls_key == foldableClassKey    = Just (checkFlag LangExt.DeriveFoldable `andCond`+                                           cond_vanilla `andCond`+                                           cond_functorOK False True)+                                           -- Functor/Fold/Trav works ok+                                           -- for rank-n types+  | cls_key == traversableClassKey = Just (checkFlag LangExt.DeriveTraversable `andCond`+                                           cond_vanilla `andCond`+                                           cond_functorOK False False)+  | cls_key == genClassKey         = Just (checkFlag LangExt.DeriveGeneric `andCond`+                                           cond_vanilla `andCond`+                                           cond_RepresentableOk)+  | cls_key == gen1ClassKey        = Just (checkFlag LangExt.DeriveGeneric `andCond`+                                           cond_vanilla `andCond`+                                           cond_Representable1Ok)+  | cls_key == liftClassKey        = Just (checkFlag LangExt.DeriveLift `andCond`+                                           cond_vanilla `andCond`+                                           cond_args cls)+  | otherwise                      = Nothing+  where+    cls_key = getUnique cls+    cond_std     = cond_stdOK deriv_ctxt False+      -- Vanilla data constructors, at least one, and monotype arguments+    cond_vanilla = cond_stdOK deriv_ctxt True+      -- Vanilla data constructors but allow no data cons or polytype arguments++canDeriveAnyClass :: DynFlags -> Validity+-- IsValid: we can (try to) derive it via an empty instance declaration+-- NotValid s:  we can't, reason s+canDeriveAnyClass dflags+  | not (xopt LangExt.DeriveAnyClass dflags)+  = NotValid (text "Try enabling DeriveAnyClass")+  | otherwise+  = IsValid   -- OK!++type Condition+   = DynFlags++  -> TyCon    -- ^ The data type's 'TyCon'. For data families, this is the+              -- family 'TyCon'.++  -> TyCon    -- ^ For data families, this is the representation 'TyCon'.+              -- Otherwise, this is the same as the other 'TyCon' argument.++  -> Validity -- ^ 'IsValid' if deriving an instance for this 'TyCon' is+              -- possible. Otherwise, it's @'NotValid' err@, where @err@+              -- explains what went wrong.++orCond :: Condition -> Condition -> Condition+orCond c1 c2 dflags tc rep_tc+  = case (c1 dflags tc rep_tc, c2 dflags tc rep_tc) of+     (IsValid,    _)          -> IsValid    -- c1 succeeds+     (_,          IsValid)    -> IsValid    -- c21 succeeds+     (NotValid x, NotValid y) -> NotValid (x $$ text "  or" $$ y)+                                            -- Both fail++andCond :: Condition -> Condition -> Condition+andCond c1 c2 dflags tc rep_tc+  = c1 dflags tc rep_tc `andValid` c2 dflags tc rep_tc++-- | Some common validity checks shared among stock derivable classes. One+-- check that absolutely must hold is that if an instance @C (T a)@ is being+-- derived, then @T@ must be a tycon for a data type or a newtype. The+-- remaining checks are only performed if using a @deriving@ clause (i.e.,+-- they're ignored if using @StandaloneDeriving@):+--+-- 1. The data type must have at least one constructor (this check is ignored+--    if using @EmptyDataDeriving@).+--+-- 2. The data type cannot have any GADT constructors.+--+-- 3. The data type cannot have any constructors with existentially quantified+--    type variables.+--+-- 4. The data type cannot have a context (e.g., @data Foo a = Eq a => MkFoo@).+--+-- 5. The data type cannot have fields with higher-rank types.+cond_stdOK+  :: DerivContext -- ^ 'SupplyContext' if this is standalone deriving with a+                  -- user-supplied context, 'InferContext' if not.+                  -- If it is the former, we relax some of the validity checks+                  -- we would otherwise perform (i.e., "just go for it").++  -> Bool         -- ^ 'True' <=> allow higher rank arguments and empty data+                  -- types (with no data constructors) even in the absence of+                  -- the -XEmptyDataDeriving extension.++  -> Condition+cond_stdOK deriv_ctxt permissive dflags tc rep_tc+  = valid_ADT `andValid` valid_misc+  where+    valid_ADT, valid_misc :: Validity+    valid_ADT+      | isAlgTyCon tc || isDataFamilyTyCon tc+      = IsValid+      | otherwise+        -- Complain about functions, primitive types, and other tycons that+        -- stock deriving can't handle.+      = NotValid $ text "The last argument of the instance must be a"+               <+> text "data or newtype application"++    valid_misc+      = case deriv_ctxt of+         SupplyContext _ -> IsValid+                -- Don't check these conservative conditions for+                -- standalone deriving; just generate the code+                -- and let the typechecker handle the result+         InferContext wildcard+           | null data_cons -- 1.+           , not permissive+           -> checkFlag LangExt.EmptyDataDeriving dflags tc rep_tc `orValid`+              NotValid (no_cons_why rep_tc $$ empty_data_suggestion)+           | not (null con_whys)+           -> NotValid (vcat con_whys $$ possible_fix_suggestion wildcard)+           | otherwise+           -> IsValid++    empty_data_suggestion =+      text "Use EmptyDataDeriving to enable deriving for empty data types"+    possible_fix_suggestion wildcard+      = case wildcard of+          Just _ ->+            text "Possible fix: fill in the wildcard constraint yourself"+          Nothing ->+            text "Possible fix: use a standalone deriving declaration instead"+    data_cons  = tyConDataCons rep_tc+    con_whys   = getInvalids (map check_con data_cons)++    check_con :: DataCon -> Validity+    check_con con+      | not (null eq_spec) -- 2.+      = bad "is a GADT"+      | not (null ex_tvs) -- 3.+      = bad "has existential type variables in its type"+      | not (null theta) -- 4.+      = bad "has constraints in its type"+      | not (permissive || all isTauTy (dataConOrigArgTys con)) -- 5.+      = bad "has a higher-rank type"+      | otherwise+      = IsValid+      where+        (_, ex_tvs, eq_spec, theta, _, _) = dataConFullSig con+        bad msg = NotValid (badCon con (text msg))++no_cons_why :: TyCon -> SDoc+no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+>+                     text "must have at least one data constructor"++cond_RepresentableOk :: Condition+cond_RepresentableOk _ _ rep_tc = canDoGenerics rep_tc++cond_Representable1Ok :: Condition+cond_Representable1Ok _ _ rep_tc = canDoGenerics1 rep_tc++cond_enumOrProduct :: Class -> Condition+cond_enumOrProduct cls = cond_isEnumeration `orCond`+                         (cond_isProduct `andCond` cond_args cls)++cond_args :: Class -> Condition+-- ^ For some classes (eg 'Eq', 'Ord') we allow unlifted arg types+-- by generating specialised code.  For others (eg 'Data') we don't.+-- For even others (eg 'Lift'), unlifted types aren't even a special+-- consideration!+cond_args cls _ _ rep_tc+  = case bad_args of+      []     -> IsValid+      (ty:_) -> NotValid (hang (text "Don't know how to derive" <+> quotes (ppr cls))+                             2 (text "for type" <+> quotes (ppr ty)))+  where+    bad_args = [ arg_ty | con <- tyConDataCons rep_tc+                        , arg_ty <- dataConOrigArgTys con+                        , isLiftedType_maybe arg_ty /= Just True+                        , not (ok_ty arg_ty) ]++    cls_key = classKey cls+    ok_ty arg_ty+     | cls_key == eqClassKey   = check_in arg_ty ordOpTbl+     | cls_key == ordClassKey  = check_in arg_ty ordOpTbl+     | cls_key == showClassKey = check_in arg_ty boxConTbl+     | cls_key == liftClassKey = True     -- Lift is levity-polymorphic+     | otherwise               = False    -- Read, Ix etc++    check_in :: Type -> [(Type,a)] -> Bool+    check_in arg_ty tbl = any (eqType arg_ty . fst) tbl+++cond_isEnumeration :: Condition+cond_isEnumeration _ _ rep_tc+  | isEnumerationTyCon rep_tc = IsValid+  | otherwise                 = NotValid why+  where+    why = sep [ quotes (pprSourceTyCon rep_tc) <+>+                  text "must be an enumeration type"+              , text "(an enumeration consists of one or more nullary, non-GADT constructors)" ]+                  -- See Note [Enumeration types] in TyCon++cond_isProduct :: Condition+cond_isProduct _ _ rep_tc+  | isProductTyCon rep_tc = IsValid+  | otherwise             = NotValid why+  where+    why = quotes (pprSourceTyCon rep_tc) <+>+          text "must have precisely one constructor"++cond_functorOK :: Bool -> Bool -> Condition+-- OK for Functor/Foldable/Traversable class+-- Currently: (a) at least one argument+--            (b) don't use argument contravariantly+--            (c) don't use argument in the wrong place, e.g. data T a = T (X a a)+--            (d) optionally: don't use function types+--            (e) no "stupid context" on data type+cond_functorOK allowFunctions allowExQuantifiedLastTyVar _ _ rep_tc+  | null tc_tvs+  = NotValid (text "Data type" <+> quotes (ppr rep_tc)+              <+> text "must have some type parameters")++  | not (null bad_stupid_theta)+  = NotValid (text "Data type" <+> quotes (ppr rep_tc)+              <+> text "must not have a class context:" <+> pprTheta bad_stupid_theta)++  | otherwise+  = allValid (map check_con data_cons)+  where+    tc_tvs            = tyConTyVars rep_tc+    last_tv           = last tc_tvs+    bad_stupid_theta  = filter is_bad (tyConStupidTheta rep_tc)+    is_bad pred       = last_tv `elemVarSet` exactTyCoVarsOfType pred+      -- See Note [Check that the type variable is truly universal]++    data_cons = tyConDataCons rep_tc+    check_con con = allValid (check_universal con : foldDataConArgs (ft_check con) con)++    check_universal :: DataCon -> Validity+    check_universal con+      | allowExQuantifiedLastTyVar+      = IsValid -- See Note [DeriveFoldable with ExistentialQuantification]+                -- in TcGenFunctor+      | Just tv <- getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con)))+      , tv `elem` dataConUnivTyVars con+      , not (tv `elemVarSet` exactTyCoVarsOfTypes (dataConTheta con))+      = IsValid   -- See Note [Check that the type variable is truly universal]+      | otherwise+      = NotValid (badCon con existential)++    ft_check :: DataCon -> FFoldType Validity+    ft_check con = FT { ft_triv = IsValid, ft_var = IsValid+                      , ft_co_var = NotValid (badCon con covariant)+                      , ft_fun = \x y -> if allowFunctions then x `andValid` y+                                                           else NotValid (badCon con functions)+                      , ft_tup = \_ xs  -> allValid xs+                      , ft_ty_app = \_ x   -> x+                      , ft_bad_app = NotValid (badCon con wrong_arg)+                      , ft_forall = \_ x   -> x }++    existential = text "must be truly polymorphic in the last argument of the data type"+    covariant   = text "must not use the type variable in a function argument"+    functions   = text "must not contain function types"+    wrong_arg   = text "must use the type variable only as the last argument of a data type"++checkFlag :: LangExt.Extension -> Condition+checkFlag flag dflags _ _+  | xopt flag dflags = IsValid+  | otherwise        = NotValid why+  where+    why = text "You need " <> text flag_str+          <+> text "to derive an instance for this class"+    flag_str = case [ flagSpecName f | f <- xFlags , flagSpecFlag f == flag ] of+                 [s]   -> s+                 other -> pprPanic "checkFlag" (ppr other)++std_class_via_coercible :: Class -> Bool+-- These standard classes can be derived for a newtype+-- using the coercible trick *even if no -XGeneralizedNewtypeDeriving+-- because giving so gives the same results as generating the boilerplate+std_class_via_coercible clas+  = classKey clas `elem` [eqClassKey, ordClassKey, ixClassKey, boundedClassKey]+        -- Not Read/Show because they respect the type+        -- Not Enum, because newtypes are never in Enum+++non_coercible_class :: Class -> Bool+-- *Never* derive Read, Show, Typeable, Data, Generic, Generic1, Lift+-- by Coercible, even with -XGeneralizedNewtypeDeriving+-- Also, avoid Traversable, as the Coercible-derived instance and the "normal"-derived+-- instance behave differently if there's a non-lawful Applicative out there.+-- Besides, with roles, Coercible-deriving Traversable is ill-roled.+non_coercible_class cls+  = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey+                         , genClassKey, gen1ClassKey, typeableClassKey+                         , traversableClassKey, liftClassKey ])++badCon :: DataCon -> SDoc -> SDoc+badCon con msg = text "Constructor" <+> quotes (ppr con) <+> msg++------------------------------------------------------------------++newDerivClsInst :: ThetaType -> DerivSpec theta -> TcM ClsInst+newDerivClsInst theta (DS { ds_name = dfun_name, ds_overlap = overlap_mode+                          , ds_tvs = tvs, ds_cls = clas, ds_tys = tys })+  = newClsInst overlap_mode dfun_name tvs theta clas tys++extendLocalInstEnv :: [ClsInst] -> TcM a -> TcM a+-- Add new locally-defined instances; don't bother to check+-- for functional dependency errors -- that'll happen in TcInstDcls+extendLocalInstEnv dfuns thing_inside+ = do { env <- getGblEnv+      ; let  inst_env' = extendInstEnvList (tcg_inst_env env) dfuns+             env'      = env { tcg_inst_env = inst_env' }+      ; setGblEnv env' thing_inside }++{-+Note [Deriving any class]+~~~~~~~~~~~~~~~~~~~~~~~~~+Classic uses of a deriving clause, or a standalone-deriving declaration, are+for:+  * a stock class like Eq or Show, for which GHC knows how to generate+    the instance code+  * a newtype, via the mechanism enabled by GeneralizedNewtypeDeriving++The DeriveAnyClass extension adds a third way to derive instances, based on+empty instance declarations.++The canonical use case is in combination with GHC.Generics and default method+signatures. These allow us to have instance declarations being empty, but still+useful, e.g.++  data T a = ...blah..blah... deriving( Generic )+  instance C a => C (T a)  -- No 'where' clause++where C is some "random" user-defined class.++This boilerplate code can be replaced by the more compact++  data T a = ...blah..blah... deriving( Generic, C )++if DeriveAnyClass is enabled.++This is not restricted to Generics; any class can be derived, simply giving+rise to an empty instance.++Unfortunately, it is not clear how to determine the context (when using a+deriving clause; in standalone deriving, the user provides the context).+GHC uses the same heuristic for figuring out the class context that it uses for+Eq in the case of *-kinded classes, and for Functor in the case of+* -> *-kinded classes. That may not be optimal or even wrong. But in such+cases, standalone deriving can still be used.++Note [Check that the type variable is truly universal]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For Functor and Traversable instances, we must check that the *last argument*+of the type constructor is used truly universally quantified.  Example++   data T a b where+     T1 :: a -> b -> T a b      -- Fine! Vanilla H-98+     T2 :: b -> c -> T a b      -- Fine! Existential c, but we can still map over 'b'+     T3 :: b -> T Int b         -- Fine! Constraint 'a', but 'b' is still polymorphic+     T4 :: Ord b => b -> T a b  -- No!  'b' is constrained+     T5 :: b -> T b b           -- No!  'b' is constrained+     T6 :: T a (b,b)            -- No!  'b' is constrained++Notice that only the first of these constructors is vanilla H-98. We only+need to take care about the last argument (b in this case).  See #8678.+Eg. for T1-T3 we can write++     fmap f (T1 a b) = T1 a (f b)+     fmap f (T2 b c) = T2 (f b) c+     fmap f (T3 x)   = T3 (f x)++We need not perform these checks for Foldable instances, however, since+functions in Foldable can only consume existentially quantified type variables,+rather than produce them (as is the case in Functor and Traversable functions.)+As a result, T can have a derived Foldable instance:++    foldr f z (T1 a b) = f b z+    foldr f z (T2 b c) = f b z+    foldr f z (T3 x)   = f x z+    foldr f z (T4 x)   = f x z+    foldr f z (T5 x)   = f x z+    foldr _ z T6       = z++See Note [DeriveFoldable with ExistentialQuantification] in TcGenFunctor.++For Functor and Traversable, we must take care not to let type synonyms+unfairly reject a type for not being truly universally quantified. An+example of this is:++    type C (a :: Constraint) b = a+    data T a b = C (Show a) b => MkT b++Here, the existential context (C (Show a) b) does technically mention the last+type variable b. But this is OK, because expanding the type synonym C would+give us the context (Show a), which doesn't mention b. Therefore, we must make+sure to expand type synonyms before performing this check. Not doing so led to+#13813.+-}
+ compiler/typecheck/TcEnv.hs view
@@ -0,0 +1,1149 @@+-- (c) The University of Glasgow 2006+{-# LANGUAGE CPP, FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an+                                       -- orphan+{-# LANGUAGE UndecidableInstances #-} -- Note [Pass sensitive types]+                                      -- in module PlaceHolder+{-# LANGUAGE TypeFamilies #-}++module TcEnv(+        TyThing(..), TcTyThing(..), TcId,++        -- Instance environment, and InstInfo type+        InstInfo(..), iDFunId, pprInstInfoDetails,+        simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,+        InstBindings(..),++        -- Global environment+        tcExtendGlobalEnv, tcExtendTyConEnv,+        tcExtendGlobalEnvImplicit, setGlobalTypeEnv,+        tcExtendGlobalValEnv,+        tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalOnly,+        tcLookupTyCon, tcLookupClass,+        tcLookupDataCon, tcLookupPatSyn, tcLookupConLike,+        tcLookupLocatedGlobalId, tcLookupLocatedTyCon,+        tcLookupLocatedClass, tcLookupAxiom,+        lookupGlobal, ioLookupDataCon,++        -- Local environment+        tcExtendKindEnv, tcExtendKindEnvList,+        tcExtendTyVarEnv, tcExtendNameTyVarEnv,+        tcExtendLetEnv, tcExtendSigIds, tcExtendRecIds,+        tcExtendIdEnv, tcExtendIdEnv1, tcExtendIdEnv2,+        tcExtendBinderStack, tcExtendLocalTypeEnv,+        isTypeClosedLetBndr,++        tcLookup, tcLookupLocated, tcLookupLocalIds,+        tcLookupId, tcLookupIdMaybe, tcLookupTyVar,+        tcLookupLcl_maybe,+        getInLocalScope,+        wrongThingErr, pprBinders,++        tcAddDataFamConPlaceholders, tcAddPatSynPlaceholders,+        getTypeSigNames,+        tcExtendRecEnv,         -- For knot-tying++        -- Tidying+        tcInitTidyEnv, tcInitOpenTidyEnv,++        -- Instances+        tcLookupInstance, tcGetInstEnvs,++        -- Rules+        tcExtendRules,++        -- Defaults+        tcGetDefaultTys,++        -- Global type variables+        tcGetGlobalTyCoVars,++        -- Template Haskell stuff+        checkWellStaged, tcMetaTy, thLevel,+        topIdLvl, isBrackStage,++        -- New Ids+        newDFunName, newDFunName', newFamInstTyConName,+        newFamInstAxiomName,+        mkStableIdFromString, mkStableIdFromName,+        mkWrapperName+  ) where++#include "HsVersions.h"++import GhcPrelude++import HsSyn+import IfaceEnv+import TcRnMonad+import TcMType+import TcType+import LoadIface+import PrelNames+import TysWiredIn+import Id+import Var+import VarSet+import RdrName+import InstEnv+import DataCon ( DataCon )+import PatSyn  ( PatSyn )+import ConLike+import TyCon+import Type+import CoAxiom+import Class+import Name+import NameSet+import NameEnv+import VarEnv+import HscTypes+import DynFlags+import SrcLoc+import BasicTypes hiding( SuccessFlag(..) )+import Module+import Outputable+import Encoding+import FastString+import ListSetOps+import ErrUtils+import Util+import Maybes( MaybeErr(..), orElse )+import qualified GHC.LanguageExtensions as LangExt++import Data.IORef+import Data.List+import Control.Monad++{- *********************************************************************+*                                                                      *+            An IO interface to looking up globals+*                                                                      *+********************************************************************* -}++lookupGlobal :: HscEnv -> Name -> IO TyThing+-- A variant of lookupGlobal_maybe for the clients which are not+-- interested in recovering from lookup failure and accept panic.+lookupGlobal hsc_env name+  = do  {+          mb_thing <- lookupGlobal_maybe hsc_env name+        ; case mb_thing of+            Succeeded thing -> return thing+            Failed msg      -> pprPanic "lookupGlobal" msg+        }++lookupGlobal_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)+-- This may look up an Id that one one has previously looked up.+-- If so, we are going to read its interface file, and add its bindings+-- to the ExternalPackageTable.+lookupGlobal_maybe hsc_env name+  = do  {    -- Try local envt+          let mod = icInteractiveModule (hsc_IC hsc_env)+              dflags = hsc_dflags hsc_env+              tcg_semantic_mod = canonicalizeModuleIfHome dflags mod++        ; if nameIsLocalOrFrom tcg_semantic_mod name+              then (return+                (Failed (text "Can't find local name: " <+> ppr name)))+                  -- Internal names can happen in GHCi+              else+           -- Try home package table and external package table+          lookupImported_maybe hsc_env name+        }++lookupImported_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)+-- Returns (Failed err) if we can't find the interface file for the thing+lookupImported_maybe hsc_env name+  = do  { mb_thing <- lookupTypeHscEnv hsc_env name+        ; case mb_thing of+            Just thing -> return (Succeeded thing)+            Nothing    -> importDecl_maybe hsc_env name+            }++importDecl_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc TyThing)+importDecl_maybe hsc_env name+  | Just thing <- wiredInNameTyThing_maybe name+  = do  { when (needWiredInHomeIface thing)+               (initIfaceLoad hsc_env (loadWiredInHomeIface name))+                -- See Note [Loading instances for wired-in things]+        ; return (Succeeded thing) }+  | otherwise+  = initIfaceLoad hsc_env (importDecl name)++ioLookupDataCon :: HscEnv -> Name -> IO DataCon+ioLookupDataCon hsc_env name = do+  mb_thing <- ioLookupDataCon_maybe hsc_env name+  case mb_thing of+    Succeeded thing -> return thing+    Failed msg      -> pprPanic "lookupDataConIO" msg++ioLookupDataCon_maybe :: HscEnv -> Name -> IO (MaybeErr MsgDoc DataCon)+ioLookupDataCon_maybe hsc_env name = do+    thing <- lookupGlobal hsc_env name+    return $ case thing of+        AConLike (RealDataCon con) -> Succeeded con+        _                          -> Failed $+          pprTcTyThingCategory (AGlobal thing) <+> quotes (ppr name) <+>+                text "used as a data constructor"++{-+************************************************************************+*                                                                      *+*                      tcLookupGlobal                                  *+*                                                                      *+************************************************************************++Using the Located versions (eg. tcLookupLocatedGlobal) is preferred,+unless you know that the SrcSpan in the monad is already set to the+span of the Name.+-}+++tcLookupLocatedGlobal :: Located Name -> TcM TyThing+-- c.f. IfaceEnvEnv.tcIfaceGlobal+tcLookupLocatedGlobal name+  = addLocM tcLookupGlobal name++tcLookupGlobal :: Name -> TcM TyThing+-- The Name is almost always an ExternalName, but not always+-- In GHCi, we may make command-line bindings (ghci> let x = True)+-- that bind a GlobalId, but with an InternalName+tcLookupGlobal name+  = do  {    -- Try local envt+          env <- getGblEnv+        ; case lookupNameEnv (tcg_type_env env) name of {+                Just thing -> return thing ;+                Nothing    ->++                -- Should it have been in the local envt?+                -- (NB: use semantic mod here, since names never use+                -- identity module, see Note [Identity versus semantic module].)+          if nameIsLocalOrFrom (tcg_semantic_mod env) name+          then notFound name  -- Internal names can happen in GHCi+          else++           -- Try home package table and external package table+    do  { mb_thing <- tcLookupImported_maybe name+        ; case mb_thing of+            Succeeded thing -> return thing+            Failed msg      -> failWithTc msg+        }}}++-- Look up only in this module's global env't. Don't look in imports, etc.+-- Panic if it's not there.+tcLookupGlobalOnly :: Name -> TcM TyThing+tcLookupGlobalOnly name+  = do { env <- getGblEnv+       ; return $ case lookupNameEnv (tcg_type_env env) name of+                    Just thing -> thing+                    Nothing    -> pprPanic "tcLookupGlobalOnly" (ppr name) }++tcLookupDataCon :: Name -> TcM DataCon+tcLookupDataCon name = do+    thing <- tcLookupGlobal name+    case thing of+        AConLike (RealDataCon con) -> return con+        _                          -> wrongThingErr "data constructor" (AGlobal thing) name++tcLookupPatSyn :: Name -> TcM PatSyn+tcLookupPatSyn name = do+    thing <- tcLookupGlobal name+    case thing of+        AConLike (PatSynCon ps) -> return ps+        _                       -> wrongThingErr "pattern synonym" (AGlobal thing) name++tcLookupConLike :: Name -> TcM ConLike+tcLookupConLike name = do+    thing <- tcLookupGlobal name+    case thing of+        AConLike cl -> return cl+        _           -> wrongThingErr "constructor-like thing" (AGlobal thing) name++tcLookupClass :: Name -> TcM Class+tcLookupClass name = do+    thing <- tcLookupGlobal name+    case thing of+        ATyCon tc | Just cls <- tyConClass_maybe tc -> return cls+        _                                           -> wrongThingErr "class" (AGlobal thing) name++tcLookupTyCon :: Name -> TcM TyCon+tcLookupTyCon name = do+    thing <- tcLookupGlobal name+    case thing of+        ATyCon tc -> return tc+        _         -> wrongThingErr "type constructor" (AGlobal thing) name++tcLookupAxiom :: Name -> TcM (CoAxiom Branched)+tcLookupAxiom name = do+    thing <- tcLookupGlobal name+    case thing of+        ACoAxiom ax -> return ax+        _           -> wrongThingErr "axiom" (AGlobal thing) name++tcLookupLocatedGlobalId :: Located Name -> TcM Id+tcLookupLocatedGlobalId = addLocM tcLookupId++tcLookupLocatedClass :: Located Name -> TcM Class+tcLookupLocatedClass = addLocM tcLookupClass++tcLookupLocatedTyCon :: Located Name -> TcM TyCon+tcLookupLocatedTyCon = addLocM tcLookupTyCon++-- Find the instance that exactly matches a type class application.  The class arguments must be precisely+-- the same as in the instance declaration (modulo renaming & casts).+--+tcLookupInstance :: Class -> [Type] -> TcM ClsInst+tcLookupInstance cls tys+  = do { instEnv <- tcGetInstEnvs+       ; case lookupUniqueInstEnv instEnv cls tys of+           Left err             -> failWithTc $ text "Couldn't match instance:" <+> err+           Right (inst, tys)+             | uniqueTyVars tys -> return inst+             | otherwise        -> failWithTc errNotExact+       }+  where+    errNotExact = text "Not an exact match (i.e., some variables get instantiated)"++    uniqueTyVars tys = all isTyVarTy tys+                    && hasNoDups (map (getTyVar "tcLookupInstance") tys)++tcGetInstEnvs :: TcM InstEnvs+-- Gets both the external-package inst-env+-- and the home-pkg inst env (includes module being compiled)+tcGetInstEnvs = do { eps <- getEps+                   ; env <- getGblEnv+                   ; return (InstEnvs { ie_global  = eps_inst_env eps+                                      , ie_local   = tcg_inst_env env+                                      , ie_visible = tcVisibleOrphanMods env }) }++instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where+    lookupThing = tcLookupGlobal++{-+************************************************************************+*                                                                      *+                Extending the global environment+*                                                                      *+************************************************************************+-}++setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv+-- Use this to update the global type env+-- It updates both  * the normal tcg_type_env field+--                  * the tcg_type_env_var field seen by interface files+setGlobalTypeEnv tcg_env new_type_env+  = do  {     -- Sync the type-envt variable seen by interface files+           writeMutVar (tcg_type_env_var tcg_env) new_type_env+         ; return (tcg_env { tcg_type_env = new_type_env }) }+++tcExtendGlobalEnvImplicit :: [TyThing] -> TcM r -> TcM r+  -- Just extend the global environment with some TyThings+  -- Do not extend tcg_tcs, tcg_patsyns etc+tcExtendGlobalEnvImplicit things thing_inside+   = do { tcg_env <- getGblEnv+        ; let ge'  = extendTypeEnvList (tcg_type_env tcg_env) things+        ; tcg_env' <- setGlobalTypeEnv tcg_env ge'+        ; setGblEnv tcg_env' thing_inside }++tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r+  -- Given a mixture of Ids, TyCons, Classes, all defined in the+  -- module being compiled, extend the global environment+tcExtendGlobalEnv things thing_inside+  = do { env <- getGblEnv+       ; let env' = env { tcg_tcs = [tc | ATyCon tc <- things] ++ tcg_tcs env,+                          tcg_patsyns = [ps | AConLike (PatSynCon ps) <- things] ++ tcg_patsyns env }+       ; setGblEnv env' $+            tcExtendGlobalEnvImplicit things thing_inside+       }++tcExtendTyConEnv :: [TyCon] -> TcM r -> TcM r+  -- Given a mixture of Ids, TyCons, Classes, all defined in the+  -- module being compiled, extend the global environment+tcExtendTyConEnv tycons thing_inside+  = do { env <- getGblEnv+       ; let env' = env { tcg_tcs = tycons ++ tcg_tcs env }+       ; setGblEnv env' $+         tcExtendGlobalEnvImplicit (map ATyCon tycons) thing_inside+       }++tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a+  -- Same deal as tcExtendGlobalEnv, but for Ids+tcExtendGlobalValEnv ids thing_inside+  = tcExtendGlobalEnvImplicit [AnId id | id <- ids] thing_inside++tcExtendRecEnv :: [(Name,TyThing)] -> TcM r -> TcM r+-- Extend the global environments for the type/class knot tying game+-- Just like tcExtendGlobalEnv, except the argument is a list of pairs+tcExtendRecEnv gbl_stuff thing_inside+ = do  { tcg_env <- getGblEnv+       ; let ge'      = extendNameEnvList (tcg_type_env tcg_env) gbl_stuff+             tcg_env' = tcg_env { tcg_type_env = ge' }+         -- No need for setGlobalTypeEnv (which side-effects the+         -- tcg_type_env_var); tcExtendRecEnv is used just+         -- when kind-check a group of type/class decls. It would+         -- in any case be wrong for an interface-file decl to end up+         -- with a TcTyCon in it!+       ; setGblEnv tcg_env' thing_inside }++{-+************************************************************************+*                                                                      *+\subsection{The local environment}+*                                                                      *+************************************************************************+-}++tcLookupLocated :: Located Name -> TcM TcTyThing+tcLookupLocated = addLocM tcLookup++tcLookupLcl_maybe :: Name -> TcM (Maybe TcTyThing)+tcLookupLcl_maybe name+  = do { local_env <- getLclTypeEnv+       ; return (lookupNameEnv local_env name) }++tcLookup :: Name -> TcM TcTyThing+tcLookup name = do+    local_env <- getLclTypeEnv+    case lookupNameEnv local_env name of+        Just thing -> return thing+        Nothing    -> AGlobal <$> tcLookupGlobal name++tcLookupTyVar :: Name -> TcM TcTyVar+tcLookupTyVar name+  = do { thing <- tcLookup name+       ; case thing of+           ATyVar _ tv -> return tv+           _           -> pprPanic "tcLookupTyVar" (ppr name) }++tcLookupId :: Name -> TcM Id+-- Used when we aren't interested in the binding level, nor refinement.+-- The "no refinement" part means that we return the un-refined Id regardless+--+-- The Id is never a DataCon. (Why does that matter? see TcExpr.tcId)+tcLookupId name = do+    thing <- tcLookupIdMaybe name+    case thing of+        Just id -> return id+        _       -> pprPanic "tcLookupId" (ppr name)++tcLookupIdMaybe :: Name -> TcM (Maybe Id)+tcLookupIdMaybe name+  = do { thing <- tcLookup name+       ; case thing of+           ATcId { tct_id = id} -> return $ Just id+           AGlobal (AnId id)    -> return $ Just id+           _                    -> return Nothing }++tcLookupLocalIds :: [Name] -> TcM [TcId]+-- We expect the variables to all be bound, and all at+-- the same level as the lookup.  Only used in one place...+tcLookupLocalIds ns+  = do { env <- getLclEnv+       ; return (map (lookup (tcl_env env)) ns) }+  where+    lookup lenv name+        = case lookupNameEnv lenv name of+                Just (ATcId { tct_id = id }) ->  id+                _ -> pprPanic "tcLookupLocalIds" (ppr name)++getInLocalScope :: TcM (Name -> Bool)+getInLocalScope = do { lcl_env <- getLclTypeEnv+                     ; return (`elemNameEnv` lcl_env) }++tcExtendKindEnvList :: [(Name, TcTyThing)] -> TcM r -> TcM r+-- Used only during kind checking, for TcThings that are+--      ATcTyCon or APromotionErr+-- No need to update the global tyvars, or tcl_th_bndrs, or tcl_rdr+tcExtendKindEnvList things thing_inside+  = do { traceTc "tcExtendKindEnvList" (ppr things)+       ; updLclEnv upd_env thing_inside }+  where+    upd_env env = env { tcl_env = extendNameEnvList (tcl_env env) things }++tcExtendKindEnv :: NameEnv TcTyThing -> TcM r -> TcM r+-- A variant of tcExtendKindEvnList+tcExtendKindEnv extra_env thing_inside+  = do { traceTc "tcExtendKindEnv" (ppr extra_env)+       ; updLclEnv upd_env thing_inside }+  where+    upd_env env = env { tcl_env = tcl_env env `plusNameEnv` extra_env }++-----------------------+-- Scoped type and kind variables+tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r+tcExtendTyVarEnv tvs thing_inside+  = tcExtendNameTyVarEnv (mkTyVarNamePairs tvs) thing_inside++tcExtendNameTyVarEnv :: [(Name,TcTyVar)] -> TcM r -> TcM r+tcExtendNameTyVarEnv binds thing_inside+  -- this should be used only for explicitly mentioned scoped variables.+  -- thus, no coercion variables+  = do { tc_extend_local_env NotTopLevel+                    [(name, ATyVar name tv) | (name, tv) <- binds] $+         tcExtendBinderStack tv_binds $+         thing_inside }+  where+    tv_binds :: [TcBinder]+    tv_binds = [TcTvBndr name tv | (name,tv) <- binds]++isTypeClosedLetBndr :: Id -> Bool+-- See Note [Bindings with closed types] in TcRnTypes+isTypeClosedLetBndr = noFreeVarsOfType . idType++tcExtendRecIds :: [(Name, TcId)] -> TcM a -> TcM a+-- Used for binding the recurive uses of Ids in a binding+-- both top-level value bindings and and nested let/where-bindings+-- Does not extend the TcBinderStack+tcExtendRecIds pairs thing_inside+  = tc_extend_local_env NotTopLevel+          [ (name, ATcId { tct_id   = let_id+                         , tct_info = NonClosedLet emptyNameSet False })+          | (name, let_id) <- pairs ] $+    thing_inside++tcExtendSigIds :: TopLevelFlag -> [TcId] -> TcM a -> TcM a+-- Used for binding the Ids that have a complete user type signature+-- Does not extend the TcBinderStack+tcExtendSigIds top_lvl sig_ids thing_inside+  = tc_extend_local_env top_lvl+          [ (idName id, ATcId { tct_id   = id+                              , tct_info = info })+          | id <- sig_ids+          , let closed = isTypeClosedLetBndr id+                info   = NonClosedLet emptyNameSet closed ]+     thing_inside+++tcExtendLetEnv :: TopLevelFlag -> TcSigFun -> IsGroupClosed+                  -> [TcId] -> TcM a -> TcM a+-- Used for both top-level value bindings and and nested let/where-bindings+-- Adds to the TcBinderStack too+tcExtendLetEnv top_lvl sig_fn (IsGroupClosed fvs fv_type_closed)+               ids thing_inside+  = tcExtendBinderStack [TcIdBndr id top_lvl | id <- ids] $+    tc_extend_local_env top_lvl+          [ (idName id, ATcId { tct_id   = id+                              , tct_info = mk_tct_info id })+          | id <- ids ]+    thing_inside+  where+    mk_tct_info id+      | type_closed && isEmptyNameSet rhs_fvs = ClosedLet+      | otherwise                             = NonClosedLet rhs_fvs type_closed+      where+        name        = idName id+        rhs_fvs     = lookupNameEnv fvs name `orElse` emptyNameSet+        type_closed = isTypeClosedLetBndr id &&+                      (fv_type_closed || hasCompleteSig sig_fn name)++tcExtendIdEnv :: [TcId] -> TcM a -> TcM a+-- For lambda-bound and case-bound Ids+-- Extends the TcBinderStack as well+tcExtendIdEnv ids thing_inside+  = tcExtendIdEnv2 [(idName id, id) | id <- ids] thing_inside++tcExtendIdEnv1 :: Name -> TcId -> TcM a -> TcM a+-- Exactly like tcExtendIdEnv2, but for a single (name,id) pair+tcExtendIdEnv1 name id thing_inside+  = tcExtendIdEnv2 [(name,id)] thing_inside++tcExtendIdEnv2 :: [(Name,TcId)] -> TcM a -> TcM a+tcExtendIdEnv2 names_w_ids thing_inside+  = tcExtendBinderStack [ TcIdBndr mono_id NotTopLevel+                        | (_,mono_id) <- names_w_ids ] $+    tc_extend_local_env NotTopLevel+            [ (name, ATcId { tct_id = id+                           , tct_info    = NotLetBound })+            | (name,id) <- names_w_ids]+    thing_inside++tc_extend_local_env :: TopLevelFlag -> [(Name, TcTyThing)] -> TcM a -> TcM a+tc_extend_local_env top_lvl extra_env thing_inside+-- Precondition: the argument list extra_env has TcTyThings+--               that ATcId or ATyVar, but nothing else+--+-- Invariant: the ATcIds are fully zonked. Reasons:+--      (a) The kinds of the forall'd type variables are defaulted+--          (see Kind.defaultKind, done in skolemiseQuantifiedTyVar)+--      (b) There are no via-Indirect occurrences of the bound variables+--          in the types, because instantiation does not look through such things+--      (c) The call to tyCoVarsOfTypes is ok without looking through refs++-- The second argument of type TyVarSet is a set of type variables+-- that are bound together with extra_env and should not be regarded+-- as free in the types of extra_env.+  = do  { traceTc "tc_extend_local_env" (ppr extra_env)+        ; env0 <- getLclEnv+        ; env1 <- tcExtendLocalTypeEnv env0 extra_env+        ; stage <- getStage+        ; let env2 = extend_local_env (top_lvl, thLevel stage) extra_env env1+        ; setLclEnv env2 thing_inside }+  where+    extend_local_env :: (TopLevelFlag, ThLevel) -> [(Name, TcTyThing)] -> TcLclEnv -> TcLclEnv+    -- Extend the local LocalRdrEnv and Template Haskell staging env simultaneously+    -- Reason for extending LocalRdrEnv: after running a TH splice we need+    -- to do renaming.+    extend_local_env thlvl pairs env@(TcLclEnv { tcl_rdr = rdr_env+                                               , tcl_th_bndrs = th_bndrs })+      = env { tcl_rdr      = extendLocalRdrEnvList rdr_env+                                [ n | (n, _) <- pairs, isInternalName n ]+                                -- The LocalRdrEnv contains only non-top-level names+                                -- (GlobalRdrEnv handles the top level)+            , tcl_th_bndrs = extendNameEnvList th_bndrs  -- We only track Ids in tcl_th_bndrs+                                 [(n, thlvl) | (n, ATcId {}) <- pairs] }++tcExtendLocalTypeEnv :: TcLclEnv -> [(Name, TcTyThing)] -> TcM TcLclEnv+tcExtendLocalTypeEnv lcl_env@(TcLclEnv { tcl_env = lcl_type_env }) tc_ty_things+  | isEmptyVarSet extra_tvs+  = return (lcl_env { tcl_env = extendNameEnvList lcl_type_env tc_ty_things })+  | otherwise+  = do { global_tvs <- readMutVar (tcl_tyvars lcl_env)+       ; new_g_var  <- newMutVar (global_tvs `unionVarSet` extra_tvs)+       ; return (lcl_env { tcl_tyvars = new_g_var+                         , tcl_env = extendNameEnvList lcl_type_env tc_ty_things } ) }+  where+    extra_tvs = foldr get_tvs emptyVarSet tc_ty_things++    get_tvs (_, ATcId { tct_id = id, tct_info = closed }) tvs+      = case closed of+          ClosedLet -> ASSERT2( is_closed_type, ppr id $$ ppr (idType id) )+                       tvs+          _other    -> tvs `unionVarSet` id_tvs+        where+           id_ty          = idType id+           id_tvs         = tyCoVarsOfType id_ty+           id_co_tvs      = closeOverKinds (coVarsOfType id_ty)+           is_closed_type = not (anyVarSet isTyVar (id_tvs `minusVarSet` id_co_tvs))+           -- We only care about being closed wrt /type/ variables+           -- E.g. a top-level binding might have a type like+           --          foo :: t |> co+           -- where co :: * ~ *+           -- or some other as-yet-unsolved kind coercion++    get_tvs (_, ATyVar _ tv) tvs          -- See Note [Global TyVars]+      = tvs `unionVarSet` tyCoVarsOfType (tyVarKind tv) `extendVarSet` tv++    get_tvs (_, ATcTyCon tc) tvs = tvs `unionVarSet` tyCoVarsOfType (tyConKind tc)++    get_tvs (_, AGlobal {})       tvs = tvs+    get_tvs (_, APromotionErr {}) tvs = tvs++        -- Note [Global TyVars]+        -- It's important to add the in-scope tyvars to the global tyvar set+        -- as well.  Consider+        --      f (_::r) = let g y = y::r in ...+        -- Here, g mustn't be generalised.  This is also important during+        -- class and instance decls, when we mustn't generalise the class tyvars+        -- when typechecking the methods.+        --+        -- Nor must we generalise g over any kind variables free in r's kind+++{- *********************************************************************+*                                                                      *+             The TcBinderStack+*                                                                      *+********************************************************************* -}++tcExtendBinderStack :: [TcBinder] -> TcM a -> TcM a+tcExtendBinderStack bndrs thing_inside+  = do { traceTc "tcExtendBinderStack" (ppr bndrs)+       ; updLclEnv (\env -> env { tcl_bndrs = bndrs ++ tcl_bndrs env })+                   thing_inside }++tcInitTidyEnv :: TcM TidyEnv+-- We initialise the "tidy-env", used for tidying types before printing,+-- by building a reverse map from the in-scope type variables to the+-- OccName that the programmer originally used for them+tcInitTidyEnv+  = do  { lcl_env <- getLclEnv+        ; go emptyTidyEnv (tcl_bndrs lcl_env) }+  where+    go (env, subst) []+      = return (env, subst)+    go (env, subst) (b : bs)+      | TcTvBndr name tyvar <- b+       = do { let (env', occ') = tidyOccName env (nameOccName name)+                  name'  = tidyNameOcc name occ'+                  tyvar1 = setTyVarName tyvar name'+            ; tyvar2 <- zonkTcTyVarToTyVar tyvar1+              -- Be sure to zonk here!  Tidying applies to zonked+              -- types, so if we don't zonk we may create an+              -- ill-kinded type (#14175)+            ; go (env', extendVarEnv subst tyvar tyvar2) bs }+      | otherwise+      = go (env, subst) bs++-- | Get a 'TidyEnv' that includes mappings for all vars free in the given+-- type. Useful when tidying open types.+tcInitOpenTidyEnv :: [TyCoVar] -> TcM TidyEnv+tcInitOpenTidyEnv tvs+  = do { env1 <- tcInitTidyEnv+       ; let env2 = tidyFreeTyCoVars env1 tvs+       ; return env2 }++++{- *********************************************************************+*                                                                      *+             Adding placeholders+*                                                                      *+********************************************************************* -}++tcAddDataFamConPlaceholders :: [LInstDecl GhcRn] -> TcM a -> TcM a+-- See Note [AFamDataCon: not promoting data family constructors]+tcAddDataFamConPlaceholders inst_decls thing_inside+  = tcExtendKindEnvList [ (con, APromotionErr FamDataConPE)+                        | lid <- inst_decls, con <- get_cons lid ]+      thing_inside+      -- Note [AFamDataCon: not promoting data family constructors]+  where+    -- get_cons extracts the *constructor* bindings of the declaration+    get_cons :: LInstDecl GhcRn -> [Name]+    get_cons (L _ (TyFamInstD {}))                     = []+    get_cons (L _ (DataFamInstD { dfid_inst = fid }))  = get_fi_cons fid+    get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))+      = concatMap (get_fi_cons . unLoc) fids+    get_cons (L _ (ClsInstD _ (XClsInstDecl _))) = panic "get_cons"+    get_cons (L _ (XInstDecl _)) = panic "get_cons"++    get_fi_cons :: DataFamInstDecl GhcRn -> [Name]+    get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =+                  FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons } }}})+      = map unLoc $ concatMap (getConNames . unLoc) cons+    get_fi_cons (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =+                  FamEqn { feqn_rhs = XHsDataDefn _ }}})+      = panic "get_fi_cons"+    get_fi_cons (DataFamInstDecl (HsIB _ (XFamEqn _))) = panic "get_fi_cons"+    get_fi_cons (DataFamInstDecl (XHsImplicitBndrs _)) = panic "get_fi_cons"+++tcAddPatSynPlaceholders :: [PatSynBind GhcRn GhcRn] -> TcM a -> TcM a+-- See Note [Don't promote pattern synonyms]+tcAddPatSynPlaceholders pat_syns thing_inside+  = tcExtendKindEnvList [ (name, APromotionErr PatSynPE)+                        | PSB{ psb_id = L _ name } <- pat_syns ]+       thing_inside++getTypeSigNames :: [LSig GhcRn] -> NameSet+-- Get the names that have a user type sig+getTypeSigNames sigs+  = foldr get_type_sig emptyNameSet sigs+  where+    get_type_sig :: LSig GhcRn -> NameSet -> NameSet+    get_type_sig sig ns =+      case sig of+        L _ (TypeSig _ names _) -> extendNameSetList ns (map unLoc names)+        L _ (PatSynSig _ names _) -> extendNameSetList ns (map unLoc names)+        _ -> ns+++{- Note [AFamDataCon: not promoting data family constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data family T a+  data instance T Int = MkT+  data Proxy (a :: k)+  data S = MkS (Proxy 'MkT)++Is it ok to use the promoted data family instance constructor 'MkT' in+the data declaration for S (where both declarations live in the same module)?+No, we don't allow this. It *might* make sense, but at least it would mean that+we'd have to interleave typechecking instances and data types, whereas at+present we do data types *then* instances.++So to check for this we put in the TcLclEnv a binding for all the family+constructors, bound to AFamDataCon, so that if we trip over 'MkT' when+type checking 'S' we'll produce a decent error message.++#12088 describes this limitation. Of course, when MkT and S live in+different modules then all is well.++Note [Don't promote pattern synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We never promote pattern synonyms.++Consider this (#11265):+  pattern A = True+  instance Eq A+We want a civilised error message from the occurrence of 'A'+in the instance, yet 'A' really has not yet been type checked.++Similarly (#9161)+  {-# LANGUAGE PatternSynonyms, DataKinds #-}+  pattern A = ()+  b :: A+  b = undefined+Here, the type signature for b mentions A.  But A is a pattern+synonym, which is typechecked as part of a group of bindings (for very+good reasons; a view pattern in the RHS may mention a value binding).+It is entirely reasonable to reject this, but to do so we need A to be+in the kind environment when kind-checking the signature for B.++Hence tcAddPatSynPlaceholers adds a binding+    A -> APromotionErr PatSynPE+to the environment. Then TcHsType.tcTyVar will find A in the kind+environment, and will give a 'wrongThingErr' as a result.  But the+lookup of A won't fail.+++************************************************************************+*                                                                      *+\subsection{Rules}+*                                                                      *+************************************************************************+-}++tcExtendRules :: [LRuleDecl GhcTc] -> TcM a -> TcM a+        -- Just pop the new rules into the EPS and envt resp+        -- All the rules come from an interface file, not source+        -- Nevertheless, some may be for this module, if we read+        -- its interface instead of its source code+tcExtendRules lcl_rules thing_inside+ = do { env <- getGblEnv+      ; let+          env' = env { tcg_rules = lcl_rules ++ tcg_rules env }+      ; setGblEnv env' thing_inside }++{-+************************************************************************+*                                                                      *+                Meta level+*                                                                      *+************************************************************************+-}++checkWellStaged :: SDoc         -- What the stage check is for+                -> ThLevel      -- Binding level (increases inside brackets)+                -> ThLevel      -- Use stage+                -> TcM ()       -- Fail if badly staged, adding an error+checkWellStaged pp_thing bind_lvl use_lvl+  | use_lvl >= bind_lvl         -- OK! Used later than bound+  = return ()                   -- E.g.  \x -> [| $(f x) |]++  | bind_lvl == outerLevel      -- GHC restriction on top level splices+  = stageRestrictionError pp_thing++  | otherwise                   -- Badly staged+  = failWithTc $                -- E.g.  \x -> $(f x)+    text "Stage error:" <+> pp_thing <+>+        hsep   [text "is bound at stage" <+> ppr bind_lvl,+                text "but used at stage" <+> ppr use_lvl]++stageRestrictionError :: SDoc -> TcM a+stageRestrictionError pp_thing+  = failWithTc $+    sep [ text "GHC stage restriction:"+        , nest 2 (vcat [ pp_thing <+> text "is used in a top-level splice, quasi-quote, or annotation,"+                       , text "and must be imported, not defined locally"])]++topIdLvl :: Id -> ThLevel+-- Globals may either be imported, or may be from an earlier "chunk"+-- (separated by declaration splices) of this module.  The former+--  *can* be used inside a top-level splice, but the latter cannot.+-- Hence we give the former impLevel, but the latter topLevel+-- E.g. this is bad:+--      x = [| foo |]+--      $( f x )+-- By the time we are prcessing the $(f x), the binding for "x"+-- will be in the global env, not the local one.+topIdLvl id | isLocalId id = outerLevel+            | otherwise    = impLevel++tcMetaTy :: Name -> TcM Type+-- Given the name of a Template Haskell data type,+-- return the type+-- E.g. given the name "Expr" return the type "Expr"+tcMetaTy tc_name = do+    t <- tcLookupTyCon tc_name+    return (mkTyConApp t [])++isBrackStage :: ThStage -> Bool+isBrackStage (Brack {}) = True+isBrackStage _other     = False++{-+************************************************************************+*                                                                      *+                 getDefaultTys+*                                                                      *+************************************************************************+-}++tcGetDefaultTys :: TcM ([Type], -- Default types+                        (Bool,  -- True <=> Use overloaded strings+                         Bool)) -- True <=> Use extended defaulting rules+tcGetDefaultTys+  = do  { dflags <- getDynFlags+        ; let ovl_strings = xopt LangExt.OverloadedStrings dflags+              extended_defaults = xopt LangExt.ExtendedDefaultRules dflags+                                        -- See also #1974+              flags = (ovl_strings, extended_defaults)++        ; mb_defaults <- getDeclaredDefaultTys+        ; case mb_defaults of {+           Just tys -> return (tys, flags) ;+                                -- User-supplied defaults+           Nothing  -> do++        -- No use-supplied default+        -- Use [Integer, Double], plus modifications+        { integer_ty <- tcMetaTy integerTyConName+        ; list_ty <- tcMetaTy listTyConName+        ; checkWiredInTyCon doubleTyCon+        ; let deflt_tys = opt_deflt extended_defaults [unitTy, list_ty]+                          -- Note [Extended defaults]+                          ++ [integer_ty, doubleTy]+                          ++ opt_deflt ovl_strings [stringTy]+        ; return (deflt_tys, flags) } } }+  where+    opt_deflt True  xs = xs+    opt_deflt False _  = []++{-+Note [Extended defaults]+~~~~~~~~~~~~~~~~~~~~~+In interative mode (or with -XExtendedDefaultRules) we add () as the first type we+try when defaulting.  This has very little real impact, except in the following case.+Consider:+        Text.Printf.printf "hello"+This has type (forall a. IO a); it prints "hello", and returns 'undefined'.  We don't+want the GHCi repl loop to try to print that 'undefined'.  The neatest thing is to+default the 'a' to (), rather than to Integer (which is what would otherwise happen;+and then GHCi doesn't attempt to print the ().  So in interactive mode, we add+() to the list of defaulting types.  See #1200.++Additionally, the list type [] is added as a default specialization for+Traversable and Foldable. As such the default default list now has types of+varying kinds, e.g. ([] :: * -> *)  and (Integer :: *).++************************************************************************+*                                                                      *+\subsection{The InstInfo type}+*                                                                      *+************************************************************************++The InstInfo type summarises the information in an instance declaration++    instance c => k (t tvs) where b++It is used just for *local* instance decls (not ones from interface files).+But local instance decls includes+        - derived ones+        - generic ones+as well as explicit user written ones.+-}++data InstInfo a+  = InstInfo+      { iSpec   :: ClsInst          -- Includes the dfun id+      , iBinds  :: InstBindings a+      }++iDFunId :: InstInfo a -> DFunId+iDFunId info = instanceDFunId (iSpec info)++data InstBindings a+  = InstBindings+      { ib_tyvars  :: [Name]   -- Names of the tyvars from the instance head+                               -- that are lexically in scope in the bindings+                               -- Must correspond 1-1 with the forall'd tyvars+                               -- of the dfun Id.  When typechecking, we are+                               -- going to extend the typechecker's envt with+                               --     ib_tyvars -> dfun_forall_tyvars++      , ib_binds   :: LHsBinds a    -- Bindings for the instance methods++      , ib_pragmas :: [LSig a]      -- User pragmas recorded for generating+                                    -- specialised instances++      , ib_extensions :: [LangExt.Extension] -- Any extra extensions that should+                                             -- be enabled when type-checking+                                             -- this instance; needed for+                                             -- GeneralizedNewtypeDeriving++      , ib_derived :: Bool+           -- True <=> This code was generated by GHC from a deriving clause+           --          or standalone deriving declaration+           --          Used only to improve error messages+      }++instance (OutputableBndrId (GhcPass a))+       => Outputable (InstInfo (GhcPass a)) where+    ppr = pprInstInfoDetails++pprInstInfoDetails :: (OutputableBndrId (GhcPass a))+                   => InstInfo (GhcPass a) -> SDoc+pprInstInfoDetails info+   = hang (pprInstanceHdr (iSpec info) <+> text "where")+        2 (details (iBinds info))+  where+    details (InstBindings { ib_binds = b }) = pprLHsBinds b++simpleInstInfoClsTy :: InstInfo a -> (Class, Type)+simpleInstInfoClsTy info = case instanceHead (iSpec info) of+                           (_, cls, [ty]) -> (cls, ty)+                           _ -> panic "simpleInstInfoClsTy"++simpleInstInfoTy :: InstInfo a -> Type+simpleInstInfoTy info = snd (simpleInstInfoClsTy info)++simpleInstInfoTyCon :: InstInfo a -> TyCon+  -- Gets the type constructor for a simple instance declaration,+  -- i.e. one of the form       instance (...) => C (T a b c) where ...+simpleInstInfoTyCon inst = tcTyConAppTyCon (simpleInstInfoTy inst)++-- | Make a name for the dict fun for an instance decl.  It's an *external*+-- name, like other top-level names, and hence must be made with+-- newGlobalBinder.+newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name+newDFunName clas tys loc+  = do  { is_boot <- tcIsHsBootOrSig+        ; mod     <- getModule+        ; let info_string = occNameString (getOccName clas) +++                            concatMap (occNameString.getDFunTyKey) tys+        ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)+        ; newGlobalBinder mod dfun_occ loc }++-- | Special case of 'newDFunName' to generate dict fun name for a single TyCon.+newDFunName' :: Class -> TyCon -> TcM Name+newDFunName' clas tycon        -- Just a simple wrapper+  = do { loc <- getSrcSpanM     -- The location of the instance decl,+                                -- not of the tycon+       ; newDFunName clas [mkTyConApp tycon []] loc }+       -- The type passed to newDFunName is only used to generate+       -- a suitable string; hence the empty type arg list++{-+Make a name for the representation tycon of a family instance.  It's an+*external* name, like other top-level names, and hence must be made with+newGlobalBinder.+-}++newFamInstTyConName :: Located Name -> [Type] -> TcM Name+newFamInstTyConName (L loc name) tys = mk_fam_inst_name id loc name [tys]++newFamInstAxiomName :: Located Name -> [[Type]] -> TcM Name+newFamInstAxiomName (L loc name) branches+  = mk_fam_inst_name mkInstTyCoOcc loc name branches++mk_fam_inst_name :: (OccName -> OccName) -> SrcSpan -> Name -> [[Type]] -> TcM Name+mk_fam_inst_name adaptOcc loc tc_name tyss+  = do  { mod   <- getModule+        ; let info_string = occNameString (getOccName tc_name) +++                            intercalate "|" ty_strings+        ; occ   <- chooseUniqueOccTc (mkInstTyTcOcc info_string)+        ; newGlobalBinder mod (adaptOcc occ) loc }+  where+    ty_strings = map (concatMap (occNameString . getDFunTyKey)) tyss++{-+Stable names used for foreign exports and annotations.+For stable names, the name must be unique (see #1533).  If the+same thing has several stable Ids based on it, the+top-level bindings generated must not have the same name.+Hence we create an External name (doesn't change), and we+append a Unique to the string right here.+-}++mkStableIdFromString :: String -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId+mkStableIdFromString str sig_ty loc occ_wrapper = do+    uniq <- newUnique+    mod <- getModule+    name <- mkWrapperName "stable" str+    let occ = mkVarOccFS name :: OccName+        gnm = mkExternalName uniq mod (occ_wrapper occ) loc :: Name+        id  = mkExportedVanillaId gnm sig_ty :: Id+    return id++mkStableIdFromName :: Name -> Type -> SrcSpan -> (OccName -> OccName) -> TcM TcId+mkStableIdFromName nm = mkStableIdFromString (getOccString nm)++mkWrapperName :: (MonadIO m, HasDynFlags m, HasModule m)+              => String -> String -> m FastString+mkWrapperName what nameBase+    = do dflags <- getDynFlags+         thisMod <- getModule+         let -- Note [Generating fresh names for ccall wrapper]+             wrapperRef = nextWrapperNum dflags+             pkg = unitIdString  (moduleUnitId thisMod)+             mod = moduleNameString (moduleName      thisMod)+         wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->+             let num = lookupWithDefaultModuleEnv mod_env 0 thisMod+                 mod_env' = extendModuleEnv mod_env thisMod (num+1)+             in (mod_env', num)+         let components = [what, show wrapperNum, pkg, mod, nameBase]+         return $ mkFastString $ zEncodeString $ intercalate ":" components++{-+Note [Generating fresh names for FFI wrappers]++We used to use a unique, rather than nextWrapperNum, to distinguish+between FFI wrapper functions. However, the wrapper names that we+generate are external names. This means that if a call to them ends up+in an unfolding, then we can't alpha-rename them, and thus if the+unique randomly changes from one compile to another then we get a+spurious ABI change (#4012).++The wrapper counter has to be per-module, not global, so that the number we end+up using is not dependent on the modules compiled before the current one.+-}++{-+************************************************************************+*                                                                      *+\subsection{Errors}+*                                                                      *+************************************************************************+-}++pprBinders :: [Name] -> SDoc+-- Used in error messages+-- Use quotes for a single one; they look a bit "busy" for several+pprBinders [bndr] = quotes (ppr bndr)+pprBinders bndrs  = pprWithCommas ppr bndrs++notFound :: Name -> TcM TyThing+notFound name+  = do { lcl_env <- getLclEnv+       ; let stage = tcl_th_ctxt lcl_env+       ; case stage of   -- See Note [Out of scope might be a staging error]+           Splice {}+             | isUnboundName name -> failM  -- If the name really isn't in scope+                                            -- don't report it again (#11941)+             | otherwise -> stageRestrictionError (quotes (ppr name))+           _ -> failWithTc $+                vcat[text "GHC internal error:" <+> quotes (ppr name) <+>+                     text "is not in scope during type checking, but it passed the renamer",+                     text "tcl_env of environment:" <+> ppr (tcl_env lcl_env)]+                       -- Take care: printing the whole gbl env can+                       -- cause an infinite loop, in the case where we+                       -- are in the middle of a recursive TyCon/Class group;+                       -- so let's just not print it!  Getting a loop here is+                       -- very unhelpful, because it hides one compiler bug with another+       }++wrongThingErr :: String -> TcTyThing -> Name -> TcM a+-- It's important that this only calls pprTcTyThingCategory, which in+-- turn does not look at the details of the TcTyThing.+-- See Note [Placeholder PatSyn kinds] in TcBinds+wrongThingErr expected thing name+  = failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>+                text "used as a" <+> text expected)++{- Note [Out of scope might be a staging error]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  x = 3+  data T = MkT $(foo x)++where 'foo' is imported from somewhere.++This is really a staging error, because we can't run code involving 'x'.+But in fact the type checker processes types first, so 'x' won't even be+in the type envt when we look for it in $(foo x).  So inside splices we+report something missing from the type env as a staging error.+See #5752 and #5795.+-}
+ compiler/typecheck/TcEnv.hs-boot view
@@ -0,0 +1,10 @@+module TcEnv where++import TcRnTypes( TcM )+import VarEnv( TidyEnv )++-- Annoyingly, there's a recursion between tcInitTidyEnv+-- (which does zonking and hence needs TcMType) and+-- addErrTc etc which live in TcRnMonad.  Rats.+tcInitTidyEnv :: TcM TidyEnv+
+ compiler/typecheck/TcErrors.hs view
@@ -0,0 +1,3112 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++module TcErrors(+       reportUnsolved, reportAllUnsolved, warnAllUnsolved,+       warnDefaulting,++       solverDepthErrorTcS+  ) where++#include "HsVersions.h"++import GhcPrelude++import TcRnTypes+import TcRnMonad+import TcMType+import TcUnify( occCheckForErrors, MetaTyVarUpdateResult(..) )+import TcEnv( tcInitTidyEnv )+import TcType+import RnUnbound ( unknownNameSuggestions )+import Type+import TyCoRep+import Unify            ( tcMatchTys )+import Module+import FamInst+import FamInstEnv       ( flattenTys )+import Inst+import InstEnv+import TyCon+import Class+import DataCon+import TcEvidence+import TcEvTerm+import HsExpr  ( UnboundVar(..) )+import HsBinds ( PatSynBind(..) )+import Name+import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv+               , mkRdrUnqual, isLocalGRE, greSrcSpan )+import PrelNames ( typeableClassName )+import Id+import Var+import VarSet+import VarEnv+import NameSet+import Bag+import ErrUtils         ( ErrMsg, errDoc, pprLocErrMsg )+import BasicTypes+import ConLike          ( ConLike(..))+import Util+import FastString+import Outputable+import SrcLoc+import DynFlags+import ListSetOps       ( equivClasses )+import Maybes+import Pair+import qualified GHC.LanguageExtensions as LangExt+import FV ( fvVarList, unionFV )++import Control.Monad    ( when )+import Data.Foldable    ( toList )+import Data.List        ( partition, mapAccumL, nub, sortBy, unfoldr )+import qualified Data.Set as Set++import {-# SOURCE #-} TcHoleErrors ( findValidHoleFits )++-- import Data.Semigroup   ( Semigroup )+import qualified Data.Semigroup as Semigroup+++{-+************************************************************************+*                                                                      *+\section{Errors and contexts}+*                                                                      *+************************************************************************++ToDo: for these error messages, should we note the location as coming+from the insts, or just whatever seems to be around in the monad just+now?++Note [Deferring coercion errors to runtime]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+While developing, sometimes it is desirable to allow compilation to succeed even+if there are type errors in the code. Consider the following case:++  module Main where++  a :: Int+  a = 'a'++  main = print "b"++Even though `a` is ill-typed, it is not used in the end, so if all that we're+interested in is `main` it is handy to be able to ignore the problems in `a`.++Since we treat type equalities as evidence, this is relatively simple. Whenever+we run into a type mismatch in TcUnify, we normally just emit an error. But it+is always safe to defer the mismatch to the main constraint solver. If we do+that, `a` will get transformed into++  co :: Int ~ Char+  co = ...++  a :: Int+  a = 'a' `cast` co++The constraint solver would realize that `co` is an insoluble constraint, and+emit an error with `reportUnsolved`. But we can also replace the right-hand side+of `co` with `error "Deferred type error: Int ~ Char"`. This allows the program+to compile, and it will run fine unless we evaluate `a`. This is what+`deferErrorsToRuntime` does.++It does this by keeping track of which errors correspond to which coercion+in TcErrors. TcErrors.reportTidyWanteds does not print the errors+and does not fail if -fdefer-type-errors is on, so that we can continue+compilation. The errors are turned into warnings in `reportUnsolved`.+-}++-- | Report unsolved goals as errors or warnings. We may also turn some into+-- deferred run-time errors if `-fdefer-type-errors` is on.+reportUnsolved :: WantedConstraints -> TcM (Bag EvBind)+reportUnsolved wanted+  = do { binds_var <- newTcEvBinds+       ; defer_errors <- goptM Opt_DeferTypeErrors+       ; warn_errors <- woptM Opt_WarnDeferredTypeErrors -- implement #10283+       ; let type_errors | not defer_errors = TypeError+                         | warn_errors      = TypeWarn (Reason Opt_WarnDeferredTypeErrors)+                         | otherwise        = TypeDefer++       ; defer_holes <- goptM Opt_DeferTypedHoles+       ; warn_holes  <- woptM Opt_WarnTypedHoles+       ; let expr_holes | not defer_holes = HoleError+                        | warn_holes      = HoleWarn+                        | otherwise       = HoleDefer++       ; partial_sigs      <- xoptM LangExt.PartialTypeSignatures+       ; warn_partial_sigs <- woptM Opt_WarnPartialTypeSignatures+       ; let type_holes | not partial_sigs  = HoleError+                        | warn_partial_sigs = HoleWarn+                        | otherwise         = HoleDefer++       ; defer_out_of_scope <- goptM Opt_DeferOutOfScopeVariables+       ; warn_out_of_scope <- woptM Opt_WarnDeferredOutOfScopeVariables+       ; let out_of_scope_holes | not defer_out_of_scope = HoleError+                                | warn_out_of_scope      = HoleWarn+                                | otherwise              = HoleDefer++       ; report_unsolved type_errors expr_holes+                         type_holes out_of_scope_holes+                         binds_var wanted++       ; ev_binds <- getTcEvBindsMap binds_var+       ; return (evBindMapBinds ev_binds)}++-- | Report *all* unsolved goals as errors, even if -fdefer-type-errors is on+-- However, do not make any evidence bindings, because we don't+-- have any convenient place to put them.+-- See Note [Deferring coercion errors to runtime]+-- Used by solveEqualities for kind equalities+--      (see Note [Fail fast on kind errors] in TcSimplify]+-- and for simplifyDefault.+reportAllUnsolved :: WantedConstraints -> TcM ()+reportAllUnsolved wanted+  = do { ev_binds <- newNoTcEvBinds+       ; report_unsolved TypeError HoleError HoleError HoleError+                         ev_binds wanted }++-- | Report all unsolved goals as warnings (but without deferring any errors to+-- run-time). See Note [Safe Haskell Overlapping Instances Implementation] in+-- TcSimplify+warnAllUnsolved :: WantedConstraints -> TcM ()+warnAllUnsolved wanted+  = do { ev_binds <- newTcEvBinds+       ; report_unsolved (TypeWarn NoReason) HoleWarn HoleWarn HoleWarn+                         ev_binds wanted }++-- | Report unsolved goals as errors or warnings.+report_unsolved :: TypeErrorChoice   -- Deferred type errors+                -> HoleChoice        -- Expression holes+                -> HoleChoice        -- Type holes+                -> HoleChoice        -- Out of scope holes+                -> EvBindsVar        -- cec_binds+                -> WantedConstraints -> TcM ()+report_unsolved type_errors expr_holes+    type_holes out_of_scope_holes binds_var wanted+  | isEmptyWC wanted+  = return ()+  | otherwise+  = do { traceTc "reportUnsolved {" $+         vcat [ text "type errors:" <+> ppr type_errors+              , text "expr holes:" <+> ppr expr_holes+              , text "type holes:" <+> ppr type_holes+              , text "scope holes:" <+> ppr out_of_scope_holes ]+       ; traceTc "reportUnsolved (before zonking and tidying)" (ppr wanted)++       ; wanted <- zonkWC wanted   -- Zonk to reveal all information+       ; env0 <- tcInitTidyEnv+            -- If we are deferring we are going to need /all/ evidence around,+            -- including the evidence produced by unflattening (zonkWC)+       ; let tidy_env = tidyFreeTyCoVars env0 free_tvs+             free_tvs = tyCoVarsOfWCList wanted++       ; traceTc "reportUnsolved (after zonking):" $+         vcat [ text "Free tyvars:" <+> pprTyVars free_tvs+              , text "Tidy env:" <+> ppr tidy_env+              , text "Wanted:" <+> ppr wanted ]++       ; warn_redundant <- woptM Opt_WarnRedundantConstraints+       ; let err_ctxt = CEC { cec_encl  = []+                            , cec_tidy  = tidy_env+                            , cec_defer_type_errors = type_errors+                            , cec_expr_holes = expr_holes+                            , cec_type_holes = type_holes+                            , cec_out_of_scope_holes = out_of_scope_holes+                            , cec_suppress = insolubleWC wanted+                                 -- See Note [Suppressing error messages]+                                 -- Suppress low-priority errors if there+                                 -- are insolule errors anywhere;+                                 -- See #15539 and c.f. setting ic_status+                                 -- in TcSimplify.setImplicationStatus+                            , cec_warn_redundant = warn_redundant+                            , cec_binds    = binds_var }++       ; tc_lvl <- getTcLevel+       ; reportWanteds err_ctxt tc_lvl wanted+       ; traceTc "reportUnsolved }" empty }++--------------------------------------------+--      Internal functions+--------------------------------------------++-- | An error Report collects messages categorised by their importance.+-- See Note [Error report] for details.+data Report+  = Report { report_important :: [SDoc]+           , report_relevant_bindings :: [SDoc]+           , report_valid_hole_fits :: [SDoc]+           }++instance Outputable Report where   -- Debugging only+  ppr (Report { report_important = imp+              , report_relevant_bindings = rel+              , report_valid_hole_fits = val })+    = vcat [ text "important:" <+> vcat imp+           , text "relevant:"  <+> vcat rel+           , text "valid:"  <+> vcat val ]++{- Note [Error report]+The idea is that error msgs are divided into three parts: the main msg, the+context block (\"In the second argument of ...\"), and the relevant bindings+block, which are displayed in that order, with a mark to divide them.  The+idea is that the main msg ('report_important') varies depending on the error+in question, but context and relevant bindings are always the same, which+should simplify visual parsing.++The context is added when the Report is passed off to 'mkErrorReport'.+Unfortunately, unlike the context, the relevant bindings are added in+multiple places so they have to be in the Report.+-}++instance Semigroup Report where+    Report a1 b1 c1 <> Report a2 b2 c2 = Report (a1 ++ a2) (b1 ++ b2) (c1 ++ c2)++instance Monoid Report where+    mempty = Report [] [] []+    mappend = (Semigroup.<>)++-- | Put a doc into the important msgs block.+important :: SDoc -> Report+important doc = mempty { report_important = [doc] }++-- | Put a doc into the relevant bindings block.+relevant_bindings :: SDoc -> Report+relevant_bindings doc = mempty { report_relevant_bindings = [doc] }++-- | Put a doc into the valid hole fits block.+valid_hole_fits :: SDoc -> Report+valid_hole_fits docs = mempty { report_valid_hole_fits = [docs] }++data TypeErrorChoice   -- What to do for type errors found by the type checker+  = TypeError     -- A type error aborts compilation with an error message+  | TypeWarn WarnReason+                  -- A type error is deferred to runtime, plus a compile-time warning+                  -- The WarnReason should usually be (Reason Opt_WarnDeferredTypeErrors)+                  -- but it isn't for the Safe Haskell Overlapping Instances warnings+                  -- see warnAllUnsolved+  | TypeDefer     -- A type error is deferred to runtime; no error or warning at compile time++data HoleChoice+  = HoleError     -- A hole is a compile-time error+  | HoleWarn      -- Defer to runtime, emit a compile-time warning+  | HoleDefer     -- Defer to runtime, no warning++instance Outputable HoleChoice where+  ppr HoleError = text "HoleError"+  ppr HoleWarn  = text "HoleWarn"+  ppr HoleDefer = text "HoleDefer"++instance Outputable TypeErrorChoice  where+  ppr TypeError         = text "TypeError"+  ppr (TypeWarn reason) = text "TypeWarn" <+> ppr reason+  ppr TypeDefer         = text "TypeDefer"++data ReportErrCtxt+    = CEC { cec_encl :: [Implication]  -- Enclosing implications+                                       --   (innermost first)+                                       -- ic_skols and givens are tidied, rest are not+          , cec_tidy  :: TidyEnv++          , cec_binds :: EvBindsVar    -- Make some errors (depending on cec_defer)+                                       -- into warnings, and emit evidence bindings+                                       -- into 'cec_binds' for unsolved constraints++          , cec_defer_type_errors :: TypeErrorChoice -- Defer type errors until runtime++          -- cec_expr_holes is a union of:+          --   cec_type_holes - a set of typed holes: '_', '_a', '_foo'+          --   cec_out_of_scope_holes - a set of variables which are+          --                            out of scope: 'x', 'y', 'bar'+          , cec_expr_holes :: HoleChoice           -- Holes in expressions+          , cec_type_holes :: HoleChoice           -- Holes in types+          , cec_out_of_scope_holes :: HoleChoice   -- Out of scope holes++          , cec_warn_redundant :: Bool    -- True <=> -Wredundant-constraints++          , cec_suppress :: Bool    -- True <=> More important errors have occurred,+                                    --          so create bindings if need be, but+                                    --          don't issue any more errors/warnings+                                    -- See Note [Suppressing error messages]+      }++instance Outputable ReportErrCtxt where+  ppr (CEC { cec_binds              = bvar+           , cec_defer_type_errors  = dte+           , cec_expr_holes         = eh+           , cec_type_holes         = th+           , cec_out_of_scope_holes = osh+           , cec_warn_redundant     = wr+           , cec_suppress           = sup })+    = text "CEC" <+> braces (vcat+         [ text "cec_binds"              <+> equals <+> ppr bvar+         , text "cec_defer_type_errors"  <+> equals <+> ppr dte+         , text "cec_expr_holes"         <+> equals <+> ppr eh+         , text "cec_type_holes"         <+> equals <+> ppr th+         , text "cec_out_of_scope_holes" <+> equals <+> ppr osh+         , text "cec_warn_redundant"     <+> equals <+> ppr wr+         , text "cec_suppress"           <+> equals <+> ppr sup ])++-- | Returns True <=> the ReportErrCtxt indicates that something is deferred+deferringAnyBindings :: ReportErrCtxt -> Bool+  -- Don't check cec_type_holes, as these don't cause bindings to be deferred+deferringAnyBindings (CEC { cec_defer_type_errors  = TypeError+                          , cec_expr_holes         = HoleError+                          , cec_out_of_scope_holes = HoleError }) = False+deferringAnyBindings _                                            = True++-- | Transforms a 'ReportErrCtxt' into one that does not defer any bindings+-- at all.+noDeferredBindings :: ReportErrCtxt -> ReportErrCtxt+noDeferredBindings ctxt = ctxt { cec_defer_type_errors  = TypeError+                               , cec_expr_holes         = HoleError+                               , cec_out_of_scope_holes = HoleError }++{- Note [Suppressing error messages]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The cec_suppress flag says "don't report any errors".  Instead, just create+evidence bindings (as usual).  It's used when more important errors have occurred.++Specifically (see reportWanteds)+  * If there are insoluble Givens, then we are in unreachable code and all bets+    are off.  So don't report any further errors.+  * If there are any insolubles (eg Int~Bool), here or in a nested implication,+    then suppress errors from the simple constraints here.  Sometimes the+    simple-constraint errors are a knock-on effect of the insolubles.++This suppression behaviour is controlled by the Bool flag in+ReportErrorSpec, as used in reportWanteds.++But we need to take care: flags can turn errors into warnings, and we+don't want those warnings to suppress subsequent errors (including+suppressing the essential addTcEvBind for them: #15152). So in+tryReporter we use askNoErrs to see if any error messages were+/actually/ produced; if not, we don't switch on suppression.++A consequence is that warnings never suppress warnings, so turning an+error into a warning may allow subsequent warnings to appear that were+previously suppressed.   (e.g. partial-sigs/should_fail/T14584)+-}++reportImplic :: ReportErrCtxt -> Implication -> TcM ()+reportImplic ctxt implic@(Implic { ic_skols = tvs, ic_telescope = m_telescope+                                 , ic_given = given+                                 , ic_wanted = wanted, ic_binds = evb+                                 , ic_status = status, ic_info = info+                                 , ic_tclvl = tc_lvl })+  | BracketSkol <- info+  , not insoluble+  = return ()        -- For Template Haskell brackets report only+                     -- definite errors. The whole thing will be re-checked+                     -- later when we plug it in, and meanwhile there may+                     -- certainly be un-satisfied constraints++  | otherwise+  = do { traceTc "reportImplic" (ppr implic')+       ; reportWanteds ctxt' tc_lvl wanted+       ; when (cec_warn_redundant ctxt) $+         warnRedundantConstraints ctxt' tcl_env info' dead_givens+       ; when bad_telescope $ reportBadTelescope ctxt tcl_env m_telescope tvs }+  where+    tcl_env      = implicLclEnv implic+    insoluble    = isInsolubleStatus status+    (env1, tvs') = mapAccumL tidyVarBndr (cec_tidy ctxt) tvs+    info'        = tidySkolemInfo env1 info+    implic' = implic { ic_skols = tvs'+                     , ic_given = map (tidyEvVar env1) given+                     , ic_info  = info' }+    ctxt1 | CoEvBindsVar{} <- evb    = noDeferredBindings ctxt+          | otherwise                = ctxt+          -- If we go inside an implication that has no term+          -- evidence (e.g. unifying under a forall), we can't defer+          -- type errors.  You could imagine using the /enclosing/+          -- bindings (in cec_binds), but that may not have enough stuff+          -- in scope for the bindings to be well typed.  So we just+          -- switch off deferred type errors altogether.  See #14605.++    ctxt' = ctxt1 { cec_tidy     = env1+                  , cec_encl     = implic' : cec_encl ctxt++                  , cec_suppress = insoluble || cec_suppress ctxt+                        -- Suppress inessential errors if there+                        -- are insolubles anywhere in the+                        -- tree rooted here, or we've come across+                        -- a suppress-worthy constraint higher up (#11541)++                  , cec_binds    = evb }++    dead_givens = case status of+                    IC_Solved { ics_dead = dead } -> dead+                    _                             -> []++    bad_telescope = case status of+              IC_BadTelescope -> True+              _               -> False++warnRedundantConstraints :: ReportErrCtxt -> TcLclEnv -> SkolemInfo -> [EvVar] -> TcM ()+-- See Note [Tracking redundant constraints] in TcSimplify+warnRedundantConstraints ctxt env info ev_vars+ | null redundant_evs+ = return ()++ | SigSkol {} <- info+ = setLclEnv env $  -- We want to add "In the type signature for f"+                    -- to the error context, which is a bit tiresome+   addErrCtxt (text "In" <+> ppr info) $+   do { env <- getLclEnv+      ; msg <- mkErrorReport ctxt env (important doc)+      ; reportWarning (Reason Opt_WarnRedundantConstraints) msg }++ | otherwise  -- But for InstSkol there already *is* a surrounding+              -- "In the instance declaration for Eq [a]" context+              -- and we don't want to say it twice. Seems a bit ad-hoc+ = do { msg <- mkErrorReport ctxt env (important doc)+      ; reportWarning (Reason Opt_WarnRedundantConstraints) msg }+ where+   doc = text "Redundant constraint" <> plural redundant_evs <> colon+         <+> pprEvVarTheta redundant_evs++   redundant_evs =+       filterOut is_type_error $+       case info of -- See Note [Redundant constraints in instance decls]+         InstSkol -> filterOut (improving . idType) ev_vars+         _        -> ev_vars++   -- See #15232+   is_type_error = isJust . userTypeError_maybe . idType++   improving pred -- (transSuperClasses p) does not include p+     = any isImprovementPred (pred : transSuperClasses pred)++reportBadTelescope :: ReportErrCtxt -> TcLclEnv -> Maybe SDoc -> [TcTyVar] -> TcM ()+reportBadTelescope ctxt env (Just telescope) skols+  = do { msg <- mkErrorReport ctxt env (important doc)+       ; reportError msg }+  where+    doc = hang (text "These kind and type variables:" <+> telescope $$+                text "are out of dependency order. Perhaps try this ordering:")+             2 (pprTyVars sorted_tvs)++    sorted_tvs = scopedSort skols++reportBadTelescope _ _ Nothing skols+  = pprPanic "reportBadTelescope" (ppr skols)++{- Note [Redundant constraints in instance decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For instance declarations, we don't report unused givens if+they can give rise to improvement.  Example (#10100):+    class Add a b ab | a b -> ab, a ab -> b+    instance Add Zero b b+    instance Add a b ab => Add (Succ a) b (Succ ab)+The context (Add a b ab) for the instance is clearly unused in terms+of evidence, since the dictionary has no fields.  But it is still+needed!  With the context, a wanted constraint+   Add (Succ Zero) beta (Succ Zero)+we will reduce to (Add Zero beta Zero), and thence we get beta := Zero.+But without the context we won't find beta := Zero.++This only matters in instance declarations..+-}++reportWanteds :: ReportErrCtxt -> TcLevel -> WantedConstraints -> TcM ()+reportWanteds ctxt tc_lvl (WC { wc_simple = simples, wc_impl = implics })+  = do { traceTc "reportWanteds" (vcat [ text "Simples =" <+> ppr simples+                                       , text "Suppress =" <+> ppr (cec_suppress ctxt)])+       ; traceTc "rw2" (ppr tidy_cts)++         -- First deal with things that are utterly wrong+         -- Like Int ~ Bool (incl nullary TyCons)+         -- or  Int ~ t a   (AppTy on one side)+         -- These /ones/ are not suppressed by the incoming context+       ; let ctxt_for_insols = ctxt { cec_suppress = False }+       ; (ctxt1, cts1) <- tryReporters ctxt_for_insols report1 tidy_cts++         -- Now all the other constraints.  We suppress errors here if+         -- any of the first batch failed, or if the enclosing context+         -- says to suppress+       ; let ctxt2 = ctxt { cec_suppress = cec_suppress ctxt || cec_suppress ctxt1 }+       ; (_, leftovers) <- tryReporters ctxt2 report2 cts1+       ; MASSERT2( null leftovers, ppr leftovers )++            -- All the Derived ones have been filtered out of simples+            -- by the constraint solver. This is ok; we don't want+            -- to report unsolved Derived goals as errors+            -- See Note [Do not report derived but soluble errors]++     ; mapBagM_ (reportImplic ctxt2) implics }+            -- NB ctxt1: don't suppress inner insolubles if there's only a+            -- wanted insoluble here; but do suppress inner insolubles+            -- if there's a *given* insoluble here (= inaccessible code)+ where+    env = cec_tidy ctxt+    tidy_cts = bagToList (mapBag (tidyCt env) simples)++    -- report1: ones that should *not* be suppresed by+    --          an insoluble somewhere else in the tree+    -- It's crucial that anything that is considered insoluble+    -- (see TcRnTypes.insolubleCt) is caught here, otherwise+    -- we might suppress its error message, and proceed on past+    -- type checking to get a Lint error later+    report1 = [ ("Out of scope", is_out_of_scope,    True,  mkHoleReporter tidy_cts)+              , ("Holes",        is_hole,            False, mkHoleReporter tidy_cts)+              , ("custom_error", is_user_type_error, True,  mkUserTypeErrorReporter)++              , given_eq_spec+              , ("insoluble2",   utterly_wrong,  True, mkGroupReporter mkEqErr)+              , ("skolem eq1",   very_wrong,     True, mkSkolReporter)+              , ("skolem eq2",   skolem_eq,      True, mkSkolReporter)+              , ("non-tv eq",    non_tv_eq,      True, mkSkolReporter)++                  -- The only remaining equalities are alpha ~ ty,+                  -- where alpha is untouchable; and representational equalities+                  -- Prefer homogeneous equalities over hetero, because the+                  -- former might be holding up the latter.+                  -- See Note [Equalities with incompatible kinds] in TcCanonical+              , ("Homo eqs",      is_homo_equality, True,  mkGroupReporter mkEqErr)+              , ("Other eqs",     is_equality,      False, mkGroupReporter mkEqErr) ]++    -- report2: we suppress these if there are insolubles elsewhere in the tree+    report2 = [ ("Implicit params", is_ip,           False, mkGroupReporter mkIPErr)+              , ("Irreds",          is_irred,        False, mkGroupReporter mkIrredErr)+              , ("Dicts",           is_dict,         False, mkGroupReporter mkDictErr) ]++    -- rigid_nom_eq, rigid_nom_tv_eq,+    is_hole, is_dict,+      is_equality, is_ip, is_irred :: Ct -> PredTree -> Bool++    is_given_eq ct pred+       | EqPred {} <- pred = arisesFromGivens ct+       | otherwise         = False+       -- I think all given residuals are equalities++    -- Things like (Int ~N Bool)+    utterly_wrong _ (EqPred NomEq ty1 ty2) = isRigidTy ty1 && isRigidTy ty2+    utterly_wrong _ _                      = False++    -- Things like (a ~N Int)+    very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2+    very_wrong _ _                      = False++    -- Things like (a ~N b) or (a  ~N  F Bool)+    skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1+    skolem_eq _ _                    = False++    -- Things like (F a  ~N  Int)+    non_tv_eq _ (EqPred NomEq ty1 _) = not (isTyVarTy ty1)+    non_tv_eq _ _                    = False++    is_out_of_scope ct _ = isOutOfScopeCt ct+    is_hole         ct _ = isHoleCt ct++    is_user_type_error ct _ = isUserTypeErrorCt ct++    is_homo_equality _ (EqPred _ ty1 ty2) = tcTypeKind ty1 `tcEqType` tcTypeKind ty2+    is_homo_equality _ _                  = False++    is_equality _ (EqPred {}) = True+    is_equality _ _           = False++    is_dict _ (ClassPred {}) = True+    is_dict _ _              = False++    is_ip _ (ClassPred cls _) = isIPClass cls+    is_ip _ _                 = False++    is_irred _ (IrredPred {}) = True+    is_irred _ _              = False++    given_eq_spec  -- See Note [Given errors]+      | has_gadt_match (cec_encl ctxt)+      = ("insoluble1a", is_given_eq, True,  mkGivenErrorReporter)+      | otherwise+      = ("insoluble1b", is_given_eq, False, ignoreErrorReporter)+          -- False means don't suppress subsequent errors+          -- Reason: we don't report all given errors+          --         (see mkGivenErrorReporter), and we should only suppress+          --         subsequent errors if we actually report this one!+          --         #13446 is an example++    -- See Note [Given errors]+    has_gadt_match [] = False+    has_gadt_match (implic : implics)+      | PatSkol {} <- ic_info implic+      , not (ic_no_eqs implic)+      , wopt Opt_WarnInaccessibleCode (implicDynFlags implic)+          -- Don't bother doing this if -Winaccessible-code isn't enabled.+          -- See Note [Avoid -Winaccessible-code when deriving] in TcInstDcls.+      = True+      | otherwise+      = has_gadt_match implics++---------------+isSkolemTy :: TcLevel -> Type -> Bool+-- The type is a skolem tyvar+isSkolemTy tc_lvl ty+  | Just tv <- getTyVar_maybe ty+  =  isSkolemTyVar tv+  || (isTyVarTyVar tv && isTouchableMetaTyVar tc_lvl tv)+     -- The last case is for touchable TyVarTvs+     -- we postpone untouchables to a latter test (too obscure)++  | otherwise+  = False++isTyFun_maybe :: Type -> Maybe TyCon+isTyFun_maybe ty = case tcSplitTyConApp_maybe ty of+                      Just (tc,_) | isTypeFamilyTyCon tc -> Just tc+                      _ -> Nothing++--------------------------------------------+--      Reporters+--------------------------------------------++type Reporter+  = ReportErrCtxt -> [Ct] -> TcM ()+type ReporterSpec+  = ( String                     -- Name+    , Ct -> PredTree -> Bool     -- Pick these ones+    , Bool                       -- True <=> suppress subsequent reporters+    , Reporter)                  -- The reporter itself++mkSkolReporter :: Reporter+-- Suppress duplicates with either the same LHS, or same location+mkSkolReporter ctxt cts+  = mapM_ (reportGroup mkEqErr ctxt) (group cts)+  where+     group [] = []+     group (ct:cts) = (ct : yeses) : group noes+        where+          (yeses, noes) = partition (group_with ct) cts++     group_with ct1 ct2+       | EQ <- cmp_loc ct1 ct2 = True+       | eq_lhs_type   ct1 ct2 = True+       | otherwise             = False++mkHoleReporter :: [Ct] -> Reporter+-- Reports errors one at a time+mkHoleReporter tidy_simples ctxt+  = mapM_ $ \ct -> do { err <- mkHoleError tidy_simples ctxt ct+                      ; maybeReportHoleError ctxt ct err+                      ; maybeAddDeferredHoleBinding ctxt err ct }++mkUserTypeErrorReporter :: Reporter+mkUserTypeErrorReporter ctxt+  = mapM_ $ \ct -> do { err <- mkUserTypeError ctxt ct+                      ; maybeReportError ctxt err+                      ; addDeferredBinding ctxt err ct }++mkUserTypeError :: ReportErrCtxt -> Ct -> TcM ErrMsg+mkUserTypeError ctxt ct = mkErrorMsgFromCt ctxt ct+                        $ important+                        $ pprUserTypeErrorTy+                        $ case getUserTypeErrorMsg ct of+                            Just msg -> msg+                            Nothing  -> pprPanic "mkUserTypeError" (ppr ct)+++mkGivenErrorReporter :: Reporter+-- See Note [Given errors]+mkGivenErrorReporter ctxt cts+  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct+       ; dflags <- getDynFlags+       ; let (implic:_) = cec_encl ctxt+                 -- Always non-empty when mkGivenErrorReporter is called+             ct' = setCtLoc ct (setCtLocEnv (ctLoc ct) (implicLclEnv implic))+                   -- For given constraints we overwrite the env (and hence src-loc)+                   -- with one from the immediately-enclosing implication.+                   -- See Note [Inaccessible code]++             inaccessible_msg = hang (text "Inaccessible code in")+                                   2 (ppr (ic_info implic))+             report = important inaccessible_msg `mappend`+                      relevant_bindings binds_msg++       ; err <- mkEqErr_help dflags ctxt report ct'+                             Nothing ty1 ty2++       ; traceTc "mkGivenErrorReporter" (ppr ct)+       ; reportWarning (Reason Opt_WarnInaccessibleCode) err }+  where+    (ct : _ )  = cts    -- Never empty+    (ty1, ty2) = getEqPredTys (ctPred ct)++ignoreErrorReporter :: Reporter+-- Discard Given errors that don't come from+-- a pattern match; maybe we should warn instead?+ignoreErrorReporter ctxt cts+  = do { traceTc "mkGivenErrorReporter no" (ppr cts $$ ppr (cec_encl ctxt))+       ; return () }+++{- Note [Given errors]+~~~~~~~~~~~~~~~~~~~~~~+Given constraints represent things for which we have (or will have)+evidence, so they aren't errors.  But if a Given constraint is+insoluble, this code is inaccessible, and we might want to at least+warn about that.  A classic case is++   data T a where+     T1 :: T Int+     T2 :: T a+     T3 :: T Bool++   f :: T Int -> Bool+   f T1 = ...+   f T2 = ...+   f T3 = ...  -- We want to report this case as inaccessible++We'd like to point out that the T3 match is inaccessible. It+will have a Given constraint [G] Int ~ Bool.++But we don't want to report ALL insoluble Given constraints.  See Trac+#12466 for a long discussion.  For example, if we aren't careful+we'll complain about+   f :: ((Int ~ Bool) => a -> a) -> Int+which arguably is OK.  It's more debatable for+   g :: (Int ~ Bool) => Int -> Int+but it's tricky to distinguish these cases so we don't report+either.++The bottom line is this: has_gadt_match looks for an enclosing+pattern match which binds some equality constraints.  If we+find one, we report the insoluble Given.+-}++mkGroupReporter :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg)+                             -- Make error message for a group+                -> Reporter  -- Deal with lots of constraints+-- Group together errors from same location,+-- and report only the first (to avoid a cascade)+mkGroupReporter mk_err ctxt cts+  = mapM_ (reportGroup mk_err ctxt . toList) (equivClasses cmp_loc cts)++eq_lhs_type :: Ct -> Ct -> Bool+eq_lhs_type ct1 ct2+  = case (classifyPredType (ctPred ct1), classifyPredType (ctPred ct2)) of+       (EqPred eq_rel1 ty1 _, EqPred eq_rel2 ty2 _) ->+         (eq_rel1 == eq_rel2) && (ty1 `eqType` ty2)+       _ -> pprPanic "mkSkolReporter" (ppr ct1 $$ ppr ct2)++cmp_loc :: Ct -> Ct -> Ordering+cmp_loc ct1 ct2 = ctLocSpan (ctLoc ct1) `compare` ctLocSpan (ctLoc ct2)++reportGroup :: (ReportErrCtxt -> [Ct] -> TcM ErrMsg) -> ReportErrCtxt+            -> [Ct] -> TcM ()+reportGroup mk_err ctxt cts =+  case partition isMonadFailInstanceMissing cts of+        -- Only warn about missing MonadFail constraint when+        -- there are no other missing constraints!+        (monadFailCts, []) ->+            do { err <- mk_err ctxt monadFailCts+               ; reportWarning (Reason Opt_WarnMissingMonadFailInstances) err }++        (_, cts') -> do { err <- mk_err ctxt cts'+                        ; traceTc "About to maybeReportErr" $+                          vcat [ text "Constraint:"             <+> ppr cts'+                               , text "cec_suppress ="          <+> ppr (cec_suppress ctxt)+                               , text "cec_defer_type_errors =" <+> ppr (cec_defer_type_errors ctxt) ]+                        ; maybeReportError ctxt err+                            -- But see Note [Always warn with -fdefer-type-errors]+                        ; traceTc "reportGroup" (ppr cts')+                        ; mapM_ (addDeferredBinding ctxt err) cts' }+                            -- Add deferred bindings for all+                            -- Redundant if we are going to abort compilation,+                            -- but that's hard to know for sure, and if we don't+                            -- abort, we need bindings for all (e.g. #12156)+  where+    isMonadFailInstanceMissing ct =+        case ctLocOrigin (ctLoc ct) of+            FailablePattern _pat -> True+            _otherwise           -> False++maybeReportHoleError :: ReportErrCtxt -> Ct -> ErrMsg -> TcM ()+-- Unlike maybeReportError, these "hole" errors are+-- /not/ suppressed by cec_suppress.  We want to see them!+maybeReportHoleError ctxt ct err+  -- When -XPartialTypeSignatures is on, warnings (instead of errors) are+  -- generated for holes in partial type signatures.+  -- Unless -fwarn-partial-type-signatures is not on,+  -- in which case the messages are discarded.+  | isTypeHoleCt ct+  = -- For partial type signatures, generate warnings only, and do that+    -- only if -fwarn-partial-type-signatures is on+    case cec_type_holes ctxt of+       HoleError -> reportError err+       HoleWarn  -> reportWarning (Reason Opt_WarnPartialTypeSignatures) err+       HoleDefer -> return ()++  -- Always report an error for out-of-scope variables+  -- Unless -fdefer-out-of-scope-variables is on,+  -- in which case the messages are discarded.+  -- See #12170, #12406+  | isOutOfScopeCt ct+  = -- If deferring, report a warning only if -Wout-of-scope-variables is on+    case cec_out_of_scope_holes ctxt of+      HoleError -> reportError err+      HoleWarn  ->+        reportWarning (Reason Opt_WarnDeferredOutOfScopeVariables) err+      HoleDefer -> return ()++  -- Otherwise this is a typed hole in an expression,+  -- but not for an out-of-scope variable+  | otherwise+  = -- If deferring, report a warning only if -Wtyped-holes is on+    case cec_expr_holes ctxt of+       HoleError -> reportError err+       HoleWarn  -> reportWarning (Reason Opt_WarnTypedHoles) err+       HoleDefer -> return ()++maybeReportError :: ReportErrCtxt -> ErrMsg -> TcM ()+-- Report the error and/or make a deferred binding for it+maybeReportError ctxt err+  | cec_suppress ctxt    -- Some worse error has occurred;+  = return ()            -- so suppress this error/warning++  | otherwise+  = case cec_defer_type_errors ctxt of+      TypeDefer       -> return ()+      TypeWarn reason -> reportWarning reason err+      TypeError       -> reportError err++addDeferredBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()+-- See Note [Deferring coercion errors to runtime]+addDeferredBinding ctxt err ct+  | deferringAnyBindings ctxt+  , CtWanted { ctev_pred = pred, ctev_dest = dest } <- ctEvidence ct+    -- Only add deferred bindings for Wanted constraints+  = do { dflags <- getDynFlags+       ; let err_msg = pprLocErrMsg err+             err_fs  = mkFastString $ showSDoc dflags $+                       err_msg $$ text "(deferred type error)"+             err_tm  = evDelayedError pred err_fs+             ev_binds_var = cec_binds ctxt++       ; case dest of+           EvVarDest evar+             -> addTcEvBind ev_binds_var $ mkWantedEvBind evar err_tm+           HoleDest hole+             -> do { -- See Note [Deferred errors for coercion holes]+                     let co_var = coHoleCoVar hole+                   ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm+                   ; fillCoercionHole hole (mkTcCoVarCo co_var) }}++  | otherwise   -- Do not set any evidence for Given/Derived+  = return ()++maybeAddDeferredHoleBinding :: ReportErrCtxt -> ErrMsg -> Ct -> TcM ()+maybeAddDeferredHoleBinding ctxt err ct+  | isExprHoleCt ct+  = addDeferredBinding ctxt err ct  -- Only add bindings for holes in expressions+  | otherwise                       -- not for holes in partial type signatures+  = return ()++tryReporters :: ReportErrCtxt -> [ReporterSpec] -> [Ct] -> TcM (ReportErrCtxt, [Ct])+-- Use the first reporter in the list whose predicate says True+tryReporters ctxt reporters cts+  = do { let (vis_cts, invis_cts) = partition (isVisibleOrigin . ctOrigin) cts+       ; traceTc "tryReporters {" (ppr vis_cts $$ ppr invis_cts)+       ; (ctxt', cts') <- go ctxt reporters vis_cts invis_cts+       ; traceTc "tryReporters }" (ppr cts')+       ; return (ctxt', cts') }+  where+    go ctxt [] vis_cts invis_cts+      = return (ctxt, vis_cts ++ invis_cts)++    go ctxt (r : rs) vis_cts invis_cts+       -- always look at *visible* Origins before invisible ones+       -- this is the whole point of isVisibleOrigin+      = do { (ctxt', vis_cts') <- tryReporter ctxt r vis_cts+           ; (ctxt'', invis_cts') <- tryReporter ctxt' r invis_cts+           ; go ctxt'' rs vis_cts' invis_cts' }+                -- Carry on with the rest, because we must make+                -- deferred bindings for them if we have -fdefer-type-errors+                -- But suppress their error messages++tryReporter :: ReportErrCtxt -> ReporterSpec -> [Ct] -> TcM (ReportErrCtxt, [Ct])+tryReporter ctxt (str, keep_me,  suppress_after, reporter) cts+  | null yeses+  = return (ctxt, cts)+  | otherwise+  = do { traceTc "tryReporter{ " (text str <+> ppr yeses)+       ; (_, no_errs) <- askNoErrs (reporter ctxt yeses)+       ; let suppress_now = not no_errs && suppress_after+                            -- See Note [Suppressing error messages]+             ctxt' = ctxt { cec_suppress = suppress_now || cec_suppress ctxt }+       ; traceTc "tryReporter end }" (text str <+> ppr (cec_suppress ctxt) <+> ppr suppress_after)+       ; return (ctxt', nos) }+  where+    (yeses, nos) = partition (\ct -> keep_me ct (classifyPredType (ctPred ct))) cts+++pprArising :: CtOrigin -> SDoc+-- Used for the main, top-level error message+-- We've done special processing for TypeEq, KindEq, Given+pprArising (TypeEqOrigin {}) = empty+pprArising (KindEqOrigin {}) = empty+pprArising (GivenOrigin {})  = empty+pprArising orig              = pprCtOrigin orig++-- Add the "arising from..." part to a message about bunch of dicts+addArising :: CtOrigin -> SDoc -> SDoc+addArising orig msg = hang msg 2 (pprArising orig)++pprWithArising :: [Ct] -> (CtLoc, SDoc)+-- Print something like+--    (Eq a) arising from a use of x at y+--    (Show a) arising from a use of p at q+-- Also return a location for the error message+-- Works for Wanted/Derived only+pprWithArising []+  = panic "pprWithArising"+pprWithArising (ct:cts)+  | null cts+  = (loc, addArising (ctLocOrigin loc)+                     (pprTheta [ctPred ct]))+  | otherwise+  = (loc, vcat (map ppr_one (ct:cts)))+  where+    loc = ctLoc ct+    ppr_one ct' = hang (parens (pprType (ctPred ct')))+                     2 (pprCtLoc (ctLoc ct'))++mkErrorMsgFromCt :: ReportErrCtxt -> Ct -> Report -> TcM ErrMsg+mkErrorMsgFromCt ctxt ct report+  = mkErrorReport ctxt (ctLocEnv (ctLoc ct)) report++mkErrorReport :: ReportErrCtxt -> TcLclEnv -> Report -> TcM ErrMsg+mkErrorReport ctxt tcl_env (Report important relevant_bindings valid_subs)+  = do { context <- mkErrInfo (cec_tidy ctxt) (tcl_ctxt tcl_env)+       ; mkErrDocAt (RealSrcSpan (tcl_loc tcl_env))+            (errDoc important [context] (relevant_bindings ++ valid_subs))+       }++type UserGiven = Implication++getUserGivens :: ReportErrCtxt -> [UserGiven]+-- One item for each enclosing implication+getUserGivens (CEC {cec_encl = implics}) = getUserGivensFromImplics implics++getUserGivensFromImplics :: [Implication] -> [UserGiven]+getUserGivensFromImplics implics+  = reverse (filterOut (null . ic_given) implics)++{- Note [Always warn with -fdefer-type-errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When -fdefer-type-errors is on we warn about *all* type errors, even+if cec_suppress is on.  This can lead to a lot more warnings than you+would get errors without -fdefer-type-errors, but if we suppress any of+them you might get a runtime error that wasn't warned about at compile+time.++This is an easy design choice to change; just flip the order of the+first two equations for maybeReportError++To be consistent, we should also report multiple warnings from a single+location in mkGroupReporter, when -fdefer-type-errors is on.  But that+is perhaps a bit *over*-consistent! Again, an easy choice to change.++With #10283, you can now opt out of deferred type error warnings.++Note [Deferred errors for coercion holes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we need to defer a type error where the destination for the evidence+is a coercion hole. We can't just put the error in the hole, because we can't+make an erroneous coercion. (Remember that coercions are erased for runtime.)+Instead, we invent a new EvVar, bind it to an error and then make a coercion+from that EvVar, filling the hole with that coercion. Because coercions'+types are unlifted, the error is guaranteed to be hit before we get to the+coercion.++Note [Do not report derived but soluble errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The wc_simples include Derived constraints that have not been solved,+but are not insoluble (in that case they'd be reported by 'report1').+We do not want to report these as errors:++* Superclass constraints. If we have an unsolved [W] Ord a, we'll also have+  an unsolved [D] Eq a, and we do not want to report that; it's just noise.++* Functional dependencies.  For givens, consider+      class C a b | a -> b+      data T a where+         MkT :: C a d => [d] -> T a+      f :: C a b => T a -> F Int+      f (MkT xs) = length xs+  Then we get a [D] b~d.  But there *is* a legitimate call to+  f, namely   f (MkT [True]) :: T Bool, in which b=d.  So we should+  not reject the program.++  For wanteds, something similar+      data T a where+        MkT :: C Int b => a -> b -> T a+      g :: C Int c => c -> ()+      f :: T a -> ()+      f (MkT x y) = g x+  Here we get [G] C Int b, [W] C Int a, hence [D] a~b.+  But again f (MkT True True) is a legitimate call.++(We leave the Deriveds in wc_simple until reportErrors, so that we don't lose+derived superclasses between iterations of the solver.)++For functional dependencies, here is a real example,+stripped off from libraries/utf8-string/Codec/Binary/UTF8/Generic.hs++  class C a b | a -> b+  g :: C a b => a -> b -> ()+  f :: C a b => a -> b -> ()+  f xa xb =+      let loop = g xa+      in loop xb++We will first try to infer a type for loop, and we will succeed:+    C a b' => b' -> ()+Subsequently, we will type check (loop xb) and all is good. But,+recall that we have to solve a final implication constraint:+    C a b => (C a b' => .... cts from body of loop .... ))+And now we have a problem as we will generate an equality b ~ b' and fail to+solve it.+++************************************************************************+*                                                                      *+                Irreducible predicate errors+*                                                                      *+************************************************************************+-}++mkIrredErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg+mkIrredErr ctxt cts+  = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1+       ; let orig = ctOrigin ct1+             msg  = couldNotDeduce (getUserGivens ctxt) (map ctPred cts, orig)+       ; mkErrorMsgFromCt ctxt ct1 $+            important msg `mappend` relevant_bindings binds_msg }+  where+    (ct1:_) = cts++----------------+mkHoleError :: [Ct] -> ReportErrCtxt -> Ct -> TcM ErrMsg+mkHoleError _ _ ct@(CHoleCan { cc_hole = ExprHole (OutOfScope occ rdr_env0) })+  -- Out-of-scope variables, like 'a', where 'a' isn't bound; suggest possible+  -- in-scope variables in the message, and note inaccessible exact matches+  = do { dflags   <- getDynFlags+       ; imp_info <- getImports+       ; curr_mod <- getModule+       ; hpt <- getHpt+       ; let suggs_msg = unknownNameSuggestions dflags hpt curr_mod rdr_env0+                                                (tcl_rdr lcl_env) imp_info rdr+       ; rdr_env     <- getGlobalRdrEnv+       ; splice_locs <- getTopLevelSpliceLocs+       ; let match_msgs = mk_match_msgs rdr_env splice_locs+       ; mkErrDocAt (RealSrcSpan err_loc) $+                    errDoc [out_of_scope_msg] [] (match_msgs ++ [suggs_msg]) }++  where+    rdr         = mkRdrUnqual occ+    ct_loc      = ctLoc ct+    lcl_env     = ctLocEnv ct_loc+    err_loc     = tcl_loc lcl_env+    hole_ty     = ctEvPred (ctEvidence ct)+    boring_type = isTyVarTy hole_ty++    out_of_scope_msg -- Print v :: ty only if the type has structure+      | boring_type = hang herald 2 (ppr occ)+      | otherwise   = hang herald 2 (pp_with_type occ hole_ty)++    herald | isDataOcc occ = text "Data constructor not in scope:"+           | otherwise     = text "Variable not in scope:"++    -- Indicate if the out-of-scope variable exactly (and unambiguously) matches+    -- a top-level binding in a later inter-splice group; see Note [OutOfScope+    -- exact matches]+    mk_match_msgs rdr_env splice_locs+      = let gres = filter isLocalGRE (lookupGlobalRdrEnv rdr_env occ)+        in case gres of+             [gre]+               |  RealSrcSpan bind_loc <- greSrcSpan gre+                  -- Find splice between the unbound variable and the match; use+                  -- lookupLE, not lookupLT, since match could be in the splice+               ,  Just th_loc <- Set.lookupLE bind_loc splice_locs+               ,  err_loc < th_loc+               -> [mk_bind_scope_msg bind_loc th_loc]+             _ -> []++    mk_bind_scope_msg bind_loc th_loc+      | is_th_bind+      = hang (quotes (ppr occ) <+> parens (text "splice on" <+> th_rng))+           2 (text "is not in scope before line" <+> int th_start_ln)+      | otherwise+      = hang (quotes (ppr occ) <+> bind_rng <+> text "is not in scope")+           2 (text "before the splice on" <+> th_rng)+      where+        bind_rng = parens (text "line" <+> int bind_ln)+        th_rng+          | th_start_ln == th_end_ln = single+          | otherwise                = multi+        single = text "line"  <+> int th_start_ln+        multi  = text "lines" <+> int th_start_ln <> text "-" <> int th_end_ln+        bind_ln     = srcSpanStartLine bind_loc+        th_start_ln = srcSpanStartLine th_loc+        th_end_ln   = srcSpanEndLine   th_loc+        is_th_bind = th_loc `containsSpan` bind_loc++mkHoleError tidy_simples ctxt ct@(CHoleCan { cc_hole = hole })+  -- Explicit holes, like "_" or "_f"+  = do { (ctxt, binds_msg, ct) <- relevantBindings False ctxt ct+               -- The 'False' means "don't filter the bindings"; see #8191++       ; show_hole_constraints <- goptM Opt_ShowHoleConstraints+       ; let constraints_msg+               | isExprHoleCt ct, show_hole_constraints+                  = givenConstraintsMsg ctxt+               | otherwise = empty++       ; show_valid_hole_fits <- goptM Opt_ShowValidHoleFits+       ; (ctxt, sub_msg) <- if show_valid_hole_fits+                            then validHoleFits ctxt tidy_simples ct+                            else return (ctxt, empty)+       ; mkErrorMsgFromCt ctxt ct $+            important hole_msg `mappend`+            relevant_bindings (binds_msg $$ constraints_msg) `mappend`+            valid_hole_fits sub_msg}++  where+    occ       = holeOcc hole+    hole_ty   = ctEvPred (ctEvidence ct)+    hole_kind = tcTypeKind hole_ty+    tyvars    = tyCoVarsOfTypeList hole_ty++    hole_msg = case hole of+      ExprHole {} -> vcat [ hang (text "Found hole:")+                               2 (pp_with_type occ hole_ty)+                          , tyvars_msg, expr_hole_hint ]+      TypeHole {} -> vcat [ hang (text "Found type wildcard" <+>+                                  quotes (ppr occ))+                               2 (text "standing for" <+>+                                  quotes pp_hole_type_with_kind)+                          , tyvars_msg, type_hole_hint ]++    pp_hole_type_with_kind+      | isLiftedTypeKind hole_kind+        || isCoVarType hole_ty -- Don't print the kind of unlifted+                               -- equalities (#15039)+      = pprType hole_ty+      | otherwise+      = pprType hole_ty <+> dcolon <+> pprKind hole_kind++    tyvars_msg = ppUnless (null tyvars) $+                 text "Where:" <+> (vcat (map loc_msg other_tvs)+                                    $$ pprSkols ctxt skol_tvs)+       where+         (skol_tvs, other_tvs) = partition is_skol tyvars+         is_skol tv = isTcTyVar tv && isSkolemTyVar tv+                      -- Coercion variables can be free in the+                      -- hole, via kind casts++    type_hole_hint+         | HoleError <- cec_type_holes ctxt+         = text "To use the inferred type, enable PartialTypeSignatures"+         | otherwise+         = empty++    expr_hole_hint                       -- Give hint for, say,   f x = _x+         | lengthFS (occNameFS occ) > 1  -- Don't give this hint for plain "_"+         = text "Or perhaps" <+> quotes (ppr occ)+           <+> text "is mis-spelled, or not in scope"+         | otherwise+         = empty++    loc_msg tv+       | isTyVar tv+       = case tcTyVarDetails tv of+           MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable"+           _         -> empty  -- Skolems dealt with already+       | otherwise  -- A coercion variable can be free in the hole type+       = sdocWithDynFlags $ \dflags ->+         if gopt Opt_PrintExplicitCoercions dflags+         then quotes (ppr tv) <+> text "is a coercion variable"+         else empty++mkHoleError _ _ ct = pprPanic "mkHoleError" (ppr ct)++-- We unwrap the ReportErrCtxt here, to avoid introducing a loop in module+-- imports+validHoleFits :: ReportErrCtxt -- The context we're in, i.e. the+                                        -- implications and the tidy environment+                       -> [Ct]          -- Unsolved simple constraints+                       -> Ct            -- The hole constraint.+                       -> TcM (ReportErrCtxt, SDoc) -- We return the new context+                                                    -- with a possibly updated+                                                    -- tidy environment, and+                                                    -- the message.+validHoleFits ctxt@(CEC {cec_encl = implics+                             , cec_tidy = lcl_env}) simps ct+  = do { (tidy_env, msg) <- findValidHoleFits lcl_env implics simps ct+       ; return (ctxt {cec_tidy = tidy_env}, msg) }++-- See Note [Constraints include ...]+givenConstraintsMsg :: ReportErrCtxt -> SDoc+givenConstraintsMsg ctxt =+    let constraints :: [(Type, RealSrcSpan)]+        constraints =+          do { implic@Implic{ ic_given = given } <- cec_encl ctxt+             ; constraint <- given+             ; return (varType constraint, tcl_loc (implicLclEnv implic)) }++        pprConstraint (constraint, loc) =+          ppr constraint <+> nest 2 (parens (text "from" <+> ppr loc))++    in ppUnless (null constraints) $+         hang (text "Constraints include")+            2 (vcat $ map pprConstraint constraints)++pp_with_type :: OccName -> Type -> SDoc+pp_with_type occ ty = hang (pprPrefixOcc occ) 2 (dcolon <+> pprType ty)++----------------+mkIPErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg+mkIPErr ctxt cts+  = do { (ctxt, binds_msg, ct1) <- relevantBindings True ctxt ct1+       ; let orig    = ctOrigin ct1+             preds   = map ctPred cts+             givens  = getUserGivens ctxt+             msg | null givens+                 = addArising orig $+                   sep [ text "Unbound implicit parameter" <> plural cts+                       , nest 2 (pprParendTheta preds) ]+                 | otherwise+                 = couldNotDeduce givens (preds, orig)++       ; mkErrorMsgFromCt ctxt ct1 $+            important msg `mappend` relevant_bindings binds_msg }+  where+    (ct1:_) = cts++{-++Note [Constraints include ...]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'givenConstraintsMsg' returns the "Constraints include ..." message enabled by+-fshow-hole-constraints. For example, the following hole:++    foo :: (Eq a, Show a) => a -> String+    foo x = _++would generate the message:++    Constraints include+      Eq a (from foo.hs:1:1-36)+      Show a (from foo.hs:1:1-36)++Constraints are displayed in order from innermost (closest to the hole) to+outermost. There's currently no filtering or elimination of duplicates.+++Note [OutOfScope exact matches]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When constructing an out-of-scope error message, we not only generate a list of+possible in-scope alternatives but also search for an exact, unambiguous match+in a later inter-splice group.  If we find such a match, we report its presence+(and indirectly, its scope) in the message.  For example, if a module A contains+the following declarations,++   foo :: Int+   foo = x++   $(return [])  -- Empty top-level splice++   x :: Int+   x = 23++we will issue an error similar to++   A.hs:6:7: error:+       • Variable not in scope: x :: Int+       • ‘x’ (line 11) is not in scope before the splice on line 8++By providing information about the match, we hope to clarify why declaring a+variable after a top-level splice but using it before the splice generates an+out-of-scope error (a situation which is often confusing to Haskell newcomers).++Note that if we find multiple exact matches to the out-of-scope variable+(hereafter referred to as x), we report nothing.  Such matches can only be+duplicate record fields, as the presence of any other duplicate top-level+declarations would have already halted compilation.  But if these record fields+are declared in a later inter-splice group, then so too are their corresponding+types.  Thus, these types must not occur in the inter-splice group containing x+(any unknown types would have already been reported), and so the matches to the+record fields are most likely coincidental.++One oddity of the exact match portion of the error message is that we specify+where the match to x is NOT in scope.  Why not simply state where the match IS+in scope?  It most cases, this would be just as easy and perhaps a little+clearer for the user.  But now consider the following example:++    {-# LANGUAGE TemplateHaskell #-}++    module A where++    import Language.Haskell.TH+    import Language.Haskell.TH.Syntax++    foo = x++    $(do -------------------------------------------------+        ds <- [d| ok1 = x+                |]+        addTopDecls ds+        return [])++    bar = $(do+            ds <- [d| x = 23+                      ok2 = x+                    |]+            addTopDecls ds+            litE $ stringL "hello")++    $(return []) -----------------------------------------++    ok3 = x++Here, x is out-of-scope in the declaration of foo, and so we report++    A.hs:8:7: error:+        • Variable not in scope: x+        • ‘x’ (line 16) is not in scope before the splice on lines 10-14++If we instead reported where x IS in scope, we would have to state that it is in+scope after the second top-level splice as well as among all the top-level+declarations added by both calls to addTopDecls.  But doing so would not only+add complexity to the code but also overwhelm the user with unneeded+information.++The logic which determines where x is not in scope is straightforward: it simply+finds the last top-level splice which occurs after x but before (or at) the+match to x (assuming such a splice exists).  In most cases, the check that the+splice occurs after x acts only as a sanity check.  For example, when the match+to x is a non-TH top-level declaration and a splice S occurs before the match,+then x must precede S; otherwise, it would be in scope.  But when dealing with+addTopDecls, this check serves a practical purpose.  Consider the following+declarations:++    $(do+        ds <- [d| ok = x+                  x = 23+                |]+        addTopDecls ds+        return [])++    foo = x++In this case, x is not in scope in the declaration for foo.  Since x occurs+AFTER the splice containing the match, the logic does not find any splices after+x but before or at its match, and so we report nothing about x's scope.  If we+had not checked whether x occurs before the splice, we would have instead+reported that x is not in scope before the splice.  While correct, such an error+message is more likely to confuse than to enlighten.+-}++{-+************************************************************************+*                                                                      *+                Equality errors+*                                                                      *+************************************************************************++Note [Inaccessible code]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   data T a where+     T1 :: T a+     T2 :: T Bool++   f :: (a ~ Int) => T a -> Int+   f T1 = 3+   f T2 = 4   -- Unreachable code++Here the second equation is unreachable. The original constraint+(a~Int) from the signature gets rewritten by the pattern-match to+(Bool~Int), so the danger is that we report the error as coming from+the *signature* (#7293).  So, for Given errors we replace the+env (and hence src-loc) on its CtLoc with that from the immediately+enclosing implication.++Note [Error messages for untouchables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#9109)+  data G a where { GBool :: G Bool }+  foo x = case x of GBool -> True++Here we can't solve (t ~ Bool), where t is the untouchable result+meta-var 't', because of the (a ~ Bool) from the pattern match.+So we infer the type+   f :: forall a t. G a -> t+making the meta-var 't' into a skolem.  So when we come to report+the unsolved (t ~ Bool), t won't look like an untouchable meta-var+any more.  So we don't assert that it is.+-}++-- Don't have multiple equality errors from the same location+-- E.g.   (Int,Bool) ~ (Bool,Int)   one error will do!+mkEqErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg+mkEqErr ctxt (ct:_) = mkEqErr1 ctxt ct+mkEqErr _ [] = panic "mkEqErr"++mkEqErr1 :: ReportErrCtxt -> Ct -> TcM ErrMsg+mkEqErr1 ctxt ct   -- Wanted or derived;+                   -- givens handled in mkGivenErrorReporter+  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct+       ; rdr_env <- getGlobalRdrEnv+       ; fam_envs <- tcGetFamInstEnvs+       ; exp_syns <- goptM Opt_PrintExpandedSynonyms+       ; let (keep_going, is_oriented, wanted_msg)+                           = mk_wanted_extra (ctLoc ct) exp_syns+             coercible_msg = case ctEqRel ct of+               NomEq  -> empty+               ReprEq -> mkCoercibleExplanation rdr_env fam_envs ty1 ty2+       ; dflags <- getDynFlags+       ; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctOrigin ct) $$ ppr keep_going)+       ; let report = mconcat [important wanted_msg, important coercible_msg,+                               relevant_bindings binds_msg]+       ; if keep_going+         then mkEqErr_help dflags ctxt report ct is_oriented ty1 ty2+         else mkErrorMsgFromCt ctxt ct report }+  where+    (ty1, ty2) = getEqPredTys (ctPred ct)++       -- If the types in the error message are the same as the types+       -- we are unifying, don't add the extra expected/actual message+    mk_wanted_extra :: CtLoc -> Bool -> (Bool, Maybe SwapFlag, SDoc)+    mk_wanted_extra loc expandSyns+      = case ctLocOrigin loc of+          orig@TypeEqOrigin {} -> mkExpectedActualMsg ty1 ty2 orig+                                                      t_or_k expandSyns+            where+              t_or_k = ctLocTypeOrKind_maybe loc++          KindEqOrigin cty1 mb_cty2 sub_o sub_t_or_k+            -> (True, Nothing, msg1 $$ msg2)+            where+              sub_what = case sub_t_or_k of Just KindLevel -> text "kinds"+                                            _              -> text "types"+              msg1 = sdocWithDynFlags $ \dflags ->+                     case mb_cty2 of+                       Just cty2+                         |  gopt Opt_PrintExplicitCoercions dflags+                         || not (cty1 `pickyEqType` cty2)+                         -> hang (text "When matching" <+> sub_what)+                               2 (vcat [ ppr cty1 <+> dcolon <+>+                                         ppr (tcTypeKind cty1)+                                       , ppr cty2 <+> dcolon <+>+                                         ppr (tcTypeKind cty2) ])+                       _ -> text "When matching the kind of" <+> quotes (ppr cty1)+              msg2 = case sub_o of+                       TypeEqOrigin {}+                         | Just cty2 <- mb_cty2 ->+                         thdOf3 (mkExpectedActualMsg cty1 cty2 sub_o sub_t_or_k+                                                     expandSyns)+                       _ -> empty+          _ -> (True, Nothing, empty)++-- | This function tries to reconstruct why a "Coercible ty1 ty2" constraint+-- is left over.+mkCoercibleExplanation :: GlobalRdrEnv -> FamInstEnvs+                       -> TcType -> TcType -> SDoc+mkCoercibleExplanation rdr_env fam_envs ty1 ty2+  | Just (tc, tys) <- tcSplitTyConApp_maybe ty1+  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys+  , Just msg <- coercible_msg_for_tycon rep_tc+  = msg+  | Just (tc, tys) <- splitTyConApp_maybe ty2+  , (rep_tc, _, _) <- tcLookupDataFamInst fam_envs tc tys+  , Just msg <- coercible_msg_for_tycon rep_tc+  = msg+  | Just (s1, _) <- tcSplitAppTy_maybe ty1+  , Just (s2, _) <- tcSplitAppTy_maybe ty2+  , s1 `eqType` s2+  , has_unknown_roles s1+  = hang (text "NB: We cannot know what roles the parameters to" <+>+          quotes (ppr s1) <+> text "have;")+       2 (text "we must assume that the role is nominal")+  | otherwise+  = empty+  where+    coercible_msg_for_tycon tc+        | isAbstractTyCon tc+        = Just $ hsep [ text "NB: The type constructor"+                      , quotes (pprSourceTyCon tc)+                      , text "is abstract" ]+        | isNewTyCon tc+        , [data_con] <- tyConDataCons tc+        , let dc_name = dataConName data_con+        , isNothing (lookupGRE_Name rdr_env dc_name)+        = Just $ hang (text "The data constructor" <+> quotes (ppr dc_name))+                    2 (sep [ text "of newtype" <+> quotes (pprSourceTyCon tc)+                           , text "is not in scope" ])+        | otherwise = Nothing++    has_unknown_roles ty+      | Just (tc, tys) <- tcSplitTyConApp_maybe ty+      = tys `lengthAtLeast` tyConArity tc  -- oversaturated tycon+      | Just (s, _) <- tcSplitAppTy_maybe ty+      = has_unknown_roles s+      | isTyVarTy ty+      = True+      | otherwise+      = False++{-+-- | Make a listing of role signatures for all the parameterised tycons+-- used in the provided types+++-- SLPJ Jun 15: I could not convince myself that these hints were really+-- useful.  Maybe they are, but I think we need more work to make them+-- actually helpful.+mkRoleSigs :: Type -> Type -> SDoc+mkRoleSigs ty1 ty2+  = ppUnless (null role_sigs) $+    hang (text "Relevant role signatures:")+       2 (vcat role_sigs)+  where+    tcs = nameEnvElts $ tyConsOfType ty1 `plusNameEnv` tyConsOfType ty2+    role_sigs = mapMaybe ppr_role_sig tcs++    ppr_role_sig tc+      | null roles  -- if there are no parameters, don't bother printing+      = Nothing+      | isBuiltInSyntax (tyConName tc)  -- don't print roles for (->), etc.+      = Nothing+      | otherwise+      = Just $ hsep $ [text "type role", ppr tc] ++ map ppr roles+      where+        roles = tyConRoles tc+-}++mkEqErr_help :: DynFlags -> ReportErrCtxt -> Report+             -> Ct+             -> Maybe SwapFlag   -- Nothing <=> not sure+             -> TcType -> TcType -> TcM ErrMsg+mkEqErr_help dflags ctxt report ct oriented ty1 ty2+  | Just (tv1, co1) <- tcGetCastedTyVar_maybe ty1+  = mkTyVarEqErr dflags ctxt report ct oriented tv1 co1 ty2+  | Just (tv2, co2) <- tcGetCastedTyVar_maybe ty2+  = mkTyVarEqErr dflags ctxt report ct swapped  tv2 co2 ty1+  | otherwise+  = reportEqErr ctxt report ct oriented ty1 ty2+  where+    swapped = fmap flipSwap oriented++reportEqErr :: ReportErrCtxt -> Report+            -> Ct+            -> Maybe SwapFlag   -- Nothing <=> not sure+            -> TcType -> TcType -> TcM ErrMsg+reportEqErr ctxt report ct oriented ty1 ty2+  = mkErrorMsgFromCt ctxt ct (mconcat [misMatch, report, eqInfo])+  where misMatch = important $ misMatchOrCND ctxt ct oriented ty1 ty2+        eqInfo = important $ mkEqInfoMsg ct ty1 ty2++mkTyVarEqErr, mkTyVarEqErr'+  :: DynFlags -> ReportErrCtxt -> Report -> Ct+             -> Maybe SwapFlag -> TcTyVar -> TcCoercionN -> TcType -> TcM ErrMsg+-- tv1 and ty2 are already tidied+mkTyVarEqErr dflags ctxt report ct oriented tv1 co1 ty2+  = do { traceTc "mkTyVarEqErr" (ppr ct $$ ppr tv1 $$ ppr co1 $$ ppr ty2)+       ; mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2 }++mkTyVarEqErr' dflags ctxt report ct oriented tv1 co1 ty2+  | not insoluble_occurs_check   -- See Note [Occurs check wins]+  , isUserSkolem ctxt tv1   -- ty2 won't be a meta-tyvar, or else the thing would+                            -- be oriented the other way round;+                            -- see TcCanonical.canEqTyVarTyVar+    || isTyVarTyVar tv1 && not (isTyVarTy ty2)+    || ctEqRel ct == ReprEq+     -- the cases below don't really apply to ReprEq (except occurs check)+  = mkErrorMsgFromCt ctxt ct $ mconcat+        [ important $ misMatchOrCND ctxt ct oriented ty1 ty2+        , important $ extraTyVarEqInfo ctxt tv1 ty2+        , report+        ]++  | MTVU_Occurs <- occ_check_expand+    -- We report an "occurs check" even for  a ~ F t a, where F is a type+    -- function; it's not insoluble (because in principle F could reduce)+    -- but we have certainly been unable to solve it+    -- See Note [Occurs check error] in TcCanonical+  = do { let main_msg = addArising (ctOrigin ct) $+                        hang (text "Occurs check: cannot construct the infinite" <+> what <> colon)+                              2 (sep [ppr ty1, char '~', ppr ty2])++             extra2 = important $ mkEqInfoMsg ct ty1 ty2++             interesting_tyvars = filter (not . noFreeVarsOfType . tyVarKind) $+                                  filter isTyVar $+                                  fvVarList $+                                  tyCoFVsOfType ty1 `unionFV` tyCoFVsOfType ty2+             extra3 = relevant_bindings $+                      ppWhen (not (null interesting_tyvars)) $+                      hang (text "Type variable kinds:") 2 $+                      vcat (map (tyvar_binding . tidyTyCoVarOcc (cec_tidy ctxt))+                                interesting_tyvars)++             tyvar_binding tv = ppr tv <+> dcolon <+> ppr (tyVarKind tv)+       ; mkErrorMsgFromCt ctxt ct $+         mconcat [important main_msg, extra2, extra3, report] }++  | MTVU_Bad <- occ_check_expand+  = do { let msg = vcat [ text "Cannot instantiate unification variable"+                          <+> quotes (ppr tv1)+                        , hang (text "with a" <+> what <+> text "involving polytypes:") 2 (ppr ty2)+                        , nest 2 (text "GHC doesn't yet support impredicative polymorphism") ]+       -- Unlike the other reports, this discards the old 'report_important'+       -- instead of augmenting it.  This is because the details are not likely+       -- to be helpful since this is just an unimplemented feature.+       ; mkErrorMsgFromCt ctxt ct $ report { report_important = [msg] } }++   -- check for heterogeneous equality next; see Note [Equalities with incompatible kinds]+   -- in TcCanonical+  | not (k1 `tcEqType` k2)+  = do { let main_msg = addArising (ctOrigin ct) $+                        vcat [ hang (text "Kind mismatch: cannot unify" <+>+                                     parens (ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)) <+>+                                     text "with:")+                                  2 (sep [ppr ty2, dcolon, ppr k2])+                             , text "Their kinds differ." ]+             cast_msg+               | isTcReflexiveCo co1 = empty+               | otherwise           = text "NB:" <+> ppr tv1 <+>+                                       text "was casted to have kind" <+>+                                       quotes (ppr k1)++       ; mkErrorMsgFromCt ctxt ct (mconcat [important main_msg, important cast_msg, report]) }++  -- If the immediately-enclosing implication has 'tv' a skolem, and+  -- we know by now its an InferSkol kind of skolem, then presumably+  -- it started life as a TyVarTv, else it'd have been unified, given+  -- that there's no occurs-check or forall problem+  | (implic:_) <- cec_encl ctxt+  , Implic { ic_skols = skols } <- implic+  , tv1 `elem` skols+  = mkErrorMsgFromCt ctxt ct $ mconcat+        [ important $ misMatchMsg ct oriented ty1 ty2+        , important $ extraTyVarEqInfo ctxt tv1 ty2+        , report+        ]++  -- Check for skolem escape+  | (implic:_) <- cec_encl ctxt   -- Get the innermost context+  , Implic { ic_skols = skols, ic_info = skol_info } <- implic+  , let esc_skols = filter (`elemVarSet` (tyCoVarsOfType ty2)) skols+  , not (null esc_skols)+  = do { let msg = important $ misMatchMsg ct oriented ty1 ty2+             esc_doc = sep [ text "because" <+> what <+> text "variable" <> plural esc_skols+                             <+> pprQuotedList esc_skols+                           , text "would escape" <+>+                             if isSingleton esc_skols then text "its scope"+                                                      else text "their scope" ]+             tv_extra = important $+                        vcat [ nest 2 $ esc_doc+                             , sep [ (if isSingleton esc_skols+                                      then text "This (rigid, skolem)" <+>+                                           what <+> text "variable is"+                                      else text "These (rigid, skolem)" <+>+                                           what <+> text "variables are")+                               <+> text "bound by"+                             , nest 2 $ ppr skol_info+                             , nest 2 $ text "at" <+>+                               ppr (tcl_loc (implicLclEnv implic)) ] ]+       ; mkErrorMsgFromCt ctxt ct (mconcat [msg, tv_extra, report]) }++  -- Nastiest case: attempt to unify an untouchable variable+  -- So tv is a meta tyvar (or started that way before we+  -- generalised it).  So presumably it is an *untouchable*+  -- meta tyvar or a TyVarTv, else it'd have been unified+  -- See Note [Error messages for untouchables]+  | (implic:_) <- cec_encl ctxt   -- Get the innermost context+  , Implic { ic_given = given, ic_tclvl = lvl, ic_info = skol_info } <- implic+  = ASSERT2( not (isTouchableMetaTyVar lvl tv1)+           , ppr tv1 $$ ppr lvl )  -- See Note [Error messages for untouchables]+    do { let msg = important $ misMatchMsg ct oriented ty1 ty2+             tclvl_extra = important $+                  nest 2 $+                  sep [ quotes (ppr tv1) <+> text "is untouchable"+                      , nest 2 $ text "inside the constraints:" <+> pprEvVarTheta given+                      , nest 2 $ text "bound by" <+> ppr skol_info+                      , nest 2 $ text "at" <+>+                        ppr (tcl_loc (implicLclEnv implic)) ]+             tv_extra = important $ extraTyVarEqInfo ctxt tv1 ty2+             add_sig  = important $ suggestAddSig ctxt ty1 ty2+       ; mkErrorMsgFromCt ctxt ct $ mconcat+            [msg, tclvl_extra, tv_extra, add_sig, report] }++  | otherwise+  = reportEqErr ctxt report ct oriented (mkTyVarTy tv1) ty2+        -- This *can* happen (#6123, and test T2627b)+        -- Consider an ambiguous top-level constraint (a ~ F a)+        -- Not an occurs check, because F is a type function.+  where+    Pair _ k1 = tcCoercionKind co1+    k2        = tcTypeKind ty2++    ty1 = mkTyVarTy tv1+    occ_check_expand       = occCheckForErrors dflags tv1 ty2+    insoluble_occurs_check = isInsolubleOccursCheck (ctEqRel ct) tv1 ty2++    what = case ctLocTypeOrKind_maybe (ctLoc ct) of+      Just KindLevel -> text "kind"+      _              -> text "type"++mkEqInfoMsg :: Ct -> TcType -> TcType -> SDoc+-- Report (a) ambiguity if either side is a type function application+--            e.g. F a0 ~ Int+--        (b) warning about injectivity if both sides are the same+--            type function application   F a ~ F b+--            See Note [Non-injective type functions]+mkEqInfoMsg ct ty1 ty2+  = tyfun_msg $$ ambig_msg+  where+    mb_fun1 = isTyFun_maybe ty1+    mb_fun2 = isTyFun_maybe ty2++    ambig_msg | isJust mb_fun1 || isJust mb_fun2+              = snd (mkAmbigMsg False ct)+              | otherwise = empty++    tyfun_msg | Just tc1 <- mb_fun1+              , Just tc2 <- mb_fun2+              , tc1 == tc2+              , not (isInjectiveTyCon tc1 Nominal)+              = text "NB:" <+> quotes (ppr tc1)+                <+> text "is a non-injective type family"+              | otherwise = empty++isUserSkolem :: ReportErrCtxt -> TcTyVar -> Bool+-- See Note [Reporting occurs-check errors]+isUserSkolem ctxt tv+  = isSkolemTyVar tv && any is_user_skol_tv (cec_encl ctxt)+  where+    is_user_skol_tv (Implic { ic_skols = sks, ic_info = skol_info })+      = tv `elem` sks && is_user_skol_info skol_info++    is_user_skol_info (InferSkol {}) = False+    is_user_skol_info _ = True++misMatchOrCND :: ReportErrCtxt -> Ct+              -> Maybe SwapFlag -> TcType -> TcType -> SDoc+-- If oriented then ty1 is actual, ty2 is expected+misMatchOrCND ctxt ct oriented ty1 ty2+  | null givens ||+    (isRigidTy ty1 && isRigidTy ty2) ||+    isGivenCt ct+       -- If the equality is unconditionally insoluble+       -- or there is no context, don't report the context+  = misMatchMsg ct oriented ty1 ty2+  | otherwise+  = couldNotDeduce givens ([eq_pred], orig)+  where+    ev      = ctEvidence ct+    eq_pred = ctEvPred ev+    orig    = ctEvOrigin ev+    givens  = [ given | given <- getUserGivens ctxt, not (ic_no_eqs given)]+              -- Keep only UserGivens that have some equalities.+              -- See Note [Suppress redundant givens during error reporting]++couldNotDeduce :: [UserGiven] -> (ThetaType, CtOrigin) -> SDoc+couldNotDeduce givens (wanteds, orig)+  = vcat [ addArising orig (text "Could not deduce:" <+> pprTheta wanteds)+         , vcat (pp_givens givens)]++pp_givens :: [UserGiven] -> [SDoc]+pp_givens givens+   = case givens of+         []     -> []+         (g:gs) ->      ppr_given (text "from the context:") g+                 : map (ppr_given (text "or from:")) gs+    where+       ppr_given herald implic@(Implic { ic_given = gs, ic_info = skol_info })+           = hang (herald <+> pprEvVarTheta (mkMinimalBySCs evVarPred gs))+             -- See Note [Suppress redundant givens during error reporting]+             -- for why we use mkMinimalBySCs above.+                2 (sep [ text "bound by" <+> ppr skol_info+                       , text "at" <+> ppr (tcl_loc (implicLclEnv implic)) ])++{-+Note [Suppress redundant givens during error reporting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When GHC is unable to solve a constraint and prints out an error message, it+will print out what given constraints are in scope to provide some context to+the programmer. But we shouldn't print out /every/ given, since some of them+are not terribly helpful to diagnose type errors. Consider this example:++  foo :: Int :~: Int -> a :~: b -> a :~: c+  foo Refl Refl = Refl++When reporting that GHC can't solve (a ~ c), there are two givens in scope:+(Int ~ Int) and (a ~ b). But (Int ~ Int) is trivially soluble (i.e.,+redundant), so it's not terribly useful to report it in an error message.+To accomplish this, we discard any Implications that do not bind any+equalities by filtering the `givens` selected in `misMatchOrCND` (based on+the `ic_no_eqs` field of the Implication).++But this is not enough to avoid all redundant givens! Consider this example,+from #15361:++  goo :: forall (a :: Type) (b :: Type) (c :: Type).+         a :~~: b -> a :~~: c+  goo HRefl = HRefl++Matching on HRefl brings the /single/ given (* ~ *, a ~ b) into scope.+The (* ~ *) part arises due the kinds of (:~~:) being unified. More+importantly, (* ~ *) is redundant, so we'd like not to report it. However,+the Implication (* ~ *, a ~ b) /does/ bind an equality (as reported by its+ic_no_eqs field), so the test above will keep it wholesale.++To refine this given, we apply mkMinimalBySCs on it to extract just the (a ~ b)+part. This works because mkMinimalBySCs eliminates reflexive equalities in+addition to superclasses (see Note [Remove redundant provided dicts]+in TcPatSyn).+-}++extraTyVarEqInfo :: ReportErrCtxt -> TcTyVar -> TcType -> SDoc+-- Add on extra info about skolem constants+-- NB: The types themselves are already tidied+extraTyVarEqInfo ctxt tv1 ty2+  = extraTyVarInfo ctxt tv1 $$ ty_extra ty2+  where+    ty_extra ty = case tcGetTyVar_maybe ty of+                    Just tv -> extraTyVarInfo ctxt tv+                    Nothing -> empty++extraTyVarInfo :: ReportErrCtxt -> TcTyVar -> SDoc+extraTyVarInfo ctxt tv+  = ASSERT2( isTyVar tv, ppr tv )+    case tcTyVarDetails tv of+          SkolemTv {}   -> pprSkols ctxt [tv]+          RuntimeUnk {} -> quotes (ppr tv) <+> text "is an interactive-debugger skolem"+          MetaTv {}     -> empty++suggestAddSig :: ReportErrCtxt -> TcType -> TcType -> SDoc+-- See Note [Suggest adding a type signature]+suggestAddSig ctxt ty1 ty2+  | null inferred_bndrs+  = empty+  | [bndr] <- inferred_bndrs+  = text "Possible fix: add a type signature for" <+> quotes (ppr bndr)+  | otherwise+  = text "Possible fix: add type signatures for some or all of" <+> (ppr inferred_bndrs)+  where+    inferred_bndrs = nub (get_inf ty1 ++ get_inf ty2)+    get_inf ty | Just tv <- tcGetTyVar_maybe ty+               , isSkolemTyVar tv+               , (implic, _) : _ <- getSkolemInfo (cec_encl ctxt) [tv]+               , InferSkol prs <- ic_info implic+               = map fst prs+               | otherwise+               = []++--------------------+misMatchMsg :: Ct -> Maybe SwapFlag -> TcType -> TcType -> SDoc+-- Types are already tidy+-- If oriented then ty1 is actual, ty2 is expected+misMatchMsg ct oriented ty1 ty2+  | Just NotSwapped <- oriented+  = misMatchMsg ct (Just IsSwapped) ty2 ty1++  -- These next two cases are when we're about to report, e.g., that+  -- 'LiftedRep doesn't match 'VoidRep. Much better just to say+  -- lifted vs. unlifted+  | isLiftedRuntimeRep ty1+  = lifted_vs_unlifted++  | isLiftedRuntimeRep ty2+  = lifted_vs_unlifted++  | otherwise  -- So now we have Nothing or (Just IsSwapped)+               -- For some reason we treat Nothing like IsSwapped+  = addArising orig $+    pprWithExplicitKindsWhenMismatch ty1 ty2 (ctOrigin ct) $+    sep [ text herald1 <+> quotes (ppr ty1)+        , nest padding $+          text herald2 <+> quotes (ppr ty2)+        , sameOccExtra ty2 ty1 ]+  where+    herald1 = conc [ "Couldn't match"+                   , if is_repr     then "representation of" else ""+                   , if is_oriented then "expected"          else ""+                   , what ]+    herald2 = conc [ "with"+                   , if is_repr     then "that of"           else ""+                   , if is_oriented then ("actual " ++ what) else "" ]+    padding = length herald1 - length herald2++    is_repr = case ctEqRel ct of { ReprEq -> True; NomEq -> False }+    is_oriented = isJust oriented++    orig = ctOrigin ct+    what = case ctLocTypeOrKind_maybe (ctLoc ct) of+      Just KindLevel -> "kind"+      _              -> "type"++    conc :: [String] -> String+    conc = foldr1 add_space++    add_space :: String -> String -> String+    add_space s1 s2 | null s1   = s2+                    | null s2   = s1+                    | otherwise = s1 ++ (' ' : s2)++    lifted_vs_unlifted+      = addArising orig $+        text "Couldn't match a lifted type with an unlifted type"++-- | Prints explicit kinds (with @-fprint-explicit-kinds@) in an 'SDoc' when a+-- type mismatch occurs to due invisible kind arguments.+--+-- This function first checks to see if the 'CtOrigin' argument is a+-- 'TypeEqOrigin', and if so, uses the expected/actual types from that to+-- check for a kind mismatch (as these types typically have more surrounding+-- types and are likelier to be able to glean information about whether a+-- mismatch occurred in an invisible argument position or not). If the+-- 'CtOrigin' is not a 'TypeEqOrigin', fall back on the actual mismatched types+-- themselves.+pprWithExplicitKindsWhenMismatch :: Type -> Type -> CtOrigin+                                 -> SDoc -> SDoc+pprWithExplicitKindsWhenMismatch ty1 ty2 ct+  = pprWithExplicitKindsWhen show_kinds+  where+    (act_ty, exp_ty) = case ct of+      TypeEqOrigin { uo_actual = act+                   , uo_expected = exp } -> (act, exp)+      _                                  -> (ty1, ty2)+    show_kinds = tcEqTypeVis act_ty exp_ty+                 -- True when the visible bit of the types look the same,+                 -- so we want to show the kinds in the displayed type++mkExpectedActualMsg :: Type -> Type -> CtOrigin -> Maybe TypeOrKind -> Bool+                    -> (Bool, Maybe SwapFlag, SDoc)+-- NotSwapped means (actual, expected), IsSwapped is the reverse+-- First return val is whether or not to print a herald above this msg+mkExpectedActualMsg ty1 ty2 ct@(TypeEqOrigin { uo_actual = act+                                             , uo_expected = exp+                                             , uo_thing = maybe_thing })+                    m_level printExpanded+  | KindLevel <- level, occurs_check_error       = (True, Nothing, empty)+  | isUnliftedTypeKind act, isLiftedTypeKind exp = (False, Nothing, msg2)+  | isLiftedTypeKind act, isUnliftedTypeKind exp = (False, Nothing, msg3)+  | tcIsLiftedTypeKind exp                       = (False, Nothing, msg4)+  | Just msg <- num_args_msg                     = (False, Nothing, msg $$ msg1)+  | KindLevel <- level, Just th <- maybe_thing   = (False, Nothing, msg5 th)+  | act `pickyEqType` ty1, exp `pickyEqType` ty2 = (True, Just NotSwapped, empty)+  | exp `pickyEqType` ty1, act `pickyEqType` ty2 = (True, Just IsSwapped, empty)+  | otherwise                                    = (True, Nothing, msg1)+  where+    level = m_level `orElse` TypeLevel++    occurs_check_error+      | Just act_tv <- tcGetTyVar_maybe act+      , act_tv `elemVarSet` tyCoVarsOfType exp+      = True+      | Just exp_tv <- tcGetTyVar_maybe exp+      , exp_tv `elemVarSet` tyCoVarsOfType act+      = True+      | otherwise+      = False++    sort = case level of+      TypeLevel -> text "type"+      KindLevel -> text "kind"++    msg1 = case level of+      KindLevel+        | Just th <- maybe_thing+        -> msg5 th++      _ | not (act `pickyEqType` exp)+        -> pprWithExplicitKindsWhenMismatch ty1 ty2 ct $+           vcat [ text "Expected" <+> sort <> colon <+> ppr exp+                , text "  Actual" <+> sort <> colon <+> ppr act+                , if printExpanded then expandedTys else empty ]++        | otherwise+        -> empty++    thing_msg = case maybe_thing of+                  Just thing -> \_ -> quotes thing <+> text "is"+                  Nothing    -> \vowel -> text "got a" <>+                                          if vowel then char 'n' else empty+    msg2 = sep [ text "Expecting a lifted type, but"+               , thing_msg True, text "unlifted" ]+    msg3 = sep [ text "Expecting an unlifted type, but"+               , thing_msg False, text "lifted" ]+    msg4 = maybe_num_args_msg $$+           sep [ text "Expected a type, but"+               , maybe (text "found something with kind")+                       (\thing -> quotes thing <+> text "has kind")+                       maybe_thing+               , quotes (pprWithTYPE act) ]++    msg5 th = pprWithExplicitKindsWhenMismatch ty1 ty2 ct $+              hang (text "Expected" <+> kind_desc <> comma)+                 2 (text "but" <+> quotes th <+> text "has kind" <+>+                    quotes (ppr act))+      where+        kind_desc | tcIsConstraintKind exp = text "a constraint"++                    -- TYPE t0+                  | Just arg <- kindRep_maybe exp+                  , tcIsTyVarTy arg = sdocWithDynFlags $ \dflags ->+                                      if gopt Opt_PrintExplicitRuntimeReps dflags+                                      then text "kind" <+> quotes (ppr exp)+                                      else text "a type"++                  | otherwise       = text "kind" <+> quotes (ppr exp)++    num_args_msg = case level of+      KindLevel+        | not (isMetaTyVarTy exp) && not (isMetaTyVarTy act)+           -- if one is a meta-tyvar, then it's possible that the user+           -- has asked for something impredicative, and we couldn't unify.+           -- Don't bother with counting arguments.+        -> let n_act = count_args act+               n_exp = count_args exp in+           case n_act - n_exp of+             n | n > 0   -- we don't know how many args there are, so don't+                         -- recommend removing args that aren't+               , Just thing <- maybe_thing+               -> Just $ text "Expecting" <+> speakN (abs n) <+>+                         more <+> quotes thing+               where+                 more+                  | n == 1    = text "more argument to"+                  | otherwise = text "more arguments to"  -- n > 1+             _ -> Nothing++      _ -> Nothing++    maybe_num_args_msg = case num_args_msg of+      Nothing -> empty+      Just m  -> m++    count_args ty = count isVisibleBinder $ fst $ splitPiTys ty++    expandedTys =+      ppUnless (expTy1 `pickyEqType` exp && expTy2 `pickyEqType` act) $ vcat+        [ text "Type synonyms expanded:"+        , text "Expected type:" <+> ppr expTy1+        , text "  Actual type:" <+> ppr expTy2+        ]++    (expTy1, expTy2) = expandSynonymsToMatch exp act++mkExpectedActualMsg _ _ _ _ _ = panic "mkExpectedAcutalMsg"++{- Note [Insoluble occurs check wins]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider [G] a ~ [a],  [W] a ~ [a] (#13674).  The Given is insoluble+so we don't use it for rewriting.  The Wanted is also insoluble, and+we don't solve it from the Given.  It's very confusing to say+    Cannot solve a ~ [a] from given constraints a ~ [a]++And indeed even thinking about the Givens is silly; [W] a ~ [a] is+just as insoluble as Int ~ Bool.++Conclusion: if there's an insoluble occurs check (isInsolubleOccursCheck)+then report it first.++(NB: there are potentially-soluble ones, like (a ~ F a b), and we don't+want to be as draconian with them.)++Note [Expanding type synonyms to make types similar]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In type error messages, if -fprint-expanded-types is used, we want to expand+type synonyms to make expected and found types as similar as possible, but we+shouldn't expand types too much to make type messages even more verbose and+harder to understand. The whole point here is to make the difference in expected+and found types clearer.++`expandSynonymsToMatch` does this, it takes two types, and expands type synonyms+only as much as necessary. Given two types t1 and t2:++  * If they're already same, it just returns the types.++  * If they're in form `C1 t1_1 .. t1_n` and `C2 t2_1 .. t2_m` (C1 and C2 are+    type constructors), it expands C1 and C2 if they're different type synonyms.+    Then it recursively does the same thing on expanded types. If C1 and C2 are+    same, then it applies the same procedure to arguments of C1 and arguments of+    C2 to make them as similar as possible.++    Most important thing here is to keep number of synonym expansions at+    minimum. For example, if t1 is `T (T3, T5, Int)` and t2 is `T (T5, T3,+    Bool)` where T5 = T4, T4 = T3, ..., T1 = X, it returns `T (T3, T3, Int)` and+    `T (T3, T3, Bool)`.++  * Otherwise types don't have same shapes and so the difference is clearly+    visible. It doesn't do any expansions and show these types.++Note that we only expand top-layer type synonyms. Only when top-layer+constructors are the same we start expanding inner type synonyms.++Suppose top-layer type synonyms of t1 and t2 can expand N and M times,+respectively. If their type-synonym-expanded forms will meet at some point (i.e.+will have same shapes according to `sameShapes` function), it's possible to find+where they meet in O(N+M) top-layer type synonym expansions and O(min(N,M))+comparisons. We first collect all the top-layer expansions of t1 and t2 in two+lists, then drop the prefix of the longer list so that they have same lengths.+Then we search through both lists in parallel, and return the first pair of+types that have same shapes. Inner types of these two types with same shapes+are then expanded using the same algorithm.++In case they don't meet, we return the last pair of types in the lists, which+has top-layer type synonyms completely expanded. (in this case the inner types+are not expanded at all, as the current form already shows the type error)+-}++-- | Expand type synonyms in given types only enough to make them as similar as+-- possible. Returned types are the same in terms of used type synonyms.+--+-- To expand all synonyms, see 'Type.expandTypeSynonyms'.+--+-- See `ExpandSynsFail` tests in tests testsuite/tests/typecheck/should_fail for+-- some examples of how this should work.+expandSynonymsToMatch :: Type -> Type -> (Type, Type)+expandSynonymsToMatch ty1 ty2 = (ty1_ret, ty2_ret)+  where+    (ty1_ret, ty2_ret) = go ty1 ty2++    -- | Returns (type synonym expanded version of first type,+    --            type synonym expanded version of second type)+    go :: Type -> Type -> (Type, Type)+    go t1 t2+      | t1 `pickyEqType` t2 =+        -- Types are same, nothing to do+        (t1, t2)++    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      | tc1 == tc2 =+        -- Type constructors are same. They may be synonyms, but we don't+        -- expand further.+        let (tys1', tys2') =+              unzip (zipWith (\ty1 ty2 -> go ty1 ty2) tys1 tys2)+         in (TyConApp tc1 tys1', TyConApp tc2 tys2')++    go (AppTy t1_1 t1_2) (AppTy t2_1 t2_2) =+      let (t1_1', t2_1') = go t1_1 t2_1+          (t1_2', t2_2') = go t1_2 t2_2+       in (mkAppTy t1_1' t1_2', mkAppTy t2_1' t2_2')++    go ty1@(FunTy _ t1_1 t1_2) ty2@(FunTy _ t2_1 t2_2) =+      let (t1_1', t2_1') = go t1_1 t2_1+          (t1_2', t2_2') = go t1_2 t2_2+       in ( ty1 { ft_arg = t1_1', ft_res = t1_2' }+          , ty2 { ft_arg = t2_1', ft_res = t2_2' })++    go (ForAllTy b1 t1) (ForAllTy b2 t2) =+      -- NOTE: We may have a bug here, but we just can't reproduce it easily.+      -- See D1016 comments for details and our attempts at producing a test+      -- case. Short version: We probably need RnEnv2 to really get this right.+      let (t1', t2') = go t1 t2+       in (ForAllTy b1 t1', ForAllTy b2 t2')++    go (CastTy ty1 _) ty2 = go ty1 ty2+    go ty1 (CastTy ty2 _) = go ty1 ty2++    go t1 t2 =+      -- See Note [Expanding type synonyms to make types similar] for how this+      -- works+      let+        t1_exp_tys = t1 : tyExpansions t1+        t2_exp_tys = t2 : tyExpansions t2+        t1_exps    = length t1_exp_tys+        t2_exps    = length t2_exp_tys+        dif        = abs (t1_exps - t2_exps)+      in+        followExpansions $+          zipEqual "expandSynonymsToMatch.go"+            (if t1_exps > t2_exps then drop dif t1_exp_tys else t1_exp_tys)+            (if t2_exps > t1_exps then drop dif t2_exp_tys else t2_exp_tys)++    -- | Expand the top layer type synonyms repeatedly, collect expansions in a+    -- list. The list does not include the original type.+    --+    -- Example, if you have:+    --+    --   type T10 = T9+    --   type T9  = T8+    --   ...+    --   type T0  = Int+    --+    -- `tyExpansions T10` returns [T9, T8, T7, ... Int]+    --+    -- This only expands the top layer, so if you have:+    --+    --   type M a = Maybe a+    --+    -- `tyExpansions (M T10)` returns [Maybe T10] (T10 is not expanded)+    tyExpansions :: Type -> [Type]+    tyExpansions = unfoldr (\t -> (\x -> (x, x)) `fmap` tcView t)++    -- | Drop the type pairs until types in a pair look alike (i.e. the outer+    -- constructors are the same).+    followExpansions :: [(Type, Type)] -> (Type, Type)+    followExpansions [] = pprPanic "followExpansions" empty+    followExpansions [(t1, t2)]+      | sameShapes t1 t2 = go t1 t2 -- expand subtrees+      | otherwise        = (t1, t2) -- the difference is already visible+    followExpansions ((t1, t2) : tss)+      -- Traverse subtrees when the outer shapes are the same+      | sameShapes t1 t2 = go t1 t2+      -- Otherwise follow the expansions until they look alike+      | otherwise = followExpansions tss++    sameShapes :: Type -> Type -> Bool+    sameShapes AppTy{}          AppTy{}          = True+    sameShapes (TyConApp tc1 _) (TyConApp tc2 _) = tc1 == tc2+    sameShapes (FunTy {})       (FunTy {})       = True+    sameShapes (ForAllTy {})    (ForAllTy {})    = True+    sameShapes (CastTy ty1 _)   ty2              = sameShapes ty1 ty2+    sameShapes ty1              (CastTy ty2 _)   = sameShapes ty1 ty2+    sameShapes _                _                = False++sameOccExtra :: TcType -> TcType -> SDoc+-- See Note [Disambiguating (X ~ X) errors]+sameOccExtra ty1 ty2+  | Just (tc1, _) <- tcSplitTyConApp_maybe ty1+  , Just (tc2, _) <- tcSplitTyConApp_maybe ty2+  , let n1 = tyConName tc1+        n2 = tyConName tc2+        same_occ = nameOccName n1                   == nameOccName n2+        same_pkg = moduleUnitId (nameModule n1) == moduleUnitId (nameModule n2)+  , n1 /= n2   -- Different Names+  , same_occ   -- but same OccName+  = text "NB:" <+> (ppr_from same_pkg n1 $$ ppr_from same_pkg n2)+  | otherwise+  = empty+  where+    ppr_from same_pkg nm+      | isGoodSrcSpan loc+      = hang (quotes (ppr nm) <+> text "is defined at")+           2 (ppr loc)+      | otherwise  -- Imported things have an UnhelpfulSrcSpan+      = hang (quotes (ppr nm))+           2 (sep [ text "is defined in" <+> quotes (ppr (moduleName mod))+                  , ppUnless (same_pkg || pkg == mainUnitId) $+                    nest 4 $ text "in package" <+> quotes (ppr pkg) ])+       where+         pkg = moduleUnitId mod+         mod = nameModule nm+         loc = nameSrcSpan nm++{-+Note [Suggest adding a type signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The OutsideIn algorithm rejects GADT programs that don't have a principal+type, and indeed some that do.  Example:+   data T a where+     MkT :: Int -> T Int++   f (MkT n) = n++Does this have type f :: T a -> a, or f :: T a -> Int?+The error that shows up tends to be an attempt to unify an+untouchable type variable.  So suggestAddSig sees if the offending+type variable is bound by an *inferred* signature, and suggests+adding a declared signature instead.++This initially came up in #8968, concerning pattern synonyms.++Note [Disambiguating (X ~ X) errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See #8278++Note [Reporting occurs-check errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given (a ~ [a]), if 'a' is a rigid type variable bound by a user-supplied+type signature, then the best thing is to report that we can't unify+a with [a], because a is a skolem variable.  That avoids the confusing+"occur-check" error message.++But nowadays when inferring the type of a function with no type signature,+even if there are errors inside, we still generalise its signature and+carry on. For example+   f x = x:x+Here we will infer something like+   f :: forall a. a -> [a]+with a deferred error of (a ~ [a]).  So in the deferred unsolved constraint+'a' is now a skolem, but not one bound by the programmer in the context!+Here we really should report an occurs check.++So isUserSkolem distinguishes the two.++Note [Non-injective type functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very confusing to get a message like+     Couldn't match expected type `Depend s'+            against inferred type `Depend s1'+so mkTyFunInfoMsg adds:+       NB: `Depend' is type function, and hence may not be injective++Warn of loopy local equalities that were dropped.+++************************************************************************+*                                                                      *+                 Type-class errors+*                                                                      *+************************************************************************+-}++mkDictErr :: ReportErrCtxt -> [Ct] -> TcM ErrMsg+mkDictErr ctxt cts+  = ASSERT( not (null cts) )+    do { inst_envs <- tcGetInstEnvs+       ; let (ct1:_) = cts  -- ct1 just for its location+             min_cts = elim_superclasses cts+             lookups = map (lookup_cls_inst inst_envs) min_cts+             (no_inst_cts, overlap_cts) = partition is_no_inst lookups++       -- Report definite no-instance errors,+       -- or (iff there are none) overlap errors+       -- But we report only one of them (hence 'head') because they all+       -- have the same source-location origin, to try avoid a cascade+       -- of error from one location+       ; (ctxt, err) <- mk_dict_err ctxt (head (no_inst_cts ++ overlap_cts))+       ; mkErrorMsgFromCt ctxt ct1 (important err) }+  where+    no_givens = null (getUserGivens ctxt)++    is_no_inst (ct, (matches, unifiers, _))+      =  no_givens+      && null matches+      && (null unifiers || all (not . isAmbiguousTyVar) (tyCoVarsOfCtList ct))++    lookup_cls_inst inst_envs ct+                -- Note [Flattening in error message generation]+      = (ct, lookupInstEnv True inst_envs clas (flattenTys emptyInScopeSet tys))+      where+        (clas, tys) = getClassPredTys (ctPred ct)+++    -- When simplifying [W] Ord (Set a), we need+    --    [W] Eq a, [W] Ord a+    -- but we really only want to report the latter+    elim_superclasses cts = mkMinimalBySCs ctPred cts++mk_dict_err :: ReportErrCtxt -> (Ct, ClsInstLookupResult)+            -> TcM (ReportErrCtxt, SDoc)+-- Report an overlap error if this class constraint results+-- from an overlap (returning Left clas), otherwise return (Right pred)+mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_overlapped))+  | null matches  -- No matches but perhaps several unifiers+  = do { (ctxt, binds_msg, ct) <- relevantBindings True ctxt ct+       ; candidate_insts <- get_candidate_instances+       ; return (ctxt, cannot_resolve_msg ct candidate_insts binds_msg) }++  | null unsafe_overlapped   -- Some matches => overlap errors+  = return (ctxt, overlap_msg)++  | otherwise+  = return (ctxt, safe_haskell_msg)+  where+    orig          = ctOrigin ct+    pred          = ctPred ct+    (clas, tys)   = getClassPredTys pred+    ispecs        = [ispec | (ispec, _) <- matches]+    unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]+    useful_givens = discardProvCtxtGivens orig (getUserGivensFromImplics implics)+         -- useful_givens are the enclosing implications with non-empty givens,+         -- modulo the horrid discardProvCtxtGivens++    get_candidate_instances :: TcM [ClsInst]+    -- See Note [Report candidate instances]+    get_candidate_instances+      | [ty] <- tys   -- Only try for single-parameter classes+      = do { instEnvs <- tcGetInstEnvs+           ; return (filter (is_candidate_inst ty)+                            (classInstances instEnvs clas)) }+      | otherwise = return []++    is_candidate_inst ty inst -- See Note [Report candidate instances]+      | [other_ty] <- is_tys inst+      , Just (tc1, _) <- tcSplitTyConApp_maybe ty+      , Just (tc2, _) <- tcSplitTyConApp_maybe other_ty+      = let n1 = tyConName tc1+            n2 = tyConName tc2+            different_names = n1 /= n2+            same_occ_names = nameOccName n1 == nameOccName n2+        in different_names && same_occ_names+      | otherwise = False++    cannot_resolve_msg :: Ct -> [ClsInst] -> SDoc -> SDoc+    cannot_resolve_msg ct candidate_insts binds_msg+      = vcat [ no_inst_msg+             , nest 2 extra_note+             , vcat (pp_givens useful_givens)+             , mb_patsyn_prov `orElse` empty+             , ppWhen (has_ambig_tvs && not (null unifiers && null useful_givens))+               (vcat [ ppUnless lead_with_ambig ambig_msg, binds_msg, potential_msg ])++             , ppWhen (isNothing mb_patsyn_prov) $+                   -- Don't suggest fixes for the provided context of a pattern+                   -- synonym; the right fix is to bind more in the pattern+               show_fixes (ctxtFixes has_ambig_tvs pred implics+                           ++ drv_fixes)+             , ppWhen (not (null candidate_insts))+               (hang (text "There are instances for similar types:")+                   2 (vcat (map ppr candidate_insts))) ]+                   -- See Note [Report candidate instances]+      where+        orig = ctOrigin ct+        -- See Note [Highlighting ambiguous type variables]+        lead_with_ambig = has_ambig_tvs && not (any isRuntimeUnkSkol ambig_tvs)+                        && not (null unifiers) && null useful_givens++        (has_ambig_tvs, ambig_msg) = mkAmbigMsg lead_with_ambig ct+        ambig_tvs = uncurry (++) (getAmbigTkvs ct)++        no_inst_msg+          | lead_with_ambig+          = ambig_msg <+> pprArising orig+              $$ text "prevents the constraint" <+>  quotes (pprParendType pred)+              <+> text "from being solved."++          | null useful_givens+          = addArising orig $ text "No instance for"+            <+> pprParendType pred++          | otherwise+          = addArising orig $ text "Could not deduce"+            <+> pprParendType pred++        potential_msg+          = ppWhen (not (null unifiers) && want_potential orig) $+            sdocWithDynFlags $ \dflags ->+            getPprStyle $ \sty ->+            pprPotentials dflags sty potential_hdr unifiers++        potential_hdr+          = vcat [ ppWhen lead_with_ambig $+                     text "Probable fix: use a type annotation to specify what"+                     <+> pprQuotedList ambig_tvs <+> text "should be."+                 , text "These potential instance" <> plural unifiers+                   <+> text "exist:"]++        mb_patsyn_prov :: Maybe SDoc+        mb_patsyn_prov+          | not lead_with_ambig+          , ProvCtxtOrigin PSB{ psb_def = (dL->L _ pat) } <- orig+          = Just (vcat [ text "In other words, a successful match on the pattern"+                       , nest 2 $ ppr pat+                       , text "does not provide the constraint" <+> pprParendType pred ])+          | otherwise = Nothing++    -- Report "potential instances" only when the constraint arises+    -- directly from the user's use of an overloaded function+    want_potential (TypeEqOrigin {}) = False+    want_potential _                 = True++    extra_note | any isFunTy (filterOutInvisibleTypes (classTyCon clas) tys)+               = text "(maybe you haven't applied a function to enough arguments?)"+               | className clas == typeableClassName  -- Avoid mysterious "No instance for (Typeable T)+               , [_,ty] <- tys                        -- Look for (Typeable (k->*) (T k))+               , Just (tc,_) <- tcSplitTyConApp_maybe ty+               , not (isTypeFamilyTyCon tc)+               = hang (text "GHC can't yet do polykinded")+                    2 (text "Typeable" <+>+                       parens (ppr ty <+> dcolon <+> ppr (tcTypeKind ty)))+               | otherwise+               = empty++    drv_fixes = case orig of+                   DerivClauseOrigin                  -> [drv_fix False]+                   StandAloneDerivOrigin              -> [drv_fix True]+                   DerivOriginDC _ _       standalone -> [drv_fix standalone]+                   DerivOriginCoerce _ _ _ standalone -> [drv_fix standalone]+                   _                -> []++    drv_fix standalone_wildcard+      | standalone_wildcard+      = text "fill in the wildcard constraint yourself"+      | otherwise+      = hang (text "use a standalone 'deriving instance' declaration,")+           2 (text "so you can specify the instance context yourself")++    -- Normal overlap error+    overlap_msg+      = ASSERT( not (null matches) )+        vcat [  addArising orig (text "Overlapping instances for"+                                <+> pprType (mkClassPred clas tys))++             ,  ppUnless (null matching_givens) $+                  sep [text "Matching givens (or their superclasses):"+                      , nest 2 (vcat matching_givens)]++             ,  sdocWithDynFlags $ \dflags ->+                getPprStyle $ \sty ->+                pprPotentials dflags sty (text "Matching instances:") $+                ispecs ++ unifiers++             ,  ppWhen (null matching_givens && isSingleton matches && null unifiers) $+                -- Intuitively, some given matched the wanted in their+                -- flattened or rewritten (from given equalities) form+                -- but the matcher can't figure that out because the+                -- constraints are non-flat and non-rewritten so we+                -- simply report back the whole given+                -- context. Accelerate Smart.hs showed this problem.+                  sep [ text "There exists a (perhaps superclass) match:"+                      , nest 2 (vcat (pp_givens useful_givens))]++             ,  ppWhen (isSingleton matches) $+                parens (vcat [ text "The choice depends on the instantiation of" <+>+                                  quotes (pprWithCommas ppr (tyCoVarsOfTypesList tys))+                             , ppWhen (null (matching_givens)) $+                               vcat [ text "To pick the first instance above, use IncoherentInstances"+                                    , text "when compiling the other instance declarations"]+                        ])]++    matching_givens = mapMaybe matchable useful_givens++    matchable implic@(Implic { ic_given = evvars, ic_info = skol_info })+      = case ev_vars_matching of+             [] -> Nothing+             _  -> Just $ hang (pprTheta ev_vars_matching)+                            2 (sep [ text "bound by" <+> ppr skol_info+                                   , text "at" <+>+                                     ppr (tcl_loc (implicLclEnv implic)) ])+        where ev_vars_matching = [ pred+                                 | ev_var <- evvars+                                 , let pred = evVarPred ev_var+                                 , any can_match (pred : transSuperClasses pred) ]+              can_match pred+                 = case getClassPredTys_maybe pred of+                     Just (clas', tys') -> clas' == clas+                                          && isJust (tcMatchTys tys tys')+                     Nothing -> False++    -- Overlap error because of Safe Haskell (first+    -- match should be the most specific match)+    safe_haskell_msg+     = ASSERT( matches `lengthIs` 1 && not (null unsafe_ispecs) )+       vcat [ addArising orig (text "Unsafe overlapping instances for"+                       <+> pprType (mkClassPred clas tys))+            , sep [text "The matching instance is:",+                   nest 2 (pprInstance $ head ispecs)]+            , vcat [ text "It is compiled in a Safe module and as such can only"+                   , text "overlap instances from the same module, however it"+                   , text "overlaps the following instances from different" <+>+                     text "modules:"+                   , nest 2 (vcat [pprInstances $ unsafe_ispecs])+                   ]+            ]+++ctxtFixes :: Bool -> PredType -> [Implication] -> [SDoc]+ctxtFixes has_ambig_tvs pred implics+  | not has_ambig_tvs+  , isTyVarClassPred pred+  , (skol:skols) <- usefulContext implics pred+  , let what | null skols+             , SigSkol (PatSynCtxt {}) _ _ <- skol+             = text "\"required\""+             | otherwise+             = empty+  = [sep [ text "add" <+> pprParendType pred+           <+> text "to the" <+> what <+> text "context of"+         , nest 2 $ ppr_skol skol $$+                    vcat [ text "or" <+> ppr_skol skol+                         | skol <- skols ] ] ]+  | otherwise = []+  where+    ppr_skol (PatSkol (RealDataCon dc) _) = text "the data constructor" <+> quotes (ppr dc)+    ppr_skol (PatSkol (PatSynCon ps)   _) = text "the pattern synonym"  <+> quotes (ppr ps)+    ppr_skol skol_info = ppr skol_info++discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven]+discardProvCtxtGivens orig givens  -- See Note [discardProvCtxtGivens]+  | ProvCtxtOrigin (PSB {psb_id = (dL->L _ name)}) <- orig+  = filterOut (discard name) givens+  | otherwise+  = givens+  where+    discard n (Implic { ic_info = SigSkol (PatSynCtxt n') _ _ }) = n == n'+    discard _ _                                                  = False++usefulContext :: [Implication] -> PredType -> [SkolemInfo]+-- usefulContext picks out the implications whose context+-- the programmer might plausibly augment to solve 'pred'+usefulContext implics pred+  = go implics+  where+    pred_tvs = tyCoVarsOfType pred+    go [] = []+    go (ic : ics)+       | implausible ic = rest+       | otherwise      = ic_info ic : rest+       where+          -- Stop when the context binds a variable free in the predicate+          rest | any (`elemVarSet` pred_tvs) (ic_skols ic) = []+               | otherwise                                 = go ics++    implausible ic+      | null (ic_skols ic)            = True+      | implausible_info (ic_info ic) = True+      | otherwise                     = False++    implausible_info (SigSkol (InfSigCtxt {}) _ _) = True+    implausible_info _                             = False+    -- Do not suggest adding constraints to an *inferred* type signature++{- Note [Report candidate instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have an unsolved (Num Int), where `Int` is not the Prelude Int,+but comes from some other module, then it may be helpful to point out+that there are some similarly named instances elsewhere.  So we get+something like+    No instance for (Num Int) arising from the literal ‘3’+    There are instances for similar types:+      instance Num GHC.Types.Int -- Defined in ‘GHC.Num’+Discussion in #9611.++Note [Highlighting ambiguous type variables]+~-------------------------------------------+When we encounter ambiguous type variables (i.e. type variables+that remain metavariables after type inference), we need a few more+conditions before we can reason that *ambiguity* prevents constraints+from being solved:+  - We can't have any givens, as encountering a typeclass error+    with given constraints just means we couldn't deduce+    a solution satisfying those constraints and as such couldn't+    bind the type variable to a known type.+  - If we don't have any unifiers, we don't even have potential+    instances from which an ambiguity could arise.+  - Lastly, I don't want to mess with error reporting for+    unknown runtime types so we just fall back to the old message there.+Once these conditions are satisfied, we can safely say that ambiguity prevents+the constraint from being solved.++Note [discardProvCtxtGivens]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+In most situations we call all enclosing implications "useful". There is one+exception, and that is when the constraint that causes the error is from the+"provided" context of a pattern synonym declaration:++  pattern Pat :: (Num a, Eq a) => Show a   => a -> Maybe a+             --  required      => provided => type+  pattern Pat x <- (Just x, 4)++When checking the pattern RHS we must check that it does actually bind all+the claimed "provided" constraints; in this case, does the pattern (Just x, 4)+bind the (Show a) constraint.  Answer: no!++But the implication we generate for this will look like+   forall a. (Num a, Eq a) => [W] Show a+because when checking the pattern we must make the required+constraints available, since they are needed to match the pattern (in+this case the literal '4' needs (Num a, Eq a)).++BUT we don't want to suggest adding (Show a) to the "required" constraints+of the pattern synonym, thus:+  pattern Pat :: (Num a, Eq a, Show a) => Show a => a -> Maybe a+It would then typecheck but it's silly.  We want the /pattern/ to bind+the alleged "provided" constraints, Show a.++So we suppress that Implication in discardProvCtxtGivens.  It's+painfully ad-hoc but the truth is that adding it to the "required"+constraints would work.  Suppressing it solves two problems.  First,+we never tell the user that we could not deduce a "provided"+constraint from the "required" context. Second, we never give a+possible fix that suggests to add a "provided" constraint to the+"required" context.++For example, without this distinction the above code gives a bad error+message (showing both problems):++  error: Could not deduce (Show a) ... from the context: (Eq a)+         ... Possible fix: add (Show a) to the context of+         the signature for pattern synonym `Pat' ...++-}++show_fixes :: [SDoc] -> SDoc+show_fixes []     = empty+show_fixes (f:fs) = sep [ text "Possible fix:"+                        , nest 2 (vcat (f : map (text "or" <+>) fs))]++pprPotentials :: DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc+-- See Note [Displaying potential instances]+pprPotentials dflags sty herald insts+  | null insts+  = empty++  | null show_these+  = hang herald+       2 (vcat [ not_in_scope_msg empty+               , flag_hint ])++  | otherwise+  = hang herald+       2 (vcat [ pprInstances show_these+               , ppWhen (n_in_scope_hidden > 0) $+                 text "...plus"+                   <+> speakNOf n_in_scope_hidden (text "other")+               , not_in_scope_msg (text "...plus")+               , flag_hint ])+  where+    n_show = 3 :: Int+    show_potentials = gopt Opt_PrintPotentialInstances dflags++    (in_scope, not_in_scope) = partition inst_in_scope insts+    sorted = sortBy fuzzyClsInstCmp in_scope+    show_these | show_potentials = sorted+               | otherwise       = take n_show sorted+    n_in_scope_hidden = length sorted - length show_these++       -- "in scope" means that all the type constructors+       -- are lexically in scope; these instances are likely+       -- to be more useful+    inst_in_scope :: ClsInst -> Bool+    inst_in_scope cls_inst = nameSetAll name_in_scope $+                             orphNamesOfTypes (is_tys cls_inst)++    name_in_scope name+      | isBuiltInSyntax name+      = True -- E.g. (->)+      | Just mod <- nameModule_maybe name+      = qual_in_scope (qualName sty mod (nameOccName name))+      | otherwise+      = True++    qual_in_scope :: QualifyName -> Bool+    qual_in_scope NameUnqual    = True+    qual_in_scope (NameQual {}) = True+    qual_in_scope _             = False++    not_in_scope_msg herald+      | null not_in_scope+      = empty+      | otherwise+      = hang (herald <+> speakNOf (length not_in_scope) (text "instance")+                     <+> text "involving out-of-scope types")+           2 (ppWhen show_potentials (pprInstances not_in_scope))++    flag_hint = ppUnless (show_potentials || equalLength show_these insts) $+                text "(use -fprint-potential-instances to see them all)"++{- Note [Displaying potential instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When showing a list of instances for+  - overlapping instances (show ones that match)+  - no such instance (show ones that could match)+we want to give it a bit of structure.  Here's the plan++* Say that an instance is "in scope" if all of the+  type constructors it mentions are lexically in scope.+  These are the ones most likely to be useful to the programmer.++* Show at most n_show in-scope instances,+  and summarise the rest ("plus 3 others")++* Summarise the not-in-scope instances ("plus 4 not in scope")++* Add the flag -fshow-potential-instances which replaces the+  summary with the full list+-}++{-+Note [Flattening in error message generation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (C (Maybe (F x))), where F is a type function, and we have+instances+                C (Maybe Int) and C (Maybe a)+Since (F x) might turn into Int, this is an overlap situation, and+indeed (because of flattening) the main solver will have refrained+from solving.  But by the time we get to error message generation, we've+un-flattened the constraint.  So we must *re*-flatten it before looking+up in the instance environment, lest we only report one matching+instance when in fact there are two.++Re-flattening is pretty easy, because we don't need to keep track of+evidence.  We don't re-use the code in TcCanonical because that's in+the TcS monad, and we are in TcM here.++Note [Kind arguments in error messages]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It can be terribly confusing to get an error message like (#9171)++    Couldn't match expected type ‘GetParam Base (GetParam Base Int)’+                with actual type ‘GetParam Base (GetParam Base Int)’++The reason may be that the kinds don't match up.  Typically you'll get+more useful information, but not when it's as a result of ambiguity.++To mitigate this, GHC attempts to enable the -fprint-explicit-kinds flag+whenever any error message arises due to a kind mismatch. This means that+the above error message would instead be displayed as:++    Couldn't match expected type+                  ‘GetParam @* @k2 @* Base (GetParam @* @* @k2 Base Int)’+                with actual type+                  ‘GetParam @* @k20 @* Base (GetParam @* @* @k20 Base Int)’++Which makes it clearer that the culprit is the mismatch between `k2` and `k20`.+-}++mkAmbigMsg :: Bool -- True when message has to be at beginning of sentence+           -> Ct -> (Bool, SDoc)+mkAmbigMsg prepend_msg ct+  | null ambig_kvs && null ambig_tvs = (False, empty)+  | otherwise                        = (True,  msg)+  where+    (ambig_kvs, ambig_tvs) = getAmbigTkvs ct++    msg |  any isRuntimeUnkSkol ambig_kvs  -- See Note [Runtime skolems]+        || any isRuntimeUnkSkol ambig_tvs+        = vcat [ text "Cannot resolve unknown runtime type"+                 <> plural ambig_tvs <+> pprQuotedList ambig_tvs+               , text "Use :print or :force to determine these types"]++        | not (null ambig_tvs)+        = pp_ambig (text "type") ambig_tvs++        | otherwise+        = pp_ambig (text "kind") ambig_kvs++    pp_ambig what tkvs+      | prepend_msg -- "Ambiguous type variable 't0'"+      = text "Ambiguous" <+> what <+> text "variable"+        <> plural tkvs <+> pprQuotedList tkvs++      | otherwise -- "The type variable 't0' is ambiguous"+      = text "The" <+> what <+> text "variable" <> plural tkvs+        <+> pprQuotedList tkvs <+> is_or_are tkvs <+> text "ambiguous"++    is_or_are [_] = text "is"+    is_or_are _   = text "are"++pprSkols :: ReportErrCtxt -> [TcTyVar] -> SDoc+pprSkols ctxt tvs+  = vcat (map pp_one (getSkolemInfo (cec_encl ctxt) tvs))+  where+    pp_one (Implic { ic_info = skol_info }, tvs)+      | UnkSkol <- skol_info+      = hang (pprQuotedList tvs)+           2 (is_or_are tvs "an" "unknown")+      | otherwise+      = vcat [ hang (pprQuotedList tvs)+                  2 (is_or_are tvs "a"  "rigid" <+> text "bound by")+             , nest 2 (pprSkolInfo skol_info)+             , nest 2 (text "at" <+> ppr (foldr1 combineSrcSpans (map getSrcSpan tvs))) ]++    is_or_are [_] article adjective = text "is" <+> text article <+> text adjective+                                      <+> text "type variable"+    is_or_are _   _       adjective = text "are" <+> text adjective+                                      <+> text "type variables"++getAmbigTkvs :: Ct -> ([Var],[Var])+getAmbigTkvs ct+  = partition (`elemVarSet` dep_tkv_set) ambig_tkvs+  where+    tkvs       = tyCoVarsOfCtList ct+    ambig_tkvs = filter isAmbiguousTyVar tkvs+    dep_tkv_set = tyCoVarsOfTypes (map tyVarKind tkvs)++getSkolemInfo :: [Implication] -> [TcTyVar]+              -> [(Implication, [TcTyVar])]+-- Get the skolem info for some type variables+-- from the implication constraints that bind them+--+-- In the returned (implic, tvs) pairs, the 'tvs' part is non-empty+getSkolemInfo _ []+  = []++getSkolemInfo [] tvs+  = pprPanic "No skolem info:" (ppr tvs)++getSkolemInfo (implic:implics) tvs+  | null tvs_here =                      getSkolemInfo implics tvs+  | otherwise     = (implic, tvs_here) : getSkolemInfo implics tvs_other+  where+    (tvs_here, tvs_other) = partition (`elem` ic_skols implic) tvs++-----------------------+-- relevantBindings looks at the value environment and finds values whose+-- types mention any of the offending type variables.  It has to be+-- careful to zonk the Id's type first, so it has to be in the monad.+-- We must be careful to pass it a zonked type variable, too.+--+-- We always remove closed top-level bindings, though,+-- since they are never relevant (cf #8233)++relevantBindings :: Bool  -- True <=> filter by tyvar; False <=> no filtering+                          -- See #8191+                 -> ReportErrCtxt -> Ct+                 -> TcM (ReportErrCtxt, SDoc, Ct)+-- Also returns the zonked and tidied CtOrigin of the constraint+relevantBindings want_filtering ctxt ct+  = do { dflags <- getDynFlags+       ; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)+       ; let ct_tvs = tyCoVarsOfCt ct `unionVarSet` extra_tvs++             -- For *kind* errors, report the relevant bindings of the+             -- enclosing *type* equality, because that's more useful for the programmer+             extra_tvs = case tidy_orig of+                             KindEqOrigin t1 m_t2 _ _ -> tyCoVarsOfTypes $+                                                         t1 : maybeToList m_t2+                             _                        -> emptyVarSet+       ; traceTc "relevantBindings" $+           vcat [ ppr ct+                , pprCtOrigin (ctLocOrigin loc)+                , ppr ct_tvs+                , pprWithCommas id [ ppr id <+> dcolon <+> ppr (idType id)+                                   | TcIdBndr id _ <- tcl_bndrs lcl_env ]+                , pprWithCommas id+                    [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ]++       ; (tidy_env', docs, discards)+              <- go dflags env1 ct_tvs (maxRelevantBinds dflags)+                    emptyVarSet [] False+                    (removeBindingShadowing $ tcl_bndrs lcl_env)+         -- tcl_bndrs has the innermost bindings first,+         -- which are probably the most relevant ones++       ; let doc = ppUnless (null docs) $+                   hang (text "Relevant bindings include")+                      2 (vcat docs $$ ppWhen discards discardMsg)++             -- Put a zonked, tidied CtOrigin into the Ct+             loc'  = setCtLocOrigin loc tidy_orig+             ct'   = setCtLoc ct loc'+             ctxt' = ctxt { cec_tidy = tidy_env' }++       ; return (ctxt', doc, ct') }+  where+    ev      = ctEvidence ct+    loc     = ctEvLoc ev+    lcl_env = ctLocEnv loc++    run_out :: Maybe Int -> Bool+    run_out Nothing = False+    run_out (Just n) = n <= 0++    dec_max :: Maybe Int -> Maybe Int+    dec_max = fmap (\n -> n - 1)+++    go :: DynFlags -> TidyEnv -> TcTyVarSet -> Maybe Int -> TcTyVarSet -> [SDoc]+       -> Bool                          -- True <=> some filtered out due to lack of fuel+       -> [TcBinder]+       -> TcM (TidyEnv, [SDoc], Bool)   -- The bool says if we filtered any out+                                        -- because of lack of fuel+    go _ tidy_env _ _ _ docs discards []+      = return (tidy_env, reverse docs, discards)+    go dflags tidy_env ct_tvs n_left tvs_seen docs discards (tc_bndr : tc_bndrs)+      = case tc_bndr of+          TcTvBndr {} -> discard_it+          TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl+          TcIdBndr_ExpType name et top_lvl ->+            do { mb_ty <- readExpType_maybe et+                   -- et really should be filled in by now. But there's a chance+                   -- it hasn't, if, say, we're reporting a kind error en route to+                   -- checking a term. See test indexed-types/should_fail/T8129+                   -- Or we are reporting errors from the ambiguity check on+                   -- a local type signature+               ; case mb_ty of+                   Just ty -> go2 name ty top_lvl+                   Nothing -> discard_it  -- No info; discard+               }+      where+        discard_it = go dflags tidy_env ct_tvs n_left tvs_seen docs+                        discards tc_bndrs+        go2 id_name id_type top_lvl+          = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type+               ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty)+               ; let id_tvs = tyCoVarsOfType tidy_ty+                     doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty+                               , nest 2 (parens (text "bound at"+                                    <+> ppr (getSrcLoc id_name)))]+                     new_seen = tvs_seen `unionVarSet` id_tvs++               ; if (want_filtering && not (hasPprDebug dflags)+                                    && id_tvs `disjointVarSet` ct_tvs)+                          -- We want to filter out this binding anyway+                          -- so discard it silently+                 then discard_it++                 else if isTopLevel top_lvl && not (isNothing n_left)+                          -- It's a top-level binding and we have not specified+                          -- -fno-max-relevant-bindings, so discard it silently+                 then discard_it++                 else if run_out n_left && id_tvs `subVarSet` tvs_seen+                          -- We've run out of n_left fuel and this binding only+                          -- mentions already-seen type variables, so discard it+                 then go dflags tidy_env ct_tvs n_left tvs_seen docs+                         True      -- Record that we have now discarded something+                         tc_bndrs++                          -- Keep this binding, decrement fuel+                 else go dflags tidy_env' ct_tvs (dec_max n_left) new_seen+                         (doc:docs) discards tc_bndrs }+++discardMsg :: SDoc+discardMsg = text "(Some bindings suppressed;" <+>+             text "use -fmax-relevant-binds=N or -fno-max-relevant-binds)"++-----------------------+warnDefaulting :: [Ct] -> Type -> TcM ()+warnDefaulting wanteds default_ty+  = do { warn_default <- woptM Opt_WarnTypeDefaults+       ; env0 <- tcInitTidyEnv+       ; let tidy_env = tidyFreeTyCoVars env0 $+                        tyCoVarsOfCtsList (listToBag wanteds)+             tidy_wanteds = map (tidyCt tidy_env) wanteds+             (loc, ppr_wanteds) = pprWithArising tidy_wanteds+             warn_msg =+                hang (hsep [ text "Defaulting the following"+                           , text "constraint" <> plural tidy_wanteds+                           , text "to type"+                           , quotes (ppr default_ty) ])+                     2+                     ppr_wanteds+       ; setCtLocM loc $ warnTc (Reason Opt_WarnTypeDefaults) warn_default warn_msg }++{-+Note [Runtime skolems]+~~~~~~~~~~~~~~~~~~~~~~+We want to give a reasonably helpful error message for ambiguity+arising from *runtime* skolems in the debugger.  These+are created by in RtClosureInspect.zonkRTTIType.++************************************************************************+*                                                                      *+                 Error from the canonicaliser+         These ones are called *during* constraint simplification+*                                                                      *+************************************************************************+-}++solverDepthErrorTcS :: CtLoc -> TcType -> TcM a+solverDepthErrorTcS loc ty+  = setCtLocM loc $+    do { ty <- zonkTcType ty+       ; env0 <- tcInitTidyEnv+       ; let tidy_env     = tidyFreeTyCoVars env0 (tyCoVarsOfTypeList ty)+             tidy_ty      = tidyType tidy_env ty+             msg+               = vcat [ text "Reduction stack overflow; size =" <+> ppr depth+                      , hang (text "When simplifying the following type:")+                           2 (ppr tidy_ty)+                      , note ]+       ; failWithTcM (tidy_env, msg) }+  where+    depth = ctLocDepth loc+    note = vcat+      [ text "Use -freduction-depth=0 to disable this check"+      , text "(any upper bound you could choose might fail unpredictably with"+      , text " minor updates to GHC, so disabling the check is recommended if"+      , text " you're sure that type checking should terminate)" ]
+ compiler/typecheck/TcEvTerm.hs view
@@ -0,0 +1,70 @@++-- (those who have too heavy dependencies for TcEvidence)+module TcEvTerm+    ( evDelayedError, evCallStack )+where++import GhcPrelude++import FastString+import Type+import CoreSyn+import MkCore+import Literal ( Literal(..) )+import TcEvidence+import HscTypes+import DynFlags+import Name+import Module+import CoreUtils+import PrelNames+import SrcLoc++-- Used with Opt_DeferTypeErrors+-- See Note [Deferring coercion errors to runtime]+-- in TcSimplify+evDelayedError :: Type -> FastString -> EvTerm+evDelayedError ty msg+  = EvExpr $+    Var errorId `mkTyApps` [getRuntimeRep ty, ty] `mkApps` [litMsg]+  where+    errorId = tYPE_ERROR_ID+    litMsg  = Lit (LitString (bytesFS msg))++-- Dictionary for CallStack implicit parameters+evCallStack :: (MonadThings m, HasModule m, HasDynFlags m) =>+    EvCallStack -> m EvExpr+-- See Note [Overview of implicit CallStacks] in TcEvidence.hs+evCallStack cs = do+  df            <- getDynFlags+  m             <- getModule+  srcLocDataCon <- lookupDataCon srcLocDataConName+  let mkSrcLoc l = mkCoreConApps srcLocDataCon <$>+               sequence [ mkStringExprFS (unitIdFS $ moduleUnitId m)+                        , mkStringExprFS (moduleNameFS $ moduleName m)+                        , mkStringExprFS (srcSpanFile l)+                        , return $ mkIntExprInt df (srcSpanStartLine l)+                        , return $ mkIntExprInt df (srcSpanStartCol l)+                        , return $ mkIntExprInt df (srcSpanEndLine l)+                        , return $ mkIntExprInt df (srcSpanEndCol l)+                        ]++  emptyCS <- Var <$> lookupId emptyCallStackName++  pushCSVar <- lookupId pushCallStackName+  let pushCS name loc rest =+        mkCoreApps (Var pushCSVar) [mkCoreTup [name, loc], rest]++  let mkPush name loc tm = do+        nameExpr <- mkStringExprFS name+        locExpr <- mkSrcLoc loc+        -- at this point tm :: IP sym CallStack+        -- but we need the actual CallStack to pass to pushCS,+        -- so we use unwrapIP to strip the dictionary wrapper+        -- See Note [Overview of implicit CallStacks]+        let ip_co = unwrapIP (exprType tm)+        return (pushCS nameExpr locExpr (Cast tm ip_co))++  case cs of+    EvCsPushCall name loc tm -> mkPush (occNameFS $ getOccName name) loc tm+    EvCsEmpty -> return emptyCS
+ compiler/typecheck/TcExpr.hs view
@@ -0,0 +1,2919 @@+{-+%+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[TcExpr]{Typecheck an expression}+-}++{-# LANGUAGE CPP, TupleSections, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module TcExpr ( tcPolyExpr, tcMonoExpr, tcMonoExprNC,+                tcInferSigma, tcInferSigmaNC, tcInferRho, tcInferRhoNC,+                tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,+                tcCheckId,+                addExprErrCtxt,+                getFixedTyVars ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-}   TcSplice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )+import THNames( liftStringName, liftName )++import HsSyn+import TcHsSyn+import TcRnMonad+import TcUnify+import BasicTypes+import Inst+import TcBinds          ( chooseInferredQuantifiers, tcLocalBinds )+import TcSigs           ( tcUserTypeSig, tcInstSig )+import TcSimplify       ( simplifyInfer, InferMode(..) )+import FamInst          ( tcGetFamInstEnvs, tcLookupDataFamInst )+import FamInstEnv       ( FamInstEnvs )+import RnEnv            ( addUsedGRE )+import RnUtils          ( addNameClashErrRn, unknownSubordinateErr )+import TcEnv+import TcArrows+import TcMatches+import TcHsType+import TcPatSyn( tcPatSynBuilderOcc, nonBidirectionalErr )+import TcPat+import TcMType+import TcType+import Id+import IdInfo+import ConLike+import DataCon+import PatSyn+import Name+import NameEnv+import NameSet+import RdrName+import TyCon+import TyCoRep+import Type+import TcEvidence+import VarSet+import MkId( seqId )+import TysWiredIn+import TysPrim( intPrimTy, mkTemplateTyVars, tYPE )+import PrimOp( tagToEnumKey )+import PrelNames+import DynFlags+import SrcLoc+import Util+import VarEnv  ( emptyTidyEnv, mkInScopeSet )+import ListSetOps+import Maybes+import Outputable+import FastString+import Control.Monad+import Class(classTyCon)+import UniqSet ( nonDetEltsUniqSet )+import qualified GHC.LanguageExtensions as LangExt++import Data.Function+import Data.List+import qualified Data.Set as Set++{-+************************************************************************+*                                                                      *+\subsection{Main wrappers}+*                                                                      *+************************************************************************+-}++tcPolyExpr, tcPolyExprNC+  :: LHsExpr GhcRn         -- Expression to type check+  -> TcSigmaType           -- Expected type (could be a polytype)+  -> TcM (LHsExpr GhcTcId) -- Generalised expr with expected type++-- tcPolyExpr is a convenient place (frequent but not too frequent)+-- place to add context information.+-- The NC version does not do so, usually because the caller wants+-- to do so himself.++tcPolyExpr   expr res_ty = tc_poly_expr expr (mkCheckExpType res_ty)+tcPolyExprNC expr res_ty = tc_poly_expr_nc expr (mkCheckExpType res_ty)++-- these versions take an ExpType+tc_poly_expr, tc_poly_expr_nc :: LHsExpr GhcRn -> ExpSigmaType+                              -> TcM (LHsExpr GhcTcId)+tc_poly_expr expr res_ty+  = addExprErrCtxt expr $+    do { traceTc "tcPolyExpr" (ppr res_ty); tc_poly_expr_nc expr res_ty }++tc_poly_expr_nc (L loc expr) res_ty+  = setSrcSpan loc $+    do { traceTc "tcPolyExprNC" (ppr res_ty)+       ; (wrap, expr')+           <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->+              tcExpr expr res_ty+       ; return $ L loc (mkHsWrap wrap expr') }++---------------+tcMonoExpr, tcMonoExprNC+    :: LHsExpr GhcRn     -- Expression to type check+    -> ExpRhoType        -- Expected type+                         -- Definitely no foralls at the top+    -> TcM (LHsExpr GhcTcId)++tcMonoExpr expr res_ty+  = addErrCtxt (exprCtxt expr) $+    tcMonoExprNC expr res_ty++tcMonoExprNC (L loc expr) res_ty+  = setSrcSpan loc $+    do  { expr' <- tcExpr expr res_ty+        ; return (L loc expr') }++---------------+tcInferSigma, tcInferSigmaNC :: LHsExpr GhcRn -> TcM ( LHsExpr GhcTcId+                                                    , TcSigmaType )+-- Infer a *sigma*-type.+tcInferSigma expr = addErrCtxt (exprCtxt expr) (tcInferSigmaNC expr)++tcInferSigmaNC (L loc expr)+  = setSrcSpan loc $+    do { (expr', sigma) <- tcInferNoInst (tcExpr expr)+       ; return (L loc expr', sigma) }++tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcRhoType)+-- Infer a *rho*-type. The return type is always (shallowly) instantiated.+tcInferRho expr = addErrCtxt (exprCtxt expr) (tcInferRhoNC expr)++tcInferRhoNC expr+  = do { (expr', sigma) <- tcInferSigmaNC expr+       ; (wrap, rho) <- topInstantiate (lexprCtOrigin expr) sigma+       ; return (mkLHsWrap wrap expr', rho) }+++{-+************************************************************************+*                                                                      *+        tcExpr: the main expression typechecker+*                                                                      *+************************************************************************++NB: The res_ty is always deeply skolemised.+-}++tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)+tcExpr (HsVar _ (L _ name))   res_ty = tcCheckId name res_ty+tcExpr e@(HsUnboundVar _ uv)  res_ty = tcUnboundId e uv res_ty++tcExpr e@(HsApp {})     res_ty = tcApp1 e res_ty+tcExpr e@(HsAppType {}) res_ty = tcApp1 e res_ty++tcExpr e@(HsLit x lit) res_ty+  = do { let lit_ty = hsLitType lit+       ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty }++tcExpr (HsPar x expr) res_ty = do { expr' <- tcMonoExprNC expr res_ty+                                  ; return (HsPar x expr') }++tcExpr (HsSCC x src lbl expr) res_ty+  = do { expr' <- tcMonoExpr expr res_ty+       ; return (HsSCC x src lbl expr') }++tcExpr (HsTickPragma x src info srcInfo expr) res_ty+  = do { expr' <- tcMonoExpr expr res_ty+       ; return (HsTickPragma x src info srcInfo expr') }++tcExpr (HsCoreAnn x src lbl expr) res_ty+  = do  { expr' <- tcMonoExpr expr res_ty+        ; return (HsCoreAnn x src lbl expr') }++tcExpr (HsOverLit x lit) res_ty+  = do  { lit' <- newOverloadedLit lit res_ty+        ; return (HsOverLit x lit') }++tcExpr (NegApp x expr neg_expr) res_ty+  = do  { (expr', neg_expr')+            <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $+               \[arg_ty] ->+               tcMonoExpr expr (mkCheckExpType arg_ty)+        ; return (NegApp x expr' neg_expr') }++tcExpr e@(HsIPVar _ x) res_ty+  = do {   {- Implicit parameters must have a *tau-type* not a+              type scheme.  We enforce this by creating a fresh+              type variable as its type.  (Because res_ty may not+              be a tau-type.) -}+         ip_ty <- newOpenFlexiTyVarTy+       ; let ip_name = mkStrLitTy (hsIPNameFS x)+       ; ipClass <- tcLookupClass ipClassName+       ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])+       ; tcWrapResult e+                   (fromDict ipClass ip_name ip_ty (HsVar noExt (noLoc ip_var)))+                   ip_ty res_ty }+  where+  -- Coerces a dictionary for `IP "x" t` into `t`.+  fromDict ipClass x ty = mkHsWrap $ mkWpCastR $+                          unwrapIP $ mkClassPred ipClass [x,ty]+  origin = IPOccOrigin x++tcExpr e@(HsOverLabel _ mb_fromLabel l) res_ty+  = do { -- See Note [Type-checking overloaded labels]+         loc <- getSrcSpanM+       ; case mb_fromLabel of+           Just fromLabel -> tcExpr (applyFromLabel loc fromLabel) res_ty+           Nothing -> do { isLabelClass <- tcLookupClass isLabelClassName+                         ; alpha <- newFlexiTyVarTy liftedTypeKind+                         ; let pred = mkClassPred isLabelClass [lbl, alpha]+                         ; loc <- getSrcSpanM+                         ; var <- emitWantedEvVar origin pred+                         ; tcWrapResult e+                                       (fromDict pred (HsVar noExt (L loc var)))+                                        alpha res_ty } }+  where+  -- Coerces a dictionary for `IsLabel "x" t` into `t`,+  -- or `HasField "x" r a into `r -> a`.+  fromDict pred = mkHsWrap $ mkWpCastR $ unwrapIP pred+  origin = OverLabelOrigin l+  lbl = mkStrLitTy l++  applyFromLabel loc fromLabel =+    HsAppType noExt+         (L loc (HsVar noExt (L loc fromLabel)))+         (mkEmptyWildCardBndrs (L loc (HsTyLit noExt (HsStrTy NoSourceText l))))++tcExpr (HsLam x match) res_ty+  = do  { (match', wrap) <- tcMatchLambda herald match_ctxt match res_ty+        ; return (mkHsWrap wrap (HsLam x match')) }+  where+    match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }+    herald = sep [ text "The lambda expression" <+>+                   quotes (pprSetDepth (PartWay 1) $+                           pprMatches match),+                        -- The pprSetDepth makes the abstraction print briefly+                   text "has"]++tcExpr e@(HsLamCase x matches) res_ty+  = do { (matches', wrap)+           <- tcMatchLambda msg match_ctxt matches res_ty+           -- The laziness annotation is because we don't want to fail here+           -- if there are multiple arguments+       ; return (mkHsWrap wrap $ HsLamCase x matches') }+  where+    msg = sep [ text "The function" <+> quotes (ppr e)+              , text "requires"]+    match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }++tcExpr e@(ExprWithTySig _ expr sig_ty) res_ty+  = do { let loc = getLoc (hsSigWcType sig_ty)+       ; sig_info <- checkNoErrs $  -- Avoid error cascade+                     tcUserTypeSig loc sig_ty Nothing+       ; (expr', poly_ty) <- tcExprSig expr sig_info+       ; let expr'' = ExprWithTySig noExt expr' sig_ty+       ; tcWrapResult e expr'' poly_ty res_ty }++{-+Note [Type-checking overloaded labels]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Recall that we have++  module GHC.OverloadedLabels where+    class IsLabel (x :: Symbol) a where+      fromLabel :: a++We translate `#foo` to `fromLabel @"foo"`, where we use++ * the in-scope `fromLabel` if `RebindableSyntax` is enabled; or if not+ * `GHC.OverloadedLabels.fromLabel`.++In the `RebindableSyntax` case, the renamer will have filled in the+first field of `HsOverLabel` with the `fromLabel` function to use, and+we simply apply it to the appropriate visible type argument.++In the `OverloadedLabels` case, when we see an overloaded label like+`#foo`, we generate a fresh variable `alpha` for the type and emit an+`IsLabel "foo" alpha` constraint.  Because the `IsLabel` class has a+single method, it is represented by a newtype, so we can coerce+`IsLabel "foo" alpha` to `alpha` (just like for implicit parameters).++-}+++{-+************************************************************************+*                                                                      *+                Infix operators and sections+*                                                                      *+************************************************************************++Note [Left sections]+~~~~~~~~~~~~~~~~~~~~+Left sections, like (4 *), are equivalent to+        \ x -> (*) 4 x,+or, if PostfixOperators is enabled, just+        (*) 4+With PostfixOperators we don't actually require the function to take+two arguments at all.  For example, (x `not`) means (not x); you get+postfix operators!  Not Haskell 98, but it's less work and kind of+useful.++Note [Typing rule for ($)]+~~~~~~~~~~~~~~~~~~~~~~~~~~+People write+   runST $ blah+so much, where+   runST :: (forall s. ST s a) -> a+that I have finally given in and written a special type-checking+rule just for saturated applications of ($).+  * Infer the type of the first argument+  * Decompose it; should be of form (arg2_ty -> res_ty),+       where arg2_ty might be a polytype+  * Use arg2_ty to typecheck arg2++Note [Typing rule for seq]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to allow+       x `seq` (# p,q #)+which suggests this type for seq:+   seq :: forall (a:*) (b:Open). a -> b -> b,+with (b:Open) meaning that be can be instantiated with an unboxed+tuple.  The trouble is that this might accept a partially-applied+'seq', and I'm just not certain that would work.  I'm only sure it's+only going to work when it's fully applied, so it turns into+    case x of _ -> (# p,q #)++So it seems more uniform to treat 'seq' as if it was a language+construct.++See also Note [seqId magic] in MkId+-}++tcExpr expr@(OpApp fix arg1 op arg2) res_ty+  | (L loc (HsVar _ (L lv op_name))) <- op+  , op_name `hasKey` seqIdKey           -- Note [Typing rule for seq]+  = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind+       ; let arg2_exp_ty = res_ty+       ; arg1' <- tcArg op arg1 arg1_ty 1+       ; arg2' <- addErrCtxt (funAppCtxt op arg2 2) $+                  tc_poly_expr_nc arg2 arg2_exp_ty+       ; arg2_ty <- readExpType arg2_exp_ty+       ; op_id <- tcLookupId op_name+       ; let op' = L loc (mkHsWrap (mkWpTyApps [arg1_ty, arg2_ty])+                                   (HsVar noExt (L lv op_id)))+       ; return $ OpApp fix arg1' op' arg2' }++  | (L loc (HsVar _ (L lv op_name))) <- op+  , op_name `hasKey` dollarIdKey        -- Note [Typing rule for ($)]+  = do { traceTc "Application rule" (ppr op)+       ; (arg1', arg1_ty) <- tcInferSigma arg1++       ; let doc   = text "The first argument of ($) takes"+             orig1 = lexprCtOrigin arg1+       ; (wrap_arg1, [arg2_sigma], op_res_ty) <-+           matchActualFunTys doc orig1 (Just (unLoc arg1)) 1 arg1_ty++         -- We have (arg1 $ arg2)+         -- So: arg1_ty = arg2_ty -> op_res_ty+         -- where arg2_sigma maybe polymorphic; that's the point++       ; arg2'  <- tcArg op arg2 arg2_sigma 2++       -- Make sure that the argument type has kind '*'+       --   ($) :: forall (r:RuntimeRep) (a:*) (b:TYPE r). (a->b) -> a -> b+       -- Eg we do not want to allow  (D#  $  4.0#)   #5570+       --    (which gives a seg fault)+       --+       -- The *result* type can have any kind (#8739),+       -- so we don't need to check anything for that+       ; _ <- unifyKind (Just (XHsType $ NHsCoreTy arg2_sigma))+                        (tcTypeKind arg2_sigma) liftedTypeKind+           -- ignore the evidence. arg2_sigma must have type * or #,+           -- because we know arg2_sigma -> or_res_ty is well-kinded+           -- (because otherwise matchActualFunTys would fail)+           -- There's no possibility here of, say, a kind family reducing to *.++       ; wrap_res <- tcSubTypeHR orig1 (Just expr) op_res_ty res_ty+                       -- op_res -> res++       ; op_id  <- tcLookupId op_name+       ; res_ty <- readExpType res_ty+       ; let op' = L loc (mkHsWrap (mkWpTyApps [ getRuntimeRep res_ty+                                               , arg2_sigma+                                               , res_ty])+                                   (HsVar noExt (L lv op_id)))+             -- arg1' :: arg1_ty+             -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty)+             -- wrap_res :: op_res_ty "->" res_ty+             -- op' :: (a2_ty -> res_ty) -> a2_ty -> res_ty++             -- wrap1 :: arg1_ty "->" (arg2_sigma -> res_ty)+             wrap1 = mkWpFun idHsWrapper wrap_res arg2_sigma res_ty doc+                     <.> wrap_arg1+             doc = text "When looking at the argument to ($)"++       ; return (OpApp fix (mkLHsWrap wrap1 arg1') op' arg2') }++  | (L loc (HsRecFld _ (Ambiguous _ lbl))) <- op+  , Just sig_ty <- obviousSig (unLoc arg1)+    -- See Note [Disambiguating record fields]+  = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty+       ; sel_name <- disambiguateSelector lbl sig_tc_ty+       ; let op' = L loc (HsRecFld noExt (Unambiguous sel_name lbl))+       ; tcExpr (OpApp fix arg1 op' arg2) res_ty+       }++  | otherwise+  = do { traceTc "Non Application rule" (ppr op)+       ; (wrap, op', [HsValArg arg1', HsValArg arg2'])+           <- tcApp (Just $ mk_op_msg op)+                     op [HsValArg arg1, HsValArg arg2] res_ty+       ; return (mkHsWrap wrap $ OpApp fix arg1' op' arg2') }++-- Right sections, equivalent to \ x -> x `op` expr, or+--      \ x -> op x expr++tcExpr expr@(SectionR x op arg2) res_ty+  = do { (op', op_ty) <- tcInferFun op+       ; (wrap_fun, [arg1_ty, arg2_ty], op_res_ty)+                  <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op)) 2 op_ty+       ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)+                                 (mkVisFunTy arg1_ty op_res_ty) res_ty+       ; arg2' <- tcArg op arg2 arg2_ty 2+       ; return ( mkHsWrap wrap_res $+                  SectionR x (mkLHsWrap wrap_fun op') arg2' ) }+  where+    fn_orig = lexprCtOrigin op+    -- It's important to use the origin of 'op', so that call-stacks+    -- come out right; they are driven by the OccurrenceOf CtOrigin+    -- See #13285++tcExpr expr@(SectionL x arg1 op) res_ty+  = do { (op', op_ty) <- tcInferFun op+       ; dflags <- getDynFlags      -- Note [Left sections]+       ; let n_reqd_args | xopt LangExt.PostfixOperators dflags = 1+                         | otherwise                            = 2++       ; (wrap_fn, (arg1_ty:arg_tys), op_res_ty)+           <- matchActualFunTys (mk_op_msg op) fn_orig (Just (unLoc op))+                                n_reqd_args op_ty+       ; wrap_res <- tcSubTypeHR SectionOrigin (Just expr)+                                 (mkVisFunTys arg_tys op_res_ty) res_ty+       ; arg1' <- tcArg op arg1 arg1_ty 1+       ; return ( mkHsWrap wrap_res $+                  SectionL x arg1' (mkLHsWrap wrap_fn op') ) }+  where+    fn_orig = lexprCtOrigin op+    -- It's important to use the origin of 'op', so that call-stacks+    -- come out right; they are driven by the OccurrenceOf CtOrigin+    -- See #13285++tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty+  | all tupArgPresent tup_args+  = do { let arity  = length tup_args+             tup_tc = tupleTyCon boxity arity+       ; res_ty <- expTypeToType res_ty+       ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty+                           -- Unboxed tuples have RuntimeRep vars, which we+                           -- don't care about here+                           -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+       ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys+                                       Boxed   -> arg_tys+       ; tup_args1 <- tcTupArgs tup_args arg_tys'+       ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) }++  | otherwise+  = -- The tup_args are a mixture of Present and Missing (for tuple sections)+    do { let arity = length tup_args++       ; arg_tys <- case boxity of+           { Boxed   -> newFlexiTyVarTys arity liftedTypeKind+           ; Unboxed -> replicateM arity newOpenFlexiTyVarTy }+       ; let actual_res_ty+                 = mkVisFunTys [ty | (ty, (L _ (Missing _))) <- arg_tys `zip` tup_args]+                            (mkTupleTy boxity arg_tys)++       ; wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "ExpTuple")+                             (Just expr)+                             actual_res_ty res_ty++       -- Handle tuple sections where+       ; tup_args1 <- tcTupArgs tup_args arg_tys++       ; return $ mkHsWrap wrap (ExplicitTuple x tup_args1 boxity) }++tcExpr (ExplicitSum _ alt arity expr) res_ty+  = do { let sum_tc = sumTyCon arity+       ; res_ty <- expTypeToType res_ty+       ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty+       ; -- Drop levity vars, we don't care about them here+         let arg_tys' = drop arity arg_tys+       ; expr' <- tcPolyExpr expr (arg_tys' `getNth` (alt - 1))+       ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) }++tcExpr (ExplicitList _ witness exprs) res_ty+  = case witness of+      Nothing   -> do  { res_ty <- expTypeToType res_ty+                       ; (coi, elt_ty) <- matchExpectedListTy res_ty+                       ; exprs' <- mapM (tc_elt elt_ty) exprs+                       ; return $+                         mkHsWrapCo coi $ ExplicitList elt_ty Nothing exprs' }++      Just fln -> do { ((exprs', elt_ty), fln')+                         <- tcSyntaxOp ListOrigin fln+                                       [synKnownType intTy, SynList] res_ty $+                            \ [elt_ty] ->+                            do { exprs' <-+                                    mapM (tc_elt elt_ty) exprs+                               ; return (exprs', elt_ty) }++                     ; return $ ExplicitList elt_ty (Just fln') exprs' }+     where tc_elt elt_ty expr = tcPolyExpr expr elt_ty++{-+************************************************************************+*                                                                      *+                Let, case, if, do+*                                                                      *+************************************************************************+-}++tcExpr (HsLet x (L l binds) expr) res_ty+  = do  { (binds', expr') <- tcLocalBinds binds $+                             tcMonoExpr expr res_ty+        ; return (HsLet x (L l binds') expr') }++tcExpr (HsCase x scrut matches) res_ty+  = do  {  -- We used to typecheck the case alternatives first.+           -- The case patterns tend to give good type info to use+           -- when typechecking the scrutinee.  For example+           --   case (map f) of+           --     (x:xs) -> ...+           -- will report that map is applied to too few arguments+           --+           -- But now, in the GADT world, we need to typecheck the scrutinee+           -- first, to get type info that may be refined in the case alternatives+          (scrut', scrut_ty) <- tcInferRho scrut++        ; traceTc "HsCase" (ppr scrut_ty)+        ; matches' <- tcMatchesCase match_ctxt scrut_ty matches res_ty+        ; return (HsCase x scrut' matches') }+ where+    match_ctxt = MC { mc_what = CaseAlt,+                      mc_body = tcBody }++tcExpr (HsIf x Nothing pred b1 b2) res_ty    -- Ordinary 'if'+  = do { pred' <- tcMonoExpr pred (mkCheckExpType boolTy)+       ; res_ty <- tauifyExpType res_ty+           -- Just like Note [Case branches must never infer a non-tau type]+           -- in TcMatches (See #10619)++       ; b1' <- tcMonoExpr b1 res_ty+       ; b2' <- tcMonoExpr b2 res_ty+       ; return (HsIf x Nothing pred' b1' b2') }++tcExpr (HsIf x (Just fun) pred b1 b2) res_ty+  = do { ((pred', b1', b2'), fun')+           <- tcSyntaxOp IfOrigin fun [SynAny, SynAny, SynAny] res_ty $+              \ [pred_ty, b1_ty, b2_ty] ->+              do { pred' <- tcPolyExpr pred pred_ty+                 ; b1'   <- tcPolyExpr b1   b1_ty+                 ; b2'   <- tcPolyExpr b2   b2_ty+                 ; return (pred', b1', b2') }+       ; return (HsIf x (Just fun') pred' b1' b2') }++tcExpr (HsMultiIf _ alts) res_ty+  = do { res_ty <- if isSingleton alts+                   then return res_ty+                   else tauifyExpType res_ty+             -- Just like TcMatches+             -- Note [Case branches must never infer a non-tau type]++       ; alts' <- mapM (wrapLocM $ tcGRHS match_ctxt res_ty) alts+       ; res_ty <- readExpType res_ty+       ; return (HsMultiIf res_ty alts') }+  where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }++tcExpr (HsDo _ do_or_lc stmts) res_ty+  = do { expr' <- tcDoStmts do_or_lc stmts res_ty+       ; return expr' }++tcExpr (HsProc x pat cmd) res_ty+  = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty+        ; return $ mkHsWrapCo coi (HsProc x pat' cmd') }++-- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.+-- See Note [Grand plan for static forms] in StaticPtrTable for an overview.+-- To type check+--      (static e) :: p a+-- we want to check (e :: a),+-- and wrap (static e) in a call to+--    fromStaticPtr :: IsStatic p => StaticPtr a -> p a++tcExpr (HsStatic fvs expr) res_ty+  = do  { res_ty          <- expTypeToType res_ty+        ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty+        ; (expr', lie)    <- captureConstraints $+            addErrCtxt (hang (text "In the body of a static form:")+                             2 (ppr expr)+                       ) $+            tcPolyExprNC expr expr_ty++        -- Check that the free variables of the static form are closed.+        -- It's OK to use nonDetEltsUniqSet here as the only side effects of+        -- checkClosedInStaticForm are error messages.+        ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs++        -- Require the type of the argument to be Typeable.+        -- The evidence is not used, but asking the constraint ensures that+        -- the current implementation is as restrictive as future versions+        -- of the StaticPointers extension.+        ; typeableClass <- tcLookupClass typeableClassName+        ; _ <- emitWantedEvVar StaticOrigin $+                  mkTyConApp (classTyCon typeableClass)+                             [liftedTypeKind, expr_ty]++        -- Insert the constraints of the static form in a global list for later+        -- validation.+        ; emitStaticConstraints lie++        -- Wrap the static form with the 'fromStaticPtr' call.+        ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName+                                             [p_ty]+        ; let wrap = mkWpTyApps [expr_ty]+        ; loc <- getSrcSpanM+        ; return $ mkHsWrapCo co $ HsApp noExt+                                         (L loc $ mkHsWrap wrap fromStaticPtr)+                                         (L loc (HsStatic fvs expr'))+        }++{-+************************************************************************+*                                                                      *+                Record construction and update+*                                                                      *+************************************************************************+-}++tcExpr expr@(RecordCon { rcon_con_name = L loc con_name+                       , rcon_flds = rbinds }) res_ty+  = do  { con_like <- tcLookupConLike con_name++        -- Check for missing fields+        ; checkMissingFields con_like rbinds++        ; (con_expr, con_sigma) <- tcInferId con_name+        ; (con_wrap, con_tau) <-+            topInstantiate (OccurrenceOf con_name) con_sigma+              -- a shallow instantiation should really be enough for+              -- a data constructor.+        ; let arity = conLikeArity con_like+              Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau+        ; case conLikeWrapId_maybe con_like of+               Nothing -> nonBidirectionalErr (conLikeName con_like)+               Just con_id -> do {+                  res_wrap <- tcSubTypeHR (Shouldn'tHappenOrigin "RecordCon")+                                          (Just expr) actual_res_ty res_ty+                ; rbinds' <- tcRecordBinds con_like arg_tys rbinds+                ; return $+                  mkHsWrap res_wrap $+                  RecordCon { rcon_ext = RecordConTc+                                 { rcon_con_like = con_like+                                 , rcon_con_expr = mkHsWrap con_wrap con_expr }+                            , rcon_con_name = L loc con_id+                            , rcon_flds = rbinds' } } }++{-+Note [Type of a record update]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The main complication with RecordUpd is that we need to explicitly+handle the *non-updated* fields.  Consider:++        data T a b c = MkT1 { fa :: a, fb :: (b,c) }+                     | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }+                     | MkT3 { fd :: a }++        upd :: T a b c -> (b',c) -> T a b' c+        upd t x = t { fb = x}++The result type should be (T a b' c)+not (T a b c),   because 'b' *is not* mentioned in a non-updated field+not (T a b' c'), because 'c' *is*     mentioned in a non-updated field+NB that it's not good enough to look at just one constructor; we must+look at them all; cf #3219++After all, upd should be equivalent to:+        upd t x = case t of+                        MkT1 p q -> MkT1 p x+                        MkT2 a b -> MkT2 p b+                        MkT3 d   -> error ...++So we need to give a completely fresh type to the result record,+and then constrain it by the fields that are *not* updated ("p" above).+We call these the "fixed" type variables, and compute them in getFixedTyVars.++Note that because MkT3 doesn't contain all the fields being updated,+its RHS is simply an error, so it doesn't impose any type constraints.+Hence the use of 'relevant_cont'.++Note [Implicit type sharing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We also take into account any "implicit" non-update fields.  For example+        data T a b where { MkT { f::a } :: T a a; ... }+So the "real" type of MkT is: forall ab. (a~b) => a -> T a b++Then consider+        upd t x = t { f=x }+We infer the type+        upd :: T a b -> a -> T a b+        upd (t::T a b) (x::a)+           = case t of { MkT (co:a~b) (_:a) -> MkT co x }+We can't give it the more general type+        upd :: T a b -> c -> T c b++Note [Criteria for update]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to allow update for existentials etc, provided the updated+field isn't part of the existential. For example, this should be ok.+  data T a where { MkT { f1::a, f2::b->b } :: T a }+  f :: T a -> b -> T b+  f t b = t { f1=b }++The criterion we use is this:++  The types of the updated fields+  mention only the universally-quantified type variables+  of the data constructor++NB: this is not (quite) the same as being a "naughty" record selector+(See Note [Naughty record selectors]) in TcTyClsDecls), at least+in the case of GADTs. Consider+   data T a where { MkT :: { f :: a } :: T [a] }+Then f is not "naughty" because it has a well-typed record selector.+But we don't allow updates for 'f'.  (One could consider trying to+allow this, but it makes my head hurt.  Badly.  And no one has asked+for it.)++In principle one could go further, and allow+  g :: T a -> T a+  g t = t { f2 = \x -> x }+because the expression is polymorphic...but that seems a bridge too far.++Note [Data family example]+~~~~~~~~~~~~~~~~~~~~~~~~~~+    data instance T (a,b) = MkT { x::a, y::b }+  --->+    data :TP a b = MkT { a::a, y::b }+    coTP a b :: T (a,b) ~ :TP a b++Suppose r :: T (t1,t2), e :: t3+Then  r { x=e } :: T (t3,t1)+  --->+      case r |> co1 of+        MkT x y -> MkT e y |> co2+      where co1 :: T (t1,t2) ~ :TP t1 t2+            co2 :: :TP t3 t2 ~ T (t3,t2)+The wrapping with co2 is done by the constructor wrapper for MkT++Outgoing invariants+~~~~~~~~~~~~~~~~~~~+In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):++  * cons are the data constructors to be updated++  * in_inst_tys, out_inst_tys have same length, and instantiate the+        *representation* tycon of the data cons.  In Note [Data+        family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]++Note [Mixed Record Field Updates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following pattern synonym.++  data MyRec = MyRec { foo :: Int, qux :: String }++  pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}++This allows updates such as the following++  updater :: MyRec -> MyRec+  updater a = a {f1 = 1 }++It would also make sense to allow the following update (which we reject).++  updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"++This leads to confusing behaviour when the selectors in fact refer the same+field.++  updater a = a {f1 = 1, foo = 2} ==? ???++For this reason, we reject a mixture of pattern synonym and normal record+selectors in the same update block. Although of course we still allow the+following.++  updater a = (a {f1 = 1}) {foo = 2}++  > updater (MyRec 0 "str")+  MyRec 2 "str"++-}++tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty+  = ASSERT( notNull rbnds )+    do  { -- STEP -2: typecheck the record_expr, the record to be updated+          (record_expr', record_rho) <- tcInferRho record_expr++        -- STEP -1  See Note [Disambiguating record fields]+        -- After this we know that rbinds is unambiguous+        ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty+        ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds+              upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds+              sel_ids      = map selectorAmbiguousFieldOcc upd_flds+        -- STEP 0+        -- Check that the field names are really field names+        -- and they are all field names for proper records or+        -- all field names for pattern synonyms.+        ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)+                         | fld <- rbinds,+                           -- Excludes class ops+                           let L loc sel_id = hsRecUpdFieldId (unLoc fld),+                           not (isRecordSelector sel_id),+                           let fld_name = idName sel_id ]+        ; unless (null bad_guys) (sequence bad_guys >> failM)+        -- See note [Mixed Record Selectors]+        ; let (data_sels, pat_syn_sels) =+                partition isDataConRecordSelector sel_ids+        ; MASSERT( all isPatSynRecordSelector pat_syn_sels )+        ; checkTc ( null data_sels || null pat_syn_sels )+                  ( mixedSelectors data_sels pat_syn_sels )++        -- STEP 1+        -- Figure out the tycon and data cons from the first field name+        ; let   -- It's OK to use the non-tc splitters here (for a selector)+              sel_id : _  = sel_ids++              mtycon :: Maybe TyCon+              mtycon = case idDetails sel_id of+                          RecSelId (RecSelData tycon) _ -> Just tycon+                          _ -> Nothing++              con_likes :: [ConLike]+              con_likes = case idDetails sel_id of+                             RecSelId (RecSelData tc) _+                                -> map RealDataCon (tyConDataCons tc)+                             RecSelId (RecSelPatSyn ps) _+                                -> [PatSynCon ps]+                             _  -> panic "tcRecordUpd"+                -- NB: for a data type family, the tycon is the instance tycon++              relevant_cons = conLikesWithFields con_likes upd_fld_occs+                -- A constructor is only relevant to this process if+                -- it contains *all* the fields that are being updated+                -- Other ones will cause a runtime error if they occur++        -- Step 2+        -- Check that at least one constructor has all the named fields+        -- i.e. has an empty set of bad fields returned by badFields+        ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)++        -- Take apart a representative constructor+        ; let con1 = ASSERT( not (null relevant_cons) ) head relevant_cons+              (con1_tvs, _, _, _prov_theta, req_theta, con1_arg_tys, _)+                 = conLikeFullSig con1+              con1_flds   = map flLabel $ conLikeFieldLabels con1+              con1_tv_tys = mkTyVarTys con1_tvs+              con1_res_ty = case mtycon of+                              Just tc -> mkFamilyTyConApp tc con1_tv_tys+                              Nothing -> conLikeResTy con1 con1_tv_tys++        -- Check that we're not dealing with a unidirectional pattern+        -- synonym+        ; unless (isJust $ conLikeWrapId_maybe con1)+                  (nonBidirectionalErr (conLikeName con1))++        -- STEP 3    Note [Criteria for update]+        -- Check that each updated field is polymorphic; that is, its type+        -- mentions only the universally-quantified variables of the data con+        ; let flds1_w_tys  = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys+              bad_upd_flds = filter bad_fld flds1_w_tys+              con1_tv_set  = mkVarSet con1_tvs+              bad_fld (fld, ty) = fld `elem` upd_fld_occs &&+                                      not (tyCoVarsOfType ty `subVarSet` con1_tv_set)+        ; checkTc (null bad_upd_flds) (badFieldTypes bad_upd_flds)++        -- STEP 4  Note [Type of a record update]+        -- Figure out types for the scrutinee and result+        -- Both are of form (T a b c), with fresh type variables, but with+        -- common variables where the scrutinee and result must have the same type+        -- These are variables that appear in *any* arg of *any* of the+        -- relevant constructors *except* in the updated fields+        --+        ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons+              is_fixed_tv tv = tv `elemVarSet` fixed_tvs++              mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType)+              -- Deals with instantiation of kind variables+              --   c.f. TcMType.newMetaTyVars+              mk_inst_ty subst (tv, result_inst_ty)+                | is_fixed_tv tv   -- Same as result type+                = return (extendTvSubst subst tv result_inst_ty, result_inst_ty)+                | otherwise        -- Fresh type, of correct kind+                = do { (subst', new_tv) <- newMetaTyVarX subst tv+                     ; return (subst', mkTyVarTy new_tv) }++        ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs+        ; let result_inst_tys = mkTyVarTys con1_tvs'+              init_subst = mkEmptyTCvSubst (getTCvInScope result_subst)++        ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst+                                                      (con1_tvs `zip` result_inst_tys)++        ; let rec_res_ty    = TcType.substTy result_subst con1_res_ty+              scrut_ty      = TcType.substTy scrut_subst  con1_res_ty+              con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys++        ; wrap_res <- tcSubTypeHR (exprCtOrigin expr)+                                  (Just expr) rec_res_ty res_ty+        ; co_scrut <- unifyType (Just (unLoc record_expr)) record_rho scrut_ty+                -- NB: normal unification is OK here (as opposed to subsumption),+                -- because for this to work out, both record_rho and scrut_ty have+                -- to be normal datatypes -- no contravariant stuff can go on++        -- STEP 5+        -- Typecheck the bindings+        ; rbinds'      <- tcRecordUpd con1 con1_arg_tys' rbinds++        -- STEP 6: Deal with the stupid theta+        ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1)+        ; instStupidTheta RecordUpdOrigin theta'++        -- Step 7: make a cast for the scrutinee, in the+        --         case that it's from a data family+        ; let fam_co :: HsWrapper   -- RepT t1 .. tn ~R scrut_ty+              fam_co | Just tycon <- mtycon+                     , Just co_con <- tyConFamilyCoercion_maybe tycon+                     = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys [])+                     | otherwise+                     = idHsWrapper++        -- Step 8: Check that the req constraints are satisfied+        -- For normal data constructors req_theta is empty but we must do+        -- this check for pattern synonyms.+        ; let req_theta' = substThetaUnchecked scrut_subst req_theta+        ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta'++        -- Phew!+        ; return $+          mkHsWrap wrap_res $+          RecordUpd { rupd_expr+                          = mkLHsWrap fam_co (mkLHsWrapCo co_scrut record_expr')+                    , rupd_flds = rbinds'+                    , rupd_ext = RecordUpdTc+                        { rupd_cons = relevant_cons+                        , rupd_in_tys = scrut_inst_tys+                        , rupd_out_tys = result_inst_tys+                        , rupd_wrap = req_wrap }} }++tcExpr e@(HsRecFld _ f) res_ty+    = tcCheckRecSelId e f res_ty++{-+************************************************************************+*                                                                      *+        Arithmetic sequences                    e.g. [a,b..]+        and their parallel-array counterparts   e.g. [: a,b.. :]++*                                                                      *+************************************************************************+-}++tcExpr (ArithSeq _ witness seq) res_ty+  = tcArithSeq witness seq res_ty++{-+************************************************************************+*                                                                      *+                Template Haskell+*                                                                      *+************************************************************************+-}++-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceExpr'.+-- Here we get rid of it and add the finalizers to the global environment.+--+-- See Note [Delaying modFinalizers in untyped splices] in RnSplice.+tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr)))+       res_ty+  = do addModFinalizersWithLclEnv mod_finalizers+       tcExpr expr res_ty+tcExpr (HsSpliceE _ splice)          res_ty+  = tcSpliceExpr splice res_ty+tcExpr e@(HsBracket _ brack)         res_ty+  = tcTypedBracket e brack res_ty+tcExpr e@(HsRnBracketOut _ brack ps) res_ty+  = tcUntypedBracket e brack ps res_ty++{-+************************************************************************+*                                                                      *+                Catch-all+*                                                                      *+************************************************************************+-}++tcExpr other _ = pprPanic "tcMonoExpr" (ppr other)+  -- Include ArrForm, ArrApp, which shouldn't appear at all+  -- Also HsTcBracketOut, HsQuasiQuoteE++{-+************************************************************************+*                                                                      *+                Arithmetic sequences [a..b] etc+*                                                                      *+************************************************************************+-}++tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType+           -> TcM (HsExpr GhcTcId)++tcArithSeq witness seq@(From expr) res_ty+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty+       ; expr' <- tcPolyExpr expr elt_ty+       ; enum_from <- newMethodFromName (ArithSeqOrigin seq)+                              enumFromName [elt_ty]+       ; return $ mkHsWrap wrap $+         ArithSeq enum_from wit' (From expr') }++tcArithSeq witness seq@(FromThen expr1 expr2) res_ty+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty+       ; expr1' <- tcPolyExpr expr1 elt_ty+       ; expr2' <- tcPolyExpr expr2 elt_ty+       ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)+                              enumFromThenName [elt_ty]+       ; return $ mkHsWrap wrap $+         ArithSeq enum_from_then wit' (FromThen expr1' expr2') }++tcArithSeq witness seq@(FromTo expr1 expr2) res_ty+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty+       ; expr1' <- tcPolyExpr expr1 elt_ty+       ; expr2' <- tcPolyExpr expr2 elt_ty+       ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)+                              enumFromToName [elt_ty]+       ; return $ mkHsWrap wrap $+         ArithSeq enum_from_to wit' (FromTo expr1' expr2') }++tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty+  = do { (wrap, elt_ty, wit') <- arithSeqEltType witness res_ty+        ; expr1' <- tcPolyExpr expr1 elt_ty+        ; expr2' <- tcPolyExpr expr2 elt_ty+        ; expr3' <- tcPolyExpr expr3 elt_ty+        ; eft <- newMethodFromName (ArithSeqOrigin seq)+                              enumFromThenToName [elt_ty]+        ; return $ mkHsWrap wrap $+          ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') }++-----------------+arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType+                -> TcM (HsWrapper, TcType, Maybe (SyntaxExpr GhcTc))+arithSeqEltType Nothing res_ty+  = do { res_ty <- expTypeToType res_ty+       ; (coi, elt_ty) <- matchExpectedListTy res_ty+       ; return (mkWpCastN coi, elt_ty, Nothing) }+arithSeqEltType (Just fl) res_ty+  = do { (elt_ty, fl')+           <- tcSyntaxOp ListOrigin fl [SynList] res_ty $+              \ [elt_ty] -> return elt_ty+       ; return (idHsWrapper, elt_ty, Just fl') }++{-+************************************************************************+*                                                                      *+                Applications+*                                                                      *+************************************************************************+-}++-- HsArg is defined in HsTypes.hs++wrapHsArgs :: (NoGhcTc (GhcPass id) ~ GhcRn)+           => LHsExpr (GhcPass id)+           -> [HsArg (LHsExpr (GhcPass id)) (LHsWcType GhcRn)]+           -> LHsExpr (GhcPass id)+wrapHsArgs f []                     = f+wrapHsArgs f (HsValArg  a : args)   = wrapHsArgs (mkHsApp f a)          args+wrapHsArgs f (HsTypeArg _ t : args) = wrapHsArgs (mkHsAppType f t)      args+wrapHsArgs f (HsArgPar sp : args)   = wrapHsArgs (L sp $ HsPar noExt f) args++isHsValArg :: HsArg tm ty -> Bool+isHsValArg (HsValArg {})  = True+isHsValArg (HsTypeArg {}) = False+isHsValArg (HsArgPar {})  = False++isArgPar :: HsArg tm ty -> Bool+isArgPar (HsArgPar {})  = True+isArgPar (HsValArg {})  = False+isArgPar (HsTypeArg {}) = False++isArgPar_maybe :: HsArg a b -> Maybe (HsArg c d)+isArgPar_maybe (HsArgPar sp) = Just $ HsArgPar sp+isArgPar_maybe _ = Nothing++type LHsExprArgIn  = HsArg (LHsExpr GhcRn)   (LHsWcType GhcRn)+type LHsExprArgOut = HsArg (LHsExpr GhcTcId) (LHsWcType GhcRn)++tcApp1 :: HsExpr GhcRn  -- either HsApp or HsAppType+       -> ExpRhoType -> TcM (HsExpr GhcTcId)+tcApp1 e res_ty+  = do { (wrap, fun, args) <- tcApp Nothing (noLoc e) [] res_ty+       ; return (mkHsWrap wrap $ unLoc $ wrapHsArgs fun args) }++tcApp :: Maybe SDoc  -- like "The function `f' is applied to"+                     -- or leave out to get exactly that message+      -> LHsExpr GhcRn -> [LHsExprArgIn] -- Function and args+      -> ExpRhoType -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])+           -- (wrap, fun, args). For an ordinary function application,+           -- these should be assembled as (wrap (fun args)).+           -- But OpApp is slightly different, so that's why the caller+           -- must assemble++tcApp m_herald (L sp (HsPar _ fun)) args res_ty+  = tcApp m_herald fun (HsArgPar sp : args) res_ty++tcApp m_herald (L _ (HsApp _ fun arg1)) args res_ty+  = tcApp m_herald fun (HsValArg arg1 : args) res_ty++tcApp m_herald (L _ (HsAppType _ fun ty1)) args res_ty+  = tcApp m_herald fun (HsTypeArg noSrcSpan ty1 : args) res_ty++tcApp m_herald fun@(L loc (HsRecFld _ fld_lbl)) args res_ty+  | Ambiguous _ lbl        <- fld_lbl  -- Still ambiguous+  , HsValArg (L _ arg) : _ <- filterOut isArgPar args -- A value arg is first+  , Just sig_ty     <- obviousSig arg  -- A type sig on the arg disambiguates+  = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty+       ; sel_name  <- disambiguateSelector lbl sig_tc_ty+       ; (tc_fun, fun_ty) <- tcInferRecSelId (Unambiguous sel_name lbl)+       ; tcFunApp m_herald fun (L loc tc_fun) fun_ty args res_ty }++tcApp m_herald fun@(L loc (HsVar _ (L _ fun_id))) args res_ty+  -- Special typing rule for tagToEnum#+  | fun_id `hasKey` tagToEnumKey+  , n_val_args == 1+  = tcTagToEnum loc fun_id args res_ty++  -- Special typing rule for 'seq'+  -- In the saturated case, behave as if seq had type+  --    forall a (b::TYPE r). a -> b -> b+  -- for some type r.  See Note [Typing rule for seq]+  | fun_id `hasKey` seqIdKey+  , n_val_args == 2+  = do { rep <- newFlexiTyVarTy runtimeRepTy+       ; let [alpha, beta] = mkTemplateTyVars [liftedTypeKind, tYPE rep]+             seq_ty = mkSpecForAllTys [alpha,beta]+                      (mkTyVarTy alpha `mkVisFunTy` mkTyVarTy beta `mkVisFunTy` mkTyVarTy beta)+             seq_fun = L loc (HsVar noExt (L loc seqId))+             -- seq_ty = forall (a:*) (b:TYPE r). a -> b -> b+             -- where 'r' is a meta type variable+        ; tcFunApp m_herald fun seq_fun seq_ty args res_ty }+  where+    n_val_args = count isHsValArg args++tcApp _ (L loc (ExplicitList _ Nothing [])) [HsTypeArg _ ty_arg] res_ty+  -- See Note [Visible type application for the empty list constructor]+  = do { ty_arg' <- tcHsTypeApp ty_arg liftedTypeKind+       ; let list_ty = TyConApp listTyCon [ty_arg']+       ; _ <- tcSubTypeDS (OccurrenceOf nilDataConName) GenSigCtxt+                          list_ty res_ty+       ; let expr :: LHsExpr GhcTcId+             expr = L loc $ ExplicitList ty_arg' Nothing []+       ; return (idHsWrapper, expr, []) }++tcApp m_herald fun args res_ty+  = do { (tc_fun, fun_ty) <- tcInferFun fun+       ; tcFunApp m_herald fun tc_fun fun_ty args res_ty }++---------------------+tcFunApp :: Maybe SDoc  -- like "The function `f' is applied to"+                        -- or leave out to get exactly that message+         -> LHsExpr GhcRn                  -- Renamed function+         -> LHsExpr GhcTcId -> TcSigmaType -- Function and its type+         -> [LHsExprArgIn]                 -- Arguments+         -> ExpRhoType                     -- Overall result type+         -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])+            -- (wrapper-for-result, fun, args)+            -- For an ordinary function application,+            -- these should be assembled as wrap_res[ fun args ]+            -- But OpApp is slightly different, so that's why the caller+            -- must assemble++-- tcFunApp deals with the general case;+-- the special cases are handled by tcApp+tcFunApp m_herald rn_fun tc_fun fun_sigma rn_args res_ty+  = do { let orig = lexprCtOrigin rn_fun++       ; traceTc "tcFunApp" (ppr rn_fun <+> dcolon <+> ppr fun_sigma $$ ppr rn_args $$ ppr res_ty)+       ; (wrap_fun, tc_args, actual_res_ty)+           <- tcArgs rn_fun fun_sigma orig rn_args+                     (m_herald `orElse` mk_app_msg rn_fun rn_args)++            -- this is just like tcWrapResult, but the types don't line+            -- up to call that function+       ; wrap_res <- addFunResCtxt True (unLoc rn_fun) actual_res_ty res_ty $+                     tcSubTypeDS_NC_O orig GenSigCtxt+                       (Just $ unLoc $ wrapHsArgs rn_fun rn_args)+                       actual_res_ty res_ty++       ; return (wrap_res, mkLHsWrap wrap_fun tc_fun, tc_args) }++mk_app_msg :: LHsExpr GhcRn -> [LHsExprArgIn] -> SDoc+mk_app_msg fun args = sep [ text "The" <+> text what <+> quotes (ppr expr)+                          , text "is applied to"]+  where+    what | null type_app_args = "function"+         | otherwise          = "expression"+    -- Include visible type arguments (but not other arguments) in the herald.+    -- See Note [Herald for matchExpectedFunTys] in TcUnify.+    expr = mkHsAppTypes fun type_app_args+    type_app_args = [hs_ty | HsTypeArg _ hs_ty <- args]++mk_op_msg :: LHsExpr GhcRn -> SDoc+mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes"++{-+Note [Visible type application for the empty list constructor]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Getting the expression [] @Int to typecheck is slightly tricky since [] isn't+an ordinary data constructor. By default, when tcExpr typechecks a list+expression, it wraps the expression in a coercion, which gives it a type to the+effect of p[a]. It isn't until later zonking that the type becomes+forall a. [a], but that's too late for visible type application.++The workaround is to check for empty list expressions that have a visible type+argument in tcApp, and if so, directly typecheck [] @ty data constructor name.+This avoids the intermediate coercion and produces an expression of type [ty],+as one would intuitively expect.++Unfortunately, this workaround isn't terribly robust, since more involved+expressions such as (let in []) @Int won't work. Until a more elegant fix comes+along, however, this at least allows direct type application on [] to work,+which is better than before.+-}++----------------+tcInferFun :: LHsExpr GhcRn -> TcM (LHsExpr GhcTcId, TcSigmaType)+-- Infer type of a function+tcInferFun (L loc (HsVar _ (L _ name)))+  = do { (fun, ty) <- setSrcSpan loc (tcInferId name)+               -- Don't wrap a context around a plain Id+       ; return (L loc fun, ty) }++tcInferFun (L loc (HsRecFld _ f))+  = do { (fun, ty) <- setSrcSpan loc (tcInferRecSelId f)+               -- Don't wrap a context around a plain Id+       ; return (L loc fun, ty) }++tcInferFun fun+  = tcInferSigma fun+      -- NB: tcInferSigma; see TcUnify+      -- Note [Deep instantiation of InferResult] in TcUnify+++----------------+-- | Type-check the arguments to a function, possibly including visible type+-- applications+tcArgs :: LHsExpr GhcRn   -- ^ The function itself (for err msgs only)+       -> TcSigmaType    -- ^ the (uninstantiated) type of the function+       -> CtOrigin       -- ^ the origin for the function's type+       -> [LHsExprArgIn] -- ^ the args+       -> SDoc           -- ^ the herald for matchActualFunTys+       -> TcM (HsWrapper, [LHsExprArgOut], TcSigmaType)+          -- ^ (a wrapper for the function, the tc'd args, result type)+tcArgs fun orig_fun_ty fun_orig orig_args herald+  = go [] 1 orig_fun_ty orig_args+  where+    -- Don't count visible type arguments when determining how many arguments+    -- an expression is given in an arity mismatch error, since visible type+    -- arguments reported as a part of the expression herald itself.+    -- See Note [Herald for matchExpectedFunTys] in TcUnify.+    orig_expr_args_arity = count isHsValArg orig_args++    go _ _ fun_ty [] = return (idHsWrapper, [], fun_ty)++    go acc_args n fun_ty (HsArgPar sp : args)+      = do { (inner_wrap, args', res_ty) <- go acc_args n fun_ty args+           ; return (inner_wrap, HsArgPar sp : args', res_ty)+           }++    go acc_args n fun_ty (HsTypeArg l hs_ty_arg : args)+      = do { (wrap1, upsilon_ty) <- topInstantiateInferred fun_orig fun_ty+               -- wrap1 :: fun_ty "->" upsilon_ty+           ; case tcSplitForAllTy_maybe upsilon_ty of+               Just (tvb, inner_ty)+                 | binderArgFlag tvb == Specified ->+                   -- It really can't be Inferred, because we've justn+                   -- instantiated those. But, oddly, it might just be Required.+                   -- See Note [Required quantifiers in the type of a term]+                 do { let tv   = binderVar tvb+                          kind = tyVarKind tv+                    ; ty_arg <- tcHsTypeApp hs_ty_arg kind++                    ; inner_ty <- zonkTcType inner_ty+                          -- See Note [Visible type application zonk]+                    ; let in_scope  = mkInScopeSet (tyCoVarsOfTypes [upsilon_ty, ty_arg])++                          insted_ty = substTyWithInScope in_scope [tv] [ty_arg] inner_ty+                                      -- NB: tv and ty_arg have the same kind, so this+                                      --     substitution is kind-respecting+                    ; traceTc "VTA" (vcat [ppr tv, debugPprType kind+                                          , debugPprType ty_arg+                                          , debugPprType (tcTypeKind ty_arg)+                                          , debugPprType inner_ty+                                          , debugPprType insted_ty ])++                    ; (inner_wrap, args', res_ty)+                        <- go acc_args (n+1) insted_ty args+                   -- inner_wrap :: insted_ty "->" (map typeOf args') -> res_ty+                    ; let inst_wrap = mkWpTyApps [ty_arg]+                    ; return ( inner_wrap <.> inst_wrap <.> wrap1+                             , HsTypeArg l hs_ty_arg : args'+                             , res_ty ) }+               _ -> ty_app_err upsilon_ty hs_ty_arg }++    go acc_args n fun_ty (HsValArg arg : args)+      = do { (wrap, [arg_ty], res_ty)+               <- matchActualFunTysPart herald fun_orig (Just (unLoc fun)) 1 fun_ty+                                        acc_args orig_expr_args_arity+               -- wrap :: fun_ty "->" arg_ty -> res_ty+           ; arg' <- tcArg fun arg arg_ty n+           ; (inner_wrap, args', inner_res_ty)+               <- go (arg_ty : acc_args) (n+1) res_ty args+               -- inner_wrap :: res_ty "->" (map typeOf args') -> inner_res_ty+           ; return ( mkWpFun idHsWrapper inner_wrap arg_ty res_ty doc <.> wrap+                    , HsValArg arg' : args'+                    , inner_res_ty ) }+      where+        doc = text "When checking the" <+> speakNth n <+>+              text "argument to" <+> quotes (ppr fun)++    ty_app_err ty arg+      = do { (_, ty) <- zonkTidyTcType emptyTidyEnv ty+           ; failWith $+               text "Cannot apply expression of type" <+> quotes (ppr ty) $$+               text "to a visible type argument" <+> quotes (ppr arg) }++{- Note [Required quantifiers in the type of a term]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#15859)++  data A k :: k -> Type      -- A      :: forall k -> k -> Type+  type KindOf (a :: k) = k   -- KindOf :: forall k. k -> Type+  a = (undefind :: KindOf A) @Int++With ImpredicativeTypes (thin ice, I know), we instantiate+KindOf at type (forall k -> k -> Type), so+  KindOf A = forall k -> k -> Type+whose first argument is Required++We want to reject this type application to Int, but in earlier+GHCs we had an ASSERT that Required could not occur here.++The ice is thin; c.f. Note [No Required TyCoBinder in terms]+in TyCoRep.++Note [Visible type application zonk]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Substitutions should be kind-preserving, so we need kind(tv) = kind(ty_arg).++* tcHsTypeApp only guarantees that+    - ty_arg is zonked+    - kind(zonk(tv)) = kind(ty_arg)+  (checkExpectedKind zonks as it goes).++So we must zonk inner_ty as well, to guarantee consistency between zonk(tv)+and inner_ty.  Otherwise we can build an ill-kinded type.  An example was+#14158, where we had:+   id :: forall k. forall (cat :: k -> k -> *). forall (a :: k). cat a a+and we had the visible type application+  id @(->)++* We instantiated k := kappa, yielding+    forall (cat :: kappa -> kappa -> *). forall (a :: kappa). cat a a+* Then we called tcHsTypeApp (->) with expected kind (kappa -> kappa -> *).+* That instantiated (->) as ((->) q1 q1), and unified kappa := q1,+  Here q1 :: RuntimeRep+* Now we substitute+     cat  :->  (->) q1 q1 :: TYPE q1 -> TYPE q1 -> *+  but we must first zonk the inner_ty to get+      forall (a :: TYPE q1). cat a a+  so that the result of substitution is well-kinded+  Failing to do so led to #14158.+-}++----------------+tcArg :: LHsExpr GhcRn                   -- The function (for error messages)+      -> LHsExpr GhcRn                   -- Actual arguments+      -> TcRhoType                       -- expected arg type+      -> Int                             -- # of argument+      -> TcM (LHsExpr GhcTcId)           -- Resulting argument+tcArg fun arg ty arg_no = addErrCtxt (funAppCtxt fun arg arg_no) $+                          tcPolyExprNC arg ty++----------------+tcTupArgs :: [LHsTupArg GhcRn] -> [TcSigmaType] -> TcM [LHsTupArg GhcTcId]+tcTupArgs args tys+  = ASSERT( equalLength args tys ) mapM go (args `zip` tys)+  where+    go (L l (Missing {}),   arg_ty) = return (L l (Missing arg_ty))+    go (L l (Present x expr), arg_ty) = do { expr' <- tcPolyExpr expr arg_ty+                                           ; return (L l (Present x expr')) }+    go (L _ (XTupArg{}), _) = panic "tcTupArgs"++---------------------------+-- See TcType.SyntaxOpType also for commentary+tcSyntaxOp :: CtOrigin+           -> SyntaxExpr GhcRn+           -> [SyntaxOpType]           -- ^ shape of syntax operator arguments+           -> ExpRhoType               -- ^ overall result type+           -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments+           -> TcM (a, SyntaxExpr GhcTcId)+-- ^ Typecheck a syntax operator+-- The operator is a variable or a lambda at this stage (i.e. renamer+-- output)+tcSyntaxOp orig expr arg_tys res_ty+  = tcSyntaxOpGen orig expr arg_tys (SynType res_ty)++-- | Slightly more general version of 'tcSyntaxOp' that allows the caller+-- to specify the shape of the result of the syntax operator+tcSyntaxOpGen :: CtOrigin+              -> SyntaxExpr GhcRn+              -> [SyntaxOpType]+              -> SyntaxOpType+              -> ([TcSigmaType] -> TcM a)+              -> TcM (a, SyntaxExpr GhcTcId)+tcSyntaxOpGen orig op arg_tys res_ty thing_inside+  = do { (expr, sigma) <- tcInferSigma $ noLoc $ syn_expr op+       ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma)+       ; (result, expr_wrap, arg_wraps, res_wrap)+           <- tcSynArgA orig sigma arg_tys res_ty $+              thing_inside+       ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma )+       ; return (result, SyntaxExpr { syn_expr = mkHsWrap expr_wrap $ unLoc expr+                                    , syn_arg_wraps = arg_wraps+                                    , syn_res_wrap  = res_wrap }) }++{-+Note [tcSynArg]+~~~~~~~~~~~~~~~+Because of the rich structure of SyntaxOpType, we must do the+contra-/covariant thing when working down arrows, to get the+instantiation vs. skolemisation decisions correct (and, more+obviously, the orientation of the HsWrappers). We thus have+two tcSynArgs.+-}++-- works on "expected" types, skolemising where necessary+-- See Note [tcSynArg]+tcSynArgE :: CtOrigin+          -> TcSigmaType+          -> SyntaxOpType                -- ^ shape it is expected to have+          -> ([TcSigmaType] -> TcM a)    -- ^ check the arguments+          -> TcM (a, HsWrapper)+           -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)+tcSynArgE orig sigma_ty syn_ty thing_inside+  = do { (skol_wrap, (result, ty_wrapper))+           <- tcSkolemise GenSigCtxt sigma_ty $ \ _ rho_ty ->+              go rho_ty syn_ty+       ; return (result, skol_wrap <.> ty_wrapper) }+    where+    go rho_ty SynAny+      = do { result <- thing_inside [rho_ty]+           ; return (result, idHsWrapper) }++    go rho_ty SynRho   -- same as SynAny, because we skolemise eagerly+      = do { result <- thing_inside [rho_ty]+           ; return (result, idHsWrapper) }++    go rho_ty SynList+      = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty+           ; result <- thing_inside [elt_ty]+           ; return (result, mkWpCastN list_co) }++    go rho_ty (SynFun arg_shape res_shape)+      = do { ( ( ( (result, arg_ty, res_ty)+                 , res_wrapper )                   -- :: res_ty_out "->" res_ty+               , arg_wrapper1, [], arg_wrapper2 )  -- :: arg_ty "->" arg_ty_out+             , match_wrapper )         -- :: (arg_ty -> res_ty) "->" rho_ty+               <- matchExpectedFunTys herald 1 (mkCheckExpType rho_ty) $+                  \ [arg_ty] res_ty ->+                  do { arg_tc_ty <- expTypeToType arg_ty+                     ; res_tc_ty <- expTypeToType res_ty++                         -- another nested arrow is too much for now,+                         -- but I bet we'll never need this+                     ; MASSERT2( case arg_shape of+                                   SynFun {} -> False;+                                   _         -> True+                               , text "Too many nested arrows in SyntaxOpType" $$+                                 pprCtOrigin orig )++                     ; tcSynArgA orig arg_tc_ty [] arg_shape $+                       \ arg_results ->+                       tcSynArgE orig res_tc_ty res_shape $+                       \ res_results ->+                       do { result <- thing_inside (arg_results ++ res_results)+                          ; return (result, arg_tc_ty, res_tc_ty) }}++           ; return ( result+                    , match_wrapper <.>+                      mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper+                              arg_ty res_ty doc ) }+      where+        herald = text "This rebindable syntax expects a function with"+        doc = text "When checking a rebindable syntax operator arising from" <+> ppr orig++    go rho_ty (SynType the_ty)+      = do { wrap   <- tcSubTypeET orig GenSigCtxt the_ty rho_ty+           ; result <- thing_inside []+           ; return (result, wrap) }++-- works on "actual" types, instantiating where necessary+-- See Note [tcSynArg]+tcSynArgA :: CtOrigin+          -> TcSigmaType+          -> [SyntaxOpType]              -- ^ argument shapes+          -> SyntaxOpType                -- ^ result shape+          -> ([TcSigmaType] -> TcM a)    -- ^ check the arguments+          -> TcM (a, HsWrapper, [HsWrapper], HsWrapper)+            -- ^ returns a wrapper to be applied to the original function,+            -- wrappers to be applied to arguments+            -- and a wrapper to be applied to the overall expression+tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside+  = do { (match_wrapper, arg_tys, res_ty)+           <- matchActualFunTys herald orig Nothing (length arg_shapes) sigma_ty+              -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)+       ; ((result, res_wrapper), arg_wrappers)+           <- tc_syn_args_e arg_tys arg_shapes $ \ arg_results ->+              tc_syn_arg    res_ty  res_shape  $ \ res_results ->+              thing_inside (arg_results ++ res_results)+       ; return (result, match_wrapper, arg_wrappers, res_wrapper) }+  where+    herald = text "This rebindable syntax expects a function with"++    tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]+                  -> ([TcSigmaType] -> TcM a)+                  -> TcM (a, [HsWrapper])+                    -- the wrappers are for arguments+    tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside+      = do { ((result, arg_wraps), arg_wrap)+               <- tcSynArgE     orig arg_ty  arg_shape  $ \ arg1_results ->+                  tc_syn_args_e      arg_tys arg_shapes $ \ args_results ->+                  thing_inside (arg1_results ++ args_results)+           ; return (result, arg_wrap : arg_wraps) }+    tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside []++    tc_syn_arg :: TcSigmaType -> SyntaxOpType+               -> ([TcSigmaType] -> TcM a)+               -> TcM (a, HsWrapper)+                  -- the wrapper applies to the overall result+    tc_syn_arg res_ty SynAny thing_inside+      = do { result <- thing_inside [res_ty]+           ; return (result, idHsWrapper) }+    tc_syn_arg res_ty SynRho thing_inside+      = do { (inst_wrap, rho_ty) <- deeplyInstantiate orig res_ty+               -- inst_wrap :: res_ty "->" rho_ty+           ; result <- thing_inside [rho_ty]+           ; return (result, inst_wrap) }+    tc_syn_arg res_ty SynList thing_inside+      = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty+               -- inst_wrap :: res_ty "->" rho_ty+           ; (list_co, elt_ty)   <- matchExpectedListTy rho_ty+               -- list_co :: [elt_ty] ~N rho_ty+           ; result <- thing_inside [elt_ty]+           ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) }+    tc_syn_arg _ (SynFun {}) _+      = pprPanic "tcSynArgA hits a SynFun" (ppr orig)+    tc_syn_arg res_ty (SynType the_ty) thing_inside+      = do { wrap   <- tcSubTypeO orig GenSigCtxt res_ty the_ty+           ; result <- thing_inside []+           ; return (result, wrap) }++{-+Note [Push result type in]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Unify with expected result before type-checking the args so that the+info from res_ty percolates to args.  This is when we might detect a+too-few args situation.  (One can think of cases when the opposite+order would give a better error message.)+experimenting with putting this first.++Here's an example where it actually makes a real difference++   class C t a b | t a -> b+   instance C Char a Bool++   data P t a = forall b. (C t a b) => MkP b+   data Q t   = MkQ (forall a. P t a)++   f1, f2 :: Q Char;+   f1 = MkQ (MkP True)+   f2 = MkQ (MkP True :: forall a. P Char a)++With the change, f1 will type-check, because the 'Char' info from+the signature is propagated into MkQ's argument. With the check+in the other order, the extra signature in f2 is reqd.++************************************************************************+*                                                                      *+                Expressions with a type signature+                        expr :: type+*                                                                      *+********************************************************************* -}++tcExprSig :: LHsExpr GhcRn -> TcIdSigInfo -> TcM (LHsExpr GhcTcId, TcType)+tcExprSig expr (CompleteSig { sig_bndr = poly_id, sig_loc = loc })+  = setSrcSpan loc $   -- Sets the location for the implication constraint+    do { (tv_prs, theta, tau) <- tcInstType tcInstSkolTyVars poly_id+       ; given <- newEvVars theta+       ; traceTc "tcExprSig: CompleteSig" $+         vcat [ text "poly_id:" <+> ppr poly_id <+> dcolon <+> ppr (idType poly_id)+              , text "tv_prs:" <+> ppr tv_prs ]++       ; let skol_info = SigSkol ExprSigCtxt (idType poly_id) tv_prs+             skol_tvs  = map snd tv_prs+       ; (ev_binds, expr') <- checkConstraints skol_info skol_tvs given $+                              tcExtendNameTyVarEnv tv_prs $+                              tcPolyExprNC expr tau++       ; let poly_wrap = mkWpTyLams   skol_tvs+                         <.> mkWpLams given+                         <.> mkWpLet  ev_binds+       ; return (mkLHsWrap poly_wrap expr', idType poly_id) }++tcExprSig expr sig@(PartialSig { psig_name = name, sig_loc = loc })+  = setSrcSpan loc $   -- Sets the location for the implication constraint+    do { (tclvl, wanted, (expr', sig_inst))+             <- pushLevelAndCaptureConstraints  $+                do { sig_inst <- tcInstSig sig+                   ; expr' <- tcExtendNameTyVarEnv (sig_inst_skols sig_inst) $+                              tcExtendNameTyVarEnv (sig_inst_wcs   sig_inst) $+                              tcPolyExprNC expr (sig_inst_tau sig_inst)+                   ; return (expr', sig_inst) }+       -- See Note [Partial expression signatures]+       ; let tau = sig_inst_tau sig_inst+             infer_mode | null (sig_inst_theta sig_inst)+                        , isNothing (sig_inst_wcx sig_inst)+                        = ApplyMR+                        | otherwise+                        = NoRestrictions+       ; (qtvs, givens, ev_binds, residual, _)+                 <- simplifyInfer tclvl infer_mode [sig_inst] [(name, tau)] wanted+       ; emitConstraints residual++       ; tau <- zonkTcType tau+       ; let inferred_theta = map evVarPred givens+             tau_tvs        = tyCoVarsOfType tau+       ; (binders, my_theta) <- chooseInferredQuantifiers inferred_theta+                                   tau_tvs qtvs (Just sig_inst)+       ; let inferred_sigma = mkInfSigmaTy qtvs inferred_theta tau+             my_sigma       = mkForAllTys binders (mkPhiTy  my_theta tau)+       ; wrap <- if inferred_sigma `eqType` my_sigma -- NB: eqType ignores vis.+                 then return idHsWrapper  -- Fast path; also avoids complaint when we infer+                                          -- an ambiguous type and have AllowAmbiguousType+                                          -- e..g infer  x :: forall a. F a -> Int+                 else tcSubType_NC ExprSigCtxt inferred_sigma my_sigma++       ; traceTc "tcExpSig" (ppr qtvs $$ ppr givens $$ ppr inferred_sigma $$ ppr my_sigma)+       ; let poly_wrap = wrap+                         <.> mkWpTyLams qtvs+                         <.> mkWpLams givens+                         <.> mkWpLet  ev_binds+       ; return (mkLHsWrap poly_wrap expr', my_sigma) }+++{- Note [Partial expression signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Partial type signatures on expressions are easy to get wrong.  But+here is a guiding principile+    e :: ty+should behave like+    let x :: ty+        x = e+    in x++So for partial signatures we apply the MR if no context is given.  So+   e :: IO _          apply the MR+   e :: _ => IO _     do not apply the MR+just like in TcBinds.decideGeneralisationPlan++This makes a difference (#11670):+   peek :: Ptr a -> IO CLong+   peek ptr = peekElemOff undefined 0 :: _+from (peekElemOff undefined 0) we get+          type: IO w+   constraints: Storable w++We must NOT try to generalise over 'w' because the signature specifies+no constraints so we'll complain about not being able to solve+Storable w.  Instead, don't generalise; then _ gets instantiated to+CLong, as it should.+-}++{- *********************************************************************+*                                                                      *+                 tcInferId+*                                                                      *+********************************************************************* -}++tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId)+tcCheckId name res_ty+  = do { (expr, actual_res_ty) <- tcInferId name+       ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty])+       ; addFunResCtxt False (HsVar noExt (noLoc name)) actual_res_ty res_ty $+         tcWrapResultO (OccurrenceOf name) (HsVar noExt (noLoc name)) expr+                                                          actual_res_ty res_ty }++tcCheckRecSelId :: HsExpr GhcRn -> AmbiguousFieldOcc GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)+tcCheckRecSelId rn_expr f@(Unambiguous _ (L _ lbl)) res_ty+  = do { (expr, actual_res_ty) <- tcInferRecSelId f+       ; addFunResCtxt False (HsRecFld noExt f) actual_res_ty res_ty $+         tcWrapResultO (OccurrenceOfRecSel lbl) rn_expr expr actual_res_ty res_ty }+tcCheckRecSelId rn_expr (Ambiguous _ lbl) res_ty+  = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of+      Nothing       -> ambiguousSelector lbl+      Just (arg, _) -> do { sel_name <- disambiguateSelector lbl arg+                          ; tcCheckRecSelId rn_expr (Unambiguous sel_name lbl)+                                                    res_ty }+tcCheckRecSelId _ (XAmbiguousFieldOcc _) _ = panic "tcCheckRecSelId"++------------------------+tcInferRecSelId :: AmbiguousFieldOcc GhcRn -> TcM (HsExpr GhcTcId, TcRhoType)+tcInferRecSelId (Unambiguous sel (L _ lbl))+  = do { (expr', ty) <- tc_infer_id lbl sel+       ; return (expr', ty) }+tcInferRecSelId (Ambiguous _ lbl)+  = ambiguousSelector lbl+tcInferRecSelId (XAmbiguousFieldOcc _) = panic "tcInferRecSelId"++------------------------+tcInferId :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)+-- Look up an occurrence of an Id+-- Do not instantiate its type+tcInferId id_name+  | id_name `hasKey` tagToEnumKey+  = failWithTc (text "tagToEnum# must appear applied to one argument")+        -- tcApp catches the case (tagToEnum# arg)++  | id_name `hasKey` assertIdKey+  = do { dflags <- getDynFlags+       ; if gopt Opt_IgnoreAsserts dflags+         then tc_infer_id (nameRdrName id_name) id_name+         else tc_infer_assert id_name }++  | otherwise+  = do { (expr, ty) <- tc_infer_id (nameRdrName id_name) id_name+       ; traceTc "tcInferId" (ppr id_name <+> dcolon <+> ppr ty)+       ; return (expr, ty) }++tc_infer_assert :: Name -> TcM (HsExpr GhcTcId, TcSigmaType)+-- Deal with an occurrence of 'assert'+-- See Note [Adding the implicit parameter to 'assert']+tc_infer_assert assert_name+  = do { assert_error_id <- tcLookupId assertErrorName+       ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name)+                                          (idType assert_error_id)+       ; return (mkHsWrap wrap (HsVar noExt (noLoc assert_error_id)), id_rho)+       }++tc_infer_id :: RdrName -> Name -> TcM (HsExpr GhcTcId, TcSigmaType)+tc_infer_id lbl id_name+ = do { thing <- tcLookup id_name+      ; case thing of+             ATcId { tct_id = id }+               -> do { check_naughty id        -- Note [Local record selectors]+                     ; checkThLocalId id+                     ; return_id id }++             AGlobal (AnId id)+               -> do { check_naughty id+                     ; return_id id }+                    -- A global cannot possibly be ill-staged+                    -- nor does it need the 'lifting' treatment+                    -- hence no checkTh stuff here++             AGlobal (AConLike cl) -> case cl of+                 RealDataCon con -> return_data_con con+                 PatSynCon ps    -> tcPatSynBuilderOcc ps++             _ -> failWithTc $+                  ppr thing <+> text "used where a value identifier was expected" }+  where+    return_id id = return (HsVar noExt (noLoc id), idType id)++    return_data_con con+       -- For data constructors, must perform the stupid-theta check+      | null stupid_theta+      = return (HsConLikeOut noExt (RealDataCon con), con_ty)++      | otherwise+       -- See Note [Instantiating stupid theta]+      = do { let (tvs, theta, rho) = tcSplitSigmaTy con_ty+           ; (subst, tvs') <- newMetaTyVars tvs+           ; let tys'   = mkTyVarTys tvs'+                 theta' = substTheta subst theta+                 rho'   = substTy subst rho+           ; wrap <- instCall (OccurrenceOf id_name) tys' theta'+           ; addDataConStupidTheta con tys'+           ; return ( mkHsWrap wrap (HsConLikeOut noExt (RealDataCon con))+                    , rho') }++      where+        con_ty         = dataConUserType con+        stupid_theta   = dataConStupidTheta con++    check_naughty id+      | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)+      | otherwise                  = return ()+++tcUnboundId :: HsExpr GhcRn -> UnboundVar -> ExpRhoType -> TcM (HsExpr GhcTcId)+-- Typecheck an occurrence of an unbound Id+--+-- Some of these started life as a true expression hole "_".+-- Others might simply be variables that accidentally have no binding site+--+-- We turn all of them into HsVar, since HsUnboundVar can't contain an+-- Id; and indeed the evidence for the CHoleCan does bind it, so it's+-- not unbound any more!+tcUnboundId rn_expr unbound res_ty+ = do { ty <- newOpenFlexiTyVarTy  -- Allow Int# etc (#12531)+      ; let occ = unboundVarOcc unbound+      ; name <- newSysName occ+      ; let ev = mkLocalId name ty+      ; can <- newHoleCt (ExprHole unbound) ev ty+      ; emitInsoluble can+      ; tcWrapResultO (UnboundOccurrenceOf occ) rn_expr (HsVar noExt (noLoc ev))+                                                                     ty res_ty }+++{-+Note [Adding the implicit parameter to 'assert']+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The typechecker transforms (assert e1 e2) to (assertError e1 e2).+This isn't really the Right Thing because there's no way to "undo"+if you want to see the original source code in the typechecker+output.  We'll have fix this in due course, when we care more about+being able to reconstruct the exact original program.++Note [tagToEnum#]+~~~~~~~~~~~~~~~~~+Nasty check to ensure that tagToEnum# is applied to a type that is an+enumeration TyCon.  Unification may refine the type later, but this+check won't see that, alas.  It's crude, because it relies on our+knowing *now* that the type is ok, which in turn relies on the+eager-unification part of the type checker pushing enough information+here.  In theory the Right Thing to do is to have a new form of+constraint but I definitely cannot face that!  And it works ok as-is.++Here's are two cases that should fail+        f :: forall a. a+        f = tagToEnum# 0        -- Can't do tagToEnum# at a type variable++        g :: Int+        g = tagToEnum# 0        -- Int is not an enumeration++When data type families are involved it's a bit more complicated.+     data family F a+     data instance F [Int] = A | B | C+Then we want to generate something like+     tagToEnum# R:FListInt 3# |> co :: R:FListInt ~ F [Int]+Usually that coercion is hidden inside the wrappers for+constructors of F [Int] but here we have to do it explicitly.++It's all grotesquely complicated.++Note [Instantiating stupid theta]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Normally, when we infer the type of an Id, we don't instantiate,+because we wish to allow for visible type application later on.+But if a datacon has a stupid theta, we're a bit stuck. We need+to emit the stupid theta constraints with instantiated types. It's+difficult to defer this to the lazy instantiation, because a stupid+theta has no spot to put it in a type. So we just instantiate eagerly+in this case. Thus, users cannot use visible type application with+a data constructor sporting a stupid theta. I won't feel so bad for+the users that complain.++-}++tcTagToEnum :: SrcSpan -> Name -> [LHsExprArgIn] -> ExpRhoType+            -> TcM (HsWrapper, LHsExpr GhcTcId, [LHsExprArgOut])+-- tagToEnum# :: forall a. Int# -> a+-- See Note [tagToEnum#]   Urgh!+tcTagToEnum loc fun_name args res_ty+  = do { fun <- tcLookupId fun_name++       ; let pars1 = mapMaybe isArgPar_maybe before+             pars2 = mapMaybe isArgPar_maybe after+             -- args contains exactly one HsValArg+             (before, _:after) = break isHsValArg args++       ; arg <- case filterOut isArgPar args of+           [HsTypeArg _ hs_ty_arg, HsValArg term_arg]+             -> do { ty_arg <- tcHsTypeApp hs_ty_arg liftedTypeKind+                   ; _ <- tcSubTypeDS (OccurrenceOf fun_name) GenSigCtxt ty_arg res_ty+                     -- other than influencing res_ty, we just+                     -- don't care about a type arg passed in.+                     -- So drop the evidence.+                   ; return term_arg }+           [HsValArg term_arg] -> do { _ <- expTypeToType res_ty+                                     ; return term_arg }+           _          -> too_many_args "tagToEnum#" args++       ; res_ty <- readExpType res_ty+       ; ty'    <- zonkTcType res_ty++       -- Check that the type is algebraic+       ; let mb_tc_app = tcSplitTyConApp_maybe ty'+             Just (tc, tc_args) = mb_tc_app+       ; checkTc (isJust mb_tc_app)+                 (mk_error ty' doc1)++       -- Look through any type family+       ; fam_envs <- tcGetFamInstEnvs+       ; let (rep_tc, rep_args, coi)+               = tcLookupDataFamInst fam_envs tc tc_args+            -- coi :: tc tc_args ~R rep_tc rep_args++       ; checkTc (isEnumerationTyCon rep_tc)+                 (mk_error ty' doc2)++       ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy)+       ; let fun' = L loc (mkHsWrap (WpTyApp rep_ty) (HsVar noExt (L loc fun)))+             rep_ty = mkTyConApp rep_tc rep_args+             out_args = concat+              [ pars1+              , [HsValArg arg']+              , pars2+              ]++       ; return (mkWpCastR (mkTcSymCo coi), fun', out_args) }+                 -- coi is a Representational coercion+  where+    doc1 = vcat [ text "Specify the type by giving a type signature"+                , text "e.g. (tagToEnum# x) :: Bool" ]+    doc2 = text "Result type must be an enumeration type"++    mk_error :: TcType -> SDoc -> SDoc+    mk_error ty what+      = hang (text "Bad call to tagToEnum#"+               <+> text "at type" <+> ppr ty)+           2 what++too_many_args :: String -> [LHsExprArgIn] -> TcM a+too_many_args fun args+  = failWith $+    hang (text "Too many type arguments to" <+> text fun <> colon)+       2 (sep (map pp args))+  where+    pp (HsValArg e)                             = ppr e+    pp (HsTypeArg _ (HsWC { hswc_body = L _ t })) = pprHsType t+    pp (HsTypeArg _ (XHsWildCardBndrs _)) = panic "too_many_args"+    pp (HsArgPar _) = empty+++{-+************************************************************************+*                                                                      *+                 Template Haskell checks+*                                                                      *+************************************************************************+-}++checkThLocalId :: Id -> TcM ()+checkThLocalId id+  = do  { mb_local_use <- getStageAndBindLevel (idName id)+        ; case mb_local_use of+             Just (top_lvl, bind_lvl, use_stage)+                | thLevel use_stage > bind_lvl+                -> checkCrossStageLifting top_lvl id use_stage+             _  -> return ()   -- Not a locally-bound thing, or+                               -- no cross-stage link+    }++--------------------------------------+checkCrossStageLifting :: TopLevelFlag -> Id -> ThStage -> TcM ()+-- If we are inside typed brackets, and (use_lvl > bind_lvl)+-- we must check whether there's a cross-stage lift to do+-- Examples   \x -> [|| x ||]+--            [|| map ||]+-- There is no error-checking to do, because the renamer did that+--+-- This is similar to checkCrossStageLifting in RnSplice, but+-- this code is applied to *typed* brackets.++checkCrossStageLifting top_lvl id (Brack _ (TcPending ps_var lie_var))+  | isTopLevel top_lvl+  = when (isExternalName id_name) (keepAlive id_name)+    -- See Note [Keeping things alive for Template Haskell] in RnSplice++  | otherwise+  =     -- Nested identifiers, such as 'x' in+        -- E.g. \x -> [|| h x ||]+        -- We must behave as if the reference to x was+        --      h $(lift x)+        -- We use 'x' itself as the splice proxy, used by+        -- the desugarer to stitch it all back together.+        -- If 'x' occurs many times we may get many identical+        -- bindings of the same splice proxy, but that doesn't+        -- matter, although it's a mite untidy.+    do  { let id_ty = idType id+        ; checkTc (isTauTy id_ty) (polySpliceErr id)+               -- If x is polymorphic, its occurrence sites might+               -- have different instantiations, so we can't use plain+               -- 'x' as the splice proxy name.  I don't know how to+               -- solve this, and it's probably unimportant, so I'm+               -- just going to flag an error for now++        ; lift <- if isStringTy id_ty then+                     do { sid <- tcLookupId THNames.liftStringName+                                     -- See Note [Lifting strings]+                        ; return (HsVar noExt (noLoc sid)) }+                  else+                     setConstraintVar lie_var   $+                          -- Put the 'lift' constraint into the right LIE+                     newMethodFromName (OccurrenceOf id_name)+                                       THNames.liftName+                                       [getRuntimeRep id_ty, id_ty]++                   -- Update the pending splices+        ; ps <- readMutVar ps_var+        ; let pending_splice = PendingTcSplice id_name+                                 (nlHsApp (noLoc lift) (nlHsVar id))+        ; writeMutVar ps_var (pending_splice : ps)++        ; return () }+  where+    id_name = idName id++checkCrossStageLifting _ _ _ = return ()++polySpliceErr :: Id -> SDoc+polySpliceErr id+  = text "Can't splice the polymorphic local variable" <+> quotes (ppr id)++{-+Note [Lifting strings]+~~~~~~~~~~~~~~~~~~~~~~+If we see $(... [| s |] ...) where s::String, we don't want to+generate a mass of Cons (CharL 'x') (Cons (CharL 'y') ...)) etc.+So this conditional short-circuits the lifting mechanism to generate+(liftString "xy") in that case.  I didn't want to use overlapping instances+for the Lift class in TH.Syntax, because that can lead to overlapping-instance+errors in a polymorphic situation.++If this check fails (which isn't impossible) we get another chance; see+Note [Converting strings] in Convert.hs++Local record selectors+~~~~~~~~~~~~~~~~~~~~~~+Record selectors for TyCons in this module are ordinary local bindings,+which show up as ATcIds rather than AGlobals.  So we need to check for+naughtiness in both branches.  c.f. TcTyClsBindings.mkAuxBinds.+++************************************************************************+*                                                                      *+\subsection{Record bindings}+*                                                                      *+************************************************************************+-}++getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet+-- These tyvars must not change across the updates+getFixedTyVars upd_fld_occs univ_tvs cons+      = mkVarSet [tv1 | con <- cons+                      , let (u_tvs, _, eqspec, prov_theta+                             , req_theta, arg_tys, _)+                              = conLikeFullSig con+                            theta = eqSpecPreds eqspec+                                     ++ prov_theta+                                     ++ req_theta+                            flds = conLikeFieldLabels con+                            fixed_tvs = exactTyCoVarsOfTypes fixed_tys+                                    -- fixed_tys: See Note [Type of a record update]+                                        `unionVarSet` tyCoVarsOfTypes theta+                                    -- Universally-quantified tyvars that+                                    -- appear in any of the *implicit*+                                    -- arguments to the constructor are fixed+                                    -- See Note [Implicit type sharing]++                            fixed_tys = [ty | (fl, ty) <- zip flds arg_tys+                                            , not (flLabel fl `elem` upd_fld_occs)]+                      , (tv1,tv) <- univ_tvs `zip` u_tvs+                      , tv `elemVarSet` fixed_tvs ]++{-+Note [Disambiguating record fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the -XDuplicateRecordFields extension is used, and the renamer+encounters a record selector or update that it cannot immediately+disambiguate (because it involves fields that belong to multiple+datatypes), it will defer resolution of the ambiguity to the+typechecker.  In this case, the `Ambiguous` constructor of+`AmbiguousFieldOcc` is used.++Consider the following definitions:++        data S = MkS { foo :: Int }+        data T = MkT { foo :: Int, bar :: Int }+        data U = MkU { bar :: Int, baz :: Int }++When the renamer sees `foo` as a selector or an update, it will not+know which parent datatype is in use.++For selectors, there are two possible ways to disambiguate:++1. Check if the pushed-in type is a function whose domain is a+   datatype, for example:++       f s = (foo :: S -> Int) s++       g :: T -> Int+       g = foo++    This is checked by `tcCheckRecSelId` when checking `HsRecFld foo`.++2. Check if the selector is applied to an argument that has a type+   signature, for example:++       h = foo (s :: S)++    This is checked by `tcApp`.+++Updates are slightly more complex.  The `disambiguateRecordBinds`+function tries to determine the parent datatype in three ways:++1. Check for types that have all the fields being updated. For example:++        f x = x { foo = 3, bar = 2 }++   Here `f` must be updating `T` because neither `S` nor `U` have+   both fields. This may also discover that no possible type exists.+   For example the following will be rejected:++        f' x = x { foo = 3, baz = 3 }++2. Use the type being pushed in, if it is already a TyConApp. The+   following are valid updates to `T`:++        g :: T -> T+        g x = x { foo = 3 }++        g' x = x { foo = 3 } :: T++3. Use the type signature of the record expression, if it exists and+   is a TyConApp. Thus this is valid update to `T`:++        h x = (x :: T) { foo = 3 }+++Note that we do not look up the types of variables being updated, and+no constraint-solving is performed, so for example the following will+be rejected as ambiguous:++     let bad (s :: S) = foo s++     let r :: T+         r = blah+     in r { foo = 3 }++     \r. (r { foo = 3 },  r :: T )++We could add further tests, of a more heuristic nature. For example,+rather than looking for an explicit signature, we could try to infer+the type of the argument to a selector or the record expression being+updated, in case we are lucky enough to get a TyConApp straight+away. However, it might be hard for programmers to predict whether a+particular update is sufficiently obvious for the signature to be+omitted. Moreover, this might change the behaviour of typechecker in+non-obvious ways.++See also Note [HsRecField and HsRecUpdField] in HsPat.+-}++-- Given a RdrName that refers to multiple record fields, and the type+-- of its argument, try to determine the name of the selector that is+-- meant.+disambiguateSelector :: Located RdrName -> Type -> TcM Name+disambiguateSelector lr@(L _ rdr) parent_type+ = do { fam_inst_envs <- tcGetFamInstEnvs+      ; case tyConOf fam_inst_envs parent_type of+          Nothing -> ambiguousSelector lr+          Just p  ->+            do { xs <- lookupParents rdr+               ; let parent = RecSelData p+               ; case lookup parent xs of+                   Just gre -> do { addUsedGRE True gre+                                  ; return (gre_name gre) }+                   Nothing  -> failWithTc (fieldNotInType parent rdr) } }++-- This field name really is ambiguous, so add a suitable "ambiguous+-- occurrence" error, then give up.+ambiguousSelector :: Located RdrName -> TcM a+ambiguousSelector (L _ rdr)+  = do { env <- getGlobalRdrEnv+       ; let gres = lookupGRE_RdrName rdr env+       ; setErrCtxt [] $ addNameClashErrRn rdr gres+       ; failM }++-- Disambiguate the fields in a record update.+-- See Note [Disambiguating record fields]+disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType+                 -> [LHsRecUpdField GhcRn] -> ExpRhoType+                 -> TcM [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]+disambiguateRecordBinds record_expr record_rho rbnds res_ty+    -- Are all the fields unambiguous?+  = case mapM isUnambiguous rbnds of+                     -- If so, just skip to looking up the Ids+                     -- Always the case if DuplicateRecordFields is off+      Just rbnds' -> mapM lookupSelector rbnds'+      Nothing     -> -- If not, try to identify a single parent+        do { fam_inst_envs <- tcGetFamInstEnvs+             -- Look up the possible parents for each field+           ; rbnds_with_parents <- getUpdFieldsParents+           ; let possible_parents = map (map fst . snd) rbnds_with_parents+             -- Identify a single parent+           ; p <- identifyParent fam_inst_envs possible_parents+             -- Pick the right selector with that parent for each field+           ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents }+  where+    -- Extract the selector name of a field update if it is unambiguous+    isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)+    isUnambiguous x = case unLoc (hsRecFieldLbl (unLoc x)) of+                        Unambiguous sel_name _ -> Just (x, sel_name)+                        Ambiguous{}            -> Nothing+                        XAmbiguousFieldOcc{}   -> Nothing++    -- Look up the possible parents and selector GREs for each field+    getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn+                                , [(RecSelParent, GlobalRdrElt)])]+    getUpdFieldsParents+      = fmap (zip rbnds) $ mapM+          (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc)+          rbnds++    -- Given a the lists of possible parents for each field,+    -- identify a single parent+    identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent+    identifyParent fam_inst_envs possible_parents+      = case foldr1 intersect possible_parents of+        -- No parents for all fields: record update is ill-typed+        []  -> failWithTc (noPossibleParents rbnds)++        -- Exactly one datatype with all the fields: use that+        [p] -> return p++        -- Multiple possible parents: try harder to disambiguate+        -- Can we get a parent TyCon from the pushed-in type?+        _:_ | Just p <- tyConOfET fam_inst_envs res_ty -> return (RecSelData p)++        -- Does the expression being updated have a type signature?+        -- If so, try to extract a parent TyCon from it+            | Just {} <- obviousSig (unLoc record_expr)+            , Just tc <- tyConOf fam_inst_envs record_rho+            -> return (RecSelData tc)++        -- Nothing else we can try...+        _ -> failWithTc badOverloadedUpdate++    -- Make a field unambiguous by choosing the given parent.+    -- Emits an error if the field cannot have that parent,+    -- e.g. if the user writes+    --     r { x = e } :: T+    -- where T does not have field x.+    pickParent :: RecSelParent+               -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])+               -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))+    pickParent p (upd, xs)+      = case lookup p xs of+                      -- Phew! The parent is valid for this field.+                      -- Previously ambiguous fields must be marked as+                      -- used now that we know which one is meant, but+                      -- unambiguous ones shouldn't be recorded again+                      -- (giving duplicate deprecation warnings).+          Just gre -> do { unless (null (tail xs)) $ do+                             let L loc _ = hsRecFieldLbl (unLoc upd)+                             setSrcSpan loc $ addUsedGRE True gre+                         ; lookupSelector (upd, gre_name gre) }+                      -- The field doesn't belong to this parent, so report+                      -- an error but keep going through all the fields+          Nothing  -> do { addErrTc (fieldNotInType p+                                      (unLoc (hsRecUpdFieldRdr (unLoc upd))))+                         ; lookupSelector (upd, gre_name (snd (head xs))) }++    -- Given a (field update, selector name) pair, look up the+    -- selector to give a field update with an unambiguous Id+    lookupSelector :: (LHsRecUpdField GhcRn, Name)+                 -> TcM (LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))+    lookupSelector (L l upd, n)+      = do { i <- tcLookupId n+           ; let L loc af = hsRecFieldLbl upd+                 lbl      = rdrNameAmbiguousFieldOcc af+           ; return $ L l upd { hsRecFieldLbl+                                  = L loc (Unambiguous i (L loc lbl)) } }+++-- Extract the outermost TyCon of a type, if there is one; for+-- data families this is the representation tycon (because that's+-- where the fields live).+tyConOf :: FamInstEnvs -> TcSigmaType -> Maybe TyCon+tyConOf fam_inst_envs ty0+  = case tcSplitTyConApp_maybe ty of+      Just (tc, tys) -> Just (fstOf3 (tcLookupDataFamInst fam_inst_envs tc tys))+      Nothing        -> Nothing+  where+    (_, _, ty) = tcSplitSigmaTy ty0++-- Variant of tyConOf that works for ExpTypes+tyConOfET :: FamInstEnvs -> ExpRhoType -> Maybe TyCon+tyConOfET fam_inst_envs ty0 = tyConOf fam_inst_envs =<< checkingExpType_maybe ty0++-- For an ambiguous record field, find all the candidate record+-- selectors (as GlobalRdrElts) and their parents.+lookupParents :: RdrName -> RnM [(RecSelParent, GlobalRdrElt)]+lookupParents rdr+  = do { env <- getGlobalRdrEnv+       ; let gres = lookupGRE_RdrName rdr env+       ; mapM lookupParent gres }+  where+    lookupParent :: GlobalRdrElt -> RnM (RecSelParent, GlobalRdrElt)+    lookupParent gre = do { id <- tcLookupId (gre_name gre)+                          ; if isRecordSelector id+                              then return (recordSelectorTyCon id, gre)+                              else failWithTc (notSelector (gre_name gre)) }++-- A type signature on the argument of an ambiguous record selector or+-- the record expression in an update must be "obvious", i.e. the+-- outermost constructor ignoring parentheses.+obviousSig :: HsExpr GhcRn -> Maybe (LHsSigWcType GhcRn)+obviousSig (ExprWithTySig _ _ ty) = Just ty+obviousSig (HsPar _ p)          = obviousSig (unLoc p)+obviousSig _                    = Nothing+++{-+Game plan for record bindings+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+1. Find the TyCon for the bindings, from the first field label.++2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.++For each binding field = value++3. Instantiate the field type (from the field label) using the type+   envt from step 2.++4  Type check the value using tcArg, passing the field type as+   the expected argument type.++This extends OK when the field types are universally quantified.+-}++tcRecordBinds+        :: ConLike+        -> [TcType]     -- Expected type for each field+        -> HsRecordBinds GhcRn+        -> TcM (HsRecordBinds GhcTcId)++tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)+  = do  { mb_binds <- mapM do_bind rbinds+        ; return (HsRecFields (catMaybes mb_binds) dd) }+  where+    fields = map flSelector $ conLikeFieldLabels con_like+    flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys++    do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)+            -> TcM (Maybe (LHsRecField GhcTcId (LHsExpr GhcTcId)))+    do_bind (L l fld@(HsRecField { hsRecFieldLbl = f+                                 , hsRecFieldArg = rhs }))++      = do { mb <- tcRecordField con_like flds_w_tys f rhs+           ; case mb of+               Nothing         -> return Nothing+               Just (f', rhs') -> return (Just (L l (fld { hsRecFieldLbl = f'+                                                          , hsRecFieldArg = rhs' }))) }++tcRecordUpd+        :: ConLike+        -> [TcType]     -- Expected type for each field+        -> [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]+        -> TcM [LHsRecUpdField GhcTcId]++tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds+  where+    fields = map flSelector $ conLikeFieldLabels con_like+    flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys++    do_bind :: LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)+            -> TcM (Maybe (LHsRecUpdField GhcTcId))+    do_bind (L l fld@(HsRecField { hsRecFieldLbl = L loc af+                                 , hsRecFieldArg = rhs }))+      = do { let lbl = rdrNameAmbiguousFieldOcc af+                 sel_id = selectorAmbiguousFieldOcc af+                 f = L loc (FieldOcc (idName sel_id) (L loc lbl))+           ; mb <- tcRecordField con_like flds_w_tys f rhs+           ; case mb of+               Nothing         -> return Nothing+               Just (f', rhs') ->+                 return (Just+                         (L l (fld { hsRecFieldLbl+                                      = L loc (Unambiguous+                                               (extFieldOcc (unLoc f'))+                                               (L loc lbl))+                                   , hsRecFieldArg = rhs' }))) }++tcRecordField :: ConLike -> Assoc Name Type+              -> LFieldOcc GhcRn -> LHsExpr GhcRn+              -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))+tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs+  | Just field_ty <- assocMaybe flds_w_tys sel_name+      = addErrCtxt (fieldCtxt field_lbl) $+        do { rhs' <- tcPolyExprNC rhs field_ty+           ; let field_id = mkUserLocal (nameOccName sel_name)+                                        (nameUnique sel_name)+                                        field_ty loc+                -- Yuk: the field_id has the *unique* of the selector Id+                --          (so we can find it easily)+                --      but is a LocalId with the appropriate type of the RHS+                --          (so the desugarer knows the type of local binder to make)+           ; return (Just (L loc (FieldOcc field_id lbl), rhs')) }+      | otherwise+      = do { addErrTc (badFieldCon con_like field_lbl)+           ; return Nothing }+  where+        field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)+tcRecordField _ _ (L _ (XFieldOcc _)) _ = panic "tcRecordField"+++checkMissingFields ::  ConLike -> HsRecordBinds GhcRn -> TcM ()+checkMissingFields con_like rbinds+  | null field_labels   -- Not declared as a record;+                        -- But C{} is still valid if no strict fields+  = if any isBanged field_strs then+        -- Illegal if any arg is strict+        addErrTc (missingStrictFields con_like [])+    else do+        warn <- woptM Opt_WarnMissingFields+        when (warn && notNull field_strs && null field_labels)+             (warnTc (Reason Opt_WarnMissingFields) True+                 (missingFields con_like []))++  | otherwise = do              -- A record+    unless (null missing_s_fields)+           (addErrTc (missingStrictFields con_like missing_s_fields))++    warn <- woptM Opt_WarnMissingFields+    when (warn && notNull missing_ns_fields)+         (warnTc (Reason Opt_WarnMissingFields) True+             (missingFields con_like missing_ns_fields))++  where+    missing_s_fields+        = [ flLabel fl | (fl, str) <- field_info,+                 isBanged str,+                 not (fl `elemField` field_names_used)+          ]+    missing_ns_fields+        = [ flLabel fl | (fl, str) <- field_info,+                 not (isBanged str),+                 not (fl `elemField` field_names_used)+          ]++    field_names_used = hsRecFields rbinds+    field_labels     = conLikeFieldLabels con_like++    field_info = zipEqual "missingFields"+                          field_labels+                          field_strs++    field_strs = conLikeImplBangs con_like++    fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds++{-+************************************************************************+*                                                                      *+\subsection{Errors and contexts}+*                                                                      *+************************************************************************++Boring and alphabetical:+-}++addExprErrCtxt :: LHsExpr GhcRn -> TcM a -> TcM a+addExprErrCtxt expr = addErrCtxt (exprCtxt expr)++exprCtxt :: LHsExpr GhcRn -> SDoc+exprCtxt expr+  = hang (text "In the expression:") 2 (ppr expr)++fieldCtxt :: FieldLabelString -> SDoc+fieldCtxt field_name+  = text "In the" <+> quotes (ppr field_name) <+> ptext (sLit "field of a record")++addFunResCtxt :: Bool  -- There is at least one argument+              -> HsExpr GhcRn -> TcType -> ExpRhoType+              -> TcM a -> TcM a+-- When we have a mis-match in the return type of a function+-- try to give a helpful message about too many/few arguments+--+-- Used for naked variables too; but with has_args = False+addFunResCtxt has_args fun fun_res_ty env_ty+  = addLandmarkErrCtxtM (\env -> (env, ) <$> mk_msg)+      -- NB: use a landmark error context, so that an empty context+      -- doesn't suppress some more useful context+  where+    mk_msg+      = do { mb_env_ty <- readExpType_maybe env_ty+                     -- by the time the message is rendered, the ExpType+                     -- will be filled in (except if we're debugging)+           ; fun_res' <- zonkTcType fun_res_ty+           ; env'     <- case mb_env_ty of+                           Just env_ty -> zonkTcType env_ty+                           Nothing     ->+                             do { dumping <- doptM Opt_D_dump_tc_trace+                                ; MASSERT( dumping )+                                ; newFlexiTyVarTy liftedTypeKind }+           ; let -- See Note [Splitting nested sigma types in mismatched+                 --           function types]+                 (_, _, fun_tau) = tcSplitNestedSigmaTys fun_res'+                 -- No need to call tcSplitNestedSigmaTys here, since env_ty is+                 -- an ExpRhoTy, i.e., it's already deeply instantiated.+                 (_, _, env_tau) = tcSplitSigmaTy env'+                 (args_fun, res_fun) = tcSplitFunTys fun_tau+                 (args_env, res_env) = tcSplitFunTys env_tau+                 n_fun = length args_fun+                 n_env = length args_env+                 info  | n_fun == n_env = Outputable.empty+                       | n_fun > n_env+                       , not_fun res_env+                       = text "Probable cause:" <+> quotes (ppr fun)+                         <+> text "is applied to too few arguments"++                       | has_args+                       , not_fun res_fun+                       = text "Possible cause:" <+> quotes (ppr fun)+                         <+> text "is applied to too many arguments"++                       | otherwise+                       = Outputable.empty  -- Never suggest that a naked variable is                                         -- applied to too many args!+           ; return info }+      where+        not_fun ty   -- ty is definitely not an arrow type,+                     -- and cannot conceivably become one+          = case tcSplitTyConApp_maybe ty of+              Just (tc, _) -> isAlgTyCon tc+              Nothing      -> False++{-+Note [Splitting nested sigma types in mismatched function types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When one applies a function to too few arguments, GHC tries to determine this+fact if possible so that it may give a helpful error message. It accomplishes+this by checking if the type of the applied function has more argument types+than supplied arguments.++Previously, GHC computed the number of argument types through tcSplitSigmaTy.+This is incorrect in the face of nested foralls, however! This caused Trac+#13311, for instance:++  f :: forall a. (Monoid a) => forall b. (Monoid b) => Maybe a -> Maybe b++If one uses `f` like so:++  do { f; putChar 'a' }++Then tcSplitSigmaTy will decompose the type of `f` into:++  Tyvars: [a]+  Context: (Monoid a)+  Argument types: []+  Return type: forall b. Monoid b => Maybe a -> Maybe b++That is, it will conclude that there are *no* argument types, and since `f`+was given no arguments, it won't print a helpful error message. On the other+hand, tcSplitNestedSigmaTys correctly decomposes `f`'s type down to:++  Tyvars: [a, b]+  Context: (Monoid a, Monoid b)+  Argument types: [Maybe a]+  Return type: Maybe b++So now GHC recognizes that `f` has one more argument type than it was actually+provided.+-}++badFieldTypes :: [(FieldLabelString,TcType)] -> SDoc+badFieldTypes prs+  = hang (text "Record update for insufficiently polymorphic field"+                         <> plural prs <> colon)+       2 (vcat [ ppr f <+> dcolon <+> ppr ty | (f,ty) <- prs ])++badFieldsUpd+  :: [LHsRecField' (AmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]+               -- Field names that don't belong to a single datacon+  -> [ConLike] -- Data cons of the type which the first field name belongs to+  -> SDoc+badFieldsUpd rbinds data_cons+  = hang (text "No constructor has all these fields:")+       2 (pprQuotedList conflictingFields)+          -- See Note [Finding the conflicting fields]+  where+    -- A (preferably small) set of fields such that no constructor contains+    -- all of them.  See Note [Finding the conflicting fields]+    conflictingFields = case nonMembers of+        -- nonMember belongs to a different type.+        (nonMember, _) : _ -> [aMember, nonMember]+        [] -> let+            -- All of rbinds belong to one type. In this case, repeatedly add+            -- a field to the set until no constructor contains the set.++            -- Each field, together with a list indicating which constructors+            -- have all the fields so far.+            growingSets :: [(FieldLabelString, [Bool])]+            growingSets = scanl1 combine membership+            combine (_, setMem) (field, fldMem)+              = (field, zipWith (&&) setMem fldMem)+            in+            -- Fields that don't change the membership status of the set+            -- are redundant and can be dropped.+            map (fst . head) $ groupBy ((==) `on` snd) growingSets++    aMember = ASSERT( not (null members) ) fst (head members)+    (members, nonMembers) = partition (or . snd) membership++    -- For each field, which constructors contain the field?+    membership :: [(FieldLabelString, [Bool])]+    membership = sortMembership $+        map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $+          map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds++    fieldLabelSets :: [Set.Set FieldLabelString]+    fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons++    -- Sort in order of increasing number of True, so that a smaller+    -- conflicting set can be found.+    sortMembership =+      map snd .+      sortBy (compare `on` fst) .+      map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))++    countTrue = count id++{-+Note [Finding the conflicting fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+  data A = A {a0, a1 :: Int}+         | B {b0, b1 :: Int}+and we see a record update+  x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }+Then we'd like to find the smallest subset of fields that no+constructor has all of.  Here, say, {a0,b0}, or {a0,b1}, etc.+We don't really want to report that no constructor has all of+{a0,a1,b0,b1}, because when there are hundreds of fields it's+hard to see what was really wrong.++We may need more than two fields, though; eg+  data T = A { x,y :: Int, v::Int }+          | B { y,z :: Int, v::Int }+          | C { z,x :: Int, v::Int }+with update+   r { x=e1, y=e2, z=e3 }, we++Finding the smallest subset is hard, so the code here makes+a decent stab, no more.  See #7989.+-}++naughtyRecordSel :: RdrName -> SDoc+naughtyRecordSel sel_id+  = text "Cannot use record selector" <+> quotes (ppr sel_id) <+>+    text "as a function due to escaped type variables" $$+    text "Probable fix: use pattern-matching syntax instead"++notSelector :: Name -> SDoc+notSelector field+  = hsep [quotes (ppr field), text "is not a record selector"]++mixedSelectors :: [Id] -> [Id] -> SDoc+mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)+  = ptext+      (sLit "Cannot use a mixture of pattern synonym and record selectors") $$+    text "Record selectors defined by"+      <+> quotes (ppr (tyConName rep_dc))+      <> text ":"+      <+> pprWithCommas ppr data_sels $$+    text "Pattern synonym selectors defined by"+      <+> quotes (ppr (patSynName rep_ps))+      <> text ":"+      <+> pprWithCommas ppr pat_syn_sels+  where+    RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id+    RecSelData rep_dc = recordSelectorTyCon dc_rep_id+mixedSelectors _ _ = panic "TcExpr: mixedSelectors emptylists"+++missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc+missingStrictFields con fields+  = header <> rest+  where+    rest | null fields = Outputable.empty  -- Happens for non-record constructors+                                           -- with strict fields+         | otherwise   = colon <+> pprWithCommas ppr fields++    header = text "Constructor" <+> quotes (ppr con) <+>+             text "does not have the required strict field(s)"++missingFields :: ConLike -> [FieldLabelString] -> SDoc+missingFields con fields+  = header <> rest+  where+    rest | null fields = Outputable.empty+         | otherwise = colon <+> pprWithCommas ppr fields+    header = text "Fields of" <+> quotes (ppr con) <+>+             text "not initialised"++-- callCtxt fun args = text "In the call" <+> parens (ppr (foldl' mkHsApp fun args))++noPossibleParents :: [LHsRecUpdField GhcRn] -> SDoc+noPossibleParents rbinds+  = hang (text "No type has all these fields:")+       2 (pprQuotedList fields)+  where+    fields = map (hsRecFieldLbl . unLoc) rbinds++badOverloadedUpdate :: SDoc+badOverloadedUpdate = text "Record update is ambiguous, and requires a type signature"++fieldNotInType :: RecSelParent -> RdrName -> SDoc+fieldNotInType p rdr+  = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr++{-+************************************************************************+*                                                                      *+\subsection{Static Pointers}+*                                                                      *+************************************************************************+-}++-- | A data type to describe why a variable is not closed.+data NotClosedReason = NotLetBoundReason+                     | NotTypeClosed VarSet+                     | NotClosed Name NotClosedReason++-- | Checks if the given name is closed and emits an error if not.+--+-- See Note [Not-closed error messages].+checkClosedInStaticForm :: Name -> TcM ()+checkClosedInStaticForm name = do+    type_env <- getLclTypeEnv+    case checkClosed type_env name of+      Nothing -> return ()+      Just reason -> addErrTc $ explain name reason+  where+    -- See Note [Checking closedness].+    checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason+    checkClosed type_env n = checkLoop type_env (unitNameSet n) n++    checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason+    checkLoop type_env visited n = do+      -- The @visited@ set is an accumulating parameter that contains the set of+      -- visited nodes, so we avoid repeating cycles in the traversal.+      case lookupNameEnv type_env n of+        Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of+          ClosedLet   -> Nothing+          NotLetBound -> Just NotLetBoundReason+          NonClosedLet fvs type_closed -> listToMaybe $+            -- Look for a non-closed variable in fvs+            [ NotClosed n' reason+            | n' <- nameSetElemsStable fvs+            , not (elemNameSet n' visited)+            , Just reason <- [checkLoop type_env (extendNameSet visited n') n']+            ] +++            if type_closed then+              []+            else+              -- We consider non-let-bound variables easier to figure out than+              -- non-closed types, so we report non-closed types to the user+              -- only if we cannot spot the former.+              [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ]+        -- The binding is closed.+        _ -> Nothing++    -- Converts a reason into a human-readable sentence.+    --+    -- @explain name reason@ starts with+    --+    -- "<name> is used in a static form but it is not closed because it"+    --+    -- and then follows a list of causes. For each id in the path, the text+    --+    -- "uses <id> which"+    --+    -- is appended, yielding something like+    --+    -- "uses <id> which uses <id1> which uses <id2> which"+    --+    -- until the end of the path is reached, which is reported as either+    --+    -- "is not let-bound"+    --+    -- when the final node is not let-bound, or+    --+    -- "has a non-closed type because it contains the type variables:+    -- v1, v2, v3"+    --+    -- when the final node has a non-closed type.+    --+    explain :: Name -> NotClosedReason -> SDoc+    explain name reason =+      quotes (ppr name) <+> text "is used in a static form but it is not closed"+                        <+> text "because it"+                        $$+                        sep (causes reason)++    causes :: NotClosedReason -> [SDoc]+    causes NotLetBoundReason = [text "is not let-bound."]+    causes (NotTypeClosed vs) =+      [ text "has a non-closed type because it contains the"+      , text "type variables:" <+>+        pprVarSet vs (hsep . punctuate comma . map (quotes . ppr))+      ]+    causes (NotClosed n reason) =+      let msg = text "uses" <+> quotes (ppr n) <+> text "which"+       in case reason of+            NotClosed _ _ -> msg : causes reason+            _   -> let (xs0, xs1) = splitAt 1 $ causes reason+                    in fmap (msg <+>) xs0 ++ xs1++-- Note [Not-closed error messages]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- When variables in a static form are not closed, we go through the trouble+-- of explaining why they aren't.+--+-- Thus, the following program+--+-- > {-# LANGUAGE StaticPointers #-}+-- > module M where+-- >+-- > f x = static g+-- >   where+-- >     g = h+-- >     h = x+--+-- produces the error+--+--    'g' is used in a static form but it is not closed because it+--    uses 'h' which uses 'x' which is not let-bound.+--+-- And a program like+--+-- > {-# LANGUAGE StaticPointers #-}+-- > module M where+-- >+-- > import Data.Typeable+-- > import GHC.StaticPtr+-- >+-- > f :: Typeable a => a -> StaticPtr TypeRep+-- > f x = const (static (g undefined)) (h x)+-- >   where+-- >     g = h+-- >     h = typeOf+--+-- produces the error+--+--    'g' is used in a static form but it is not closed because it+--    uses 'h' which has a non-closed type because it contains the+--    type variables: 'a'+--++-- Note [Checking closedness]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- @checkClosed@ checks if a binding is closed and returns a reason if it is+-- not.+--+-- The bindings define a graph where the nodes are ids, and there is an edge+-- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free+-- variables.+--+-- When @n@ is not closed, it has to exist in the graph some node reachable+-- from @n@ that it is not a let-bound variable or that it has a non-closed+-- type. Thus, the "reason" is a path from @n@ to this offending node.+--+-- When @n@ is not closed, we traverse the graph reachable from @n@ to build+-- the reason.+--
+ compiler/typecheck/TcExpr.hs-boot view
@@ -0,0 +1,41 @@+module TcExpr where+import Name+import HsSyn    ( HsExpr, LHsExpr, SyntaxExpr )+import TcType   ( TcRhoType, TcSigmaType, SyntaxOpType, ExpType, ExpRhoType )+import TcRnTypes( TcM, CtOrigin )+import HsExtension ( GhcRn, GhcTcId )++tcPolyExpr ::+          LHsExpr GhcRn+       -> TcSigmaType+       -> TcM (LHsExpr GhcTcId)++tcMonoExpr, tcMonoExprNC ::+          LHsExpr GhcRn+       -> ExpRhoType+       -> TcM (LHsExpr GhcTcId)++tcInferSigma, tcInferSigmaNC ::+          LHsExpr GhcRn+       -> TcM (LHsExpr GhcTcId, TcSigmaType)++tcInferRho ::+          LHsExpr GhcRn+       -> TcM (LHsExpr GhcTcId, TcRhoType)++tcSyntaxOp :: CtOrigin+           -> SyntaxExpr GhcRn+           -> [SyntaxOpType]           -- ^ shape of syntax operator arguments+           -> ExpType                  -- ^ overall result type+           -> ([TcSigmaType] -> TcM a) -- ^ Type check any arguments+           -> TcM (a, SyntaxExpr GhcTcId)++tcSyntaxOpGen :: CtOrigin+              -> SyntaxExpr GhcRn+              -> [SyntaxOpType]+              -> SyntaxOpType+              -> ([TcSigmaType] -> TcM a)+              -> TcM (a, SyntaxExpr GhcTcId)+++tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr GhcTcId)
+ compiler/typecheck/TcFlatten.hs view
@@ -0,0 +1,1879 @@+{-# LANGUAGE CPP, ViewPatterns, BangPatterns #-}++module TcFlatten(+   FlattenMode(..),+   flatten, flattenKind, flattenArgsNom,++   unflattenWanteds+ ) where++#include "HsVersions.h"++import GhcPrelude++import TcRnTypes+import TcType+import Type+import TcEvidence+import TyCon+import TyCoRep   -- performs delicate algorithm on types+import Coercion+import Var+import VarSet+import VarEnv+import Outputable+import TcSMonad as TcS+import BasicTypes( SwapFlag(..) )++import Util+import Bag+import Control.Monad+import MonadUtils    ( zipWith3M )++import Control.Arrow ( first )++{-+Note [The flattening story]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* A CFunEqCan is either of form+     [G] <F xis> : F xis ~ fsk   -- fsk is a FlatSkolTv+     [W]       x : F xis ~ fmv   -- fmv is a FlatMetaTv+  where+     x is the witness variable+     xis are function-free+     fsk/fmv is a flatten skolem;+        it is always untouchable (level 0)++* CFunEqCans can have any flavour: [G], [W], [WD] or [D]++* KEY INSIGHTS:++   - A given flatten-skolem, fsk, is known a-priori to be equal to+     F xis (the LHS), with <F xis> evidence.  The fsk is still a+     unification variable, but it is "owned" by its CFunEqCan, and+     is filled in (unflattened) only by unflattenGivens.++   - A unification flatten-skolem, fmv, stands for the as-yet-unknown+     type to which (F xis) will eventually reduce.  It is filled in+++   - All fsk/fmv variables are "untouchable".  To make it simple to test,+     we simply give them TcLevel=0.  This means that in a CTyVarEq, say,+       fmv ~ Int+     we NEVER unify fmv.++   - A unification flatten-skolem, fmv, ONLY gets unified when either+       a) The CFunEqCan takes a step, using an axiom+       b) By unflattenWanteds+    They are never unified in any other form of equality.+    For example [W] ffmv ~ Int  is stuck; it does not unify with fmv.++* We *never* substitute in the RHS (i.e. the fsk/fmv) of a CFunEqCan.+  That would destroy the invariant about the shape of a CFunEqCan,+  and it would risk wanted/wanted interactions. The only way we+  learn information about fsk is when the CFunEqCan takes a step.++  However we *do* substitute in the LHS of a CFunEqCan (else it+  would never get to fire!)++* Unflattening:+   - We unflatten Givens when leaving their scope (see unflattenGivens)+   - We unflatten Wanteds at the end of each attempt to simplify the+     wanteds; see unflattenWanteds, called from solveSimpleWanteds.++* Ownership of fsk/fmv.  Each canonical [G], [W], or [WD]+       CFunEqCan x : F xis ~ fsk/fmv+  "owns" a distinct evidence variable x, and flatten-skolem fsk/fmv.+  Why? We make a fresh fsk/fmv when the constraint is born;+  and we never rewrite the RHS of a CFunEqCan.++  In contrast a [D] CFunEqCan /shares/ its fmv with its partner [W],+  but does not "own" it.  If we reduce a [D] F Int ~ fmv, where+  say type instance F Int = ty, then we don't discharge fmv := ty.+  Rather we simply generate [D] fmv ~ ty (in TcInteract.reduce_top_fun_eq,+  and dischargeFmv)++* Inert set invariant: if F xis1 ~ fsk1, F xis2 ~ fsk2+                       then xis1 /= xis2+  i.e. at most one CFunEqCan with a particular LHS++* Function applications can occur in the RHS of a CTyEqCan.  No reason+  not allow this, and it reduces the amount of flattening that must occur.++* Flattening a type (F xis):+    - If we are flattening in a Wanted/Derived constraint+      then create new [W] x : F xis ~ fmv+      else create new [G] x : F xis ~ fsk+      with fresh evidence variable x and flatten-skolem fsk/fmv++    - Add it to the work list++    - Replace (F xis) with fsk/fmv in the type you are flattening++    - You can also add the CFunEqCan to the "flat cache", which+      simply keeps track of all the function applications you+      have flattened.++    - If (F xis) is in the cache already, just+      use its fsk/fmv and evidence x, and emit nothing.++    - No need to substitute in the flat-cache. It's not the end+      of the world if we start with, say (F alpha ~ fmv1) and+      (F Int ~ fmv2) and then find alpha := Int.  Athat will+      simply give rise to fmv1 := fmv2 via [Interacting rule] below++* Canonicalising a CFunEqCan [G/W] x : F xis ~ fsk/fmv+    - Flatten xis (to substitute any tyvars; there are already no functions)+                  cos :: xis ~ flat_xis+    - New wanted  x2 :: F flat_xis ~ fsk/fmv+    - Add new wanted to flat cache+    - Discharge x = F cos ; x2++* [Interacting rule]+    (inert)     [W] x1 : F tys ~ fmv1+    (work item) [W] x2 : F tys ~ fmv2+  Just solve one from the other:+    x2 := x1+    fmv2 := fmv1+  This just unites the two fsks into one.+  Always solve given from wanted if poss.++* For top-level reductions, see Note [Top-level reductions for type functions]+  in TcInteract+++Why given-fsks, alone, doesn't work+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Could we get away with only flatten meta-tyvars, with no flatten-skolems? No.++  [W] w : alpha ~ [F alpha Int]++---> flatten+  w = ...w'...+  [W] w' : alpha ~ [fsk]+  [G] <F alpha Int> : F alpha Int ~ fsk++--> unify (no occurs check)+  alpha := [fsk]++But since fsk = F alpha Int, this is really an occurs check error.  If+that is all we know about alpha, we will succeed in constraint+solving, producing a program with an infinite type.++Even if we did finally get (g : fsk ~ Bool) by solving (F alpha Int ~ fsk)+using axiom, zonking would not see it, so (x::alpha) sitting in the+tree will get zonked to an infinite type.  (Zonking always only does+refl stuff.)++Why flatten-meta-vars, alone doesn't work+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Look at Simple13, with unification-fmvs only++  [G] g : a ~ [F a]++---> Flatten given+  g' = g;[x]+  [G] g'  : a ~ [fmv]+  [W] x : F a ~ fmv++--> subst a in x+  g' = g;[x]+  x = F g' ; x2+  [W] x2 : F [fmv] ~ fmv++And now we have an evidence cycle between g' and x!++If we used a given instead (ie current story)++  [G] g : a ~ [F a]++---> Flatten given+  g' = g;[x]+  [G] g'  : a ~ [fsk]+  [G] <F a> : F a ~ fsk++---> Substitute for a+  [G] g'  : a ~ [fsk]+  [G] F (sym g'); <F a> : F [fsk] ~ fsk+++Why is it right to treat fmv's differently to ordinary unification vars?+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  f :: forall a. a -> a -> Bool+  g :: F Int -> F Int -> Bool++Consider+  f (x:Int) (y:Bool)+This gives alpha~Int, alpha~Bool.  There is an inconsistency,+but really only one error.  SherLoc may tell you which location+is most likely, based on other occurrences of alpha.++Consider+  g (x:Int) (y:Bool)+Here we get (F Int ~ Int, F Int ~ Bool), which flattens to+  (fmv ~ Int, fmv ~ Bool)+But there are really TWO separate errors.++  ** We must not complain about Int~Bool. **++Moreover these two errors could arise in entirely unrelated parts of+the code.  (In the alpha case, there must be *some* connection (eg+v:alpha in common envt).)++Note [Unflattening can force the solver to iterate]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Look at #10340:+   type family Any :: *   -- No instances+   get :: MonadState s m => m s+   instance MonadState s (State s) where ...++   foo :: State Any Any+   foo = get++For 'foo' we instantiate 'get' at types mm ss+   [WD] MonadState ss mm, [WD] mm ss ~ State Any Any+Flatten, and decompose+   [WD] MonadState ss mm, [WD] Any ~ fmv+   [WD] mm ~ State fmv, [WD] fmv ~ ss+Unify mm := State fmv:+   [WD] MonadState ss (State fmv)+   [WD] Any ~ fmv, [WD] fmv ~ ss+Now we are stuck; the instance does not match!!  So unflatten:+   fmv := Any+   ss := Any    (*)+   [WD] MonadState Any (State Any)++The unification (*) represents progress, so we must do a second+round of solving; this time it succeeds. This is done by the 'go'+loop in solveSimpleWanteds.++This story does not feel right but it's the best I can do; and the+iteration only happens in pretty obscure circumstances.+++************************************************************************+*                                                                      *+*                  Examples+     Here is a long series of examples I had to work through+*                                                                      *+************************************************************************++Simple20+~~~~~~~~+axiom F [a] = [F a]++ [G] F [a] ~ a+-->+ [G] fsk ~ a+ [G] [F a] ~ fsk  (nc)+-->+ [G] F a ~ fsk2+ [G] fsk ~ [fsk2]+ [G] fsk ~ a+-->+ [G] F a ~ fsk2+ [G] a ~ [fsk2]+ [G] fsk ~ a++----------------------------------------+indexed-types/should_compile/T44984++  [W] H (F Bool) ~ H alpha+  [W] alpha ~ F Bool+-->+  F Bool  ~ fmv0+  H fmv0  ~ fmv1+  H alpha ~ fmv2++  fmv1 ~ fmv2+  fmv0 ~ alpha++flatten+~~~~~~~+  fmv0  := F Bool+  fmv1  := H (F Bool)+  fmv2  := H alpha+  alpha := F Bool+plus+  fmv1 ~ fmv2++But these two are equal under the above assumptions.+Solve by Refl.+++--- under plan B, namely solve fmv1:=fmv2 eagerly ---+  [W] H (F Bool) ~ H alpha+  [W] alpha ~ F Bool+-->+  F Bool  ~ fmv0+  H fmv0  ~ fmv1+  H alpha ~ fmv2++  fmv1 ~ fmv2+  fmv0 ~ alpha+-->+  F Bool  ~ fmv0+  H fmv0  ~ fmv1+  H alpha ~ fmv2    fmv2 := fmv1++  fmv0 ~ alpha++flatten+  fmv0 := F Bool+  fmv1 := H fmv0 = H (F Bool)+  retain   H alpha ~ fmv2+    because fmv2 has been filled+  alpha := F Bool+++----------------------------+indexed-types/should_failt/T4179++after solving+  [W] fmv_1 ~ fmv_2+  [W] A3 (FCon x)           ~ fmv_1    (CFunEqCan)+  [W] A3 (x (aoa -> fmv_2)) ~ fmv_2    (CFunEqCan)++----------------------------------------+indexed-types/should_fail/T7729a++a)  [W]   BasePrimMonad (Rand m) ~ m1+b)  [W]   tt m1 ~ BasePrimMonad (Rand m)++--->  process (b) first+    BasePrimMonad (Ramd m) ~ fmv_atH+    fmv_atH ~ tt m1++--->  now process (a)+    m1 ~ s_atH ~ tt m1    -- An obscure occurs check+++----------------------------------------+typecheck/TcTypeNatSimple++Original constraint+  [W] x + y ~ x + alpha  (non-canonical)+==>+  [W] x + y     ~ fmv1   (CFunEqCan)+  [W] x + alpha ~ fmv2   (CFuneqCan)+  [W] fmv1 ~ fmv2        (CTyEqCan)++(sigh)++----------------------------------------+indexed-types/should_fail/GADTwrong1++  [G] Const a ~ ()+==> flatten+  [G] fsk ~ ()+  work item: Const a ~ fsk+==> fire top rule+  [G] fsk ~ ()+  work item fsk ~ ()++Surely the work item should rewrite to () ~ ()?  Well, maybe not;+it'a very special case.  More generally, our givens look like+F a ~ Int, where (F a) is not reducible.+++----------------------------------------+indexed_types/should_fail/T8227:++Why using a different can-rewrite rule in CFunEqCan heads+does not work.++Assuming NOT rewriting wanteds with wanteds++   Inert: [W] fsk_aBh ~ fmv_aBk -> fmv_aBk+          [W] fmv_aBk ~ fsk_aBh++          [G] Scalar fsk_aBg ~ fsk_aBh+          [G] V a ~ f_aBg++   Worklist includes  [W] Scalar fmv_aBi ~ fmv_aBk+   fmv_aBi, fmv_aBk are flatten unification variables++   Work item: [W] V fsk_aBh ~ fmv_aBi++Note that the inert wanteds are cyclic, because we do not rewrite+wanteds with wanteds.+++Then we go into a loop when normalise the work-item, because we+use rewriteOrSame on the argument of V.++Conclusion: Don't make canRewrite context specific; instead use+[W] a ~ ty to rewrite a wanted iff 'a' is a unification variable.+++----------------------------------------++Here is a somewhat similar case:++   type family G a :: *++   blah :: (G a ~ Bool, Eq (G a)) => a -> a+   blah = error "urk"++   foo x = blah x++For foo we get+   [W] Eq (G a), G a ~ Bool+Flattening+   [W] G a ~ fmv, Eq fmv, fmv ~ Bool+We can't simplify away the Eq Bool unless we substitute for fmv.+Maybe that doesn't matter: we would still be left with unsolved+G a ~ Bool.++--------------------------+#9318 has a very simple program leading to++  [W] F Int ~ Int+  [W] F Int ~ Bool++We don't want to get "Error Int~Bool".  But if fmv's can rewrite+wanteds, we will++  [W] fmv ~ Int+  [W] fmv ~ Bool+--->+  [W] Int ~ Bool+++************************************************************************+*                                                                      *+*                FlattenEnv & FlatM+*             The flattening environment & monad+*                                                                      *+************************************************************************++-}++type FlatWorkListRef = TcRef [Ct]  -- See Note [The flattening work list]++data FlattenEnv+  = FE { fe_mode    :: !FlattenMode+       , fe_loc     :: !CtLoc             -- See Note [Flattener CtLoc]+       , fe_flavour :: !CtFlavour+       , fe_eq_rel  :: !EqRel             -- See Note [Flattener EqRels]+       , fe_work    :: !FlatWorkListRef } -- See Note [The flattening work list]++data FlattenMode  -- Postcondition for all three: inert wrt the type substitution+  = FM_FlattenAll          -- Postcondition: function-free+  | FM_SubstOnly           -- See Note [Flattening under a forall]++--  | FM_Avoid TcTyVar Bool  -- See Note [Lazy flattening]+--                           -- Postcondition:+--                           --  * tyvar is only mentioned in result under a rigid path+--                           --    e.g.   [a] is ok, but F a won't happen+--                           --  * If flat_top is True, top level is not a function application+--                           --   (but under type constructors is ok e.g. [F a])++instance Outputable FlattenMode where+  ppr FM_FlattenAll = text "FM_FlattenAll"+  ppr FM_SubstOnly  = text "FM_SubstOnly"++eqFlattenMode :: FlattenMode -> FlattenMode -> Bool+eqFlattenMode FM_FlattenAll FM_FlattenAll = True+eqFlattenMode FM_SubstOnly  FM_SubstOnly  = True+--  FM_Avoid tv1 b1 `eq` FM_Avoid tv2 b2 = tv1 == tv2 && b1 == b2+eqFlattenMode _  _ = False++-- | The 'FlatM' monad is a wrapper around 'TcS' with the following+-- extra capabilities: (1) it offers access to a 'FlattenEnv';+-- and (2) it maintains the flattening worklist.+-- See Note [The flattening work list].+newtype FlatM a+  = FlatM { runFlatM :: FlattenEnv -> TcS a }++instance Monad FlatM where+  m >>= k  = FlatM $ \env ->+             do { a  <- runFlatM m env+                ; runFlatM (k a) env }++instance Functor FlatM where+  fmap = liftM++instance Applicative FlatM where+  pure x = FlatM $ const (pure x)+  (<*>) = ap++liftTcS :: TcS a -> FlatM a+liftTcS thing_inside+  = FlatM $ const thing_inside++emitFlatWork :: Ct -> FlatM ()+-- See Note [The flattening work list]+emitFlatWork ct = FlatM $ \env -> updTcRef (fe_work env) (ct :)++-- convenient wrapper when you have a CtEvidence describing+-- the flattening operation+runFlattenCtEv :: FlattenMode -> CtEvidence -> FlatM a -> TcS a+runFlattenCtEv mode ev+  = runFlatten mode (ctEvLoc ev) (ctEvFlavour ev) (ctEvEqRel ev)++-- Run thing_inside (which does flattening), and put all+-- the work it generates onto the main work list+-- See Note [The flattening work list]+runFlatten :: FlattenMode -> CtLoc -> CtFlavour -> EqRel -> FlatM a -> TcS a+runFlatten mode loc flav eq_rel thing_inside+  = do { flat_ref <- newTcRef []+       ; let fmode = FE { fe_mode = mode+                        , fe_loc  = loc+                        , fe_flavour = flav+                        , fe_eq_rel = eq_rel+                        , fe_work = flat_ref }+       ; res <- runFlatM thing_inside fmode+       ; new_flats <- readTcRef flat_ref+       ; updWorkListTcS (add_flats new_flats)+       ; return res }+  where+    add_flats new_flats wl+      = wl { wl_funeqs = add_funeqs new_flats (wl_funeqs wl) }++    add_funeqs []     wl = wl+    add_funeqs (f:fs) wl = add_funeqs fs (f:wl)+      -- add_funeqs fs ws = reverse fs ++ ws+      -- e.g. add_funeqs [f1,f2,f3] [w1,w2,w3,w4]+      --        = [f3,f2,f1,w1,w2,w3,w4]++traceFlat :: String -> SDoc -> FlatM ()+traceFlat herald doc = liftTcS $ traceTcS herald doc++getFlatEnvField :: (FlattenEnv -> a) -> FlatM a+getFlatEnvField accessor+  = FlatM $ \env -> return (accessor env)++getEqRel :: FlatM EqRel+getEqRel = getFlatEnvField fe_eq_rel++getRole :: FlatM Role+getRole = eqRelRole <$> getEqRel++getFlavour :: FlatM CtFlavour+getFlavour = getFlatEnvField fe_flavour++getFlavourRole :: FlatM CtFlavourRole+getFlavourRole+  = do { flavour <- getFlavour+       ; eq_rel <- getEqRel+       ; return (flavour, eq_rel) }++getMode :: FlatM FlattenMode+getMode = getFlatEnvField fe_mode++getLoc :: FlatM CtLoc+getLoc = getFlatEnvField fe_loc++checkStackDepth :: Type -> FlatM ()+checkStackDepth ty+  = do { loc <- getLoc+       ; liftTcS $ checkReductionDepth loc ty }++-- | Change the 'EqRel' in a 'FlatM'.+setEqRel :: EqRel -> FlatM a -> FlatM a+setEqRel new_eq_rel thing_inside+  = FlatM $ \env ->+    if new_eq_rel == fe_eq_rel env+    then runFlatM thing_inside env+    else runFlatM thing_inside (env { fe_eq_rel = new_eq_rel })++-- | Change the 'FlattenMode' in a 'FlattenEnv'.+setMode :: FlattenMode -> FlatM a -> FlatM a+setMode new_mode thing_inside+  = FlatM $ \env ->+    if new_mode `eqFlattenMode` fe_mode env+    then runFlatM thing_inside env+    else runFlatM thing_inside (env { fe_mode = new_mode })++-- | Make sure that flattening actually produces a coercion (in other+-- words, make sure our flavour is not Derived)+-- Note [No derived kind equalities]+noBogusCoercions :: FlatM a -> FlatM a+noBogusCoercions thing_inside+  = FlatM $ \env ->+    -- No new thunk is made if the flavour hasn't changed (note the bang).+    let !env' = case fe_flavour env of+          Derived -> env { fe_flavour = Wanted WDeriv }+          _       -> env+    in+    runFlatM thing_inside env'++bumpDepth :: FlatM a -> FlatM a+bumpDepth (FlatM thing_inside)+  = FlatM $ \env -> do+      -- bumpDepth can be called a lot during flattening so we force the+      -- new env to avoid accumulating thunks.+      { let !env' = env { fe_loc = bumpCtLocDepth (fe_loc env) }+      ; thing_inside env' }++{-+Note [The flattening work list]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The "flattening work list", held in the fe_work field of FlattenEnv,+is a list of CFunEqCans generated during flattening.  The key idea+is this.  Consider flattening (Eq (F (G Int) (H Bool)):+  * The flattener recursively calls itself on sub-terms before building+    the main term, so it will encounter the terms in order+              G Int+              H Bool+              F (G Int) (H Bool)+    flattening to sub-goals+              w1: G Int ~ fuv0+              w2: H Bool ~ fuv1+              w3: F fuv0 fuv1 ~ fuv2++  * Processing w3 first is BAD, because we can't reduce i t,so it'll+    get put into the inert set, and later kicked out when w1, w2 are+    solved.  In #9872 this led to inert sets containing hundreds+    of suspended calls.++  * So we want to process w1, w2 first.++  * So you might think that we should just use a FIFO deque for the work-list,+    so that putting adding goals in order w1,w2,w3 would mean we processed+    w1 first.++  * BUT suppose we have 'type instance G Int = H Char'.  Then processing+    w1 leads to a new goal+                w4: H Char ~ fuv0+    We do NOT want to put that on the far end of a deque!  Instead we want+    to put it at the *front* of the work-list so that we continue to work+    on it.++So the work-list structure is this:++  * The wl_funeqs (in TcS) is a LIFO stack; we push new goals (such as w4) on+    top (extendWorkListFunEq), and take new work from the top+    (selectWorkItem).++  * When flattening, emitFlatWork pushes new flattening goals (like+    w1,w2,w3) onto the flattening work list, fe_work, another+    push-down stack.++  * When we finish flattening, we *reverse* the fe_work stack+    onto the wl_funeqs stack (which brings w1 to the top).++The function runFlatten initialises the fe_work stack, and reverses+it onto wl_fun_eqs at the end.++Note [Flattener EqRels]+~~~~~~~~~~~~~~~~~~~~~~~+When flattening, we need to know which equality relation -- nominal+or representation -- we should be respecting. The only difference is+that we rewrite variables by representational equalities when fe_eq_rel+is ReprEq, and that we unwrap newtypes when flattening w.r.t.+representational equality.++Note [Flattener CtLoc]+~~~~~~~~~~~~~~~~~~~~~~+The flattener does eager type-family reduction.+Type families might loop, and we+don't want GHC to do so. A natural solution is to have a bounded depth+to these processes. A central difficulty is that such a solution isn't+quite compositional. For example, say it takes F Int 10 steps to get to Bool.+How many steps does it take to get from F Int -> F Int to Bool -> Bool?+10? 20? What about getting from Const Char (F Int) to Char? 11? 1? Hard to+know and hard to track. So, we punt, essentially. We store a CtLoc in+the FlattenEnv and just update the environment when recurring. In the+TyConApp case, where there may be multiple type families to flatten,+we just copy the current CtLoc into each branch. If any branch hits the+stack limit, then the whole thing fails.++A consequence of this is that setting the stack limits appropriately+will be essentially impossible. So, the official recommendation if a+stack limit is hit is to disable the check entirely. Otherwise, there+will be baffling, unpredictable errors.++Note [Lazy flattening]+~~~~~~~~~~~~~~~~~~~~~~+The idea of FM_Avoid mode is to flatten less aggressively.  If we have+       a ~ [F Int]+there seems to be no great merit in lifting out (F Int).  But if it was+       a ~ [G a Int]+then we *do* want to lift it out, in case (G a Int) reduces to Bool, say,+which gets rid of the occurs-check problem.  (For the flat_top Bool, see+comments above and at call sites.)++HOWEVER, the lazy flattening actually seems to make type inference go+*slower*, not faster.  perf/compiler/T3064 is a case in point; it gets+*dramatically* worse with FM_Avoid.  I think it may be because+floating the types out means we normalise them, and that often makes+them smaller and perhaps allows more re-use of previously solved+goals.  But to be honest I'm not absolutely certain, so I am leaving+FM_Avoid in the code base.  What I'm removing is the unique place+where it is *used*, namely in TcCanonical.canEqTyVar.++See also Note [Conservative unification check] in TcUnify, which gives+other examples where lazy flattening caused problems.++Bottom line: FM_Avoid is unused for now (Nov 14).+Note: T5321Fun got faster when I disabled FM_Avoid+      T5837 did too, but it's pathalogical anyway++Note [Phantoms in the flattener]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++data Proxy p = Proxy++and we're flattening (Proxy ty) w.r.t. ReprEq. Then, we know that `ty`+is really irrelevant -- it will be ignored when solving for representational+equality later on. So, we omit flattening `ty` entirely. This may+violate the expectation of "xi"s for a bit, but the canonicaliser will+soon throw out the phantoms when decomposing a TyConApp. (Or, the+canonicaliser will emit an insoluble, in which case the unflattened version+yields a better error message anyway.)++Note [No derived kind equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A kind-level coercion can appear in types, via mkCastTy. So, whenever+we are generating a coercion in a dependent context (in other words,+in a kind) we need to make sure that our flavour is never Derived+(as Derived constraints have no evidence). The noBogusCoercions function+changes the flavour from Derived just for this purpose.++-}++{- *********************************************************************+*                                                                      *+*      Externally callable flattening functions                        *+*                                                                      *+*  They are all wrapped in runFlatten, so their                        *+*  flattening work gets put into the work list                         *+*                                                                      *+********************************************************************* -}++flatten :: FlattenMode -> CtEvidence -> TcType+        -> TcS (Xi, TcCoercion)+flatten mode ev ty+  = do { traceTcS "flatten {" (ppr mode <+> ppr ty)+       ; (ty', co) <- runFlattenCtEv mode ev (flatten_one ty)+       ; traceTcS "flatten }" (ppr ty')+       ; return (ty', co) }++-- specialized to flattening kinds: never Derived, always Nominal+-- See Note [No derived kind equalities]+flattenKind :: CtLoc -> CtFlavour -> TcType -> TcS (Xi, TcCoercionN)+flattenKind loc flav ty+  = do { traceTcS "flattenKind {" (ppr flav <+> ppr ty)+       ; let flav' = case flav of+                       Derived -> Wanted WDeriv  -- the WDeriv/WOnly choice matters not+                       _       -> flav+       ; (ty', co) <- runFlatten FM_FlattenAll loc flav' NomEq (flatten_one ty)+       ; traceTcS "flattenKind }" (ppr ty' $$ ppr co) -- co is never a panic+       ; return (ty', co) }++flattenArgsNom :: CtEvidence -> TyCon -> [TcType] -> TcS ([Xi], [TcCoercion], TcCoercionN)+-- Externally-callable, hence runFlatten+-- Flatten a vector of types all at once; in fact they are+-- always the arguments of type family or class, so+--      ctEvFlavour ev = Nominal+-- and we want to flatten all at nominal role+-- The kind passed in is the kind of the type family or class, call it T+-- The last coercion returned has type (tcTypeKind(T xis) ~N tcTypeKind(T tys))+--+-- For Derived constraints the returned coercion may be undefined+-- because flattening may use a Derived equality ([D] a ~ ty)+flattenArgsNom ev tc tys+  = do { traceTcS "flatten_args {" (vcat (map ppr tys))+       ; (tys', cos, kind_co)+           <- runFlattenCtEv FM_FlattenAll ev (flatten_args_tc tc (repeat Nominal) tys)+       ; traceTcS "flatten }" (vcat (map ppr tys'))+       ; return (tys', cos, kind_co) }+++{- *********************************************************************+*                                                                      *+*           The main flattening functions+*                                                                      *+********************************************************************* -}++{- Note [Flattening]+~~~~~~~~~~~~~~~~~~~~+  flatten ty  ==>   (xi, co)+    where+      xi has no type functions, unless they appear under ForAlls+         has no skolems that are mapped in the inert set+         has no filled-in metavariables+      co :: xi ~ ty++Key invariants:+  (F0) co :: xi ~ zonk(ty)+  (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind+  (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty))++Note that it is flatten's job to flatten *every type function it sees*.+flatten is only called on *arguments* to type functions, by canEqGiven.++Flattening also:+  * zonks, removing any metavariables, and+  * applies the substitution embodied in the inert set++Because flattening zonks and the returned coercion ("co" above) is also+zonked, it's possible that (co :: xi ~ ty) isn't quite true. So, instead,+we can rely on this fact:++  (F1) tcTypeKind(xi) succeeds and returns a fully zonked kind++Note that the left-hand type of co is *always* precisely xi. The right-hand+type may or may not be ty, however: if ty has unzonked filled-in metavariables,+then the right-hand type of co will be the zonked version of ty.+It is for this reason that we+occasionally have to explicitly zonk, when (co :: xi ~ ty) is important+even before we zonk the whole program. For example, see the FTRNotFollowed+case in flattenTyVar.++Why have these invariants on flattening? Because we sometimes use tcTypeKind+during canonicalisation, and we want this kind to be zonked (e.g., see+TcCanonical.canEqTyVar).++Flattening is always homogeneous. That is, the kind of the result of flattening is+always the same as the kind of the input, modulo zonking. More formally:++  (F2) tcTypeKind(xi) `eqType` zonk(tcTypeKind(ty))++This invariant means that the kind of a flattened type might not itself be flat.++Recall that in comments we use alpha[flat = ty] to represent a+flattening skolem variable alpha which has been generated to stand in+for ty.++----- Example of flattening a constraint: ------+  flatten (List (F (G Int)))  ==>  (xi, cc)+    where+      xi  = List alpha+      cc  = { G Int ~ beta[flat = G Int],+              F beta ~ alpha[flat = F beta] }+Here+  * alpha and beta are 'flattening skolem variables'.+  * All the constraints in cc are 'given', and all their coercion terms+    are the identity.++NB: Flattening Skolems only occur in canonical constraints, which+are never zonked, so we don't need to worry about zonking doing+accidental unflattening.++Note that we prefer to leave type synonyms unexpanded when possible,+so when the flattener encounters one, it first asks whether its+transitive expansion contains any type function applications.  If so,+it expands the synonym and proceeds; if not, it simply returns the+unexpanded synonym.++Note [flatten_args performance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In programs with lots of type-level evaluation, flatten_args becomes+part of a tight loop. For example, see test perf/compiler/T9872a, which+calls flatten_args a whopping 7,106,808 times. It is thus important+that flatten_args be efficient.++Performance testing showed that the current implementation is indeed+efficient. It's critically important that zipWithAndUnzipM be+specialized to TcS, and it's also quite helpful to actually `inline`+it. On test T9872a, here are the allocation stats (Dec 16, 2014):++ * Unspecialized, uninlined:     8,472,613,440 bytes allocated in the heap+ * Specialized, uninlined:       6,639,253,488 bytes allocated in the heap+ * Specialized, inlined:         6,281,539,792 bytes allocated in the heap++To improve performance even further, flatten_args_nom is split off+from flatten_args, as nominal equality is the common case. This would+be natural to write using mapAndUnzipM, but even inlined, that function+is not as performant as a hand-written loop.++ * mapAndUnzipM, inlined:        7,463,047,432 bytes allocated in the heap+ * hand-written recursion:       5,848,602,848 bytes allocated in the heap++If you make any change here, pay close attention to the T9872{a,b,c} tests+and T5321Fun.++If we need to make this yet more performant, a possible way forward is to+duplicate the flattener code for the nominal case, and make that case+faster. This doesn't seem quite worth it, yet.++Note [flatten_exact_fam_app_fully performance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The refactor of GRefl seems to cause performance trouble for T9872x: the allocation of flatten_exact_fam_app_fully_performance increased. See note [Generalized reflexive coercion] in TyCoRep for more information about GRefl and #15192 for the current state.++The explicit pattern match in homogenise_result helps with T9872a, b, c.++Still, it increases the expected allocation of T9872d by ~2%.++TODO: a step-by-step replay of the refactor to analyze the performance.++-}++{-# INLINE flatten_args_tc #-}+flatten_args_tc+  :: TyCon         -- T+  -> [Role]        -- Role r+  -> [Type]        -- Arg types [t1,..,tn]+  -> FlatM ( [Xi]  -- List of flattened args [x1,..,xn]+                   -- 1-1 corresp with [t1,..,tn]+           , [Coercion]  -- List of arg coercions [co1,..,con]+                         -- 1-1 corresp with [t1,..,tn]+                         --    coi :: xi ~r ti+           , CoercionN)  -- Result coercion, rco+                         --    rco : (T t1..tn) ~N (T (x1 |> co1) .. (xn |> con))+flatten_args_tc tc = flatten_args all_bndrs any_named_bndrs inner_ki emptyVarSet+  -- NB: TyCon kinds are always closed+  where+    (bndrs, named)+      = ty_con_binders_ty_binders' (tyConBinders tc)+    -- it's possible that the result kind has arrows (for, e.g., a type family)+    -- so we must split it+    (inner_bndrs, inner_ki, inner_named) = split_pi_tys' (tyConResKind tc)+    !all_bndrs                           = bndrs `chkAppend` inner_bndrs+    !any_named_bndrs                     = named || inner_named+    -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%.++{-# INLINE flatten_args #-}+flatten_args :: [TyCoBinder] -> Bool -- Binders, and True iff any of them are+                                     -- named.+             -> Kind -> TcTyCoVarSet -- function kind; kind's free vars+             -> [Role] -> [Type]     -- these are in 1-to-1 correspondence+             -> FlatM ([Xi], [Coercion], CoercionN)+-- Coercions :: Xi ~ Type, at roles given+-- Third coercion :: tcTypeKind(fun xis) ~N tcTypeKind(fun tys)+-- That is, the third coercion relates the kind of some function (whose kind is+-- passed as the first parameter) instantiated at xis to the kind of that+-- function instantiated at the tys. This is useful in keeping flattening+-- homoegeneous. The list of roles must be at least as long as the list of+-- types.+flatten_args orig_binders+             any_named_bndrs+             orig_inner_ki+             orig_fvs+             orig_roles+             orig_tys+  = if any_named_bndrs+    then flatten_args_slow orig_binders+                           orig_inner_ki+                           orig_fvs+                           orig_roles+                           orig_tys+    else flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys++{-# INLINE flatten_args_fast #-}+-- | fast path flatten_args, in which none of the binders are named and+-- therefore we can avoid tracking a lifting context.+-- There are many bang patterns in here. It's been observed that they+-- greatly improve performance of an optimized build.+-- The T9872 test cases are good witnesses of this fact.+flatten_args_fast :: [TyCoBinder]+                  -> Kind+                  -> [Role]+                  -> [Type]+                  -> FlatM ([Xi], [Coercion], CoercionN)+flatten_args_fast orig_binders orig_inner_ki orig_roles orig_tys+  = fmap finish (iterate orig_tys orig_roles orig_binders)+  where++    iterate :: [Type]+            -> [Role]+            -> [TyCoBinder]+            -> FlatM ([Xi], [Coercion], [TyCoBinder])+    iterate (ty:tys) (role:roles) (_:binders) = do+      (xi, co) <- go role ty+      (xis, cos, binders) <- iterate tys roles binders+      pure (xi : xis, co : cos, binders)+    iterate [] _ binders = pure ([], [], binders)+    iterate _ _ _ = pprPanic+        "flatten_args wandered into deeper water than usual" (vcat [])+           -- This debug information is commented out because leaving it in+           -- causes a ~2% increase in allocations in T9872{a,c,d}.+           {-+             (vcat [ppr orig_binders,+                    ppr orig_inner_ki,+                    ppr (take 10 orig_roles), -- often infinite!+                    ppr orig_tys])+           -}++    {-# INLINE go #-}+    go :: Role+       -> Type+       -> FlatM (Xi, Coercion)+    go role ty+      = case role of+          -- In the slow path we bind the Xi and Coercion from the recursive+          -- call and then use it such+          --+          --   let kind_co = mkTcSymCo $ mkReflCo Nominal (tyBinderType binder)+          --       casted_xi = xi `mkCastTy` kind_co+          --       casted_co = xi |> kind_co ~r xi ; co+          --+          -- but this isn't necessary:+          --   mkTcSymCo (Refl a b) = Refl a b,+          --   mkCastTy x (Refl _ _) = x+          --   mkTcGReflLeftCo _ ty (Refl _ _) `mkTransCo` co = co+          --+          -- Also, no need to check isAnonTyCoBinder or isNamedBinder, since+          -- we've already established that they're all anonymous.+          Nominal          -> setEqRel NomEq  $ flatten_one ty+          Representational -> setEqRel ReprEq $ flatten_one ty+          Phantom          -> -- See Note [Phantoms in the flattener]+                              do { ty <- liftTcS $ zonkTcType ty+                                 ; return (ty, mkReflCo Phantom ty) }+++    {-# INLINE finish #-}+    finish :: ([Xi], [Coercion], [TyCoBinder]) -> ([Xi], [Coercion], CoercionN)+    finish (xis, cos, binders) = (xis, cos, kind_co)+      where+        final_kind = mkPiTys binders orig_inner_ki+        kind_co    = mkNomReflCo final_kind++{-# INLINE flatten_args_slow #-}+-- | Slow path, compared to flatten_args_fast, because this one must track+-- a lifting context.+flatten_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet+                  -> [Role] -> [Type]+                  -> FlatM ([Xi], [Coercion], CoercionN)+flatten_args_slow binders inner_ki fvs roles tys+-- Arguments used dependently must be flattened with proper coercions, but+-- we're not guaranteed to get a proper coercion when flattening with the+-- "Derived" flavour. So we must call noBogusCoercions when flattening arguments+-- corresponding to binders that are dependent. However, we might legitimately+-- have *more* arguments than binders, in the case that the inner_ki is a variable+-- that gets instantiated with a Π-type. We conservatively choose not to produce+-- bogus coercions for these, too. Note that this might miss an opportunity for+-- a Derived rewriting a Derived. The solution would be to generate evidence for+-- Deriveds, thus avoiding this whole noBogusCoercions idea. See also+-- Note [No derived kind equalities]+  = do { flattened_args <- zipWith3M fl (map isNamedBinder binders ++ repeat True)+                                        roles tys+       ; return (simplifyArgsWorker binders inner_ki fvs roles flattened_args) }+  where+    {-# INLINE fl #-}+    fl :: Bool   -- must we ensure to produce a real coercion here?+                  -- see comment at top of function+       -> Role -> Type -> FlatM (Xi, Coercion)+    fl True  r ty = noBogusCoercions $ fl1 r ty+    fl False r ty =                    fl1 r ty++    {-# INLINE fl1 #-}+    fl1 :: Role -> Type -> FlatM (Xi, Coercion)+    fl1 Nominal ty+      = setEqRel NomEq $+        flatten_one ty++    fl1 Representational ty+      = setEqRel ReprEq $+        flatten_one ty++    fl1 Phantom ty+    -- See Note [Phantoms in the flattener]+      = do { ty <- liftTcS $ zonkTcType ty+           ; return (ty, mkReflCo Phantom ty) }++------------------+flatten_one :: TcType -> FlatM (Xi, Coercion)+-- Flatten a type to get rid of type function applications, returning+-- the new type-function-free type, and a collection of new equality+-- constraints.  See Note [Flattening] for more detail.+--+-- Postcondition: Coercion :: Xi ~ TcType+-- The role on the result coercion matches the EqRel in the FlattenEnv++flatten_one xi@(LitTy {})+  = do { role <- getRole+       ; return (xi, mkReflCo role xi) }++flatten_one (TyVarTy tv)+  = flattenTyVar tv++flatten_one (AppTy ty1 ty2)+  = flatten_app_tys ty1 [ty2]++flatten_one (TyConApp tc tys)+  -- Expand type synonyms that mention type families+  -- on the RHS; see Note [Flattening synonyms]+  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys+  , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'+  = do { mode <- getMode+       ; case mode of+           FM_FlattenAll | not (isFamFreeTyCon tc)+                         -> flatten_one expanded_ty+           _             -> flatten_ty_con_app tc tys }++  -- Otherwise, it's a type function application, and we have to+  -- flatten it away as well, and generate a new given equality constraint+  -- between the application and a newly generated flattening skolem variable.+  | isTypeFamilyTyCon tc+  = flatten_fam_app tc tys++  -- For * a normal data type application+  --     * data family application+  -- we just recursively flatten the arguments.+  | otherwise+-- FM_Avoid stuff commented out; see Note [Lazy flattening]+--  , let fmode' = case fmode of  -- Switch off the flat_top bit in FM_Avoid+--                   FE { fe_mode = FM_Avoid tv _ }+--                     -> fmode { fe_mode = FM_Avoid tv False }+--                   _ -> fmode+  = flatten_ty_con_app tc tys++flatten_one ty@(FunTy _ ty1 ty2)+  = do { (xi1,co1) <- flatten_one ty1+       ; (xi2,co2) <- flatten_one ty2+       ; role <- getRole+       ; return (ty { ft_arg = xi1, ft_res = xi2 }+                , mkFunCo role co1 co2) }++flatten_one ty@(ForAllTy {})+-- TODO (RAE): This is inadequate, as it doesn't flatten the kind of+-- the bound tyvar. Doing so will require carrying around a substitution+-- and the usual substTyVarBndr-like silliness. Argh.++-- We allow for-alls when, but only when, no type function+-- applications inside the forall involve the bound type variables.+  = do { let (bndrs, rho) = tcSplitForAllVarBndrs ty+             tvs           = binderVars bndrs+       ; (rho', co) <- setMode FM_SubstOnly $ flatten_one rho+                         -- Substitute only under a forall+                         -- See Note [Flattening under a forall]+       ; return (mkForAllTys bndrs rho', mkHomoForAllCos tvs co) }++flatten_one (CastTy ty g)+  = do { (xi, co) <- flatten_one ty+       ; (g', _)   <- flatten_co g++       ; role <- getRole+       ; return (mkCastTy xi g', castCoercionKind co role xi ty g' g) }++flatten_one (CoercionTy co) = first mkCoercionTy <$> flatten_co co++-- | "Flatten" a coercion. Really, just zonk it so we can uphold+-- (F1) of Note [Flattening]+flatten_co :: Coercion -> FlatM (Coercion, Coercion)+flatten_co co+  = do { co <- liftTcS $ zonkCo co+       ; env_role <- getRole+       ; let co' = mkTcReflCo env_role (mkCoercionTy co)+       ; return (co, co') }++-- flatten (nested) AppTys+flatten_app_tys :: Type -> [Type] -> FlatM (Xi, Coercion)+-- commoning up nested applications allows us to look up the function's kind+-- only once. Without commoning up like this, we would spend a quadratic amount+-- of time looking up functions' types+flatten_app_tys (AppTy ty1 ty2) tys = flatten_app_tys ty1 (ty2:tys)+flatten_app_tys fun_ty arg_tys+  = do { (fun_xi, fun_co) <- flatten_one fun_ty+       ; flatten_app_ty_args fun_xi fun_co arg_tys }++-- Given a flattened function (with the coercion produced by flattening) and+-- a bunch of unflattened arguments, flatten the arguments and apply.+-- The coercion argument's role matches the role stored in the FlatM monad.+--+-- The bang patterns used here were observed to improve performance. If you+-- wish to remove them, be sure to check for regeressions in allocations.+flatten_app_ty_args :: Xi -> Coercion -> [Type] -> FlatM (Xi, Coercion)+flatten_app_ty_args fun_xi fun_co []+  -- this will be a common case when called from flatten_fam_app, so shortcut+  = return (fun_xi, fun_co)+flatten_app_ty_args fun_xi fun_co arg_tys+  = do { (xi, co, kind_co) <- case tcSplitTyConApp_maybe fun_xi of+           Just (tc, xis) ->+             do { let tc_roles  = tyConRolesRepresentational tc+                      arg_roles = dropList xis tc_roles+                ; (arg_xis, arg_cos, kind_co)+                    <- flatten_vector (tcTypeKind fun_xi) arg_roles arg_tys++                  -- Here, we have fun_co :: T xi1 xi2 ~ ty+                  -- and we need to apply fun_co to the arg_cos. The problem is+                  -- that using mkAppCo is wrong because that function expects+                  -- its second coercion to be Nominal, and the arg_cos might+                  -- not be. The solution is to use transitivity:+                  -- T <xi1> <xi2> arg_cos ;; fun_co <arg_tys>+                ; eq_rel <- getEqRel+                ; let app_xi = mkTyConApp tc (xis ++ arg_xis)+                      app_co = case eq_rel of+                        NomEq  -> mkAppCos fun_co arg_cos+                        ReprEq -> mkTcTyConAppCo Representational tc+                                    (zipWith mkReflCo tc_roles xis ++ arg_cos)+                                  `mkTcTransCo`+                                  mkAppCos fun_co (map mkNomReflCo arg_tys)+                ; return (app_xi, app_co, kind_co) }+           Nothing ->+             do { (arg_xis, arg_cos, kind_co)+                    <- flatten_vector (tcTypeKind fun_xi) (repeat Nominal) arg_tys+                ; let arg_xi = mkAppTys fun_xi arg_xis+                      arg_co = mkAppCos fun_co arg_cos+                ; return (arg_xi, arg_co, kind_co) }++       ; role <- getRole+       ; return (homogenise_result xi co role kind_co) }++flatten_ty_con_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)+flatten_ty_con_app tc tys+  = do { role <- getRole+       ; (xis, cos, kind_co) <- flatten_args_tc tc (tyConRolesX role tc) tys+       ; let tyconapp_xi = mkTyConApp tc xis+             tyconapp_co = mkTyConAppCo role tc cos+       ; return (homogenise_result tyconapp_xi tyconapp_co role kind_co) }++-- Make the result of flattening homogeneous (Note [Flattening] (F2))+homogenise_result :: Xi              -- a flattened type+                  -> Coercion        -- :: xi ~r original ty+                  -> Role            -- r+                  -> CoercionN       -- kind_co :: tcTypeKind(xi) ~N tcTypeKind(ty)+                  -> (Xi, Coercion)  -- (xi |> kind_co, (xi |> kind_co)+                                     --   ~r original ty)+homogenise_result xi co r kind_co+  -- the explicit pattern match here improves the performance of T9872a, b, c by+  -- ~2%+  | isGReflCo kind_co = (xi `mkCastTy` kind_co, co)+  | otherwise         = (xi `mkCastTy` kind_co+                        , (mkSymCo $ GRefl r xi (MCo kind_co)) `mkTransCo` co)+{-# INLINE homogenise_result #-}++-- Flatten a vector (list of arguments).+flatten_vector :: Kind   -- of the function being applied to these arguments+               -> [Role] -- If we're flatten w.r.t. ReprEq, what roles do the+                         -- args have?+               -> [Type] -- the args to flatten+               -> FlatM ([Xi], [Coercion], CoercionN)+flatten_vector ki roles tys+  = do { eq_rel <- getEqRel+       ; case eq_rel of+           NomEq  -> flatten_args bndrs+                                  any_named_bndrs+                                  inner_ki+                                  fvs+                                  (repeat Nominal)+                                  tys+           ReprEq -> flatten_args bndrs+                                  any_named_bndrs+                                  inner_ki+                                  fvs+                                  roles+                                  tys+       }+  where+    (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki+    fvs                                = tyCoVarsOfType ki+{-# INLINE flatten_vector #-}++{-+Note [Flattening synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Not expanding synonyms aggressively improves error messages, and+keeps types smaller. But we need to take care.++Suppose+   type T a = a -> a+and we want to flatten the type (T (F a)).  Then we can safely flatten+the (F a) to a skolem, and return (T fsk).  We don't need to expand the+synonym.  This works because TcTyConAppCo can deal with synonyms+(unlike TyConAppCo), see Note [TcCoercions] in TcEvidence.++But (#8979) for+   type T a = (F a, a)    where F is a type function+we must expand the synonym in (say) T Int, to expose the type function+to the flattener.+++Note [Flattening under a forall]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Under a forall, we+  (a) MUST apply the inert substitution+  (b) MUST NOT flatten type family applications+Hence FMSubstOnly.++For (a) consider   c ~ a, a ~ T (forall b. (b, [c]))+If we don't apply the c~a substitution to the second constraint+we won't see the occurs-check error.++For (b) consider  (a ~ forall b. F a b), we don't want to flatten+to     (a ~ forall b.fsk, F a b ~ fsk)+because now the 'b' has escaped its scope.  We'd have to flatten to+       (a ~ forall b. fsk b, forall b. F a b ~ fsk b)+and we have not begun to think about how to make that work!++************************************************************************+*                                                                      *+             Flattening a type-family application+*                                                                      *+************************************************************************+-}++flatten_fam_app :: TyCon -> [TcType] -> FlatM (Xi, Coercion)+  --   flatten_fam_app            can be over-saturated+  --   flatten_exact_fam_app       is exactly saturated+  --   flatten_exact_fam_app_fully lifts out the application to top level+  -- Postcondition: Coercion :: Xi ~ F tys+flatten_fam_app tc tys  -- Can be over-saturated+    = ASSERT2( tys `lengthAtLeast` tyConArity tc+             , ppr tc $$ ppr (tyConArity tc) $$ ppr tys)++      do { mode <- getMode+         ; case mode of+             { FM_SubstOnly  -> flatten_ty_con_app tc tys+             ; FM_FlattenAll ->++                 -- Type functions are saturated+                 -- The type function might be *over* saturated+                 -- in which case the remaining arguments should+                 -- be dealt with by AppTys+      do { let (tys1, tys_rest) = splitAt (tyConArity tc) tys+         ; (xi1, co1) <- flatten_exact_fam_app_fully tc tys1+               -- co1 :: xi1 ~ F tys1++         ; flatten_app_ty_args xi1 co1 tys_rest } } }++-- the [TcType] exactly saturate the TyCon+-- See note [flatten_exact_fam_app_fully performance]+flatten_exact_fam_app_fully :: TyCon -> [TcType] -> FlatM (Xi, Coercion)+flatten_exact_fam_app_fully tc tys+  -- See Note [Reduce type family applications eagerly]+     -- the following tcTypeKind should never be evaluated, as it's just used in+     -- casting, and casts by refl are dropped+  = do { mOut <- try_to_reduce_nocache tc tys+       ; case mOut of+           Just out -> pure out+           Nothing -> do+               { -- First, flatten the arguments+               ; (xis, cos, kind_co)+                   <- setEqRel NomEq $  -- just do this once, instead of for+                                        -- each arg+                      flatten_args_tc tc (repeat Nominal) tys+                      -- kind_co :: tcTypeKind(F xis) ~N tcTypeKind(F tys)+               ; eq_rel   <- getEqRel+               ; cur_flav <- getFlavour+               ; let role   = eqRelRole eq_rel+                     ret_co = mkTyConAppCo role tc cos+                      -- ret_co :: F xis ~ F tys; might be heterogeneous++                -- Now, look in the cache+               ; mb_ct <- liftTcS $ lookupFlatCache tc xis+               ; case mb_ct of+                   Just (co, rhs_ty, flav)  -- co :: F xis ~ fsk+                        -- flav is [G] or [WD]+                        -- See Note [Type family equations] in TcSMonad+                     | (NotSwapped, _) <- flav `funEqCanDischargeF` cur_flav+                     ->  -- Usable hit in the flat-cache+                        do { traceFlat "flatten/flat-cache hit" $+                               (ppr tc <+> ppr xis $$ ppr rhs_ty)+                           ; (fsk_xi, fsk_co) <- flatten_one rhs_ty+                                  -- The fsk may already have been unified, so+                                  -- flatten it+                                  -- fsk_co :: fsk_xi ~ fsk+                           ; let xi  = fsk_xi `mkCastTy` kind_co+                                 co' = mkTcCoherenceLeftCo role fsk_xi kind_co fsk_co+                                       `mkTransCo`+                                       maybeSubCo eq_rel (mkSymCo co)+                                       `mkTransCo` ret_co+                           ; return (xi, co')+                           }+                                            -- :: fsk_xi ~ F xis++                   -- Try to reduce the family application right now+                   -- See Note [Reduce type family applications eagerly]+                   _ -> do { mOut <- try_to_reduce tc+                                                   xis+                                                   kind_co+                                                   (`mkTransCo` ret_co)+                           ; case mOut of+                               Just out -> pure out+                               Nothing -> do+                                 { loc <- getLoc+                                 ; (ev, co, fsk) <- liftTcS $+                                     newFlattenSkolem cur_flav loc tc xis++                                 -- The new constraint (F xis ~ fsk) is not+                                 -- necessarily inert (e.g. the LHS may be a+                                 -- redex) so we must put it in the work list+                                 ; let ct = CFunEqCan { cc_ev     = ev+                                                      , cc_fun    = tc+                                                      , cc_tyargs = xis+                                                      , cc_fsk    = fsk }+                                 ; emitFlatWork ct++                                 ; traceFlat "flatten/flat-cache miss" $+                                     (ppr tc <+> ppr xis $$ ppr fsk $$ ppr ev)++                                 -- NB: fsk's kind is already flattened because+                                 --     the xis are flattened+                                 ; let fsk_ty = mkTyVarTy fsk+                                       xi = fsk_ty `mkCastTy` kind_co+                                       co' = mkTcCoherenceLeftCo role fsk_ty kind_co (maybeSubCo eq_rel (mkSymCo co))+                                             `mkTransCo` ret_co+                                 ; return (xi, co')+                                 }+                           }+               }+        }++  where++    -- try_to_reduce and try_to_reduce_nocache (below) could be unified into+    -- a more general definition, but it was observed that separating them+    -- gives better performance (lower allocation numbers in T9872x).++    try_to_reduce :: TyCon   -- F, family tycon+                  -> [Type]  -- args, not necessarily flattened+                  -> CoercionN -- kind_co :: tcTypeKind(F args) ~N+                               --            tcTypeKind(F orig_args)+                               -- where+                               -- orig_args is what was passed to the outer+                               -- function+                  -> (   Coercion     -- :: (xi |> kind_co) ~ F args+                      -> Coercion )   -- what to return from outer function+                  -> FlatM (Maybe (Xi, Coercion))+    try_to_reduce tc tys kind_co update_co+      = do { checkStackDepth (mkTyConApp tc tys)+           ; mb_match <- liftTcS $ matchFam tc tys+           ; case mb_match of+                 -- NB: norm_co will always be homogeneous. All type families+                 -- are homogeneous.+               Just (norm_co, norm_ty)+                 -> do { traceFlat "Eager T.F. reduction success" $+                         vcat [ ppr tc, ppr tys, ppr norm_ty+                              , ppr norm_co <+> dcolon+                                            <+> ppr (coercionKind norm_co)+                              ]+                       ; (xi, final_co) <- bumpDepth $ flatten_one norm_ty+                       ; eq_rel <- getEqRel+                       ; let co = maybeSubCo eq_rel norm_co+                                   `mkTransCo` mkSymCo final_co+                       ; flavour <- getFlavour+                           -- NB: only extend cache with nominal equalities+                       ; when (eq_rel == NomEq) $+                         liftTcS $+                         extendFlatCache tc tys ( co, xi, flavour )+                       ; let role = eqRelRole eq_rel+                             xi' = xi `mkCastTy` kind_co+                             co' = update_co $+                                   mkTcCoherenceLeftCo role xi kind_co (mkSymCo co)+                       ; return $ Just (xi', co') }+               Nothing -> pure Nothing }++    try_to_reduce_nocache :: TyCon   -- F, family tycon+                          -> [Type]  -- args, not necessarily flattened+                          -> FlatM (Maybe (Xi, Coercion))+    try_to_reduce_nocache tc tys+      = do { checkStackDepth (mkTyConApp tc tys)+           ; mb_match <- liftTcS $ matchFam tc tys+           ; case mb_match of+                 -- NB: norm_co will always be homogeneous. All type families+                 -- are homogeneous.+               Just (norm_co, norm_ty)+                 -> do { (xi, final_co) <- bumpDepth $ flatten_one norm_ty+                       ; eq_rel <- getEqRel+                       ; let co  = mkSymCo (maybeSubCo eq_rel norm_co+                                            `mkTransCo` mkSymCo final_co)+                       ; return $ Just (xi, co) }+               Nothing -> pure Nothing }++{- Note [Reduce type family applications eagerly]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we come across a type-family application like (Append (Cons x Nil) t),+then, rather than flattening to a skolem etc, we may as well just reduce+it on the spot to (Cons x t).  This saves a lot of intermediate steps.+Examples that are helped are tests T9872, and T5321Fun.++Performance testing indicates that it's best to try this *twice*, once+before flattening arguments and once after flattening arguments.+Adding the extra reduction attempt before flattening arguments cut+the allocation amounts for the T9872{a,b,c} tests by half.++An example of where the early reduction appears helpful:++  type family Last x where+    Last '[x]     = x+    Last (h ': t) = Last t++  workitem: (x ~ Last '[1,2,3,4,5,6])++Flattening the argument never gets us anywhere, but trying to flatten+it at every step is quadratic in the length of the list. Reducing more+eagerly makes simplifying the right-hand type linear in its length.++Testing also indicated that the early reduction should *not* use the+flat-cache, but that the later reduction *should*. (Although the+effect was not large.)  Hence the Bool argument to try_to_reduce.  To+me (SLPJ) this seems odd; I get that eager reduction usually succeeds;+and if don't use the cache for eager reduction, we will miss most of+the opportunities for using it at all.  More exploration would be good+here.++At the end, once we've got a flat rhs, we extend the flatten-cache to record+the result. Doing so can save lots of work when the same redex shows up more+than once. Note that we record the link from the redex all the way to its+*final* value, not just the single step reduction. Interestingly, using the+flat-cache for the first reduction resulted in an increase in allocations+of about 3% for the four T9872x tests. However, using the flat-cache in+the later reduction is a similar gain. I (Richard E) don't currently (Dec '14)+have any knowledge as to *why* these facts are true.++************************************************************************+*                                                                      *+             Flattening a type variable+*                                                                      *+********************************************************************* -}++-- | The result of flattening a tyvar "one step".+data FlattenTvResult+  = FTRNotFollowed+      -- ^ The inert set doesn't make the tyvar equal to anything else++  | FTRFollowed TcType Coercion+      -- ^ The tyvar flattens to a not-necessarily flat other type.+      -- co :: new type ~r old type, where the role is determined by+      -- the FlattenEnv++flattenTyVar :: TyVar -> FlatM (Xi, Coercion)+flattenTyVar tv+  = do { mb_yes <- flatten_tyvar1 tv+       ; case mb_yes of+           FTRFollowed ty1 co1  -- Recur+             -> do { (ty2, co2) <- flatten_one ty1+                   -- ; traceFlat "flattenTyVar2" (ppr tv $$ ppr ty2)+                   ; return (ty2, co2 `mkTransCo` co1) }++           FTRNotFollowed   -- Done, but make sure the kind is zonked+                            -- Note [Flattening] invariant (F1)+             -> do { tv' <- liftTcS $ updateTyVarKindM zonkTcType tv+                   ; role <- getRole+                   ; let ty' = mkTyVarTy tv'+                   ; return (ty', mkTcReflCo role ty') } }++flatten_tyvar1 :: TcTyVar -> FlatM FlattenTvResult+-- "Flattening" a type variable means to apply the substitution to it+-- Specifically, look up the tyvar in+--   * the internal MetaTyVar box+--   * the inerts+-- See also the documentation for FlattenTvResult++flatten_tyvar1 tv+  = do { mb_ty <- liftTcS $ isFilledMetaTyVar_maybe tv+       ; case mb_ty of+           Just ty -> do { traceFlat "Following filled tyvar"+                             (ppr tv <+> equals <+> ppr ty)+                         ; role <- getRole+                         ; return (FTRFollowed ty (mkReflCo role ty)) } ;+           Nothing -> do { traceFlat "Unfilled tyvar" (ppr tv)+                         ; fr <- getFlavourRole+                         ; flatten_tyvar2 tv fr } }++flatten_tyvar2 :: TcTyVar -> CtFlavourRole -> FlatM FlattenTvResult+-- The tyvar is not a filled-in meta-tyvar+-- Try in the inert equalities+-- See Definition [Applying a generalised substitution] in TcSMonad+-- See Note [Stability of flattening] in TcSMonad++flatten_tyvar2 tv fr@(_, eq_rel)+  = do { ieqs <- liftTcS $ getInertEqs+       ; mode <- getMode+       ; case lookupDVarEnv ieqs tv of+           Just (ct:_)   -- If the first doesn't work,+                         -- the subsequent ones won't either+             | CTyEqCan { cc_ev = ctev, cc_tyvar = tv+                        , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct+             , let ct_fr = (ctEvFlavour ctev, ct_eq_rel)+             , ct_fr `eqCanRewriteFR` fr  -- This is THE key call of eqCanRewriteFR+             ->  do { traceFlat "Following inert tyvar"+                        (ppr mode <+>+                         ppr tv <+>+                         equals <+>+                         ppr rhs_ty $$ ppr ctev)+                    ; let rewrite_co1 = mkSymCo (ctEvCoercion ctev)+                          rewrite_co  = case (ct_eq_rel, eq_rel) of+                            (ReprEq, _rel)  -> ASSERT( _rel == ReprEq )+                                    -- if this ASSERT fails, then+                                    -- eqCanRewriteFR answered incorrectly+                                               rewrite_co1+                            (NomEq, NomEq)  -> rewrite_co1+                            (NomEq, ReprEq) -> mkSubCo rewrite_co1++                    ; return (FTRFollowed rhs_ty rewrite_co) }+                    -- NB: ct is Derived then fmode must be also, hence+                    -- we are not going to touch the returned coercion+                    -- so ctEvCoercion is fine.++           _other -> return FTRNotFollowed }++{-+Note [An alternative story for the inert substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(This entire note is just background, left here in case we ever want+ to return the previous state of affairs)++We used (GHC 7.8) to have this story for the inert substitution inert_eqs++ * 'a' is not in fvs(ty)+ * They are *inert* in the weaker sense that there is no infinite chain of+   (i1 `eqCanRewrite` i2), (i2 `eqCanRewrite` i3), etc++This means that flattening must be recursive, but it does allow+  [G] a ~ [b]+  [G] b ~ Maybe c++This avoids "saturating" the Givens, which can save a modest amount of work.+It is easy to implement, in TcInteract.kick_out, by only kicking out an inert+only if (a) the work item can rewrite the inert AND+        (b) the inert cannot rewrite the work item++This is significantly harder to think about. It can save a LOT of work+in occurs-check cases, but we don't care about them much.  #5837+is an example; all the constraints here are Givens++             [G] a ~ TF (a,Int)+    -->+    work     TF (a,Int) ~ fsk+    inert    fsk ~ a++    --->+    work     fsk ~ (TF a, TF Int)+    inert    fsk ~ a++    --->+    work     a ~ (TF a, TF Int)+    inert    fsk ~ a++    ---> (attempting to flatten (TF a) so that it does not mention a+    work     TF a ~ fsk2+    inert    a ~ (fsk2, TF Int)+    inert    fsk ~ (fsk2, TF Int)++    ---> (substitute for a)+    work     TF (fsk2, TF Int) ~ fsk2+    inert    a ~ (fsk2, TF Int)+    inert    fsk ~ (fsk2, TF Int)++    ---> (top-level reduction, re-orient)+    work     fsk2 ~ (TF fsk2, TF Int)+    inert    a ~ (fsk2, TF Int)+    inert    fsk ~ (fsk2, TF Int)++    ---> (attempt to flatten (TF fsk2) to get rid of fsk2+    work     TF fsk2 ~ fsk3+    work     fsk2 ~ (fsk3, TF Int)+    inert    a   ~ (fsk2, TF Int)+    inert    fsk ~ (fsk2, TF Int)++    --->+    work     TF fsk2 ~ fsk3+    inert    fsk2 ~ (fsk3, TF Int)+    inert    a   ~ ((fsk3, TF Int), TF Int)+    inert    fsk ~ ((fsk3, TF Int), TF Int)++Because the incoming given rewrites all the inert givens, we get more and+more duplication in the inert set.  But this really only happens in pathalogical+casee, so we don't care.+++************************************************************************+*                                                                      *+             Unflattening+*                                                                      *+************************************************************************++An unflattening example:+    [W] F a ~ alpha+flattens to+    [W] F a ~ fmv   (CFunEqCan)+    [W] fmv ~ alpha (CTyEqCan)+We must solve both!+-}++unflattenWanteds :: Cts -> Cts -> TcS Cts+unflattenWanteds tv_eqs funeqs+ = do { tclvl    <- getTcLevel++      ; traceTcS "Unflattening" $ braces $+        vcat [ text "Funeqs =" <+> pprCts funeqs+             , text "Tv eqs =" <+> pprCts tv_eqs ]++         -- Step 1: unflatten the CFunEqCans, except if that causes an occurs check+         -- Occurs check: consider  [W] alpha ~ [F alpha]+         --                 ==> (flatten) [W] F alpha ~ fmv, [W] alpha ~ [fmv]+         --                 ==> (unify)   [W] F [fmv] ~ fmv+         -- See Note [Unflatten using funeqs first]+      ; funeqs <- foldrBagM unflatten_funeq emptyCts funeqs+      ; traceTcS "Unflattening 1" $ braces (pprCts funeqs)++          -- Step 2: unify the tv_eqs, if possible+      ; tv_eqs  <- foldrBagM (unflatten_eq tclvl) emptyCts tv_eqs+      ; traceTcS "Unflattening 2" $ braces (pprCts tv_eqs)++          -- Step 3: fill any remaining fmvs with fresh unification variables+      ; funeqs <- mapBagM finalise_funeq funeqs+      ; traceTcS "Unflattening 3" $ braces (pprCts funeqs)++          -- Step 4: remove any tv_eqs that look like ty ~ ty+      ; tv_eqs <- foldrBagM finalise_eq emptyCts tv_eqs++      ; let all_flat = tv_eqs `andCts` funeqs+      ; traceTcS "Unflattening done" $ braces (pprCts all_flat)++      ; return all_flat }+  where+    ----------------+    unflatten_funeq :: Ct -> Cts -> TcS Cts+    unflatten_funeq ct@(CFunEqCan { cc_fun = tc, cc_tyargs = xis+                                  , cc_fsk = fmv, cc_ev = ev }) rest+      = do {   -- fmv should be an un-filled flatten meta-tv;+               -- we now fix its final value by filling it, being careful+               -- to observe the occurs check.  Zonking will eliminate it+               -- altogether in due course+             rhs' <- zonkTcType (mkTyConApp tc xis)+           ; case occCheckExpand [fmv] rhs' of+               Just rhs''    -- Normal case: fill the tyvar+                 -> do { setReflEvidence ev NomEq rhs''+                       ; unflattenFmv fmv rhs''+                       ; return rest }++               Nothing ->  -- Occurs check+                          return (ct `consCts` rest) }++    unflatten_funeq other_ct _+      = pprPanic "unflatten_funeq" (ppr other_ct)++    ----------------+    finalise_funeq :: Ct -> TcS Ct+    finalise_funeq (CFunEqCan { cc_fsk = fmv, cc_ev = ev })+      = do { demoteUnfilledFmv fmv+           ; return (mkNonCanonical ev) }+    finalise_funeq ct = pprPanic "finalise_funeq" (ppr ct)++    ----------------+    unflatten_eq :: TcLevel -> Ct -> Cts -> TcS Cts+    unflatten_eq tclvl ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv+                                    , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest++      | NomEq <- eq_rel -- See Note [Do not unify representational equalities]+                        --     in TcInteract+      , isFmvTyVar tv   -- Previously these fmvs were untouchable,+                        -- but now they are touchable+                        -- NB: unlike unflattenFmv, filling a fmv here /does/+                        --     bump the unification count; it is "improvement"+                        -- Note [Unflattening can force the solver to iterate]+      = ASSERT2( tyVarKind tv `eqType` tcTypeKind rhs, ppr ct )+           -- CTyEqCan invariant should ensure this is true+        do { is_filled <- isFilledMetaTyVar tv+           ; elim <- case is_filled of+               False -> do { traceTcS "unflatten_eq 2" (ppr ct)+                           ; tryFill ev tv rhs }+               True  -> do { traceTcS "unflatten_eq 3" (ppr ct)+                           ; try_fill_rhs ev tclvl tv rhs }+           ; if elim+             then do { setReflEvidence ev eq_rel (mkTyVarTy tv)+                     ; return rest }+             else return (ct `consCts` rest) }++      | otherwise+      = return (ct `consCts` rest)++    unflatten_eq _ ct _ = pprPanic "unflatten_irred" (ppr ct)++    ----------------+    try_fill_rhs ev tclvl lhs_tv rhs+         -- Constraint is lhs_tv ~ rhs_tv,+         -- and lhs_tv is filled, so try RHS+      | Just (rhs_tv, co) <- getCastedTyVar_maybe rhs+                             -- co :: kind(rhs_tv) ~ kind(lhs_tv)+      , isFmvTyVar rhs_tv || (isTouchableMetaTyVar tclvl rhs_tv+                              && not (isTyVarTyVar rhs_tv))+                              -- LHS is a filled fmv, and so is a type+                              -- family application, which a TyVarTv should+                              -- not unify with+      = do { is_filled <- isFilledMetaTyVar rhs_tv+           ; if is_filled then return False+             else tryFill ev rhs_tv+                          (mkTyVarTy lhs_tv `mkCastTy` mkSymCo co) }++      | otherwise+      = return False++    ----------------+    finalise_eq :: Ct -> Cts -> TcS Cts+    finalise_eq (CTyEqCan { cc_ev = ev, cc_tyvar = tv+                          , cc_rhs = rhs, cc_eq_rel = eq_rel }) rest+      | isFmvTyVar tv+      = do { ty1 <- zonkTcTyVar tv+           ; rhs' <- zonkTcType rhs+           ; if ty1 `tcEqType` rhs'+             then do { setReflEvidence ev eq_rel rhs'+                     ; return rest }+             else return (mkNonCanonical ev `consCts` rest) }++      | otherwise+      = return (mkNonCanonical ev `consCts` rest)++    finalise_eq ct _ = pprPanic "finalise_irred" (ppr ct)++tryFill :: CtEvidence -> TcTyVar -> TcType -> TcS Bool+-- (tryFill tv rhs ev) assumes 'tv' is an /un-filled/ MetaTv+-- If tv does not appear in 'rhs', it set tv := rhs,+-- binds the evidence (which should be a CtWanted) to Refl<rhs>+-- and return True.  Otherwise returns False+tryFill ev tv rhs+  = ASSERT2( not (isGiven ev), ppr ev )+    do { rhs' <- zonkTcType rhs+       ; case () of+            _ | Just tv' <- tcGetTyVar_maybe rhs'+              , tv == tv'   -- tv == rhs+              -> return True++            _ | Just rhs'' <- occCheckExpand [tv] rhs'+              -> do {       -- Fill the tyvar+                      unifyTyVar tv rhs''+                    ; return True }++            _ | otherwise   -- Occurs check+              -> return False+    }++setReflEvidence :: CtEvidence -> EqRel -> TcType -> TcS ()+setReflEvidence ev eq_rel rhs+  = setEvBindIfWanted ev (evCoercion refl_co)+  where+    refl_co = mkTcReflCo (eqRelRole eq_rel) rhs++{-+Note [Unflatten using funeqs first]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    [W] G a ~ Int+    [W] F (G a) ~ G a++do not want to end up with+    [W] F Int ~ Int+because that might actually hold!  Better to end up with the two above+unsolved constraints.  The flat form will be++    G a ~ fmv1     (CFunEqCan)+    F fmv1 ~ fmv2  (CFunEqCan)+    fmv1 ~ Int     (CTyEqCan)+    fmv1 ~ fmv2    (CTyEqCan)++Flatten using the fun-eqs first.+-}++-- | Like 'splitPiTys'' but comes with a 'Bool' which is 'True' iff there is at+-- least one named binder.+split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool)+split_pi_tys' ty = split ty ty+  where+  split orig_ty ty | Just ty' <- coreView ty = split orig_ty ty'+  split _       (ForAllTy b res) = let (bs, ty, _) = split res res+                                   in  (Named b : bs, ty, True)+  split _       (FunTy { ft_af = af, ft_arg = arg, ft_res = res })+                                 = let (bs, ty, named) = split res res+                                   in  (Anon af arg : bs, ty, named)+  split orig_ty _                = ([], orig_ty, False)+{-# INLINE split_pi_tys' #-}++-- | Like 'tyConBindersTyCoBinders' but you also get a 'Bool' which is true iff+-- there is at least one named binder.+ty_con_binders_ty_binders' :: [TyConBinder] -> ([TyCoBinder], Bool)+ty_con_binders_ty_binders' = foldr go ([], False)+  where+    go (Bndr tv (NamedTCB vis)) (bndrs, _)+      = (Named (Bndr tv vis) : bndrs, True)+    go (Bndr tv (AnonTCB af))   (bndrs, n)+      = (Anon af (tyVarKind tv)   : bndrs, n)+    {-# INLINE go #-}+{-# INLINE ty_con_binders_ty_binders' #-}
+ compiler/typecheck/TcForeign.hs view
@@ -0,0 +1,569 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1998++\section[TcForeign]{Typechecking \tr{foreign} declarations}++A foreign declaration is used to either give an externally+implemented function a Haskell type (and calling interface) or+give a Haskell function an external calling interface. Either way,+the range of argument and result types these functions can accommodate+is restricted to what the outside world understands (read C), and this+module checks to see if a foreign declaration has got a legal type.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}++module TcForeign+        ( tcForeignImports+        , tcForeignExports++        -- Low-level exports for hooks+        , isForeignImport, isForeignExport+        , tcFImport, tcFExport+        , tcForeignImports'+        , tcCheckFIType, checkCTarget, checkForeignArgs, checkForeignRes+        , normaliseFfiType+        , nonIOok, mustBeIO+        , checkSafe, noCheckSafe+        , tcForeignExports'+        , tcCheckFEType+        ) where++#include "HsVersions.h"++import GhcPrelude++import HsSyn++import TcRnMonad+import TcHsType+import TcExpr+import TcEnv++import FamInst+import FamInstEnv+import Coercion+import Type+import ForeignCall+import ErrUtils+import Id+import Name+import RdrName+import DataCon+import TyCon+import TcType+import PrelNames+import DynFlags+import Outputable+import Platform+import SrcLoc+import Bag+import Hooks+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.Maybe++-- Defines a binding+isForeignImport :: LForeignDecl name -> Bool+isForeignImport (L _ (ForeignImport {})) = True+isForeignImport _                        = False++-- Exports a binding+isForeignExport :: LForeignDecl name -> Bool+isForeignExport (L _ (ForeignExport {})) = True+isForeignExport _                        = False++{-+Note [Don't recur in normaliseFfiType']+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+normaliseFfiType' is the workhorse for normalising a type used in a foreign+declaration. If we have++newtype Age = MkAge Int++we want to see that Age -> IO () is the same as Int -> IO (). But, we don't+need to recur on any type parameters, because no paramaterized types (with+interesting parameters) are marshalable! The full list of marshalable types+is in the body of boxedMarshalableTyCon in TcType. The only members of that+list not at kind * are Ptr, FunPtr, and StablePtr, all of which get marshaled+the same way regardless of type parameter. So, no need to recur into+parameters.++Similarly, we don't need to look in AppTy's, because nothing headed by+an AppTy will be marshalable.++Note [FFI type roles]+~~~~~~~~~~~~~~~~~~~~~+The 'go' helper function within normaliseFfiType' always produces+representational coercions. But, in the "children_only" case, we need to+use these coercions in a TyConAppCo. Accordingly, the roles on the coercions+must be twiddled to match the expectation of the enclosing TyCon. However,+we cannot easily go from an R coercion to an N one, so we forbid N roles+on FFI type constructors. Currently, only two such type constructors exist:+IO and FunPtr. Thus, this is not an onerous burden.++If we ever want to lift this restriction, we would need to make 'go' take+the target role as a parameter. This wouldn't be hard, but it's a complication+not yet necessary and so is not yet implemented.+-}++-- normaliseFfiType takes the type from an FFI declaration, and+-- evaluates any type synonyms, type functions, and newtypes. However,+-- we are only allowed to look through newtypes if the constructor is+-- in scope.  We return a bag of all the newtype constructors thus found.+-- Always returns a Representational coercion+normaliseFfiType :: Type -> TcM (Coercion, Type, Bag GlobalRdrElt)+normaliseFfiType ty+    = do fam_envs <- tcGetFamInstEnvs+         normaliseFfiType' fam_envs ty++normaliseFfiType' :: FamInstEnvs -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)+normaliseFfiType' env ty0 = go initRecTc ty0+  where+    go :: RecTcChecker -> Type -> TcM (Coercion, Type, Bag GlobalRdrElt)+    go rec_nts ty+      | Just ty' <- tcView ty     -- Expand synonyms+      = go rec_nts ty'++      | Just (tc, tys) <- splitTyConApp_maybe ty+      = go_tc_app rec_nts tc tys++      | (bndrs, inner_ty) <- splitForAllVarBndrs ty+      , not (null bndrs)+      = do (coi, nty1, gres1) <- go rec_nts inner_ty+           return ( mkHomoForAllCos (binderVars bndrs) coi+                  , mkForAllTys bndrs nty1, gres1 )++      | otherwise -- see Note [Don't recur in normaliseFfiType']+      = return (mkRepReflCo ty, ty, emptyBag)++    go_tc_app :: RecTcChecker -> TyCon -> [Type]+              -> TcM (Coercion, Type, Bag GlobalRdrElt)+    go_tc_app rec_nts tc tys+        -- We don't want to look through the IO newtype, even if it is+        -- in scope, so we have a special case for it:+        | tc_key `elem` [ioTyConKey, funPtrTyConKey, funTyConKey]+                  -- These *must not* have nominal roles on their parameters!+                  -- See Note [FFI type roles]+        = children_only++        | isNewTyCon tc         -- Expand newtypes+        , Just rec_nts' <- checkRecTc rec_nts tc+                   -- See Note [Expanding newtypes] in TyCon.hs+                   -- We can't just use isRecursiveTyCon; sometimes recursion is ok:+                   --     newtype T = T (Ptr T)+                   --   Here, we don't reject the type for being recursive.+                   -- If this is a recursive newtype then it will normally+                   -- be rejected later as not being a valid FFI type.+        = do { rdr_env <- getGlobalRdrEnv+             ; case checkNewtypeFFI rdr_env tc of+                 Nothing  -> nothing+                 Just gre -> do { (co', ty', gres) <- go rec_nts' nt_rhs+                                ; return (mkTransCo nt_co co', ty', gre `consBag` gres) } }++        | isFamilyTyCon tc              -- Expand open tycons+        , (co, ty) <- normaliseTcApp env Representational tc tys+        , not (isReflexiveCo co)+        = do (co', ty', gres) <- go rec_nts ty+             return (mkTransCo co co', ty', gres)++        | otherwise+        = nothing -- see Note [Don't recur in normaliseFfiType']+        where+          tc_key = getUnique tc+          children_only+            = do xs <- mapM (go rec_nts) tys+                 let (cos, tys', gres) = unzip3 xs+                        -- the (repeat Representational) is because 'go' always+                        -- returns R coercions+                     cos' = zipWith3 downgradeRole (tyConRoles tc)+                                     (repeat Representational) cos+                 return ( mkTyConAppCo Representational tc cos'+                        , mkTyConApp tc tys', unionManyBags gres)+          nt_co  = mkUnbranchedAxInstCo Representational (newTyConCo tc) tys []+          nt_rhs = newTyConInstRhs tc tys++          ty      = mkTyConApp tc tys+          nothing = return (mkRepReflCo ty, ty, emptyBag)++checkNewtypeFFI :: GlobalRdrEnv -> TyCon -> Maybe GlobalRdrElt+checkNewtypeFFI rdr_env tc+  | Just con <- tyConSingleDataCon_maybe tc+  , Just gre <- lookupGRE_Name rdr_env (dataConName con)+  = Just gre    -- See Note [Newtype constructor usage in foreign declarations]+  | otherwise+  = Nothing++{-+Note [Newtype constructor usage in foreign declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC automatically "unwraps" newtype constructors in foreign import/export+declarations.  In effect that means that a newtype data constructor is+used even though it is not mentioned expclitly in the source, so we don't+want to report it as "defined but not used" or "imported but not used".+eg     newtype D = MkD Int+       foreign import foo :: D -> IO ()+Here 'MkD' us used.  See #7408.++GHC also expands type functions during this process, so it's not enough+just to look at the free variables of the declaration.+eg     type instance F Bool = D+       foreign import bar :: F Bool -> IO ()+Here again 'MkD' is used.++So we really have wait until the type checker to decide what is used.+That's why tcForeignImports and tecForeignExports return a (Bag GRE)+for the newtype constructors they see. Then TcRnDriver can add them+to the module's usages.+++************************************************************************+*                                                                      *+\subsection{Imports}+*                                                                      *+************************************************************************+-}++tcForeignImports :: [LForeignDecl GhcRn]+                 -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)+tcForeignImports decls+  = getHooked tcForeignImportsHook tcForeignImports' >>= ($ decls)++tcForeignImports' :: [LForeignDecl GhcRn]+                  -> TcM ([Id], [LForeignDecl GhcTc], Bag GlobalRdrElt)+-- For the (Bag GlobalRdrElt) result,+-- see Note [Newtype constructor usage in foreign declarations]+tcForeignImports' decls+  = do { (ids, decls, gres) <- mapAndUnzip3M tcFImport $+                               filter isForeignImport decls+       ; return (ids, decls, unionManyBags gres) }++tcFImport :: LForeignDecl GhcRn+          -> TcM (Id, LForeignDecl GhcTc, Bag GlobalRdrElt)+tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty+                                    , fd_fi = imp_decl }))+  = setSrcSpan dloc $ addErrCtxt (foreignDeclCtxt fo)  $+    do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty+       ; (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty+       ; let+           -- Drop the foralls before inspecting the+           -- structure of the foreign type.+             (bndrs, res_ty)   = tcSplitPiTys norm_sig_ty+             arg_tys           = mapMaybe binderRelevantType_maybe bndrs+             id                = mkLocalId nm sig_ty+                 -- Use a LocalId to obey the invariant that locally-defined+                 -- things are LocalIds.  However, it does not need zonking,+                 -- (so TcHsSyn.zonkForeignExports ignores it).++       ; imp_decl' <- tcCheckFIType arg_tys res_ty imp_decl+          -- Can't use sig_ty here because sig_ty :: Type and+          -- we need HsType Id hence the undefined+       ; let fi_decl = ForeignImport { fd_name = L nloc id+                                     , fd_sig_ty = undefined+                                     , fd_i_ext = mkSymCo norm_co+                                     , fd_fi = imp_decl' }+       ; return (id, L dloc fi_decl, gres) }+tcFImport d = pprPanic "tcFImport" (ppr d)++-- ------------ Checking types for foreign import ----------------------++tcCheckFIType :: [Type] -> Type -> ForeignImport -> TcM ForeignImport++tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src)+  -- Foreign import label+  = do checkCg checkCOrAsmOrLlvmOrInterp+       -- NB check res_ty not sig_ty!+       --    In case sig_ty is (forall a. ForeignPtr a)+       check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)+       cconv' <- checkCConv cconv+       return (CImport (L lc cconv') safety mh l src)++tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do+        -- Foreign wrapper (former f.e.d.)+        -- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid+        -- foreign type.  For legacy reasons ft -> IO (Ptr ft) is accepted, too.+        -- The use of the latter form is DEPRECATED, though.+    checkCg checkCOrAsmOrLlvmOrInterp+    cconv' <- checkCConv cconv+    case arg_tys of+        [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys+                        checkForeignRes nonIOok  checkSafe isFFIExportResultTy res1_ty+                        checkForeignRes mustBeIO checkSafe (isFFIDynTy arg1_ty) res_ty+                  where+                     (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty+        _ -> addErrTc (illegalForeignTyErr Outputable.empty (text "One argument expected"))+    return (CImport (L lc cconv') safety mh CWrapper src)++tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh+                                            (CFunction target) src)+  | isDynamicTarget target = do -- Foreign import dynamic+      checkCg checkCOrAsmOrLlvmOrInterp+      cconv' <- checkCConv cconv+      case arg_tys of           -- The first arg must be Ptr or FunPtr+        []                ->+          addErrTc (illegalForeignTyErr Outputable.empty (text "At least one argument expected"))+        (arg1_ty:arg_tys) -> do+          dflags <- getDynFlags+          let curried_res_ty = mkVisFunTys arg_tys res_ty+          check (isFFIDynTy curried_res_ty arg1_ty)+                (illegalForeignTyErr argument)+          checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys+          checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty+      return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src+  | cconv == PrimCallConv = do+      dflags <- getDynFlags+      checkTc (xopt LangExt.GHCForeignImportPrim dflags)+              (text "Use GHCForeignImportPrim to allow `foreign import prim'.")+      checkCg checkCOrAsmOrLlvmOrInterp+      checkCTarget target+      checkTc (playSafe safety)+              (text "The safe/unsafe annotation should not be used with `foreign import prim'.")+      checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys+      -- prim import result is more liberal, allows (#,,#)+      checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty+      return idecl+  | otherwise = do              -- Normal foreign import+      checkCg checkCOrAsmOrLlvmOrInterp+      cconv' <- checkCConv cconv+      checkCTarget target+      dflags <- getDynFlags+      checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys+      checkForeignRes nonIOok checkSafe (isFFIImportResultTy dflags) res_ty+      checkMissingAmpersand dflags arg_tys res_ty+      case target of+          StaticTarget _ _ _ False+           | not (null arg_tys) ->+              addErrTc (text "`value' imports cannot have function types")+          _ -> return ()+      return $ CImport (L lc cconv') (L ls safety) mh (CFunction target) src+++-- This makes a convenient place to check+-- that the C identifier is valid for C+checkCTarget :: CCallTarget -> TcM ()+checkCTarget (StaticTarget _ str _ _) = do+    checkCg checkCOrAsmOrLlvmOrInterp+    checkTc (isCLabelString str) (badCName str)++checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"+++checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM ()+checkMissingAmpersand dflags arg_tys res_ty+  | null arg_tys && isFunPtrTy res_ty &&+    wopt Opt_WarnDodgyForeignImports dflags+  = addWarn (Reason Opt_WarnDodgyForeignImports)+        (text "possible missing & in foreign import of FunPtr")+  | otherwise+  = return ()++{-+************************************************************************+*                                                                      *+\subsection{Exports}+*                                                                      *+************************************************************************+-}++tcForeignExports :: [LForeignDecl GhcRn]+             -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt)+tcForeignExports decls =+  getHooked tcForeignExportsHook tcForeignExports' >>= ($ decls)++tcForeignExports' :: [LForeignDecl GhcRn]+             -> TcM (LHsBinds GhcTcId, [LForeignDecl GhcTcId], Bag GlobalRdrElt)+-- For the (Bag GlobalRdrElt) result,+-- see Note [Newtype constructor usage in foreign declarations]+tcForeignExports' decls+  = foldlM combine (emptyLHsBinds, [], emptyBag) (filter isForeignExport decls)+  where+   combine (binds, fs, gres1) (L loc fe) = do+       (b, f, gres2) <- setSrcSpan loc (tcFExport fe)+       return (b `consBag` binds, L loc f : fs, gres1 `unionBags` gres2)++tcFExport :: ForeignDecl GhcRn+          -> TcM (LHsBind GhcTc, ForeignDecl GhcTc, Bag GlobalRdrElt)+tcFExport fo@(ForeignExport { fd_name = L loc nm, fd_sig_ty = hs_ty, fd_fe = spec })+  = addErrCtxt (foreignDeclCtxt fo) $ do++    sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty+    rhs <- tcPolyExpr (nlHsVar nm) sig_ty++    (norm_co, norm_sig_ty, gres) <- normaliseFfiType sig_ty++    spec' <- tcCheckFEType norm_sig_ty spec++           -- we're exporting a function, but at a type possibly more+           -- constrained than its declared/inferred type. Hence the need+           -- to create a local binding which will call the exported function+           -- at a particular type (and, maybe, overloading).+++    -- We need to give a name to the new top-level binding that+    -- is *stable* (i.e. the compiler won't change it later),+    -- because this name will be referred to by the C code stub.+    id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc+    return ( mkVarBind id rhs+           , ForeignExport { fd_name = L loc id+                           , fd_sig_ty = undefined+                           , fd_e_ext = norm_co, fd_fe = spec' }+           , gres)+tcFExport d = pprPanic "tcFExport" (ppr d)++-- ------------ Checking argument types for foreign export ----------------------++tcCheckFEType :: Type -> ForeignExport -> TcM ForeignExport+tcCheckFEType sig_ty (CExport (L l (CExportStatic esrc str cconv)) src) = do+    checkCg checkCOrAsmOrLlvm+    checkTc (isCLabelString str) (badCName str)+    cconv' <- checkCConv cconv+    checkForeignArgs isFFIExternalTy arg_tys+    checkForeignRes nonIOok noCheckSafe isFFIExportResultTy res_ty+    return (CExport (L l (CExportStatic esrc str cconv')) src)+  where+      -- Drop the foralls before inspecting n+      -- the structure of the foreign type.+    (bndrs, res_ty) = tcSplitPiTys sig_ty+    arg_tys         = mapMaybe binderRelevantType_maybe bndrs++{-+************************************************************************+*                                                                      *+\subsection{Miscellaneous}+*                                                                      *+************************************************************************+-}++------------ Checking argument types for foreign import ----------------------+checkForeignArgs :: (Type -> Validity) -> [Type] -> TcM ()+checkForeignArgs pred tys = mapM_ go tys+  where+    go ty = check (pred ty) (illegalForeignTyErr argument)++------------ Checking result types for foreign calls ----------------------+-- | Check that the type has the form+--    (IO t) or (t) , and that t satisfies the given predicate.+-- When calling this function, any newtype wrappers (should) have been+-- already dealt with by normaliseFfiType.+--+-- We also check that the Safe Haskell condition of FFI imports having+-- results in the IO monad holds.+--+checkForeignRes :: Bool -> Bool -> (Type -> Validity) -> Type -> TcM ()+checkForeignRes non_io_result_ok check_safe pred_res_ty ty+  | Just (_, res_ty) <- tcSplitIOType_maybe ty+  =     -- Got an IO result type, that's always fine!+     check (pred_res_ty res_ty) (illegalForeignTyErr result)++  -- Case for non-IO result type with FFI Import+  | not non_io_result_ok+  = addErrTc $ illegalForeignTyErr result (text "IO result type expected")++  | otherwise+  = do { dflags <- getDynFlags+       ; case pred_res_ty ty of+                -- Handle normal typecheck fail, we want to handle this first and+                -- only report safe haskell errors if the normal type check is OK.+           NotValid msg -> addErrTc $ illegalForeignTyErr result msg++           -- handle safe infer fail+           _ | check_safe && safeInferOn dflags+               -> recordUnsafeInfer emptyBag++           -- handle safe language typecheck fail+           _ | check_safe && safeLanguageOn dflags+               -> addErrTc (illegalForeignTyErr result safeHsErr)++           -- success! non-IO return is fine+           _ -> return () }+  where+    safeHsErr =+      text "Safe Haskell is on, all FFI imports must be in the IO monad"++nonIOok, mustBeIO :: Bool+nonIOok  = True+mustBeIO = False++checkSafe, noCheckSafe :: Bool+checkSafe   = True+noCheckSafe = False++-- Checking a supported backend is in use++checkCOrAsmOrLlvm :: HscTarget -> Validity+checkCOrAsmOrLlvm HscC    = IsValid+checkCOrAsmOrLlvm HscAsm  = IsValid+checkCOrAsmOrLlvm HscLlvm = IsValid+checkCOrAsmOrLlvm _+  = NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)")++checkCOrAsmOrLlvmOrInterp :: HscTarget -> Validity+checkCOrAsmOrLlvmOrInterp HscC           = IsValid+checkCOrAsmOrLlvmOrInterp HscAsm         = IsValid+checkCOrAsmOrLlvmOrInterp HscLlvm        = IsValid+checkCOrAsmOrLlvmOrInterp HscInterpreted = IsValid+checkCOrAsmOrLlvmOrInterp _+  = NotValid (text "requires interpreted, unregisterised, llvm or native code generation")++checkCg :: (HscTarget -> Validity) -> TcM ()+checkCg check = do+    dflags <- getDynFlags+    let target = hscTarget dflags+    case target of+      HscNothing -> return ()+      _ ->+        case check target of+          IsValid      -> return ()+          NotValid err -> addErrTc (text "Illegal foreign declaration:" <+> err)++-- Calling conventions++checkCConv :: CCallConv -> TcM CCallConv+checkCConv CCallConv    = return CCallConv+checkCConv CApiConv     = return CApiConv+checkCConv StdCallConv  = do dflags <- getDynFlags+                             let platform = targetPlatform dflags+                             if platformArch platform == ArchX86+                                 then return StdCallConv+                                 else do -- This is a warning, not an error. see #3336+                                         when (wopt Opt_WarnUnsupportedCallingConventions dflags) $+                                             addWarnTc (Reason Opt_WarnUnsupportedCallingConventions)+                                                 (text "the 'stdcall' calling convention is unsupported on this platform," $$ text "treating as ccall")+                                         return CCallConv+checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'")+                             return PrimCallConv+checkCConv JavaScriptCallConv = do dflags <- getDynFlags+                                   if platformArch (targetPlatform dflags) == ArchJavaScript+                                       then return JavaScriptCallConv+                                       else do addErrTc (text "The `javascript' calling convention is unsupported on this platform")+                                               return JavaScriptCallConv++-- Warnings++check :: Validity -> (MsgDoc -> MsgDoc) -> TcM ()+check IsValid _             = return ()+check (NotValid doc) err_fn = addErrTc (err_fn doc)++illegalForeignTyErr :: SDoc -> SDoc -> SDoc+illegalForeignTyErr arg_or_res extra+  = hang msg 2 extra+  where+    msg = hsep [ text "Unacceptable", arg_or_res+               , text "type in foreign declaration:"]++-- Used for 'arg_or_res' argument to illegalForeignTyErr+argument, result :: SDoc+argument = text "argument"+result   = text "result"++badCName :: CLabelString -> MsgDoc+badCName target+  = sep [quotes (ppr target) <+> text "is not a valid C identifier"]++foreignDeclCtxt :: ForeignDecl GhcRn -> SDoc+foreignDeclCtxt fo+  = hang (text "When checking declaration:")+       2 (ppr fo)
+ compiler/typecheck/TcGenDeriv.hs view
@@ -0,0 +1,2391 @@+{-+    %+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++TcGenDeriv: Generating derived instance declarations++This module is nominally ``subordinate'' to @TcDeriv@, which is the+``official'' interface to deriving-related things.++This is where we do all the grimy bindings' generation.+-}++{-# LANGUAGE CPP, ScopedTypeVariables #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module TcGenDeriv (+        BagDerivStuff, DerivStuff(..),++        gen_Eq_binds,+        gen_Ord_binds,+        gen_Enum_binds,+        gen_Bounded_binds,+        gen_Ix_binds,+        gen_Show_binds,+        gen_Read_binds,+        gen_Data_binds,+        gen_Lift_binds,+        gen_Newtype_binds,+        mkCoerceClassMethEqn,+        genAuxBinds,+        ordOpTbl, boxConTbl, litConTbl,+        mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr+    ) where++#include "HsVersions.h"++import GhcPrelude++import TcRnMonad+import HsSyn+import RdrName+import BasicTypes+import DataCon+import Name+import Fingerprint+import Encoding++import DynFlags+import PrelInfo+import FamInst+import FamInstEnv+import PrelNames+import THNames+import MkId ( coerceId )+import PrimOp+import SrcLoc+import TyCon+import TcEnv+import TcType+import TcValidity ( checkValidCoAxBranch )+import CoAxiom    ( coAxiomSingleBranch )+import TysPrim+import TysWiredIn+import Type+import Class+import VarSet+import VarEnv+import Util+import Var+import Outputable+import Lexeme+import FastString+import Pair+import Bag++import Data.List  ( find, partition, intersperse )++type BagDerivStuff = Bag DerivStuff++data AuxBindSpec+  = DerivCon2Tag TyCon  -- The con2Tag for given TyCon+  | DerivTag2Con TyCon  -- ...ditto tag2Con+  | DerivMaxTag  TyCon  -- ...and maxTag+  deriving( Eq )+  -- All these generate ZERO-BASED tag operations+  -- I.e first constructor has tag 0++data DerivStuff     -- Please add this auxiliary stuff+  = DerivAuxBind AuxBindSpec++  -- Generics and DeriveAnyClass+  | DerivFamInst FamInst               -- New type family instances++  -- New top-level auxiliary bindings+  | DerivHsBind (LHsBind GhcPs, LSig GhcPs) -- Also used for SYB+++{-+************************************************************************+*                                                                      *+                Eq instances+*                                                                      *+************************************************************************++Here are the heuristics for the code we generate for @Eq@. Let's+assume we have a data type with some (possibly zero) nullary data+constructors and some ordinary, non-nullary ones (the rest, also+possibly zero of them).  Here's an example, with both \tr{N}ullary and+\tr{O}rdinary data cons.++  data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...++* For the ordinary constructors (if any), we emit clauses to do The+  Usual Thing, e.g.,:++    (==) (O1 a1 b1)    (O1 a2 b2)    = a1 == a2 && b1 == b2+    (==) (O2 a1)       (O2 a2)       = a1 == a2+    (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2++  Note: if we're comparing unlifted things, e.g., if 'a1' and+  'a2' are Float#s, then we have to generate+       case (a1 `eqFloat#` a2) of r -> r+  for that particular test.++* If there are a lot of (more than ten) nullary constructors, we emit a+  catch-all clause of the form:++      (==) a b  = case (con2tag_Foo a) of { a# ->+                  case (con2tag_Foo b) of { b# ->+                  case (a# ==# b#)     of {+                    r -> r }}}++  If con2tag gets inlined this leads to join point stuff, so+  it's better to use regular pattern matching if there aren't too+  many nullary constructors.  "Ten" is arbitrary, of course++* If there aren't any nullary constructors, we emit a simpler+  catch-all:++     (==) a b  = False++* For the @(/=)@ method, we normally just use the default method.+  If the type is an enumeration type, we could/may/should? generate+  special code that calls @con2tag_Foo@, much like for @(==)@ shown+  above.++We thought about doing this: If we're also deriving 'Ord' for this+tycon, we generate:+  instance ... Eq (Foo ...) where+    (==) a b  = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}+    (/=) a b  = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }+However, that requires that (Ord <whatever>) was put in the context+for the instance decl, which it probably wasn't, so the decls+produced don't get through the typechecker.+-}++gen_Eq_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)+gen_Eq_binds loc tycon = do+    dflags <- getDynFlags+    return (method_binds dflags, aux_binds)+  where+    all_cons = tyConDataCons tycon+    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons++    -- If there are ten or more (arbitrary number) nullary constructors,+    -- use the con2tag stuff.  For small types it's better to use+    -- ordinary pattern matching.+    (tag_match_cons, pat_match_cons)+       | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons)+       | otherwise                       = ([],           all_cons)++    no_tag_match_cons = null tag_match_cons++    fall_through_eqn dflags+      | no_tag_match_cons   -- All constructors have arguments+      = case pat_match_cons of+          []  -> []   -- No constructors; no fall-though case+          [_] -> []   -- One constructor; no fall-though case+          _   ->      -- Two or more constructors; add fall-through of+                      --       (==) _ _ = False+                 [([nlWildPat, nlWildPat], false_Expr)]++      | otherwise -- One or more tag_match cons; add fall-through of+                  -- extract tags compare for equality+      = [([a_Pat, b_Pat],+         untag_Expr dflags tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]+                    (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]++    aux_binds | no_tag_match_cons = emptyBag+              | otherwise         = unitBag $ DerivAuxBind $ DerivCon2Tag tycon++    method_binds dflags = unitBag (eq_bind dflags)+    eq_bind dflags = mkFunBindEC 2 loc eq_RDR (const true_Expr)+                                 (map pats_etc pat_match_cons+                                   ++ fall_through_eqn dflags)++    ------------------------------------------------------------------+    pats_etc data_con+      = let+            con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed+            con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed++            data_con_RDR = getRdrName data_con+            con_arity   = length tys_needed+            as_needed   = take con_arity as_RDRs+            bs_needed   = take con_arity bs_RDRs+            tys_needed  = dataConOrigArgTys data_con+        in+        ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)+      where+        nested_eq_expr []  [] [] = true_Expr+        nested_eq_expr tys as bs+          = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)+          -- Using 'foldr1' here ensures that the derived code is correctly+          -- associated. See #10859.+          where+            nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b))++{-+************************************************************************+*                                                                      *+        Ord instances+*                                                                      *+************************************************************************++Note [Generating Ord instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose constructors are K1..Kn, and some are nullary.+The general form we generate is:++* Do case on first argument+        case a of+          K1 ... -> rhs_1+          K2 ... -> rhs_2+          ...+          Kn ... -> rhs_n+          _ -> nullary_rhs++* To make rhs_i+     If i = 1, 2, n-1, n, generate a single case.+        rhs_2    case b of+                   K1 {}  -> LT+                   K2 ... -> ...eq_rhs(K2)...+                   _      -> GT++     Otherwise do a tag compare against the bigger range+     (because this is the one most likely to succeed)+        rhs_3    case tag b of tb ->+                 if 3 <# tg then GT+                 else case b of+                         K3 ... -> ...eq_rhs(K3)....+                         _      -> LT++* To make eq_rhs(K), which knows that+    a = K a1 .. av+    b = K b1 .. bv+  we just want to compare (a1,b1) then (a2,b2) etc.+  Take care on the last field to tail-call into comparing av,bv++* To make nullary_rhs generate this+     case con2tag a of a# ->+     case con2tag b of ->+     a# `compare` b#++Several special cases:++* Two or fewer nullary constructors: don't generate nullary_rhs++* Be careful about unlifted comparisons.  When comparing unboxed+  values we can't call the overloaded functions.+  See function unliftedOrdOp++Note [Game plan for deriving Ord]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's a bad idea to define only 'compare', and build the other binary+comparisons on top of it; see #2130, #4019.  Reason: we don't+want to laboriously make a three-way comparison, only to extract a+binary result, something like this:+     (>) (I# x) (I# y) = case <# x y of+                            True -> False+                            False -> case ==# x y of+                                       True  -> False+                                       False -> True++This being said, we can get away with generating full code only for+'compare' and '<' thus saving us generation of other three operators.+Other operators can be cheaply expressed through '<':+a <= b = not $ b < a+a > b = b < a+a >= b = not $ a < b++So for sufficiently small types (few constructors, or all nullary)+we generate all methods; for large ones we just use 'compare'.++-}++data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT++------------+ordMethRdr :: OrdOp -> RdrName+ordMethRdr op+  = case op of+       OrdCompare -> compare_RDR+       OrdLT      -> lt_RDR+       OrdLE      -> le_RDR+       OrdGE      -> ge_RDR+       OrdGT      -> gt_RDR++------------+ltResult :: OrdOp -> LHsExpr GhcPs+-- Knowing a<b, what is the result for a `op` b?+ltResult OrdCompare = ltTag_Expr+ltResult OrdLT      = true_Expr+ltResult OrdLE      = true_Expr+ltResult OrdGE      = false_Expr+ltResult OrdGT      = false_Expr++------------+eqResult :: OrdOp -> LHsExpr GhcPs+-- Knowing a=b, what is the result for a `op` b?+eqResult OrdCompare = eqTag_Expr+eqResult OrdLT      = false_Expr+eqResult OrdLE      = true_Expr+eqResult OrdGE      = true_Expr+eqResult OrdGT      = false_Expr++------------+gtResult :: OrdOp -> LHsExpr GhcPs+-- Knowing a>b, what is the result for a `op` b?+gtResult OrdCompare = gtTag_Expr+gtResult OrdLT      = false_Expr+gtResult OrdLE      = false_Expr+gtResult OrdGE      = true_Expr+gtResult OrdGT      = true_Expr++------------+gen_Ord_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)+gen_Ord_binds loc tycon = do+    dflags <- getDynFlags+    return $ if null tycon_data_cons -- No data-cons => invoke bale-out case+      then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []+           , emptyBag)+      else ( unitBag (mkOrdOp dflags OrdCompare) `unionBags` other_ops dflags+           , aux_binds)+  where+    aux_binds | single_con_type = emptyBag+              | otherwise       = unitBag $ DerivAuxBind $ DerivCon2Tag tycon++        -- Note [Game plan for deriving Ord]+    other_ops dflags+      | (last_tag - first_tag) <= 2     -- 1-3 constructors+        || null non_nullary_cons        -- Or it's an enumeration+      = listToBag [mkOrdOp dflags OrdLT, lE, gT, gE]+      | otherwise+      = emptyBag++    negate_expr = nlHsApp (nlHsVar not_RDR)+    lE = mk_easy_FunBind loc le_RDR [a_Pat, b_Pat] $+        negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr)+    gT = mk_easy_FunBind loc gt_RDR [a_Pat, b_Pat] $+        nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr+    gE = mk_easy_FunBind loc ge_RDR [a_Pat, b_Pat] $+        negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr)++    get_tag con = dataConTag con - fIRST_TAG+        -- We want *zero-based* tags, because that's what+        -- con2Tag returns (generated by untag_Expr)!++    tycon_data_cons = tyConDataCons tycon+    single_con_type = isSingleton tycon_data_cons+    (first_con : _) = tycon_data_cons+    (last_con : _)  = reverse tycon_data_cons+    first_tag       = get_tag first_con+    last_tag        = get_tag last_con++    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons+++    mkOrdOp :: DynFlags -> OrdOp -> LHsBind GhcPs+    -- Returns a binding   op a b = ... compares a and b according to op ....+    mkOrdOp dflags op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat]+                                        (mkOrdOpRhs dflags op)++    mkOrdOpRhs :: DynFlags -> OrdOp -> LHsExpr GhcPs+    mkOrdOpRhs dflags op       -- RHS for comparing 'a' and 'b' according to op+      | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases+      = nlHsCase (nlHsVar a_RDR) $+        map (mkOrdOpAlt dflags op) tycon_data_cons+        -- i.e.  case a of { C1 x y -> case b of C1 x y -> ....compare x,y...+        --                   C2 x   -> case b of C2 x -> ....comopare x.... }++      | null non_nullary_cons    -- All nullary, so go straight to comparing tags+      = mkTagCmp dflags op++      | otherwise                -- Mixed nullary and non-nullary+      = nlHsCase (nlHsVar a_RDR) $+        (map (mkOrdOpAlt dflags op) non_nullary_cons+         ++ [mkHsCaseAlt nlWildPat (mkTagCmp dflags op)])+++    mkOrdOpAlt :: DynFlags -> OrdOp -> DataCon+                  -> LMatch GhcPs (LHsExpr GhcPs)+    -- Make the alternative  (Ki a1 a2 .. av ->+    mkOrdOpAlt dflags op data_con+      = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)+                    (mkInnerRhs dflags op data_con)+      where+        as_needed    = take (dataConSourceArity data_con) as_RDRs+        data_con_RDR = getRdrName data_con++    mkInnerRhs dflags op data_con+      | single_con_type+      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]++      | tag == first_tag+      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]+      | tag == last_tag+      = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]++      | tag == first_tag + 1+      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con)+                                             (gtResult op)+                                 , mkInnerEqAlt op data_con+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]+      | tag == last_tag - 1+      = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con)+                                             (ltResult op)+                                 , mkInnerEqAlt op data_con+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]++      | tag > last_tag `div` 2  -- lower range is larger+      = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $+        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)+               (gtResult op) $  -- Definitely GT+        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con+                                 , mkHsCaseAlt nlWildPat (ltResult op) ]++      | otherwise               -- upper range is larger+      = untag_Expr dflags tycon [(b_RDR, bh_RDR)] $+        nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)+               (ltResult op) $  -- Definitely LT+        nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con+                                 , mkHsCaseAlt nlWildPat (gtResult op) ]+      where+        tag     = get_tag data_con+        tag_lit = noLoc (HsLit noExt (HsIntPrim NoSourceText (toInteger tag)))++    mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)+    -- First argument 'a' known to be built with K+    -- Returns a case alternative  Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)+    mkInnerEqAlt op data_con+      = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $+        mkCompareFields op (dataConOrigArgTys data_con)+      where+        data_con_RDR = getRdrName data_con+        bs_needed    = take (dataConSourceArity data_con) bs_RDRs++    mkTagCmp :: DynFlags -> OrdOp -> LHsExpr GhcPs+    -- Both constructors known to be nullary+    -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#+    mkTagCmp dflags op =+      untag_Expr dflags tycon[(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $+        unliftedOrdOp intPrimTy op ah_RDR bh_RDR++mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs+-- Generates nested comparisons for (a1,a2...) against (b1,b2,...)+-- where the ai,bi have the given types+mkCompareFields op tys+  = go tys as_RDRs bs_RDRs+  where+    go []   _      _          = eqResult op+    go [ty] (a:_)  (b:_)+      | isUnliftedType ty     = unliftedOrdOp ty op a b+      | otherwise             = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)+    go (ty:tys) (a:as) (b:bs) = mk_compare ty a b+                                  (ltResult op)+                                  (go tys as bs)+                                  (gtResult op)+    go _ _ _ = panic "mkCompareFields"++    -- (mk_compare ty a b) generates+    --    (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })+    -- but with suitable special cases for+    mk_compare ty a b lt eq gt+      | isUnliftedType ty+      = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt+      | otherwise+      = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))+          [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt,+           mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq,+           mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt]+      where+        a_expr = nlHsVar a+        b_expr = nlHsVar b+        (lt_op, _, eq_op, _, _) = primOrdOps "Ord" ty++unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs+unliftedOrdOp ty op a b+  = case op of+       OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr+                                     ltTag_Expr eqTag_Expr gtTag_Expr+       OrdLT      -> wrap lt_op+       OrdLE      -> wrap le_op+       OrdGE      -> wrap ge_op+       OrdGT      -> wrap gt_op+  where+   (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" ty+   wrap prim_op = genPrimOpApp a_expr prim_op b_expr+   a_expr = nlHsVar a+   b_expr = nlHsVar b++unliftedCompare :: RdrName -> RdrName+                -> LHsExpr GhcPs -> LHsExpr GhcPs   -- What to cmpare+                -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+                                                    -- Three results+                -> LHsExpr GhcPs+-- Return (if a < b then lt else if a == b then eq else gt)+unliftedCompare lt_op eq_op a_expr b_expr lt eq gt+  = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $+                        -- Test (<) first, not (==), because the latter+                        -- is true less often, so putting it first would+                        -- mean more tests (dynamically)+        nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt+  where+    ascribeBool e = nlExprWithTySig e boolTy++nlConWildPat :: DataCon -> LPat GhcPs+-- The pattern (K {})+nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))+                                   (RecCon (HsRecFields { rec_flds = []+                                                        , rec_dotdot = Nothing })))++{-+************************************************************************+*                                                                      *+        Enum instances+*                                                                      *+************************************************************************++@Enum@ can only be derived for enumeration types.  For a type+\begin{verbatim}+data Foo ... = N1 | N2 | ... | Nn+\end{verbatim}++we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a+@maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).++\begin{verbatim}+instance ... Enum (Foo ...) where+    succ x   = toEnum (1 + fromEnum x)+    pred x   = toEnum (fromEnum x - 1)++    toEnum i = tag2con_Foo i++    enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]++    -- or, really...+    enumFrom a+      = case con2tag_Foo a of+          a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)++   enumFromThen a b+     = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]++    -- or, really...+    enumFromThen a b+      = case con2tag_Foo a of { a# ->+        case con2tag_Foo b of { b# ->+        map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)+        }}+\end{verbatim}++For @enumFromTo@ and @enumFromThenTo@, we use the default methods.+-}++gen_Enum_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)+gen_Enum_binds loc tycon = do+    dflags <- getDynFlags+    return (method_binds dflags, aux_binds)+  where+    method_binds dflags = listToBag+      [ succ_enum      dflags+      , pred_enum      dflags+      , to_enum        dflags+      , enum_from      dflags+      , enum_from_then dflags+      , from_enum      dflags+      ]+    aux_binds = listToBag $ map DerivAuxBind+                  [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]++    occ_nm = getOccString tycon++    succ_enum dflags+      = mk_easy_FunBind loc succ_RDR [a_Pat] $+        untag_Expr dflags tycon [(a_RDR, ah_RDR)] $+        nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR dflags tycon),+                               nlHsVarApps intDataCon_RDR [ah_RDR]])+             (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")+             (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))+                    (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],+                                        nlHsIntLit 1]))++    pred_enum dflags+      = mk_easy_FunBind loc pred_RDR [a_Pat] $+        untag_Expr dflags tycon [(a_RDR, ah_RDR)] $+        nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,+                               nlHsVarApps intDataCon_RDR [ah_RDR]])+             (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")+             (nlHsApp (nlHsVar (tag2con_RDR dflags tycon))+                      (nlHsApps plus_RDR+                            [ nlHsVarApps intDataCon_RDR [ah_RDR]+                            , nlHsLit (HsInt noExt+                                                (mkIntegralLit (-1 :: Int)))]))++    to_enum dflags+      = mk_easy_FunBind loc toEnum_RDR [a_Pat] $+        nlHsIf (nlHsApps and_RDR+                [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],+                 nlHsApps le_RDR [ nlHsVar a_RDR+                                 , nlHsVar (maxtag_RDR dflags tycon)]])+             (nlHsVarApps (tag2con_RDR dflags tycon) [a_RDR])+             (illegal_toEnum_tag occ_nm (maxtag_RDR dflags tycon))++    enum_from dflags+      = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $+          nlHsApps map_RDR+                [nlHsVar (tag2con_RDR dflags tycon),+                 nlHsPar (enum_from_to_Expr+                            (nlHsVarApps intDataCon_RDR [ah_RDR])+                            (nlHsVar (maxtag_RDR dflags tycon)))]++    enum_from_then dflags+      = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $+          untag_Expr dflags tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $+          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $+            nlHsPar (enum_from_then_to_Expr+                    (nlHsVarApps intDataCon_RDR [ah_RDR])+                    (nlHsVarApps intDataCon_RDR [bh_RDR])+                    (nlHsIf  (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],+                                               nlHsVarApps intDataCon_RDR [bh_RDR]])+                           (nlHsIntLit 0)+                           (nlHsVar (maxtag_RDR dflags tycon))+                           ))++    from_enum dflags+      = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $+          (nlHsVarApps intDataCon_RDR [ah_RDR])++{-+************************************************************************+*                                                                      *+        Bounded instances+*                                                                      *+************************************************************************+-}++gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)+gen_Bounded_binds loc tycon+  | isEnumerationTyCon tycon+  = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)+  | otherwise+  = ASSERT(isSingleton data_cons)+    (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)+  where+    data_cons = tyConDataCons tycon++    ----- enum-flavored: ---------------------------+    min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)+    max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)++    data_con_1     = head data_cons+    data_con_N     = last data_cons+    data_con_1_RDR = getRdrName data_con_1+    data_con_N_RDR = getRdrName data_con_N++    ----- single-constructor-flavored: -------------+    arity          = dataConSourceArity data_con_1++    min_bound_1con = mkHsVarBind loc minBound_RDR $+                     nlHsVarApps data_con_1_RDR (replicate arity minBound_RDR)+    max_bound_1con = mkHsVarBind loc maxBound_RDR $+                     nlHsVarApps data_con_1_RDR (replicate arity maxBound_RDR)++{-+************************************************************************+*                                                                      *+        Ix instances+*                                                                      *+************************************************************************++Deriving @Ix@ is only possible for enumeration types and+single-constructor types.  We deal with them in turn.++For an enumeration type, e.g.,+\begin{verbatim}+    data Foo ... = N1 | N2 | ... | Nn+\end{verbatim}+things go not too differently from @Enum@:+\begin{verbatim}+instance ... Ix (Foo ...) where+    range (a, b)+      = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]++    -- or, really...+    range (a, b)+      = case (con2tag_Foo a) of { a# ->+        case (con2tag_Foo b) of { b# ->+        map tag2con_Foo (enumFromTo (I# a#) (I# b#))+        }}++    -- Generate code for unsafeIndex, because using index leads+    -- to lots of redundant range tests+    unsafeIndex c@(a, b) d+      = case (con2tag_Foo d -# con2tag_Foo a) of+               r# -> I# r#++    inRange (a, b) c+      = let+            p_tag = con2tag_Foo c+        in+        p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b++    -- or, really...+    inRange (a, b) c+      = case (con2tag_Foo a)   of { a_tag ->+        case (con2tag_Foo b)   of { b_tag ->+        case (con2tag_Foo c)   of { c_tag ->+        if (c_tag >=# a_tag) then+          c_tag <=# b_tag+        else+          False+        }}}+\end{verbatim}+(modulo suitable case-ification to handle the unlifted tags)++For a single-constructor type (NB: this includes all tuples), e.g.,+\begin{verbatim}+    data Foo ... = MkFoo a b Int Double c c+\end{verbatim}+we follow the scheme given in Figure~19 of the Haskell~1.2 report+(p.~147).+-}++gen_Ix_binds :: SrcSpan -> TyCon -> TcM (LHsBinds GhcPs, BagDerivStuff)++gen_Ix_binds loc tycon = do+    dflags <- getDynFlags+    return $ if isEnumerationTyCon tycon+      then (enum_ixes dflags, listToBag $ map DerivAuxBind+                   [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])+      else (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))+  where+    --------------------------------------------------------------+    enum_ixes dflags = listToBag+      [ enum_range   dflags+      , enum_index   dflags+      , enum_inRange dflags+      ]++    enum_range dflags+      = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] $+          untag_Expr dflags tycon [(b_RDR, bh_RDR)] $+          nlHsApp (nlHsVarApps map_RDR [tag2con_RDR dflags tycon]) $+              nlHsPar (enum_from_to_Expr+                        (nlHsVarApps intDataCon_RDR [ah_RDR])+                        (nlHsVarApps intDataCon_RDR [bh_RDR]))++    enum_index dflags+      = mk_easy_FunBind loc unsafeIndex_RDR+                [noLoc (AsPat noExt (noLoc c_RDR)+                           (nlTuplePat [a_Pat, nlWildPat] Boxed)),+                                d_Pat] (+           untag_Expr dflags tycon [(a_RDR, ah_RDR)] (+           untag_Expr dflags tycon [(d_RDR, dh_RDR)] (+           let+                rhs = nlHsVarApps intDataCon_RDR [c_RDR]+           in+           nlHsCase+             (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))+             [mkHsCaseAlt (nlVarPat c_RDR) rhs]+           ))+        )++    -- This produces something like `(ch >= ah) && (ch <= bh)`+    enum_inRange dflags+      = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $+          untag_Expr dflags tycon [(a_RDR, ah_RDR)] (+          untag_Expr dflags tycon [(b_RDR, bh_RDR)] (+          untag_Expr dflags tycon [(c_RDR, ch_RDR)] (+          -- This used to use `if`, which interacts badly with RebindableSyntax.+          -- See #11396.+          nlHsApps and_RDR+              [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)+              , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)+              ]+          )))++    --------------------------------------------------------------+    single_con_ixes+      = listToBag [single_con_range, single_con_index, single_con_inRange]++    data_con+      = case tyConSingleDataCon_maybe tycon of -- just checking...+          Nothing -> panic "get_Ix_binds"+          Just dc -> dc++    con_arity    = dataConSourceArity data_con+    data_con_RDR = getRdrName data_con++    as_needed = take con_arity as_RDRs+    bs_needed = take con_arity bs_RDRs+    cs_needed = take con_arity cs_RDRs++    con_pat  xs  = nlConVarPat data_con_RDR xs+    con_expr     = nlHsVarApps data_con_RDR cs_needed++    --------------------------------------------------------------+    single_con_range+      = mk_easy_FunBind loc range_RDR+          [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $+        noLoc (mkHsComp ListComp stmts con_expr)+      where+        stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed++        mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)+                                 (nlHsApp (nlHsVar range_RDR)+                                          (mkLHsVarTuple [a,b]))++    ----------------+    single_con_index+      = mk_easy_FunBind loc unsafeIndex_RDR+                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,+                 con_pat cs_needed]+        -- We need to reverse the order we consider the components in+        -- so that+        --     range (l,u) !! index (l,u) i == i   -- when i is in range+        -- (from http://haskell.org/onlinereport/ix.html) holds.+                (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))+      where+        -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)+        mk_index []        = nlHsIntLit 0+        mk_index [(l,u,i)] = mk_one l u i+        mk_index ((l,u,i) : rest)+          = genOpApp (+                mk_one l u i+            ) plus_RDR (+                genOpApp (+                    (nlHsApp (nlHsVar unsafeRangeSize_RDR)+                             (mkLHsVarTuple [l,u]))+                ) times_RDR (mk_index rest)+           )+        mk_one l u i+          = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]++    ------------------+    single_con_inRange+      = mk_easy_FunBind loc inRange_RDR+                [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,+                 con_pat cs_needed] $+          if con_arity == 0+             -- If the product type has no fields, inRange is trivially true+             -- (see #12853).+             then true_Expr+             else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range+                    as_needed bs_needed cs_needed)+      where+        in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]++{-+************************************************************************+*                                                                      *+        Read instances+*                                                                      *+************************************************************************++Example++  infix 4 %%+  data T = Int %% Int+         | T1 { f1 :: Int }+         | T2 T++instance Read T where+  readPrec =+    parens+    ( prec 4 (+        do x <- ReadP.step Read.readPrec+           expectP (Symbol "%%")+           y <- ReadP.step Read.readPrec+           return (x %% y))+      ++++      prec (appPrec+1) (+        -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok+        -- Record construction binds even more tightly than application+        do expectP (Ident "T1")+           expectP (Punc '{')+           x          <- Read.readField "f1" (ReadP.reset readPrec)+           expectP (Punc '}')+           return (T1 { f1 = x }))+      ++++      prec appPrec (+        do expectP (Ident "T2")+           x <- ReadP.step Read.readPrec+           return (T2 x))+    )++  readListPrec = readListPrecDefault+  readList     = readListDefault+++Note [Use expectP]+~~~~~~~~~~~~~~~~~~+Note that we use+   expectP (Ident "T1")+rather than+   Ident "T1" <- lexP+The latter desugares to inline code for matching the Ident and the+string, and this can be very voluminous. The former is much more+compact.  Cf #7258, although that also concerned non-linearity in+the occurrence analyser, a separate issue.++Note [Read for empty data types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What should we get for this?  (#7931)+   data Emp deriving( Read )   -- No data constructors++Here we want+  read "[]" :: [Emp]   to succeed, returning []+So we do NOT want+   instance Read Emp where+     readPrec = error "urk"+Rather we want+   instance Read Emp where+     readPred = pfail   -- Same as choose []++Because 'pfail' allows the parser to backtrack, but 'error' doesn't.+These instances are also useful for Read (Either Int Emp), where+we want to be able to parse (Left 3) just fine.+-}++gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon+               -> (LHsBinds GhcPs, BagDerivStuff)++gen_Read_binds get_fixity loc tycon+  = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)+  where+    -----------------------------------------------------------------------+    default_readlist+        = mkHsVarBind loc readList_RDR     (nlHsVar readListDefault_RDR)++    default_readlistprec+        = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)+    -----------------------------------------------------------------------++    data_cons = tyConDataCons tycon+    (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons++    read_prec = mkHsVarBind loc readPrec_RDR rhs+      where+        rhs | null data_cons -- See Note [Read for empty data types]+            = nlHsVar pfail_RDR+            | otherwise+            = nlHsApp (nlHsVar parens_RDR)+                      (foldr1 mk_alt (read_nullary_cons +++                                      read_non_nullary_cons))++    read_non_nullary_cons = map read_non_nullary_con non_nullary_cons++    read_nullary_cons+      = case nullary_cons of+            []    -> []+            [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]+            _     -> [nlHsApp (nlHsVar choose_RDR)+                              (nlList (map mk_pair nullary_cons))]+        -- NB For operators the parens around (:=:) are matched by the+        -- enclosing "parens" call, so here we must match the naked+        -- data_con_str con++    match_con con | isSym con_str = [symbol_pat con_str]+                  | otherwise     = ident_h_pat  con_str+                  where+                    con_str = data_con_str con+        -- For nullary constructors we must match Ident s for normal constrs+        -- and   Symbol s   for operators++    mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),+                                  result_expr con []]++    read_non_nullary_con data_con+      | is_infix  = mk_parser infix_prec  infix_stmts  body+      | is_record = mk_parser record_prec record_stmts body+--              Using these two lines instead allows the derived+--              read for infix and record bindings to read the prefix form+--      | is_infix  = mk_alt prefix_parser (mk_parser infix_prec  infix_stmts  body)+--      | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)+      | otherwise = prefix_parser+      where+        body = result_expr data_con as_needed+        con_str = data_con_str data_con++        prefix_parser = mk_parser prefix_prec prefix_stmts body++        read_prefix_con+            | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]+            | otherwise     = ident_h_pat con_str++        read_infix_con+            | isSym con_str = [symbol_pat con_str]+            | otherwise     = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]++        prefix_stmts            -- T a b c+          = read_prefix_con ++ read_args++        infix_stmts             -- a %% b, or  a `T` b+          = [read_a1]+            ++ read_infix_con+            ++ [read_a2]++        record_stmts            -- T { f1 = a, f2 = b }+          = read_prefix_con+            ++ [read_punc "{"]+            ++ concat (intersperse [read_punc ","] field_stmts)+            ++ [read_punc "}"]++        field_stmts  = zipWithEqual "lbl_stmts" read_field labels as_needed++        con_arity    = dataConSourceArity data_con+        labels       = map flLabel $ dataConFieldLabels data_con+        dc_nm        = getName data_con+        is_infix     = dataConIsInfix data_con+        is_record    = labels `lengthExceeds` 0+        as_needed    = take con_arity as_RDRs+        read_args    = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)+        (read_a1:read_a2:_) = read_args++        prefix_prec = appPrecedence+        infix_prec  = getPrecedence get_fixity dc_nm+        record_prec = appPrecedence + 1 -- Record construction binds even more tightly+                                        -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})++    ------------------------------------------------------------------------+    --          Helpers+    ------------------------------------------------------------------------+    mk_alt e1 e2       = genOpApp e1 alt_RDR e2                         -- e1 +++ e2+    mk_parser p ss b   = nlHsApps prec_RDR [nlHsIntLit p                -- prec p (do { ss ; b })+                                           , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]+    con_app con as     = nlHsVarApps (getRdrName con) as                -- con as+    result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)++    -- For constructors and field labels ending in '#', we hackily+    -- let the lexer generate two tokens, and look for both in sequence+    -- Thus [Ident "I"; Symbol "#"].  See #5041+    ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]+                  | otherwise                    = [ ident_pat s ]++    bindLex pat  = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat))  -- expectP p+                   -- See Note [Use expectP]+    ident_pat  s = bindLex $ nlHsApps ident_RDR  [nlHsLit (mkHsString s)]  -- expectP (Ident "foo")+    symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)]  -- expectP (Symbol ">>")+    read_punc c  = bindLex $ nlHsApps punc_RDR   [nlHsLit (mkHsString c)]  -- expectP (Punc "<")++    data_con_str con = occNameString (getOccName con)++    read_arg a ty = ASSERT( not (isUnliftedType ty) )+                    noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))++    -- When reading field labels we might encounter+    --      a  = 3+    --      _a = 3+    -- or   (#) = 4+    -- Note the parens!+    read_field lbl a =+        [noLoc+          (mkBindStmt+            (nlVarPat a)+            (nlHsApp+              read_field+              (nlHsVarApps reset_RDR [readPrec_RDR])+            )+          )+        ]+        where+          lbl_str = unpackFS lbl+          mk_read_field read_field_rdr lbl+              = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)]+          read_field+              | isSym lbl_str+              = mk_read_field readSymField_RDR lbl_str+              | Just (ss, '#') <- snocView lbl_str -- #14918+              = mk_read_field readFieldHash_RDR ss+              | otherwise+              = mk_read_field readField_RDR lbl_str++{-+************************************************************************+*                                                                      *+        Show instances+*                                                                      *+************************************************************************++Example++    infixr 5 :^:++    data Tree a =  Leaf a  |  Tree a :^: Tree a++    instance (Show a) => Show (Tree a) where++        showsPrec d (Leaf m) = showParen (d > app_prec) showStr+          where+             showStr = showString "Leaf " . showsPrec (app_prec+1) m++        showsPrec d (u :^: v) = showParen (d > up_prec) showStr+          where+             showStr = showsPrec (up_prec+1) u .+                       showString " :^: "      .+                       showsPrec (up_prec+1) v+                -- Note: right-associativity of :^: ignored++    up_prec  = 5    -- Precedence of :^:+    app_prec = 10   -- Application has precedence one more than+                    -- the most tightly-binding operator+-}++gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon+               -> (LHsBinds GhcPs, BagDerivStuff)++gen_Show_binds get_fixity loc tycon+  = (unitBag shows_prec, emptyBag)+  where+    data_cons = tyConDataCons tycon+    shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons)+    comma_space = nlHsVar showCommaSpace_RDR++    pats_etc data_con+      | nullary_con =  -- skip the showParen junk...+         ASSERT(null bs_needed)+         ([nlWildPat, con_pat], mk_showString_app op_con_str)+      | otherwise   =+         ([a_Pat, con_pat],+          showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit+                         (HsInt noExt (mkIntegralLit con_prec_plus_one))))+                         (nlHsPar (nested_compose_Expr show_thingies)))+        where+             data_con_RDR  = getRdrName data_con+             con_arity     = dataConSourceArity data_con+             bs_needed     = take con_arity bs_RDRs+             arg_tys       = dataConOrigArgTys data_con         -- Correspond 1-1 with bs_needed+             con_pat       = nlConVarPat data_con_RDR bs_needed+             nullary_con   = con_arity == 0+             labels        = map flLabel $ dataConFieldLabels data_con+             lab_fields    = length labels+             record_syntax = lab_fields > 0++             dc_nm          = getName data_con+             dc_occ_nm      = getOccName data_con+             con_str        = occNameString dc_occ_nm+             op_con_str     = wrapOpParens con_str+             backquote_str  = wrapOpBackquotes con_str++             show_thingies+                | is_infix      = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]+                | record_syntax = mk_showString_app (op_con_str ++ " {") :+                                  show_record_args ++ [mk_showString_app "}"]+                | otherwise     = mk_showString_app (op_con_str ++ " ") : show_prefix_args++             show_label l = mk_showString_app (nm ++ " = ")+                        -- Note the spaces around the "=" sign.  If we+                        -- don't have them then we get Foo { x=-1 } and+                        -- the "=-" parses as a single lexeme.  Only the+                        -- space after the '=' is necessary, but it+                        -- seems tidier to have them both sides.+                 where+                   nm       = wrapOpParens (unpackFS l)++             show_args               = zipWith show_arg bs_needed arg_tys+             (show_arg1:show_arg2:_) = show_args+             show_prefix_args        = intersperse (nlHsVar showSpace_RDR) show_args++                -- Assumption for record syntax: no of fields == no of+                -- labelled fields (and in same order)+             show_record_args = concat $+                                intersperse [comma_space] $+                                [ [show_label lbl, arg]+                                | (lbl,arg) <- zipEqual "gen_Show_binds"+                                                        labels show_args ]++             show_arg :: RdrName -> Type -> LHsExpr GhcPs+             show_arg b arg_ty+                 | isUnliftedType arg_ty+                 -- See Note [Deriving and unboxed types] in TcDerivInfer+                 = with_conv $+                    nlHsApps compose_RDR+                        [mk_shows_app boxed_arg, mk_showString_app postfixMod]+                 | otherwise+                 = mk_showsPrec_app arg_prec arg+               where+                 arg        = nlHsVar b+                 boxed_arg  = box "Show" arg arg_ty+                 postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty+                 with_conv expr+                    | (Just conv) <- assoc_ty_id_maybe primConvTbl arg_ty =+                        nested_compose_Expr+                            [ mk_showString_app ("(" ++ conv ++ " ")+                            , expr+                            , mk_showString_app ")"+                            ]+                    | otherwise = expr++                -- Fixity stuff+             is_infix = dataConIsInfix data_con+             con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm+             arg_prec | record_syntax = 0  -- Record fields don't need parens+                      | otherwise     = con_prec_plus_one++wrapOpParens :: String -> String+wrapOpParens s | isSym s   = '(' : s ++ ")"+               | otherwise = s++wrapOpBackquotes :: String -> String+wrapOpBackquotes s | isSym s   = s+                   | otherwise = '`' : s ++ "`"++isSym :: String -> Bool+isSym ""      = False+isSym (c : _) = startsVarSym c || startsConSym c++-- | showString :: String -> ShowS+mk_showString_app :: String -> LHsExpr GhcPs+mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))++-- | showsPrec :: Show a => Int -> a -> ShowS+mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs+mk_showsPrec_app p x+  = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExt (mkIntegralLit p)), x]++-- | shows :: Show a => a -> ShowS+mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs+mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x++getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer+getPrec is_infix get_fixity nm+  | not is_infix   = appPrecedence+  | otherwise      = getPrecedence get_fixity nm++appPrecedence :: Integer+appPrecedence = fromIntegral maxPrecedence + 1+  -- One more than the precedence of the most+  -- tightly-binding operator++getPrecedence :: (Name -> Fixity) -> Name -> Integer+getPrecedence get_fixity nm+   = case get_fixity nm of+        Fixity _ x _assoc -> fromIntegral x+          -- NB: the Report says that associativity is not taken+          --     into account for either Read or Show; hence we+          --     ignore associativity here++{-+************************************************************************+*                                                                      *+        Data instances+*                                                                      *+************************************************************************++From the data type++  data T a b = T1 a b | T2++we generate++  $cT1 = mkDataCon $dT "T1" Prefix+  $cT2 = mkDataCon $dT "T2" Prefix+  $dT  = mkDataType "Module.T" [] [$con_T1, $con_T2]+  -- the [] is for field labels.++  instance (Data a, Data b) => Data (T a b) where+    gfoldl k z (T1 a b) = z T `k` a `k` b+    gfoldl k z T2           = z T2+    -- ToDo: add gmapT,Q,M, gfoldr++    gunfold k z c = case conIndex c of+                        I# 1# -> k (k (z T1))+                        I# 2# -> z T2++    toConstr (T1 _ _) = $cT1+    toConstr T2       = $cT2++    dataTypeOf _ = $dT++    dataCast1 = gcast1   -- If T :: * -> *+    dataCast2 = gcast2   -- if T :: * -> * -> *+-}++gen_Data_binds :: SrcSpan+               -> TyCon                 -- For data families, this is the+                                        --  *representation* TyCon+               -> TcM (LHsBinds GhcPs,  -- The method bindings+                       BagDerivStuff)   -- Auxiliary bindings+gen_Data_binds loc rep_tc+  = do { dflags  <- getDynFlags++       -- Make unique names for the data type and constructor+       -- auxiliary bindings.  Start with the name of the TyCon/DataCon+       -- but that might not be unique: see #12245.+       ; dt_occ  <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc))+       ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName)+                         (tyConDataCons rep_tc)+       ; let dt_rdr  = mkRdrUnqual dt_occ+             dc_rdrs = map mkRdrUnqual dc_occs++       -- OK, now do the work+       ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) }++gen_data :: DynFlags -> RdrName -> [RdrName]+         -> SrcSpan -> TyCon+         -> (LHsBinds GhcPs,      -- The method bindings+             BagDerivStuff)       -- Auxiliary bindings+gen_data dflags data_type_name constr_names loc rep_tc+  = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]+     `unionBags` gcast_binds,+                -- Auxiliary definitions: the data type and constructors+     listToBag ( genDataTyCon+               : zipWith genDataDataCon data_cons constr_names ) )+  where+    data_cons  = tyConDataCons rep_tc+    n_cons     = length data_cons+    one_constr = n_cons == 1+    genDataTyCon :: DerivStuff+    genDataTyCon        --  $dT+      = DerivHsBind (mkHsVarBind loc data_type_name rhs,+                     L loc (TypeSig noExt [L loc data_type_name] sig_ty))++    sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)+    rhs    = nlHsVar mkDataType_RDR+             `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))+             `nlHsApp` nlList (map nlHsVar constr_names)++    genDataDataCon :: DataCon -> RdrName -> DerivStuff+    genDataDataCon dc constr_name       --  $cT1 etc+      = DerivHsBind (mkHsVarBind loc constr_name rhs,+                     L loc (TypeSig noExt [L loc constr_name] sig_ty))+      where+        sig_ty   = mkLHsSigWcType (nlHsTyVar constr_RDR)+        rhs      = nlHsApps mkConstr_RDR constr_args++        constr_args+           = [ -- nlHsIntLit (toInteger (dataConTag dc)),   -- Tag+               nlHsVar (data_type_name)                     -- DataType+             , nlHsLit (mkHsString (occNameString dc_occ))  -- String name+             , nlList  labels                               -- Field labels+             , nlHsVar fixity ]                             -- Fixity++        labels   = map (nlHsLit . mkHsString . unpackFS . flLabel)+                       (dataConFieldLabels dc)+        dc_occ   = getOccName dc+        is_infix = isDataSymOcc dc_occ+        fixity | is_infix  = infix_RDR+               | otherwise = prefix_RDR++        ------------ gfoldl+    gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons)++    gfoldl_eqn con+      = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],+                   foldl' mk_k_app (z_Expr `nlHsApp` nlHsVar con_name) as_needed)+                   where+                     con_name ::  RdrName+                     con_name = getRdrName con+                     as_needed = take (dataConSourceArity con) as_RDRs+                     mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))++        ------------ gunfold+    gunfold_bind = mk_easy_FunBind loc+                     gunfold_RDR+                     [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat]+                     gunfold_rhs++    gunfold_rhs+        | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case+        | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)+                                (map gunfold_alt data_cons)++    gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)+    mk_unfold_rhs dc = foldr nlHsApp+                           (z_Expr `nlHsApp` nlHsVar (getRdrName dc))+                           (replicate (dataConSourceArity dc) (nlHsVar k_RDR))++    mk_unfold_pat dc    -- Last one is a wild-pat, to avoid+                        -- redundant test, and annoying warning+      | tag-fIRST_TAG == n_cons-1 = nlWildPat   -- Last constructor+      | otherwise = nlConPat intDataCon_RDR+                             [nlLitPat (HsIntPrim NoSourceText (toInteger tag))]+      where+        tag = dataConTag dc++        ------------ toConstr+    toCon_bind = mkFunBindEC 1 loc toConstr_RDR id+                     (zipWith to_con_eqn data_cons constr_names)+    to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)++        ------------ dataTypeOf+    dataTypeOf_bind = mk_easy_FunBind+                        loc+                        dataTypeOf_RDR+                        [nlWildPat]+                        (nlHsVar data_type_name)++        ------------ gcast1/2+        -- Make the binding    dataCast1 x = gcast1 x  -- if T :: * -> *+        --               or    dataCast2 x = gcast2 s  -- if T :: * -> * -> *+        -- (or nothing if T has neither of these two types)++        -- But care is needed for data families:+        -- If we have   data family D a+        --              data instance D (a,b,c) = A | B deriving( Data )+        -- and we want  instance ... => Data (D [(a,b,c)]) where ...+        -- then we need     dataCast1 x = gcast1 x+        -- because D :: * -> *+        -- even though rep_tc has kind * -> * -> * -> *+        -- Hence looking for the kind of fam_tc not rep_tc+        -- See #4896+    tycon_kind = case tyConFamInst_maybe rep_tc of+                    Just (fam_tc, _) -> tyConKind fam_tc+                    Nothing          -> tyConKind rep_tc+    gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR+                | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR+                | otherwise                 = emptyBag+    mk_gcast dataCast_RDR gcast_RDR+      = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]+                                 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))+++kind1, kind2 :: Kind+kind1 = liftedTypeKind `mkVisFunTy` liftedTypeKind+kind2 = liftedTypeKind `mkVisFunTy` kind1++gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,+    mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,+    dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,+    constr_RDR, dataType_RDR,+    eqChar_RDR  , ltChar_RDR  , geChar_RDR  , gtChar_RDR  , leChar_RDR  ,+    eqInt_RDR   , ltInt_RDR   , geInt_RDR   , gtInt_RDR   , leInt_RDR   ,+    eqInt8_RDR  , ltInt8_RDR  , geInt8_RDR  , gtInt8_RDR  , leInt8_RDR  ,+    eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR ,+    eqWord_RDR  , ltWord_RDR  , geWord_RDR  , gtWord_RDR  , leWord_RDR  ,+    eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR ,+    eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR,+    eqAddr_RDR  , ltAddr_RDR  , geAddr_RDR  , gtAddr_RDR  , leAddr_RDR  ,+    eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,+    eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR,+    extendWord8_RDR, extendInt8_RDR,+    extendWord16_RDR, extendInt16_RDR :: RdrName+gfoldl_RDR     = varQual_RDR  gENERICS (fsLit "gfoldl")+gunfold_RDR    = varQual_RDR  gENERICS (fsLit "gunfold")+toConstr_RDR   = varQual_RDR  gENERICS (fsLit "toConstr")+dataTypeOf_RDR = varQual_RDR  gENERICS (fsLit "dataTypeOf")+dataCast1_RDR  = varQual_RDR  gENERICS (fsLit "dataCast1")+dataCast2_RDR  = varQual_RDR  gENERICS (fsLit "dataCast2")+gcast1_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast1")+gcast2_RDR     = varQual_RDR  tYPEABLE (fsLit "gcast2")+mkConstr_RDR   = varQual_RDR  gENERICS (fsLit "mkConstr")+constr_RDR     = tcQual_RDR   gENERICS (fsLit "Constr")+mkDataType_RDR = varQual_RDR  gENERICS (fsLit "mkDataType")+dataType_RDR   = tcQual_RDR   gENERICS (fsLit "DataType")+conIndex_RDR   = varQual_RDR  gENERICS (fsLit "constrIndex")+prefix_RDR     = dataQual_RDR gENERICS (fsLit "Prefix")+infix_RDR      = dataQual_RDR gENERICS (fsLit "Infix")++eqChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqChar#")+ltChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltChar#")+leChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "leChar#")+gtChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtChar#")+geChar_RDR     = varQual_RDR  gHC_PRIM (fsLit "geChar#")++eqInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "==#")+ltInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<#" )+leInt_RDR      = varQual_RDR  gHC_PRIM (fsLit "<=#")+gtInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">#" )+geInt_RDR      = varQual_RDR  gHC_PRIM (fsLit ">=#")++eqInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqInt8#")+ltInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltInt8#" )+leInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "leInt8#")+gtInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtInt8#" )+geInt8_RDR     = varQual_RDR  gHC_PRIM (fsLit "geInt8#")++eqInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqInt16#")+ltInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltInt16#" )+leInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "leInt16#")+gtInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtInt16#" )+geInt16_RDR    = varQual_RDR  gHC_PRIM (fsLit "geInt16#")++eqWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqWord#")+ltWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltWord#")+leWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "leWord#")+gtWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtWord#")+geWord_RDR     = varQual_RDR  gHC_PRIM (fsLit "geWord#")++eqWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqWord8#")+ltWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltWord8#" )+leWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "leWord8#")+gtWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtWord8#" )+geWord8_RDR    = varQual_RDR  gHC_PRIM (fsLit "geWord8#")++eqWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "eqWord16#")+ltWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "ltWord16#" )+leWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "leWord16#")+gtWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "gtWord16#" )+geWord16_RDR   = varQual_RDR  gHC_PRIM (fsLit "geWord16#")++eqAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "eqAddr#")+ltAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "ltAddr#")+leAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "leAddr#")+gtAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "gtAddr#")+geAddr_RDR     = varQual_RDR  gHC_PRIM (fsLit "geAddr#")++eqFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "eqFloat#")+ltFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "ltFloat#")+leFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "leFloat#")+gtFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "gtFloat#")+geFloat_RDR    = varQual_RDR  gHC_PRIM (fsLit "geFloat#")++eqDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "==##")+ltDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<##" )+leDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit "<=##")+gtDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">##" )+geDouble_RDR   = varQual_RDR  gHC_PRIM (fsLit ">=##")++extendWord8_RDR = varQual_RDR  gHC_PRIM (fsLit "extendWord8#")+extendInt8_RDR  = varQual_RDR  gHC_PRIM (fsLit "extendInt8#")++extendWord16_RDR = varQual_RDR  gHC_PRIM (fsLit "extendWord16#")+extendInt16_RDR  = varQual_RDR  gHC_PRIM (fsLit "extendInt16#")+++{-+************************************************************************+*                                                                      *+                        Lift instances+*                                                                      *+************************************************************************++Example:++    data Foo a = Foo a | a :^: a deriving Lift++    ==>++    instance (Lift a) => Lift (Foo a) where+        lift (Foo a) = [| Foo a |]+        lift ((:^:) u v) = [| (:^:) u v |]++        liftTyped (Foo a) = [|| Foo a ||]+        liftTyped ((:^:) u v) = [|| (:^:) u v ||]+-}+++gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)+gen_Lift_binds loc tycon = (listToBag [lift_bind, liftTyped_bind], emptyBag)+  where+    lift_bind      = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)+                                 (map (pats_etc mk_exp) data_cons)+    liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp pure_Expr)+                                 (map (pats_etc mk_texp) data_cons)++    mk_exp = ExpBr NoExt+    mk_texp = TExpBr NoExt+    data_cons = tyConDataCons tycon++    pats_etc mk_bracket data_con+      = ([con_pat], lift_Expr)+       where+            con_pat      = nlConVarPat data_con_RDR as_needed+            data_con_RDR = getRdrName data_con+            con_arity    = dataConSourceArity data_con+            as_needed    = take con_arity as_RDRs+            lift_Expr    = noLoc (HsBracket NoExt (mk_bracket br_body))+            br_body      = nlHsApps (Exact (dataConName data_con))+                                    (map nlHsVar as_needed)++{-+************************************************************************+*                                                                      *+                     Newtype-deriving instances+*                                                                      *+************************************************************************++Note [Newtype-deriving instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We take every method in the original instance and `coerce` it to fit+into the derived instance. We need type applications on the argument+to `coerce` to make it obvious what instantiation of the method we're+coercing from.  So from, say,++  class C a b where+    op :: forall c. a -> [b] -> c -> Int++  newtype T x = MkT <rep-ty>++  instance C a <rep-ty> => C a (T x) where+    op = coerce @ (a -> [<rep-ty>] -> c -> Int)+                @ (a -> [T x]      -> c -> Int)+                op :: forall c. a -> [T x] -> c -> Int++In addition to the type applications, we also have an explicit+type signature on the entire RHS. This brings the method-bound variable+`c` into scope over the two type applications.+See Note [GND and QuantifiedConstraints] for more information on why this+is important.++Giving 'coerce' two explicitly-visible type arguments grants us finer control+over how it should be instantiated. Recall++  coerce :: Coercible a b => a -> b++By giving it explicit type arguments we deal with the case where+'op' has a higher rank type, and so we must instantiate 'coerce' with+a polytype.  E.g.++   class C a where op :: a -> forall b. b -> b+   newtype T x = MkT <rep-ty>+   instance C <rep-ty> => C (T x) where+     op = coerce @ (<rep-ty> -> forall b. b -> b)+                 @ (T x      -> forall b. b -> b)+                op :: T x -> forall b. b -> b++The use of type applications is crucial here. If we had tried using only+explicit type signatures, like so:++   instance C <rep-ty> => C (T x) where+     op = coerce (op :: <rep-ty> -> forall b. b -> b)+                     :: T x      -> forall b. b -> b++Then GHC will attempt to deeply skolemize the two type signatures, which will+wreak havoc with the Coercible solver. Therefore, we instead use type+applications, which do not deeply skolemize and thus avoid this issue.+The downside is that we currently require -XImpredicativeTypes to permit this+polymorphic type instantiation, so we have to switch that flag on locally in+TcDeriv.genInst. See #8503 for more discussion.++Note [Newtype-deriving trickiness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#12768):+  class C a where { op :: D a => a -> a }++  instance C a  => C [a] where { op = opList }++  opList :: (C a, D [a]) => [a] -> [a]+  opList = ...++Now suppose we try GND on this:+  newtype N a = MkN [a] deriving( C )++The GND is expecting to get an implementation of op for N by+coercing opList, thus:++  instance C a => C (N a) where { op = opN }++  opN :: (C a, D (N a)) => N a -> N a+  opN = coerce @([a]   -> [a])+               @([N a] -> [N a]+               opList :: D (N a) => [N a] -> [N a]++But there is no reason to suppose that (D [a]) and (D (N a))+are inter-coercible; these instances might completely different.+So GHC rightly rejects this code.++Note [GND and QuantifiedConstraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following example from #15290:++  class C m where+    join :: m (m a) -> m a++  newtype T m a = MkT (m a)++  deriving instance+    (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>+    C (T m)++The code that GHC used to generate for this was:++  instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>+      C (T m) where+    join = coerce @(forall a.   m   (m a) ->   m a)+                  @(forall a. T m (T m a) -> T m a)+                  join++This instantiates `coerce` at a polymorphic type, a form of impredicative+polymorphism, so we're already on thin ice. And in fact the ice breaks,+as we'll explain:++The call to `coerce` gives rise to:++  Coercible (forall a.   m   (m a) ->   m a)+            (forall a. T m (T m a) -> T m a)++And that simplified to the following implication constraint:++  forall a <no-ev>. m (T m a) ~R# m (m a)++But because this constraint is under a `forall`, inside a type, we have to+prove it *without computing any term evidence* (hence the <no-ev>). Alas, we+*must* generate a term-level evidence binding in order to instantiate the+quantified constraint! In response, GHC currently chooses not to use such+a quantified constraint.+See Note [Instances in no-evidence implications] in TcInteract.++But this isn't the death knell for combining QuantifiedConstraints with GND.+On the contrary, if we generate GND bindings in a slightly different way, then+we can avoid this situation altogether. Instead of applying `coerce` to two+polymorphic types, we instead let an explicit type signature do the polymorphic+instantiation, and omit the `forall`s in the type applications.+More concretely, we generate the following code instead:++  instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>+      C (T m) where+    join = coerce @(  m   (m a) ->   m a)+                  @(T m (T m a) -> T m a)+                  join :: forall a. T m (T m a) -> T m a++Now the visible type arguments are both monotypes, so we need do any of this+funny quantified constraint instantiation business.++You might think that that second @(T m (T m a) -> T m a) argument is redundant+in the presence of the explicit `:: forall a. T m (T m a) -> T m a` type+signature, but in fact leaving it off will break this example (from the+T15290d test case):++  class C a where+    c :: Int -> forall b. b -> a++  instance C Int++  instance C Age where+    c = coerce @(Int -> forall b. b -> Int)+               c :: Int -> forall b. b -> Age++That is because the explicit type signature deeply skolemizes the forall-bound+`b`, which wreaks havoc with the `Coercible` solver. An additional visible type+argument of @(Int -> forall b. b -> Age) is enough to prevent this.++Be aware that the use of an explicit type signature doesn't /solve/ this+problem; it just makes it less likely to occur. For example, if a class has+a truly higher-rank type like so:++  class CProblem m where+    op :: (forall b. ... (m b) ...) -> Int++Then the same situation will arise again. But at least it won't arise for the+common case of methods with ordinary, prenex-quantified types.++Note [GND and ambiguity]+~~~~~~~~~~~~~~~~~~~~~~~~+We make an effort to make the code generated through GND be robust w.r.t.+ambiguous type variables. As one example, consider the following example+(from #15637):++  class C a where f :: String+  instance C () where f = "foo"+  newtype T = T () deriving C++A naïve attempt and generating a C T instance would be:++  instance C T where+    f = coerce @String @String f+          :: String++This isn't going to typecheck, however, since GHC doesn't know what to+instantiate the type variable `a` with in the call to `f` in the method body.+(Note that `f :: forall a. String`!) To compensate for the possibility of+ambiguity here, we explicitly instantiate `a` like so:++  instance C T where+    f = coerce @String @String (f @())+          :: String++All better now.+-}++gen_Newtype_binds :: SrcSpan+                  -> Class   -- the class being derived+                  -> [TyVar] -- the tvs in the instance head (this includes+                             -- the tvs from both the class types and the+                             -- newtype itself)+                  -> [Type]  -- instance head parameters (incl. newtype)+                  -> Type    -- the representation type+                  -> TcM (LHsBinds GhcPs, BagDerivStuff)+-- See Note [Newtype-deriving instances]+gen_Newtype_binds loc cls inst_tvs inst_tys rhs_ty+  = do let ats = classATs cls+       atf_insts <- ASSERT( all (not . isDataFamilyTyCon) ats )+                    mapM mk_atf_inst ats+       return ( listToBag $ map mk_bind (classMethods cls)+              , listToBag $ map DerivFamInst atf_insts )+  where+    mk_bind :: Id -> LHsBind GhcPs+    mk_bind meth_id+      = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch+                                          (mkPrefixFunRhs (L loc meth_RDR))+                                          [] rhs_expr]+      where+        Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id+        (_, _, from_tau) = tcSplitSigmaTy from_ty+        (_, _, to_tau)   = tcSplitSigmaTy to_ty++        meth_RDR = getRdrName meth_id++        rhs_expr = nlHsVar (getRdrName coerceId)+                                      `nlHsAppType`     from_tau+                                      `nlHsAppType`     to_tau+                                      `nlHsApp`         meth_app+                                      `nlExprWithTySig` to_ty++        -- The class method, applied to all of the class instance types+        -- (including the representation type) to avoid potential ambiguity.+        -- See Note [GND and ambiguity]+        meth_app = foldl' nlHsAppType (nlHsVar meth_RDR) $+                   filterOutInferredTypes (classTyCon cls) underlying_inst_tys+                     -- Filter out any inferred arguments, since they can't be+                     -- applied with visible type application.++    mk_atf_inst :: TyCon -> TcM FamInst+    mk_atf_inst fam_tc = do+        rep_tc_name <- newFamInstTyConName (L loc (tyConName fam_tc))+                                           rep_lhs_tys+        let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs'+                                    fam_tc rep_lhs_tys rep_rhs_ty+        -- Check (c) from Note [GND and associated type families] in TcDeriv+        checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom)+        newFamInst SynFamilyInst axiom+      where+        cls_tvs     = classTyVars cls+        in_scope    = mkInScopeSet $ mkVarSet inst_tvs+        lhs_env     = zipTyEnv cls_tvs inst_tys+        lhs_subst   = mkTvSubst in_scope lhs_env+        rhs_env     = zipTyEnv cls_tvs underlying_inst_tys+        rhs_subst   = mkTvSubst in_scope rhs_env+        fam_tvs     = tyConTyVars fam_tc+        rep_lhs_tys = substTyVars lhs_subst fam_tvs+        rep_rhs_tys = substTyVars rhs_subst fam_tvs+        rep_rhs_ty  = mkTyConApp fam_tc rep_rhs_tys+        rep_tcvs    = tyCoVarsOfTypesList rep_lhs_tys+        (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs+        rep_tvs'    = scopedSort rep_tvs+        rep_cvs'    = scopedSort rep_cvs++    -- Same as inst_tys, but with the last argument type replaced by the+    -- representation type.+    underlying_inst_tys :: [Type]+    underlying_inst_tys = changeLast inst_tys rhs_ty++nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs+nlHsAppType e s = noLoc (HsAppType noExt e hs_ty)+  where+    hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec (typeToLHsType s)++nlExprWithTySig :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs+nlExprWithTySig e s = noLoc $ ExprWithTySig noExt (parenthesizeHsExpr sigPrec e) hs_ty+  where+    hs_ty = mkLHsSigWcType (typeToLHsType s)++mkCoerceClassMethEqn :: Class   -- the class being derived+                     -> [TyVar] -- the tvs in the instance head (this includes+                                -- the tvs from both the class types and the+                                -- newtype itself)+                     -> [Type]  -- instance head parameters (incl. newtype)+                     -> Type    -- the representation type+                     -> Id      -- the method to look at+                     -> Pair Type+-- See Note [Newtype-deriving instances]+-- See also Note [Newtype-deriving trickiness]+-- The pair is the (from_type, to_type), where to_type is+-- the type of the method we are trying to get+mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id+  = Pair (substTy rhs_subst user_meth_ty)+         (substTy lhs_subst user_meth_ty)+  where+    cls_tvs = classTyVars cls+    in_scope = mkInScopeSet $ mkVarSet inst_tvs+    lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys)+    rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty))+    (_class_tvs, _class_constraint, user_meth_ty)+      = tcSplitMethodTy (varType id)++{-+************************************************************************+*                                                                      *+\subsection{Generating extra binds (@con2tag@ and @tag2con@)}+*                                                                      *+************************************************************************++\begin{verbatim}+data Foo ... = ...++con2tag_Foo :: Foo ... -> Int#+tag2con_Foo :: Int -> Foo ...   -- easier if Int, not Int#+maxtag_Foo  :: Int              -- ditto (NB: not unlifted)+\end{verbatim}++The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)+fiddling around.+-}++genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec+                  -> (LHsBind GhcPs, LSig GhcPs)+genAuxBindSpec dflags loc (DerivCon2Tag tycon)+  = (mkFunBindSE 0 loc rdr_name eqns,+     L loc (TypeSig noExt [L loc rdr_name] sig_ty))+  where+    rdr_name = con2tag_RDR dflags tycon++    sig_ty = mkLHsSigWcType $ L loc $ XHsType $ NHsCoreTy $+             mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $+             mkParentType tycon `mkVisFunTy` intPrimTy++    lots_of_constructors = tyConFamilySize tycon > 8+                        -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS+                        -- but we don't do vectored returns any more.++    eqns | lots_of_constructors = [get_tag_eqn]+         | otherwise = map mk_eqn (tyConDataCons tycon)++    get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)++    mk_eqn :: DataCon -> ([LPat GhcPs], LHsExpr GhcPs)+    mk_eqn con = ([nlWildConPat con],+                  nlHsLit (HsIntPrim NoSourceText+                                    (toInteger ((dataConTag con) - fIRST_TAG))))++genAuxBindSpec dflags loc (DerivTag2Con tycon)+  = (mkFunBindSE 0 loc rdr_name+        [([nlConVarPat intDataCon_RDR [a_RDR]],+           nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],+     L loc (TypeSig noExt [L loc rdr_name] sig_ty))+  where+    sig_ty = mkLHsSigWcType $ L loc $+             XHsType $ NHsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $+             intTy `mkVisFunTy` mkParentType tycon++    rdr_name = tag2con_RDR dflags tycon++genAuxBindSpec dflags loc (DerivMaxTag tycon)+  = (mkHsVarBind loc rdr_name rhs,+     L loc (TypeSig noExt [L loc rdr_name] sig_ty))+  where+    rdr_name = maxtag_RDR dflags tycon+    sig_ty = mkLHsSigWcType (L loc (XHsType (NHsCoreTy intTy)))+    rhs = nlHsApp (nlHsVar intDataCon_RDR)+                  (nlHsLit (HsIntPrim NoSourceText max_tag))+    max_tag =  case (tyConDataCons tycon) of+                 data_cons -> toInteger ((length data_cons) - fIRST_TAG)++type SeparateBagsDerivStuff =+  -- AuxBinds and SYB bindings+  ( Bag (LHsBind GhcPs, LSig GhcPs)+  -- Extra family instances (used by Generic and DeriveAnyClass)+  , Bag (FamInst) )++genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff+genAuxBinds dflags loc b = genAuxBinds' b2 where+  (b1,b2) = partitionBagWith splitDerivAuxBind b+  splitDerivAuxBind (DerivAuxBind x) = Left x+  splitDerivAuxBind  x               = Right x++  rm_dups = foldrBag dup_check emptyBag+  dup_check a b = if anyBag (== a) b then b else consBag a b++  genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff+  genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec dflags loc) (rm_dups b1)+                            , emptyBag )+  f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff+  f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before+  f (DerivHsBind  b) = add1 b+  f (DerivFamInst t) = add2 t++  add1 x (a,b) = (x `consBag` a,b)+  add2 x (a,b) = (a,x `consBag` b)++mkParentType :: TyCon -> Type+-- Turn the representation tycon of a family into+-- a use of its family constructor+mkParentType tc+  = case tyConFamInst_maybe tc of+       Nothing  -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))+       Just (fam_tc,tys) -> mkTyConApp fam_tc tys++{-+************************************************************************+*                                                                      *+\subsection{Utility bits for generating bindings}+*                                                                      *+************************************************************************+-}++-- | Make a function binding. If no equations are given, produce a function+-- with the given arity that produces a stock error.+mkFunBindSE :: Arity -> SrcSpan -> RdrName+             -> [([LPat GhcPs], LHsExpr GhcPs)]+             -> LHsBind GhcPs+mkFunBindSE arity loc fun pats_and_exprs+  = mkRdrFunBindSE arity (L loc fun) matches+  where+    matches = [mkMatch (mkPrefixFunRhs (L loc fun))+                               (map (parenthesizePat appPrec) p) e+                               (noLoc emptyLocalBinds)+              | (p,e) <-pats_and_exprs]++mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]+             -> LHsBind GhcPs+mkRdrFunBind fun@(L loc _fun_rdr) matches+  = L loc (mkFunBind fun matches)++-- | Make a function binding. If no equations are given, produce a function+-- with the given arity that uses an empty case expression for the last+-- argument that is passes to the given function to produce the right-hand+-- side.+mkFunBindEC :: Arity -> SrcSpan -> RdrName+            -> (LHsExpr GhcPs -> LHsExpr GhcPs)+            -> [([LPat GhcPs], LHsExpr GhcPs)]+            -> LHsBind GhcPs+mkFunBindEC arity loc fun catch_all pats_and_exprs+  = mkRdrFunBindEC arity catch_all (L loc fun) matches+  where+    matches = [ mkMatch (mkPrefixFunRhs (L loc fun))+                                (map (parenthesizePat appPrec) p) e+                                (noLoc emptyLocalBinds)+              | (p,e) <- pats_and_exprs ]++-- | Produces a function binding. When no equations are given, it generates+-- a binding of the given arity and an empty case expression+-- for the last argument that it passes to the given function to produce+-- the right-hand side.+mkRdrFunBindEC :: Arity+               -> (LHsExpr GhcPs -> LHsExpr GhcPs)+               -> Located RdrName+               -> [LMatch GhcPs (LHsExpr GhcPs)]+               -> LHsBind GhcPs+mkRdrFunBindEC arity catch_all+                 fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches')+ where+   -- Catch-all eqn looks like+   --     fmap _ z = case z of {}+   -- or+   --     traverse _ z = pure (case z of)+   -- or+   --     foldMap _ z = mempty+   -- It's needed if there no data cons at all,+   -- which can happen with -XEmptyDataDecls+   -- See #4302+   matches' = if null matches+              then [mkMatch (mkPrefixFunRhs fun)+                            (replicate (arity - 1) nlWildPat ++ [z_Pat])+                            (catch_all $ nlHsCase z_Expr [])+                            (noLoc emptyLocalBinds)]+              else matches++-- | Produces a function binding. When there are no equations, it generates+-- a binding with the given arity that produces an error based on the name of+-- the type of the last argument.+mkRdrFunBindSE :: Arity -> Located RdrName ->+                    [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs+mkRdrFunBindSE arity+                 fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')+ where+   -- Catch-all eqn looks like+   --     compare _ _ = error "Void compare"+   -- It's needed if there no data cons at all,+   -- which can happen with -XEmptyDataDecls+   -- See #4302+   matches' = if null matches+              then [mkMatch (mkPrefixFunRhs fun)+                            (replicate arity nlWildPat)+                            (error_Expr str) (noLoc emptyLocalBinds)]+              else matches+   str = "Void " ++ occNameString (rdrNameOcc fun_rdr)+++box ::         String           -- The class involved+            -> LHsExpr GhcPs    -- The argument+            -> Type             -- The argument type+            -> LHsExpr GhcPs    -- Boxed version of the arg+-- See Note [Deriving and unboxed types] in TcDerivInfer+box cls_str arg arg_ty = assoc_ty_id cls_str boxConTbl arg_ty arg++---------------------+primOrdOps :: String    -- The class involved+           -> Type      -- The type+           -> (RdrName, RdrName, RdrName, RdrName, RdrName)  -- (lt,le,eq,ge,gt)+-- See Note [Deriving and unboxed types] in TcDerivInfer+primOrdOps str ty = assoc_ty_id str ordOpTbl ty++ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]+ordOpTbl+ =  [(charPrimTy  , (ltChar_RDR  , leChar_RDR+     , eqChar_RDR  , geChar_RDR  , gtChar_RDR  ))+    ,(intPrimTy   , (ltInt_RDR   , leInt_RDR+     , eqInt_RDR   , geInt_RDR   , gtInt_RDR   ))+    ,(int8PrimTy  , (ltInt8_RDR  , leInt8_RDR+     , eqInt8_RDR  , geInt8_RDR  , gtInt8_RDR   ))+    ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR+     , eqInt16_RDR , geInt16_RDR , gtInt16_RDR   ))+    ,(wordPrimTy  , (ltWord_RDR  , leWord_RDR+     , eqWord_RDR  , geWord_RDR  , gtWord_RDR  ))+    ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR+     , eqWord8_RDR , geWord8_RDR , gtWord8_RDR   ))+    ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR+     , eqWord16_RDR, geWord16_RDR, gtWord16_RDR  ))+    ,(addrPrimTy  , (ltAddr_RDR  , leAddr_RDR+     , eqAddr_RDR  , geAddr_RDR  , gtAddr_RDR  ))+    ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR+     , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))+    ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR+     , eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]++-- A mapping from a primitive type to a function that constructs its boxed+-- version.+-- NOTE: Int8#/Word8# will become Int/Word.+boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]+boxConTbl =+    [ (charPrimTy  , nlHsApp (nlHsVar $ getRdrName charDataCon))+    , (intPrimTy   , nlHsApp (nlHsVar $ getRdrName intDataCon))+    , (wordPrimTy  , nlHsApp (nlHsVar $ getRdrName wordDataCon ))+    , (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon ))+    , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon))+    , (int8PrimTy,+        nlHsApp (nlHsVar $ getRdrName intDataCon)+        . nlHsApp (nlHsVar extendInt8_RDR))+    , (word8PrimTy,+        nlHsApp (nlHsVar $ getRdrName wordDataCon)+        .  nlHsApp (nlHsVar extendWord8_RDR))+    , (int16PrimTy,+        nlHsApp (nlHsVar $ getRdrName intDataCon)+        . nlHsApp (nlHsVar extendInt16_RDR))+    , (word16PrimTy,+        nlHsApp (nlHsVar $ getRdrName wordDataCon)+        .  nlHsApp (nlHsVar extendWord16_RDR))+    ]+++-- | A table of postfix modifiers for unboxed values.+postfixModTbl :: [(Type, String)]+postfixModTbl+  = [(charPrimTy  , "#" )+    ,(intPrimTy   , "#" )+    ,(wordPrimTy  , "##")+    ,(floatPrimTy , "#" )+    ,(doublePrimTy, "##")+    ,(int8PrimTy, "#")+    ,(word8PrimTy, "##")+    ,(int16PrimTy, "#")+    ,(word16PrimTy, "##")+    ]++primConvTbl :: [(Type, String)]+primConvTbl =+    [ (int8PrimTy, "narrowInt8#")+    , (word8PrimTy, "narrowWord8#")+    , (int16PrimTy, "narrowInt16#")+    , (word16PrimTy, "narrowWord16#")+    ]++litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]+litConTbl+  = [(charPrimTy  , nlHsApp (nlHsVar charPrimL_RDR))+    ,(intPrimTy   , nlHsApp (nlHsVar intPrimL_RDR)+                      . nlHsApp (nlHsVar toInteger_RDR))+    ,(wordPrimTy  , nlHsApp (nlHsVar wordPrimL_RDR)+                      . nlHsApp (nlHsVar toInteger_RDR))+    ,(addrPrimTy  , nlHsApp (nlHsVar stringPrimL_RDR)+                      . nlHsApp (nlHsApp+                          (nlHsVar map_RDR)+                          (compose_RDR `nlHsApps`+                            [ nlHsVar fromIntegral_RDR+                            , nlHsVar fromEnum_RDR+                            ])))+    ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)+                      . nlHsApp (nlHsVar toRational_RDR))+    ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)+                      . nlHsApp (nlHsVar toRational_RDR))+    ]++-- | Lookup `Type` in an association list.+assoc_ty_id :: HasCallStack => String           -- The class involved+            -> [(Type,a)]       -- The table+            -> Type             -- The type+            -> a                -- The result of the lookup+assoc_ty_id cls_str tbl ty+  | Just a <- assoc_ty_id_maybe tbl ty = a+  | otherwise =+      pprPanic "Error in deriving:"+          (text "Can't derive" <+> text cls_str <+>+           text "for primitive type" <+> ppr ty)++-- | Lookup `Type` in an association list.+assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a+assoc_ty_id_maybe tbl ty = snd <$> find (\(t, _) -> t `eqType` ty) tbl++-----------------------------------------------------------------------++and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+and_Expr a b = genOpApp a and_RDR    b++-----------------------------------------------------------------------++eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+eq_Expr ty a b+    | not (isUnliftedType ty) = genOpApp a eq_RDR b+    | otherwise               = genPrimOpApp a prim_eq b+ where+   (_, _, prim_eq, _, _) = primOrdOps "Eq" ty++untag_Expr :: DynFlags -> TyCon -> [( RdrName,  RdrName)]+              -> LHsExpr GhcPs -> LHsExpr GhcPs+untag_Expr _ _ [] expr = expr+untag_Expr dflags tycon ((untag_this, put_tag_here) : more) expr+  = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR dflags tycon)+                                   [untag_this])) {-of-}+      [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr dflags tycon more expr)]++enum_from_to_Expr+        :: LHsExpr GhcPs -> LHsExpr GhcPs+        -> LHsExpr GhcPs+enum_from_then_to_Expr+        :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+        -> LHsExpr GhcPs++enum_from_to_Expr      f   t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2+enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2++showParen_Expr+        :: LHsExpr GhcPs -> LHsExpr GhcPs+        -> LHsExpr GhcPs++showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2++nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs++nested_compose_Expr []  = panic "nested_compose_expr"   -- Arg is always non-empty+nested_compose_Expr [e] = parenify e+nested_compose_Expr (e:es)+  = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)++-- impossible_Expr is used in case RHSs that should never happen.+-- We generate these to keep the desugarer from complaining that they *might* happen!+error_Expr :: String -> LHsExpr GhcPs+error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))++-- illegal_Expr is used when signalling error conditions in the RHS of a derived+-- method. It is currently only used by Enum.{succ,pred}+illegal_Expr :: String -> String -> String -> LHsExpr GhcPs+illegal_Expr meth tp msg =+   nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))++-- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you+-- to include the value of a_RDR in the error string.+illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs+illegal_toEnum_tag tp maxtag =+   nlHsApp (nlHsVar error_RDR)+           (nlHsApp (nlHsApp (nlHsVar append_RDR)+                       (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))+                    (nlHsApp (nlHsApp (nlHsApp+                           (nlHsVar showsPrec_RDR)+                           (nlHsIntLit 0))+                           (nlHsVar a_RDR))+                           (nlHsApp (nlHsApp+                               (nlHsVar append_RDR)+                               (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))+                               (nlHsApp (nlHsApp (nlHsApp+                                        (nlHsVar showsPrec_RDR)+                                        (nlHsIntLit 0))+                                        (nlHsVar maxtag))+                                        (nlHsLit (mkHsString ")"))))))++parenify :: LHsExpr GhcPs -> LHsExpr GhcPs+parenify e@(L _ (HsVar _ _)) = e+parenify e                   = mkHsPar e++-- genOpApp wraps brackets round the operator application, so that the+-- renamer won't subsequently try to re-associate it.+genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs+genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)++genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs+genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))++a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR+    :: RdrName+a_RDR           = mkVarUnqual (fsLit "a")+b_RDR           = mkVarUnqual (fsLit "b")+c_RDR           = mkVarUnqual (fsLit "c")+d_RDR           = mkVarUnqual (fsLit "d")+f_RDR           = mkVarUnqual (fsLit "f")+k_RDR           = mkVarUnqual (fsLit "k")+z_RDR           = mkVarUnqual (fsLit "z")+ah_RDR          = mkVarUnqual (fsLit "a#")+bh_RDR          = mkVarUnqual (fsLit "b#")+ch_RDR          = mkVarUnqual (fsLit "c#")+dh_RDR          = mkVarUnqual (fsLit "d#")++as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]+as_RDRs         = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]+bs_RDRs         = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]+cs_RDRs         = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]++a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,+    true_Expr, pure_Expr :: LHsExpr GhcPs+a_Expr          = nlHsVar a_RDR+b_Expr          = nlHsVar b_RDR+c_Expr          = nlHsVar c_RDR+z_Expr          = nlHsVar z_RDR+ltTag_Expr      = nlHsVar ltTag_RDR+eqTag_Expr      = nlHsVar eqTag_RDR+gtTag_Expr      = nlHsVar gtTag_RDR+false_Expr      = nlHsVar false_RDR+true_Expr       = nlHsVar true_RDR+pure_Expr       = nlHsVar pure_RDR++a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs+a_Pat           = nlVarPat a_RDR+b_Pat           = nlVarPat b_RDR+c_Pat           = nlVarPat c_RDR+d_Pat           = nlVarPat d_RDR+k_Pat           = nlVarPat k_RDR+z_Pat           = nlVarPat z_RDR++minusInt_RDR, tagToEnum_RDR :: RdrName+minusInt_RDR  = getRdrName (primOpId IntSubOp   )+tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)++con2tag_RDR, tag2con_RDR, maxtag_RDR :: DynFlags -> TyCon -> RdrName+-- Generates Orig s RdrName, for the binding positions+con2tag_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkCon2TagOcc+tag2con_RDR dflags tycon = mk_tc_deriv_name dflags tycon mkTag2ConOcc+maxtag_RDR  dflags tycon = mk_tc_deriv_name dflags tycon mkMaxTagOcc++mk_tc_deriv_name :: DynFlags -> TyCon -> (OccName -> OccName) -> RdrName+mk_tc_deriv_name dflags tycon occ_fun =+   mkAuxBinderName dflags (tyConName tycon) occ_fun++mkAuxBinderName :: DynFlags -> Name -> (OccName -> OccName) -> RdrName+-- ^ Make a top-level binder name for an auxiliary binding for a parent name+-- See Note [Auxiliary binders]+mkAuxBinderName dflags parent occ_fun+  = mkRdrUnqual (occ_fun stable_parent_occ)+  where+    stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string+    stable_string+      | hasPprDebug dflags = parent_stable+      | otherwise          = parent_stable_hash+    parent_stable = nameStableString parent+    parent_stable_hash =+      let Fingerprint high low = fingerprintString parent_stable+      in toBase62 high ++ toBase62Padded low+      -- See Note [Base 62 encoding 128-bit integers] in Encoding+    parent_occ  = nameOccName parent+++{-+Note [Auxiliary binders]+~~~~~~~~~~~~~~~~~~~~~~~~+We often want to make a top-level auxiliary binding.  E.g. for comparison we haev++  instance Ord T where+    compare a b = $con2tag a `compare` $con2tag b++  $con2tag :: T -> Int+  $con2tag = ...code....++Of course these top-level bindings should all have distinct name, and we are+generating RdrNames here.  We can't just use the TyCon or DataCon to distinguish+because with standalone deriving two imported TyCons might both be called T!+(See #7947.)++So we use package name, module name and the name of the parent+(T in this example) as part of the OccName we generate for the new binding.+To make the symbol names short we take a base62 hash of the full name.++In the past we used the *unique* from the parent, but that's not stable across+recompilations as uniques are nondeterministic.+-}
+ compiler/typecheck/TcGenFunctor.hs view
@@ -0,0 +1,1293 @@+{-+(c) The University of Glasgow 2011+++The deriving code for the Functor, Foldable, and Traversable classes+(equivalent to the code in TcGenDeriv, for other classes)+-}++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-}++module TcGenFunctor (+        FFoldType(..), functorLikeTraverse,+        deepSubtypesContaining, foldDataConArgs,++        gen_Functor_binds, gen_Foldable_binds, gen_Traversable_binds+    ) where++import GhcPrelude++import Bag+import DataCon+import FastString+import HsSyn+import Panic+import PrelNames+import RdrName+import SrcLoc+import State+import TcGenDeriv+import TcType+import TyCon+import TyCoRep+import Type+import Util+import Var+import VarSet+import MkId (coerceId)+import TysWiredIn (true_RDR, false_RDR)++import Data.Maybe (catMaybes, isJust)++{-+************************************************************************+*                                                                      *+                        Functor instances++ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html++*                                                                      *+************************************************************************++For the data type:++  data T a = T1 Int a | T2 (T a)++We generate the instance:++  instance Functor T where+      fmap f (T1 b1 a) = T1 b1 (f a)+      fmap f (T2 ta)   = T2 (fmap f ta)++Notice that we don't simply apply 'fmap' to the constructor arguments.+Rather+  - Do nothing to an argument whose type doesn't mention 'a'+  - Apply 'f' to an argument of type 'a'+  - Apply 'fmap f' to other arguments+That's why we have to recurse deeply into the constructor argument types,+rather than just one level, as we typically do.++What about types with more than one type parameter?  In general, we only+derive Functor for the last position:++  data S a b = S1 [b] | S2 (a, T a b)+  instance Functor (S a) where+    fmap f (S1 bs)    = S1 (fmap f bs)+    fmap f (S2 (p,q)) = S2 (a, fmap f q)++However, we have special cases for+         - tuples+         - functions++More formally, we write the derivation of fmap code over type variable+'a for type 'b as ($fmap 'a 'b).  In this general notation the derived+instance for T is:++  instance Functor T where+      fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)+      fmap f (T2 x1)    = T2 ($(fmap 'a '(T a)) x1)++  $(fmap 'a 'b)          =  \x -> x     -- when b does not contain a+  $(fmap 'a 'a)          =  f+  $(fmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)+  $(fmap 'a '(T b1 b2))  =  fmap $(fmap 'a 'b2)   -- when a only occurs in the last parameter, b2+  $(fmap 'a '(b -> c))   =  \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))++For functions, the type parameter 'a can occur in a contravariant position,+which means we need to derive a function like:++  cofmap :: (a -> b) -> (f b -> f a)++This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:++  $(cofmap 'a 'b)          =  \x -> x     -- when b does not contain a+  $(cofmap 'a 'a)          =  error "type variable in contravariant position"+  $(cofmap 'a '(b1,b2))    =  \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)+  $(cofmap 'a '[b])        =  map $(cofmap 'a 'b)+  $(cofmap 'a '(T b1 b2))  =  fmap $(cofmap 'a 'b2)   -- when a only occurs in the last parameter, b2+  $(cofmap 'a '(b -> c))   =  \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))++Note that the code produced by $(fmap _ _) is always a higher order function,+with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern+matching on the type, this means create a lambda function (see the (,) case above).+The resulting code for fmap can look a bit weird, for example:++  data X a = X (a,Int)+  -- generated instance+  instance Functor X where+      fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x++The optimizer should be able to simplify this code by simple inlining.++An older version of the deriving code tried to avoid these applied+lambda functions by producing a meta level function. But the function to+be mapped, `f`, is a function on the code level, not on the meta level,+so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.+It is better to produce too many lambdas than to eta expand, see ticket #7436.+-}++gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)+-- When the argument is phantom, we can use  fmap _ = coerce+-- See Note [Phantom types with Functor, Foldable, and Traversable]+gen_Functor_binds loc tycon+  | Phantom <- last (tyConRoles tycon)+  = (unitBag fmap_bind, emptyBag)+  where+    fmap_name = L loc fmap_RDR+    fmap_bind = mkRdrFunBind fmap_name fmap_eqns+    fmap_eqns = [mkSimpleMatch fmap_match_ctxt+                               [nlWildPat]+                               coerce_Expr]+    fmap_match_ctxt = mkPrefixFunRhs fmap_name++gen_Functor_binds loc tycon+  = (listToBag [fmap_bind, replace_bind], emptyBag)+  where+    data_cons = tyConDataCons tycon+    fmap_name = L loc fmap_RDR++    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]+    fmap_bind = mkRdrFunBindEC 2 id fmap_name fmap_eqns+    fmap_match_ctxt = mkPrefixFunRhs fmap_name++    fmap_eqn con = flip evalState bs_RDRs $+                     match_for_con fmap_match_ctxt [f_Pat] con =<< parts+      where+        parts = sequence $ foldDataConArgs ft_fmap con++    fmap_eqns = map fmap_eqn data_cons++    ft_fmap :: FFoldType (State [RdrName] (LHsExpr GhcPs))+    ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x+                   -- fmap f = \x -> x+                 , ft_var  = return f_Expr+                   -- fmap f = f+                 , ft_fun  = \g h -> do+                     gg <- g+                     hh <- h+                     mkSimpleLam2 $ \x b -> return $+                       nlHsApp hh (nlHsApp x (nlHsApp gg b))+                   -- fmap f = \x b -> h (x (g b))+                 , ft_tup = \t gs -> do+                     gg <- sequence gs+                     mkSimpleLam $ mkSimpleTupleCase (match_for_con CaseAlt) t gg+                   -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)+                 , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g+                   -- fmap f = fmap g+                 , ft_forall = \_ g -> g+                 , ft_bad_app = panic "in other argument in ft_fmap"+                 , ft_co_var = panic "contravariant in ft_fmap" }++    -- See Note [Deriving <$]+    replace_name = L loc replace_RDR++    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]+    replace_bind = mkRdrFunBindEC 2 id replace_name replace_eqns+    replace_match_ctxt = mkPrefixFunRhs replace_name++    replace_eqn con = flip evalState bs_RDRs $+        match_for_con replace_match_ctxt [z_Pat] con =<< parts+      where+        parts = traverse (fmap replace) $ foldDataConArgs ft_replace con++    replace_eqns = map replace_eqn data_cons++    ft_replace :: FFoldType (State [RdrName] Replacer)+    ft_replace = FT { ft_triv = fmap Nested $ mkSimpleLam $ \x -> return x+                   -- (p <$) = \x -> x+                 , ft_var  = fmap Immediate $ mkSimpleLam $ \_ -> return z_Expr+                   -- (p <$) = const p+                 , ft_fun  = \g h -> do+                     gg <- replace <$> g+                     hh <- replace <$> h+                     fmap Nested $ mkSimpleLam2 $ \x b -> return $+                       nlHsApp hh (nlHsApp x (nlHsApp gg b))+                   -- (<$) p = \x b -> h (x (g b))+                 , ft_tup = \t gs -> do+                     gg <- traverse (fmap replace) gs+                     fmap Nested . mkSimpleLam $+                          mkSimpleTupleCase (match_for_con CaseAlt) t gg+                   -- (p <$) = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)+                 , ft_ty_app = \_ gm -> do+                       g <- gm+                       case g of+                         Nested g' -> pure . Nested $+                                          nlHsApp fmap_Expr $ g'+                         Immediate _ -> pure . Nested $+                                          nlHsApp replace_Expr z_Expr+                   -- (p <$) = fmap (p <$)+                 , ft_forall = \_ g -> g+                 , ft_bad_app = panic "in other argument in ft_replace"+                 , ft_co_var = panic "contravariant in ft_replace" }++    -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...+    match_for_con :: HsMatchContext RdrName+                  -> [LPat GhcPs] -> DataCon -> [LHsExpr GhcPs]+                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))+    match_for_con ctxt = mkSimpleConMatch ctxt $+        \con_name xs -> return $ nlHsApps con_name xs  -- Con x1 x2 ..++-- See Note [Deriving <$]+data Replacer = Immediate {replace :: LHsExpr GhcPs}+              | Nested {replace :: LHsExpr GhcPs}++{- Note [Deriving <$]+   ~~~~~~~~~~~~~~~~~~++We derive the definition of <$. Allowing this to take the default definition+can lead to memory leaks: mapping over a structure with a constant function can+fill the result structure with trivial thunks that retain the values from the+original structure. The simplifier seems to handle this all right for simple+types, but not for recursive ones. Consider++data Tree a = Bin !(Tree a) a !(Tree a) | Tip deriving Functor++-- fmap _ Tip = Tip+-- fmap f (Bin l v r) = Bin (fmap f l) (f v) (fmap f r)++Using the default definition of <$, we get (<$) x = fmap (\_ -> x) and that+simplifies no further. Why is that? `fmap` is defined recursively, so GHC+cannot inline it. The static argument transformation would turn the definition+into a non-recursive one++-- fmap f = go where+--   go Tip = Tip+--   go (Bin l v r) = Bin (go l) (f v) (go r)++which GHC could inline, producing an efficient definion of `<$`. But there are+several problems. First, GHC does not perform the static argument transformation+by default, even with -O2. Second, even when it does perform the static argument+transformation, it does so only when there are at least two static arguments,+which is not the case for fmap. Finally, when the type in question is+non-regular, such as++data Nesty a = Z a | S (Nesty a) (Nest (a, a))++the function argument is no longer (entirely) static, so the static argument+transformation will do nothing for us.++Applying the default definition of `<$` will produce a tree full of thunks that+look like ((\_ -> x) x0), which represents unnecessary thunk allocation and+also retention of the previous value, potentially leaking memory. Instead, we+derive <$ separately. Two aspects are different from fmap: the case of the+sought type variable (ft_var) and the case of a type application (ft_ty_app).+The interesting one is ft_ty_app. We have to distinguish two cases: the+"immediate" case where the type argument *is* the sought type variable, and+the "nested" case where the type argument *contains* the sought type variable.++The immediate case:++Suppose we have++data Imm a = Imm (F ... a)++Then we want to define++x <$ Imm q = Imm (x <$ q)++The nested case:++Suppose we have++data Nes a = Nes (F ... (G a))++Then we want to define++x <$ Nes q = Nes (fmap (x <$) q)++We use the Replacer type to tag whether the expression derived for applying+<$ to the last type variable was the ft_var case (immediate) or one of the+others (letting ft_forall pass through as usual).++We could, but do not, give tuples special treatment to improve efficiency+in some cases. Suppose we have++data Nest a = Z a | S (Nest (a,a))++The optimal definition would be++x <$ Z _ = Z x+x <$ S t = S ((x, x) <$ t)++which produces a result with maximal internal sharing. The reason we do not+attempt to treat this case specially is that we have no way to give+user-provided tuple-like types similar treatment. If the user changed the+definition to++data Pair a = Pair a a+data Nest a = Z a | S (Nest (Pair a))++they would experience a surprising degradation in performance. -}+++{-+Utility functions related to Functor deriving.++Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.+This function works like a fold: it makes a value of type 'a' in a bottom up way.+-}++-- Generic traversal for Functor deriving+-- See Note [FFoldType and functorLikeTraverse]+data FFoldType a      -- Describes how to fold over a Type in a functor like way+   = FT { ft_triv    :: a+          -- ^ Does not contain variable+        , ft_var     :: a+          -- ^ The variable itself+        , ft_co_var  :: a+          -- ^ The variable itself, contravariantly+        , ft_fun     :: a -> a -> a+          -- ^ Function type+        , ft_tup     :: TyCon -> [a] -> a+          -- ^ Tuple type+        , ft_ty_app  :: Type -> a -> a+          -- ^ Type app, variable only in last argument+        , ft_bad_app :: a+          -- ^ Type app, variable other than in last argument+        , ft_forall  :: TcTyVar -> a -> a+          -- ^ Forall type+     }++functorLikeTraverse :: forall a.+                       TyVar         -- ^ Variable to look for+                    -> FFoldType a   -- ^ How to fold+                    -> Type          -- ^ Type to process+                    -> a+functorLikeTraverse var (FT { ft_triv = caseTrivial,     ft_var = caseVar+                            , ft_co_var = caseCoVar,     ft_fun = caseFun+                            , ft_tup = caseTuple,        ft_ty_app = caseTyApp+                            , ft_bad_app = caseWrongArg, ft_forall = caseForAll })+                    ty+  = fst (go False ty)+  where+    go :: Bool        -- Covariant or contravariant context+       -> Type+       -> (a, Bool)   -- (result of type a, does type contain var)++    go co ty | Just ty' <- tcView ty = go co ty'+    go co (TyVarTy    v) | v == var = (if co then caseCoVar else caseVar,True)+    go co (FunTy { ft_arg = x, ft_res = y, ft_af = af })+       | InvisArg <- af = go co y+       | xc || yc       = (caseFun xr yr,True)+       where (xr,xc) = go (not co) x+             (yr,yc) = go co       y+    go co (AppTy    x y) | xc = (caseWrongArg,   True)+                         | yc = (caseTyApp x yr, True)+        where (_, xc) = go co x+              (yr,yc) = go co y+    go co ty@(TyConApp con args)+       | not (or xcs)     = (caseTrivial, False)   -- Variable does not occur+       -- At this point we know that xrs, xcs is not empty,+       -- and at least one xr is True+       | isTupleTyCon con = (caseTuple con xrs, True)+       | or (init xcs)    = (caseWrongArg, True)         -- T (..var..)    ty+       | Just (fun_ty, _) <- splitAppTy_maybe ty         -- T (..no var..) ty+                          = (caseTyApp fun_ty (last xrs), True)+       | otherwise        = (caseWrongArg, True)   -- Non-decomposable (eg type function)+       where+         -- When folding over an unboxed tuple, we must explicitly drop the+         -- runtime rep arguments, or else GHC will generate twice as many+         -- variables in a unboxed tuple pattern match and expression as it+         -- actually needs. See #12399+         (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args))+    go co (ForAllTy (Bndr v vis) x)+       | isVisibleArgFlag vis = panic "unexpected visible binder"+       | v /= var && xc       = (caseForAll v xr,True)+       where (xr,xc) = go co x++    go _ _ = (caseTrivial,False)++-- Return all syntactic subterms of ty that contain var somewhere+-- These are the things that should appear in instance constraints+deepSubtypesContaining :: TyVar -> Type -> [TcType]+deepSubtypesContaining tv+  = functorLikeTraverse tv+        (FT { ft_triv = []+            , ft_var = []+            , ft_fun = (++)+            , ft_tup = \_ xs -> concat xs+            , ft_ty_app = (:)+            , ft_bad_app = panic "in other argument in deepSubtypesContaining"+            , ft_co_var = panic "contravariant in deepSubtypesContaining"+            , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })+++foldDataConArgs :: FFoldType a -> DataCon -> [a]+-- Fold over the arguments of the datacon+foldDataConArgs ft con+  = map foldArg (dataConOrigArgTys con)+  where+    foldArg+      = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of+             Just tv -> functorLikeTraverse tv ft+             Nothing -> const (ft_triv ft)+    -- If we are deriving Foldable for a GADT, there is a chance that the last+    -- type variable in the data type isn't actually a type variable at all.+    -- (for example, this can happen if the last type variable is refined to+    -- be a concrete type such as Int). If the last type variable is refined+    -- to be a specific type, then getTyVar_maybe will return Nothing.+    -- See Note [DeriveFoldable with ExistentialQuantification]+    --+    -- The kind checks have ensured the last type parameter is of kind *.++-- Make a HsLam using a fresh variable from a State monad+mkSimpleLam :: (LHsExpr GhcPs -> State [RdrName] (LHsExpr GhcPs))+            -> State [RdrName] (LHsExpr GhcPs)+-- (mkSimpleLam fn) returns (\x. fn(x))+mkSimpleLam lam =+    get >>= \case+      n:names -> do+        put names+        body <- lam (nlHsVar n)+        return (mkHsLam [nlVarPat n] body)+      _ -> panic "mkSimpleLam"++mkSimpleLam2 :: (LHsExpr GhcPs -> LHsExpr GhcPs+             -> State [RdrName] (LHsExpr GhcPs))+             -> State [RdrName] (LHsExpr GhcPs)+mkSimpleLam2 lam =+    get >>= \case+      n1:n2:names -> do+        put names+        body <- lam (nlHsVar n1) (nlHsVar n2)+        return (mkHsLam [nlVarPat n1,nlVarPat n2] body)+      _ -> panic "mkSimpleLam2"++-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"+--+-- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in+-- which the LHS pattern-matches on @extra_pats@, followed by a match on the+-- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@+-- and its arguments, applying an expression (from @insides@) to each of the+-- respective arguments of @con@.+mkSimpleConMatch :: Monad m => HsMatchContext RdrName+                 -> (RdrName -> [LHsExpr GhcPs] -> m (LHsExpr GhcPs))+                 -> [LPat GhcPs]+                 -> DataCon+                 -> [LHsExpr GhcPs]+                 -> m (LMatch GhcPs (LHsExpr GhcPs))+mkSimpleConMatch ctxt fold extra_pats con insides = do+    let con_name = getRdrName con+    let vars_needed = takeList insides as_RDRs+    let bare_pat = nlConVarPat con_name vars_needed+    let pat = if null vars_needed+          then bare_pat+          else nlParPat bare_pat+    rhs <- fold con_name+                (zipWith (\i v -> i `nlHsApp` nlHsVar v) insides vars_needed)+    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs+                     (noLoc emptyLocalBinds)++-- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"+--+-- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to+-- 'mkSimpleConMatch', with two key differences:+--+-- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a+--    @[LHsExpr RdrName]@. This is because it filters out the expressions+--    corresponding to arguments whose types do not mention the last type+--    variable in a derived 'Foldable' or 'Traversable' instance (i.e., the+--    'Nothing' elements of @insides@).+--+-- 2. @fold@ takes an expression as its first argument instead of a+--    constructor name. This is because it uses a specialized+--    constructor function expression that only takes as many parameters as+--    there are argument types that mention the last type variable.+--+-- See Note [Generated code for DeriveFoldable and DeriveTraversable]+mkSimpleConMatch2 :: Monad m+                  => HsMatchContext RdrName+                  -> (LHsExpr GhcPs -> [LHsExpr GhcPs]+                                      -> m (LHsExpr GhcPs))+                  -> [LPat GhcPs]+                  -> DataCon+                  -> [Maybe (LHsExpr GhcPs)]+                  -> m (LMatch GhcPs (LHsExpr GhcPs))+mkSimpleConMatch2 ctxt fold extra_pats con insides = do+    let con_name = getRdrName con+        vars_needed = takeList insides as_RDRs+        pat = nlConVarPat con_name vars_needed+        -- Make sure to zip BEFORE invoking catMaybes. We want the variable+        -- indicies in each expression to match up with the argument indices+        -- in con_expr (defined below).+        exps = catMaybes $ zipWith (\i v -> (`nlHsApp` nlHsVar v) <$> i)+                                   insides vars_needed+        -- An element of argTysTyVarInfo is True if the constructor argument+        -- with the same index has a type which mentions the last type+        -- variable.+        argTysTyVarInfo = map isJust insides+        (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_Vars++        con_expr+          | null asWithTyVar = nlHsApps con_name asWithoutTyVar+          | otherwise =+              let bs   = filterByList  argTysTyVarInfo bs_RDRs+                  vars = filterByLists argTysTyVarInfo bs_Vars as_Vars+              in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)++    rhs <- fold con_expr exps+    return $ mkMatch ctxt (extra_pats ++ [pat]) rhs+                     (noLoc emptyLocalBinds)++-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"+mkSimpleTupleCase :: Monad m => ([LPat GhcPs] -> DataCon -> [a]+                                 -> m (LMatch GhcPs (LHsExpr GhcPs)))+                  -> TyCon -> [a] -> LHsExpr GhcPs -> m (LHsExpr GhcPs)+mkSimpleTupleCase match_for_con tc insides x+  = do { let data_con = tyConSingleDataCon tc+       ; match <- match_for_con [] data_con insides+       ; return $ nlHsCase x [match] }++{-+************************************************************************+*                                                                      *+                        Foldable instances++ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html++*                                                                      *+************************************************************************++Deriving Foldable instances works the same way as Functor instances,+only Foldable instances are not possible for function types at all.+Given (data T a = T a a (T a) deriving Foldable), we get:++  instance Foldable T where+      foldr f z (T x1 x2 x3) =+        $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) )++-XDeriveFoldable is different from -XDeriveFunctor in that it filters out+arguments to the constructor that would produce useless code in a Foldable+instance. For example, the following datatype:++  data Foo a = Foo Int a Int deriving Foldable++would have the following generated Foldable instance:++  instance Foldable Foo where+    foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2++since neither of the two Int arguments are folded over.++The cases are:++  $(foldr 'a 'a)         =  f+  $(foldr 'a '(b1,b2))   =  \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )+  $(foldr 'a '(T b1 b2)) =  \x z -> foldr $(foldr 'a 'b2) z x  -- when a only occurs in the last parameter, b2++Note that the arguments to the real foldr function are the wrong way around,+since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).++One can envision a case for types that don't contain the last type variable:++  $(foldr 'a 'b)         =  \x z -> z     -- when b does not contain a++But this case will never materialize, since the aforementioned filtering+removes all such types from consideration.+See Note [Generated code for DeriveFoldable and DeriveTraversable].++Foldable instances differ from Functor and Traversable instances in that+Foldable instances can be derived for data types in which the last type+variable is existentially quantified. In particular, if the last type variable+is refined to a more specific type in a GADT:++  data GADT a where+      G :: a ~ Int => a -> G Int++then the deriving machinery does not attempt to check that the type a contains+Int, since it is not syntactically equal to a type variable. That is, the+derived Foldable instance for GADT is:++  instance Foldable GADT where+      foldr _ z (GADT _) = z++See Note [DeriveFoldable with ExistentialQuantification].++Note [Deriving null]+~~~~~~~~~~~~~~~~~~~~++In some cases, deriving the definition of 'null' can produce much better+results than the default definition. For example, with++  data SnocList a = Nil | Snoc (SnocList a) a++the default definition of 'null' would walk the entire spine of a+nonempty snoc-list before concluding that it is not null. But looking at+the Snoc constructor, we can immediately see that it contains an 'a', and+so 'null' can return False immediately if it matches on Snoc. When we+derive 'null', we keep track of things that cannot be null. The interesting+case is type application. Given++  data Wrap a = Wrap (Foo (Bar a))++we use++  null (Wrap fba) = all null fba++but if we see++  data Wrap a = Wrap (Foo a)++we can just use++  null (Wrap fa) = null fa++Indeed, we allow this to happen even for tuples:++  data Wrap a = Wrap (Foo (a, Int))++produces++  null (Wrap fa) = null fa++As explained in Note [Deriving <$], giving tuples special performance treatment+could surprise users if they switch to other types, but Ryan Scott seems to+think it's okay to do it for now.+-}++gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)+-- When the parameter is phantom, we can use foldMap _ _ = mempty+-- See Note [Phantom types with Functor, Foldable, and Traversable]+gen_Foldable_binds loc tycon+  | Phantom <- last (tyConRoles tycon)+  = (unitBag foldMap_bind, emptyBag)+  where+    foldMap_name = L loc foldMap_RDR+    foldMap_bind = mkRdrFunBind foldMap_name foldMap_eqns+    foldMap_eqns = [mkSimpleMatch foldMap_match_ctxt+                                  [nlWildPat, nlWildPat]+                                  mempty_Expr]+    foldMap_match_ctxt = mkPrefixFunRhs foldMap_name++gen_Foldable_binds loc tycon+  | null data_cons  -- There's no real point producing anything but+                    -- foldMap for a type with no constructors.+  = (unitBag foldMap_bind, emptyBag)++  | otherwise+  = (listToBag [foldr_bind, foldMap_bind, null_bind], emptyBag)+  where+    data_cons = tyConDataCons tycon++    foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns+    eqns = map foldr_eqn data_cons+    foldr_eqn con+      = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs+      where+        parts = sequence $ foldDataConArgs ft_foldr con++    foldMap_name = L loc foldMap_RDR++    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]+    foldMap_bind = mkRdrFunBindEC 2 (const mempty_Expr)+                      foldMap_name foldMap_eqns++    foldMap_eqns = map foldMap_eqn data_cons++    foldMap_eqn con+      = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs+      where+        parts = sequence $ foldDataConArgs ft_foldMap con++    -- Given a list of NullM results, produce Nothing if any of+    -- them is NotNull, and otherwise produce a list of Maybes+    -- with Justs representing unknowns and Nothings representing+    -- things that are definitely null.+    convert :: [NullM a] -> Maybe [Maybe a]+    convert = traverse go where+      go IsNull = Just Nothing+      go NotNull = Nothing+      go (NullM a) = Just (Just a)++    null_name = L loc null_RDR+    null_match_ctxt = mkPrefixFunRhs null_name+    null_bind = mkRdrFunBind null_name null_eqns+    null_eqns = map null_eqn data_cons+    null_eqn con+      = flip evalState bs_RDRs $ do+          parts <- sequence $ foldDataConArgs ft_null con+          case convert parts of+            Nothing -> return $+              mkMatch null_match_ctxt [nlParPat (nlWildConPat con)]+                false_Expr (noLoc emptyLocalBinds)+            Just cp -> match_null [] con cp++    -- Yields 'Just' an expression if we're folding over a type that mentions+    -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.+    -- See Note [FFoldType and functorLikeTraverse]+    ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))+    ft_foldr+      = FT { ft_triv    = return Nothing+             -- foldr f = \x z -> z+           , ft_var     = return $ Just f_Expr+             -- foldr f = f+           , ft_tup     = \t g -> do+               gg  <- sequence g+               lam <- mkSimpleLam2 $ \x z ->+                 mkSimpleTupleCase (match_foldr z) t gg x+               return (Just lam)+             -- foldr f = (\x z -> case x of ...)+           , ft_ty_app  = \_ g -> do+               gg <- g+               mapM (\gg' -> mkSimpleLam2 $ \x z -> return $+                 nlHsApps foldable_foldr_RDR [gg',z,x]) gg+             -- foldr f = (\x z -> foldr g z x)+           , ft_forall  = \_ g -> g+           , ft_co_var  = panic "contravariant in ft_foldr"+           , ft_fun     = panic "function in ft_foldr"+           , ft_bad_app = panic "in other argument in ft_foldr" }++    match_foldr :: LHsExpr GhcPs+                -> [LPat GhcPs]+                -> DataCon+                -> [Maybe (LHsExpr GhcPs)]+                -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))+    match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)+      where+        -- g1 v1 (g2 v2 (.. z))+        mkFoldr :: [LHsExpr GhcPs] -> LHsExpr GhcPs+        mkFoldr = foldr nlHsApp z++    -- See Note [FFoldType and functorLikeTraverse]+    ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))+    ft_foldMap+      = FT { ft_triv = return Nothing+             -- foldMap f = \x -> mempty+           , ft_var  = return (Just f_Expr)+             -- foldMap f = f+           , ft_tup  = \t g -> do+               gg  <- sequence g+               lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg+               return (Just lam)+             -- foldMap f = \x -> case x of (..,)+           , ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g+             -- foldMap f = foldMap g+           , ft_forall = \_ g -> g+           , ft_co_var = panic "contravariant in ft_foldMap"+           , ft_fun = panic "function in ft_foldMap"+           , ft_bad_app = panic "in other argument in ft_foldMap" }++    match_foldMap :: [LPat GhcPs]+                  -> DataCon+                  -> [Maybe (LHsExpr GhcPs)]+                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))+    match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)+      where+        -- mappend v1 (mappend v2 ..)+        mkFoldMap :: [LHsExpr GhcPs] -> LHsExpr GhcPs+        mkFoldMap [] = mempty_Expr+        mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs++    -- See Note [FFoldType and functorLikeTraverse]+    -- Yields NullM an expression if we're folding over an expression+    -- that may or may not be null. Yields IsNull if it's certainly+    -- null, and yields NotNull if it's certainly not null.+    -- See Note [Deriving null]+    ft_null :: FFoldType (State [RdrName] (NullM (LHsExpr GhcPs)))+    ft_null+      = FT { ft_triv = return IsNull+             -- null = \_ -> True+           , ft_var  = return NotNull+             -- null = \_ -> False+           , ft_tup  = \t g -> do+               gg  <- sequence g+               case convert gg of+                 Nothing -> pure NotNull+                 Just ggg ->+                   NullM <$> (mkSimpleLam $ mkSimpleTupleCase match_null t ggg)+             -- null = \x -> case x of (..,)+           , ft_ty_app = \_ g -> flip fmap g $ \nestedResult ->+                              case nestedResult of+                                -- If e definitely contains the parameter,+                                -- then we can test if (G e) contains it by+                                -- simply checking if (G e) is null+                                NotNull -> NullM null_Expr+                                -- This case is unreachable--it will actually be+                                -- caught by ft_triv+                                IsNull -> IsNull+                                -- The general case uses (all null),+                                -- (all (all null)), etc.+                                NullM nestedTest -> NullM $+                                                    nlHsApp all_Expr nestedTest+             -- null fa = null fa, or null fa = all null fa, or null fa = True+           , ft_forall = \_ g -> g+           , ft_co_var = panic "contravariant in ft_null"+           , ft_fun = panic "function in ft_null"+           , ft_bad_app = panic "in other argument in ft_null" }++    match_null :: [LPat GhcPs]+                  -> DataCon+                  -> [Maybe (LHsExpr GhcPs)]+                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))+    match_null = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkNull xs)+      where+        -- v1 && v2 && ..+        mkNull :: [LHsExpr GhcPs] -> LHsExpr GhcPs+        mkNull [] = true_Expr+        mkNull xs = foldr1 (\x y -> nlHsApps and_RDR [x,y]) xs++data NullM a =+    IsNull   -- Definitely null+  | NotNull  -- Definitely not null+  | NullM a  -- Unknown++{-+************************************************************************+*                                                                      *+                        Traversable instances++ see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html+*                                                                      *+************************************************************************++Again, Traversable is much like Functor and Foldable.++The cases are:++  $(traverse 'a 'a)          =  f+  $(traverse 'a '(b1,b2))    =  \x -> case x of (x1,x2) ->+     liftA2 (,) ($(traverse 'a 'b1) x1) ($(traverse 'a 'b2) x2)+  $(traverse 'a '(T b1 b2))  =  traverse $(traverse 'a 'b2)  -- when a only occurs in the last parameter, b2++Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types+do not mention the last type parameter. Therefore, the following datatype:++  data Foo a = Foo Int a Int++would have the following derived Traversable instance:++  instance Traversable Foo where+    traverse f (Foo x1 x2 x3) =+      fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 )++since the two Int arguments do not produce any effects in a traversal.++One can envision a case for types that do not mention the last type parameter:++  $(traverse 'a 'b)          =  pure     -- when b does not contain a++But this case will never materialize, since the aforementioned filtering+removes all such types from consideration.+See Note [Generated code for DeriveFoldable and DeriveTraversable].+-}++gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds GhcPs, BagDerivStuff)+-- When the argument is phantom, we can use traverse = pure . coerce+-- See Note [Phantom types with Functor, Foldable, and Traversable]+gen_Traversable_binds loc tycon+  | Phantom <- last (tyConRoles tycon)+  = (unitBag traverse_bind, emptyBag)+  where+    traverse_name = L loc traverse_RDR+    traverse_bind = mkRdrFunBind traverse_name traverse_eqns+    traverse_eqns =+        [mkSimpleMatch traverse_match_ctxt+                       [nlWildPat, z_Pat]+                       (nlHsApps pure_RDR [nlHsApp coerce_Expr z_Expr])]+    traverse_match_ctxt = mkPrefixFunRhs traverse_name++gen_Traversable_binds loc tycon+  = (unitBag traverse_bind, emptyBag)+  where+    data_cons = tyConDataCons tycon++    traverse_name = L loc traverse_RDR++    -- See Note [EmptyDataDecls with Functor, Foldable, and Traversable]+    traverse_bind = mkRdrFunBindEC 2 (nlHsApp pure_Expr)+                                   traverse_name traverse_eqns+    traverse_eqns = map traverse_eqn data_cons+    traverse_eqn con+      = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs+      where+        parts = sequence $ foldDataConArgs ft_trav con++    -- Yields 'Just' an expression if we're folding over a type that mentions+    -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.+    -- See Note [FFoldType and functorLikeTraverse]+    ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr GhcPs)))+    ft_trav+      = FT { ft_triv    = return Nothing+             -- traverse f = pure x+           , ft_var     = return (Just f_Expr)+             -- traverse f = f x+           , ft_tup     = \t gs -> do+               gg  <- sequence gs+               lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg+               return (Just lam)+             -- traverse f = \x -> case x of (a1,a2,..) ->+             --                           liftA2 (,,) (g1 a1) (g2 a2) <*> ..+           , ft_ty_app  = \_ g -> fmap (nlHsApp traverse_Expr) <$> g+             -- traverse f = traverse g+           , ft_forall  = \_ g -> g+           , ft_co_var  = panic "contravariant in ft_trav"+           , ft_fun     = panic "function in ft_trav"+           , ft_bad_app = panic "in other argument in ft_trav" }++    -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)+    --                    (g2 a2) <*> ...+    match_for_con :: [LPat GhcPs]+                  -> DataCon+                  -> [Maybe (LHsExpr GhcPs)]+                  -> State [RdrName] (LMatch GhcPs (LHsExpr GhcPs))+    match_for_con = mkSimpleConMatch2 CaseAlt $+                                             \con xs -> return (mkApCon con xs)+      where+        -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..+        mkApCon :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs+        mkApCon con [] = nlHsApps pure_RDR [con]+        mkApCon con [x] = nlHsApps fmap_RDR [con,x]+        mkApCon con (x1:x2:xs) =+            foldl' appAp (nlHsApps liftA2_RDR [con,x1,x2]) xs+          where appAp x y = nlHsApps ap_RDR [x,y]++-----------------------------------------------------------------------++f_Expr, z_Expr, fmap_Expr, replace_Expr, mempty_Expr, foldMap_Expr,+    traverse_Expr, coerce_Expr, pure_Expr, true_Expr, false_Expr,+    all_Expr, null_Expr :: LHsExpr GhcPs+f_Expr        = nlHsVar f_RDR+z_Expr        = nlHsVar z_RDR+fmap_Expr     = nlHsVar fmap_RDR+replace_Expr  = nlHsVar replace_RDR+mempty_Expr   = nlHsVar mempty_RDR+foldMap_Expr  = nlHsVar foldMap_RDR+traverse_Expr = nlHsVar traverse_RDR+coerce_Expr   = nlHsVar (getRdrName coerceId)+pure_Expr     = nlHsVar pure_RDR+true_Expr     = nlHsVar true_RDR+false_Expr    = nlHsVar false_RDR+all_Expr      = nlHsVar all_RDR+null_Expr     = nlHsVar null_RDR++f_RDR, z_RDR :: RdrName+f_RDR = mkVarUnqual (fsLit "f")+z_RDR = mkVarUnqual (fsLit "z")++as_RDRs, bs_RDRs :: [RdrName]+as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]+bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]++as_Vars, bs_Vars :: [LHsExpr GhcPs]+as_Vars = map nlHsVar as_RDRs+bs_Vars = map nlHsVar bs_RDRs++f_Pat, z_Pat :: LPat GhcPs+f_Pat = nlVarPat f_RDR+z_Pat = nlVarPat z_RDR++{-+Note [DeriveFoldable with ExistentialQuantification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Functor and Traversable instances can only be derived for data types whose+last type parameter is truly universally polymorphic. For example:++  data T a b where+    T1 ::                 b   -> T a b   -- YES, b is unconstrained+    T2 :: Ord b   =>      b   -> T a b   -- NO, b is constrained by (Ord b)+    T3 :: b ~ Int =>      b   -> T a b   -- NO, b is constrained by (b ~ Int)+    T4 ::                 Int -> T a Int -- NO, this is just like T3+    T5 :: Ord a   => a -> b   -> T a b   -- YES, b is unconstrained, even+                                         -- though a is existential+    T6 ::                 Int -> T Int b -- YES, b is unconstrained++For Foldable instances, however, we can completely lift the constraint that+the last type parameter be truly universally polymorphic. This means that T+(as defined above) can have a derived Foldable instance:++  instance Foldable (T a) where+    foldr f z (T1 b)   = f b z+    foldr f z (T2 b)   = f b z+    foldr f z (T3 b)   = f b z+    foldr f z (T4 b)   = z+    foldr f z (T5 a b) = f b z+    foldr f z (T6 a)   = z++    foldMap f (T1 b)   = f b+    foldMap f (T2 b)   = f b+    foldMap f (T3 b)   = f b+    foldMap f (T4 b)   = mempty+    foldMap f (T5 a b) = f b+    foldMap f (T6 a)   = mempty++In a Foldable instance, it is safe to fold over an occurrence of the last type+parameter that is not truly universally polymorphic. However, there is a bit+of subtlety in determining what is actually an occurrence of a type parameter.+T3 and T4, as defined above, provide one example:++  data T a b where+    ...+    T3 :: b ~ Int => b   -> T a b+    T4 ::            Int -> T a Int+    ...++  instance Foldable (T a) where+    ...+    foldr f z (T3 b) = f b z+    foldr f z (T4 b) = z+    ...+    foldMap f (T3 b) = f b+    foldMap f (T4 b) = mempty+    ...++Notice that the argument of T3 is folded over, whereas the argument of T4 is+not. This is because we only fold over constructor arguments that+syntactically mention the universally quantified type parameter of that+particular data constructor. See foldDataConArgs for how this is implemented.++As another example, consider the following data type. The argument of each+constructor has the same type as the last type parameter:++  data E a where+    E1 :: (a ~ Int) => a   -> E a+    E2 ::              Int -> E Int+    E3 :: (a ~ Int) => a   -> E Int+    E4 :: (a ~ Int) => Int -> E a++Only E1's argument is an occurrence of a universally quantified type variable+that is syntactically equivalent to the last type parameter, so only E1's+argument will be folded over in a derived Foldable instance.++See #10447 for the original discussion on this feature. Also see+https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/derive-functor+for a more in-depth explanation.++Note [FFoldType and functorLikeTraverse]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Deriving Functor, Foldable, and Traversable all require generating expressions+which perform an operation on each argument of a data constructor depending+on the argument's type. In particular, a generated operation can be different+depending on whether the type mentions the last type variable of the datatype+(e.g., if you have data T a = MkT a Int, then a generated foldr expression would+fold over the first argument of MkT, but not the second).++This pattern is abstracted with the FFoldType datatype, which provides hooks+for the user to specify how a constructor argument should be folded when it+has a type with a particular "shape". The shapes are as follows (assume that+a is the last type variable in a given datatype):++* ft_triv:    The type does not mention the last type variable at all.+              Examples: Int, b++* ft_var:     The type is syntactically equal to the last type variable.+              Moreover, the type appears in a covariant position (see+              the Deriving Functor instances section of the user's guide+              for an in-depth explanation of covariance vs. contravariance).+              Example: a (covariantly)++* ft_co_var:  The type is syntactically equal to the last type variable.+              Moreover, the type appears in a contravariant position.+              Example: a (contravariantly)++* ft_fun:     A function type which mentions the last type variable in+              the argument position, result position or both.+              Examples: a -> Int, Int -> a, Maybe a -> [a]++* ft_tup:     A tuple type which mentions the last type variable in at least+              one of its fields. The TyCon argument of ft_tup represents the+              particular tuple's type constructor.+              Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #)++* ft_ty_app:  A type is being applied to the last type parameter, where the+              applied type does not mention the last type parameter (if it+              did, it would fall under ft_bad_app). The Type argument to+              ft_ty_app represents the applied type.++              Note that functions, tuples, and foralls are distinct cases+              and take precedence of ft_ty_app. (For example, (Int -> a) would+              fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a).+              Examples: Maybe a, Either b a++* ft_bad_app: A type application uses the last type parameter in a position+              other than the last argument. This case is singled out because+              Functor, Foldable, and Traversable instances cannot be derived+              for datatypes containing arguments with such types.+              Examples: Either a Int, Const a b++* ft_forall:  A forall'd type mentions the last type parameter on its right-+              hand side (and is not quantified on the left-hand side). This+              case is present mostly for plumbing purposes.+              Example: forall b. Either b a++If FFoldType describes a strategy for folding subcomponents of a Type, then+functorLikeTraverse is the function that applies that strategy to the entirety+of a Type, returning the final folded-up result.++foldDataConArgs applies functorLikeTraverse to every argument type of a+constructor, returning a list of the fold results. This makes foldDataConArgs+a natural way to generate the subexpressions in a generated fmap, foldr,+foldMap, or traverse definition (the subexpressions must then be combined in+a method-specific fashion to form the final generated expression).++Deriving Generic1 also does validity checking by looking for the last type+variable in certain positions of a constructor's argument types, so it also+uses foldDataConArgs. See Note [degenerate use of FFoldType] in TcGenGenerics.++Note [Generated code for DeriveFoldable and DeriveTraversable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on+that of -XDeriveFunctor. However, there an important difference between deriving+the former two typeclasses and the latter one, which is best illustrated by the+following scenario:++  data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable)++The generated code for the Functor instance is straightforward:++  instance Functor WithInt where+    fmap f (WithInt a i) = WithInt (f a) i++But if we use too similar of a strategy for deriving the Foldable and+Traversable instances, we end up with this code:++  instance Foldable WithInt where+    foldMap f (WithInt a i) = f a <> mempty++  instance Traversable WithInt where+    traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i++This is unsatisfying for two reasons:++1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure+   expects an argument whose type is of kind *. This effectively prevents+   Traversable from being derived for any datatype with an unlifted argument+   type (#11174).++2. The generated code contains superfluous expressions. By the Monoid laws,+   we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can+   reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)).++We can fix both of these issues by incorporating a slight twist to the usual+algorithm that we use for -XDeriveFunctor. The differences can be summarized+as follows:++1. In the generated expression, we only fold over arguments whose types+   mention the last type parameter. Any other argument types will simply+   produce useless 'mempty's or 'pure's, so they can be safely ignored.++2. In the case of -XDeriveTraversable, instead of applying ConName,+   we apply (\b_i ... b_k -> ConName a_1 ... a_n), where++   * ConName has n arguments+   * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond+     to the arguments whose types mention the last type parameter. As a+     consequence, taking the difference of {a_1, ..., a_n} and+     {b_i, ..., b_k} yields the all the argument values of ConName whose types+     do not mention the last type parameter. Note that [i, ..., k] is a+     strictly increasing—but not necessarily consecutive—integer sequence.++     For example, the datatype++       data Foo a = Foo Int a Int a++     would generate the following Traversable instance:++       instance Traversable Foo where+         traverse f (Foo a1 a2 a3 a4) =+           fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4++Technically, this approach would also work for -XDeriveFunctor as well, but we+decide not to do so because:++1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a))+   instead of (WithInt (f a) i).++2. There would be certain datatypes for which the above strategy would+   generate Functor code that would fail to typecheck. For example:++     data Bar f a = Bar (forall f. Functor f => f a) deriving Functor++   With the conventional algorithm, it would generate something like:++     fmap f (Bar a) = Bar (fmap f a)++   which typechecks. But with the strategy mentioned above, it would generate:++     fmap f (Bar a) = (\b -> Bar b) (fmap f a)++   which does not typecheck, since GHC cannot unify the rank-2 type variables+   in the types of b and (fmap f a).++Note [Phantom types with Functor, Foldable, and Traversable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Given a type F :: * -> * whose type argument has a phantom role, we can always+produce lawful Functor and Traversable instances using++    fmap _ = coerce+    traverse _ = pure . coerce++Indeed, these are equivalent to any *strictly lawful* instances one could+write, except that this definition of 'traverse' may be lazier.  That is, if+instances obey the laws under true equality (rather than up to some equivalence+relation), then they will be essentially equivalent to these. These definitions+are incredibly cheap, so we want to use them even if it means ignoring some+non-strictly-lawful instance in an embedded type.++Foldable has far fewer laws to work with, which leaves us unwelcome+freedom in implementing it. At a minimum, we would like to ensure that+a derived foldMap is always at least as good as foldMapDefault with a+derived traverse. To accomplish that, we must define++   foldMap _ _ = mempty++in these cases.++This may have different strictness properties from a standard derivation.+Consider++   data NotAList a = Nil | Cons (NotAList a) deriving Foldable++The usual deriving mechanism would produce++   foldMap _ Nil = mempty+   foldMap f (Cons x) = foldMap f x++which is strict in the entire spine of the NotAList.++Final point: why do we even care about such types? Users will rarely if ever+map, fold, or traverse over such things themselves, but other derived+instances may:++   data Hasn'tAList a = NotHere a (NotAList a) deriving Foldable++Note [EmptyDataDecls with Functor, Foldable, and Traversable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++There are some slightly tricky decisions to make about how to handle+Functor, Foldable, and Traversable instances for types with no constructors.+For fmap, the two basic options are++   fmap _ _ = error "Sorry, no constructors"++or++   fmap _ z = case z of++In most cases, the latter is more helpful: if the thunk passed to fmap+throws an exception, we're generally going to be much more interested in+that exception than in the fact that there aren't any constructors.++In order to match the semantics for phantoms (see note above), we need to+be a bit careful about 'traverse'. The obvious definition would be++   traverse _ z = case z of++but this is stricter than the one for phantoms. We instead use++   traverse _ z = pure $ case z of++For foldMap, the obvious choices are++   foldMap _ _ = mempty++or++   foldMap _ z = case z of++We choose the first one to be consistent with what foldMapDefault does for+a derived Traversable instance.+-}
+ compiler/typecheck/TcGenGenerics.hs view
@@ -0,0 +1,1043 @@+{-+(c) The University of Glasgow 2011+++The deriving code for the Generic class+(equivalent to the code in TcGenDeriv, for other classes)+-}++{-# LANGUAGE CPP, ScopedTypeVariables, TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module TcGenGenerics (canDoGenerics, canDoGenerics1,+                      GenericKind(..),+                      gen_Generic_binds, get_gen1_constrained_tys) where++import GhcPrelude++import HsSyn+import Type+import TcType+import TcGenDeriv+import TcGenFunctor+import DataCon+import TyCon+import FamInstEnv       ( FamInst, FamFlavor(..), mkSingleCoAxiom )+import FamInst+import Module           ( moduleName, moduleNameFS+                        , moduleUnitId, unitIdFS, getModule )+import IfaceEnv         ( newGlobalBinder )+import Name      hiding ( varName )+import RdrName+import BasicTypes+import TysPrim+import TysWiredIn+import PrelNames+import TcEnv+import TcRnMonad+import HscTypes+import ErrUtils( Validity(..), andValid )+import SrcLoc+import Bag+import VarEnv+import VarSet (elemVarSet)+import Outputable+import FastString+import Util++import Control.Monad (mplus)+import Data.List (zip4, partition)+import Data.Maybe (isJust)++#include "HsVersions.h"++{-+************************************************************************+*                                                                      *+\subsection{Bindings for the new generic deriving mechanism}+*                                                                      *+************************************************************************++For the generic representation we need to generate:+\begin{itemize}+\item A Generic instance+\item A Rep type instance+\item Many auxiliary datatypes and instances for them (for the meta-information)+\end{itemize}+-}++gen_Generic_binds :: GenericKind -> TyCon -> [Type]+                 -> TcM (LHsBinds GhcPs, FamInst)+gen_Generic_binds gk tc inst_tys = do+  repTyInsts <- tc_mkRepFamInsts gk tc inst_tys+  return (mkBindsRep gk tc, repTyInsts)++{-+************************************************************************+*                                                                      *+\subsection{Generating representation types}+*                                                                      *+************************************************************************+-}++get_gen1_constrained_tys :: TyVar -> Type -> [Type]+-- called by TcDeriv.inferConstraints; generates a list of types, each of which+-- must be a Functor in order for the Generic1 instance to work.+get_gen1_constrained_tys argVar+  = argTyFold argVar $ ArgTyAlg { ata_rec0 = const []+                                , ata_par1 = [], ata_rec1 = const []+                                , ata_comp = (:) }++{-++Note [Requirements for deriving Generic and Rep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++In the following, T, Tfun, and Targ are "meta-variables" ranging over type+expressions.++(Generic T) and (Rep T) are derivable for some type expression T if the+following constraints are satisfied.++  (a) D is a type constructor *value*. In other words, D is either a type+      constructor or it is equivalent to the head of a data family instance (up to+      alpha-renaming).++  (b) D cannot have a "stupid context".++  (c) The right-hand side of D cannot include existential types, universally+      quantified types, or "exotic" unlifted types. An exotic unlifted type+      is one which is not listed in the definition of allowedUnliftedTy+      (i.e., one for which we have no representation type).+      See Note [Generics and unlifted types]++  (d) T :: *.++(Generic1 T) and (Rep1 T) are derivable for some type expression T if the+following constraints are satisfied.++  (a),(b),(c) As above.++  (d) T must expect arguments, and its last parameter must have kind *.++      We use `a' to denote the parameter of D that corresponds to the last+      parameter of T.++  (e) For any type-level application (Tfun Targ) in the right-hand side of D+      where the head of Tfun is not a tuple constructor:++      (b1) `a' must not occur in Tfun.++      (b2) If `a' occurs in Targ, then Tfun :: * -> *.++-}++canDoGenerics :: TyCon -> Validity+-- canDoGenerics determines if Generic/Rep can be derived.+--+-- Check (a) from Note [Requirements for deriving Generic and Rep] is taken+-- care of because canDoGenerics is applied to rep tycons.+--+-- It returns IsValid if deriving is possible. It returns (NotValid reason)+-- if not.+canDoGenerics tc+  = mergeErrors (+          -- Check (b) from Note [Requirements for deriving Generic and Rep].+              (if (not (null (tyConStupidTheta tc)))+                then (NotValid (tc_name <+> text "must not have a datatype context"))+                else IsValid)+          -- See comment below+            : (map bad_con (tyConDataCons tc)))+  where+    -- The tc can be a representation tycon. When we want to display it to the+    -- user (in an error message) we should print its parent+    tc_name = ppr $ case tyConFamInst_maybe tc of+        Just (ptc, _) -> ptc+        _             -> tc++        -- Check (c) from Note [Requirements for deriving Generic and Rep].+        --+        -- If any of the constructors has an exotic unlifted type as argument,+        -- then we can't build the embedding-projection pair, because+        -- it relies on instantiating *polymorphic* sum and product types+        -- at the argument types of the constructors+    bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc))+                  then (NotValid (ppr dc <+> text+                    "must not have exotic unlifted or polymorphic arguments"))+                  else (if (not (isVanillaDataCon dc))+                          then (NotValid (ppr dc <+> text "must be a vanilla data constructor"))+                          else IsValid)++        -- Nor can we do the job if it's an existential data constructor,+        -- Nor if the args are polymorphic types (I don't think)+    bad_arg_type ty = (isUnliftedType ty && not (allowedUnliftedTy ty))+                      || not (isTauTy ty)++-- Returns True the Type argument is an unlifted type which has a+-- corresponding generic representation type. For example,+-- (allowedUnliftedTy Int#) would return True since there is the UInt+-- representation type.+allowedUnliftedTy :: Type -> Bool+allowedUnliftedTy = isJust . unboxedRepRDRs++mergeErrors :: [Validity] -> Validity+mergeErrors []             = IsValid+mergeErrors (NotValid s:t) = case mergeErrors t of+  IsValid     -> NotValid s+  NotValid s' -> NotValid (s <> text ", and" $$ s')+mergeErrors (IsValid : t) = mergeErrors t++-- A datatype used only inside of canDoGenerics1. It's the result of analysing+-- a type term.+data Check_for_CanDoGenerics1 = CCDG1+  { _ccdg1_hasParam :: Bool       -- does the parameter of interest occurs in+                                  -- this type?+  , _ccdg1_errors   :: Validity   -- errors generated by this type+  }++{-++Note [degenerate use of FFoldType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++We use foldDataConArgs here only for its ability to treat tuples+specially. foldDataConArgs also tracks covariance (though it assumes all+higher-order type parameters are covariant) and has hooks for special handling+of functions and polytypes, but we do *not* use those.++The key issue is that Generic1 deriving currently offers no sophisticated+support for functions. For example, we cannot handle++  data F a = F ((a -> Int) -> Int)++even though a is occurring covariantly.++In fact, our rule is harsh: a is simply not allowed to occur within the first+argument of (->). We treat (->) the same as any other non-tuple tycon.++Unfortunately, this means we have to track "the parameter occurs in this type"+explicitly, even though foldDataConArgs is also doing this internally.++-}++-- canDoGenerics1 determines if a Generic1/Rep1 can be derived.+--+-- Checks (a) through (c) from Note [Requirements for deriving Generic and Rep]+-- are taken care of by the call to canDoGenerics.+--+-- It returns IsValid if deriving is possible. It returns (NotValid reason)+-- if not.+canDoGenerics1 :: TyCon -> Validity+canDoGenerics1 rep_tc =+  canDoGenerics rep_tc `andValid` additionalChecks+  where+    additionalChecks+        -- check (d) from Note [Requirements for deriving Generic and Rep]+      | null (tyConTyVars rep_tc) = NotValid $+          text "Data type" <+> quotes (ppr rep_tc)+      <+> text "must have some type parameters"++      | otherwise = mergeErrors $ concatMap check_con data_cons++    data_cons = tyConDataCons rep_tc+    check_con con = case check_vanilla con of+      j@(NotValid {}) -> [j]+      IsValid -> _ccdg1_errors `map` foldDataConArgs (ft_check con) con++    bad :: DataCon -> SDoc -> SDoc+    bad con msg = text "Constructor" <+> quotes (ppr con) <+> msg++    check_vanilla :: DataCon -> Validity+    check_vanilla con | isVanillaDataCon con = IsValid+                      | otherwise            = NotValid (bad con existential)++    bmzero      = CCDG1 False IsValid+    bmbad con s = CCDG1 True $ NotValid $ bad con s+    bmplus (CCDG1 b1 m1) (CCDG1 b2 m2) = CCDG1 (b1 || b2) (m1 `andValid` m2)++    -- check (e) from Note [Requirements for deriving Generic and Rep]+    -- See also Note [degenerate use of FFoldType]+    ft_check :: DataCon -> FFoldType Check_for_CanDoGenerics1+    ft_check con = FT+      { ft_triv = bmzero++      , ft_var = caseVar, ft_co_var = caseVar++      -- (component_0,component_1,...,component_n)+      , ft_tup = \_ components -> if any _ccdg1_hasParam (init components)+                                  then bmbad con wrong_arg+                                  else foldr bmplus bmzero components++      -- (dom -> rng), where the head of ty is not a tuple tycon+      , ft_fun = \dom rng -> -- cf #8516+          if _ccdg1_hasParam dom+          then bmbad con wrong_arg+          else bmplus dom rng++      -- (ty arg), where head of ty is neither (->) nor a tuple constructor and+      -- the parameter of interest does not occur in ty+      , ft_ty_app = \_ arg -> arg++      , ft_bad_app = bmbad con wrong_arg+      , ft_forall  = \_ body -> body -- polytypes are handled elsewhere+      }+      where+        caseVar = CCDG1 True IsValid+++    existential = text "must not have existential arguments"+    wrong_arg   = text "applies a type to an argument involving the last parameter"+               $$ text "but the applied type is not of kind * -> *"++{-+************************************************************************+*                                                                      *+\subsection{Generating the RHS of a generic default method}+*                                                                      *+************************************************************************+-}++type US = Int   -- Local unique supply, just a plain Int+type Alt = (LPat GhcPs, LHsExpr GhcPs)++-- GenericKind serves to mark if a datatype derives Generic (Gen0) or+-- Generic1 (Gen1).+data GenericKind = Gen0 | Gen1++-- as above, but with a payload of the TyCon's name for "the" parameter+data GenericKind_ = Gen0_ | Gen1_ TyVar++-- as above, but using a single datacon's name for "the" parameter+data GenericKind_DC = Gen0_DC | Gen1_DC TyVar++forgetArgVar :: GenericKind_DC -> GenericKind+forgetArgVar Gen0_DC   = Gen0+forgetArgVar Gen1_DC{} = Gen1++-- When working only within a single datacon, "the" parameter's name should+-- match that datacon's name for it.+gk2gkDC :: GenericKind_ -> DataCon -> GenericKind_DC+gk2gkDC Gen0_   _ = Gen0_DC+gk2gkDC Gen1_{} d = Gen1_DC $ last $ dataConUnivTyVars d+++-- Bindings for the Generic instance+mkBindsRep :: GenericKind -> TyCon -> LHsBinds GhcPs+mkBindsRep gk tycon =+    unitBag (mkRdrFunBind (L loc from01_RDR) [from_eqn])+  `unionBags`+    unitBag (mkRdrFunBind (L loc to01_RDR) [to_eqn])+      where+        -- The topmost M1 (the datatype metadata) has the exact same type+        -- across all cases of a from/to definition, and can be factored out+        -- to save some allocations during typechecking.+        -- See Note [Generics compilation speed tricks]+        from_eqn = mkHsCaseAlt x_Pat $ mkM1_E+                                       $ nlHsPar $ nlHsCase x_Expr from_matches+        to_eqn   = mkHsCaseAlt (mkM1_P x_Pat) $ nlHsCase x_Expr to_matches++        from_matches  = [mkHsCaseAlt pat rhs | (pat,rhs) <- from_alts]+        to_matches    = [mkHsCaseAlt pat rhs | (pat,rhs) <- to_alts  ]+        loc           = srcLocSpan (getSrcLoc tycon)+        datacons      = tyConDataCons tycon++        (from01_RDR, to01_RDR) = case gk of+                                   Gen0 -> (from_RDR,  to_RDR)+                                   Gen1 -> (from1_RDR, to1_RDR)++        -- Recurse over the sum first+        from_alts, to_alts :: [Alt]+        (from_alts, to_alts) = mkSum gk_ (1 :: US) datacons+          where gk_ = case gk of+                  Gen0 -> Gen0_+                  Gen1 -> ASSERT(tyvars `lengthAtLeast` 1)+                          Gen1_ (last tyvars)+                    where tyvars = tyConTyVars tycon++--------------------------------------------------------------------------------+-- The type synonym instance and synonym+--       type instance Rep (D a b) = Rep_D a b+--       type Rep_D a b = ...representation type for D ...+--------------------------------------------------------------------------------++tc_mkRepFamInsts :: GenericKind   -- Gen0 or Gen1+                 -> TyCon         -- The type to generate representation for+                 -> [Type]        -- The type(s) to which Generic(1) is applied+                                  -- in the generated instance+                 -> TcM FamInst   -- Generated representation0 coercion+tc_mkRepFamInsts gk tycon inst_tys =+       -- Consider the example input tycon `D`, where data D a b = D_ a+       -- Also consider `R:DInt`, where { data family D x y :: * -> *+       --                               ; data instance D Int a b = D_ a }+  do { -- `rep` = GHC.Generics.Rep or GHC.Generics.Rep1 (type family)+       fam_tc <- case gk of+         Gen0 -> tcLookupTyCon repTyConName+         Gen1 -> tcLookupTyCon rep1TyConName++     ; fam_envs <- tcGetFamInstEnvs++     ; let -- If the derived instance is+           --   instance Generic (Foo x)+           -- then:+           --   `arg_ki` = *, `inst_ty` = Foo x :: *+           --+           -- If the derived instance is+           --   instance Generic1 (Bar x :: k -> *)+           -- then:+           --   `arg_k` = k, `inst_ty` = Bar x :: k -> *+           (arg_ki, inst_ty) = case (gk, inst_tys) of+             (Gen0, [inst_t])        -> (liftedTypeKind, inst_t)+             (Gen1, [arg_k, inst_t]) -> (arg_k,          inst_t)+             _ -> pprPanic "tc_mkRepFamInsts" (ppr inst_tys)++     ; let mbFamInst         = tyConFamInst_maybe tycon+           -- If we're examining a data family instance, we grab the parent+           -- TyCon (ptc) and use it to determine the type arguments+           -- (inst_args) for the data family *instance*'s type variables.+           ptc               = maybe tycon fst mbFamInst+           (_, inst_args, _) = tcLookupDataFamInst fam_envs ptc $ snd+                                 $ tcSplitTyConApp inst_ty++     ; let -- `tyvars` = [a,b]+           (tyvars, gk_) = case gk of+             Gen0 -> (all_tyvars, Gen0_)+             Gen1 -> ASSERT(not $ null all_tyvars)+                     (init all_tyvars, Gen1_ $ last all_tyvars)+             where all_tyvars = tyConTyVars tycon++       -- `repTy` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> *+     ; repTy <- tc_mkRepTy gk_ tycon arg_ki++       -- `rep_name` is a name we generate for the synonym+     ; mod <- getModule+     ; loc <- getSrcSpanM+     ; let tc_occ  = nameOccName (tyConName tycon)+           rep_occ = case gk of Gen0 -> mkGenR tc_occ; Gen1 -> mkGen1R tc_occ+     ; rep_name <- newGlobalBinder mod rep_occ loc++       -- We make sure to substitute the tyvars with their user-supplied+       -- type arguments before generating the Rep/Rep1 instance, since some+       -- of the tyvars might have been instantiated when deriving.+       -- See Note [Generating a correctly typed Rep instance].+     ; let (env_tyvars, env_inst_args)+             = case gk_ of+                 Gen0_ -> (tyvars, inst_args)+                 Gen1_ last_tv+                          -- See the "wrinkle" in+                          -- Note [Generating a correctly typed Rep instance]+                       -> ( last_tv : tyvars+                          , anyTypeOfKind (tyVarKind last_tv) : inst_args )+           env        = zipTyEnv env_tyvars env_inst_args+           in_scope   = mkInScopeSet (tyCoVarsOfTypes inst_tys)+           subst      = mkTvSubst in_scope env+           repTy'     = substTyUnchecked  subst repTy+           tcv'       = tyCoVarsOfTypeList inst_ty+           (tv', cv') = partition isTyVar tcv'+           tvs'       = scopedSort tv'+           cvs'       = scopedSort cv'+           axiom      = mkSingleCoAxiom Nominal rep_name tvs' [] cvs'+                                        fam_tc inst_tys repTy'++     ; newFamInst SynFamilyInst axiom  }++--------------------------------------------------------------------------------+-- Type representation+--------------------------------------------------------------------------------++-- | See documentation of 'argTyFold'; that function uses the fields of this+-- type to interpret the structure of a type when that type is considered as an+-- argument to a constructor that is being represented with 'Rep1'.+data ArgTyAlg a = ArgTyAlg+  { ata_rec0 :: (Type -> a)+  , ata_par1 :: a, ata_rec1 :: (Type -> a)+  , ata_comp :: (Type -> a -> a)+  }++-- | @argTyFold@ implements a generalised and safer variant of the @arg@+-- function from Figure 3 in <http://dreixel.net/research/pdf/gdmh.pdf>. @arg@+-- is conceptually equivalent to:+--+-- > arg t = case t of+-- >   _ | isTyVar t         -> if (t == argVar) then Par1 else Par0 t+-- >   App f [t'] |+-- >     representable1 f &&+-- >     t' == argVar        -> Rec1 f+-- >   App f [t'] |+-- >     representable1 f &&+-- >     t' has tyvars       -> f :.: (arg t')+-- >   _                     -> Rec0 t+--+-- where @argVar@ is the last type variable in the data type declaration we are+-- finding the representation for.+--+-- @argTyFold@ is more general than @arg@ because it uses 'ArgTyAlg' to+-- abstract out the concrete invocations of @Par0@, @Rec0@, @Par1@, @Rec1@, and+-- @:.:@.+--+-- @argTyFold@ is safer than @arg@ because @arg@ would lead to a GHC panic for+-- some data types. The problematic case is when @t@ is an application of a+-- non-representable type @f@ to @argVar@: @App f [argVar]@ is caught by the+-- @_@ pattern, and ends up represented as @Rec0 t@. This type occurs /free/ in+-- the RHS of the eventual @Rep1@ instance, which is therefore ill-formed. Some+-- representable1 checks have been relaxed, and others were moved to+-- @canDoGenerics1@.+argTyFold :: forall a. TyVar -> ArgTyAlg a -> Type -> a+argTyFold argVar (ArgTyAlg {ata_rec0 = mkRec0,+                            ata_par1 = mkPar1, ata_rec1 = mkRec1,+                            ata_comp = mkComp}) =+  -- mkRec0 is the default; use it if there is no interesting structure+  -- (e.g. occurrences of parameters or recursive occurrences)+  \t -> maybe (mkRec0 t) id $ go t where+  go :: Type -> -- type to fold through+        Maybe a -- the result (e.g. representation type), unless it's trivial+  go t = isParam `mplus` isApp where++    isParam = do -- handles parameters+      t' <- getTyVar_maybe t+      Just $ if t' == argVar then mkPar1 -- moreover, it is "the" parameter+             else mkRec0 t -- NB mkRec0 instead of the conventional mkPar0++    isApp = do -- handles applications+      (phi, beta) <- tcSplitAppTy_maybe t++      let interesting = argVar `elemVarSet` exactTyCoVarsOfType beta++      -- Does it have no interesting structure to represent?+      if not interesting then Nothing+        else -- Is the argument the parameter? Special case for mkRec1.+          if Just argVar == getTyVar_maybe beta then Just $ mkRec1 phi+            else mkComp phi `fmap` go beta -- It must be a composition.+++tc_mkRepTy ::  -- Gen0_ or Gen1_, for Rep or Rep1+               GenericKind_+              -- The type to generate representation for+            -> TyCon+              -- The kind of the representation type's argument+              -- See Note [Handling kinds in a Rep instance]+            -> Kind+               -- Generated representation0 type+            -> TcM Type+tc_mkRepTy gk_ tycon k =+  do+    d1      <- tcLookupTyCon d1TyConName+    c1      <- tcLookupTyCon c1TyConName+    s1      <- tcLookupTyCon s1TyConName+    rec0    <- tcLookupTyCon rec0TyConName+    rec1    <- tcLookupTyCon rec1TyConName+    par1    <- tcLookupTyCon par1TyConName+    u1      <- tcLookupTyCon u1TyConName+    v1      <- tcLookupTyCon v1TyConName+    plus    <- tcLookupTyCon sumTyConName+    times   <- tcLookupTyCon prodTyConName+    comp    <- tcLookupTyCon compTyConName+    uAddr   <- tcLookupTyCon uAddrTyConName+    uChar   <- tcLookupTyCon uCharTyConName+    uDouble <- tcLookupTyCon uDoubleTyConName+    uFloat  <- tcLookupTyCon uFloatTyConName+    uInt    <- tcLookupTyCon uIntTyConName+    uWord   <- tcLookupTyCon uWordTyConName++    let tcLookupPromDataCon = fmap promoteDataCon . tcLookupDataCon++    md         <- tcLookupPromDataCon metaDataDataConName+    mc         <- tcLookupPromDataCon metaConsDataConName+    ms         <- tcLookupPromDataCon metaSelDataConName+    pPrefix    <- tcLookupPromDataCon prefixIDataConName+    pInfix     <- tcLookupPromDataCon infixIDataConName+    pLA        <- tcLookupPromDataCon leftAssociativeDataConName+    pRA        <- tcLookupPromDataCon rightAssociativeDataConName+    pNA        <- tcLookupPromDataCon notAssociativeDataConName+    pSUpk      <- tcLookupPromDataCon sourceUnpackDataConName+    pSNUpk     <- tcLookupPromDataCon sourceNoUnpackDataConName+    pNSUpkness <- tcLookupPromDataCon noSourceUnpackednessDataConName+    pSLzy      <- tcLookupPromDataCon sourceLazyDataConName+    pSStr      <- tcLookupPromDataCon sourceStrictDataConName+    pNSStrness <- tcLookupPromDataCon noSourceStrictnessDataConName+    pDLzy      <- tcLookupPromDataCon decidedLazyDataConName+    pDStr      <- tcLookupPromDataCon decidedStrictDataConName+    pDUpk      <- tcLookupPromDataCon decidedUnpackDataConName++    fix_env <- getFixityEnv++    let mkSum' a b = mkTyConApp plus  [k,a,b]+        mkProd a b = mkTyConApp times [k,a,b]+        mkRec0 a   = mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k a+        mkRec1 a   = mkTyConApp rec1  [k,a]+        mkPar1     = mkTyConTy  par1+        mkD    a   = mkTyConApp d1 [ k, metaDataTy, sumP (tyConDataCons a) ]+        mkC      a = mkTyConApp c1 [ k+                                   , metaConsTy a+                                   , prod (dataConInstOrigArgTys a+                                            . mkTyVarTys . tyConTyVars $ tycon)+                                          (dataConSrcBangs    a)+                                          (dataConImplBangs   a)+                                          (dataConFieldLabels a)]+        mkS mlbl su ss ib a = mkTyConApp s1 [k, metaSelTy mlbl su ss ib, a]++        -- Sums and products are done in the same way for both Rep and Rep1+        sumP [] = mkTyConApp v1 [k]+        sumP l  = foldBal mkSum' . map mkC  $ l+        -- The Bool is True if this constructor has labelled fields+        prod :: [Type] -> [HsSrcBang] -> [HsImplBang] -> [FieldLabel] -> Type+        prod [] _  _  _  = mkTyConApp u1 [k]+        prod l  sb ib fl = foldBal mkProd+                                   [ ASSERT(null fl || lengthExceeds fl j)+                                     arg t sb' ib' (if null fl+                                                       then Nothing+                                                       else Just (fl !! j))+                                   | (t,sb',ib',j) <- zip4 l sb ib [0..] ]++        arg :: Type -> HsSrcBang -> HsImplBang -> Maybe FieldLabel -> Type+        arg t (HsSrcBang _ su ss) ib fl = mkS fl su ss ib $ case gk_ of+            -- Here we previously used Par0 if t was a type variable, but we+            -- realized that we can't always guarantee that we are wrapping-up+            -- all type variables in Par0. So we decided to stop using Par0+            -- altogether, and use Rec0 all the time.+                      Gen0_        -> mkRec0 t+                      Gen1_ argVar -> argPar argVar t+          where+            -- Builds argument representation for Rep1 (more complicated due to+            -- the presence of composition).+            argPar argVar = argTyFold argVar $ ArgTyAlg+              {ata_rec0 = mkRec0, ata_par1 = mkPar1,+               ata_rec1 = mkRec1, ata_comp = mkComp comp k}++        tyConName_user = case tyConFamInst_maybe tycon of+                           Just (ptycon, _) -> tyConName ptycon+                           Nothing          -> tyConName tycon++        dtName  = mkStrLitTy . occNameFS . nameOccName $ tyConName_user+        mdName  = mkStrLitTy . moduleNameFS . moduleName+                . nameModule . tyConName $ tycon+        pkgName = mkStrLitTy . unitIdFS . moduleUnitId+                . nameModule . tyConName $ tycon+        isNT    = mkTyConTy $ if isNewTyCon tycon+                              then promotedTrueDataCon+                              else promotedFalseDataCon++        ctName = mkStrLitTy . occNameFS . nameOccName . dataConName+        ctFix c+            | dataConIsInfix c+            = case lookupFixity fix_env (dataConName c) of+                   Fixity _ n InfixL -> buildFix n pLA+                   Fixity _ n InfixR -> buildFix n pRA+                   Fixity _ n InfixN -> buildFix n pNA+            | otherwise = mkTyConTy pPrefix+        buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc+                                             , mkNumLitTy (fromIntegral n)]++        isRec c = mkTyConTy $ if dataConFieldLabels c `lengthExceeds` 0+                              then promotedTrueDataCon+                              else promotedFalseDataCon++        selName = mkStrLitTy . flLabel++        mbSel Nothing  = mkTyConApp promotedNothingDataCon [typeSymbolKind]+        mbSel (Just s) = mkTyConApp promotedJustDataCon+                                    [typeSymbolKind, selName s]++        metaDataTy   = mkTyConApp md [dtName, mdName, pkgName, isNT]+        metaConsTy c = mkTyConApp mc [ctName c, ctFix c, isRec c]+        metaSelTy mlbl su ss ib =+            mkTyConApp ms [mbSel mlbl, pSUpkness, pSStrness, pDStrness]+          where+            pSUpkness = mkTyConTy $ case su of+                                         SrcUnpack   -> pSUpk+                                         SrcNoUnpack -> pSNUpk+                                         NoSrcUnpack -> pNSUpkness++            pSStrness = mkTyConTy $ case ss of+                                         SrcLazy     -> pSLzy+                                         SrcStrict   -> pSStr+                                         NoSrcStrict -> pNSStrness++            pDStrness = mkTyConTy $ case ib of+                                         HsLazy      -> pDLzy+                                         HsStrict    -> pDStr+                                         HsUnpack{}  -> pDUpk++    return (mkD tycon)++mkComp :: TyCon -> Kind -> Type -> Type -> Type+mkComp comp k f g+  | k1_first  = mkTyConApp comp  [k,liftedTypeKind,f,g]+  | otherwise = mkTyConApp comp  [liftedTypeKind,k,f,g]+  where+    -- Which of these is the case?+    --     newtype (:.:) {k1} {k2} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...+    -- or  newtype (:.:) {k2} {k1} (f :: k2->*) (g :: k1->k2) (p :: k1) = ...+    -- We want to instantiate with k1=k, and k2=*+    --    Reason for k2=*: see Note [Handling kinds in a Rep instance]+    -- But we need to know which way round!+    k1_first = k_first == p_kind_var+    [k_first,_,_,_,p] = tyConTyVars comp+    Just p_kind_var = getTyVar_maybe (tyVarKind p)++-- Given the TyCons for each URec-related type synonym, check to see if the+-- given type is an unlifted type that generics understands. If so, return+-- its representation type. Otherwise, return Rec0.+-- See Note [Generics and unlifted types]+mkBoxTy :: TyCon -- UAddr+        -> TyCon -- UChar+        -> TyCon -- UDouble+        -> TyCon -- UFloat+        -> TyCon -- UInt+        -> TyCon -- UWord+        -> TyCon -- Rec0+        -> Kind  -- What to instantiate Rec0's kind variable with+        -> Type+        -> Type+mkBoxTy uAddr uChar uDouble uFloat uInt uWord rec0 k ty+  | ty `eqType` addrPrimTy   = mkTyConApp uAddr   [k]+  | ty `eqType` charPrimTy   = mkTyConApp uChar   [k]+  | ty `eqType` doublePrimTy = mkTyConApp uDouble [k]+  | ty `eqType` floatPrimTy  = mkTyConApp uFloat  [k]+  | ty `eqType` intPrimTy    = mkTyConApp uInt    [k]+  | ty `eqType` wordPrimTy   = mkTyConApp uWord   [k]+  | otherwise                = mkTyConApp rec0    [k,ty]++--------------------------------------------------------------------------------+-- Dealing with sums+--------------------------------------------------------------------------------++mkSum :: GenericKind_ -- Generic or Generic1?+      -> US          -- Base for generating unique names+      -> [DataCon]   -- The data constructors+      -> ([Alt],     -- Alternatives for the T->Trep "from" function+          [Alt])     -- Alternatives for the Trep->T "to" function++-- Datatype without any constructors+mkSum _ _ [] = ([from_alt], [to_alt])+  where+    from_alt = (x_Pat, nlHsCase x_Expr [])+    to_alt   = (x_Pat, nlHsCase x_Expr [])+               -- These M1s are meta-information for the datatype++-- Datatype with at least one constructor+mkSum gk_ us datacons =+  -- switch the payload of gk_ to be datacon-centric instead of tycon-centric+ unzip [ mk1Sum (gk2gkDC gk_ d) us i (length datacons) d+           | (d,i) <- zip datacons [1..] ]++-- Build the sum for a particular constructor+mk1Sum :: GenericKind_DC -- Generic or Generic1?+       -> US        -- Base for generating unique names+       -> Int       -- The index of this constructor+       -> Int       -- Total number of constructors+       -> DataCon   -- The data constructor+       -> (Alt,     -- Alternative for the T->Trep "from" function+           Alt)     -- Alternative for the Trep->T "to" function+mk1Sum gk_ us i n datacon = (from_alt, to_alt)+  where+    gk = forgetArgVar gk_++    -- Existentials already excluded+    argTys = dataConOrigArgTys datacon+    n_args = dataConSourceArity datacon++    datacon_varTys = zip (map mkGenericLocal [us .. us+n_args-1]) argTys+    datacon_vars = map fst datacon_varTys+    us'          = us + n_args++    datacon_rdr  = getRdrName datacon++    from_alt     = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs)+    from_alt_rhs = genLR_E i n (mkProd_E gk_ us' datacon_varTys)++    to_alt     = ( genLR_P i n (mkProd_P gk us' datacon_varTys)+                 , to_alt_rhs+                 ) -- These M1s are meta-information for the datatype+    to_alt_rhs = case gk_ of+      Gen0_DC        -> nlHsVarApps datacon_rdr datacon_vars+      Gen1_DC argVar -> nlHsApps datacon_rdr $ map argTo datacon_varTys+        where+          argTo (var, ty) = converter ty `nlHsApp` nlHsVar var where+            converter = argTyFold argVar $ ArgTyAlg+              {ata_rec0 = nlHsVar . unboxRepRDR,+               ata_par1 = nlHsVar unPar1_RDR,+               ata_rec1 = const $ nlHsVar unRec1_RDR,+               ata_comp = \_ cnv -> (nlHsVar fmap_RDR `nlHsApp` cnv)+                                    `nlHsCompose` nlHsVar unComp1_RDR}+++-- Generates the L1/R1 sum pattern+genLR_P :: Int -> Int -> LPat GhcPs -> LPat GhcPs+genLR_P i n p+  | n == 0       = error "impossible"+  | n == 1       = p+  | i <= div n 2 = nlParPat $ nlConPat l1DataCon_RDR [genLR_P i     (div n 2) p]+  | otherwise    = nlParPat $ nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m)     p]+                     where m = div n 2++-- Generates the L1/R1 sum expression+genLR_E :: Int -> Int -> LHsExpr GhcPs -> LHsExpr GhcPs+genLR_E i n e+  | n == 0       = error "impossible"+  | n == 1       = e+  | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp`+                                            nlHsPar (genLR_E i     (div n 2) e)+  | otherwise    = nlHsVar r1DataCon_RDR `nlHsApp`+                                            nlHsPar (genLR_E (i-m) (n-m)     e)+                     where m = div n 2++--------------------------------------------------------------------------------+-- Dealing with products+--------------------------------------------------------------------------------++-- Build a product expression+mkProd_E :: GenericKind_DC    -- Generic or Generic1?+         -> US                -- Base for unique names+         -> [(RdrName, Type)]+                       -- List of variables matched on the lhs and their types+         -> LHsExpr GhcPs   -- Resulting product expression+mkProd_E _   _ []     = mkM1_E (nlHsVar u1DataCon_RDR)+mkProd_E gk_ _ varTys = mkM1_E (foldBal prod appVars)+                     -- These M1s are meta-information for the constructor+  where+    appVars = map (wrapArg_E gk_) varTys+    prod a b = prodDataCon_RDR `nlHsApps` [a,b]++wrapArg_E :: GenericKind_DC -> (RdrName, Type) -> LHsExpr GhcPs+wrapArg_E Gen0_DC          (var, ty) = mkM1_E $+                            boxRepRDR ty `nlHsVarApps` [var]+                         -- This M1 is meta-information for the selector+wrapArg_E (Gen1_DC argVar) (var, ty) = mkM1_E $+                            converter ty `nlHsApp` nlHsVar var+                         -- This M1 is meta-information for the selector+  where converter = argTyFold argVar $ ArgTyAlg+          {ata_rec0 = nlHsVar . boxRepRDR,+           ata_par1 = nlHsVar par1DataCon_RDR,+           ata_rec1 = const $ nlHsVar rec1DataCon_RDR,+           ata_comp = \_ cnv -> nlHsVar comp1DataCon_RDR `nlHsCompose`+                                  (nlHsVar fmap_RDR `nlHsApp` cnv)}++boxRepRDR :: Type -> RdrName+boxRepRDR = maybe k1DataCon_RDR fst . unboxedRepRDRs++unboxRepRDR :: Type -> RdrName+unboxRepRDR = maybe unK1_RDR snd . unboxedRepRDRs++-- Retrieve the RDRs associated with each URec data family instance+-- constructor. See Note [Generics and unlifted types]+unboxedRepRDRs :: Type -> Maybe (RdrName, RdrName)+unboxedRepRDRs ty+  | ty `eqType` addrPrimTy   = Just (uAddrDataCon_RDR,   uAddrHash_RDR)+  | ty `eqType` charPrimTy   = Just (uCharDataCon_RDR,   uCharHash_RDR)+  | ty `eqType` doublePrimTy = Just (uDoubleDataCon_RDR, uDoubleHash_RDR)+  | ty `eqType` floatPrimTy  = Just (uFloatDataCon_RDR,  uFloatHash_RDR)+  | ty `eqType` intPrimTy    = Just (uIntDataCon_RDR,    uIntHash_RDR)+  | ty `eqType` wordPrimTy   = Just (uWordDataCon_RDR,   uWordHash_RDR)+  | otherwise          = Nothing++-- Build a product pattern+mkProd_P :: GenericKind       -- Gen0 or Gen1+         -> US                -- Base for unique names+         -> [(RdrName, Type)] -- List of variables to match,+                              --   along with their types+         -> LPat GhcPs      -- Resulting product pattern+mkProd_P _  _ []     = mkM1_P (nlNullaryConPat u1DataCon_RDR)+mkProd_P gk _ varTys = mkM1_P (foldBal prod appVars)+                     -- These M1s are meta-information for the constructor+  where+    appVars = unzipWith (wrapArg_P gk) varTys+    prod a b = nlParPat $ prodDataCon_RDR `nlConPat` [a,b]++wrapArg_P :: GenericKind -> RdrName -> Type -> LPat GhcPs+wrapArg_P Gen0 v ty = mkM1_P (nlParPat $ boxRepRDR ty `nlConVarPat` [v])+                   -- This M1 is meta-information for the selector+wrapArg_P Gen1 v _  = nlParPat $ m1DataCon_RDR `nlConVarPat` [v]++mkGenericLocal :: US -> RdrName+mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u))++x_RDR :: RdrName+x_RDR = mkVarUnqual (fsLit "x")++x_Expr :: LHsExpr GhcPs+x_Expr = nlHsVar x_RDR++x_Pat :: LPat GhcPs+x_Pat = nlVarPat x_RDR++mkM1_E :: LHsExpr GhcPs -> LHsExpr GhcPs+mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e++mkM1_P :: LPat GhcPs -> LPat GhcPs+mkM1_P p = nlParPat $ m1DataCon_RDR `nlConPat` [p]++nlHsCompose :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+nlHsCompose x y = compose_RDR `nlHsApps` [x, y]++-- | Variant of foldr1 for producing balanced lists+foldBal :: (a -> a -> a) -> [a] -> a+foldBal op = foldBal' op (error "foldBal: empty list")++foldBal' :: (a -> a -> a) -> a -> [a] -> a+foldBal' _  x []  = x+foldBal' _  _ [y] = y+foldBal' op x l   = let (a,b) = splitAt (length l `div` 2) l+                    in foldBal' op x a `op` foldBal' op x b++{-+Note [Generics and unlifted types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Normally, all constants are marked with K1/Rec0. The exception to this rule is+when a data constructor has an unlifted argument (e.g., Int#, Char#, etc.). In+that case, we must use a data family instance of URec (from GHC.Generics) to+mark it. As a result, before we can generate K1 or unK1, we must first check+to see if the type is actually one of the unlifted types for which URec has a+data family instance; if so, we generate that instead.++See wiki:commentary/compiler/generic-deriving#handling-unlifted-types for more+details on why URec is implemented the way it is.++Note [Generating a correctly typed Rep instance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tc_mkRepTy derives the RHS of the Rep(1) type family instance when deriving+Generic(1). That is, it derives the ellipsis in the following:++    instance Generic Foo where+      type Rep Foo = ...++However, tc_mkRepTy only has knowledge of the *TyCon* of the type for which+a Generic(1) instance is being derived, not the fully instantiated type. As a+result, tc_mkRepTy builds the most generalized Rep(1) instance possible using+the type variables it learns from the TyCon (i.e., it uses tyConTyVars). This+can cause problems when the instance has instantiated type variables+(see #11732). As an example:++    data T a = MkT a+    deriving instance Generic (T Int)+    ==>+    instance Generic (T Int) where+      type Rep (T Int) = (... (Rec0 a)) -- wrong!++-XStandaloneDeriving is one way for the type variables to become instantiated.+Another way is when Generic1 is being derived for a datatype with a visible+kind binder, e.g.,++   data P k (a :: k) = MkP k deriving Generic1+   ==>+   instance Generic1 (P *) where+     type Rep1 (P *) = (... (Rec0 k)) -- wrong!++See Note [Unify kinds in deriving] in TcDeriv.++In any such scenario, we must prevent a discrepancy between the LHS and RHS of+a Rep(1) instance. To do so, we create a type variable substitution that maps+the tyConTyVars of the TyCon to their counterparts in the fully instantiated+type. (For example, using T above as example, you'd map a :-> Int.) We then+apply the substitution to the RHS before generating the instance.++A wrinkle in all of this: when forming the type variable substitution for+Generic1 instances, we map the last type variable of the tycon to Any. Why?+It's because of wily data types like this one (#15012):++   data T a = MkT (FakeOut a)+   type FakeOut a = Int++If we ignore a, then we'll produce the following Rep1 instance:++   instance Generic1 T where+     type Rep1 T = ... (Rec0 (FakeOut a))+     ...++Oh no! Now we have `a` on the RHS, but it's completely unbound. Instead, we+ensure that `a` is mapped to Any:++   instance Generic1 T where+     type Rep1 T = ... (Rec0 (FakeOut Any))+     ...++And now all is good.++Alternatively, we could have avoided this problem by expanding all type+synonyms on the RHSes of Rep1 instances. But we might blow up the size of+these types even further by doing this, so we choose not to do so.++Note [Handling kinds in a Rep instance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because Generic1 is poly-kinded, the representation types were generalized to+be kind-polymorphic as well. As a result, tc_mkRepTy must explicitly apply+the kind of the instance being derived to all the representation type+constructors. For instance, if you have++    data Empty (a :: k) = Empty deriving Generic1++Then the generated code is now approximately (with -fprint-explicit-kinds+syntax):++    instance Generic1 k (Empty k) where+      type Rep1 k (Empty k) = U1 k++Most representation types have only one kind variable, making them easy to deal+with. The only non-trivial case is (:.:), which is only used in Generic1+instances:++    newtype (:.:) (f :: k2 -> *) (g :: k1 -> k2) (p :: k1) =+        Comp1 { unComp1 :: f (g p) }++Here, we do something a bit counter-intuitive: we make k1 be the kind of the+instance being derived, and we always make k2 be *. Why *? It's because+the code that GHC generates using (:.:) is always of the form x :.: Rec1 y+for some types x and y. In other words, the second type to which (:.:) is+applied always has kind k -> *, for some kind k, so k2 cannot possibly be+anything other than * in a generated Generic1 instance.++Note [Generics compilation speed tricks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Deriving Generic(1) is known to have a large constant factor during+compilation, which contributes to noticeable compilation slowdowns when+deriving Generic(1) for large datatypes (see #5642).++To ease the pain, there is a trick one can play when generating definitions for+to(1) and from(1). If you have a datatype like:++  data Letter = A | B | C | D++then a naïve Generic instance for Letter would be:++  instance Generic Letter where+    type Rep Letter = D1 ('MetaData ...) ...++    to (M1 (L1 (L1 (M1 U1)))) = A+    to (M1 (L1 (R1 (M1 U1)))) = B+    to (M1 (R1 (L1 (M1 U1)))) = C+    to (M1 (R1 (R1 (M1 U1)))) = D++    from A = M1 (L1 (L1 (M1 U1)))+    from B = M1 (L1 (R1 (M1 U1)))+    from C = M1 (R1 (L1 (M1 U1)))+    from D = M1 (R1 (R1 (M1 U1)))++Notice that in every LHS pattern-match of the 'to' definition, and in every RHS+expression in the 'from' definition, the topmost constructor is M1. This+corresponds to the datatype-specific metadata (the D1 in the Rep Letter+instance). But this is wasteful from a typechecking perspective, since this+definition requires GHC to typecheck an application of M1 in every single case,+leading to an O(n) increase in the number of coercions the typechecker has to+solve, which in turn increases allocations and degrades compilation speed.++Luckily, since the topmost M1 has the exact same type across every case, we can+factor it out reduce the typechecker's burden:++  instance Generic Letter where+    type Rep Letter = D1 ('MetaData ...) ...++    to (M1 x) = case x of+      L1 (L1 (M1 U1)) -> A+      L1 (R1 (M1 U1)) -> B+      R1 (L1 (M1 U1)) -> C+      R1 (R1 (M1 U1)) -> D++    from x = M1 (case x of+      A -> L1 (L1 (M1 U1))+      B -> L1 (R1 (M1 U1))+      C -> R1 (L1 (M1 U1))+      D -> R1 (R1 (M1 U1)))++A simple change, but one that pays off, since it goes turns an O(n) amount of+coercions to an O(1) amount.+-}
+ compiler/typecheck/TcHoleErrors.hs view
@@ -0,0 +1,1028 @@+module TcHoleErrors ( findValidHoleFits, tcFilterHoleFits, HoleFit (..)+                    , HoleFitCandidate (..), tcCheckHoleFit, tcSubsumes+                    , withoutUnification ) where++import GhcPrelude++import TcRnTypes+import TcRnMonad+import TcMType+import TcEvidence+import TcType+import Type+import DataCon+import Name+import RdrName ( pprNameProvenance , GlobalRdrElt (..), globalRdrEnvElts )+import PrelNames ( gHC_ERR )+import Id+import VarSet+import VarEnv+import Bag+import ConLike          ( ConLike(..) )+import Util+import TcEnv (tcLookup)+import Outputable+import DynFlags+import Maybes+import FV ( fvVarList, fvVarSet, unionFV, mkFVs, FV )++import Control.Arrow ( (&&&) )++import Control.Monad    ( filterM, replicateM )+import Data.List        ( partition, sort, sortOn, nubBy )+import Data.Graph       ( graphFromEdges, topSort )+import Data.Function    ( on )+++import TcSimplify    ( simpl_top, runTcSDeriveds )+import TcUnify       ( tcSubType_NC )++import ExtractDocs ( extractDocs )+import qualified Data.Map as Map+import HsDoc           ( HsDocString, unpackHDS, DeclDocMap(..) )+import HscTypes        ( ModIface(..) )+import LoadIface       ( loadInterfaceForNameMaybe )++import PrelInfo (knownKeyNames)+++{-+Note [Valid hole fits include ...]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+`findValidHoleFits` returns the "Valid hole fits include ..." message.+For example, look at the following definitions in a file called test.hs:++   import Data.List (inits)++   f :: [String]+   f = _ "hello, world"++The hole in `f` would generate the message:++  • Found hole: _ :: [Char] -> [String]+  • In the expression: _+    In the expression: _ "hello, world"+    In an equation for ‘f’: f = _ "hello, world"+  • Relevant bindings include f :: [String] (bound at test.hs:6:1)+    Valid hole fits include+      lines :: String -> [String]+        (imported from ‘Prelude’ at mpt.hs:3:8-9+          (and originally defined in ‘base-4.11.0.0:Data.OldList’))+      words :: String -> [String]+        (imported from ‘Prelude’ at mpt.hs:3:8-9+          (and originally defined in ‘base-4.11.0.0:Data.OldList’))+      inits :: forall a. [a] -> [[a]]+        with inits @Char+        (imported from ‘Data.List’ at mpt.hs:4:19-23+          (and originally defined in ‘base-4.11.0.0:Data.OldList’))+      repeat :: forall a. a -> [a]+        with repeat @String+        (imported from ‘Prelude’ at mpt.hs:3:8-9+          (and originally defined in ‘GHC.List’))+      fail :: forall (m :: * -> *). Monad m => forall a. String -> m a+        with fail @[] @String+        (imported from ‘Prelude’ at mpt.hs:3:8-9+          (and originally defined in ‘GHC.Base’))+      return :: forall (m :: * -> *). Monad m => forall a. a -> m a+        with return @[] @String+        (imported from ‘Prelude’ at mpt.hs:3:8-9+          (and originally defined in ‘GHC.Base’))+      pure :: forall (f :: * -> *). Applicative f => forall a. a -> f a+        with pure @[] @String+        (imported from ‘Prelude’ at mpt.hs:3:8-9+          (and originally defined in ‘GHC.Base’))+      read :: forall a. Read a => String -> a+        with read @[String]+        (imported from ‘Prelude’ at mpt.hs:3:8-9+          (and originally defined in ‘Text.Read’))+      mempty :: forall a. Monoid a => a+        with mempty @([Char] -> [String])+        (imported from ‘Prelude’ at mpt.hs:3:8-9+          (and originally defined in ‘GHC.Base’))++Valid hole fits are found by checking top level identifiers and local bindings+in scope for whether their type can be instantiated to the the type of the hole.+Additionally, we also need to check whether all relevant constraints are solved+by choosing an identifier of that type as well, see Note [Relevant Constraints]++Since checking for subsumption results in the side-effect of type variables+being unified by the simplifier, we need to take care to restore them after+to being flexible type variables after we've checked for subsumption.+This is to avoid affecting the hole and later checks by prematurely having+unified one of the free unification variables.++When outputting, we sort the hole fits by the size of the types we'd need to+apply by type application to the type of the fit to to make it fit. This is done+in order to display "more relevant" suggestions first. Another option is to+sort by building a subsumption graph of fits, i.e. a graph of which fits subsume+what other fits, and then outputting those fits which are are subsumed by other+fits (i.e. those more specific than other fits) first. This results in the ones+"closest" to the type of the hole to be displayed first.++To help users understand how the suggested fit works, we also display the values+that the quantified type variables would take if that fit is used, like+`mempty @([Char] -> [String])` and `pure @[] @String` in the example above.+If -XTypeApplications is enabled, this can even be copied verbatim as a+replacement for the hole.+++Note [Nested implications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++For the simplifier to be able to use any givens present in the enclosing+implications to solve relevant constraints, we nest the wanted subsumption+constraints and relevant constraints within the enclosing implications.++As an example, let's look at the following code:++  f :: Show a => a -> String+  f x = show _++The hole will result in the hole constraint:++  [WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_))++Here the nested implications are just one level deep, namely:++  [Implic {+      TcLevel = 2+      Skolems = a_a1pa[sk:2]+      No-eqs = True+      Status = Unsolved+      Given = $dShow_a1pc :: Show a_a1pa[sk:2]+      Wanted =+        WC {wc_simple =+              [WD] __a1ph {0}:: a_a1pd[tau:2] (CHoleCan: ExprHole(_))+              [WD] $dShow_a1pe {0}:: Show a_a1pd[tau:2] (CDictCan(psc))}+      Binds = EvBindsVar<a1pi>+      Needed inner = []+      Needed outer = []+      the type signature for:+        f :: forall a. Show a => a -> String }]++As we can see, the givens say that the information about the skolem+`a_a1pa[sk:2]` fulfills the Show constraint.++The simples are:++  [[WD] __a1ph {0}:: a0_a1pd[tau:2] (CHoleCan: ExprHole(_)),+    [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)]++I.e. the hole `a0_a1pd[tau:2]` and the constraint that the type of the hole must+fulfill `Show a0_a1pd[tau:2])`.++So when we run the check, we need to make sure that the++  [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)++Constraint gets solved. When we now check for whether `x :: a0_a1pd[tau:2]` fits+the hole in `tcCheckHoleFit`, the call to `tcSubType` will end up writing the+meta type variable `a0_a1pd[tau:2] := a_a1pa[sk:2]`. By wrapping the wanted+constraints needed by tcSubType_NC and the relevant constraints (see+Note [Relevant Constraints] for more details) in the nested implications, we+can pass the information in the givens along to the simplifier. For our example,+we end up needing to check whether the following constraints are soluble.++  WC {wc_impl =+        Implic {+          TcLevel = 2+          Skolems = a_a1pa[sk:2]+          No-eqs = True+          Status = Unsolved+          Given = $dShow_a1pc :: Show a_a1pa[sk:2]+          Wanted =+            WC {wc_simple =+                  [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical)}+          Binds = EvBindsVar<a1pl>+          Needed inner = []+          Needed outer = []+          the type signature for:+            f :: forall a. Show a => a -> String }}++But since `a0_a1pd[tau:2] := a_a1pa[sk:2]` and we have from the nested+implications that Show a_a1pa[sk:2] is a given, this is trivial, and we end up+with a final WC of WC {}, confirming x :: a0_a1pd[tau:2] as a match.++To avoid side-effects on the nested implications, we create a new EvBindsVar so+that any changes to the ev binds during a check remains localised to that check.+++Note [Valid refinement hole fits include ...]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the `-frefinement-level-hole-fits=N` flag is given, we additionally look+for "valid refinement hole fits"", i.e. valid hole fits with up to N+additional holes in them.++With `-frefinement-level-hole-fits=0` (the default), GHC will find all+identifiers 'f' (top-level or nested) that will fit in the hole.++With `-frefinement-level-hole-fits=1`, GHC will additionally find all+applications 'f _' that will fit in the hole, where 'f' is an in-scope+identifier, applied to single argument.  It will also report the type of the+needed argument (a new hole).++And similarly as the number of arguments increases++As an example, let's look at the following code:++  f :: [Integer] -> Integer+  f = _++with `-frefinement-level-hole-fits=1`, we'd get:++  Valid refinement hole fits include++    foldl1 (_ :: Integer -> Integer -> Integer)+      with foldl1 @[] @Integer+      where foldl1 :: forall (t :: * -> *).+                      Foldable t =>+                      forall a. (a -> a -> a) -> t a -> a+    foldr1 (_ :: Integer -> Integer -> Integer)+      with foldr1 @[] @Integer+      where foldr1 :: forall (t :: * -> *).+                      Foldable t =>+                      forall a. (a -> a -> a) -> t a -> a+    const (_ :: Integer)+      with const @Integer @[Integer]+      where const :: forall a b. a -> b -> a+    ($) (_ :: [Integer] -> Integer)+      with ($) @'GHC.Types.LiftedRep @[Integer] @Integer+      where ($) :: forall a b. (a -> b) -> a -> b+    fail (_ :: String)+      with fail @((->) [Integer]) @Integer+      where fail :: forall (m :: * -> *).+                    Monad m =>+                    forall a. String -> m a+    return (_ :: Integer)+      with return @((->) [Integer]) @Integer+      where return :: forall (m :: * -> *). Monad m => forall a. a -> m a+    (Some refinement hole fits suppressed;+      use -fmax-refinement-hole-fits=N or -fno-max-refinement-hole-fits)++Which are hole fits with holes in them. This allows e.g. beginners to+discover the fold functions and similar, but also allows for advanced users+to figure out the valid functions in the Free monad, e.g.++  instance Functor f => Monad (Free f) where+      Pure a >>= f = f a+      Free f >>= g = Free (fmap _a f)++Will output (with -frefinment-level-hole-fits=1):+    Found hole: _a :: Free f a -> Free f b+          Where: ‘a’, ‘b’ are rigid type variables bound by+                  the type signature for:+                    (>>=) :: forall a b. Free f a -> (a -> Free f b) -> Free f b+                  at fms.hs:25:12-14+                ‘f’ is a rigid type variable bound by+    ...+    Relevant bindings include+      g :: a -> Free f b (bound at fms.hs:27:16)+      f :: f (Free f a) (bound at fms.hs:27:10)+      (>>=) :: Free f a -> (a -> Free f b) -> Free f b+        (bound at fms.hs:25:12)+    ...+    Valid refinement hole fits include+      ...+      (=<<) (_ :: a -> Free f b)+        with (=<<) @(Free f) @a @b+        where (=<<) :: forall (m :: * -> *) a b.+                      Monad m =>+                      (a -> m b) -> m a -> m b+        (imported from ‘Prelude’ at fms.hs:5:18-22+        (and originally defined in ‘GHC.Base’))+      ...++Where `(=<<) _` is precisely the function we want (we ultimately want `>>= g`).++We find these refinement suggestions by considering hole fits that don't+fit the type of the hole, but ones that would fit if given an additional+argument. We do this by creating a new type variable with `newOpenFlexiTyVar`+(e.g. `t_a1/m[tau:1]`), and then considering hole fits of the type+`t_a1/m[tau:1] -> v` where `v` is the type of the hole.++Since the simplifier is free to unify this new type variable with any type, we+can discover any identifiers that would fit if given another identifier of a+suitable type. This is then generalized so that we can consider any number of+additional arguments by setting the `-frefinement-level-hole-fits` flag to any+number, and then considering hole fits like e.g. `foldl _ _` with two additional+arguments.++To make sure that the refinement hole fits are useful, we check that the types+of the additional holes have a concrete value and not just an invented type+variable. This eliminates suggestions such as `head (_ :: [t0 -> a]) (_ :: t0)`,+and limits the number of less than useful refinement hole fits.++Additionally, to further aid the user in their implementation, we show the+types of the holes the binding would have to be applied to in order to work.+In the free monad example above, this is demonstrated with+`(=<<) (_ :: a -> Free f b)`, which tells the user that the `(=<<)` needs to+be applied to an expression of type `a -> Free f b` in order to match.+If -XScopedTypeVariables is enabled, this hole fit can even be copied verbatim.+++Note [Relevant Constraints]+~~~~~~~~~~~~~~~~~~~++As highlighted by #14273, we need to check any relevant constraints as well+as checking for subsumption. Relevant constraints are the simple constraints+whose free unification variables are mentioned in the type of the hole.++In the simplest case, these are all non-hole constraints in the simples, such+as is the case in++  f :: String+  f = show _++Where the simples will be :++  [[WD] __a1kz {0}:: a0_a1kv[tau:1] (CHoleCan: ExprHole(_)),+    [WD] $dShow_a1kw {0}:: Show a0_a1kv[tau:1] (CNonCanonical)]++However, when there are multiple holes, we need to be more careful. As an+example, Let's take a look at the following code:++  f :: Show a => a -> String+  f x = show (_b (show _a))++Here there are two holes, `_a` and `_b`, and the simple constraints passed to+findValidHoleFits are:++  [[WD] _a_a1pi {0}:: String+                        -> a0_a1pd[tau:2] (CHoleCan: ExprHole(_b)),+    [WD] _b_a1ps {0}:: a1_a1po[tau:2] (CHoleCan: ExprHole(_a)),+    [WD] $dShow_a1pe {0}:: Show a0_a1pd[tau:2] (CNonCanonical),+    [WD] $dShow_a1pp {0}:: Show a1_a1po[tau:2] (CNonCanonical)]+++Here we have the two hole constraints for `_a` and `_b`, but also additional+constraints that these holes must fulfill. When we are looking for a match for+the hole `_a`, we filter the simple constraints to the "Relevant constraints",+by throwing out all hole constraints and any constraints which do not mention+a variable mentioned in the type of the hole. For hole `_a`, we will then+only require that the `$dShow_a1pp` constraint is solved, since that is+the only non-hole constraint that mentions any free type variables mentioned in+the hole constraint for `_a`, namely `a_a1pd[tau:2]` , and similarly for the+hole `_b` we only require that the `$dShow_a1pe` constraint is solved.++Note [Leaking errors]+~~~~~~~~~~~~~~~~~~~++When considering candidates, GHC believes that we're checking for validity in+actual source. However, As evidenced by #15321, #15007 and #15202, this can+cause bewildering error messages. The solution here is simple: if a candidate+would cause the type checker to error, it is not a valid hole fit, and thus it+is discarded.++-}+++data HoleFitDispConfig = HFDC { showWrap :: Bool+                              , showWrapVars :: Bool+                              , showType :: Bool+                              , showProv :: Bool+                              , showMatches :: Bool }++debugHoleFitDispConfig :: HoleFitDispConfig+debugHoleFitDispConfig = HFDC True True True False False+++-- We read the various -no-show-*-of-hole-fits flags+-- and set the display config accordingly.+getHoleFitDispConfig :: TcM HoleFitDispConfig+getHoleFitDispConfig+  = do { sWrap <- goptM Opt_ShowTypeAppOfHoleFits+       ; sWrapVars <- goptM Opt_ShowTypeAppVarsOfHoleFits+       ; sType <- goptM Opt_ShowTypeOfHoleFits+       ; sProv <- goptM Opt_ShowProvOfHoleFits+       ; sMatc <- goptM Opt_ShowMatchesOfHoleFits+       ; return HFDC{ showWrap = sWrap, showWrapVars = sWrapVars+                    , showProv = sProv, showType = sType+                    , showMatches = sMatc } }++-- Which sorting algorithm to use+data SortingAlg = NoSorting      -- Do not sort the fits at all+                | BySize         -- Sort them by the size of the match+                | BySubsumption  -- Sort by full subsumption+                deriving (Eq, Ord)++getSortingAlg :: TcM SortingAlg+getSortingAlg =+    do { shouldSort <- goptM Opt_SortValidHoleFits+       ; subsumSort <- goptM Opt_SortBySubsumHoleFits+       ; sizeSort <- goptM Opt_SortBySizeHoleFits+       -- We default to sizeSort unless it has been explicitly turned off+       -- or subsumption sorting has been turned on.+       ; return $ if not shouldSort+                    then NoSorting+                    else if subsumSort+                         then BySubsumption+                         else if sizeSort+                              then BySize+                              else NoSorting }+++-- | HoleFitCandidates are passed to the filter and checked whether they can be+-- made to fit.+data HoleFitCandidate = IdHFCand Id             -- An id, like locals.+                      | NameHFCand Name         -- A name, like built-in syntax.+                      | GreHFCand GlobalRdrElt  -- A global, like imported ids.+                      deriving (Eq)+instance Outputable HoleFitCandidate where+  ppr = pprHoleFitCand++pprHoleFitCand :: HoleFitCandidate -> SDoc+pprHoleFitCand (IdHFCand id) = text "Id HFC: " <> ppr id+pprHoleFitCand (NameHFCand name) = text "Name HFC: " <> ppr name+pprHoleFitCand (GreHFCand gre) = text "Gre HFC: " <> ppr gre++instance HasOccName HoleFitCandidate where+  occName hfc = case hfc of+                  IdHFCand id -> occName id+                  NameHFCand name -> occName name+                  GreHFCand gre -> occName (gre_name gre)++-- | HoleFit is the type we use for valid hole fits. It contains the+-- element that was checked, the Id of that element as found by `tcLookup`,+-- and the refinement level of the fit, which is the number of extra argument+-- holes that this fit uses (e.g. if hfRefLvl is 2, the fit is for `Id _ _`).+data HoleFit =+  HoleFit { hfId   :: Id       -- The elements id in the TcM+          , hfCand :: HoleFitCandidate  -- The candidate that was checked.+          , hfType :: TcType -- The type of the id, possibly zonked.+          , hfRefLvl :: Int  -- The number of holes in this fit.+          , hfWrap :: [TcType] -- The wrapper for the match.+          , hfMatches :: [TcType]  -- What the refinement variables got matched+                                   -- with, if anything+          , hfDoc :: Maybe HsDocString } -- Documentation of this HoleFit, if+                                         -- available.+++hfName :: HoleFit -> Name+hfName hf = case hfCand hf of+              IdHFCand id -> idName id+              NameHFCand name -> name+              GreHFCand gre -> gre_name gre++hfIsLcl :: HoleFit -> Bool+hfIsLcl hf = case hfCand hf of+               IdHFCand _    -> True+               NameHFCand _  -> False+               GreHFCand gre -> gre_lcl gre++-- We define an Eq and Ord instance to be able to build a graph.+instance Eq HoleFit where+   (==) = (==) `on` hfId++-- We compare HoleFits by their name instead of their Id, since we don't+-- want our tests to be affected by the non-determinism of `nonDetCmpVar`,+-- which is used to compare Ids. When comparing, we want HoleFits with a lower+-- refinement level to come first.+instance Ord HoleFit where+  compare a b = cmp a b+    where cmp  = if hfRefLvl a == hfRefLvl b+                 then compare `on` hfName+                 else compare `on` hfRefLvl++instance Outputable HoleFit where+    ppr = pprHoleFit debugHoleFitDispConfig++-- If enabled, we go through the fits and add any associated documentation,+-- by looking it up in the module or the environment (for local fits)+addDocs :: [HoleFit] -> TcM [HoleFit]+addDocs fits =+  do { showDocs <- goptM Opt_ShowDocsOfHoleFits+     ; if showDocs+       then do { (_, DeclDocMap lclDocs, _) <- extractDocs <$> getGblEnv+               ; mapM (upd lclDocs) fits }+       else return fits }+  where+   msg = text "TcHoleErrors addDocs"+   lookupInIface name (ModIface { mi_decl_docs = DeclDocMap dmap })+     = Map.lookup name dmap+   upd lclDocs fit =+     let name = hfName fit in+     do { doc <- if hfIsLcl fit+                 then pure (Map.lookup name lclDocs)+                 else do { mbIface <- loadInterfaceForNameMaybe msg name+                         ; return $ mbIface >>= lookupInIface name }+        ; return $ fit {hfDoc = doc} }++-- For pretty printing hole fits, we display the name and type of the fit,+-- with added '_' to represent any extra arguments in case of a non-zero+-- refinement level.+pprHoleFit :: HoleFitDispConfig -> HoleFit -> SDoc+pprHoleFit (HFDC sWrp sWrpVars sTy sProv sMs) hf = hang display 2 provenance+    where name = hfName hf+          ty = hfType hf+          matches =  hfMatches hf+          wrap = hfWrap hf+          tyApp = sep $ map ((text "@" <>) . pprParendType) wrap+          tyAppVars = sep $ punctuate comma $+              map (\(v,t) -> ppr v <+> text "~" <+> pprParendType t) $+                zip vars wrap+            where+              vars = unwrapTypeVars ty+              -- Attempts to get all the quantified type variables in a type,+              -- e.g.+              -- return :: forall (m :: * -> *) Monad m => (forall a . a) -> m a+              -- into [m, a]+              unwrapTypeVars :: Type -> [TyVar]+              unwrapTypeVars t = vars ++ case splitFunTy_maybe unforalled of+                                  Just (_, unfunned) -> unwrapTypeVars unfunned+                                  _ -> []+                where (vars, unforalled) = splitForAllTys t+          holeVs = sep $ map (parens . (text "_" <+> dcolon <+>) . ppr) matches+          holeDisp = if sMs then holeVs+                     else sep $ replicate (length matches) $ text "_"+          occDisp = pprPrefixOcc name+          tyDisp = ppWhen sTy $ dcolon <+> ppr ty+          has = not . null+          wrapDisp = ppWhen (has wrap && (sWrp || sWrpVars))+                      $ text "with" <+> if sWrp || not sTy+                                        then occDisp <+> tyApp+                                        else tyAppVars+          docs = case hfDoc hf of+                   Just d -> text "{-^" <>+                             (vcat . map text . lines . unpackHDS) d+                             <> text "-}"+                   _ -> empty+          funcInfo = ppWhen (has matches && sTy) $+                       text "where" <+> occDisp <+> tyDisp+          subDisp = occDisp <+> if has matches then holeDisp else tyDisp+          display =  subDisp $$ nest 2 (funcInfo $+$ docs $+$ wrapDisp)+          provenance = ppWhen sProv $ parens $+                case hfCand hf of+                    GreHFCand gre -> pprNameProvenance gre+                    _ -> text "bound at" <+> ppr (getSrcLoc name)++getLocalBindings :: TidyEnv -> Ct -> TcM [Id]+getLocalBindings tidy_orig ct+ = do { (env1, _) <- zonkTidyOrigin tidy_orig (ctLocOrigin loc)+      ; go env1 [] (removeBindingShadowing $ tcl_bndrs lcl_env) }+  where+    loc     = ctEvLoc (ctEvidence ct)+    lcl_env = ctLocEnv loc++    go :: TidyEnv -> [Id] -> [TcBinder] -> TcM [Id]+    go _ sofar [] = return (reverse sofar)+    go env sofar (tc_bndr : tc_bndrs) =+        case tc_bndr of+          TcIdBndr id _ -> keep_it id+          _ -> discard_it+     where+        discard_it = go env sofar tc_bndrs+        keep_it id = go env (id:sofar) tc_bndrs++++-- See Note [Valid hole fits include ...]+findValidHoleFits :: TidyEnv        -- ^ The tidy_env for zonking+                  -> [Implication]  -- ^ Enclosing implications for givens+                  -> [Ct]+                  -- ^ The  unsolved simple constraints in the implication for+                  -- the hole.+                  -> Ct -- ^ The hole constraint itself+                  -> TcM (TidyEnv, SDoc)+findValidHoleFits tidy_env implics simples ct | isExprHoleCt ct =+  do { rdr_env <- getGlobalRdrEnv+     ; lclBinds <- getLocalBindings tidy_env ct+     ; maxVSubs <- maxValidHoleFits <$> getDynFlags+     ; hfdc <- getHoleFitDispConfig+     ; sortingAlg <- getSortingAlg+     ; let findVLimit = if sortingAlg > NoSorting then Nothing else maxVSubs+     ; refLevel <- refLevelHoleFits <$> getDynFlags+     ; traceTc "findingValidHoleFitsFor { " $ ppr ct+     ; traceTc "hole_lvl is:" $ ppr hole_lvl+     ; traceTc "implics are: " $ ppr implics+     ; traceTc "simples are: " $ ppr simples+     ; traceTc "locals are: " $ ppr lclBinds+     ; let (lcl, gbl) = partition gre_lcl (globalRdrEnvElts rdr_env)+           -- We remove binding shadowings here, but only for the local level.+           -- this is so we e.g. suggest the global fmap from the Functor class+           -- even though there is a local definition as well, such as in the+           -- Free monad example.+           locals = removeBindingShadowing $+                      map IdHFCand lclBinds ++ map GreHFCand lcl+           globals = map GreHFCand gbl+           syntax = map NameHFCand builtIns+           to_check = locals ++ syntax ++ globals+     ; (searchDiscards, subs) <-+        tcFilterHoleFits findVLimit implics relevantCts (hole_ty, []) to_check+     ; (tidy_env, tidy_subs) <- zonkSubs tidy_env subs+     ; tidy_sorted_subs <- sortFits sortingAlg tidy_subs+     ; let (pVDisc, limited_subs) = possiblyDiscard maxVSubs tidy_sorted_subs+           vDiscards = pVDisc || searchDiscards+     ; subs_with_docs <- addDocs limited_subs+     ; let vMsg = ppUnless (null subs_with_docs) $+                    hang (text "Valid hole fits include") 2 $+                      vcat (map (pprHoleFit hfdc) subs_with_docs)+                        $$ ppWhen vDiscards subsDiscardMsg+     -- Refinement hole fits. See Note [Valid refinement hole fits include ...]+     ; (tidy_env, refMsg) <- if refLevel >= Just 0 then+         do { maxRSubs <- maxRefHoleFits <$> getDynFlags+            -- We can use from just, since we know that Nothing >= _ is False.+            ; let refLvls = [1..(fromJust refLevel)]+            -- We make a new refinement type for each level of refinement, where+            -- the level of refinement indicates number of additional arguments+            -- to allow.+            ; ref_tys <- mapM mkRefTy refLvls+            ; traceTc "ref_tys are" $ ppr ref_tys+            ; let findRLimit = if sortingAlg > NoSorting then Nothing+                                                         else maxRSubs+            ; refDs <- mapM (flip (tcFilterHoleFits findRLimit implics+                                     relevantCts) to_check) ref_tys+            ; (tidy_env, tidy_rsubs) <- zonkSubs tidy_env $ concatMap snd refDs+            ; tidy_sorted_rsubs <- sortFits sortingAlg tidy_rsubs+            -- For refinement substitutions we want matches+            -- like id (_ :: t), head (_ :: [t]), asTypeOf (_ :: t),+            -- and others in that vein to appear last, since these are+            -- unlikely to be the most relevant fits.+            ; (tidy_env, tidy_hole_ty) <- zonkTidyTcType tidy_env hole_ty+            ; let hasExactApp = any (tcEqType tidy_hole_ty) . hfWrap+                  (exact, not_exact) = partition hasExactApp tidy_sorted_rsubs+                  (pRDisc, exact_last_rfits) =+                    possiblyDiscard maxRSubs $ not_exact ++ exact+                  rDiscards = pRDisc || any fst refDs+            ; rsubs_with_docs <- addDocs exact_last_rfits+            ; return (tidy_env,+                ppUnless (null rsubs_with_docs) $+                  hang (text "Valid refinement hole fits include") 2 $+                  vcat (map (pprHoleFit hfdc) rsubs_with_docs)+                    $$ ppWhen rDiscards refSubsDiscardMsg) }+       else return (tidy_env, empty)+     ; traceTc "findingValidHoleFitsFor }" empty+     ; return (tidy_env, vMsg $$ refMsg) }+  where+    -- We extract the type, the tcLevel and the types free variables+    -- from from the constraint.+    hole_ty :: TcPredType+    hole_ty = ctPred ct+    hole_fvs :: FV+    hole_fvs = tyCoFVsOfType hole_ty+    hole_lvl = ctLocLevel $ ctEvLoc $ ctEvidence ct++    -- BuiltInSyntax names like (:) and []+    builtIns :: [Name]+    builtIns = filter isBuiltInSyntax knownKeyNames++    -- We make a refinement type by adding a new type variable in front+    -- of the type of t h hole, going from e.g. [Integer] -> Integer+    -- to t_a1/m[tau:1] -> [Integer] -> Integer. This allows the simplifier+    -- to unify the new type variable with any type, allowing us+    -- to suggest a "refinement hole fit", like `(foldl1 _)` instead+    -- of only concrete hole fits like `sum`.+    mkRefTy :: Int -> TcM (TcType, [TcTyVar])+    mkRefTy refLvl = (wrapWithVars &&& id) <$> newTyVars+      where newTyVars = replicateM refLvl $ setLvl <$>+                            (newOpenTypeKind >>= newFlexiTyVar)+            setLvl = flip setMetaTyVarTcLevel hole_lvl+            wrapWithVars vars = mkVisFunTys (map mkTyVarTy vars) hole_ty++    sortFits :: SortingAlg    -- How we should sort the hole fits+             -> [HoleFit]     -- The subs to sort+             -> TcM [HoleFit]+    sortFits NoSorting subs = return subs+    sortFits BySize subs+        = (++) <$> sortBySize (sort lclFits)+               <*> sortBySize (sort gblFits)+        where (lclFits, gblFits) = span hfIsLcl subs++    -- To sort by subsumption, we invoke the sortByGraph function, which+    -- builds the subsumption graph for the fits and then sorts them using a+    -- graph sort.  Since we want locals to come first anyway, we can sort+    -- them separately. The substitutions are already checked in local then+    -- global order, so we can get away with using span here.+    -- We use (<*>) to expose the parallelism, in case it becomes useful later.+    sortFits BySubsumption subs+        = (++) <$> sortByGraph (sort lclFits)+               <*> sortByGraph (sort gblFits)+        where (lclFits, gblFits) = span hfIsLcl subs++    -- See Note [Relevant Constraints]+    relevantCts :: [Ct]+    relevantCts = if isEmptyVarSet (fvVarSet hole_fvs) then []+                  else filter isRelevant simples+      where ctFreeVarSet :: Ct -> VarSet+            ctFreeVarSet = fvVarSet . tyCoFVsOfType . ctPred+            hole_fv_set = fvVarSet hole_fvs+            anyFVMentioned :: Ct -> Bool+            anyFVMentioned ct = not $ isEmptyVarSet $+                                  ctFreeVarSet ct `intersectVarSet` hole_fv_set+            -- We filter out those constraints that have no variables (since+            -- they won't be solved by finding a type for the type variable+            -- representing the hole) and also other holes, since we're not+            -- trying to find hole fits for many holes at once.+            isRelevant ct = not (isEmptyVarSet (ctFreeVarSet ct))+                            && anyFVMentioned ct+                            && not (isHoleCt ct)++    -- We zonk the hole fits so that the output aligns with the rest+    -- of the typed hole error message output.+    zonkSubs :: TidyEnv -> [HoleFit] -> TcM (TidyEnv, [HoleFit])+    zonkSubs = zonkSubs' []+      where zonkSubs' zs env [] = return (env, reverse zs)+            zonkSubs' zs env (hf:hfs) = do { (env', z) <- zonkSub env hf+                                           ; zonkSubs' (z:zs) env' hfs }+            zonkSub env hf@HoleFit{hfType = ty, hfMatches = m, hfWrap = wrp}+              = do { (env, ty') <- zonkTidyTcType env ty+                   ; (env, m') <- zonkTidyTcTypes env m+                   ; (env, wrp') <- zonkTidyTcTypes env wrp+                   ; let zFit = hf {hfType = ty', hfMatches = m', hfWrap = wrp'}+                   ; return (env, zFit ) }++    -- Based on the flags, we might possibly discard some or all the+    -- fits we've found.+    possiblyDiscard :: Maybe Int -> [HoleFit] -> (Bool, [HoleFit])+    possiblyDiscard (Just max) fits = (fits `lengthExceeds` max, take max fits)+    possiblyDiscard Nothing fits = (False, fits)++    -- Sort by size uses as a measure for relevance the sizes of the+    -- different types needed to instantiate the fit to the type of the hole.+    -- This is much quicker than sorting by subsumption, and gives reasonable+    -- results in most cases.+    sortBySize :: [HoleFit] -> TcM [HoleFit]+    sortBySize = return . sortOn sizeOfFit+      where sizeOfFit :: HoleFit -> TypeSize+            sizeOfFit = sizeTypes . nubBy tcEqType .  hfWrap++    -- Based on a suggestion by phadej on #ghc, we can sort the found fits+    -- by constructing a subsumption graph, and then do a topological sort of+    -- the graph. This makes the most specific types appear first, which are+    -- probably those most relevant. This takes a lot of work (but results in+    -- much more useful output), and can be disabled by+    -- '-fno-sort-valid-hole-fits'.+    sortByGraph :: [HoleFit] -> TcM [HoleFit]+    sortByGraph fits = go [] fits+      where tcSubsumesWCloning :: TcType -> TcType -> TcM Bool+            tcSubsumesWCloning ht ty = withoutUnification fvs (tcSubsumes ht ty)+              where fvs = tyCoFVsOfTypes [ht,ty]+            go :: [(HoleFit, [HoleFit])] -> [HoleFit] -> TcM [HoleFit]+            go sofar [] = do { traceTc "subsumptionGraph was" $ ppr sofar+                             ; return $ uncurry (++)+                                         $ partition hfIsLcl topSorted }+              where toV (hf, adjs) = (hf, hfId hf, map hfId adjs)+                    (graph, fromV, _) = graphFromEdges $ map toV sofar+                    topSorted = map ((\(h,_,_) -> h) . fromV) $ topSort graph+            go sofar (hf:hfs) =+              do { adjs <-+                     filterM (tcSubsumesWCloning (hfType hf) . hfType) fits+                 ; go ((hf, adjs):sofar) hfs }++-- We don't (as of yet) handle holes in types, only in expressions.+findValidHoleFits env _ _ _ = return (env, empty)+++-- | tcFilterHoleFits filters the candidates by whether, given the implications+-- and the relevant constraints, they can be made to match the type by+-- running the type checker. Stops after finding limit matches.+tcFilterHoleFits :: Maybe Int+               -- ^ How many we should output, if limited+               -> [Implication]+               -- ^ Enclosing implications for givens+               -> [Ct]+               -- ^ Any relevant unsolved simple constraints+               -> (TcType, [TcTyVar])+               -- ^ The type to check for fits and a list of refinement+               -- variables (free type variables in the type) for emulating+               -- additional holes.+               -> [HoleFitCandidate]+               -- ^ The candidates to check whether fit.+               -> TcM (Bool, [HoleFit])+               -- ^ We return whether or not we stopped due to hitting the limit+               -- and the fits we found.+tcFilterHoleFits (Just 0) _ _ _ _ = return (False, []) -- Stop right away on 0+tcFilterHoleFits limit implics relevantCts ht@(hole_ty, _) candidates =+  do { traceTc "checkingFitsFor {" $ ppr hole_ty+     ; (discards, subs) <- go [] emptyVarSet limit ht candidates+     ; traceTc "checkingFitsFor }" empty+     ; return (discards, subs) }+  where+    hole_fvs :: FV+    hole_fvs = tyCoFVsOfType hole_ty+    -- Kickoff the checking of the elements.+    -- We iterate over the elements, checking each one in turn for whether+    -- it fits, and adding it to the results if it does.+    go :: [HoleFit]           -- What we've found so far.+       -> VarSet              -- Ids we've already checked+       -> Maybe Int           -- How many we're allowed to find, if limited+       -> (TcType, [TcTyVar]) -- The type, and its refinement variables.+       -> [HoleFitCandidate]  -- The elements we've yet to check.+       -> TcM (Bool, [HoleFit])+    go subs _ _ _ [] = return (False, reverse subs)+    go subs _ (Just 0) _ _ = return (True, reverse subs)+    go subs seen maxleft ty (el:elts) =+        -- See Note [Leaking errors]+        tryTcDiscardingErrs discard_it $+        do { traceTc "lookingUp" $ ppr el+           ; maybeThing <- lookup el+           ; case maybeThing of+               Just id | not_trivial id ->+                       do { fits <- fitsHole ty (idType id)+                          ; case fits of+                              Just (wrp, matches) -> keep_it id wrp matches+                              _ -> discard_it }+               _ -> discard_it }+        where+          -- We want to filter out undefined and the likes from GHC.Err+          not_trivial id = nameModule_maybe (idName id) /= Just gHC_ERR++          lookup :: HoleFitCandidate -> TcM (Maybe Id)+          lookup (IdHFCand id) = return (Just id)+          lookup hfc = do { thing <- tcLookup name+                          ; return $ case thing of+                                       ATcId {tct_id = id} -> Just id+                                       AGlobal (AnId id)   -> Just id+                                       AGlobal (AConLike (RealDataCon con)) ->+                                           Just (dataConWrapId con)+                                       _ -> Nothing }+            where name = case hfc of+                           IdHFCand id -> idName id+                           GreHFCand gre -> gre_name gre+                           NameHFCand name -> name+          discard_it = go subs seen maxleft ty elts+          keep_it eid wrp ms = go (fit:subs) (extendVarSet seen eid)+                                 ((\n -> n - 1) <$> maxleft) ty elts+            where+              fit = HoleFit { hfId = eid, hfCand = el, hfType = (idType eid)+                            , hfRefLvl = length (snd ty)+                            , hfWrap = wrp, hfMatches = ms+                            , hfDoc = Nothing }+++++    unfoldWrapper :: HsWrapper -> [Type]+    unfoldWrapper = reverse . unfWrp'+      where unfWrp' (WpTyApp ty) = [ty]+            unfWrp' (WpCompose w1 w2) = unfWrp' w1 ++ unfWrp' w2+            unfWrp' _ = []+++    -- The real work happens here, where we invoke the type checker using+    -- tcCheckHoleFit to see whether the given type fits the hole.+    fitsHole :: (TcType, [TcTyVar]) -- The type of the hole wrapped with the+                                    -- refinement variables created to simulate+                                    -- additional holes (if any), and the list+                                    -- of those variables (possibly empty).+                                    -- As an example: If the actual type of the+                                    -- hole (as specified by the hole+                                    -- constraint CHoleExpr passed to+                                    -- findValidHoleFits) is t and we want to+                                    -- simulate N additional holes, h_ty will+                                    -- be  r_1 -> ... -> r_N -> t, and+                                    -- ref_vars will be [r_1, ... , r_N].+                                    -- In the base case with no additional+                                    -- holes, h_ty will just be t and ref_vars+                                    -- will be [].+             -> TcType -- The type we're checking to whether it can be+                       -- instantiated to the type h_ty.+             -> TcM (Maybe ([TcType], [TcType])) -- If it is not a match, we+                                                 -- return Nothing. Otherwise,+                                                 -- we Just return the list of+                                                 -- types that quantified type+                                                 -- variables in ty would take+                                                 -- if used in place of h_ty,+                                                 -- and the list types of any+                                                 -- additional holes simulated+                                                 -- with the refinement+                                                 -- variables in ref_vars.+    fitsHole (h_ty, ref_vars) ty =+    -- We wrap this with the withoutUnification to avoid having side-effects+    -- beyond the check, but we rely on the side-effects when looking for+    -- refinement hole fits, so we can't wrap the side-effects deeper than this.+      withoutUnification fvs $+      do { traceTc "checkingFitOf {" $ ppr ty+         ; (fits, wrp) <- tcCheckHoleFit (listToBag relevantCts) implics h_ty ty+         ; traceTc "Did it fit?" $ ppr fits+         ; traceTc "wrap is: " $ ppr wrp+         ; traceTc "checkingFitOf }" empty+         ; z_wrp_tys <- zonkTcTypes (unfoldWrapper wrp)+         -- We'd like to avoid refinement suggestions like `id _ _` or+         -- `head _ _`, and only suggest refinements where our all phantom+         -- variables got unified during the checking. This can be disabled+         -- with the `-fabstract-refinement-hole-fits` flag.+         -- Here we do the additional handling when there are refinement+         -- variables, i.e. zonk them to read their final value to check for+         -- abstract refinements, and to report what the type of the simulated+         -- holes must be for this to be a match.+         ; if fits+           then if null ref_vars+                then return (Just (z_wrp_tys, []))+                else do { let -- To be concrete matches, matches have to+                              -- be more than just an invented type variable.+                              fvSet = fvVarSet fvs+                              notAbstract :: TcType -> Bool+                              notAbstract t = case getTyVar_maybe t of+                                                Just tv -> tv `elemVarSet` fvSet+                                                _ -> True+                              allConcrete = all notAbstract z_wrp_tys+                        ; z_vars  <- zonkTcTyVars ref_vars+                        ; let z_mtvs = mapMaybe tcGetTyVar_maybe z_vars+                        ; allFilled <- not <$> anyM isFlexiTyVar z_mtvs+                        ; allowAbstract <- goptM Opt_AbstractRefHoleFits+                        ; if allowAbstract || (allFilled && allConcrete )+                          then return $ Just (z_wrp_tys, z_vars)+                          else return Nothing }+           else return Nothing }+     where fvs = mkFVs ref_vars `unionFV` hole_fvs `unionFV` tyCoFVsOfType ty+++subsDiscardMsg :: SDoc+subsDiscardMsg =+    text "(Some hole fits suppressed;" <+>+    text "use -fmax-valid-hole-fits=N" <+>+    text "or -fno-max-valid-hole-fits)"++refSubsDiscardMsg :: SDoc+refSubsDiscardMsg =+    text "(Some refinement hole fits suppressed;" <+>+    text "use -fmax-refinement-hole-fits=N" <+>+    text "or -fno-max-refinement-hole-fits)"+++-- | Checks whether a MetaTyVar is flexible or not.+isFlexiTyVar :: TcTyVar -> TcM Bool+isFlexiTyVar tv | isMetaTyVar tv = isFlexi <$> readMetaTyVar tv+isFlexiTyVar _ = return False++-- | Takes a list of free variables and restores any Flexi type variables in+-- free_vars after the action is run.+withoutUnification :: FV -> TcM a -> TcM a+withoutUnification free_vars action =+  do { flexis <- filterM isFlexiTyVar fuvs+     ; result <- action+          -- Reset any mutated free variables+     ; mapM_ restore flexis+     ; return result }+  where restore = flip writeTcRef Flexi . metaTyVarRef+        fuvs = fvVarList free_vars++-- | Reports whether first type (ty_a) subsumes the second type (ty_b),+-- discarding any errors. Subsumption here means that the ty_b can fit into the+-- ty_a, i.e. `tcSubsumes a b == True` if b is a subtype of a.+tcSubsumes :: TcSigmaType -> TcSigmaType -> TcM Bool+tcSubsumes ty_a ty_b = fst <$> tcCheckHoleFit emptyBag [] ty_a ty_b+++-- | A tcSubsumes which takes into account relevant constraints, to fix trac+-- #14273. This makes sure that when checking whether a type fits the hole,+-- the type has to be subsumed by type of the hole as well as fulfill all+-- constraints on the type of the hole.+-- Note: The simplifier may perform unification, so make sure to restore any+-- free type variables to avoid side-effects.+tcCheckHoleFit :: Cts                   -- ^  Any relevant Cts to the hole.+               -> [Implication]+               -- ^ The nested implications of the hole with the innermost+               -- implication first.+               -> TcSigmaType           -- ^ The type of the hole.+               -> TcSigmaType           -- ^ The type to check whether fits.+               -> TcM (Bool, HsWrapper)+               -- ^ Whether it was a match, and the wrapper from hole_ty to ty.+tcCheckHoleFit _ _ hole_ty ty | hole_ty `eqType` ty+    = return (True, idHsWrapper)+tcCheckHoleFit relevantCts implics hole_ty ty = discardErrs $+  do { -- We wrap the subtype constraint in the implications to pass along the+       -- givens, and so we must ensure that any nested implications and skolems+       -- end up with the correct level. The implications are ordered so that+       -- the innermost (the one with the highest level) is first, so it+       -- suffices to get the level of the first one (or the current level, if+       -- there are no implications involved).+       innermost_lvl <- case implics of+                          [] -> getTcLevel+                          -- imp is the innermost implication+                          (imp:_) -> return (ic_tclvl imp)+     ; (wrp, wanted) <- setTcLevel innermost_lvl $ captureConstraints $+                          tcSubType_NC ExprSigCtxt ty hole_ty+     ; traceTc "Checking hole fit {" empty+     ; traceTc "wanteds are: " $ ppr wanted+     ; if isEmptyWC wanted && isEmptyBag relevantCts+       then traceTc "}" empty >> return (True, wrp)+       else do { fresh_binds <- newTcEvBinds+                -- The relevant constraints may contain HoleDests, so we must+                -- take care to clone them as well (to avoid #15370).+               ; cloned_relevants <- mapBagM cloneWanted relevantCts+                 -- We wrap the WC in the nested implications, see+                 -- Note [Nested Implications]+               ; let outermost_first = reverse implics+                     setWC = setWCAndBinds fresh_binds+                    -- We add the cloned relevants to the wanteds generated by+                    -- the call to tcSubType_NC, see Note [Relevant Constraints]+                    -- There's no need to clone the wanteds, because they are+                    -- freshly generated by `tcSubtype_NC`.+                     w_rel_cts = addSimples wanted cloned_relevants+                     w_givens = foldr setWC w_rel_cts outermost_first+               ; traceTc "w_givens are: " $ ppr w_givens+               ; rem <- runTcSDeriveds $ simpl_top w_givens+               -- We don't want any insoluble or simple constraints left, but+               -- solved implications are ok (and neccessary for e.g. undefined)+               ; traceTc "rems was:" $ ppr rem+               ; traceTc "}" empty+               ; return (isSolvedWC rem, wrp) } }+     where+       setWCAndBinds :: EvBindsVar         -- Fresh ev binds var.+                     -> Implication        -- The implication to put WC in.+                     -> WantedConstraints  -- The WC constraints to put implic.+                     -> WantedConstraints  -- The new constraints.+       setWCAndBinds binds imp wc+         = WC { wc_simple = emptyBag+              , wc_impl = unitBag $ imp { ic_wanted = wc , ic_binds = binds } }
+ compiler/typecheck/TcHoleErrors.hs-boot view
@@ -0,0 +1,12 @@+-- This boot file is in place to break the loop where:+-- + TcSimplify calls 'TcErrors.reportUnsolved',+-- + which calls 'TcHoleErrors.findValidHoleFits`+-- + which calls 'TcSimplify.simpl_top'+module TcHoleErrors where++import TcRnTypes  ( TcM, Ct, Implication )+import Outputable ( SDoc )+import VarEnv     ( TidyEnv )++findValidHoleFits :: TidyEnv -> [Implication] -> [Ct] -> Ct+                  -> TcM (TidyEnv, SDoc)
+ compiler/typecheck/TcHsSyn.hs view
@@ -0,0 +1,1954 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1996-1998+++TcHsSyn: Specialisations of the @HsSyn@ syntax for the typechecker++This module is an extension of @HsSyn@ syntax, for use in the type+checker.+-}++{-# LANGUAGE CPP, TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}++module TcHsSyn (+        -- * Extracting types from HsSyn+        hsLitType, hsLPatType, hsPatType,++        -- * Other HsSyn functions+        mkHsDictLet, mkHsApp,+        mkHsAppTy, mkHsCaseAlt,+        shortCutLit, hsOverLitName,+        conLikeResTy,++        -- * re-exported from TcMonad+        TcId, TcIdSet,++        -- * Zonking+        -- | For a description of "zonking", see Note [What is zonking?]+        -- in TcMType+        zonkTopDecls, zonkTopExpr, zonkTopLExpr,+        zonkTopBndrs,+        ZonkEnv, ZonkFlexi(..), emptyZonkEnv, mkEmptyZonkEnv, initZonkEnv,+        zonkTyVarBinders, zonkTyVarBindersX, zonkTyVarBinderX,+        zonkTyBndrs, zonkTyBndrsX, zonkRecTyVarBndrs,+        zonkTcTypeToType,  zonkTcTypeToTypeX,+        zonkTcTypesToTypes, zonkTcTypesToTypesX,+        zonkTyVarOcc,+        zonkCoToCo,+        zonkEvBinds, zonkTcEvBinds,+        zonkTcMethInfoToMethInfoX,+        lookupTyVarOcc+  ) where++#include "HsVersions.h"++import GhcPrelude++import HsSyn+import Id+import IdInfo+import TcRnMonad+import PrelNames+import BuildTyCl ( TcMethInfo, MethInfo )+import TcType+import TcMType+import TcEnv   ( tcLookupGlobalOnly )+import TcEvidence+import TysPrim+import TyCon+import TysWiredIn+import Type+import Coercion+import ConLike+import DataCon+import HscTypes+import Name+import NameEnv+import Var+import VarEnv+import DynFlags+import Literal+import BasicTypes+import Maybes+import SrcLoc+import Bag+import Outputable+import Util+import UniqFM+import CoreSyn++import {-# SOURCE #-} TcSplice (runTopSplice)++import Control.Monad+import Data.List  ( partition )+import Control.Arrow ( second )++{-+************************************************************************+*                                                                      *+       Extracting the type from HsSyn+*                                                                      *+************************************************************************++-}++hsLPatType :: OutPat GhcTc -> Type+hsLPatType lpat = hsPatType (unLoc lpat)++hsPatType :: Pat GhcTc -> Type+hsPatType (ParPat _ pat)                = hsLPatType pat+hsPatType (WildPat ty)                  = ty+hsPatType (VarPat _ lvar)               = idType (unLoc lvar)+hsPatType (BangPat _ pat)               = hsLPatType pat+hsPatType (LazyPat _ pat)               = hsLPatType pat+hsPatType (LitPat _ lit)                = hsLitType lit+hsPatType (AsPat _ var _)               = idType (unLoc var)+hsPatType (ViewPat ty _ _)              = ty+hsPatType (ListPat (ListPatTc ty Nothing) _)      = mkListTy ty+hsPatType (ListPat (ListPatTc _ (Just (ty,_))) _) = ty+hsPatType (TuplePat tys _ bx)           = mkTupleTy bx tys+hsPatType (SumPat tys _ _ _ )           = mkSumTy tys+hsPatType (ConPatOut { pat_con = lcon+                     , pat_arg_tys = tys })+                                        = conLikeResTy (unLoc lcon) tys+hsPatType (SigPat ty _ _)               = ty+hsPatType (NPat ty _ _ _)               = ty+hsPatType (NPlusKPat ty _ _ _ _ _)      = ty+hsPatType (CoPat _ _ _ ty)              = ty+hsPatType p                             = pprPanic "hsPatType" (ppr p)++hsLitType :: HsLit (GhcPass p) -> TcType+hsLitType (HsChar _ _)       = charTy+hsLitType (HsCharPrim _ _)   = charPrimTy+hsLitType (HsString _ _)     = stringTy+hsLitType (HsStringPrim _ _) = addrPrimTy+hsLitType (HsInt _ _)        = intTy+hsLitType (HsIntPrim _ _)    = intPrimTy+hsLitType (HsWordPrim _ _)   = wordPrimTy+hsLitType (HsInt64Prim _ _)  = int64PrimTy+hsLitType (HsWord64Prim _ _) = word64PrimTy+hsLitType (HsInteger _ _ ty) = ty+hsLitType (HsRat _ _ ty)     = ty+hsLitType (HsFloatPrim _ _)  = floatPrimTy+hsLitType (HsDoublePrim _ _) = doublePrimTy+hsLitType (XLit p)           = pprPanic "hsLitType" (ppr p)++-- Overloaded literals. Here mainly because it uses isIntTy etc++shortCutLit :: DynFlags -> OverLitVal -> TcType -> Maybe (HsExpr GhcTcId)+shortCutLit dflags (HsIntegral int@(IL src neg i)) ty+  | isIntTy ty  && inIntRange  dflags i = Just (HsLit noExt (HsInt noExt int))+  | isWordTy ty && inWordRange dflags i = Just (mkLit wordDataCon (HsWordPrim src i))+  | isIntegerTy ty = Just (HsLit noExt (HsInteger src i ty))+  | otherwise = shortCutLit dflags (HsFractional (integralFractionalLit neg i)) ty+        -- The 'otherwise' case is important+        -- Consider (3 :: Float).  Syntactically it looks like an IntLit,+        -- so we'll call shortCutIntLit, but of course it's a float+        -- This can make a big difference for programs with a lot of+        -- literals, compiled without -O++shortCutLit _ (HsFractional f) ty+  | isFloatTy ty  = Just (mkLit floatDataCon  (HsFloatPrim noExt f))+  | isDoubleTy ty = Just (mkLit doubleDataCon (HsDoublePrim noExt f))+  | otherwise     = Nothing++shortCutLit _ (HsIsString src s) ty+  | isStringTy ty = Just (HsLit noExt (HsString src s))+  | otherwise     = Nothing++mkLit :: DataCon -> HsLit GhcTc -> HsExpr GhcTc+mkLit con lit = HsApp noExt (nlHsDataCon con) (nlHsLit lit)++------------------------------+hsOverLitName :: OverLitVal -> Name+-- Get the canonical 'fromX' name for a particular OverLitVal+hsOverLitName (HsIntegral {})   = fromIntegerName+hsOverLitName (HsFractional {}) = fromRationalName+hsOverLitName (HsIsString {})   = fromStringName++{-+************************************************************************+*                                                                      *+\subsection[BackSubst-HsBinds]{Running a substitution over @HsBinds@}+*                                                                      *+************************************************************************++The rest of the zonking is done *after* typechecking.+The main zonking pass runs over the bindings++ a) to convert TcTyVars to TyVars etc, dereferencing any bindings etc+ b) convert unbound TcTyVar to Void+ c) convert each TcId to an Id by zonking its type++The type variables are converted by binding mutable tyvars to immutable ones+and then zonking as normal.++The Ids are converted by binding them in the normal Tc envt; that+way we maintain sharing; eg an Id is zonked at its binding site and they+all occurrences of that Id point to the common zonked copy++It's all pretty boring stuff, because HsSyn is such a large type, and+the environment manipulation is tiresome.+-}++-- Confused by zonking? See Note [What is zonking?] in TcMType.++-- | See Note [The ZonkEnv]+-- Confused by zonking? See Note [What is zonking?] in TcMType.+data ZonkEnv  -- See Note [The ZonkEnv]+  = ZonkEnv { ze_flexi  :: ZonkFlexi+            , ze_tv_env :: TyCoVarEnv TyCoVar+            , ze_id_env :: IdEnv      Id+            , ze_meta_tv_env :: TcRef (TyVarEnv Type) }++{- Note [The ZonkEnv]+~~~~~~~~~~~~~~~~~~~~~+* ze_flexi :: ZonkFlexi says what to do with a+  unification variable that is still un-unified.+  See Note [Un-unified unification variables]++* ze_tv_env :: TyCoVarEnv TyCoVar promotes sharing. At a binding site+  of a tyvar or covar, we zonk the kind right away and add a mapping+  to the env. This prevents re-zonking the kind at every+  occurrence. But this is *just* an optimisation.++* ze_id_env : IdEnv Id promotes sharing among Ids, by making all+  occurrences of the Id point to a single zonked copy, built at the+  binding site.++  Unlike ze_tv_env, it is knot-tied: see extendIdZonkEnvRec.+  In a mutually recusive group+     rec { f = ...g...; g = ...f... }+  we want the occurrence of g to point to the one zonked Id for g,+  and the same for f.++  Because it is knot-tied, we must be careful to consult it lazily.+  Specifically, zonkIdOcc is not monadic.++* ze_meta_tv_env: see Note [Sharing when zonking to Type]+++Notes:+  * We must be careful never to put coercion variables (which are Ids,+    after all) in the knot-tied ze_id_env, because coercions can+    appear in types, and we sometimes inspect a zonked type in this+    module.  [Question: where, precisely?]++  * In zonkTyVarOcc we consult ze_tv_env in a monadic context,+    a second reason that ze_tv_env can't be monadic.++  * An obvious suggestion would be to have one VarEnv Var to+    replace both ze_id_env and ze_tv_env, but that doesn't work+    because of the knot-tying stuff mentioned above.++Note [Un-unified unification variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What should we do if we find a Flexi unification variable?+There are three possibilities:++* DefaultFlexi: this is the common case, in situations like+     length @alpha ([] @alpha)+  It really doesn't matter what type we choose for alpha.  But+  we must choose a type!  We can't leae mutable unification+  variables floating around: after typecheck is complete, every+  type variable occurrence must have a bindign site.++  So we default it to 'Any' of the right kind.++  All this works for both type and kind variables (indeed+  the two are the same thign).++* SkolemiseFlexi: is a special case for the LHS of RULES.+  See Note [Zonking the LHS of a RULE]++* RuntimeUnkFlexi: is a special case for the GHCi debugger.+  It's a way to have a variable that is not a mutuable+  unification variable, but doesn't have a binding site+  either.+-}++data ZonkFlexi   -- See Note [Un-unified unification variables]+  = DefaultFlexi    -- Default unbound unificaiton variables to Any+  | SkolemiseFlexi  -- Skolemise unbound unification variables+                    -- See Note [Zonking the LHS of a RULE]+  | RuntimeUnkFlexi -- Used in the GHCi debugger++instance Outputable ZonkEnv where+  ppr (ZonkEnv { ze_tv_env = tv_env+               , ze_id_env = id_env })+    = text "ZE" <+> braces (vcat+         [ text "ze_tv_env =" <+> ppr tv_env+         , text "ze_id_env =" <+> ppr id_env ])++-- The EvBinds have to already be zonked, but that's usually the case.+emptyZonkEnv :: TcM ZonkEnv+emptyZonkEnv = mkEmptyZonkEnv DefaultFlexi++mkEmptyZonkEnv :: ZonkFlexi -> TcM ZonkEnv+mkEmptyZonkEnv flexi+  = do { mtv_env_ref <- newTcRef emptyVarEnv+       ; return (ZonkEnv { ze_flexi = flexi+                         , ze_tv_env = emptyVarEnv+                         , ze_id_env = emptyVarEnv+                         , ze_meta_tv_env = mtv_env_ref }) }++initZonkEnv :: (ZonkEnv -> TcM b) -> TcM b+initZonkEnv thing_inside = do { ze <- mkEmptyZonkEnv DefaultFlexi+                              ; thing_inside ze }++-- | Extend the knot-tied environment.+extendIdZonkEnvRec :: ZonkEnv -> [Var] -> ZonkEnv+extendIdZonkEnvRec ze@(ZonkEnv { ze_id_env = id_env }) ids+    -- NB: Don't look at the var to decide which env't to put it in. That+    -- would end up knot-tying all the env'ts.+  = ze { ze_id_env = extendVarEnvList id_env [(id,id) | id <- ids] }+  -- Given coercion variables will actually end up here. That's OK though:+  -- coercion variables are never looked up in the knot-tied env't, so zonking+  -- them simply doesn't get optimised. No one gets hurt. An improvement (?)+  -- would be to do SCC analysis in zonkEvBinds and then only knot-tie the+  -- recursive groups. But perhaps the time it takes to do the analysis is+  -- more than the savings.++extendZonkEnv :: ZonkEnv -> [Var] -> ZonkEnv+extendZonkEnv ze@(ZonkEnv { ze_tv_env = tyco_env, ze_id_env = id_env }) vars+  = ze { ze_tv_env = extendVarEnvList tyco_env [(tv,tv) | tv <- tycovars]+       , ze_id_env = extendVarEnvList id_env   [(id,id) | id <- ids] }+  where+    (tycovars, ids) = partition isTyCoVar vars++extendIdZonkEnv1 :: ZonkEnv -> Var -> ZonkEnv+extendIdZonkEnv1 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+  = 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 }++zonkEnvIds :: ZonkEnv -> TypeEnv+zonkEnvIds (ZonkEnv { ze_id_env = id_env})+  = mkNameEnv [(getName id, AnId id) | id <- nonDetEltsUFM id_env]+  -- It's OK to use nonDetEltsUFM here because we forget the ordering+  -- immediately by creating a TypeEnv++zonkLIdOcc :: ZonkEnv -> Located TcId -> Located Id+zonkLIdOcc env = onHasSrcSpan (zonkIdOcc env)++zonkIdOcc :: ZonkEnv -> TcId -> Id+-- Ids defined in this module should be in the envt;+-- ignore others.  (Actually, data constructors are also+-- not LocalVars, even when locally defined, but that is fine.)+-- (Also foreign-imported things aren't currently in the ZonkEnv;+--  that's ok because they don't need zonking.)+--+-- Actually, Template Haskell works in 'chunks' of declarations, and+-- an earlier chunk won't be in the 'env' that the zonking phase+-- carries around.  Instead it'll be in the tcg_gbl_env, already fully+-- zonked.  There's no point in looking it up there (except for error+-- checking), and it's not conveniently to hand; hence the simple+-- 'orElse' case in the LocalVar branch.+--+-- Even without template splices, in module Main, the checking of+-- 'main' is done as a separate chunk.+zonkIdOcc (ZonkEnv { ze_id_env = id_env}) id+  | isLocalVar id = lookupVarEnv id_env id `orElse`+                    id+  | otherwise     = id++zonkIdOccs :: ZonkEnv -> [TcId] -> [Id]+zonkIdOccs env ids = map (zonkIdOcc env) ids++-- zonkIdBndr is used *after* typechecking to get the Id's type+-- to its final form.  The TyVarEnv give+zonkIdBndr :: ZonkEnv -> TcId -> TcM Id+zonkIdBndr env v+  = do ty' <- zonkTcTypeToTypeX env (idType v)+       ensureNotLevPoly ty'+         (text "In the type of binder" <+> quotes (ppr v))++       return (modifyIdInfo (`setLevityInfoWithType` ty') (setIdType v ty'))++zonkIdBndrs :: ZonkEnv -> [TcId] -> TcM [Id]+zonkIdBndrs env ids = mapM (zonkIdBndr env) ids++zonkTopBndrs :: [TcId] -> TcM [Id]+zonkTopBndrs ids = initZonkEnv $ \ ze -> zonkIdBndrs ze ids++zonkFieldOcc :: ZonkEnv -> FieldOcc GhcTcId -> TcM (FieldOcc GhcTc)+zonkFieldOcc env (FieldOcc sel lbl)+  = fmap ((flip FieldOcc) lbl) $ zonkIdBndr env sel+zonkFieldOcc _ (XFieldOcc _) = panic "zonkFieldOcc"++zonkEvBndrsX :: ZonkEnv -> [EvVar] -> TcM (ZonkEnv, [Var])+zonkEvBndrsX = mapAccumLM zonkEvBndrX++zonkEvBndrX :: ZonkEnv -> EvVar -> TcM (ZonkEnv, EvVar)+-- Works for dictionaries and coercions+zonkEvBndrX env var+  = do { var' <- zonkEvBndr env var+       ; return (extendZonkEnv env [var'], var') }++zonkEvBndr :: ZonkEnv -> EvVar -> TcM EvVar+-- Works for dictionaries and coercions+-- Does not extend the ZonkEnv+zonkEvBndr env var+  = do { let var_ty = varType var+       ; ty <-+           {-# SCC "zonkEvBndr_zonkTcTypeToType" #-}+           zonkTcTypeToTypeX env var_ty+       ; return (setVarType var ty) }++{-+zonkEvVarOcc :: ZonkEnv -> EvVar -> TcM EvTerm+zonkEvVarOcc env v+  | isCoVar v+  = EvCoercion <$> zonkCoVarOcc env v+  | otherwise+  = return (EvId $ zonkIdOcc env v)+-}++zonkCoreBndrX :: ZonkEnv -> Var -> TcM (ZonkEnv, Var)+zonkCoreBndrX env v+  | isId v = do { v' <- zonkIdBndr env v+                ; return (extendIdZonkEnv1 env v', v') }+  | otherwise = zonkTyBndrX env v++zonkCoreBndrsX :: ZonkEnv -> [Var] -> TcM (ZonkEnv, [Var])+zonkCoreBndrsX = mapAccumLM zonkCoreBndrX++zonkTyBndrs :: [TcTyVar] -> TcM (ZonkEnv, [TyVar])+zonkTyBndrs tvs = initZonkEnv $ \ze -> zonkTyBndrsX ze tvs++zonkTyBndrsX :: ZonkEnv -> [TcTyVar] -> TcM (ZonkEnv, [TyVar])+zonkTyBndrsX = mapAccumLM zonkTyBndrX++zonkTyBndrX :: ZonkEnv -> TcTyVar -> TcM (ZonkEnv, TyVar)+-- This guarantees to return a TyVar (not a TcTyVar)+-- then we add it to the envt, so all occurrences are replaced+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') }++zonkTyVarBinders ::  [VarBndr TcTyVar vis]+                 -> TcM (ZonkEnv, [VarBndr TyVar vis])+zonkTyVarBinders tvbs = initZonkEnv $ \ ze -> zonkTyVarBindersX ze tvbs++zonkTyVarBindersX :: ZonkEnv -> [VarBndr TcTyVar vis]+                             -> TcM (ZonkEnv, [VarBndr TyVar vis])+zonkTyVarBindersX = mapAccumLM zonkTyVarBinderX++zonkTyVarBinderX :: ZonkEnv -> VarBndr TcTyVar vis+                            -> TcM (ZonkEnv, VarBndr TyVar vis)+-- Takes a TcTyVar and guarantees to return a TyVar+zonkTyVarBinderX env (Bndr tv vis)+  = do { (env', tv') <- zonkTyBndrX env tv+       ; return (env', Bndr tv' vis) }++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++zonkTopLExpr :: LHsExpr GhcTcId -> TcM (LHsExpr GhcTc)+zonkTopLExpr e = initZonkEnv $ \ ze -> zonkLExpr ze e++zonkTopDecls :: Bag EvBind+             -> LHsBinds GhcTcId+             -> [LRuleDecl GhcTcId] -> [LTcSpecPrag]+             -> [LForeignDecl GhcTcId]+             -> TcM (TypeEnv,+                     Bag EvBind,+                     LHsBinds GhcTc,+                     [LForeignDecl GhcTc],+                     [LTcSpecPrag],+                     [LRuleDecl    GhcTc])+zonkTopDecls ev_binds binds rules imp_specs fords+  = do  { (env1, ev_binds') <- initZonkEnv $ \ ze -> zonkEvBinds ze ev_binds+        ; (env2, binds')    <- zonkRecMonoBinds env1 binds+                        -- Top level is implicitly recursive+        ; rules' <- zonkRules env2 rules+        ; specs' <- zonkLTcSpecPrags env2 imp_specs+        ; fords' <- zonkForeignExports env2 fords+        ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') }++---------------------------------------------+zonkLocalBinds :: ZonkEnv -> HsLocalBinds GhcTcId+               -> TcM (ZonkEnv, HsLocalBinds GhcTc)+zonkLocalBinds env (EmptyLocalBinds x)+  = return (env, (EmptyLocalBinds x))++zonkLocalBinds _ (HsValBinds _ (ValBinds {}))+  = panic "zonkLocalBinds" -- Not in typechecker output++zonkLocalBinds env (HsValBinds x (XValBindsLR (NValBinds binds sigs)))+  = do  { (env1, new_binds) <- go env binds+        ; return (env1, HsValBinds x (XValBindsLR (NValBinds new_binds sigs))) }+  where+    go env []+      = return (env, [])+    go env ((r,b):bs)+      = do { (env1, b')  <- zonkRecMonoBinds env b+           ; (env2, bs') <- go env1 bs+           ; return (env2, (r,b'):bs') }++zonkLocalBinds env (HsIPBinds x (IPBinds dict_binds binds )) = do+    new_binds <- mapM (wrapLocM zonk_ip_bind) binds+    let+        env1 = extendIdZonkEnvRec env+                 [ n | (dL->L _ (IPBind _ (Right n) _)) <- new_binds]+    (env2, new_dict_binds) <- zonkTcEvBinds env1 dict_binds+    return (env2, HsIPBinds x (IPBinds new_dict_binds new_binds))+  where+    zonk_ip_bind (IPBind x n e)+        = do n' <- mapIPNameTc (zonkIdBndr env) n+             e' <- zonkLExpr env e+             return (IPBind x n' e')+    zonk_ip_bind (XIPBind _) = panic "zonkLocalBinds : XCIPBind"++zonkLocalBinds _ (HsIPBinds _ (XHsIPBinds _))+  = panic "zonkLocalBinds" -- Not in typechecker output+zonkLocalBinds _ (XHsLocalBindsLR _)+  = panic "zonkLocalBinds" -- Not in typechecker output++---------------------------------------------+zonkRecMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (ZonkEnv, LHsBinds GhcTc)+zonkRecMonoBinds env binds+ = fixM (\ ~(_, new_binds) -> do+        { let env1 = extendIdZonkEnvRec env (collectHsBindsBinders new_binds)+        ; binds' <- zonkMonoBinds env1 binds+        ; return (env1, binds') })++---------------------------------------------+zonkMonoBinds :: ZonkEnv -> LHsBinds GhcTcId -> TcM (LHsBinds GhcTc)+zonkMonoBinds env binds = mapBagM (zonk_lbind env) binds++zonk_lbind :: ZonkEnv -> LHsBind GhcTcId -> TcM (LHsBind GhcTc)+zonk_lbind env = wrapLocM (zonk_bind env)++zonk_bind :: ZonkEnv -> HsBind GhcTcId -> TcM (HsBind GhcTc)+zonk_bind env bind@(PatBind { pat_lhs = pat, pat_rhs = grhss+                            , pat_ext = NPatBindTc fvs ty})+  = do  { (_env, new_pat) <- zonkPat env pat            -- Env already extended+        ; new_grhss <- zonkGRHSs env zonkLExpr grhss+        ; new_ty    <- zonkTcTypeToTypeX env ty+        ; return (bind { pat_lhs = new_pat, pat_rhs = new_grhss+                       , pat_ext = NPatBindTc fvs new_ty }) }++zonk_bind env (VarBind { var_ext = x+                       , var_id = var, var_rhs = expr, var_inline = inl })+  = do { new_var  <- zonkIdBndr env var+       ; new_expr <- zonkLExpr env expr+       ; return (VarBind { var_ext = x+                         , var_id = new_var+                         , var_rhs = new_expr+                         , var_inline = inl }) }++zonk_bind env bind@(FunBind { fun_id = (dL->L loc var)+                            , fun_matches = ms+                            , fun_co_fn = co_fn })+  = do { new_var <- zonkIdBndr env var+       ; (env1, new_co_fn) <- zonkCoFn env co_fn+       ; new_ms <- zonkMatchGroup env1 zonkLExpr ms+       ; return (bind { fun_id = cL loc new_var+                      , fun_matches = new_ms+                      , fun_co_fn = new_co_fn }) }++zonk_bind env (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs+                        , abs_ev_binds = ev_binds+                        , abs_exports = exports+                        , abs_binds = val_binds+                        , abs_sig = has_sig })+  = ASSERT( all isImmutableTyVar tyvars )+    do { (env0, new_tyvars) <- zonkTyBndrsX env tyvars+       ; (env1, new_evs) <- zonkEvBndrsX env0 evs+       ; (env2, new_ev_binds) <- zonkTcEvBinds_s env1 ev_binds+       ; (new_val_bind, new_exports) <- fixM $ \ ~(new_val_binds, _) ->+         do { let env3 = extendIdZonkEnvRec env2 $+                         collectHsBindsBinders new_val_binds+            ; new_val_binds <- mapBagM (zonk_val_bind env3) val_binds+            ; new_exports   <- mapM (zonk_export env3) exports+            ; return (new_val_binds, new_exports) }+       ; return (AbsBinds { abs_ext = noExt+                          , abs_tvs = new_tyvars, abs_ev_vars = new_evs+                          , abs_ev_binds = new_ev_binds+                          , abs_exports = new_exports, abs_binds = new_val_bind+                          , abs_sig = has_sig }) }+  where+    zonk_val_bind env lbind+      | has_sig+      , (dL->L loc bind@(FunBind { fun_id      = (dL->L mloc mono_id)+                                 , fun_matches = ms+                                 , fun_co_fn   = co_fn })) <- lbind+      = do { new_mono_id <- updateVarTypeM (zonkTcTypeToTypeX env) mono_id+                            -- Specifically /not/ zonkIdBndr; we do not+                            -- want to complain about a levity-polymorphic binder+           ; (env', new_co_fn) <- zonkCoFn env co_fn+           ; new_ms            <- zonkMatchGroup env' zonkLExpr ms+           ; return $ cL loc $+             bind { fun_id      = cL mloc new_mono_id+                  , fun_matches = new_ms+                  , fun_co_fn   = new_co_fn } }+      | otherwise+      = zonk_lbind env lbind   -- The normal case++    zonk_export env (ABE{ abe_ext = x+                        , abe_wrap = wrap+                        , abe_poly = poly_id+                        , abe_mono = mono_id+                        , abe_prags = prags })+        = do new_poly_id <- zonkIdBndr env poly_id+             (_, new_wrap) <- zonkCoFn env wrap+             new_prags <- zonkSpecPrags env prags+             return (ABE{ abe_ext = x+                        , abe_wrap = new_wrap+                        , abe_poly = new_poly_id+                        , abe_mono = zonkIdOcc env mono_id+                        , abe_prags = new_prags })+    zonk_export _ (XABExport _) = panic "zonk_bind: XABExport"++zonk_bind env (PatSynBind x bind@(PSB { psb_id = (dL->L loc id)+                                      , psb_args = details+                                      , psb_def = lpat+                                      , psb_dir = dir }))+  = do { id' <- zonkIdBndr env id+       ; (env1, lpat') <- zonkPat env lpat+       ; let details' = zonkPatSynDetails env1 details+       ; (_env2, dir') <- zonkPatSynDir env1 dir+       ; return $ PatSynBind x $+                  bind { psb_id = cL loc id'+                       , psb_args = details'+                       , psb_def = lpat'+                       , psb_dir = dir' } }++zonk_bind _ (PatSynBind _ (XPatSynBind _)) = panic "zonk_bind"+zonk_bind _ (XHsBindsLR _)                 = panic "zonk_bind"++zonkPatSynDetails :: ZonkEnv+                  -> HsPatSynDetails (Located TcId)+                  -> HsPatSynDetails (Located Id)+zonkPatSynDetails env (PrefixCon as)+  = PrefixCon (map (zonkLIdOcc env) as)+zonkPatSynDetails env (InfixCon a1 a2)+  = InfixCon (zonkLIdOcc env a1) (zonkLIdOcc env a2)+zonkPatSynDetails env (RecCon flds)+  = RecCon (map (fmap (zonkLIdOcc env)) flds)++zonkPatSynDir :: ZonkEnv -> HsPatSynDir GhcTcId+              -> TcM (ZonkEnv, HsPatSynDir GhcTc)+zonkPatSynDir env Unidirectional        = return (env, Unidirectional)+zonkPatSynDir env ImplicitBidirectional = return (env, ImplicitBidirectional)+zonkPatSynDir env (ExplicitBidirectional mg) = do+    mg' <- zonkMatchGroup env zonkLExpr mg+    return (env, ExplicitBidirectional mg')++zonkSpecPrags :: ZonkEnv -> TcSpecPrags -> TcM TcSpecPrags+zonkSpecPrags _   IsDefaultMethod = return IsDefaultMethod+zonkSpecPrags env (SpecPrags ps)  = do { ps' <- zonkLTcSpecPrags env ps+                                       ; return (SpecPrags ps') }++zonkLTcSpecPrags :: ZonkEnv -> [LTcSpecPrag] -> TcM [LTcSpecPrag]+zonkLTcSpecPrags env ps+  = mapM zonk_prag ps+  where+    zonk_prag (dL->L loc (SpecPrag id co_fn inl))+        = do { (_, co_fn') <- zonkCoFn env co_fn+             ; return (cL loc (SpecPrag (zonkIdOcc env id) co_fn' inl)) }++{-+************************************************************************+*                                                                      *+\subsection[BackSubst-Match-GRHSs]{Match and GRHSs}+*                                                                      *+************************************************************************+-}++zonkMatchGroup :: ZonkEnv+            -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))+            -> MatchGroup GhcTcId (Located (body GhcTcId))+            -> TcM (MatchGroup GhcTc (Located (body GhcTc)))+zonkMatchGroup env zBody (MG { mg_alts = (dL->L l ms)+                             , mg_ext = MatchGroupTc arg_tys res_ty+                             , mg_origin = origin })+  = do  { ms' <- mapM (zonkMatch env zBody) ms+        ; arg_tys' <- zonkTcTypesToTypesX env arg_tys+        ; res_ty'  <- zonkTcTypeToTypeX env res_ty+        ; return (MG { mg_alts = cL l ms'+                     , mg_ext = MatchGroupTc arg_tys' res_ty'+                     , mg_origin = origin }) }+zonkMatchGroup _ _ (XMatchGroup {}) = panic "zonkMatchGroup"++zonkMatch :: ZonkEnv+          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))+          -> LMatch GhcTcId (Located (body GhcTcId))+          -> TcM (LMatch GhcTc (Located (body GhcTc)))+zonkMatch env zBody (dL->L loc match@(Match { m_pats = pats+                                            , m_grhss = grhss }))+  = do  { (env1, new_pats) <- zonkPats env pats+        ; new_grhss <- zonkGRHSs env1 zBody grhss+        ; return (cL loc (match { m_pats = new_pats, m_grhss = new_grhss })) }+zonkMatch _ _ (dL->L  _ (XMatch _)) = panic "zonkMatch"+zonkMatch _ _ _ = panic "zonkMatch: Impossible Match"+                             -- due to #15884++-------------------------------------------------------------------------+zonkGRHSs :: ZonkEnv+          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))+          -> GRHSs GhcTcId (Located (body GhcTcId))+          -> TcM (GRHSs GhcTc (Located (body GhcTc)))++zonkGRHSs env zBody (GRHSs x grhss (dL->L l binds)) = do+    (new_env, new_binds) <- zonkLocalBinds env binds+    let+        zonk_grhs (GRHS xx guarded rhs)+          = do (env2, new_guarded) <- zonkStmts new_env zonkLExpr guarded+               new_rhs <- zBody env2 rhs+               return (GRHS xx new_guarded new_rhs)+        zonk_grhs (XGRHS _) = panic "zonkGRHSs"+    new_grhss <- mapM (wrapLocM zonk_grhs) grhss+    return (GRHSs x new_grhss (cL l new_binds))+zonkGRHSs _ _ (XGRHSs _) = panic "zonkGRHSs"++{-+************************************************************************+*                                                                      *+\subsection[BackSubst-HsExpr]{Running a zonkitution over a TypeCheckedExpr}+*                                                                      *+************************************************************************+-}++zonkLExprs :: ZonkEnv -> [LHsExpr GhcTcId] -> TcM [LHsExpr GhcTc]+zonkLExpr  :: ZonkEnv -> LHsExpr GhcTcId   -> TcM (LHsExpr GhcTc)+zonkExpr   :: ZonkEnv -> HsExpr GhcTcId    -> TcM (HsExpr GhcTc)++zonkLExprs env exprs = mapM (zonkLExpr env) exprs+zonkLExpr  env expr  = wrapLocM (zonkExpr env) expr++zonkExpr env (HsVar x (dL->L l id))+  = ASSERT2( isNothing (isDataConId_maybe id), ppr id )+    return (HsVar x (cL l (zonkIdOcc env id)))++zonkExpr _ e@(HsConLikeOut {}) = return e++zonkExpr _ (HsIPVar x id)+  = return (HsIPVar x id)++zonkExpr _ e@HsOverLabel{} = return e++zonkExpr env (HsLit x (HsRat e f ty))+  = do new_ty <- zonkTcTypeToTypeX env ty+       return (HsLit x (HsRat e f new_ty))++zonkExpr _ (HsLit x lit)+  = return (HsLit x lit)++zonkExpr env (HsOverLit x lit)+  = do  { lit' <- zonkOverLit env lit+        ; return (HsOverLit x lit') }++zonkExpr env (HsLam x matches)+  = do new_matches <- zonkMatchGroup env zonkLExpr matches+       return (HsLam x new_matches)++zonkExpr env (HsLamCase x matches)+  = do new_matches <- zonkMatchGroup env zonkLExpr matches+       return (HsLamCase x new_matches)++zonkExpr env (HsApp x e1 e2)+  = do new_e1 <- zonkLExpr env e1+       new_e2 <- zonkLExpr env e2+       return (HsApp x new_e1 new_e2)++zonkExpr env (HsAppType x e t)+  = do new_e <- zonkLExpr env e+       return (HsAppType x new_e t)+       -- NB: the type is an HsType; can't zonk that!++zonkExpr _ e@(HsRnBracketOut _ _ _)+  = pprPanic "zonkExpr: HsRnBracketOut" (ppr e)++zonkExpr env (HsTcBracketOut x body bs)+  = do bs' <- mapM zonk_b bs+       return (HsTcBracketOut x body bs')+  where+    zonk_b (PendingTcSplice n e) = do e' <- zonkLExpr env e+                                      return (PendingTcSplice n e')++zonkExpr env (HsSpliceE _ (HsSplicedT s)) =+  runTopSplice s >>= zonkExpr env++zonkExpr _ (HsSpliceE x s) = WARN( True, ppr s ) -- Should not happen+                           return (HsSpliceE x s)++zonkExpr env (OpApp fixity e1 op e2)+  = do new_e1 <- zonkLExpr env e1+       new_op <- zonkLExpr env op+       new_e2 <- zonkLExpr env e2+       return (OpApp fixity new_e1 new_op new_e2)++zonkExpr env (NegApp x expr op)+  = do (env', new_op) <- zonkSyntaxExpr env op+       new_expr <- zonkLExpr env' expr+       return (NegApp x new_expr new_op)++zonkExpr env (HsPar x e)+  = do new_e <- zonkLExpr env e+       return (HsPar x new_e)++zonkExpr env (SectionL x expr op)+  = do new_expr <- zonkLExpr env expr+       new_op   <- zonkLExpr env op+       return (SectionL x new_expr new_op)++zonkExpr env (SectionR x op expr)+  = do new_op   <- zonkLExpr env op+       new_expr <- zonkLExpr env expr+       return (SectionR x new_op new_expr)++zonkExpr env (ExplicitTuple x tup_args boxed)+  = do { new_tup_args <- mapM zonk_tup_arg tup_args+       ; return (ExplicitTuple x new_tup_args boxed) }+  where+    zonk_tup_arg (dL->L l (Present x e)) = do { e' <- zonkLExpr env e+                                              ; return (cL l (Present x e')) }+    zonk_tup_arg (dL->L l (Missing t)) = do { t' <- zonkTcTypeToTypeX env t+                                            ; return (cL l (Missing t')) }+    zonk_tup_arg (dL->L _ (XTupArg{})) = panic "zonkExpr.XTupArg"+    zonk_tup_arg _ = panic "zonk_tup_arg: Impossible Match"+                             -- due to #15884+++zonkExpr env (ExplicitSum args alt arity expr)+  = do new_args <- mapM (zonkTcTypeToTypeX env) args+       new_expr <- zonkLExpr env expr+       return (ExplicitSum new_args alt arity new_expr)++zonkExpr env (HsCase x expr ms)+  = do new_expr <- zonkLExpr env expr+       new_ms <- zonkMatchGroup env zonkLExpr ms+       return (HsCase x new_expr new_ms)++zonkExpr env (HsIf x Nothing e1 e2 e3)+  = do new_e1 <- zonkLExpr env e1+       new_e2 <- zonkLExpr env e2+       new_e3 <- zonkLExpr env e3+       return (HsIf x Nothing new_e1 new_e2 new_e3)++zonkExpr env (HsIf x (Just fun) e1 e2 e3)+  = do (env1, new_fun) <- zonkSyntaxExpr env fun+       new_e1 <- zonkLExpr env1 e1+       new_e2 <- zonkLExpr env1 e2+       new_e3 <- zonkLExpr env1 e3+       return (HsIf x (Just new_fun) new_e1 new_e2 new_e3)++zonkExpr env (HsMultiIf ty alts)+  = do { alts' <- mapM (wrapLocM zonk_alt) alts+       ; ty'   <- zonkTcTypeToTypeX env ty+       ; return $ HsMultiIf ty' alts' }+  where zonk_alt (GRHS x guard expr)+          = do { (env', guard') <- zonkStmts env zonkLExpr guard+               ; expr'          <- zonkLExpr env' expr+               ; return $ GRHS x guard' expr' }+        zonk_alt (XGRHS _) = panic "zonkExpr.HsMultiIf"++zonkExpr env (HsLet x (dL->L l binds) expr)+  = do (new_env, new_binds) <- zonkLocalBinds env binds+       new_expr <- zonkLExpr new_env expr+       return (HsLet x (cL l new_binds) new_expr)++zonkExpr env (HsDo ty do_or_lc (dL->L l stmts))+  = do (_, new_stmts) <- zonkStmts env zonkLExpr stmts+       new_ty <- zonkTcTypeToTypeX env ty+       return (HsDo new_ty do_or_lc (cL l new_stmts))++zonkExpr env (ExplicitList ty wit exprs)+  = do (env1, new_wit) <- zonkWit env wit+       new_ty <- zonkTcTypeToTypeX env1 ty+       new_exprs <- zonkLExprs env1 exprs+       return (ExplicitList new_ty new_wit new_exprs)+   where zonkWit env Nothing    = return (env, Nothing)+         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln++zonkExpr env expr@(RecordCon { rcon_ext = ext, rcon_flds = rbinds })+  = do  { new_con_expr <- zonkExpr env (rcon_con_expr ext)+        ; new_rbinds   <- zonkRecFields env rbinds+        ; return (expr { rcon_ext  = ext { rcon_con_expr = new_con_expr }+                       , rcon_flds = new_rbinds }) }++zonkExpr env (RecordUpd { rupd_flds = rbinds+                        , rupd_expr = expr+                        , rupd_ext = RecordUpdTc+                            { rupd_cons = cons, rupd_in_tys = in_tys+                            , rupd_out_tys = out_tys, rupd_wrap = req_wrap }})+  = do  { new_expr    <- zonkLExpr env expr+        ; new_in_tys  <- mapM (zonkTcTypeToTypeX env) in_tys+        ; new_out_tys <- mapM (zonkTcTypeToTypeX env) out_tys+        ; new_rbinds  <- zonkRecUpdFields env rbinds+        ; (_, new_recwrap) <- zonkCoFn env req_wrap+        ; return (RecordUpd { rupd_expr = new_expr, rupd_flds =  new_rbinds+                            , rupd_ext = RecordUpdTc+                                { rupd_cons = cons, rupd_in_tys = new_in_tys+                                , rupd_out_tys = new_out_tys+                                , rupd_wrap = new_recwrap }}) }++zonkExpr env (ExprWithTySig _ e ty)+  = do { e' <- zonkLExpr env e+       ; return (ExprWithTySig noExt e' ty) }++zonkExpr env (ArithSeq expr wit info)+  = do (env1, new_wit) <- zonkWit env wit+       new_expr <- zonkExpr env expr+       new_info <- zonkArithSeq env1 info+       return (ArithSeq new_expr new_wit new_info)+   where zonkWit env Nothing    = return (env, Nothing)+         zonkWit env (Just fln) = second Just <$> zonkSyntaxExpr env fln++zonkExpr env (HsSCC x src lbl expr)+  = do new_expr <- zonkLExpr env expr+       return (HsSCC x src lbl new_expr)++zonkExpr env (HsTickPragma x src info srcInfo expr)+  = do new_expr <- zonkLExpr env expr+       return (HsTickPragma x src info srcInfo new_expr)++-- hdaume: core annotations+zonkExpr env (HsCoreAnn x src lbl expr)+  = do new_expr <- zonkLExpr env expr+       return (HsCoreAnn x src lbl new_expr)++-- arrow notation extensions+zonkExpr env (HsProc x pat body)+  = do  { (env1, new_pat) <- zonkPat env pat+        ; new_body <- zonkCmdTop env1 body+        ; return (HsProc x new_pat new_body) }++-- StaticPointers extension+zonkExpr env (HsStatic fvs expr)+  = HsStatic fvs <$> zonkLExpr env expr++zonkExpr env (HsWrap x co_fn expr)+  = do (env1, new_co_fn) <- zonkCoFn env co_fn+       new_expr <- zonkExpr env1 expr+       return (HsWrap x new_co_fn new_expr)++zonkExpr _ e@(HsUnboundVar {}) = return e++zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)++-------------------------------------------------------------------------+{-+Note [Skolems in zonkSyntaxExpr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider rebindable syntax with something like++  (>>=) :: (forall x. blah) -> (forall y. blah') -> blah''++The x and y become skolems that are in scope when type-checking the+arguments to the bind. This means that we must extend the ZonkEnv with+these skolems when zonking the arguments to the bind. But the skolems+are different between the two arguments, and so we should theoretically+carry around different environments to use for the different arguments.++However, this becomes a logistical nightmare, especially in dealing with+the more exotic Stmt forms. So, we simplify by making the critical+assumption that the uniques of the skolems are different. (This assumption+is justified by the use of newUnique in TcMType.instSkolTyCoVarX.)+Now, we can safely just extend one environment.+-}++-- See Note [Skolems in zonkSyntaxExpr]+zonkSyntaxExpr :: ZonkEnv -> SyntaxExpr GhcTcId+               -> TcM (ZonkEnv, SyntaxExpr GhcTc)+zonkSyntaxExpr env (SyntaxExpr { syn_expr      = expr+                               , syn_arg_wraps = arg_wraps+                               , syn_res_wrap  = res_wrap })+  = do { (env0, res_wrap')  <- zonkCoFn env res_wrap+       ; expr'              <- zonkExpr env0 expr+       ; (env1, arg_wraps') <- mapAccumLM zonkCoFn env0 arg_wraps+       ; return (env1, SyntaxExpr { syn_expr      = expr'+                                  , syn_arg_wraps = arg_wraps'+                                  , syn_res_wrap  = res_wrap' }) }++-------------------------------------------------------------------------++zonkLCmd  :: ZonkEnv -> LHsCmd GhcTcId   -> TcM (LHsCmd GhcTc)+zonkCmd   :: ZonkEnv -> HsCmd GhcTcId    -> TcM (HsCmd GhcTc)++zonkLCmd  env cmd  = wrapLocM (zonkCmd env) cmd++zonkCmd env (HsCmdWrap x w cmd)+  = do { (env1, w') <- zonkCoFn env w+       ; cmd' <- zonkCmd env1 cmd+       ; return (HsCmdWrap x w' cmd') }+zonkCmd env (HsCmdArrApp ty e1 e2 ho rl)+  = do new_e1 <- zonkLExpr env e1+       new_e2 <- zonkLExpr env e2+       new_ty <- zonkTcTypeToTypeX env ty+       return (HsCmdArrApp new_ty new_e1 new_e2 ho rl)++zonkCmd env (HsCmdArrForm x op f fixity args)+  = do new_op <- zonkLExpr env op+       new_args <- mapM (zonkCmdTop env) args+       return (HsCmdArrForm x new_op f fixity new_args)++zonkCmd env (HsCmdApp x c e)+  = do new_c <- zonkLCmd env c+       new_e <- zonkLExpr env e+       return (HsCmdApp x new_c new_e)++zonkCmd env (HsCmdLam x matches)+  = do new_matches <- zonkMatchGroup env zonkLCmd matches+       return (HsCmdLam x new_matches)++zonkCmd env (HsCmdPar x c)+  = do new_c <- zonkLCmd env c+       return (HsCmdPar x new_c)++zonkCmd env (HsCmdCase x expr ms)+  = do new_expr <- zonkLExpr env expr+       new_ms <- zonkMatchGroup env zonkLCmd ms+       return (HsCmdCase x new_expr new_ms)++zonkCmd env (HsCmdIf x eCond ePred cThen cElse)+  = do { (env1, new_eCond) <- zonkWit env eCond+       ; new_ePred <- zonkLExpr env1 ePred+       ; new_cThen <- zonkLCmd env1 cThen+       ; new_cElse <- zonkLCmd env1 cElse+       ; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) }+  where+    zonkWit env Nothing  = return (env, Nothing)+    zonkWit env (Just w) = second Just <$> zonkSyntaxExpr env w++zonkCmd env (HsCmdLet x (dL->L l binds) cmd)+  = do (new_env, new_binds) <- zonkLocalBinds env binds+       new_cmd <- zonkLCmd new_env cmd+       return (HsCmdLet x (cL l new_binds) new_cmd)++zonkCmd env (HsCmdDo ty (dL->L l stmts))+  = do (_, new_stmts) <- zonkStmts env zonkLCmd stmts+       new_ty <- zonkTcTypeToTypeX env ty+       return (HsCmdDo new_ty (cL l new_stmts))++zonkCmd _ (XCmd{}) = panic "zonkCmd"++++zonkCmdTop :: ZonkEnv -> LHsCmdTop GhcTcId -> TcM (LHsCmdTop GhcTc)+zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd++zonk_cmd_top :: ZonkEnv -> HsCmdTop GhcTcId -> TcM (HsCmdTop GhcTc)+zonk_cmd_top env (HsCmdTop (CmdTopTc stack_tys ty ids) cmd)+  = do new_cmd <- zonkLCmd env cmd+       new_stack_tys <- zonkTcTypeToTypeX env stack_tys+       new_ty <- zonkTcTypeToTypeX env ty+       new_ids <- mapSndM (zonkExpr env) ids++       MASSERT( isLiftedTypeKind (tcTypeKind new_stack_tys) )+         -- desugarer assumes that this is not levity polymorphic...+         -- but indeed it should always be lifted due to the typing+         -- rules for arrows++       return (HsCmdTop (CmdTopTc new_stack_tys new_ty new_ids) new_cmd)+zonk_cmd_top _ (XCmdTop {}) = panic "zonk_cmd_top"++-------------------------------------------------------------------------+zonkCoFn :: ZonkEnv -> HsWrapper -> TcM (ZonkEnv, HsWrapper)+zonkCoFn env WpHole   = return (env, WpHole)+zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1+                                    ; (env2, c2') <- zonkCoFn env1 c2+                                    ; return (env2, WpCompose c1' c2') }+zonkCoFn env (WpFun c1 c2 t1 d) = do { (env1, c1') <- zonkCoFn env c1+                                     ; (env2, c2') <- zonkCoFn env1 c2+                                     ; t1'         <- zonkTcTypeToTypeX env2 t1+                                     ; return (env2, WpFun c1' c2' t1' d) }+zonkCoFn env (WpCast co) = do { co' <- zonkCoToCo env co+                              ; return (env, WpCast co') }+zonkCoFn env (WpEvLam ev)   = do { (env', ev') <- zonkEvBndrX env ev+                                 ; return (env', WpEvLam ev') }+zonkCoFn env (WpEvApp arg)  = do { arg' <- zonkEvTerm env arg+                                 ; return (env, WpEvApp arg') }+zonkCoFn env (WpTyLam tv)   = ASSERT( isImmutableTyVar tv )+                              do { (env', tv') <- zonkTyBndrX env tv+                                 ; return (env', WpTyLam tv') }+zonkCoFn env (WpTyApp ty)   = do { ty' <- zonkTcTypeToTypeX env ty+                                 ; return (env, WpTyApp ty') }+zonkCoFn env (WpLet bs)     = do { (env1, bs') <- zonkTcEvBinds env bs+                                 ; return (env1, WpLet bs') }++-------------------------------------------------------------------------+zonkOverLit :: ZonkEnv -> HsOverLit GhcTcId -> TcM (HsOverLit GhcTc)+zonkOverLit env lit@(OverLit {ol_ext = OverLitTc r ty, ol_witness = e })+  = do  { ty' <- zonkTcTypeToTypeX env ty+        ; e' <- zonkExpr env e+        ; return (lit { ol_witness = e', ol_ext = OverLitTc r ty' }) }++zonkOverLit _ XOverLit{} = panic "zonkOverLit"++-------------------------------------------------------------------------+zonkArithSeq :: ZonkEnv -> ArithSeqInfo GhcTcId -> TcM (ArithSeqInfo GhcTc)++zonkArithSeq env (From e)+  = do new_e <- zonkLExpr env e+       return (From new_e)++zonkArithSeq env (FromThen e1 e2)+  = do new_e1 <- zonkLExpr env e1+       new_e2 <- zonkLExpr env e2+       return (FromThen new_e1 new_e2)++zonkArithSeq env (FromTo e1 e2)+  = do new_e1 <- zonkLExpr env e1+       new_e2 <- zonkLExpr env e2+       return (FromTo new_e1 new_e2)++zonkArithSeq env (FromThenTo e1 e2 e3)+  = do new_e1 <- zonkLExpr env e1+       new_e2 <- zonkLExpr env e2+       new_e3 <- zonkLExpr env e3+       return (FromThenTo new_e1 new_e2 new_e3)+++-------------------------------------------------------------------------+zonkStmts :: ZonkEnv+          -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))+          -> [LStmt GhcTcId (Located (body GhcTcId))]+          -> TcM (ZonkEnv, [LStmt GhcTc (Located (body GhcTc))])+zonkStmts env _ []     = return (env, [])+zonkStmts env zBody (s:ss) = do { (env1, s')  <- wrapLocSndM (zonkStmt env zBody) s+                                ; (env2, ss') <- zonkStmts env1 zBody ss+                                ; return (env2, s' : ss') }++zonkStmt :: ZonkEnv+         -> (ZonkEnv -> Located (body GhcTcId) -> TcM (Located (body GhcTc)))+         -> Stmt GhcTcId (Located (body GhcTcId))+         -> TcM (ZonkEnv, Stmt GhcTc (Located (body GhcTc)))+zonkStmt env _ (ParStmt bind_ty stmts_w_bndrs mzip_op bind_op)+  = do { (env1, new_bind_op) <- zonkSyntaxExpr env bind_op+       ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty+       ; new_stmts_w_bndrs <- mapM (zonk_branch env1) stmts_w_bndrs+       ; let new_binders = [b | ParStmtBlock _ _ bs _ <- new_stmts_w_bndrs+                              , b <- bs]+             env2 = extendIdZonkEnvRec env1 new_binders+       ; new_mzip <- zonkExpr env2 mzip_op+       ; return (env2+                , ParStmt new_bind_ty new_stmts_w_bndrs new_mzip new_bind_op)}+  where+    zonk_branch env1 (ParStmtBlock x stmts bndrs return_op)+       = do { (env2, new_stmts)  <- zonkStmts env1 zonkLExpr stmts+            ; (env3, new_return) <- zonkSyntaxExpr env2 return_op+            ; return (ParStmtBlock x new_stmts (zonkIdOccs env3 bndrs)+                                                                   new_return) }+    zonk_branch _ (XParStmtBlock{}) = panic "zonkStmt"++zonkStmt env zBody (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs+                            , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id+                            , recS_bind_fn = bind_id+                            , recS_ext =+                                       RecStmtTc { recS_bind_ty = bind_ty+                                                 , recS_later_rets = later_rets+                                                 , recS_rec_rets = rec_rets+                                                 , recS_ret_ty = ret_ty} })+  = do { (env1, new_bind_id) <- zonkSyntaxExpr env bind_id+       ; (env2, new_mfix_id) <- zonkSyntaxExpr env1 mfix_id+       ; (env3, new_ret_id)  <- zonkSyntaxExpr env2 ret_id+       ; new_bind_ty <- zonkTcTypeToTypeX env3 bind_ty+       ; new_rvs <- zonkIdBndrs env3 rvs+       ; new_lvs <- zonkIdBndrs env3 lvs+       ; new_ret_ty  <- zonkTcTypeToTypeX env3 ret_ty+       ; let env4 = extendIdZonkEnvRec env3 new_rvs+       ; (env5, new_segStmts) <- zonkStmts env4 zBody segStmts+        -- Zonk the ret-expressions in an envt that+        -- has the polymorphic bindings in the envt+       ; new_later_rets <- mapM (zonkExpr env5) later_rets+       ; new_rec_rets <- mapM (zonkExpr env5) rec_rets+       ; return (extendIdZonkEnvRec env3 new_lvs,     -- Only the lvs are needed+                 RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs+                         , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id+                         , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id+                         , recS_ext = RecStmtTc+                             { recS_bind_ty = new_bind_ty+                             , recS_later_rets = new_later_rets+                             , recS_rec_rets = new_rec_rets+                             , recS_ret_ty = new_ret_ty } }) }++zonkStmt env zBody (BodyStmt ty body then_op guard_op)+  = do (env1, new_then_op)  <- zonkSyntaxExpr env then_op+       (env2, new_guard_op) <- zonkSyntaxExpr env1 guard_op+       new_body <- zBody env2 body+       new_ty   <- zonkTcTypeToTypeX env2 ty+       return (env2, BodyStmt new_ty new_body new_then_op new_guard_op)++zonkStmt env zBody (LastStmt x body noret ret_op)+  = do (env1, new_ret) <- zonkSyntaxExpr env ret_op+       new_body <- zBody env1 body+       return (env, LastStmt x new_body noret new_ret)++zonkStmt env _ (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap+                          , trS_by = by, trS_form = form, trS_using = using+                          , trS_ret = return_op, trS_bind = bind_op+                          , trS_ext = bind_arg_ty+                          , trS_fmap = liftM_op })+  = do {+    ; (env1, bind_op') <- zonkSyntaxExpr env bind_op+    ; bind_arg_ty' <- zonkTcTypeToTypeX env1 bind_arg_ty+    ; (env2, stmts') <- zonkStmts env1 zonkLExpr stmts+    ; by'        <- fmapMaybeM (zonkLExpr env2) by+    ; using'     <- zonkLExpr env2 using++    ; (env3, return_op') <- zonkSyntaxExpr env2 return_op+    ; binderMap' <- mapM (zonkBinderMapEntry env3) binderMap+    ; liftM_op'  <- zonkExpr env3 liftM_op+    ; let env3' = extendIdZonkEnvRec env3 (map snd binderMap')+    ; return (env3', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap'+                               , trS_by = by', trS_form = form, trS_using = using'+                               , trS_ret = return_op', trS_bind = bind_op'+                               , trS_ext = bind_arg_ty'+                               , trS_fmap = liftM_op' }) }+  where+    zonkBinderMapEntry env  (oldBinder, newBinder) = do+        let oldBinder' = zonkIdOcc env oldBinder+        newBinder' <- zonkIdBndr env newBinder+        return (oldBinder', newBinder')++zonkStmt env _ (LetStmt x (dL->L l binds))+  = do (env1, new_binds) <- zonkLocalBinds env binds+       return (env1, LetStmt x (cL l new_binds))++zonkStmt env zBody (BindStmt bind_ty pat body bind_op fail_op)+  = do  { (env1, new_bind) <- zonkSyntaxExpr env bind_op+        ; new_bind_ty <- zonkTcTypeToTypeX env1 bind_ty+        ; new_body <- zBody env1 body+        ; (env2, new_pat) <- zonkPat env1 pat+        ; (_, new_fail) <- zonkSyntaxExpr env1 fail_op+        ; return ( env2+                 , BindStmt new_bind_ty new_pat new_body new_bind new_fail) }++-- Scopes: join > ops (in reverse order) > pats (in forward order)+--              > rest of stmts+zonkStmt env _zBody (ApplicativeStmt body_ty args mb_join)+  = do  { (env1, new_mb_join)   <- zonk_join env mb_join+        ; (env2, new_args)      <- zonk_args env1 args+        ; new_body_ty           <- zonkTcTypeToTypeX env2 body_ty+        ; return (env2, ApplicativeStmt new_body_ty new_args new_mb_join) }+  where+    zonk_join env Nothing  = return (env, Nothing)+    zonk_join env (Just j) = second Just <$> zonkSyntaxExpr env j++    get_pat (_, ApplicativeArgOne _ pat _ _) = pat+    get_pat (_, ApplicativeArgMany _ _ _ pat) = pat+    get_pat (_, XApplicativeArg _) = panic "zonkStmt"++    replace_pat pat (op, ApplicativeArgOne x _ a isBody)+      = (op, ApplicativeArgOne x pat a isBody)+    replace_pat pat (op, ApplicativeArgMany x a b _)+      = (op, ApplicativeArgMany x a b pat)+    replace_pat _ (_, XApplicativeArg _) = panic "zonkStmt"++    zonk_args env args+      = do { (env1, new_args_rev) <- zonk_args_rev env (reverse args)+           ; (env2, new_pats)     <- zonkPats env1 (map get_pat args)+           ; return (env2, zipWith replace_pat new_pats (reverse new_args_rev)) }++     -- these need to go backward, because if any operators are higher-rank,+     -- later operators may introduce skolems that are in scope for earlier+     -- arguments+    zonk_args_rev env ((op, arg) : args)+      = do { (env1, new_op)         <- zonkSyntaxExpr env op+           ; new_arg                <- zonk_arg env1 arg+           ; (env2, new_args)       <- zonk_args_rev env1 args+           ; return (env2, (new_op, new_arg) : new_args) }+    zonk_args_rev env [] = return (env, [])++    zonk_arg env (ApplicativeArgOne x pat expr isBody)+      = do { new_expr <- zonkLExpr env expr+           ; return (ApplicativeArgOne x pat new_expr isBody) }+    zonk_arg env (ApplicativeArgMany x stmts ret pat)+      = do { (env1, new_stmts) <- zonkStmts env zonkLExpr stmts+           ; new_ret           <- zonkExpr env1 ret+           ; return (ApplicativeArgMany x new_stmts new_ret pat) }+    zonk_arg _ (XApplicativeArg _) = panic "zonkStmt.XApplicativeArg"++zonkStmt _ _ (XStmtLR _) = panic "zonkStmt"++-------------------------------------------------------------------------+zonkRecFields :: ZonkEnv -> HsRecordBinds GhcTcId -> TcM (HsRecordBinds GhcTcId)+zonkRecFields env (HsRecFields flds dd)+  = do  { flds' <- mapM zonk_rbind flds+        ; return (HsRecFields flds' dd) }+  where+    zonk_rbind (dL->L l fld)+      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecFieldLbl fld)+           ; new_expr <- zonkLExpr env (hsRecFieldArg fld)+           ; return (cL l (fld { hsRecFieldLbl = new_id+                              , hsRecFieldArg = new_expr })) }++zonkRecUpdFields :: ZonkEnv -> [LHsRecUpdField GhcTcId]+                 -> TcM [LHsRecUpdField GhcTcId]+zonkRecUpdFields env = mapM zonk_rbind+  where+    zonk_rbind (dL->L l fld)+      = do { new_id   <- wrapLocM (zonkFieldOcc env) (hsRecUpdFieldOcc fld)+           ; new_expr <- zonkLExpr env (hsRecFieldArg fld)+           ; return (cL l (fld { hsRecFieldLbl = fmap ambiguousFieldOcc new_id+                               , hsRecFieldArg = new_expr })) }++-------------------------------------------------------------------------+mapIPNameTc :: (a -> TcM b) -> Either (Located HsIPName) a+            -> TcM (Either (Located HsIPName) b)+mapIPNameTc _ (Left x)  = return (Left x)+mapIPNameTc f (Right x) = do r <- f x+                             return (Right r)++{-+************************************************************************+*                                                                      *+\subsection[BackSubst-Pats]{Patterns}+*                                                                      *+************************************************************************+-}++zonkPat :: ZonkEnv -> OutPat GhcTcId -> TcM (ZonkEnv, OutPat GhcTc)+-- Extend the environment as we go, because it's possible for one+-- pattern to bind something that is used in another (inside or+-- to the right)+zonkPat env pat = wrapLocSndM (zonk_pat env) pat++zonk_pat :: ZonkEnv -> Pat GhcTcId -> TcM (ZonkEnv, Pat GhcTc)+zonk_pat env (ParPat x p)+  = do  { (env', p') <- zonkPat env p+        ; return (env', ParPat x p') }++zonk_pat env (WildPat ty)+  = do  { ty' <- zonkTcTypeToTypeX env ty+        ; ensureNotLevPoly ty'+            (text "In a wildcard pattern")+        ; return (env, WildPat ty') }++zonk_pat env (VarPat x (dL->L l v))+  = do  { v' <- zonkIdBndr env v+        ; return (extendIdZonkEnv1 env v', VarPat x (cL l v')) }++zonk_pat env (LazyPat x pat)+  = do  { (env', pat') <- zonkPat env pat+        ; return (env',  LazyPat x pat') }++zonk_pat env (BangPat x pat)+  = do  { (env', pat') <- zonkPat env pat+        ; return (env',  BangPat x pat') }++zonk_pat env (AsPat x (dL->L loc v) pat)+  = do  { v' <- zonkIdBndr env v+        ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat+        ; return (env', AsPat x (cL loc v') pat') }++zonk_pat env (ViewPat ty expr pat)+  = do  { expr' <- zonkLExpr env expr+        ; (env', pat') <- zonkPat env pat+        ; ty' <- zonkTcTypeToTypeX env ty+        ; return (env', ViewPat ty' expr' pat') }++zonk_pat env (ListPat (ListPatTc ty Nothing) pats)+  = do  { ty' <- zonkTcTypeToTypeX env ty+        ; (env', pats') <- zonkPats env pats+        ; return (env', ListPat (ListPatTc ty' Nothing) pats') }++zonk_pat env (ListPat (ListPatTc ty (Just (ty2,wit))) pats)+  = do  { (env', wit') <- zonkSyntaxExpr env wit+        ; ty2' <- zonkTcTypeToTypeX env' ty2+        ; ty' <- zonkTcTypeToTypeX env' ty+        ; (env'', pats') <- zonkPats env' pats+        ; return (env'', ListPat (ListPatTc ty' (Just (ty2',wit'))) pats') }++zonk_pat env (TuplePat tys pats boxed)+  = do  { tys' <- mapM (zonkTcTypeToTypeX env) tys+        ; (env', pats') <- zonkPats env pats+        ; return (env', TuplePat tys' pats' boxed) }++zonk_pat env (SumPat tys pat alt arity )+  = do  { tys' <- mapM (zonkTcTypeToTypeX env) tys+        ; (env', pat') <- zonkPat env pat+        ; return (env', SumPat tys' pat' alt arity) }++zonk_pat env p@(ConPatOut { pat_arg_tys = tys+                          , pat_tvs = tyvars+                          , pat_dicts = evs+                          , pat_binds = binds+                          , pat_args = args+                          , pat_wrap = wrapper+                          , pat_con = (dL->L _ con) })+  = ASSERT( all isImmutableTyVar tyvars )+    do  { new_tys <- mapM (zonkTcTypeToTypeX env) tys++          -- an unboxed tuple pattern (but only an unboxed tuple pattern)+          -- might have levity-polymorphic arguments. Check for this badness.+        ; case con of+            RealDataCon dc+              | isUnboxedTupleTyCon (dataConTyCon dc)+              -> mapM_ (checkForLevPoly doc) (dropRuntimeRepArgs new_tys)+            _ -> return ()++        ; (env0, new_tyvars) <- zonkTyBndrsX env tyvars+          -- Must zonk the existential variables, because their+          -- /kind/ need potential zonking.+          -- cf typecheck/should_compile/tc221.hs+        ; (env1, new_evs) <- zonkEvBndrsX env0 evs+        ; (env2, new_binds) <- zonkTcEvBinds env1 binds+        ; (env3, new_wrapper) <- zonkCoFn env2 wrapper+        ; (env', new_args) <- zonkConStuff env3 args+        ; return (env', p { pat_arg_tys = new_tys,+                            pat_tvs = new_tyvars,+                            pat_dicts = new_evs,+                            pat_binds = new_binds,+                            pat_args = new_args,+                            pat_wrap = new_wrapper}) }+  where+    doc = text "In the type of an element of an unboxed tuple pattern:" $$ ppr p++zonk_pat env (LitPat x lit) = return (env, LitPat x lit)++zonk_pat env (SigPat ty pat hs_ty)+  = do  { ty' <- zonkTcTypeToTypeX env ty+        ; (env', pat') <- zonkPat env pat+        ; return (env', SigPat ty' pat' hs_ty) }++zonk_pat env (NPat ty (dL->L l lit) mb_neg eq_expr)+  = do  { (env1, eq_expr') <- zonkSyntaxExpr env eq_expr+        ; (env2, mb_neg') <- case mb_neg of+            Nothing -> return (env1, Nothing)+            Just n  -> second Just <$> zonkSyntaxExpr env1 n++        ; lit' <- zonkOverLit env2 lit+        ; ty' <- zonkTcTypeToTypeX env2 ty+        ; return (env2, NPat ty' (cL l lit') mb_neg' eq_expr') }++zonk_pat env (NPlusKPat ty (dL->L loc n) (dL->L l lit1) lit2 e1 e2)+  = do  { (env1, e1') <- zonkSyntaxExpr env  e1+        ; (env2, e2') <- zonkSyntaxExpr env1 e2+        ; n' <- zonkIdBndr env2 n+        ; lit1' <- zonkOverLit env2 lit1+        ; lit2' <- zonkOverLit env2 lit2+        ; ty' <- zonkTcTypeToTypeX env2 ty+        ; return (extendIdZonkEnv1 env2 n',+                  NPlusKPat ty' (cL loc n') (cL l lit1') lit2' e1' e2') }++zonk_pat env (CoPat x co_fn pat ty)+  = do { (env', co_fn') <- zonkCoFn env co_fn+       ; (env'', pat') <- zonkPat env' (noLoc pat)+       ; ty' <- zonkTcTypeToTypeX env'' ty+       ; return (env'', CoPat x co_fn' (unLoc pat') ty') }++zonk_pat _ pat = pprPanic "zonk_pat" (ppr pat)++---------------------------+zonkConStuff :: ZonkEnv+             -> HsConDetails (OutPat GhcTcId) (HsRecFields id (OutPat GhcTcId))+             -> TcM (ZonkEnv,+                    HsConDetails (OutPat GhcTc) (HsRecFields id (OutPat GhcTc)))+zonkConStuff env (PrefixCon pats)+  = do  { (env', pats') <- zonkPats env pats+        ; return (env', PrefixCon pats') }++zonkConStuff env (InfixCon p1 p2)+  = do  { (env1, p1') <- zonkPat env  p1+        ; (env', p2') <- zonkPat env1 p2+        ; return (env', InfixCon p1' p2') }++zonkConStuff env (RecCon (HsRecFields rpats dd))+  = do  { (env', pats') <- zonkPats env (map (hsRecFieldArg . unLoc) rpats)+        ; let rpats' = zipWith (\(dL->L l rp) p' ->+                                  cL l (rp { hsRecFieldArg = p' }))+                               rpats pats'+        ; return (env', RecCon (HsRecFields rpats' dd)) }+        -- Field selectors have declared types; hence no zonking++---------------------------+zonkPats :: ZonkEnv -> [OutPat GhcTcId] -> TcM (ZonkEnv, [OutPat GhcTc])+zonkPats env []         = return (env, [])+zonkPats env (pat:pats) = do { (env1, pat') <- zonkPat env pat+                             ; (env', pats') <- zonkPats env1 pats+                             ; return (env', pat':pats') }++{-+************************************************************************+*                                                                      *+\subsection[BackSubst-Foreign]{Foreign exports}+*                                                                      *+************************************************************************+-}++zonkForeignExports :: ZonkEnv -> [LForeignDecl GhcTcId]+                   -> TcM [LForeignDecl GhcTc]+zonkForeignExports env ls = mapM (wrapLocM (zonkForeignExport env)) ls++zonkForeignExport :: ZonkEnv -> ForeignDecl GhcTcId -> TcM (ForeignDecl GhcTc)+zonkForeignExport env (ForeignExport { fd_name = i, fd_e_ext = co+                                     , fd_fe = spec })+  = return (ForeignExport { fd_name = zonkLIdOcc env i+                          , fd_sig_ty = undefined, fd_e_ext = co+                          , fd_fe = spec })+zonkForeignExport _ for_imp+  = return for_imp     -- Foreign imports don't need zonking++zonkRules :: ZonkEnv -> [LRuleDecl GhcTcId] -> TcM [LRuleDecl GhcTc]+zonkRules env rs = mapM (wrapLocM (zonkRule env)) rs++zonkRule :: ZonkEnv -> RuleDecl GhcTcId -> TcM (RuleDecl GhcTc)+zonkRule env rule@(HsRule { rd_tmvs = tm_bndrs{-::[RuleBndr TcId]-}+                          , rd_lhs = lhs+                          , rd_rhs = rhs })+  = do { (env_inside, new_tm_bndrs) <- mapAccumLM zonk_tm_bndr env tm_bndrs++       ; let env_lhs = setZonkType env_inside SkolemiseFlexi+              -- See Note [Zonking the LHS of a RULE]++       ; new_lhs <- zonkLExpr env_lhs    lhs+       ; new_rhs <- zonkLExpr env_inside rhs++       ; return $ rule { rd_tmvs = new_tm_bndrs+                       , rd_lhs  = new_lhs+                       , rd_rhs  = new_rhs } }+  where+   zonk_tm_bndr env (dL->L l (RuleBndr x (dL->L loc v)))+      = do { (env', v') <- zonk_it env v+           ; return (env', cL l (RuleBndr x (cL loc v'))) }+   zonk_tm_bndr _ (dL->L _ (RuleBndrSig {})) = panic "zonk_tm_bndr RuleBndrSig"+   zonk_tm_bndr _ (dL->L _ (XRuleBndr {})) = panic "zonk_tm_bndr XRuleBndr"+   zonk_tm_bndr _ _ = panic "zonk_tm_bndr: Impossible Match"+                            -- due to #15884++   zonk_it env v+     | isId v     = do { v' <- zonkIdBndr env v+                       ; return (extendIdZonkEnvRec env [v'], v') }+     | otherwise  = ASSERT( isImmutableTyVar v)+                    zonkTyBndrX env v+                    -- DV: used to be return (env,v) but that is plain+                    -- wrong because we may need to go inside the kind+                    -- of v and zonk there!+zonkRule _ (XRuleDecl _) = panic "zonkRule"++{-+************************************************************************+*                                                                      *+              Constraints and evidence+*                                                                      *+************************************************************************+-}++zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm+zonkEvTerm env (EvExpr e)+  = EvExpr <$> zonkCoreExpr env e+zonkEvTerm env (EvTypeable ty ev)+  = EvTypeable <$> zonkTcTypeToTypeX env ty <*> zonkEvTypeable env ev+zonkEvTerm env (EvFun { et_tvs = tvs, et_given = evs+                      , et_binds = ev_binds, et_body = body_id })+  = do { (env0, new_tvs) <- zonkTyBndrsX env tvs+       ; (env1, new_evs) <- zonkEvBndrsX env0 evs+       ; (env2, new_ev_binds) <- zonkTcEvBinds env1 ev_binds+       ; let new_body_id = zonkIdOcc env2 body_id+       ; return (EvFun { et_tvs = new_tvs, et_given = new_evs+                       , et_binds = new_ev_binds, et_body = new_body_id }) }++zonkCoreExpr :: ZonkEnv -> CoreExpr -> TcM CoreExpr+zonkCoreExpr env (Var v)+    | isCoVar v+    = Coercion <$> zonkCoVarOcc env v+    | otherwise+    = return (Var $ zonkIdOcc env v)+zonkCoreExpr _ (Lit l)+    = return $ Lit l+zonkCoreExpr env (Coercion co)+    = Coercion <$> zonkCoToCo env co+zonkCoreExpr env (Type ty)+    = Type <$> zonkTcTypeToTypeX env ty++zonkCoreExpr env (Cast e co)+    = Cast <$> zonkCoreExpr env e <*> zonkCoToCo env co+zonkCoreExpr env (Tick t e)+    = Tick t <$> zonkCoreExpr env e -- Do we need to zonk in ticks?++zonkCoreExpr env (App e1 e2)+    = App <$> zonkCoreExpr env e1 <*> zonkCoreExpr env e2+zonkCoreExpr env (Lam v e)+    = do { (env1, v') <- zonkCoreBndrX env v+         ; Lam v' <$> zonkCoreExpr env1 e }+zonkCoreExpr env (Let bind e)+    = do (env1, bind') <- zonkCoreBind env bind+         Let bind'<$> zonkCoreExpr env1 e+zonkCoreExpr env (Case scrut b ty alts)+    = do scrut' <- zonkCoreExpr env scrut+         ty' <- zonkTcTypeToTypeX env ty+         b' <- zonkIdBndr env b+         let env1 = extendIdZonkEnv1 env b'+         alts' <- mapM (zonkCoreAlt env1) alts+         return $ Case scrut' b' ty' alts'++zonkCoreAlt :: ZonkEnv -> CoreAlt -> TcM CoreAlt+zonkCoreAlt env (dc, bndrs, rhs)+    = do (env1, bndrs') <- zonkCoreBndrsX env bndrs+         rhs' <- zonkCoreExpr env1 rhs+         return $ (dc, bndrs', rhs')++zonkCoreBind :: ZonkEnv -> CoreBind -> TcM (ZonkEnv, CoreBind)+zonkCoreBind env (NonRec v e)+    = do v' <- zonkIdBndr env v+         e' <- zonkCoreExpr env e+         let env1 = extendIdZonkEnv1 env v'+         return (env1, NonRec v' e')+zonkCoreBind env (Rec pairs)+    = do (env1, pairs') <- fixM go+         return (env1, Rec pairs')+  where+    go ~(_, new_pairs) = do+         let env1 = extendIdZonkEnvRec env (map fst new_pairs)+         pairs' <- mapM (zonkCorePair env1) pairs+         return (env1, pairs')++zonkCorePair :: ZonkEnv -> (CoreBndr, CoreExpr) -> TcM (CoreBndr, CoreExpr)+zonkCorePair env (v,e) = (,) <$> zonkIdBndr env v <*> zonkCoreExpr env e++zonkEvTypeable :: ZonkEnv -> EvTypeable -> TcM EvTypeable+zonkEvTypeable env (EvTypeableTyCon tycon e)+  = do { e'  <- mapM (zonkEvTerm env) e+       ; return $ EvTypeableTyCon tycon e' }+zonkEvTypeable env (EvTypeableTyApp t1 t2)+  = do { t1' <- zonkEvTerm env t1+       ; t2' <- zonkEvTerm env t2+       ; return (EvTypeableTyApp t1' t2') }+zonkEvTypeable env (EvTypeableTrFun t1 t2)+  = do { t1' <- zonkEvTerm env t1+       ; t2' <- zonkEvTerm env t2+       ; return (EvTypeableTrFun t1' t2') }+zonkEvTypeable env (EvTypeableTyLit t1)+  = do { t1' <- zonkEvTerm env t1+       ; return (EvTypeableTyLit t1') }++zonkTcEvBinds_s :: ZonkEnv -> [TcEvBinds] -> TcM (ZonkEnv, [TcEvBinds])+zonkTcEvBinds_s env bs = do { (env, bs') <- mapAccumLM zonk_tc_ev_binds env bs+                            ; return (env, [EvBinds (unionManyBags bs')]) }++zonkTcEvBinds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, TcEvBinds)+zonkTcEvBinds env bs = do { (env', bs') <- zonk_tc_ev_binds env bs+                          ; return (env', EvBinds bs') }++zonk_tc_ev_binds :: ZonkEnv -> TcEvBinds -> TcM (ZonkEnv, Bag EvBind)+zonk_tc_ev_binds env (TcEvBinds var) = zonkEvBindsVar env var+zonk_tc_ev_binds env (EvBinds bs)    = zonkEvBinds env bs++zonkEvBindsVar :: ZonkEnv -> EvBindsVar -> TcM (ZonkEnv, Bag EvBind)+zonkEvBindsVar env (EvBindsVar { ebv_binds = ref })+  = do { bs <- readMutVar ref+       ; zonkEvBinds env (evBindMapBinds bs) }+zonkEvBindsVar env (CoEvBindsVar {}) = return (env, emptyBag)++zonkEvBinds :: ZonkEnv -> Bag EvBind -> TcM (ZonkEnv, Bag EvBind)+zonkEvBinds env binds+  = {-# SCC "zonkEvBinds" #-}+    fixM (\ ~( _, new_binds) -> do+         { let env1 = extendIdZonkEnvRec env (collect_ev_bndrs new_binds)+         ; binds' <- mapBagM (zonkEvBind env1) binds+         ; return (env1, binds') })+  where+    collect_ev_bndrs :: Bag EvBind -> [EvVar]+    collect_ev_bndrs = foldrBag add []+    add (EvBind { eb_lhs = var }) vars = var : vars++zonkEvBind :: ZonkEnv -> EvBind -> TcM EvBind+zonkEvBind env bind@(EvBind { eb_lhs = var, eb_rhs = term })+  = do { var'  <- {-# SCC "zonkEvBndr" #-} zonkEvBndr env var++         -- Optimise the common case of Refl coercions+         -- See Note [Optimise coercion zonking]+         -- This has a very big effect on some programs (eg #5030)++       ; term' <- case getEqPredTys_maybe (idType var') of+           Just (r, ty1, ty2) | ty1 `eqType` ty2+                  -> return (evCoercion (mkTcReflCo r ty1))+           _other -> zonkEvTerm env term++       ; return (bind { eb_lhs = var', eb_rhs = term' }) }++{- Note [Optimise coercion zonking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When optimising evidence binds we may come across situations where+a coercion looks like+      cv = ReflCo ty+or    cv1 = cv2+where the type 'ty' is big.  In such cases it is a waste of time to zonk both+  * The variable on the LHS+  * The coercion on the RHS+Rather, we can zonk the variable, and if its type is (ty ~ ty), we can just+use Refl on the right, ignoring the actual coercion on the RHS.++This can have a very big effect, because the constraint solver sometimes does go+to a lot of effort to prove Refl!  (Eg when solving  10+3 = 10+3; cf #5030)+++************************************************************************+*                                                                      *+                         Zonking types+*                                                                      *+************************************************************************+-}++{- Note [Sharing when zonking to Type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Problem:++    In TcMType.zonkTcTyVar, we short-circuit (Indirect ty) to+    (Indirect zty), see Note [Sharing in zonking] in TcMType. But we+    /can't/ do this when zonking a TcType to a Type (#15552, esp+    comment:3).  Suppose we have++       alpha -> alpha+         where+            alpha is already unified:+             alpha := T{tc-tycon} Int -> Int+         and T is knot-tied++    By "knot-tied" I mean that the occurrence of T is currently a TcTyCon,+    but the global env contains a mapping "T" :-> T{knot-tied-tc}. See+    Note [Type checking recursive type and class declarations] in+    TcTyClsDecls.++    Now we call zonkTcTypeToType on that (alpha -> alpha). If we follow+    the same path as Note [Sharing in zonking] in TcMType, we'll+    update alpha to+       alpha := T{knot-tied-tc} Int -> Int++    But alas, if we encounter alpha for a /second/ time, we end up+    looking at T{knot-tied-tc} and fall into a black hole. The whole+    point of zonkTcTypeToType is that it produces a type full of+    knot-tied tycons, and you must not look at the result!!++    To put it another way (zonkTcTypeToType . zonkTcTypeToType) is not+    the same as zonkTcTypeToType. (If we distinguished TcType from+    Type, this issue would have been a type error!)++Solution: (see #15552 for other variants)++    One possible solution is simply not to do the short-circuiting.+    That has less sharing, but maybe sharing is rare. And indeed,+    that turns out to be viable from a perf point of view++    But the code implements something a bit better++    * ZonkEnv contains ze_meta_tv_env, which maps+          from a MetaTyVar (unificaion variable)+          to a Type (not a TcType)++    * In zonkTyVarOcc, we check this map to see if we have zonked+      this variable before. If so, use the previous answer; if not+      zonk it, and extend the map.++    * The map is of course stateful, held in a TcRef. (That is unlike+      the treatment of lexically-scoped variables in ze_tv_env and+      ze_id_env.)++    Is the extra work worth it?  Some non-sytematic perf measurements+    suggest that compiler allocation is reduced overall (by 0.5% or so)+    but compile time really doesn't change.+-}++zonkTyVarOcc :: ZonkEnv -> TyVar -> TcM TcType+zonkTyVarOcc env@(ZonkEnv { ze_flexi = flexi+                          , ze_tv_env = tv_env+                          , ze_meta_tv_env = mtv_env_ref }) tv+  | isTcTyVar tv+  = case tcTyVarDetails tv of+      SkolemTv {}    -> lookup_in_tv_env+      RuntimeUnk {}  -> lookup_in_tv_env+      MetaTv { mtv_ref = ref }+        -> do { mtv_env <- readTcRef mtv_env_ref+                -- See Note [Sharing when zonking to Type]+              ; case lookupVarEnv mtv_env tv of+                  Just ty -> return ty+                  Nothing -> do { mtv_details <- readTcRef ref+                                ; zonk_meta mtv_env ref mtv_details } }+  | otherwise+  = lookup_in_tv_env++  where+    lookup_in_tv_env    -- Look up in the env just as we do for Ids+      = case lookupVarEnv tv_env tv of+          Nothing  -> mkTyVarTy <$> updateTyVarKindM (zonkTcTypeToTypeX env) tv+          Just tv' -> return (mkTyVarTy tv')++    zonk_meta mtv_env ref Flexi+      = do { kind <- zonkTcTypeToTypeX env (tyVarKind tv)+           ; ty <- commitFlexi flexi tv kind+           ; writeMetaTyVarRef tv ref ty  -- Belt and braces+           ; finish_meta mtv_env ty }++    zonk_meta mtv_env _ (Indirect ty)+      = do { zty <- zonkTcTypeToTypeX env ty+           ; finish_meta mtv_env zty }++    finish_meta mtv_env ty+      = do { let mtv_env' = extendVarEnv mtv_env tv ty+           ; writeTcRef mtv_env_ref mtv_env'+           ; return ty }++lookupTyVarOcc :: ZonkEnv -> TcTyVar -> Maybe TyVar+lookupTyVarOcc (ZonkEnv { ze_tv_env = tv_env }) tv+  = lookupVarEnv tv_env tv++commitFlexi :: ZonkFlexi -> TcTyVar -> Kind -> TcM Type+-- Only monadic so we can do tc-tracing+commitFlexi flexi tv zonked_kind+  = case flexi of+      SkolemiseFlexi  -> return (mkTyVarTy (mkTyVar name zonked_kind))++      DefaultFlexi+        | isRuntimeRepTy zonked_kind+        -> do { traceTc "Defaulting flexi tyvar to LiftedRep:" (pprTyVar tv)+              ; return liftedRepTy }+        | otherwise+        -> do { traceTc "Defaulting flexi tyvar to Any:" (pprTyVar tv)+              ; return (anyTypeOfKind zonked_kind) }++      RuntimeUnkFlexi+        -> do { traceTc "Defaulting flexi tyvar to RuntimeUnk:" (pprTyVar tv)+              ; return (mkTyVarTy (mkTcTyVar name zonked_kind RuntimeUnk)) }+                        -- This is where RuntimeUnks are born:+                        -- otherwise-unconstrained unification variables are+                        -- turned into RuntimeUnks as they leave the+                        -- typechecker's monad+  where+     name = tyVarName tv++zonkCoVarOcc :: ZonkEnv -> CoVar -> TcM Coercion+zonkCoVarOcc (ZonkEnv { ze_tv_env = tyco_env }) cv+  | Just cv' <- lookupVarEnv tyco_env cv  -- don't look in the knot-tied env+  = return $ mkCoVarCo cv'+  | otherwise+  = do { cv' <- zonkCoVar cv; return (mkCoVarCo cv') }++zonkCoHole :: ZonkEnv -> CoercionHole -> TcM Coercion+zonkCoHole env hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })+  = do { contents <- readTcRef ref+       ; case contents of+           Just co -> do { co' <- zonkCoToCo env co+                         ; checkCoercionHole cv co' }++              -- This next case should happen only in the presence of+              -- (undeferred) type errors. Originally, I put in a panic+              -- here, but that caused too many uses of `failIfErrsM`.+           Nothing -> do { traceTc "Zonking unfilled coercion hole" (ppr hole)+                         ; when debugIsOn $+                           whenNoErrs $+                           MASSERT2( False+                                   , text "Type-correct unfilled coercion hole"+                                     <+> ppr hole )+                         ; cv' <- zonkCoVar cv+                         ; return $ mkCoVarCo cv' } }+                             -- This will be an out-of-scope variable, but keeping+                             -- this as a coercion hole led to #15787++zonk_tycomapper :: TyCoMapper ZonkEnv TcM+zonk_tycomapper = TyCoMapper+  { tcm_tyvar      = zonkTyVarOcc+  , tcm_covar      = zonkCoVarOcc+  , tcm_hole       = zonkCoHole+  , tcm_tycobinder = \env tv _vis -> zonkTyBndrX env tv+  , tcm_tycon      = zonkTcTyConToTyCon }++-- Zonk a TyCon by changing a TcTyCon to a regular TyCon+zonkTcTyConToTyCon :: TcTyCon -> TcM TyCon+zonkTcTyConToTyCon tc+  | isTcTyCon tc = do { thing <- tcLookupGlobalOnly (getName tc)+                      ; case thing of+                          ATyCon real_tc -> return real_tc+                          _              -> pprPanic "zonkTcTyCon" (ppr tc $$ ppr thing) }+  | otherwise    = return tc -- it's already zonked++-- Confused by zonking? See Note [What is zonking?] in TcMType.+zonkTcTypeToType :: TcType -> TcM Type+zonkTcTypeToType ty = initZonkEnv $ \ ze -> zonkTcTypeToTypeX ze ty++zonkTcTypeToTypeX :: ZonkEnv -> TcType -> TcM Type+zonkTcTypeToTypeX = mapType zonk_tycomapper++zonkTcTypesToTypes :: [TcType] -> TcM [Type]+zonkTcTypesToTypes tys = initZonkEnv $ \ ze -> zonkTcTypesToTypesX ze tys++zonkTcTypesToTypesX :: ZonkEnv -> [TcType] -> TcM [Type]+zonkTcTypesToTypesX env tys = mapM (zonkTcTypeToTypeX env) tys++zonkCoToCo :: ZonkEnv -> Coercion -> TcM Coercion+zonkCoToCo = mapCoercion zonk_tycomapper++zonkTcMethInfoToMethInfoX :: ZonkEnv -> TcMethInfo -> TcM MethInfo+zonkTcMethInfoToMethInfoX ze (name, ty, gdm_spec)+  = do { ty' <- zonkTcTypeToTypeX ze ty+       ; gdm_spec' <- zonk_gdm gdm_spec+       ; return (name, ty', gdm_spec') }+  where+    zonk_gdm :: Maybe (DefMethSpec (SrcSpan, TcType))+             -> TcM (Maybe (DefMethSpec (SrcSpan, Type)))+    zonk_gdm Nothing = return Nothing+    zonk_gdm (Just VanillaDM) = return (Just VanillaDM)+    zonk_gdm (Just (GenericDM (loc, ty)))+      = do { ty' <- zonkTcTypeToTypeX ze ty+           ; return (Just (GenericDM (loc, ty'))) }++---------------------------------------+{- Note [Zonking the LHS of a RULE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also DsBinds Note [Free tyvars on rule LHS]++We need to gather the type variables mentioned on the LHS so we can+quantify over them.  Example:+  data T a = C++  foo :: T a -> Int+  foo C = 1++  {-# RULES "myrule"  foo C = 1 #-}++After type checking the LHS becomes (foo alpha (C alpha)) and we do+not want to zap the unbound meta-tyvar 'alpha' to Any, because that+limits the applicability of the rule.  Instead, we want to quantify+over it!++We do this in two stages.++* During zonking, we skolemise the TcTyVar 'alpha' to TyVar 'a'.  We+  do this by using zonkTvSkolemising as the UnboundTyVarZonker in the+  ZonkEnv.  (This is in fact the whole reason that the ZonkEnv has a+  UnboundTyVarZonker.)++* In DsBinds, we quantify over it.  See DsBinds+  Note [Free tyvars on rule LHS]++Quantifying here is awkward because (a) the data type is big and (b)+finding the free type vars of an expression is necessarily monadic+operation. (consider /\a -> f @ b, where b is side-effected to a)+-}
+ compiler/typecheck/TcHsType.hs view
@@ -0,0 +1,2939 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[TcMonoType]{Typechecking user-specified @MonoTypes@}+-}++{-# LANGUAGE CPP, TupleSections, MultiWayIf, RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}++module TcHsType (+        -- Type signatures+        kcHsSigType, tcClassSigType,+        tcHsSigType, tcHsSigWcType,+        tcHsPartialSigType,+        funsSigCtxt, addSigCtxt, pprSigCtxt,++        tcHsClsInstType,+        tcHsDeriv, tcDerivStrategy,+        tcHsTypeApp,+        UserTypeCtxt(..),+        bindImplicitTKBndrs_Tv, bindImplicitTKBndrs_Skol,+            bindImplicitTKBndrs_Q_Tv, bindImplicitTKBndrs_Q_Skol,+        bindExplicitTKBndrs_Tv, bindExplicitTKBndrs_Skol,+            bindExplicitTKBndrs_Q_Tv, bindExplicitTKBndrs_Q_Skol,+        ContextKind(..),++                -- Type checking type and class decls+        kcLookupTcTyCon, bindTyClTyVars,+        etaExpandAlgTyCon, tcbVisibilities,++          -- tyvars+        zonkAndScopedSort,++        -- Kind-checking types+        -- No kind generalisation, no checkValidType+        kcLHsQTyVars,+        tcWildCardBinders,+        tcHsLiftedType,   tcHsOpenType,+        tcHsLiftedTypeNC, tcHsOpenTypeNC,+        tcLHsType, tcLHsTypeUnsaturated, tcCheckLHsType,+        tcHsMbContext, tcHsContext, tcLHsPredType, tcInferApps,+        failIfEmitsConstraints,+        solveEqualities, -- useful re-export++        typeLevelMode, kindLevelMode,++        kindGeneralize, checkExpectedKind_pp,++        -- Sort-checking kinds+        tcLHsKindSig, badKindSig,++        -- Zonking and promoting+        zonkPromoteType,++        -- Pattern type signatures+        tcHsPatSigType, tcPatSig,++        -- Error messages+        funAppCtxt, addTyConFlavCtxt+   ) where++#include "HsVersions.h"++import GhcPrelude++import HsSyn+import TcRnMonad+import TcEvidence+import TcEnv+import TcMType+import TcValidity+import TcUnify+import TcIface+import TcSimplify+import TcHsSyn+import TyCoRep  ( Type(..) )+import TcErrors ( reportAllUnsolved )+import TcType+import Inst   ( tcInstInvisibleTyBinders, tcInstInvisibleTyBinder )+import TyCoRep( TyCoBinder(..) )  -- Used in etaExpandAlgTyCon+import Type+import TysPrim+import Coercion+import RdrName( lookupLocalRdrOcc )+import Var+import VarSet+import TyCon+import ConLike+import DataCon+import Class+import Name+-- import NameSet+import VarEnv+import TysWiredIn+import BasicTypes+import SrcLoc+import Constants ( mAX_CTUPLE_SIZE )+import ErrUtils( MsgDoc )+import Unique+import UniqSet+import Util+import UniqSupply+import Outputable+import FastString+import PrelNames hiding ( wildCardName )+import DynFlags ( WarningFlag (Opt_WarnPartialTypeSignatures) )+import qualified GHC.LanguageExtensions as LangExt++import Maybes+import Data.List ( find )+import Control.Monad++{-+        ----------------------------+                General notes+        ----------------------------++Unlike with expressions, type-checking types both does some checking and+desugars at the same time. This is necessary because we often want to perform+equality checks on the types right away, and it would be incredibly painful+to do this on un-desugared types. Luckily, desugared types are close enough+to HsTypes to make the error messages sane.++During type-checking, we perform as little validity checking as possible.+Generally, after type-checking, you will want to do validity checking, say+with TcValidity.checkValidType.++Validity checking+~~~~~~~~~~~~~~~~~+Some of the validity check could in principle be done by the kind checker,+but not all:++- During desugaring, we normalise by expanding type synonyms.  Only+  after this step can we check things like type-synonym saturation+  e.g.  type T k = k Int+        type S a = a+  Then (T S) is ok, because T is saturated; (T S) expands to (S Int);+  and then S is saturated.  This is a GHC extension.++- Similarly, also a GHC extension, we look through synonyms before complaining+  about the form of a class or instance declaration++- Ambiguity checks involve functional dependencies++Also, in a mutually recursive group of types, we can't look at the TyCon until we've+finished building the loop.  So to keep things simple, we postpone most validity+checking until step (3).++%************************************************************************+%*                                                                      *+              Check types AND do validity checking+*                                                                      *+************************************************************************+-}++funsSigCtxt :: [Located Name] -> UserTypeCtxt+-- Returns FunSigCtxt, with no redundant-context-reporting,+-- form a list of located names+funsSigCtxt (L _ name1 : _) = FunSigCtxt name1 False+funsSigCtxt []              = panic "funSigCtxt"++addSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> TcM a -> TcM a+addSigCtxt ctxt hs_ty thing_inside+  = setSrcSpan (getLoc hs_ty) $+    addErrCtxt (pprSigCtxt ctxt hs_ty) $+    thing_inside++pprSigCtxt :: UserTypeCtxt -> LHsType GhcRn -> SDoc+-- (pprSigCtxt ctxt <extra> <type>)+-- prints    In the type signature for 'f':+--              f :: <type>+-- The <extra> is either empty or "the ambiguity check for"+pprSigCtxt ctxt hs_ty+  | Just n <- isSigMaybe ctxt+  = hang (text "In the type signature:")+       2 (pprPrefixOcc n <+> dcolon <+> ppr hs_ty)++  | otherwise+  = hang (text "In" <+> pprUserTypeCtxt ctxt <> colon)+       2 (ppr hs_ty)++tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType GhcRn -> TcM Type+-- This one is used when we have a LHsSigWcType, but in+-- a place where wildcards aren't allowed. The renamer has+-- already checked this, so we can simply ignore it.+tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty)++kcHsSigType :: [Located Name] -> LHsSigType GhcRn -> TcM ()+kcHsSigType names (HsIB { hsib_body = hs_ty+                                  , hsib_ext = sig_vars })+  = discardResult                        $+    addSigCtxt (funsSigCtxt names) hs_ty $+    bindImplicitTKBndrs_Skol sig_vars    $+    tc_lhs_type typeLevelMode hs_ty liftedTypeKind++kcHsSigType _ (XHsImplicitBndrs _) = panic "kcHsSigType"++tcClassSigType :: SkolemInfo -> [Located Name] -> LHsSigType GhcRn -> TcM Type+-- Does not do validity checking+tcClassSigType skol_info names sig_ty+  = addSigCtxt (funsSigCtxt names) (hsSigType sig_ty) $+    tc_hs_sig_type skol_info sig_ty (TheKind liftedTypeKind)+       -- Do not zonk-to-Type, nor perform a validity check+       -- We are in a knot with the class and associated types+       -- Zonking and validity checking is done by tcClassDecl++tcHsSigType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type+-- Does validity checking+-- See Note [Recipe for checking a signature]+tcHsSigType ctxt sig_ty+  = addSigCtxt ctxt (hsSigType sig_ty) $+    do { traceTc "tcHsSigType {" (ppr sig_ty)++          -- Generalise here: see Note [Kind generalisation]+       ; ty <- tc_hs_sig_type skol_info sig_ty+                                      (expectedKindInCtxt ctxt)+       ; ty <- zonkTcType ty++       ; checkValidType ctxt ty+       ; traceTc "end tcHsSigType }" (ppr ty)+       ; return ty }+  where+    skol_info = SigTypeSkol ctxt++tc_hs_sig_type :: SkolemInfo -> LHsSigType GhcRn+               -> ContextKind -> TcM Type+-- Kind-checks/desugars an 'LHsSigType',+--   solve equalities,+--   and then kind-generalizes.+-- This will never emit constraints, as it uses solveEqualities interally.+-- No validity checking or zonking+tc_hs_sig_type skol_info hs_sig_type ctxt_kind+  | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type+  = do { (tc_lvl, (wanted, (spec_tkvs, ty)))+              <- pushTcLevelM                           $+                 solveLocalEqualitiesX "tc_hs_sig_type" $+                 bindImplicitTKBndrs_Skol sig_vars      $+                 do { kind <- newExpectedKind ctxt_kind+                    ; tc_lhs_type typeLevelMode hs_ty kind }+       -- Any remaining variables (unsolved in the solveLocalEqualities)+       -- should be in the global tyvars, and therefore won't be quantified++       ; spec_tkvs <- zonkAndScopedSort spec_tkvs+       ; let ty1 = mkSpecForAllTys spec_tkvs ty+       ; kvs <- kindGeneralizeLocal wanted ty1+       ; emitResidualTvConstraint skol_info Nothing (kvs ++ spec_tkvs)+                                  tc_lvl wanted++       -- See Note [Fail fast if there are insoluble kind equalities]+       --     in TcSimplify+       ; when (insolubleWC wanted) failM++       ; return (mkInvForAllTys kvs ty1) }++tc_hs_sig_type _ (XHsImplicitBndrs _) _ = panic "tc_hs_sig_type"++tcTopLHsType :: LHsSigType GhcRn -> ContextKind -> TcM Type+-- tcTopLHsType is used for kind-checking top-level HsType where+--   we want to fully solve /all/ equalities, and report errors+-- Does zonking, but not validity checking because it's used+--   for things (like deriving and instances) that aren't+--   ordinary types+tcTopLHsType hs_sig_type ctxt_kind+  | HsIB { hsib_ext = sig_vars, hsib_body = hs_ty } <- hs_sig_type+  = do { traceTc "tcTopLHsType {" (ppr hs_ty)+       ; (spec_tkvs, ty)+              <- pushTcLevelM_                     $+                 solveEqualities                   $+                 bindImplicitTKBndrs_Skol sig_vars $+                 do { kind <- newExpectedKind ctxt_kind+                    ; tc_lhs_type typeLevelMode hs_ty kind }++       ; spec_tkvs <- zonkAndScopedSort spec_tkvs+       ; let ty1 = mkSpecForAllTys spec_tkvs ty+       ; kvs <- kindGeneralize ty1+       ; final_ty <- zonkTcTypeToType (mkInvForAllTys kvs ty1)+       ; traceTc "End tcTopLHsType }" (vcat [ppr hs_ty, ppr final_ty])+       ; return final_ty}++tcTopLHsType (XHsImplicitBndrs _) _ = panic "tcTopLHsType"++-----------------+tcHsDeriv :: LHsSigType GhcRn -> TcM ([TyVar], (Class, [Type], [Kind]))+-- Like tcHsSigType, but for the ...deriving( C t1 ty2 ) clause+-- Returns the C, [ty1, ty2, and the kinds of C's remaining arguments+-- E.g.    class C (a::*) (b::k->k)+--         data T a b = ... deriving( C Int )+--    returns ([k], C, [k, Int], [k->k])+-- Return values are fully zonked+tcHsDeriv hs_ty+  = do { ty <- checkNoErrs $  -- Avoid redundant error report+                              -- with "illegal deriving", below+               tcTopLHsType hs_ty AnyKind+       ; let (tvs, pred)    = splitForAllTys ty+             (kind_args, _) = splitFunTys (tcTypeKind pred)+       ; case getClassPredTys_maybe pred of+           Just (cls, tys) -> return (tvs, (cls, tys, kind_args))+           Nothing -> failWithTc (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }++-- | Typecheck something within the context of a deriving strategy.+-- This is of particular importance when the deriving strategy is @via@.+-- For instance:+--+-- @+-- deriving via (S a) instance C (T a)+-- @+--+-- We need to typecheck @S a@, and moreover, we need to extend the tyvar+-- environment with @a@ before typechecking @C (T a)@, since @S a@ quantified+-- the type variable @a@.+tcDerivStrategy+  :: forall a.+     Maybe (DerivStrategy GhcRn) -- ^ The deriving strategy+  -> TcM ([TyVar], a) -- ^ The thing to typecheck within the context of the+                      -- deriving strategy, which might quantify some type+                      -- variables of its own.+  -> TcM (Maybe (DerivStrategy GhcTc), [TyVar], a)+     -- ^ The typechecked deriving strategy, all quantified tyvars, and+     -- the payload of the typechecked thing.+tcDerivStrategy mds thing_inside+  = case mds of+      Nothing -> boring_case Nothing+      Just ds -> do (ds', tvs, thing) <- tc_deriv_strategy ds+                    pure (Just ds', tvs, thing)+  where+    tc_deriv_strategy :: DerivStrategy GhcRn+                      -> TcM (DerivStrategy GhcTc, [TyVar], a)+    tc_deriv_strategy StockStrategy    = boring_case StockStrategy+    tc_deriv_strategy AnyclassStrategy = boring_case AnyclassStrategy+    tc_deriv_strategy NewtypeStrategy  = boring_case NewtypeStrategy+    tc_deriv_strategy (ViaStrategy ty) = do+      ty' <- checkNoErrs $+             tcTopLHsType ty AnyKind+      let (via_tvs, via_pred) = splitForAllTys ty'+      tcExtendTyVarEnv via_tvs $ do+        (thing_tvs, thing) <- thing_inside+        pure (ViaStrategy via_pred, via_tvs ++ thing_tvs, thing)++    boring_case :: mds -> TcM (mds, [TyVar], a)+    boring_case mds = do+      (thing_tvs, thing) <- thing_inside+      pure (mds, thing_tvs, thing)++tcHsClsInstType :: UserTypeCtxt    -- InstDeclCtxt or SpecInstCtxt+                -> LHsSigType GhcRn+                -> TcM Type+-- Like tcHsSigType, but for a class instance declaration+tcHsClsInstType user_ctxt hs_inst_ty+  = setSrcSpan (getLoc (hsSigType hs_inst_ty)) $+    do { -- Fail eagerly if tcTopLHsType fails.  We are at top level so+         -- these constraints will never be solved later. And failing+         -- eagerly avoids follow-on errors when checkValidInstance+         -- sees an unsolved coercion hole+         inst_ty <- checkNoErrs $+                    tcTopLHsType hs_inst_ty (TheKind constraintKind)+       ; checkValidInstance user_ctxt hs_inst_ty inst_ty+       ; return inst_ty }++----------------------------------------------+-- | Type-check a visible type application+tcHsTypeApp :: LHsWcType GhcRn -> Kind -> TcM Type+-- See Note [Recipe for checking a signature] in TcHsType+tcHsTypeApp wc_ty kind+  | HsWC { hswc_ext = sig_wcs, hswc_body = hs_ty } <- wc_ty+  = do { ty <- solveLocalEqualities "tcHsTypeApp" $+               -- We are looking at a user-written type, very like a+               -- signature so we want to solve its equalities right now+               unsetWOptM Opt_WarnPartialTypeSignatures $+               setXOptM LangExt.PartialTypeSignatures $+               -- See Note [Wildcards in visible type application]+               tcWildCardBinders sig_wcs $ \ _ ->+               tcCheckLHsType hs_ty kind+       -- We must promote here. Ex:+       --   f :: forall a. a+       --   g = f @(forall b. Proxy b -> ()) @Int ...+       -- After when processing the @Int, we'll have to check its kind+       -- against the as-yet-unknown kind of b. This check causes an assertion+       -- failure if we don't promote.+       ; ty <- zonkPromoteType ty+       ; checkValidType TypeAppCtxt ty+       ; return ty }+tcHsTypeApp (XHsWildCardBndrs _) _ = panic "tcHsTypeApp"++{- Note [Wildcards in visible type application]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++A HsWildCardBndrs's hswc_ext now only includes named wildcards, so any unnamed+wildcards stay unchanged in hswc_body and when called in tcHsTypeApp, tcCheckLHsType+will call emitWildCardHoleConstraints on them. However, this would trigger+error/warning when an unnamed wildcard is passed in as a visible type argument,+which we do not want because users should be able to write @_ to skip a instantiating+a type variable variable without fuss. The solution is to switch the+PartialTypeSignatures flags here to let the typechecker know that it's checking+a '@_' and do not emit hole constraints on it.+See related Note [Wildcards in visible kind application]+and Note [The wildcard story for types] in HsTypes.hs++-}++{-+************************************************************************+*                                                                      *+            The main kind checker: no validity checks here+*                                                                      *+************************************************************************+-}++---------------------------+tcHsOpenType, tcHsLiftedType,+  tcHsOpenTypeNC, tcHsLiftedTypeNC :: LHsType GhcRn -> TcM TcType+-- Used for type signatures+-- Do not do validity checking+tcHsOpenType ty   = addTypeCtxt ty $ tcHsOpenTypeNC ty+tcHsLiftedType ty = addTypeCtxt ty $ tcHsLiftedTypeNC ty++tcHsOpenTypeNC   ty = do { ek <- newOpenTypeKind+                         ; tc_lhs_type typeLevelMode ty ek }+tcHsLiftedTypeNC ty = tc_lhs_type typeLevelMode ty liftedTypeKind++-- Like tcHsType, but takes an expected kind+tcCheckLHsType :: LHsType GhcRn -> Kind -> TcM TcType+tcCheckLHsType hs_ty exp_kind+  = addTypeCtxt hs_ty $+    tc_lhs_type typeLevelMode hs_ty exp_kind++tcLHsType :: LHsType GhcRn -> TcM (TcType, TcKind)+-- Called from outside: set the context+tcLHsType ty = addTypeCtxt ty (tc_infer_lhs_type typeLevelMode ty)++-- Like tcLHsType, but use it in a context where type synonyms and type families+-- do not need to be saturated, like in a GHCi :kind call+tcLHsTypeUnsaturated :: LHsType GhcRn -> TcM (TcType, TcKind)+tcLHsTypeUnsaturated hs_ty+  | Just (hs_fun_ty, hs_args) <- splitHsAppTys (unLoc hs_ty)+  = addTypeCtxt hs_ty $+    do { (fun_ty, _ki) <- tcInferAppHead mode hs_fun_ty+       ; tcInferApps_nosat mode hs_fun_ty fun_ty hs_args }+         -- Notice the 'nosat'; do not instantiate trailing+         -- invisible arguments of a type family.+         -- See Note [Dealing with :kind]++  | otherwise+  = addTypeCtxt hs_ty $+    tc_infer_lhs_type mode hs_ty++  where+    mode = typeLevelMode++{- Note [Dealing with :kind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this GHCi command+  ghci> type family F :: Either j k+  ghci> :kind F+  F :: forall {j,k}. Either j k++We will only get the 'forall' if we /refrain/ from saturating those+invisible binders. But generally we /do/ saturate those invisible+binders (see tcInferApps), and we want to do so for nested application+even in GHCi.  Consider for example (#16287)+  ghci> type family F :: k+  ghci> data T :: (forall k. k) -> Type+  ghci> :kind T F+We want to reject this. It's just at the very top level that we want+to switch off saturation.++So tcLHsTypeUnsaturated does a little special case for top level+applications.  Actually the common case is a bare variable, as above.+++************************************************************************+*                                                                      *+      Type-checking modes+*                                                                      *+************************************************************************++The kind-checker is parameterised by a TcTyMode, which contains some+information about where we're checking a type.++The renamer issues errors about what it can. All errors issued here must+concern things that the renamer can't handle.++-}++-- | Info about the context in which we're checking a type. Currently,+-- differentiates only between types and kinds, but this will likely+-- grow, at least to include the distinction between patterns and+-- not-patterns.+--+-- To find out where the mode is used, search for 'mode_level'+data TcTyMode = TcTyMode { mode_level :: TypeOrKind }++typeLevelMode :: TcTyMode+typeLevelMode = TcTyMode { mode_level = TypeLevel }++kindLevelMode :: TcTyMode+kindLevelMode = TcTyMode { mode_level = KindLevel }++-- switch to kind level+kindLevel :: TcTyMode -> TcTyMode+kindLevel mode = mode { mode_level = KindLevel }++instance Outputable TcTyMode where+  ppr = ppr . mode_level++{-+Note [Bidirectional type checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In expressions, whenever we see a polymorphic identifier, say `id`, we are+free to instantiate it with metavariables, knowing that we can always+re-generalize with type-lambdas when necessary. For example:++  rank2 :: (forall a. a -> a) -> ()+  x = rank2 id++When checking the body of `x`, we can instantiate `id` with a metavariable.+Then, when we're checking the application of `rank2`, we notice that we really+need a polymorphic `id`, and then re-generalize over the unconstrained+metavariable.++In types, however, we're not so lucky, because *we cannot re-generalize*!+There is no lambda. So, we must be careful only to instantiate at the last+possible moment, when we're sure we're never going to want the lost polymorphism+again. This is done in calls to tcInstInvisibleTyBinders.++To implement this behavior, we use bidirectional type checking, where we+explicitly think about whether we know the kind of the type we're checking+or not. Note that there is a difference between not knowing a kind and+knowing a metavariable kind: the metavariables are TauTvs, and cannot become+forall-quantified kinds. Previously (before dependent types), there were+no higher-rank kinds, and so we could instantiate early and be sure that+no types would have polymorphic kinds, and so we could always assume that+the kind of a type was a fresh metavariable. Not so anymore, thus the+need for two algorithms.++For HsType forms that can never be kind-polymorphic, we implement only the+"down" direction, where we safely assume a metavariable kind. For HsType forms+that *can* be kind-polymorphic, we implement just the "up" (functions with+"infer" in their name) version, as we gain nothing by also implementing the+"down" version.++Note [Future-proofing the type checker]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As discussed in Note [Bidirectional type checking], each HsType form is+handled in *either* tc_infer_hs_type *or* tc_hs_type. These functions+are mutually recursive, so that either one can work for any type former.+But, we want to make sure that our pattern-matches are complete. So,+we have a bunch of repetitive code just so that we get warnings if we're+missing any patterns.++-}++------------------------------------------+-- | Check and desugar a type, returning the core type and its+-- possibly-polymorphic kind. Much like 'tcInferRho' at the expression+-- level.+tc_infer_lhs_type :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)+tc_infer_lhs_type mode (L span ty)+  = setSrcSpan span $+    tc_infer_hs_type mode ty++---------------------------+-- | Call 'tc_infer_hs_type' and check its result against an expected kind.+tc_infer_hs_type_ek :: HasDebugCallStack => TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType+tc_infer_hs_type_ek mode hs_ty ek+  = do { (ty, k) <- tc_infer_hs_type mode hs_ty+       ; checkExpectedKind hs_ty ty k ek }++---------------------------+-- | Infer the kind of a type and desugar. This is the "up" type-checker,+-- as described in Note [Bidirectional type checking]+tc_infer_hs_type :: TcTyMode -> HsType GhcRn -> TcM (TcType, TcKind)++tc_infer_hs_type mode (HsParTy _ t)+  = tc_infer_lhs_type mode t++tc_infer_hs_type mode ty+  | Just (hs_fun_ty, hs_args) <- splitHsAppTys ty+  = do { (fun_ty, _ki) <- tcInferAppHead mode hs_fun_ty+       ; tcInferApps mode hs_fun_ty fun_ty hs_args }++tc_infer_hs_type mode (HsKindSig _ ty sig)+  = do { sig' <- tcLHsKindSig KindSigCtxt sig+                 -- We must typecheck the kind signature, and solve all+                 -- its equalities etc; from this point on we may do+                 -- things like instantiate its foralls, so it needs+                 -- to be fully determined (#14904)+       ; traceTc "tc_infer_hs_type:sig" (ppr ty $$ ppr sig')+       ; ty' <- tc_lhs_type mode ty sig'+       ; return (ty', sig') }++-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType' to communicate+-- the splice location to the typechecker. Here we skip over it in order to have+-- the same kind inferred for a given expression whether it was produced from+-- splices or not.+--+-- See Note [Delaying modFinalizers in untyped splices].+tc_infer_hs_type mode (HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)))+  = tc_infer_hs_type mode ty++tc_infer_hs_type mode (HsDocTy _ ty _) = tc_infer_lhs_type mode ty+tc_infer_hs_type _    (XHsType (NHsCoreTy ty))+  = return (ty, tcTypeKind ty)++tc_infer_hs_type _ (HsExplicitListTy _ _ tys)+  | null tys  -- this is so that we can use visible kind application with '[]+              -- e.g ... '[] @Bool+  = return (mkTyConTy promotedNilDataCon,+            mkSpecForAllTys [alphaTyVar] $ mkListTy alphaTy)++tc_infer_hs_type mode other_ty+  = do { kv <- newMetaKindVar+       ; ty' <- tc_hs_type mode other_ty kv+       ; return (ty', kv) }++------------------------------------------+tc_lhs_type :: TcTyMode -> LHsType GhcRn -> TcKind -> TcM TcType+tc_lhs_type mode (L span ty) exp_kind+  = setSrcSpan span $+    tc_hs_type mode ty exp_kind++tc_hs_type :: TcTyMode -> HsType GhcRn -> TcKind -> TcM TcType+-- See Note [Bidirectional type checking]++tc_hs_type mode (HsParTy _ ty)   exp_kind = tc_lhs_type mode ty exp_kind+tc_hs_type mode (HsDocTy _ ty _) exp_kind = tc_lhs_type mode ty exp_kind+tc_hs_type _ ty@(HsBangTy _ bang _) _+    -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),+    -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of+    -- bangs are invalid, so fail. (#7210, #14761)+    = do { let bangError err = failWith $+                 text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$+                 text err <+> text "annotation cannot appear nested inside a type"+         ; case bang of+             HsSrcBang _ SrcUnpack _           -> bangError "UNPACK"+             HsSrcBang _ SrcNoUnpack _         -> bangError "NOUNPACK"+             HsSrcBang _ NoSrcUnpack SrcLazy   -> bangError "laziness"+             HsSrcBang _ _ _                   -> bangError "strictness" }+tc_hs_type _ ty@(HsRecTy {})      _+      -- Record types (which only show up temporarily in constructor+      -- signatures) should have been removed by now+    = failWithTc (text "Record syntax is illegal here:" <+> ppr ty)++-- HsSpliced is an annotation produced by 'RnSplice.rnSpliceType'.+-- Here we get rid of it and add the finalizers to the global environment+-- while capturing the local environment.+--+-- See Note [Delaying modFinalizers in untyped splices].+tc_hs_type mode (HsSpliceTy _ (HsSpliced _ mod_finalizers (HsSplicedTy ty)))+           exp_kind+  = do addModFinalizersWithLclEnv mod_finalizers+       tc_hs_type mode ty exp_kind++-- This should never happen; type splices are expanded by the renamer+tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind+  = failWithTc (text "Unexpected type splice:" <+> ppr ty)++---------- Functions and applications+tc_hs_type mode (HsFunTy _ ty1 ty2) exp_kind+  = tc_fun_type mode ty1 ty2 exp_kind++tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind+  | op `hasKey` funTyConKey+  = tc_fun_type mode ty1 ty2 exp_kind++--------- Foralls+tc_hs_type mode forall@(HsForAllTy { hst_fvf = fvf, hst_bndrs = hs_tvs+                                   , hst_body = ty }) exp_kind+  = do { (tclvl, wanted, (tvs', ty'))+            <- pushLevelAndCaptureConstraints $+               bindExplicitTKBndrs_Skol hs_tvs $+               tc_lhs_type mode ty exp_kind+    -- Do not kind-generalise here!  See Note [Kind generalisation]+    -- Why exp_kind?  See Note [Body kind of HsForAllTy]+       ; let argf        = case fvf of+                             ForallVis   -> Required+                             ForallInvis -> Specified+             bndrs       = mkTyVarBinders argf tvs'+             skol_info   = ForAllSkol (ppr forall)+             m_telescope = Just (sep (map ppr hs_tvs))++       ; emitResidualTvConstraint skol_info m_telescope tvs' tclvl wanted++       ; return (mkForAllTys bndrs ty') }++tc_hs_type mode (HsQualTy { hst_ctxt = ctxt, hst_body = rn_ty }) exp_kind+  | null (unLoc ctxt)+  = tc_lhs_type mode rn_ty exp_kind++  -- See Note [Body kind of a HsQualTy]+  | tcIsConstraintKind exp_kind+  = do { ctxt' <- tc_hs_context mode ctxt+       ; ty'   <- tc_lhs_type mode rn_ty constraintKind+       ; return (mkPhiTy ctxt' ty') }++  | otherwise+  = do { ctxt' <- tc_hs_context mode ctxt++       ; ek <- newOpenTypeKind  -- The body kind (result of the function) can+                                -- be TYPE r, for any r, hence newOpenTypeKind+       ; ty' <- tc_lhs_type mode rn_ty ek+       ; checkExpectedKind (unLoc rn_ty) (mkPhiTy ctxt' ty')+                           liftedTypeKind exp_kind }++--------- Lists, arrays, and tuples+tc_hs_type mode rn_ty@(HsListTy _ elt_ty) exp_kind+  = do { tau_ty <- tc_lhs_type mode elt_ty liftedTypeKind+       ; checkWiredInTyCon listTyCon+       ; checkExpectedKind rn_ty (mkListTy tau_ty) liftedTypeKind exp_kind }++-- See Note [Distinguishing tuple kinds] in HsTypes+-- See Note [Inferring tuple kinds]+tc_hs_type mode rn_ty@(HsTupleTy _ HsBoxedOrConstraintTuple hs_tys) exp_kind+     -- (NB: not zonking before looking at exp_k, to avoid left-right bias)+  | Just tup_sort <- tupKindSort_maybe exp_kind+  = traceTc "tc_hs_type tuple" (ppr hs_tys) >>+    tc_tuple rn_ty mode tup_sort hs_tys exp_kind+  | otherwise+  = do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)+       ; (tys, kinds) <- mapAndUnzipM (tc_infer_lhs_type mode) hs_tys+       ; kinds <- mapM zonkTcType kinds+           -- Infer each arg type separately, because errors can be+           -- confusing if we give them a shared kind.  Eg #7410+           -- (Either Int, Int), we do not want to get an error saying+           -- "the second argument of a tuple should have kind *->*"++       ; let (arg_kind, tup_sort)+               = case [ (k,s) | k <- kinds+                              , Just s <- [tupKindSort_maybe k] ] of+                    ((k,s) : _) -> (k,s)+                    [] -> (liftedTypeKind, BoxedTuple)+         -- In the [] case, it's not clear what the kind is, so guess *++       ; tys' <- sequence [ setSrcSpan loc $+                            checkExpectedKind hs_ty ty kind arg_kind+                          | ((L loc hs_ty),ty,kind) <- zip3 hs_tys tys kinds ]++       ; finish_tuple rn_ty tup_sort tys' (map (const arg_kind) tys') exp_kind }+++tc_hs_type mode rn_ty@(HsTupleTy _ hs_tup_sort tys) exp_kind+  = tc_tuple rn_ty mode tup_sort tys exp_kind+  where+    tup_sort = case hs_tup_sort of  -- Fourth case dealt with above+                  HsUnboxedTuple    -> UnboxedTuple+                  HsBoxedTuple      -> BoxedTuple+                  HsConstraintTuple -> ConstraintTuple+                  _                 -> panic "tc_hs_type HsTupleTy"++tc_hs_type mode rn_ty@(HsSumTy _ hs_tys) exp_kind+  = do { let arity = length hs_tys+       ; arg_kinds <- mapM (\_ -> newOpenTypeKind) hs_tys+       ; tau_tys   <- zipWithM (tc_lhs_type mode) hs_tys arg_kinds+       ; let arg_reps = map kindRep arg_kinds+             arg_tys  = arg_reps ++ tau_tys+             sum_ty   = mkTyConApp (sumTyCon arity) arg_tys+             sum_kind = unboxedSumKind arg_reps+       ; checkExpectedKind rn_ty sum_ty sum_kind exp_kind+       }++--------- Promoted lists and tuples+tc_hs_type mode rn_ty@(HsExplicitListTy _ _ tys) exp_kind+  = do { tks <- mapM (tc_infer_lhs_type mode) tys+       ; (taus', kind) <- unifyKinds tys tks+       ; let ty = (foldr (mk_cons kind) (mk_nil kind) taus')+       ; checkExpectedKind rn_ty ty (mkListTy kind) exp_kind }+  where+    mk_cons k a b = mkTyConApp (promoteDataCon consDataCon) [k, a, b]+    mk_nil  k     = mkTyConApp (promoteDataCon nilDataCon) [k]++tc_hs_type mode rn_ty@(HsExplicitTupleTy _ tys) exp_kind+  -- using newMetaKindVar means that we force instantiations of any polykinded+  -- types. At first, I just used tc_infer_lhs_type, but that led to #11255.+  = do { ks   <- replicateM arity newMetaKindVar+       ; taus <- zipWithM (tc_lhs_type mode) tys ks+       ; let kind_con   = tupleTyCon           Boxed arity+             ty_con     = promotedTupleDataCon Boxed arity+             tup_k      = mkTyConApp kind_con ks+       ; checkExpectedKind rn_ty (mkTyConApp ty_con (ks ++ taus)) tup_k exp_kind }+  where+    arity = length tys++--------- Constraint types+tc_hs_type mode rn_ty@(HsIParamTy _ (L _ n) ty) exp_kind+  = do { MASSERT( isTypeLevel (mode_level mode) )+       ; ty' <- tc_lhs_type mode ty liftedTypeKind+       ; let n' = mkStrLitTy $ hsIPNameFS n+       ; ipClass <- tcLookupClass ipClassName+       ; checkExpectedKind rn_ty (mkClassPred ipClass [n',ty'])+                           constraintKind exp_kind }++tc_hs_type _ rn_ty@(HsStarTy _ _) exp_kind+  -- Desugaring 'HsStarTy' to 'Data.Kind.Type' here means that we don't have to+  -- handle it in 'coreView' and 'tcView'.+  = checkExpectedKind rn_ty liftedTypeKind liftedTypeKind exp_kind++--------- Literals+tc_hs_type _ rn_ty@(HsTyLit _ (HsNumTy _ n)) exp_kind+  = do { checkWiredInTyCon typeNatKindCon+       ; checkExpectedKind rn_ty (mkNumLitTy n) typeNatKind exp_kind }++tc_hs_type _ rn_ty@(HsTyLit _ (HsStrTy _ s)) exp_kind+  = do { checkWiredInTyCon typeSymbolKindCon+       ; checkExpectedKind rn_ty (mkStrLitTy s) typeSymbolKind exp_kind }++--------- Potentially kind-polymorphic types: call the "up" checker+-- See Note [Future-proofing the type checker]+tc_hs_type mode ty@(HsTyVar {})            ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsAppTy {})            ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsAppKindTy{})         ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsOpTy {})             ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(HsKindSig {})          ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type mode ty@(XHsType (NHsCoreTy{})) ek = tc_infer_hs_type_ek mode ty ek+tc_hs_type _    wc@(HsWildCardTy _)        ek = tcWildCardOcc wc ek++------------------------------------------+tc_fun_type :: TcTyMode -> LHsType GhcRn -> LHsType GhcRn -> TcKind+            -> TcM TcType+tc_fun_type mode ty1 ty2 exp_kind = case mode_level mode of+  TypeLevel ->+    do { arg_k <- newOpenTypeKind+       ; res_k <- newOpenTypeKind+       ; ty1' <- tc_lhs_type mode ty1 arg_k+       ; ty2' <- tc_lhs_type mode ty2 res_k+       ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkVisFunTy ty1' ty2')+                           liftedTypeKind exp_kind }+  KindLevel ->  -- no representation polymorphism in kinds. yet.+    do { ty1' <- tc_lhs_type mode ty1 liftedTypeKind+       ; ty2' <- tc_lhs_type mode ty2 liftedTypeKind+       ; checkExpectedKind (HsFunTy noExt ty1 ty2) (mkVisFunTy ty1' ty2')+                           liftedTypeKind exp_kind }++---------------------------+tcWildCardOcc :: HsType GhcRn -> Kind -> TcM TcType+tcWildCardOcc wc exp_kind+  = do { wc_tv <- newWildTyVar+          -- The wildcard's kind should be an un-filled-in meta tyvar+       ; loc <- getSrcSpanM+       ; uniq <- newUnique+       ; let name = mkInternalName uniq (mkTyVarOcc "_") loc+       ; part_tysig <- xoptM LangExt.PartialTypeSignatures+       ; warning <- woptM Opt_WarnPartialTypeSignatures+       -- See Note [Wildcards in visible kind application]+       ; unless (part_tysig && not warning)+             (emitWildCardHoleConstraints [(name,wc_tv)])+       ; checkExpectedKind wc (mkTyVarTy wc_tv)+                           (tyVarKind wc_tv) exp_kind }++{- Note [Wildcards in visible kind application]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are cases where users might want to pass in a wildcard as a visible kind+argument, for instance:++data T :: forall k1 k2. k1 → k2 → Type where+  MkT :: T a b+x :: T @_ @Nat False n+x = MkT++So we should allow '@_' without emitting any hole constraints, and+regardless of whether PartialTypeSignatures is enabled or not. But how would+the typechecker know which '_' is being used in VKA and which is not when it+calls emitWildCardHoleConstraints in tcHsPartialSigType on all HsWildCardBndrs?+The solution then is to neither rename nor include unnamed wildcards in HsWildCardBndrs,+but instead give every unnamed wildcard a fresh wild tyvar in tcWildCardOcc.+And whenever we see a '@', we automatically turn on PartialTypeSignatures and+turn off hole constraint warnings, and never call emitWildCardHoleConstraints+under these conditions.+See related Note [Wildcards in visible type application] here and+Note [The wildcard story for types] in HsTypes.hs++-}++{- *********************************************************************+*                                                                      *+                Tuples+*                                                                      *+********************************************************************* -}++---------------------------+tupKindSort_maybe :: TcKind -> Maybe TupleSort+tupKindSort_maybe k+  | Just (k', _) <- splitCastTy_maybe k = tupKindSort_maybe k'+  | Just k'      <- tcView k            = tupKindSort_maybe k'+  | tcIsConstraintKind k = Just ConstraintTuple+  | tcIsLiftedTypeKind k   = Just BoxedTuple+  | otherwise            = Nothing++tc_tuple :: HsType GhcRn -> TcTyMode -> TupleSort -> [LHsType GhcRn] -> TcKind -> TcM TcType+tc_tuple rn_ty mode tup_sort tys exp_kind+  = do { arg_kinds <- case tup_sort of+           BoxedTuple      -> return (replicate arity liftedTypeKind)+           UnboxedTuple    -> replicateM arity newOpenTypeKind+           ConstraintTuple -> return (replicate arity constraintKind)+       ; tau_tys <- zipWithM (tc_lhs_type mode) tys arg_kinds+       ; finish_tuple rn_ty tup_sort tau_tys arg_kinds exp_kind }+  where+    arity   = length tys++finish_tuple :: HsType GhcRn+             -> TupleSort+             -> [TcType]    -- ^ argument types+             -> [TcKind]    -- ^ of these kinds+             -> TcKind      -- ^ expected kind of the whole tuple+             -> TcM TcType+finish_tuple rn_ty tup_sort tau_tys tau_kinds exp_kind+  = do { traceTc "finish_tuple" (ppr res_kind $$ ppr tau_kinds $$ ppr exp_kind)+       ; let arg_tys  = case tup_sort of+                   -- See also Note [Unboxed tuple RuntimeRep vars] in TyCon+                 UnboxedTuple    -> tau_reps ++ tau_tys+                 BoxedTuple      -> tau_tys+                 ConstraintTuple -> tau_tys+       ; tycon <- case tup_sort of+           ConstraintTuple+             | arity > mAX_CTUPLE_SIZE+                         -> failWith (bigConstraintTuple arity)+             | otherwise -> tcLookupTyCon (cTupleTyConName arity)+           BoxedTuple    -> do { let tc = tupleTyCon Boxed arity+                               ; checkWiredInTyCon tc+                               ; return tc }+           UnboxedTuple  -> return (tupleTyCon Unboxed arity)+       ; checkExpectedKind rn_ty (mkTyConApp tycon arg_tys) res_kind exp_kind }+  where+    arity = length tau_tys+    tau_reps = map kindRep tau_kinds+    res_kind = case tup_sort of+                 UnboxedTuple    -> unboxedTupleKind tau_reps+                 BoxedTuple      -> liftedTypeKind+                 ConstraintTuple -> constraintKind++bigConstraintTuple :: Arity -> MsgDoc+bigConstraintTuple arity+  = hang (text "Constraint tuple arity too large:" <+> int arity+          <+> parens (text "max arity =" <+> int mAX_CTUPLE_SIZE))+       2 (text "Instead, use a nested tuple")+++{- *********************************************************************+*                                                                      *+                Type applications+*                                                                      *+********************************************************************* -}++splitHsAppTys :: HsType GhcRn -> Maybe (LHsType GhcRn, [LHsTypeArg GhcRn])+splitHsAppTys hs_ty+  | is_app hs_ty = Just (go (noLoc hs_ty) [])+  | otherwise    = Nothing+  where+    is_app :: HsType GhcRn -> Bool+    is_app (HsAppKindTy {})        = True+    is_app (HsAppTy {})            = True+    is_app (HsOpTy _ _ (L _ op) _) = not (op `hasKey` funTyConKey)+      -- I'm not sure why this funTyConKey test is necessary+      -- Can it even happen?  Perhaps for   t1 `(->)` t2+      -- but then maybe it's ok to treat that like a normal+      -- application rather than using the special rule for HsFunTy+    is_app (HsTyVar {})            = True+    is_app (HsParTy _ (L _ ty))    = is_app ty+    is_app _                       = False++    go (L _  (HsAppTy _ f a))      as = go f (HsValArg a : as)+    go (L _  (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as)+    go (L sp (HsParTy _ f))        as = go f (HsArgPar sp : as)+    go (L _  (HsOpTy _ l op@(L sp _) r)) as+      = ( L sp (HsTyVar noExt NotPromoted op)+        , HsValArg l : HsValArg r : as )+    go f as = (f, as)++---------------------------+tcInferAppHead :: TcTyMode -> LHsType GhcRn -> TcM (TcType, TcKind)+-- Version of tc_infer_lhs_type specialised for the head of an+-- application. In particular, for a HsTyVar (which includes type+-- constructors, it does not zoom off into tcInferApps and family+-- saturation+tcInferAppHead mode (L _ (HsTyVar _ _ (L _ tv)))+  = tcTyVar mode tv+tcInferAppHead mode ty+  = tc_infer_lhs_type mode ty++---------------------------+-- | Apply a type of a given kind to a list of arguments. This instantiates+-- invisible parameters as necessary. Always consumes all the arguments,+-- using matchExpectedFunKind as necessary.+-- This takes an optional @VarEnv Kind@ which maps kind variables to kinds.-+-- These kinds should be used to instantiate invisible kind variables;+-- they come from an enclosing class for an associated type/data family.+--+-- tcInferApps also arranges to saturate any trailing invisible arguments+--   of a type-family application, which is usually the right thing to do+-- tcInferApps_nosat does not do this saturation; it is used only+--   by ":kind" in GHCi+tcInferApps, tcInferApps_nosat+    :: TcTyMode+    -> LHsType GhcRn        -- ^ Function (for printing only)+    -> TcType               -- ^ Function+    -> [LHsTypeArg GhcRn]   -- ^ Args+    -> TcM (TcType, TcKind) -- ^ (f args, args, result kind)+tcInferApps mode hs_ty fun hs_args+  = do { (f_args, res_k) <- tcInferApps_nosat mode hs_ty fun hs_args+       ; saturateFamApp f_args res_k }++tcInferApps_nosat mode orig_hs_ty fun orig_hs_args+  = do { traceTc "tcInferApps {" (ppr orig_hs_ty $$ ppr orig_hs_args)+       ; (f_args, res_k) <- go_init 1 fun orig_hs_args+       ; traceTc "tcInferApps }" (ppr f_args <+> dcolon <+> ppr res_k)+       ; return (f_args, res_k) }+  where++    -- go_init just initialises the auxiliary+    -- arguments of the 'go' loop+    go_init n fun all_args+      = go n fun empty_subst fun_ki all_args+      where+        fun_ki = tcTypeKind fun+           -- We do (tcTypeKind fun) here, even though the caller+           -- knows the function kind, to absolutely guarantee+           -- INVARIANT for 'go'+           -- Note that in a typical application (F t1 t2 t3),+           -- the 'fun' is just a TyCon, so tcTypeKind is fast++        empty_subst = mkEmptyTCvSubst $ mkInScopeSet $+                      tyCoVarsOfType fun_ki++    go :: Int             -- The # of the next argument+       -> TcType          -- Function applied to some args+       -> TCvSubst        -- Applies to function kind+       -> TcKind          -- Function kind+       -> [LHsTypeArg GhcRn]    -- Un-type-checked args+       -> TcM (TcType, TcKind)  -- Result type and its kind+    -- INVARIANT: in any call (go n fun subst fun_ki args)+    --               tcTypeKind fun  =  subst(fun_ki)+    -- So the 'subst' and 'fun_ki' arguments are simply+    -- there to avoid repeatedly calling tcTypeKind.+    --+    -- Reason for INVARIANT: to support the Purely Kinded Type Invariant+    -- it's important that if fun_ki has a forall, then so does+    -- (tcTypeKind fun), because the next thing we are going to do+    -- is apply 'fun' to an argument type.++    -- Dispatch on all_args first, for performance reasons+    go n fun subst fun_ki all_args = case (all_args, tcSplitPiTy_maybe fun_ki) of++      ---------------- No user-written args left. We're done!+      ([], _) -> return (fun, substTy subst fun_ki)++      ---------------- HsArgPar: We don't care about parens here+      (HsArgPar _ : args, _) -> go n fun subst fun_ki args++      ---------------- HsTypeArg: a kind application (fun @ki)+      (HsTypeArg _ hs_ki_arg : hs_args, Just (ki_binder, inner_ki)) ->+        case ki_binder of++        -- FunTy with PredTy on LHS, or ForAllTy with Inferred+        Named (Bndr _ Inferred) -> instantiate ki_binder inner_ki+        Anon InvisArg _         -> instantiate ki_binder inner_ki++        Named (Bndr _ Specified) ->  -- Visible kind application+          do { traceTc "tcInferApps (vis kind app)"+                       (vcat [ ppr ki_binder, ppr hs_ki_arg+                             , ppr (tyBinderType ki_binder)+                             , ppr subst ])++             ; let exp_kind = substTy subst $ tyBinderType ki_binder++             ; ki_arg <- addErrCtxt (funAppCtxt orig_hs_ty hs_ki_arg n) $+                         unsetWOptM Opt_WarnPartialTypeSignatures $+                         setXOptM LangExt.PartialTypeSignatures $+                             -- Urgh!  see Note [Wildcards in visible kind application]+                             -- ToDo: must kill this ridiculous messing with DynFlags+                         tc_lhs_type (kindLevel mode) hs_ki_arg exp_kind++             ; traceTc "tcInferApps (vis kind app)" (ppr exp_kind)+             ; (subst', fun') <- mkAppTyM subst fun ki_binder ki_arg+             ; go (n+1) fun' subst' inner_ki hs_args }++        -- Attempted visible kind application (fun @ki), but fun_ki is+        --   forall k -> blah   or   k1 -> k2+        -- So we need a normal application.  Error.+        _ -> ty_app_err hs_ki_arg $ substTy subst fun_ki++      -- No binder; try applying the substitution, or fail if that's not possible+      (HsTypeArg _ ki_arg : _, Nothing) -> try_again_after_substing_or $+                                           ty_app_err ki_arg substed_fun_ki++      ---------------- HsValArg: a nomal argument (fun ty)+      (HsValArg arg : args, Just (ki_binder, inner_ki))+        -- next binder is invisible; need to instantiate it+        | isInvisibleBinder ki_binder   -- FunTy with InvisArg on LHS;+                                        -- or ForAllTy with Inferred or Specified+         -> instantiate ki_binder inner_ki++        -- "normal" case+        | otherwise+         -> do { traceTc "tcInferApps (vis normal app)"+                          (vcat [ ppr ki_binder+                                , ppr arg+                                , ppr (tyBinderType ki_binder)+                                , ppr subst ])+                ; let exp_kind = substTy subst $ tyBinderType ki_binder+                ; arg' <- addErrCtxt (funAppCtxt orig_hs_ty arg n) $+                          tc_lhs_type mode arg exp_kind+                ; traceTc "tcInferApps (vis normal app) 2" (ppr exp_kind)+                ; (subst', fun') <- mkAppTyM subst fun ki_binder arg'+                ; go (n+1) fun' subst' inner_ki args }++          -- no binder; try applying the substitution, or infer another arrow in fun kind+      (HsValArg _ : _, Nothing)+        -> try_again_after_substing_or $+           do { let arrows_needed = n_initial_val_args all_args+              ; co <- matchExpectedFunKind hs_ty arrows_needed substed_fun_ki++              ; fun' <- zonkTcType (fun `mkTcCastTy` co)+                     -- This zonk is essential, to expose the fruits+                     -- of matchExpectedFunKind to the 'go' loop++              ; traceTc "tcInferApps (no binder)" $+                   vcat [ ppr fun <+> dcolon <+> ppr fun_ki+                        , ppr arrows_needed+                        , ppr co+                        , ppr fun' <+> dcolon <+> ppr (tcTypeKind fun')]+              ; go_init n fun' all_args }+                -- Use go_init to establish go's INVARIANT+      where+        instantiate ki_binder inner_ki+          = do { traceTc "tcInferApps (need to instantiate)"+                         (vcat [ ppr ki_binder, ppr subst])+               ; (subst', arg') <- tcInstInvisibleTyBinder subst ki_binder+               ; go n (mkAppTy fun arg') subst' inner_ki all_args }+                 -- Because tcInvisibleTyBinder instantiate ki_binder,+                 -- the kind of arg' will have the same shape as the kind+                 -- of ki_binder.  So we don't need mkAppTyM here.++        try_again_after_substing_or fallthrough+          | not (isEmptyTCvSubst subst)+          = go n fun zapped_subst substed_fun_ki all_args+          | otherwise+          = fallthrough++        zapped_subst   = zapTCvSubst subst+        substed_fun_ki = substTy subst fun_ki+        hs_ty          = appTypeToArg orig_hs_ty (take (n-1) orig_hs_args)++    n_initial_val_args :: [HsArg tm ty] -> Arity+    -- Count how many leading HsValArgs we have+    n_initial_val_args (HsValArg {} : args) = 1 + n_initial_val_args args+    n_initial_val_args (HsArgPar {} : args) = n_initial_val_args args+    n_initial_val_args _                    = 0++    ty_app_err arg ty+      = failWith $ text "Cannot apply function of kind" <+> quotes (ppr ty)+                $$ text "to visible kind argument" <+> quotes (ppr arg)+++mkAppTyM :: TCvSubst+         -> TcType -> TyCoBinder    -- fun, plus its top-level binder+         -> TcType                  -- arg+         -> TcM (TCvSubst, TcType)  -- Extended subst, plus (fun arg)+-- Precondition: the application (fun arg) is well-kinded after zonking+--               That is, the application makes sense+--+-- Precondition: for (mkAppTyM subst fun bndr arg)+--       tcTypeKind fun  =  Pi bndr. body+--  That is, fun always has a ForAllTy or FunTy at the top+--           and 'bndr' is fun's pi-binder+--+-- Postcondition: if fun and arg satisfy (PKTI), the purely-kinded type+--                invariant, then so does the result type (fun arg)+--+-- We do not require that+--    tcTypeKind arg = tyVarKind (binderVar bndr)+-- This must be true after zonking (precondition 1), but it's not+-- required for the (PKTI).+mkAppTyM subst fun ki_binder arg+  | -- See Note [mkAppTyM]: Nasty case 2+    TyConApp tc args <- fun+  , isTypeSynonymTyCon tc+  , args `lengthIs` (tyConArity tc - 1)+  , any isTrickyTvBinder (tyConTyVars tc) -- We could cache this in the synonym+  = do { arg'  <- zonkTcType  arg+       ; args' <- zonkTcTypes args+       ; let subst' = case ki_binder of+                        Anon {}           -> subst+                        Named (Bndr tv _) -> extendTvSubstAndInScope subst tv arg'+       ; return (subst', mkTyConApp tc (args' ++ [arg'])) }+++mkAppTyM subst fun (Anon {}) arg+   = return (subst, mk_app_ty fun arg)++mkAppTyM subst fun (Named (Bndr tv _)) arg+  = do { arg' <- if isTrickyTvBinder tv+                 then -- See Note [mkAppTyM]: Nasty case 1+                      zonkTcType arg+                 else return     arg+       ; return ( extendTvSubstAndInScope subst tv arg'+                , mk_app_ty fun arg' ) }++mk_app_ty :: TcType -> TcType -> TcType+-- This function just adds an ASSERT for mkAppTyM's precondition+mk_app_ty fun arg+  = ASSERT2( isPiTy fun_kind+           ,  ppr fun <+> dcolon <+> ppr fun_kind $$ ppr arg )+    mkAppTy fun arg+  where+    fun_kind = tcTypeKind fun++isTrickyTvBinder :: TcTyVar -> Bool+-- NB: isTrickyTvBinder is just an optimisation+-- It would be absolutely sound to return True always+isTrickyTvBinder tv = isPiTy (tyVarKind tv)++{- Note [The Purely Kinded Type Invariant (PKTI)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During type inference, we maintain this invariant++ (PKTI) It is legal to call 'tcTypeKind' on any Type ty,+        on any sub-term of ty, /without/ zonking ty++        Moreover, any such returned kind+        will itself satisfy (PKTI)++By "legal to call tcTypeKind" we mean "tcTypeKind will not crash".+The way in which tcTypeKind can crash is in applications+    (a t1 t2 .. tn)+if 'a' is a type variable whose kind doesn't have enough arrows+or foralls.  (The crash is in piResultTys.)++The loop in tcInferApps has to be very careful to maintain the (PKTI).+For example, suppose+    kappa is a unification variable+    We have already unified kappa := Type+      yielding    co :: Refl (Type -> Type)+    a :: kappa+then consider the type+    (a Int)+If we call tcTypeKind on that, we'll crash, because the (un-zonked)+kind of 'a' is just kappa, not an arrow kind.  So we must zonk first.++So the type inference engine is very careful when building applications.+This happens in tcInferApps. Suppose we are kind-checking the type (a Int),+where (a :: kappa).  Then in tcInferApps we'll run out of binders on+a's kind, so we'll call matchExpectedFunKind, and unify+   kappa := kappa1 -> kappa2,  with evidence co :: kappa ~ (kappa1 ~ kappa2)+At this point we must zonk the function type to expose the arrrow, so+that (a Int) will satisfy (PKTI).++The absence of this caused #14174 and #14520.++The calls to mkAppTyM is the other place we are very careful.++Note [mkAppTyM]+~~~~~~~~~~~~~~~+mkAppTyM is trying to guaranteed the Purely Kinded Type Invariant+(PKTI) for its result type (fun arg).  There are two ways it can go wrong:++* Nasty case 1: forall types (polykinds/T14174a)+    T :: forall (p :: *->*). p Int -> p Bool+  Now kind-check (T x), where x::kappa.+  Well, T and x both satisfy the PKTI, but+     T x :: x Int -> x Bool+  and (x Int) does /not/ satisfy the PKTI.++* Nasty case 2: type synonyms+    type S f a = f a+  Even though (S ff aa) would satisfy the (PKTI) if S was a data type+  (i.e. nasty case 1 is dealt with), it might still not satisfy (PKTI)+  if S is a type synonym, because the /expansion/ of (S ff aa) is+  (ff aa), and /that/ does not satisfy (PKTI).  E.g. perhaps+  (ff :: kappa), where 'kappa' has already been unified with (*->*).++  We check for nasty case 2 on the final argument of a type synonym.++Notice that in both cases the trickiness only happens if the+bound variable has a pi-type.  Hence isTrickyTvBinder.+-}+++saturateFamApp :: TcType -> TcKind -> TcM (TcType, TcKind)+-- Precondition for (saturateFamApp ty kind):+--     tcTypeKind ty = kind+--+-- If 'ty' is an unsaturated family application wtih trailing+-- invisible arguments, instanttiate them.+-- See Note [saturateFamApp]++saturateFamApp ty kind+  | Just (tc, args) <- tcSplitTyConApp_maybe ty+  , mustBeSaturated tc+  , let n_to_inst = tyConArity tc - length args+  = do { (extra_args, ki') <- tcInstInvisibleTyBinders n_to_inst kind+       ; return (ty `mkTcAppTys` extra_args, ki') }+  | otherwise+  = return (ty, kind)++{- Note [saturateFamApp]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   type family F :: Either j k+   type instance F @Type = Right Maybe+   type instance F @Type = Right Either```++Then F :: forall {j,k}. Either j k++The two type instances do a visible kind application that instantiates+'j' but not 'k'.  But we want to end up with instances that look like+  type instance F @Type @(*->*) = Right @Type @(*->*) Maybe++so that F has arity 2.  We must instantiate that trailing invisible+binder. In general, Invisible binders precede Specified and Required,+so this is only going to bite for apparently-nullary families.++Note that+  type family F2 :: forall k. k -> *+is quite different and really does have arity 0.++It's not just type instances where we need to saturate those+unsaturated arguments: see #11246.  Hence doing this in tcInferApps.+-}++appTypeToArg :: LHsType GhcRn -> [LHsTypeArg GhcRn] -> LHsType GhcRn+appTypeToArg f []                       = f+appTypeToArg f (HsValArg arg    : args) = appTypeToArg (mkHsAppTy f arg) args+appTypeToArg f (HsArgPar _      : args) = appTypeToArg f                 args+appTypeToArg f (HsTypeArg l arg : args)+  = appTypeToArg (mkHsAppKindTy l f arg) args+++{- *********************************************************************+*                                                                      *+                checkExpectedKind+*                                                                      *+********************************************************************* -}++-- | This instantiates invisible arguments for the type being checked if it must+-- be saturated and is not yet saturated. It then calls and uses the result+-- from checkExpectedKindX to build the final type+checkExpectedKind :: HasDebugCallStack+                  => HsType GhcRn       -- ^ type we're checking (for printing)+                  -> TcType             -- ^ type we're checking+                  -> TcKind             -- ^ the known kind of that type+                  -> TcKind             -- ^ the expected kind+                  -> TcM TcType+-- Just a convenience wrapper to save calls to 'ppr'+checkExpectedKind hs_ty ty act exp+  = checkExpectedKind_pp (ppr hs_ty) ty act exp++checkExpectedKind_pp :: HasDebugCallStack+                     => SDoc               -- ^ The thing we are checking+                     -> TcType             -- ^ type we're checking+                     -> TcKind             -- ^ the known kind of that type+                     -> TcKind             -- ^ the expected kind+                     -> TcM TcType+checkExpectedKind_pp pp_hs_ty ty act_kind exp_kind+  = do { traceTc "checkExpectedKind" (ppr ty $$ ppr act_kind)++       ; (new_args, act_kind') <- tcInstInvisibleTyBinders n_to_inst act_kind++       ; let origin = TypeEqOrigin { uo_actual   = act_kind'+                                   , uo_expected = exp_kind+                                   , uo_thing    = Just pp_hs_ty+                                   , uo_visible  = True } -- the hs_ty is visible++       ; traceTc "checkExpectedKindX" $+         vcat [ pp_hs_ty+              , text "act_kind':" <+> ppr act_kind'+              , text "exp_kind:" <+> ppr exp_kind ]++       ; let res_ty = ty `mkTcAppTys` new_args++       ; if act_kind' `tcEqType` exp_kind+         then return res_ty  -- This is very common+         else do { co_k <- uType KindLevel origin act_kind' exp_kind+                 ; traceTc "checkExpectedKind" (vcat [ ppr act_kind+                                                     , ppr exp_kind+                                                     , ppr co_k ])+                ; return (res_ty `mkTcCastTy` co_k) } }+    where+      -- We need to make sure that both kinds have the same number of implicit+      -- foralls out front. If the actual kind has more, instantiate accordingly.+      -- Otherwise, just pass the type & kind through: the errors are caught+      -- in unifyType.+      n_exp_invis_bndrs = invisibleTyBndrCount exp_kind+      n_act_invis_bndrs = invisibleTyBndrCount act_kind+      n_to_inst         = n_act_invis_bndrs - n_exp_invis_bndrs+++---------------------------+tcHsMbContext :: Maybe (LHsContext GhcRn) -> TcM [PredType]+tcHsMbContext Nothing    = return []+tcHsMbContext (Just cxt) = tcHsContext cxt++tcHsContext :: LHsContext GhcRn -> TcM [PredType]+tcHsContext = tc_hs_context typeLevelMode++tcLHsPredType :: LHsType GhcRn -> TcM PredType+tcLHsPredType = tc_lhs_pred typeLevelMode++tc_hs_context :: TcTyMode -> LHsContext GhcRn -> TcM [PredType]+tc_hs_context mode ctxt = mapM (tc_lhs_pred mode) (unLoc ctxt)++tc_lhs_pred :: TcTyMode -> LHsType GhcRn -> TcM PredType+tc_lhs_pred mode pred = tc_lhs_type mode pred constraintKind++---------------------------+tcTyVar :: TcTyMode -> Name -> TcM (TcType, TcKind)+-- See Note [Type checking recursive type and class declarations]+-- in TcTyClsDecls+tcTyVar mode name         -- Could be a tyvar, a tycon, or a datacon+  = do { traceTc "lk1" (ppr name)+       ; thing <- tcLookup name+       ; case thing of+           ATyVar _ tv -> return (mkTyVarTy tv, tyVarKind tv)++           ATcTyCon tc_tc+             -> do { -- See Note [GADT kind self-reference]+                     unless (isTypeLevel (mode_level mode))+                            (promotionErr name TyConPE)+                   ; check_tc tc_tc+                   ; return (mkTyConTy tc_tc, tyConKind tc_tc) }++           AGlobal (ATyCon tc)+             -> do { check_tc tc+                   ; return (mkTyConTy tc, tyConKind tc) }++           AGlobal (AConLike (RealDataCon dc))+             -> do { data_kinds <- xoptM LangExt.DataKinds+                   ; unless (data_kinds || specialPromotedDc dc) $+                       promotionErr name NoDataKindsDC+                   ; when (isFamInstTyCon (dataConTyCon dc)) $+                       -- see #15245+                       promotionErr name FamDataConPE+                   ; let (_, _, _, theta, _, _) = dataConFullSig dc+                   ; traceTc "tcTyVar" (ppr dc <+> ppr theta $$ ppr (dc_theta_illegal_constraint theta))+                   ; case dc_theta_illegal_constraint theta of+                       Just pred -> promotionErr name $+                                    ConstrainedDataConPE pred+                       Nothing   -> pure ()+                   ; let tc = promoteDataCon dc+                   ; return (mkTyConApp tc [], tyConKind tc) }++           APromotionErr err -> promotionErr name err++           _  -> wrongThingErr "type" thing name }+  where+    check_tc :: TyCon -> TcM ()+    check_tc tc = do { data_kinds   <- xoptM LangExt.DataKinds+                     ; unless (isTypeLevel (mode_level mode) ||+                               data_kinds ||+                               isKindTyCon tc) $+                       promotionErr name NoDataKindsTC }++    -- We cannot promote a data constructor with a context that contains+    -- constraints other than equalities, so error if we find one.+    -- See Note [Constraints in kinds] in TyCoRep+    dc_theta_illegal_constraint :: ThetaType -> Maybe PredType+    dc_theta_illegal_constraint = find (not . isEqPred)++{-+Note [GADT kind self-reference]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++A promoted type cannot be used in the body of that type's declaration.+#11554 shows this example, which made GHC loop:++  import Data.Kind+  data P (x :: k) = Q+  data A :: Type where+    B :: forall (a :: A). P a -> A++In order to check the constructor B, we need to have the promoted type A, but in+order to get that promoted type, B must first be checked. To prevent looping, a+TyConPE promotion error is given when tcTyVar checks an ATcTyCon in kind mode.+Any ATcTyCon is a TyCon being defined in the current recursive group (see data+type decl for TcTyThing), and all such TyCons are illegal in kinds.++#11962 proposes checking the head of a data declaration separately from+its constructors. This would allow the example above to pass.++Note [Body kind of a HsForAllTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The body of a forall is usually a type, but in principle+there's no reason to prohibit *unlifted* types.+In fact, GHC can itself construct a function with an+unboxed tuple inside a for-all (via CPR analysis; see+typecheck/should_compile/tc170).++Moreover in instance heads we get forall-types with+kind Constraint.++It's tempting to check that the body kind is either * or #. But this is+wrong. For example:++  class C a b+  newtype N = Mk Foo deriving (C a)++We're doing newtype-deriving for C. But notice how `a` isn't in scope in+the predicate `C a`. So we quantify, yielding `forall a. C a` even though+`C a` has kind `* -> Constraint`. The `forall a. C a` is a bit cheeky, but+convenient. Bottom line: don't check for * or # here.++Note [Body kind of a HsQualTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If ctxt is non-empty, the HsQualTy really is a /function/, so the+kind of the result really is '*', and in that case the kind of the+body-type can be lifted or unlifted.++However, consider+    instance Eq a => Eq [a] where ...+or+    f :: (Eq a => Eq [a]) => blah+Here both body-kind of the HsQualTy is Constraint rather than *.+Rather crudely we tell the difference by looking at exp_kind. It's+very convenient to typecheck instance types like any other HsSigType.++Admittedly the '(Eq a => Eq [a]) => blah' case is erroneous, but it's+better to reject in checkValidType.  If we say that the body kind+should be '*' we risk getting TWO error messages, one saying that Eq+[a] doens't have kind '*', and one saying that we need a Constraint to+the left of the outer (=>).++How do we figure out the right body kind?  Well, it's a bit of a+kludge: I just look at the expected kind.  If it's Constraint, we+must be in this instance situation context. It's a kludge because it+wouldn't work if any unification was involved to compute that result+kind -- but it isn't.  (The true way might be to use the 'mode'+parameter, but that seemed like a sledgehammer to crack a nut.)++Note [Inferring tuple kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Give a tuple type (a,b,c), which the parser labels as HsBoxedOrConstraintTuple,+we try to figure out whether it's a tuple of kind * or Constraint.+  Step 1: look at the expected kind+  Step 2: infer argument kinds++If after Step 2 it's not clear from the arguments that it's+Constraint, then it must be *.  Once having decided that we re-check+the arguments to give good error messages in+  e.g.  (Maybe, Maybe)++Note that we will still fail to infer the correct kind in this case:++  type T a = ((a,a), D a)+  type family D :: Constraint -> Constraint++While kind checking T, we do not yet know the kind of D, so we will default the+kind of T to * -> *. It works if we annotate `a` with kind `Constraint`.++Note [Desugaring types]+~~~~~~~~~~~~~~~~~~~~~~~+The type desugarer is phase 2 of dealing with HsTypes.  Specifically:++  * It transforms from HsType to Type++  * It zonks any kinds.  The returned type should have no mutable kind+    or type variables (hence returning Type not TcType):+      - any unconstrained kind variables are defaulted to (Any *) just+        as in TcHsSyn.+      - there are no mutable type variables because we are+        kind-checking a type+    Reason: the returned type may be put in a TyCon or DataCon where+    it will never subsequently be zonked.++You might worry about nested scopes:+        ..a:kappa in scope..+            let f :: forall b. T '[a,b] -> Int+In this case, f's type could have a mutable kind variable kappa in it;+and we might then default it to (Any *) when dealing with f's type+signature.  But we don't expect this to happen because we can't get a+lexically scoped type variable with a mutable kind variable in it.  A+delicate point, this.  If it becomes an issue we might need to+distinguish top-level from nested uses.++Moreover+  * it cannot fail,+  * it does no unifications+  * it does no validity checking, except for structural matters, such as+        (a) spurious ! annotations.+        (b) a class used as a type++Note [Kind of a type splice]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these terms, each with TH type splice inside:+     [| e1 :: Maybe $(..blah..) |]+     [| e2 :: $(..blah..) |]+When kind-checking the type signature, we'll kind-check the splice+$(..blah..); we want to give it a kind that can fit in any context,+as if $(..blah..) :: forall k. k.++In the e1 example, the context of the splice fixes kappa to *.  But+in the e2 example, we'll desugar the type, zonking the kind unification+variables as we go.  When we encounter the unconstrained kappa, we+want to default it to '*', not to (Any *).++Help functions for type applications+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-}++addTypeCtxt :: LHsType GhcRn -> TcM a -> TcM a+        -- Wrap a context around only if we want to show that contexts.+        -- Omit invisible ones and ones user's won't grok+addTypeCtxt (L _ (HsWildCardTy _)) thing = thing   -- "In the type '_'" just isn't helpful.+addTypeCtxt (L _ ty) thing+  = addErrCtxt doc thing+  where+    doc = text "In the type" <+> quotes (ppr ty)++{-+************************************************************************+*                                                                      *+                Type-variable binders+%*                                                                      *+%************************************************************************++Note [Keeping scoped variables in order: Explicit]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the user writes `forall a b c. blah`, we bring a, b, and c into+scope and then check blah. In the process of checking blah, we might+learn the kinds of a, b, and c, and these kinds might indicate that+b depends on c, and thus that we should reject the user-written type.++One approach to doing this would be to bring each of a, b, and c into+scope, one at a time, creating an implication constraint and+bumping the TcLevel for each one. This would work, because the kind+of, say, b would be untouchable when c is in scope (and the constraint+couldn't float out because c blocks it). However, it leads to terrible+error messages, complaining about skolem escape. While it is indeed+a problem of skolem escape, we can do better.++Instead, our approach is to bring the block of variables into scope+all at once, creating one implication constraint for the lot. The+user-written variables are skolems in the implication constraint. In+TcSimplify.setImplicationStatus, we check to make sure that the ordering+is correct, choosing ImplicationStatus IC_BadTelescope if they aren't.+Then, in TcErrors, we report if there is a bad telescope. This way,+we can report a suggested ordering to the user if there is a problem.++Note [Keeping scoped variables in order: Implicit]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the user implicitly quantifies over variables (say, in a type+signature), we need to come up with some ordering on these variables.+This is done by bumping the TcLevel, bringing the tyvars into scope,+and then type-checking the thing_inside. The constraints are all+wrapped in an implication, which is then solved. Finally, we can+zonk all the binders and then order them with scopedSort.++It's critical to solve before zonking and ordering in order to uncover+any unifications. You might worry that this eager solving could cause+trouble elsewhere. I don't think it will. Because it will solve only+in an increased TcLevel, it can't unify anything that was mentioned+elsewhere. Additionally, we require that the order of implicitly+quantified variables is manifest by the scope of these variables, so+we're not going to learn more information later that will help order+these variables.++Note [Recipe for checking a signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Checking a user-written signature requires several steps:++ 1. Generate constraints.+ 2. Solve constraints.+ 3. Zonk.+ 4. Promote tyvars and/or kind-generalize.+ 5. Zonk.+ 6. Check validity.++There may be some surprises in here:++Step 2 is necessary for two reasons: most signatures also bring+implicitly quantified variables into scope, and solving is necessary+to get these in the right order (see Note [Keeping scoped variables in+order: Implicit]). Additionally, solving is necessary in order to+kind-generalize correctly.++In Step 4, we have to deal with the fact that metatyvars generated+in the type may have a bumped TcLevel, because explicit foralls+raise the TcLevel. To avoid these variables from ever being visible+in the surrounding context, we must obey the following dictum:++  Every metavariable in a type must either be+    (A) promoted+    (B) generalized, or+    (C) zapped to Any++If a variable is generalized, then it becomes a skolem and no longer+has a proper TcLevel. (I'm ignoring the TcLevel on a skolem here, as+it's not really in play here.) On the other hand, if it is not+generalized (because we're not generalizing the construct -- e.g., pattern+sig -- or because the metavars are constrained -- see kindGeneralizeLocal)+we need to promote to maintain (MetaTvInv) of Note [TcLevel and untouchable type variables]+in TcType.++For more about (C), see Note [Naughty quantification candidates] in TcMType.++After promoting/generalizing, we need to zonk *again* because both+promoting and generalizing fill in metavariables.++To avoid the double-zonk, we do two things:+ 1. When we're not generalizing:+    zonkPromoteType and friends zonk and promote at the same time.+    Accordingly, the function does steps 3-5 all at once, preventing+    the need for multiple traversals.++ 2. When we are generalizing:+    kindGeneralize does not require a zonked type -- it zonks as it+    gathers free variables. So this way effectively sidesteps step 3.+-}++tcWildCardBinders :: [Name]+                  -> ([(Name, TcTyVar)] -> TcM a)+                  -> TcM a+tcWildCardBinders wc_names thing_inside+  = do { wcs <- mapM (const newWildTyVar) wc_names+       ; let wc_prs = wc_names `zip` wcs+       ; tcExtendNameTyVarEnv wc_prs $+         thing_inside wc_prs }++newWildTyVar :: TcM TcTyVar+-- ^ New unification variable for a wildcard+newWildTyVar+  = do { kind <- newMetaKindVar+       ; uniq <- newUnique+       ; details <- newMetaDetails TauTv+       ; let name = mkSysTvName uniq (fsLit "_")+             tyvar = (mkTcTyVar name kind details)+       ; traceTc "newWildTyVar" (ppr tyvar)+       ; return tyvar }++{- *********************************************************************+*                                                                      *+             Kind inference for type declarations+*                                                                      *+********************************************************************* -}++{- Note [The initial kind of a type constructor]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+kcLHsQTyVars is responsible for getting the initial kind of+a type constructor.++It has two cases:++ * The TyCon has a CUSK.  In that case, find the full, final,+   poly-kinded kind of the TyCon.  It's very like a term-level+   binding where we have a complete type signature for the+   function.++ * It does not have a CUSK.  Find a monomorphic kind, with+   unification variables in it; they will be generalised later.+   It's very like a term-level binding where we do not have+   a type signature (or, more accurately, where we have a+   partial type signature), so we infer the type and generalise.+-}+++------------------------------+-- | Kind-check a 'LHsQTyVars'. If the decl under consideration has a complete,+-- user-supplied kind signature (CUSK), generalise the result.+-- Used in 'getInitialKind' (for tycon kinds and other kinds)+-- and in kind-checking (but not for tycon kinds, which are checked with+-- tcTyClDecls). See Note [CUSKs: complete user-supplied kind signatures]+-- in HsDecls.+--+-- This function does not do telescope checking.+kcLHsQTyVars :: Name              -- ^ of the thing being checked+             -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+             -> Bool              -- ^ True <=> the decl being checked has a CUSK+             -> LHsQTyVars GhcRn+             -> TcM Kind          -- ^ The result kind+             -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon+kcLHsQTyVars name flav cusk tvs thing_inside+  | cusk      = kcLHsQTyVars_Cusk    name flav tvs thing_inside+  | otherwise = kcLHsQTyVars_NonCusk name flav tvs thing_inside+++kcLHsQTyVars_Cusk, kcLHsQTyVars_NonCusk+    :: Name              -- ^ of the thing being checked+    -> TyConFlavour      -- ^ What sort of 'TyCon' is being checked+    -> LHsQTyVars GhcRn+    -> TcM Kind          -- ^ The result kind+    -> TcM TcTyCon       -- ^ A suitably-kinded TcTyCon++------------------------------+kcLHsQTyVars_Cusk name flav+              (HsQTvs { hsq_ext = kv_ns+                      , hsq_explicit = hs_tvs }) thing_inside+  -- CUSK case+  -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls+  = addTyConFlavCtxt name flav $+    do { (scoped_kvs, (tc_tvs, res_kind))+           <- pushTcLevelM_                               $+              solveEqualities                             $+              bindImplicitTKBndrs_Q_Skol kv_ns            $+              bindExplicitTKBndrs_Q_Skol ctxt_kind hs_tvs $+              thing_inside++           -- Now, because we're in a CUSK,+           -- we quantify over the mentioned kind vars+       ; let spec_req_tkvs = scoped_kvs ++ tc_tvs+             all_kinds     = res_kind : map tyVarKind spec_req_tkvs++       ; candidates <- candidateQTyVarsOfKinds all_kinds+             -- 'candidates' are all the variables that we are going to+             -- skolemise and then quantify over.  We do not include spec_req_tvs+             -- because they are /already/ skolems++       ; let inf_candidates = candidates `delCandidates` spec_req_tkvs++       ; inferred <- quantifyTyVars emptyVarSet inf_candidates+                     -- NB: 'inferred' comes back sorted in dependency order++       ; scoped_kvs <- mapM zonkTyCoVarKind scoped_kvs+       ; tc_tvs     <- mapM zonkTyCoVarKind tc_tvs+       ; res_kind   <- zonkTcType           res_kind++       ; let mentioned_kv_set = candidateKindVars candidates+             specified        = scopedSort scoped_kvs+                                -- NB: maintain the L-R order of scoped_kvs++             final_tc_binders =  mkNamedTyConBinders Inferred  inferred+                              ++ mkNamedTyConBinders Specified specified+                              ++ map (mkRequiredTyConBinder mentioned_kv_set) tc_tvs++             all_tv_prs = mkTyVarNamePairs (scoped_kvs ++ tc_tvs)+             tycon = mkTcTyCon name final_tc_binders res_kind all_tv_prs+                               True {- it is generalised -} flav+         -- If the ordering from+         -- Note [Required, Specified, and Inferred for types] in TcTyClsDecls+         -- doesn't work, we catch it here, before an error cascade+       ; checkTyConTelescope tycon++       ; traceTc "kcLHsQTyVars: cusk" $+         vcat [ text "name" <+> ppr name+              , text "kv_ns" <+> ppr kv_ns+              , text "hs_tvs" <+> ppr hs_tvs+              , text "scoped_kvs" <+> ppr scoped_kvs+              , text "tc_tvs" <+> ppr tc_tvs+              , text "res_kind" <+> ppr res_kind+              , text "candidates" <+> ppr candidates+              , text "inferred" <+> ppr inferred+              , text "specified" <+> ppr specified+              , text "final_tc_binders" <+> ppr final_tc_binders+              , text "mkTyConKind final_tc_bndrs res_kind"+                <+> ppr (mkTyConKind final_tc_binders res_kind)+              , text "all_tv_prs" <+> ppr all_tv_prs ]++       ; return tycon }+  where+    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind+              | otherwise            = AnyKind++kcLHsQTyVars_Cusk _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars"++------------------------------+kcLHsQTyVars_NonCusk name flav+              (HsQTvs { hsq_ext = kv_ns+                      , hsq_explicit = hs_tvs }) thing_inside+  -- Non_CUSK case+  -- See note [Required, Specified, and Inferred for types] in TcTyClsDecls+  = do { (scoped_kvs, (tc_tvs, res_kind))+           -- Why bindImplicitTKBndrs_Q_Tv which uses newTyVarTyVar?+           -- See Note [Inferring kinds for type declarations] in TcTyClsDecls+           <- bindImplicitTKBndrs_Q_Tv kv_ns            $+              bindExplicitTKBndrs_Q_Tv ctxt_kind hs_tvs $+              thing_inside+              -- Why "_Tv" not "_Skol"? See third wrinkle in+              -- Note [Inferring kinds for type declarations] in TcTyClsDecls,++       ; let   -- NB: Don't add scoped_kvs to tyConTyVars, because they+               -- might unify with kind vars in other types in a mutually+               -- recursive group.+               -- See Note [Inferring kinds for type declarations] in TcTyClsDecls++             tc_binders = mkAnonTyConBinders VisArg tc_tvs+               -- Also, note that tc_binders has the tyvars from only the+               -- user-written tyvarbinders. See S1 in Note [How TcTyCons work]+               -- in TcTyClsDecls+               --+               -- mkAnonTyConBinder: see Note [No polymorphic recursion]++             all_tv_prs = (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]++             tycon = mkTcTyCon name tc_binders res_kind all_tv_prs+                               False -- not yet generalised+                               flav++       ; traceTc "kcLHsQTyVars: not-cusk" $+         vcat [ ppr name, ppr kv_ns, ppr hs_tvs+              , ppr scoped_kvs+              , ppr tc_tvs, ppr (mkTyConKind tc_binders res_kind) ]+       ; return tycon }+  where+    ctxt_kind | tcFlavourIsOpen flav = TheKind liftedTypeKind+              | otherwise            = AnyKind++kcLHsQTyVars_NonCusk _ _ (XLHsQTyVars _) _ = panic "kcLHsQTyVars"+++{- Note [No polymorphic recursion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should this kind-check?+  data T ka (a::ka) b  = MkT (T Type           Int   Bool)+                             (T (Type -> Type) Maybe Bool)++Notice that T is used at two different kinds in its RHS.  No!+This should not kind-check.  Polymorphic recursion is known to+be a tough nut.++Previously, we laboriously (with help from the renamer)+tried to give T the polymoprhic kind+   T :: forall ka -> ka -> kappa -> Type+where kappa is a unification variable, even in the getInitialKinds+phase (which is what kcLHsQTyVars_NonCusk is all about).  But+that is dangerously fragile (see the ticket).++Solution: make kcLHsQTyVars_NonCusk give T a straightforward+monomorphic kind, with no quantification whatsoever. That's why+we use mkAnonTyConBinder for all arguments when figuring out+tc_binders.++But notice that (#16322 comment:3)++* The algorithm successfully kind-checks this declaration:+    data T2 ka (a::ka) = MkT2 (T2 Type a)++  Starting with (getInitialKinds)+    T2 :: (kappa1 :: kappa2 :: *) -> (kappa3 :: kappa4 :: *) -> *+  we get+    kappa4 := kappa1   -- from the (a:ka) kind signature+    kappa1 := Type     -- From application T2 Type++  These constraints are soluble so generaliseTcTyCon gives+    T2 :: forall (k::Type) -> k -> *++  But now the /typechecking/ (aka desugaring, tcTyClDecl) phase+  fails, because the call (T2 Type a) in the RHS is ill-kinded.++  We'd really prefer all errors to show up in the kind checking+  phase.++* This algorithm still accepts (in all phases)+     data T3 ka (a::ka) = forall b. MkT3 (T3 Type b)+  although T3 is really polymorphic-recursive too.+  Perhaps we should somehow reject that.++Note [Kind-checking tyvar binders for associated types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When kind-checking the type-variable binders for associated+   data/newtype decls+   family decls+we behave specially for type variables that are already in scope;+that is, bound by the enclosing class decl.  This is done in+kcLHsQTyVarBndrs:+  * The use of tcImplicitQTKBndrs+  * The tcLookupLocal_maybe code in kc_hs_tv++See Note [Associated type tyvar names] in Class and+    Note [TyVar binders for associated decls] in HsDecls++We must do the same for family instance decls, where the in-scope+variables may be bound by the enclosing class instance decl.+Hence the use of tcImplicitQTKBndrs in tcFamTyPatsAndGen.++Note [Kind variable ordering for associated types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What should be the kind of `T` in the following example? (#15591)++  class C (a :: Type) where+    type T (x :: f a)++As per Note [Ordering of implicit variables] in RnTypes, we want to quantify+the kind variables in left-to-right order of first occurrence in order to+support visible kind application. But we cannot perform this analysis on just+T alone, since its variable `a` actually occurs /before/ `f` if you consider+the fact that `a` was previously bound by the parent class `C`. That is to say,+the kind of `T` should end up being:++  T :: forall a f. f a -> Type++(It wouldn't necessarily be /wrong/ if the kind ended up being, say,+forall f a. f a -> Type, but that would not be as predictable for users of+visible kind application.)++In contrast, if `T` were redefined to be a top-level type family, like `T2`+below:++  type family T2 (x :: f (a :: Type))++Then `a` first appears /after/ `f`, so the kind of `T2` should be:++  T2 :: forall f a. f a -> Type++In order to make this distinction, we need to know (in kcLHsQTyVars) which+type variables have been bound by the parent class (if there is one). With+the class-bound variables in hand, we can ensure that we always quantify+these first.+-}+++{- *********************************************************************+*                                                                      *+             Expected kinds+*                                                                      *+********************************************************************* -}++-- | Describes the kind expected in a certain context.+data ContextKind = TheKind Kind   -- ^ a specific kind+                 | AnyKind        -- ^ any kind will do+                 | OpenKind       -- ^ something of the form @TYPE _@++-----------------------+newExpectedKind :: ContextKind -> TcM Kind+newExpectedKind (TheKind k) = return k+newExpectedKind AnyKind     = newMetaKindVar+newExpectedKind OpenKind    = newOpenTypeKind++-----------------------+expectedKindInCtxt :: UserTypeCtxt -> ContextKind+-- Depending on the context, we might accept any kind (for instance, in a TH+-- splice), or only certain kinds (like in type signatures).+expectedKindInCtxt (TySynCtxt _)   = AnyKind+expectedKindInCtxt ThBrackCtxt     = AnyKind+expectedKindInCtxt (GhciCtxt {})   = AnyKind+-- The types in a 'default' decl can have varying kinds+-- See Note [Extended defaults]" in TcEnv+expectedKindInCtxt DefaultDeclCtxt     = AnyKind+expectedKindInCtxt TypeAppCtxt         = AnyKind+expectedKindInCtxt (ForSigCtxt _)      = TheKind liftedTypeKind+expectedKindInCtxt (InstDeclCtxt {})   = TheKind constraintKind+expectedKindInCtxt SpecInstCtxt        = TheKind constraintKind+expectedKindInCtxt _                   = OpenKind+++{- *********************************************************************+*                                                                      *+             Bringing type variables into scope+*                                                                      *+********************************************************************* -}++--------------------------------------+-- Implicit binders+--------------------------------------++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)++bindImplicitTKBndrsX+   :: (Name -> TcM TcTyVar) -- new_tv function+   -> [Name]+   -> TcM a+   -> TcM ([TcTyVar], a)   -- Returned [TcTyVar] are in 1-1 correspondence+                           -- with the passed in [Name]+bindImplicitTKBndrsX new_tv tv_names thing_inside+  = do { tkvs <- mapM new_tv tv_names+       ; traceTc "bindImplicitTKBndrs" (ppr tv_names $$ ppr tkvs)+       ; res <- tcExtendNameTyVarEnv (tv_names `zip` tkvs)+                thing_inside+       ; return (tkvs, res) }++newImplicitTyVarQ :: (Name -> TcM TcTyVar) ->  Name -> TcM TcTyVar+-- Behave like new_tv, except that if the tyvar is in scope, use it+newImplicitTyVarQ new_tv name+  = do { mb_tv <- tcLookupLcl_maybe name+       ; case mb_tv of+           Just (ATyVar _ tv) -> return tv+           _ -> new_tv name }++newFlexiKindedTyVar :: (Name -> Kind -> TcM TyVar) -> Name -> TcM TyVar+newFlexiKindedTyVar new_tv name+  = do { kind <- newMetaKindVar+       ; new_tv name kind }++newFlexiKindedSkolemTyVar :: Name -> TcM TyVar+newFlexiKindedSkolemTyVar = newFlexiKindedTyVar newSkolemTyVar++newFlexiKindedTyVarTyVar :: Name -> TcM TyVar+newFlexiKindedTyVarTyVar = newFlexiKindedTyVar newTyVarTyVar+   -- See Note [Unification variables need fresh Names] in TcMType++--------------------------------------+-- Explicit binders+--------------------------------------++bindExplicitTKBndrs_Skol, bindExplicitTKBndrs_Tv+    :: [LHsTyVarBndr GhcRn]+    -> TcM a+    -> TcM ([TcTyVar], a)++bindExplicitTKBndrs_Skol = bindExplicitTKBndrsX (tcHsTyVarBndr newSkolemTyVar)+bindExplicitTKBndrs_Tv   = bindExplicitTKBndrsX (tcHsTyVarBndr newTyVarTyVar)++bindExplicitTKBndrs_Q_Skol, bindExplicitTKBndrs_Q_Tv+    :: ContextKind+    -> [LHsTyVarBndr GhcRn]+    -> TcM a+    -> TcM ([TcTyVar], a)++bindExplicitTKBndrs_Q_Skol ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newSkolemTyVar)+bindExplicitTKBndrs_Q_Tv   ctxt_kind = bindExplicitTKBndrsX (tcHsQTyVarBndr ctxt_kind newTyVarTyVar)++-- | Used during the "kind-checking" pass in TcTyClsDecls only,+-- and even then only for data-con declarations.+bindExplicitTKBndrsX+    :: (HsTyVarBndr GhcRn -> TcM TcTyVar)+    -> [LHsTyVarBndr GhcRn]+    -> TcM a+    -> TcM ([TcTyVar], a)  -- Returned [TcTyVar] are in 1-1 correspondence+                           -- with the passed-in [LHsTyVarBndr]+bindExplicitTKBndrsX tc_tv hs_tvs thing_inside+  = do { traceTc "bindExplicTKBndrs" (ppr hs_tvs)+       ; go hs_tvs }+  where+    go [] = do { res <- thing_inside+               ; return ([], res) }+    go (L _ hs_tv : hs_tvs)+       = do { tv <- tc_tv hs_tv+            -- Extend the environment as we go, in case a binder+            -- is mentioned in the kind of a later binder+            --   e.g. forall k (a::k). blah+            -- NB: tv's Name may differ from hs_tv's+            -- See TcMType Note [Unification variables need fresh Names]+            ; (tvs,res) <- tcExtendNameTyVarEnv [(hsTyVarName hs_tv, tv)] $+                           go hs_tvs+            ; return (tv:tvs, res) }++-----------------+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 }+tcHsTyVarBndr new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind)+  = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind+       ; new_tv tv_nm kind }+tcHsTyVarBndr _ (XTyVarBndr _) = panic "tcHsTyVarBndr"++-----------------+tcHsQTyVarBndr :: ContextKind+               -> (Name -> Kind -> TcM TyVar)+               -> HsTyVarBndr GhcRn -> TcM TcTyVar+-- Just like tcHsTyVarBndr, but also+--   - uses the in-scope TyVar from class, if it exists+--   - takes a ContextKind to use for the no-sig case+tcHsQTyVarBndr ctxt_kind new_tv (UserTyVar _ (L _ tv_nm))+  = do { mb_tv <- tcLookupLcl_maybe tv_nm+       ; case mb_tv of+           Just (ATyVar _ tv) -> return tv+           _ -> do { kind <- newExpectedKind ctxt_kind+                   ; new_tv tv_nm kind } }++tcHsQTyVarBndr _ new_tv (KindedTyVar _ (L _ tv_nm) lhs_kind)+  = do { kind <- tcLHsKindSig (TyVarBndrKindCtxt tv_nm) lhs_kind+       ; mb_tv <- tcLookupLcl_maybe tv_nm+       ; case mb_tv of+           Just (ATyVar _ tv)+             -> do { discardResult $ unifyKind (Just hs_tv)+                                        kind (tyVarKind tv)+                       -- This unify rejects:+                       --    class C (m :: * -> *) where+                       --      type F (m :: *) = ...+                   ; return tv }++           _ -> new_tv tv_nm kind }+  where+    hs_tv = HsTyVar noExt NotPromoted (noLoc tv_nm)+            -- Used for error messages only++tcHsQTyVarBndr _ _ (XTyVarBndr _) = panic "tcHsTyVarBndr"+++--------------------------------------+-- Binding type/class variables in the+-- kind-checking and typechecking phases+--------------------------------------++bindTyClTyVars :: Name+               -> ([TyConBinder] -> Kind -> TcM a) -> TcM a+-- ^ Used for the type variables of a type or class decl+-- in the "kind checking" and "type checking" pass,+-- but not in the initial-kind run.+bindTyClTyVars tycon_name thing_inside+  = do { tycon <- kcLookupTcTyCon tycon_name+       ; let scoped_prs = tcTyConScopedTyVars tycon+             res_kind   = tyConResKind tycon+             binders    = tyConBinders tycon+       ; traceTc "bindTyClTyVars" (ppr tycon_name <+> ppr binders $$ ppr scoped_prs)+       ; tcExtendNameTyVarEnv scoped_prs $+         thing_inside binders res_kind }++-- getInitialKind has made a suitably-shaped kind for the type or class+-- Look it up in the local environment. This is used only for tycons+-- that we're currently type-checking, so we're sure to find a TcTyCon.+kcLookupTcTyCon :: Name -> TcM TcTyCon+kcLookupTcTyCon nm+  = do { tc_ty_thing <- tcLookup nm+       ; return $ case tc_ty_thing of+           ATcTyCon tc -> tc+           _           -> pprPanic "kcLookupTcTyCon" (ppr tc_ty_thing) }+++{- *********************************************************************+*                                                                      *+             Kind generalisation+*                                                                      *+********************************************************************* -}++zonkAndScopedSort :: [TcTyVar] -> TcM [TcTyVar]+zonkAndScopedSort spec_tkvs+  = do { spec_tkvs <- mapM zonkAndSkolemise spec_tkvs+          -- Use zonkAndSkolemise because a skol_tv might be a TyVarTv++       -- Do a stable topological sort, following+       -- Note [Ordering of implicit variables] in RnTypes+       ; return (scopedSort spec_tkvs) }++kindGeneralize :: TcType -> TcM [KindVar]+-- Quantify the free kind variables of a kind or type+-- In the latter case the type is closed, so it has no free+-- type variables.  So in both cases, all the free vars are kind vars+-- Input needn't be zonked.+-- NB: You must call solveEqualities or solveLocalEqualities before+-- kind generalization+--+-- NB: this function is just a specialised version of+--        kindGeneralizeLocal emptyWC kind_or_type+--+kindGeneralize kind_or_type+  = do { kt <- zonkTcType kind_or_type+       ; traceTc "kindGeneralise1" (ppr kt)+       ; dvs <- candidateQTyVarsOfKind kind_or_type+       ; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked+       ; traceTc "kindGeneralize" (vcat [ ppr kind_or_type+                                        , ppr dvs ])+       ; quantifyTyVars gbl_tvs dvs }++-- | This variant of 'kindGeneralize' refuses to generalize over any+-- variables free in the given WantedConstraints. Instead, it promotes+-- these variables into an outer TcLevel. See also+-- Note [Promoting unification variables] in TcSimplify+kindGeneralizeLocal :: WantedConstraints -> TcType -> TcM [KindVar]+kindGeneralizeLocal wanted kind_or_type+  = do {+       -- This bit is very much like decideMonoTyVars in TcSimplify,+       -- but constraints are so much simpler in kinds, it is much+       -- easier here. (In particular, we never quantify over a+       -- constraint in a type.)+       ; constrained <- zonkTyCoVarsAndFV (tyCoVarsOfWC wanted)+       ; (_, constrained) <- promoteTyVarSet constrained++       ; gbl_tvs <- tcGetGlobalTyCoVars -- Already zonked+       ; let mono_tvs = gbl_tvs `unionVarSet` constrained++         -- use the "Kind" variant here, as any types we see+         -- here will already have all type variables quantified;+         -- thus, every free variable is really a kv, never a tv.+       ; dvs <- candidateQTyVarsOfKind kind_or_type++       ; traceTc "kindGeneralizeLocal" $+         vcat [ text "Wanted:" <+> ppr wanted+              , text "Kind or type:" <+> ppr kind_or_type+              , text "tcvs of wanted:" <+> pprTyVars (nonDetEltsUniqSet (tyCoVarsOfWC wanted))+              , text "constrained:" <+> pprTyVars (nonDetEltsUniqSet constrained)+              , text "mono_tvs:" <+> pprTyVars (nonDetEltsUniqSet mono_tvs)+              , text "dvs:" <+> ppr dvs ]++       ; quantifyTyVars mono_tvs dvs }++{- Note [Levels and generalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f x = e+with no type signature. We are currently at level i.+We must+  * Push the level to level (i+1)+  * Allocate a fresh alpha[i+1] for the result type+  * Check that e :: alpha[i+1], gathering constraint WC+  * Solve WC as far as possible+  * Zonking the result type alpha[i+1], say to beta[i-1] -> gamma[i]+  * Find the free variables with level > i, in this case gamma[i]+  * Skolemise those free variables and quantify over them, giving+       f :: forall g. beta[i-1] -> g+  * Emit the residiual constraint wrapped in an implication for g,+    thus   forall g. WC++All of this happens for types too.  Consider+  f :: Int -> (forall a. Proxy a -> Int)++Note [Kind generalisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We do kind generalisation only at the outer level of a type signature.+For example, consider+  T :: forall k. k -> *+  f :: (forall a. T a -> Int) -> Int+When kind-checking f's type signature we generalise the kind at+the outermost level, thus:+  f1 :: forall k. (forall (a:k). T k a -> Int) -> Int  -- YES!+and *not* at the inner forall:+  f2 :: (forall k. forall (a:k). T k a -> Int) -> Int  -- NO!+Reason: same as for HM inference on value level declarations,+we want to infer the most general type.  The f2 type signature+would be *less applicable* than f1, because it requires a more+polymorphic argument.++NB: There are no explicit kind variables written in f's signature.+When there are, the renamer adds these kind variables to the list of+variables bound by the forall, so you can indeed have a type that's+higher-rank in its kind. But only by explicit request.++Note [Kinds of quantified type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcTyVarBndrsGen quantifies over a specified list of type variables,+*and* over the kind variables mentioned in the kinds of those tyvars.++Note that we must zonk those kinds (obviously) but less obviously, we+must return type variables whose kinds are zonked too. Example+    (a :: k7)  where  k7 := k9 -> k9+We must return+    [k9, a:k9->k9]+and NOT+    [k9, a:k7]+Reason: we're going to turn this into a for-all type,+   forall k9. forall (a:k7). blah+which the type checker will then instantiate, and instantiate does not+look through unification variables!++Hence using zonked_kinds when forming tvs'.++-}++-----------------------------------+etaExpandAlgTyCon :: [TyConBinder]+                  -> Kind+                  -> TcM ([TyConBinder], Kind)+-- GADT decls can have a (perhaps partial) kind signature+--      e.g.  data T a :: * -> * -> * where ...+-- This function makes up suitable (kinded) TyConBinders for the+-- argument kinds.  E.g. in this case it might return+--   ([b::*, c::*], *)+-- Never emits constraints.+-- It's a little trickier than you might think: see+-- Note [TyConBinders for the result kind signature of a data type]+etaExpandAlgTyCon tc_bndrs kind+  = do  { loc     <- getSrcSpanM+        ; uniqs   <- newUniqueSupply+        ; rdr_env <- getLocalRdrEnv+        ; let new_occs = [ occ+                         | str <- allNameStrings+                         , let occ = mkOccName tvName str+                         , isNothing (lookupLocalRdrOcc rdr_env occ)+                         -- Note [Avoid name clashes for associated data types]+                         , not (occ `elem` lhs_occs) ]+              new_uniqs = uniqsFromSupply uniqs+              subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet lhs_tvs))+        ; return (go loc new_occs new_uniqs subst [] kind) }+  where+    lhs_tvs  = map binderVar tc_bndrs+    lhs_occs = map getOccName lhs_tvs++    go loc occs uniqs subst acc kind+      = case splitPiTy_maybe kind of+          Nothing -> (reverse acc, substTy subst kind)++          Just (Anon af arg, kind')+            -> go loc occs' uniqs' subst' (tcb : acc) kind'+            where+              arg'   = substTy subst arg+              tv     = mkTyVar (mkInternalName uniq occ loc) arg'+              subst' = extendTCvInScope subst tv+              tcb    = Bndr tv (AnonTCB af)+              (uniq:uniqs') = uniqs+              (occ:occs')   = occs++          Just (Named (Bndr tv vis), kind')+            -> go loc occs uniqs subst' (tcb : acc) kind'+            where+              (subst', tv') = substTyVarBndr subst tv+              tcb = Bndr tv' (NamedTCB vis)++badKindSig :: Bool -> Kind -> SDoc+badKindSig check_for_type kind+ = hang (sep [ text "Kind signature on data type declaration has non-*"+             , (if check_for_type then empty else text "and non-variable") <+>+               text "return kind" ])+        2 (ppr kind)++tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis]+-- Result is in 1-1 correpondence with orig_args+tcbVisibilities tc orig_args+  = go (tyConKind tc) init_subst orig_args+  where+    init_subst = mkEmptyTCvSubst (mkInScopeSet (tyCoVarsOfTypes orig_args))+    go _ _ []+      = []++    go fun_kind subst all_args@(arg : args)+      | Just (tcb, inner_kind) <- splitPiTy_maybe fun_kind+      = case tcb of+          Anon af _           -> AnonTCB af   : go inner_kind subst  args+          Named (Bndr tv vis) -> NamedTCB vis : go inner_kind subst' args+                 where+                    subst' = extendTCvSubst subst tv arg++      | not (isEmptyTCvSubst subst)+      = go (substTy subst fun_kind) init_subst all_args++      | otherwise+      = pprPanic "addTcbVisibilities" (ppr tc <+> ppr orig_args)+++{- Note [TyConBinders for the result kind signature of a data type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given+  data T (a::*) :: * -> forall k. k -> *+we want to generate the extra TyConBinders for T, so we finally get+  (a::*) (b::*) (k::*) (c::k)+The function etaExpandAlgTyCon generates these extra TyConBinders from+the result kind signature.++We need to take care to give the TyConBinders+  (a) OccNames that are fresh (because the TyConBinders of a TyCon+      must have distinct OccNames++  (b) Uniques that are fresh (obviously)++For (a) we need to avoid clashes with the tyvars declared by+the user before the "::"; in the above example that is 'a'.+And also see Note [Avoid name clashes for associated data types].++For (b) suppose we have+   data T :: forall k. k -> forall k. k -> *+where the two k's are identical even up to their uniques.  Surprisingly,+this can happen: see #14515.++It's reasonably easy to solve all this; just run down the list with a+substitution; hence the recursive 'go' function.  But it has to be+done.++Note [Avoid name clashes for associated data types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider    class C a b where+               data D b :: * -> *+When typechecking the decl for D, we'll invent an extra type variable+for D, to fill out its kind.  Ideally we don't want this type variable+to be 'a', because when pretty printing we'll get+            class C a b where+               data D b a0+(NB: the tidying happens in the conversion to IfaceSyn, which happens+as part of pretty-printing a TyThing.)++That's why we look in the LocalRdrEnv to see what's in scope. This is+important only to get nice-looking output when doing ":info C" in GHCi.+It isn't essential for correctness.+++************************************************************************+*                                                                      *+             Partial signatures+*                                                                      *+************************************************************************++-}++tcHsPartialSigType+  :: UserTypeCtxt+  -> LHsSigWcType GhcRn       -- The type signature+  -> TcM ( [(Name, TcTyVar)]  -- Wildcards+         , Maybe TcType       -- Extra-constraints wildcard+         , [Name]             -- Original tyvar names, in correspondence with ...+         , [TcTyVar]          -- ... Implicitly and explicitly bound type variables+         , TcThetaType        -- Theta part+         , TcType )           -- Tau part+-- See Note [Recipe for checking a signature]+tcHsPartialSigType ctxt sig_ty+  | HsWC { hswc_ext  = sig_wcs, hswc_body = ib_ty } <- sig_ty+  , HsIB { hsib_ext = implicit_hs_tvs+         , hsib_body = hs_ty } <- ib_ty+  , (explicit_hs_tvs, L _ hs_ctxt, hs_tau) <- splitLHsSigmaTy hs_ty+  = addSigCtxt ctxt hs_ty $+    do { (implicit_tvs, (explicit_tvs, (wcs, wcx, theta, tau)))+            <- solveLocalEqualities "tcHsPatSigTypes"      $+               tcWildCardBinders sig_wcs $ \ wcs ->+               bindImplicitTKBndrs_Tv implicit_hs_tvs       $+               bindExplicitTKBndrs_Tv explicit_hs_tvs       $+               do {   -- Instantiate the type-class context; but if there+                      -- is an extra-constraints wildcard, just discard it here+                    (theta, wcx) <- tcPartialContext hs_ctxt++                  ; tau <- tcHsOpenType hs_tau++                  ; return (wcs, wcx, theta, tau) }++         -- We must return these separately, because all the zonking below+         -- might change the name of a TyVarTv. This, in turn, causes trouble+         -- in partial type signatures that bind scoped type variables, as+         -- we bring the wrong name into scope in the function body.+         -- Test case: partial-sigs/should_compile/LocalDefinitionBug+       ; let tv_names = implicit_hs_tvs ++ hsLTyVarNames explicit_hs_tvs++       -- Spit out the wildcards (including the extra-constraints one)+       -- as "hole" constraints, so that they'll be reported if necessary+       -- See Note [Extra-constraint holes in partial type signatures]+       ; emitWildCardHoleConstraints wcs++         -- The TyVarTvs created above will sometimes have too high a TcLevel+         -- (note that they are generated *after* bumping the level in+         -- the tc{Im,Ex}plicitTKBndrsSig functions. Bumping the level+         -- is still important here, because the kinds of these variables+         -- do indeed need to have the higher level, so they can unify+         -- with other local type variables. But, now that we've type-checked+         -- everything (and solved equalities in the tcImplicit call)+         -- we need to promote the TyVarTvs so we don't violate the TcLevel+         -- invariant+       ; implicit_tvs <- zonkAndScopedSort implicit_tvs+       ; explicit_tvs <- mapM zonkAndSkolemise explicit_tvs+       ; theta        <- mapM zonkTcType theta+       ; tau          <- zonkTcType tau++       ; let all_tvs = implicit_tvs ++ explicit_tvs++       ; checkValidType ctxt (mkSpecForAllTys all_tvs $ mkPhiTy theta tau)++       ; traceTc "tcHsPartialSigType" (ppr all_tvs)+       ; return (wcs, wcx, tv_names, all_tvs, theta, tau) }++tcHsPartialSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPartialSigType"+tcHsPartialSigType _ (XHsWildCardBndrs _) = panic "tcHsPartialSigType"++tcPartialContext :: HsContext GhcRn -> TcM (TcThetaType, Maybe TcType)+tcPartialContext hs_theta+  | Just (hs_theta1, hs_ctxt_last) <- snocView hs_theta+  , L wc_loc wc@(HsWildCardTy _) <- ignoreParens hs_ctxt_last+  = do { wc_tv_ty <- setSrcSpan wc_loc $+                     tcWildCardOcc wc constraintKind+       ; theta <- mapM tcLHsPredType hs_theta1+       ; return (theta, Just wc_tv_ty) }+  | otherwise+  = do { theta <- mapM tcLHsPredType hs_theta+       ; return (theta, Nothing) }++{- Note [Extra-constraint holes in partial type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f :: (_) => a -> a+  f x = ...++* The renamer leaves '_' untouched.++* Then, in tcHsPartialSigType, we make a new hole TcTyVar, in+  tcWildCardBinders.++* TcBinds.chooseInferredQuantifiers fills in that hole TcTyVar+  with the inferred constraints, e.g. (Eq a, Show a)++* TcErrors.mkHoleError finally reports the error.++An annoying difficulty happens if there are more than 62 inferred+constraints. Then we need to fill in the TcTyVar with (say) a 70-tuple.+Where do we find the TyCon?  For good reasons we only have constraint+tuples up to 62 (see Note [How tuples work] in TysWiredIn).  So how+can we make a 70-tuple?  This was the root cause of #14217.++It's incredibly tiresome, because we only need this type to fill+in the hole, to communicate to the error reporting machinery.  Nothing+more.  So I use a HACK:++* I make an /ordinary/ tuple of the constraints, in+  TcBinds.chooseInferredQuantifiers. This is ill-kinded because+  ordinary tuples can't contain constraints, but it works fine. And for+  ordinary tuples we don't have the same limit as for constraint+  tuples (which need selectors and an assocated class).++* Because it is ill-kinded, it trips an assert in writeMetaTyVar,+  so now I disable the assertion if we are writing a type of+  kind Constraint.  (That seldom/never normally happens so we aren't+  losing much.)++Result works fine, but it may eventually bite us.+++************************************************************************+*                                                                      *+      Pattern signatures (i.e signatures that occur in patterns)+*                                                                      *+********************************************************************* -}++tcHsPatSigType :: UserTypeCtxt+               -> LHsSigWcType GhcRn          -- The type signature+               -> TcM ( [(Name, TcTyVar)]     -- Wildcards+                      , [(Name, TcTyVar)]     -- The new bit of type environment, binding+                                              -- the scoped type variables+                      , TcType)       -- The type+-- Used for type-checking type signatures in+-- (a) patterns           e.g  f (x::Int) = e+-- (b) RULE forall bndrs  e.g. forall (x::Int). f x = x+--+-- This may emit constraints+-- See Note [Recipe for checking a signature]+tcHsPatSigType ctxt sig_ty+  | HsWC { hswc_ext = sig_wcs,   hswc_body = ib_ty } <- sig_ty+  , HsIB { hsib_ext = sig_ns+         , hsib_body = hs_ty } <- ib_ty+  = addSigCtxt ctxt hs_ty $+    do { sig_tkv_prs <- mapM new_implicit_tv sig_ns+       ; (wcs, sig_ty)+            <- solveLocalEqualities "tcHsPatSigType" $+                 -- Always solve local equalities if possible,+                 -- else casts get in the way of deep skolemisation+                 -- (#16033)+               tcWildCardBinders sig_wcs        $ \ wcs ->+               tcExtendNameTyVarEnv sig_tkv_prs $+               do { sig_ty <- tcHsOpenType hs_ty+                  ; return (wcs, sig_ty) }++        ; emitWildCardHoleConstraints wcs++          -- sig_ty might have tyvars that are at a higher TcLevel (if hs_ty+          -- contains a forall). Promote these.+          -- Ex: f (x :: forall a. Proxy a -> ()) = ... x ...+          -- When we instantiate x, we have to compare the kind of the argument+          -- to a's kind, which will be a metavariable.+        ; sig_ty <- zonkPromoteType sig_ty+        ; checkValidType ctxt sig_ty++        ; traceTc "tcHsPatSigType" (ppr sig_tkv_prs)+        ; return (wcs, sig_tkv_prs, sig_ty) }+  where+    new_implicit_tv name+      = do { kind <- newMetaKindVar+           ; tv   <- case ctxt of+                       RuleSigCtxt {} -> newSkolemTyVar name kind+                       _              -> newPatSigTyVar name kind+                       -- See Note [Pattern signature binders]+             -- NB: tv's Name may be fresh (in the case of newPatSigTyVar)+           ; return (name, tv) }++tcHsPatSigType _ (HsWC _ (XHsImplicitBndrs _)) = panic "tcHsPatSigType"+tcHsPatSigType _ (XHsWildCardBndrs _)          = panic "tcHsPatSigType"++tcPatSig :: Bool                    -- True <=> pattern binding+         -> LHsSigWcType GhcRn+         -> ExpSigmaType+         -> TcM (TcType,            -- The type to use for "inside" the signature+                 [(Name,TcTyVar)],  -- The new bit of type environment, binding+                                    -- the scoped type variables+                 [(Name,TcTyVar)],  -- The wildcards+                 HsWrapper)         -- Coercion due to unification with actual ty+                                    -- Of shape:  res_ty ~ sig_ty+tcPatSig in_pat_bind sig res_ty+ = do  { (sig_wcs, sig_tvs, sig_ty) <- tcHsPatSigType PatSigCtxt sig+        -- sig_tvs are the type variables free in 'sig',+        -- and not already in scope. These are the ones+        -- that should be brought into scope++        ; if null sig_tvs then do {+                -- Just do the subsumption check and return+                  wrap <- addErrCtxtM (mk_msg sig_ty) $+                          tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty+                ; return (sig_ty, [], sig_wcs, wrap)+        } else do+                -- Type signature binds at least one scoped type variable++                -- A pattern binding cannot bind scoped type variables+                -- It is more convenient to make the test here+                -- than in the renamer+        { when in_pat_bind (addErr (patBindSigErr sig_tvs))++                -- Check that all newly-in-scope tyvars are in fact+                -- constrained by the pattern.  This catches tiresome+                -- cases like+                --      type T a = Int+                --      f :: Int -> Int+                --      f (x :: T a) = ...+                -- Here 'a' doesn't get a binding.  Sigh+        ; let bad_tvs = filterOut (`elemVarSet` exactTyCoVarsOfType sig_ty)+                                  (tyCoVarsOfTypeList sig_ty)+        ; checkTc (null bad_tvs) (badPatTyVarTvs sig_ty bad_tvs)++        -- Now do a subsumption check of the pattern signature against res_ty+        ; wrap <- addErrCtxtM (mk_msg sig_ty) $+                  tcSubTypeET PatSigOrigin PatSigCtxt res_ty sig_ty++        -- Phew!+        ; return (sig_ty, sig_tvs, sig_wcs, wrap)+        } }+  where+    mk_msg sig_ty tidy_env+       = do { (tidy_env, sig_ty) <- zonkTidyTcType tidy_env sig_ty+            ; res_ty <- readExpType res_ty   -- should be filled in by now+            ; (tidy_env, res_ty) <- zonkTidyTcType tidy_env res_ty+            ; let msg = vcat [ hang (text "When checking that the pattern signature:")+                                  4 (ppr sig_ty)+                             , nest 2 (hang (text "fits the type of its context:")+                                          2 (ppr res_ty)) ]+            ; return (tidy_env, msg) }++patBindSigErr :: [(Name,TcTyVar)] -> SDoc+patBindSigErr sig_tvs+  = hang (text "You cannot bind scoped type variable" <> plural sig_tvs+          <+> pprQuotedList (map fst sig_tvs))+       2 (text "in a pattern binding signature")++{- Note [Pattern signature binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [Type variables in the type environment] in TcRnTypes.+Consider++  data T where+    MkT :: forall a. a -> (a -> Int) -> T++  f :: T -> ...+  f (MkT x (f :: b -> c)) = <blah>++Here+ * The pattern (MkT p1 p2) creates a *skolem* type variable 'a_sk',+   It must be a skolem so that that it retains its identity, and+   TcErrors.getSkolemInfo can thereby find the binding site for the skolem.++ * The type signature pattern (f :: b -> c) makes freshs meta-tyvars+   beta and gamma (TauTvs), and binds "b" :-> beta, "c" :-> gamma in the+   environment++ * Then unification makes beta := a_sk, gamma := Int+   That's why we must make beta and gamma a MetaTv,+   not a SkolemTv, so that it can unify to a_sk (or Int, respectively).++ * Finally, in '<blah>' we have the envt "b" :-> beta, "c" :-> gamma,+   so we return the pairs ("b" :-> beta, "c" :-> gamma) from tcHsPatSigType,++Another example (#13881):+   fl :: forall (l :: [a]). Sing l -> Sing l+   fl (SNil :: Sing (l :: [y])) = SNil+When we reach the pattern signature, 'l' is in scope from the+outer 'forall':+   "a" :-> a_sk :: *+   "l" :-> l_sk :: [a_sk]+We make up a fresh meta-TauTv, y_sig, for 'y', and kind-check+the pattern signature+   Sing (l :: [y])+That unifies y_sig := a_sk.  We return from tcHsPatSigType with+the pair ("y" :-> y_sig).++For RULE binders, though, things are a bit different (yuk).+  RULE "foo" forall (x::a) (y::[a]).  f x y = ...+Here this really is the binding site of the type variable so we'd like+to use a skolem, so that we get a complaint if we unify two of them+together.  Hence the new_tv function in tcHsPatSigType.+++************************************************************************+*                                                                      *+        Checking kinds+*                                                                      *+************************************************************************++-}++unifyKinds :: [LHsType GhcRn] -> [(TcType, TcKind)] -> TcM ([TcType], TcKind)+unifyKinds rn_tys act_kinds+  = do { kind <- newMetaKindVar+       ; let check rn_ty (ty, act_kind)+               = checkExpectedKind (unLoc rn_ty) ty act_kind kind+       ; tys' <- zipWithM check rn_tys act_kinds+       ; return (tys', kind) }++{-+************************************************************************+*                                                                      *+    Promotion+*                                                                      *+************************************************************************+-}++-- | Whenever a type is about to be added to the environment, it's necessary+-- to make sure that any free meta-tyvars in the type are promoted to the+-- current TcLevel. (They might be at a higher level due to the level-bumping+-- in tcExplicitTKBndrs, for example.) This function both zonks *and*+-- promotes. Why at the same time? See Note [Recipe for checking a signature]+zonkPromoteType :: TcType -> TcM TcType+zonkPromoteType = mapType zonkPromoteMapper ()++-- cf. TcMType.zonkTcTypeMapper+zonkPromoteMapper :: TyCoMapper () TcM+zonkPromoteMapper = TyCoMapper { tcm_tyvar    = const zonkPromoteTcTyVar+                               , tcm_covar    = const covar+                               , tcm_hole     = const hole+                               , tcm_tycobinder = const tybinder+                               , tcm_tycon    = return }+  where+    covar cv+      = mkCoVarCo <$> zonkPromoteTyCoVarKind cv++    hole :: CoercionHole -> TcM Coercion+    hole h+      = do { contents <- unpackCoercionHole_maybe h+           ; case contents of+               Just co -> do { co <- zonkPromoteCoercion co+                             ; checkCoercionHole cv co }+               Nothing -> do { cv' <- zonkPromoteTyCoVarKind cv+                             ; return $ mkHoleCo (setCoHoleCoVar h cv') } }+      where+        cv = coHoleCoVar h++    tybinder :: TyVar -> ArgFlag -> TcM ((), TyVar)+    tybinder tv _flag = ((), ) <$> zonkPromoteTyCoVarKind tv++zonkPromoteTcTyVar :: TyCoVar -> TcM TcType+zonkPromoteTcTyVar tv+  | isMetaTyVar tv+  = do { let ref = metaTyVarRef tv+       ; contents <- readTcRef ref+       ; case contents of+           Flexi -> do { (_, promoted_tv) <- promoteTyVar tv+                       ; mkTyVarTy <$> zonkPromoteTyCoVarKind promoted_tv }+           Indirect ty -> zonkPromoteType ty }++  | isTcTyVar tv && isSkolemTyVar tv  -- NB: isSkolemTyVar says "True" to pure TyVars+  = do { tc_lvl <- getTcLevel+       ; mkTyVarTy <$> zonkPromoteTyCoVarKind (promoteSkolem tc_lvl tv) }++  | otherwise+  = mkTyVarTy <$> zonkPromoteTyCoVarKind tv++zonkPromoteTyCoVarKind :: TyCoVar -> TcM TyCoVar+zonkPromoteTyCoVarKind = updateTyVarKindM zonkPromoteType++zonkPromoteCoercion :: Coercion -> TcM Coercion+zonkPromoteCoercion = mapCoercion zonkPromoteMapper ()++{-+************************************************************************+*                                                                      *+        Sort checking kinds+*                                                                      *+************************************************************************++tcLHsKindSig converts a user-written kind to an internal, sort-checked kind.+It does sort checking and desugaring at the same time, in one single pass.+-}++tcLHsKindSig :: UserTypeCtxt -> LHsKind GhcRn -> TcM Kind+tcLHsKindSig ctxt hs_kind+-- See  Note [Recipe for checking a signature] in TcHsType+-- Result is zonked+  = do { kind <- solveLocalEqualities "tcLHsKindSig" $+                 tc_lhs_kind kindLevelMode hs_kind+       ; traceTc "tcLHsKindSig" (ppr hs_kind $$ ppr kind)+       -- No generalization, so we must promote+       ; kind <- zonkPromoteType kind+         -- This zonk is very important in the case of higher rank kinds+         -- E.g. #13879    f :: forall (p :: forall z (y::z). <blah>).+         --                          <more blah>+         --      When instantiating p's kind at occurrences of p in <more blah>+         --      it's crucial that the kind we instantiate is fully zonked,+         --      else we may fail to substitute properly++       ; checkValidType ctxt kind+       ; traceTc "tcLHsKindSig2" (ppr kind)+       ; return kind }++tc_lhs_kind :: TcTyMode -> LHsKind GhcRn -> TcM Kind+tc_lhs_kind mode k+  = addErrCtxt (text "In the kind" <+> quotes (ppr k)) $+    tc_lhs_type (kindLevel mode) k liftedTypeKind++promotionErr :: Name -> PromotionErr -> TcM a+promotionErr name err+  = failWithTc (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here")+                   2 (parens reason))+  where+    reason = case err of+               ConstrainedDataConPE pred+                              -> text "it has an unpromotable context"+                                 <+> quotes (ppr pred)+               FamDataConPE   -> text "it comes from a data family instance"+               NoDataKindsTC  -> text "perhaps you intended to use DataKinds"+               NoDataKindsDC  -> text "perhaps you intended to use DataKinds"+               PatSynPE       -> text "pattern synonyms cannot be promoted"+               _ -> text "it is defined and used in the same recursive group"++{-+************************************************************************+*                                                                      *+                Scoped type variables+*                                                                      *+************************************************************************+-}++badPatTyVarTvs :: TcType -> [TyVar] -> SDoc+badPatTyVarTvs sig_ty bad_tvs+  = vcat [ fsep [text "The type variable" <> plural bad_tvs,+                 quotes (pprWithCommas ppr bad_tvs),+                 text "should be bound by the pattern signature" <+> quotes (ppr sig_ty),+                 text "but are actually discarded by a type synonym" ]+         , text "To fix this, expand the type synonym"+         , text "[Note: I hope to lift this restriction in due course]" ]++{-+************************************************************************+*                                                                      *+          Error messages and such+*                                                                      *+************************************************************************+-}+++-- | If the inner action emits constraints, report them as errors and fail;+-- otherwise, propagates the return value. Useful as a wrapper around+-- 'tcImplicitTKBndrs', which uses solveLocalEqualities, when there won't be+-- another chance to solve constraints+failIfEmitsConstraints :: TcM a -> TcM a+failIfEmitsConstraints thing_inside+  = checkNoErrs $  -- We say that we fail if there are constraints!+                   -- c.f same checkNoErrs in solveEqualities+    do { (res, lie) <- captureConstraints thing_inside+       ; reportAllUnsolved lie+       ; return res+       }++-- | Make an appropriate message for an error in a function argument.+-- Used for both expressions and types.+funAppCtxt :: (Outputable fun, Outputable arg) => fun -> arg -> Int -> SDoc+funAppCtxt fun arg arg_no+  = hang (hsep [ text "In the", speakNth arg_no, ptext (sLit "argument of"),+                    quotes (ppr fun) <> text ", namely"])+       2 (quotes (ppr arg))++-- | Add a "In the data declaration for T" or some such.+addTyConFlavCtxt :: Name -> TyConFlavour -> TcM a -> TcM a+addTyConFlavCtxt name flav+  = addErrCtxt $ hsep [ text "In the", ppr flav+                      , text "declaration for", quotes (ppr name) ]
+ compiler/typecheck/TcInstDcls.hs view
@@ -0,0 +1,2137 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++TcInstDecls: Typechecking instance declarations+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module TcInstDcls ( tcInstDecls1, tcInstDeclsDeriv, tcInstDecls2 ) where++#include "HsVersions.h"++import GhcPrelude++import HsSyn+import TcBinds+import TcTyClsDecls+import TcTyDecls ( addTyConsToGblEnv )+import TcClassDcl( tcClassDecl2, tcATDefault,+                   HsSigFun, mkHsSigFun, badMethodErr,+                   findMethodBind, instantiateMethod )+import TcSigs+import TcRnMonad+import TcValidity+import TcHsSyn+import TcMType+import TcType+import BuildTyCl+import Inst+import ClsInst( AssocInstInfo(..), isNotAssociated )+import InstEnv+import FamInst+import FamInstEnv+import TcDeriv+import TcEnv+import TcHsType+import TcUnify+import CoreSyn    ( Expr(..), mkApps, mkVarApps, mkLams )+import MkCore     ( nO_METHOD_BINDING_ERROR_ID )+import CoreUnfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding )+import Type+import TcEvidence+import TyCon+import CoAxiom+import DataCon+import ConLike+import Class+import Var+import VarEnv+import VarSet+import Bag+import BasicTypes+import DynFlags+import ErrUtils+import FastString+import Id+import ListSetOps+import Name+import NameSet+import Outputable+import SrcLoc+import Util+import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Maybes+import Data.List( mapAccumL )+++{-+Typechecking instance declarations is done in two passes. The first+pass, made by @tcInstDecls1@, collects information to be used in the+second pass.++This pre-processed info includes the as-yet-unprocessed bindings+inside the instance declaration.  These are type-checked in the second+pass, when the class-instance envs and GVE contain all the info from+all the instance and value decls.  Indeed that's the reason we need+two passes over the instance decls.+++Note [How instance declarations are translated]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is how we translate instance declarations into Core++Running example:+        class C a where+           op1, op2 :: Ix b => a -> b -> b+           op2 = <dm-rhs>++        instance C a => C [a]+           {-# INLINE [2] op1 #-}+           op1 = <rhs>+===>+        -- Method selectors+        op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b+        op1 = ...+        op2 = ...++        -- Default methods get the 'self' dictionary as argument+        -- so they can call other methods at the same type+        -- Default methods get the same type as their method selector+        $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b+        $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>+               -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>+               -- Note [Tricky type variable scoping]++        -- A top-level definition for each instance method+        -- Here op1_i, op2_i are the "instance method Ids"+        -- The INLINE pragma comes from the user pragma+        {-# INLINE [2] op1_i #-}  -- From the instance decl bindings+        op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b+        op1_i = /\a. \(d:C a).+               let this :: C [a]+                   this = df_i a d+                     -- Note [Subtle interaction of recursion and overlap]++                   local_op1 :: forall b. Ix b => [a] -> b -> b+                   local_op1 = <rhs>+                     -- Source code; run the type checker on this+                     -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>+                     -- Note [Tricky type variable scoping]++               in local_op1 a d++        op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)++        -- The dictionary function itself+        {-# NOINLINE CONLIKE df_i #-}   -- Never inline dictionary functions+        df_i :: forall a. C a -> C [a]+        df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)+                -- But see Note [Default methods in instances]+                -- We can't apply the type checker to the default-method call++        -- Use a RULE to short-circuit applications of the class ops+        {-# RULE "op1@C[a]" forall a, d:C a.+                            op1 [a] (df_i d) = op1_i a d #-}++Note [Instances and loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Note that df_i may be mutually recursive with both op1_i and op2_i.+  It's crucial that df_i is not chosen as the loop breaker, even+  though op1_i has a (user-specified) INLINE pragma.++* Instead the idea is to inline df_i into op1_i, which may then select+  methods from the MkC record, and thereby break the recursion with+  df_i, leaving a *self*-recursive op1_i.  (If op1_i doesn't call op at+  the same type, it won't mention df_i, so there won't be recursion in+  the first place.)++* If op1_i is marked INLINE by the user there's a danger that we won't+  inline df_i in it, and that in turn means that (since it'll be a+  loop-breaker because df_i isn't), op1_i will ironically never be+  inlined.  But this is OK: the recursion breaking happens by way of+  a RULE (the magic ClassOp rule above), and RULES work inside InlineRule+  unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils++Note [ClassOp/DFun selection]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+One thing we see a lot is stuff like+    op2 (df d1 d2)+where 'op2' is a ClassOp and 'df' is DFun.  Now, we could inline *both*+'op2' and 'df' to get+     case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of+       MkD _ op2 _ _ _ -> op2+And that will reduce to ($cop2 d1 d2) which is what we wanted.++But it's tricky to make this work in practice, because it requires us to+inline both 'op2' and 'df'.  But neither is keen to inline without having+seen the other's result; and it's very easy to get code bloat (from the+big intermediate) if you inline a bit too much.++Instead we use a cunning trick.+ * We arrange that 'df' and 'op2' NEVER inline.++ * We arrange that 'df' is ALWAYS defined in the sylised form+      df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...++ * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])+   that lists its methods.++ * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return+   a suitable constructor application -- inlining df "on the fly" as it+   were.++ * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that+   extracts the right piece iff its argument satisfies+   exprIsConApp_maybe.  This is done in MkId mkDictSelId++ * We make 'df' CONLIKE, so that shared uses still match; eg+      let d = df d1 d2+      in ...(op2 d)...(op1 d)...++Note [Single-method classes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the class has just one method (or, more accurately, just one element+of {superclasses + methods}), then we use a different strategy.++   class C a where op :: a -> a+   instance C a => C [a] where op = <blah>++We translate the class decl into a newtype, which just gives a+top-level axiom. The "constructor" MkC expands to a cast, as does the+class-op selector.++   axiom Co:C a :: C a ~ (a->a)++   op :: forall a. C a -> (a -> a)+   op a d = d |> (Co:C a)++   MkC :: forall a. (a->a) -> C a+   MkC = /\a.\op. op |> (sym Co:C a)++The clever RULE stuff doesn't work now, because ($df a d) isn't+a constructor application, so exprIsConApp_maybe won't return+Just <blah>.++Instead, we simply rely on the fact that casts are cheap:++   $df :: forall a. C a => C [a]+   {-# INLINE df #-}  -- NB: INLINE this+   $df = /\a. \d. MkC [a] ($cop_list a d)+       = $cop_list |> forall a. C a -> (sym (Co:C [a]))++   $cop_list :: forall a. C a => [a] -> [a]+   $cop_list = <blah>++So if we see+   (op ($df a d))+we'll inline 'op' and '$df', since both are simply casts, and+good things happen.++Why do we use this different strategy?  Because otherwise we+end up with non-inlined dictionaries that look like+    $df = $cop |> blah+which adds an extra indirection to every use, which seems stupid.  See+#4138 for an example (although the regression reported there+wasn't due to the indirection).++There is an awkward wrinkle though: we want to be very+careful when we have+    instance C a => C [a] where+      {-# INLINE op #-}+      op = ...+then we'll get an INLINE pragma on $cop_list but it's important that+$cop_list only inlines when it's applied to *two* arguments (the+dictionary and the list argument).  So we must not eta-expand $df+above.  We ensure that this doesn't happen by putting an INLINE+pragma on the dfun itself; after all, it ends up being just a cast.++There is one more dark corner to the INLINE story, even more deeply+buried.  Consider this (#3772):++    class DeepSeq a => C a where+      gen :: Int -> a++    instance C a => C [a] where+      gen n = ...++    class DeepSeq a where+      deepSeq :: a -> b -> b++    instance DeepSeq a => DeepSeq [a] where+      {-# INLINE deepSeq #-}+      deepSeq xs b = foldr deepSeq b xs++That gives rise to these defns:++    $cdeepSeq :: DeepSeq a -> [a] -> b -> b+    -- User INLINE( 3 args )!+    $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ...++    $fDeepSeq[] :: DeepSeq a -> DeepSeq [a]+    -- DFun (with auto INLINE pragma)+    $fDeepSeq[] a d = $cdeepSeq a d |> blah++    $cp1 a d :: C a => DeepSep [a]+    -- We don't want to eta-expand this, lest+    -- $cdeepSeq gets inlined in it!+    $cp1 a d = $fDeepSep[] a (scsel a d)++    $fC[] :: C a => C [a]+    -- Ordinary DFun+    $fC[] a d = MkC ($cp1 a d) ($cgen a d)++Here $cp1 is the code that generates the superclass for C [a].  The+issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[]+and then $cdeepSeq will inline there, which is definitely wrong.  Like+on the dfun, we solve this by adding an INLINE pragma to $cp1.++Note [Subtle interaction of recursion and overlap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+  class C a where { op1,op2 :: a -> a }+  instance C a => C [a] where+    op1 x = op2 x ++ op2 x+    op2 x = ...+  instance C [Int] where+    ...++When type-checking the C [a] instance, we need a C [a] dictionary (for+the call of op2).  If we look up in the instance environment, we find+an overlap.  And in *general* the right thing is to complain (see Note+[Overlapping instances] in InstEnv).  But in *this* case it's wrong to+complain, because we just want to delegate to the op2 of this same+instance.++Why is this justified?  Because we generate a (C [a]) constraint in+a context in which 'a' cannot be instantiated to anything that matches+other overlapping instances, or else we would not be executing this+version of op1 in the first place.++It might even be a bit disguised:++  nullFail :: C [a] => [a] -> [a]+  nullFail x = op2 x ++ op2 x++  instance C a => C [a] where+    op1 x = nullFail x++Precisely this is used in package 'regex-base', module Context.hs.+See the overlapping instances for RegexContext, and the fact that they+call 'nullFail' just like the example above.  The DoCon package also+does the same thing; it shows up in module Fraction.hs.++Conclusion: when typechecking the methods in a C [a] instance, we want to+treat the 'a' as an *existential* type variable, in the sense described+by Note [Binding when looking up instances].  That is why isOverlappableTyVar+responds True to an InstSkol, which is the kind of skolem we use in+tcInstDecl2.+++Note [Tricky type variable scoping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In our example+        class C a where+           op1, op2 :: Ix b => a -> b -> b+           op2 = <dm-rhs>++        instance C a => C [a]+           {-# INLINE [2] op1 #-}+           op1 = <rhs>++note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is+in scope in <rhs>.  In particular, we must make sure that 'b' is in+scope when typechecking <dm-rhs>.  This is achieved by subFunTys,+which brings appropriate tyvars into scope. This happens for both+<dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have+complained if 'b' is mentioned in <rhs>.++++************************************************************************+*                                                                      *+\subsection{Extracting instance decls}+*                                                                      *+************************************************************************++Gather up the instance declarations from their various sources+-}++tcInstDecls1    -- Deal with both source-code and imported instance decls+   :: [LInstDecl GhcRn]         -- Source code instance decls+   -> TcM (TcGblEnv,            -- The full inst env+           [InstInfo GhcRn],    -- Source-code instance decls to process;+                                -- contains all dfuns for this module+           [DerivInfo])         -- From data family instances++tcInstDecls1 inst_decls+  = do {    -- Do class and family instance declarations+       ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls++       ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff+             fam_insts   = concat fam_insts_s+             local_infos = concat local_infos_s++       ; gbl_env <- addClsInsts local_infos $+                    addFamInsts fam_insts   $+                    getGblEnv++       ; return ( gbl_env+                , local_infos+                , concat datafam_deriv_infos ) }++-- | Use DerivInfo for data family instances (produced by tcInstDecls1),+--   datatype declarations (TyClDecl), and standalone deriving declarations+--   (DerivDecl) to check and process all derived class instances.+tcInstDeclsDeriv+  :: [DerivInfo]+  -> [LTyClDecl GhcRn]+  -> [LDerivDecl GhcRn]+  -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)+tcInstDeclsDeriv datafam_deriv_infos tyclds derivds+  = do th_stage <- getStage -- See Note [Deriving inside TH brackets]+       if isBrackStage th_stage+       then do { gbl_env <- getGblEnv+               ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) }+       else do { data_deriv_infos <- mkDerivInfos tyclds+               ; let deriv_infos = datafam_deriv_infos ++ data_deriv_infos+               ; (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds+               ; return (tcg_env, bagToList info_bag, valbinds) }++addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a+addClsInsts infos thing_inside+  = tcExtendLocalInstEnv (map iSpec infos) thing_inside++addFamInsts :: [FamInst] -> TcM a -> TcM a+-- Extend (a) the family instance envt+--        (b) the type envt with stuff from data type decls+addFamInsts fam_insts thing_inside+  = tcExtendLocalFamInstEnv fam_insts $+    tcExtendGlobalEnv axioms          $+    do { traceTc "addFamInsts" (pprFamInsts fam_insts)+       ; gbl_env <- addTyConsToGblEnv data_rep_tycons+                    -- Does not add its axiom; that comes+                    -- from adding the 'axioms' above+       ; setGblEnv gbl_env thing_inside }+  where+    axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts+    data_rep_tycons = famInstsRepTyCons fam_insts+      -- The representation tycons for 'data instances' declarations++{-+Note [Deriving inside TH brackets]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a declaration bracket+  [d| data T = A | B deriving( Show ) |]++there is really no point in generating the derived code for deriving(+Show) and then type-checking it. This will happen at the call site+anyway, and the type check should never fail!  Moreover (#6005)+the scoping of the generated code inside the bracket does not seem to+work out.++The easy solution is simply not to generate the derived instances at+all.  (A less brutal solution would be to generate them with no+bindings.)  This will become moot when we shift to the new TH plan, so+the brutal solution will do.+-}++tcLocalInstDecl :: LInstDecl GhcRn+                -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])+        -- A source-file instance declaration+        -- Type-check all the stuff before the "where"+        --+        -- We check for respectable instance type, and context+tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))+  = do { fam_inst <- tcTyFamInstDecl NotAssociated (L loc decl)+       ; return ([], [fam_inst], []) }++tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))+  = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl NotAssociated (L loc decl)+       ; return ([], [fam_inst], maybeToList m_deriv_info) }++tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))+  = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl)+       ; return (insts, fam_insts, deriv_infos) }++tcLocalInstDecl (L _ (XInstDecl _)) = panic "tcLocalInstDecl"++tcClsInstDecl :: LClsInstDecl GhcRn+              -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])+-- The returned DerivInfos are for any associated data families+tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = hs_ty, cid_binds = binds+                                  , cid_sigs = uprags, cid_tyfam_insts = ats+                                  , cid_overlap_mode = overlap_mode+                                  , cid_datafam_insts = adts }))+  = setSrcSpan loc                      $+    addErrCtxt (instDeclCtxt1 hs_ty)  $+    do  { traceTc "tcLocalInstDecl" (ppr hs_ty)+        ; dfun_ty <- tcHsClsInstType (InstDeclCtxt False) hs_ty+        ; let (tyvars, theta, clas, inst_tys) = tcSplitDFunTy dfun_ty+             -- NB: tcHsClsInstType does checkValidInstance++        ; (subst, skol_tvs) <- tcInstSkolTyVars tyvars+        ; let tv_skol_prs = [ (tyVarName tv, skol_tv)+                            | (tv, skol_tv) <- tyvars `zip` skol_tvs ]+              n_inferred = countWhile ((== Inferred) . binderArgFlag) $+                           fst $ splitForAllVarBndrs dfun_ty+              visible_skol_tvs = drop n_inferred skol_tvs++        ; traceTc "tcLocalInstDecl 1" (ppr dfun_ty $$ ppr (invisibleTyBndrCount dfun_ty) $$ ppr skol_tvs)++        -- Next, process any associated types.+        ; (datafam_stuff, tyfam_insts)+             <- tcExtendNameTyVarEnv tv_skol_prs $+                do  { let mini_env   = mkVarEnv (classTyVars clas `zip` substTys subst inst_tys)+                          mini_subst = mkTvSubst (mkInScopeSet (mkVarSet skol_tvs)) mini_env+                          mb_info    = InClsInst { ai_class = clas+                                                 , ai_tyvars = visible_skol_tvs+                                                 , ai_inst_env = mini_env }+                    ; df_stuff  <- mapAndRecoverM (tcDataFamInstDecl mb_info) adts+                    ; tf_insts1 <- mapAndRecoverM (tcTyFamInstDecl mb_info)   ats++                      -- Check for missing associated types and build them+                      -- from their defaults (if available)+                    ; tf_insts2 <- mapM (tcATDefault loc mini_subst defined_ats)+                                        (classATItems clas)++                    ; return (df_stuff, tf_insts1 ++ concat tf_insts2) }+++        -- Finally, construct the Core representation of the instance.+        -- (This no longer includes the associated types.)+        ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType hs_ty))+                -- Dfun location is that of instance *header*++        ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name+                              tyvars theta clas inst_tys++        ; let inst_binds = InstBindings+                             { ib_binds = binds+                             , ib_tyvars = map Var.varName tyvars -- Scope over bindings+                             , ib_pragmas = uprags+                             , ib_extensions = []+                             , ib_derived = False }+              inst_info = InstInfo { iSpec  = ispec, iBinds = inst_binds }++              (datafam_insts, m_deriv_infos) = unzip datafam_stuff+              deriv_infos                    = catMaybes m_deriv_infos+              all_insts                      = tyfam_insts ++ datafam_insts++         -- In hs-boot files there should be no bindings+        ; is_boot <- tcIsHsBootOrSig+        ; let no_binds = isEmptyLHsBinds binds && null uprags+        ; failIfTc (is_boot && not no_binds) badBootDeclErr++        ; return ( [inst_info], all_insts, deriv_infos ) }+  where+    defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)+                  `unionNameSet`+                  mkNameSet (map (unLoc . feqn_tycon+                                        . hsib_body+                                        . dfid_eqn+                                        . unLoc) adts)++tcClsInstDecl (L _ (XClsInstDecl _)) = panic "tcClsInstDecl"++{-+************************************************************************+*                                                                      *+               Type family instances+*                                                                      *+************************************************************************++Family instances are somewhat of a hybrid.  They are processed together with+class instance heads, but can contain data constructors and hence they share a+lot of kinding and type checking code with ordinary algebraic data types (and+GADTs).+-}++tcTyFamInstDecl :: AssocInstInfo+                -> LTyFamInstDecl GhcRn -> TcM FamInst+  -- "type instance"+  -- See Note [Associated type instances]+tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))+  = setSrcSpan loc           $+    tcAddTyFamInstCtxt decl  $+    do { let fam_lname = feqn_tycon (hsib_body eqn)+       ; fam_tc <- tcLookupLocatedTyCon fam_lname+       ; tcFamInstDeclChecks mb_clsinfo fam_tc++         -- (0) Check it's an open type family+       ; checkTc (isTypeFamilyTyCon fam_tc)     (wrongKindOfFamily fam_tc)+       ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc)++         -- (1) do the work of verifying the synonym group+       ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo+                                        (L (getLoc fam_lname) eqn)+++         -- (2) check for validity+       ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch+       ; checkValidCoAxBranch fam_tc co_ax_branch++         -- (3) construct coercion axiom+       ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch]+       ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch+       ; newFamInst SynFamilyInst axiom }+++---------------------+tcFamInstDeclChecks :: AssocInstInfo -> TyCon -> TcM ()+-- Used for both type and data families+tcFamInstDeclChecks mb_clsinfo fam_tc+  = do { -- Type family instances require -XTypeFamilies+         -- and can't (currently) be in an hs-boot file+       ; traceTc "tcFamInstDecl" (ppr fam_tc)+       ; type_families <- xoptM LangExt.TypeFamilies+       ; is_boot       <- tcIsHsBootOrSig   -- Are we compiling an hs-boot file?+       ; checkTc type_families $ badFamInstDecl fam_tc+       ; checkTc (not is_boot) $ badBootFamInstDeclErr++       -- Check that it is a family TyCon, and that+       -- oplevel type instances are not for associated types.+       ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)++       ; when (isNotAssociated mb_clsinfo &&   -- Not in a class decl+               isTyConAssoc fam_tc)            -- but an associated type+              (addErr $ assocInClassErr fam_tc)+       }++{- Note [Associated type instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We allow this:+  class C a where+    type T x a+  instance C Int where+    type T (S y) Int = y+    type T Z     Int = Char++Note that+  a) The variable 'x' is not bound by the class decl+  b) 'x' is instantiated to a non-type-variable in the instance+  c) There are several type instance decls for T in the instance++All this is fine.  Of course, you can't give any *more* instances+for (T ty Int) elsewhere, because it's an *associated* type.+++************************************************************************+*                                                                      *+               Data family instances+*                                                                      *+************************************************************************++For some reason data family instances are a lot more complicated+than type family instances+-}++tcDataFamInstDecl :: AssocInstInfo+                  -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo)+  -- "newtype instance" and "data instance"+tcDataFamInstDecl mb_clsinfo+    (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = imp_vars+                                                   , hsib_body =+      FamEqn { feqn_bndrs  = mb_bndrs+             , feqn_pats   = hs_pats+             , feqn_tycon  = lfam_name@(L _ fam_name)+             , feqn_fixity = fixity+             , feqn_rhs    = HsDataDefn { dd_ND      = new_or_data+                                        , dd_cType   = cType+                                        , dd_ctxt    = hs_ctxt+                                        , dd_cons    = hs_cons+                                        , dd_kindSig = m_ksig+                                        , dd_derivs  = derivs } }}}))+  = setSrcSpan loc             $+    tcAddDataFamInstCtxt decl  $+    do { fam_tc <- tcLookupLocatedTyCon lfam_name++       ; tcFamInstDeclChecks mb_clsinfo fam_tc++       -- Check that the family declaration is for the right kind+       ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)+       ; gadt_syntax <- dataDeclChecks fam_name new_or_data hs_ctxt hs_cons+          -- Do /not/ check that the number of patterns = tyConArity fam_tc+          -- See [Arity of data families] in FamInstEnv++       ; (qtvs, pats, res_kind, stupid_theta)+             <- tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs+                                fixity hs_ctxt hs_pats m_ksig hs_cons++       -- Eta-reduce the axiom if possible+       -- Quite tricky: see Note [Eta-reduction for data families]+       ; let (eta_pats, eta_tcbs) = eta_reduce fam_tc pats+             eta_tvs       = map binderVar eta_tcbs+             post_eta_qtvs = filterOut (`elem` eta_tvs) qtvs++             full_tcbs = mkTyConBindersPreferAnon post_eta_qtvs+                            (tyCoVarsOfType (mkSpecForAllTys eta_tvs res_kind))+                         ++ eta_tcbs+                 -- Put the eta-removed tyvars at the end+                 -- Remember, qtvs is in arbitrary order, except kind vars are+                 -- first, so there is no reason to suppose that the eta_tvs+                 -- (obtained from the pats) are at the end (#11148)++       -- Eta-expand the representation tycon until it has reult kind *+       -- See also Note [Arity of data families] in FamInstEnv+       -- NB: we can do this after eta-reducing the axiom, because if+       --     we did it before the "extra" tvs from etaExpandAlgTyCon+       --     would always be eta-reduced+       ; (extra_tcbs, final_res_kind) <- etaExpandAlgTyCon full_tcbs res_kind+       ; checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind)+       ; let extra_pats  = map (mkTyVarTy . binderVar) extra_tcbs+             all_pats    = pats `chkAppend` extra_pats+             orig_res_ty = mkTyConApp fam_tc all_pats+             ty_binders  = full_tcbs `chkAppend` extra_tcbs++       ; traceTc "tcDataFamInstDecl" $+         vcat [ text "Fam tycon:" <+> ppr fam_tc+              , text "Pats:" <+> ppr pats+              , text "visibliities:" <+> ppr (tcbVisibilities fam_tc pats)+              , text "all_pats:" <+> ppr all_pats+              , text "ty_binders" <+> ppr ty_binders+              , text "fam_tc_binders:" <+> ppr (tyConBinders fam_tc)+              , text "eta_pats" <+> ppr eta_pats+              , text "eta_tcbs" <+> ppr eta_tcbs ]++       ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->+           do { data_cons <- tcExtendTyVarEnv qtvs $+                             -- For H98 decls, the tyvars scope+                             -- over the data constructors+                             tcConDecls rec_rep_tc ty_binders orig_res_ty hs_cons++              ; rep_tc_name <- newFamInstTyConName lfam_name pats+              ; axiom_name  <- newFamInstAxiomName lfam_name [pats]+              ; tc_rhs <- case new_or_data of+                     DataType -> return (mkDataTyConRhs data_cons)+                     NewType  -> ASSERT( not (null data_cons) )+                                 mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)++              ; let axiom  = mkSingleCoAxiom Representational axiom_name+                                 post_eta_qtvs eta_tvs [] fam_tc eta_pats+                                 (mkTyConApp rep_tc (mkTyVarTys post_eta_qtvs))+                    parent = DataFamInstTyCon axiom fam_tc all_pats++                      -- NB: Use the full ty_binders from the pats. See bullet toward+                      -- the end of Note [Data type families] in TyCon+                    rep_tc   = mkAlgTyCon rep_tc_name+                                          ty_binders liftedTypeKind+                                          (map (const Nominal) ty_binders)+                                          (fmap unLoc cType) stupid_theta+                                          tc_rhs parent+                                          gadt_syntax+                 -- We always assume that indexed types are recursive.  Why?+                 -- (1) Due to their open nature, we can never be sure that a+                 -- further instance might not introduce a new recursive+                 -- dependency.  (2) They are always valid loop breakers as+                 -- they involve a coercion.+              ; return (rep_tc, axiom) }++       -- Remember to check validity; no recursion to worry about here+       -- Check that left-hand sides are ok (mono-types, no type families,+       -- consistent instantiations, etc)+       ; let ax_branch = coAxiomSingleBranch axiom+       ; checkConsistentFamInst mb_clsinfo fam_tc ax_branch+       ; checkValidCoAxBranch fam_tc ax_branch+       ; checkValidTyCon rep_tc++       ; let m_deriv_info = case derivs of+               L _ []    -> Nothing+               L _ preds ->+                 Just $ DerivInfo { di_rep_tc  = rep_tc+                                  , di_clauses = preds+                                  , di_ctxt    = tcMkDataFamInstCtxt decl }++       ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom+       ; return (fam_inst, m_deriv_info) }+  where+    eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder])+    -- See Note [Eta reduction for data families] in FamInstEnv+    -- Splits the incoming patterns into two: the [TyVar]+    -- are the patterns that can be eta-reduced away.+    -- e.g.     T [a] Int a d c   ==>  (T [a] Int a, [d,c])+    --+    -- NB: quadratic algorithm, but types are small here+    eta_reduce fam_tc pats+        = go (reverse (zip3 pats fvs_s vis_s)) []+        where+          vis_s :: [TyConBndrVis]+          vis_s = tcbVisibilities fam_tc pats++          fvs_s :: [TyCoVarSet]  -- 1-1 correspondence with pats+                                 -- Each elt is the free vars of all /earlier/ pats+          (_, fvs_s) = mapAccumL add_fvs emptyVarSet pats+          add_fvs fvs pat = (fvs `unionVarSet` tyCoVarsOfType pat, fvs)++    go ((pat, fvs_to_the_left, tcb_vis):pats) etad_tvs+      | Just tv <- getTyVar_maybe pat+      , not (tv `elemVarSet` fvs_to_the_left)+      = go pats (Bndr tv tcb_vis : etad_tvs)+    go pats etad_tvs = (reverse (map fstOf3 pats), etad_tvs)++tcDataFamInstDecl _ _ = panic "tcDataFamInstDecl"++-----------------------+tcDataFamHeader :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn]+                -> LexicalFixity -> LHsContext GhcRn+                -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn]+                -> TcM ([TyVar], [Type], Kind, ThetaType)+-- The "header" is the part other than the data constructors themselves+-- e.g.  data instance D [a] :: * -> * where ...+-- Here the "header" is the bit before the "where"+tcDataFamHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity hs_ctxt hs_pats m_ksig hs_cons+  = do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty, res_kind)))+            <- pushTcLevelM_                                $+               solveEqualities                              $+               bindImplicitTKBndrs_Q_Skol imp_vars          $+               bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $+               do { stupid_theta <- tcHsContext hs_ctxt+                  ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats++                  -- Ensure that the instance is consistent+                  -- with its parent class+                  ; addConsistencyConstraints mb_clsinfo lhs_ty++                  -- Add constraints from the data constructors+                  ; mapM_ (wrapLocM_ kcConDecl) hs_cons++                  -- Add constraints from the result signature+                  ; res_kind <- tc_kind_sig m_ksig+                  ; lhs_ty <- checkExpectedKind_pp pp_lhs lhs_ty lhs_kind res_kind+                  ; return (stupid_theta, lhs_ty, res_kind) }++       -- See TcTyClsDecls Note [Generalising in tcFamTyPatsGuts]+       -- This code (and the stuff immediately above) is very similar+       -- to that in tcFamTyInstEqnGuts.  Maybe we should abstract the+       -- common code; but for the moment I concluded that it's+       -- clearer to duplicate it.  Still, if you fix a bug here,+       -- check there too!+       ; let scoped_tvs = imp_tvs ++ exp_tvs+       ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)+       ; qtvs <- quantifyTyVars emptyVarSet dvs++       -- Zonk the patterns etc into the Type world+       ; (ze, qtvs)   <- zonkTyBndrs qtvs+       ; lhs_ty       <- zonkTcTypeToTypeX ze lhs_ty+       ; res_kind     <- zonkTcTypeToTypeX ze res_kind+       ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta++       -- Check that type patterns match the class instance head+       ; let pats = unravelFamInstPats lhs_ty+       ; return (qtvs, pats, res_kind, stupid_theta) }+  where+    fam_name  = tyConName fam_tc+    data_ctxt = DataKindCtxt fam_name+    pp_lhs    = pprHsFamInstLHS fam_name mb_bndrs hs_pats fixity hs_ctxt+    exp_bndrs = mb_bndrs `orElse` []++    -- See Note [Result kind signature for a data family instance]+    tc_kind_sig Nothing+      = return liftedTypeKind+    tc_kind_sig (Just hs_kind)+      = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind+           ; let (tvs, inner_kind) = tcSplitForAllTys sig_kind+           ; lvl <- getTcLevel+           ; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs+             -- Perhaps surprisingly, we don't need the skolemised tvs themselves+           ; return (substTy subst inner_kind) }++{- Note [Result kind signature for a data family instance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The expected type might have a forall at the type. Normally, we+can't skolemise in kinds because we don't have type-level lambda.+But here, we're at the top-level of an instance declaration, so+we actually have a place to put the regeneralised variables.+Thus: skolemise away. cf. Inst.deeplySkolemise and TcUnify.tcSkolemise+Examples in indexed-types/should_compile/T12369++Note [Eta-reduction for data families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   data D :: * -> * -> * -> * -> *++   data instance D [(a,b)] p q :: * -> * where+      D1 :: blah1+      D2 :: blah2++Then we'll generate a representation data type+  data Drep a b p q z where+      D1 :: blah1+      D2 :: blah2++and an axiom to connect them+  axiom AxDrep forall a b p q z. D [(a,b]] p q z = Drep a b p q z++except that we'll eta-reduce the axiom to+  axiom AxDrep forall a b. D [(a,b]] = Drep a b+There are several fiddly subtleties lurking here++* The representation tycon Drep is parameerised over the free+  variables of the pattern, in no particular order. So there is no+  guarantee that 'p' and 'q' will come last in Drep's parameters, and+  in the right order.  So, if the /patterns/ of the family insatance+  are eta-redcible, we re-order Drep's parameters to put the+  eta-reduced type variables last.++* Although we eta-reduce the axiom, we eta-/expand/ the representation+  tycon Drep.  The kind of D says it takses four arguments, but the+  data instance header only supplies three.  But the AlgTyCOn for Drep+  itself must have enough TyConBinders so that its result kind is Type.+  So, with etaExpandAlgTyCon we make up some extra TyConBinders++* The result kind in the instance might be a polykind, like this:+     data family DP a :: forall k. k -> *+     data instance DP [b] :: forall k1 k2. (k1,k2) -> *++  So in type-checking the LHS (DP Int) we need to check that it is+  more polymorphic than the signature.  To do that we must skolemise+  the siganture and istantiate the call of DP.  So we end up with+     data instance DP [b] @(k1,k2) (z :: (k1,k2)) where++  Note that we must parameterise the representation tycon DPrep over+  'k1' and 'k2', as well as 'b'.++  The skolemise bit is done in tc_kind_sig, while the instantiate bit+  is done by tcFamTyPats.++* Very fiddly point.  When we eta-reduce to+     axiom AxDrep forall a b. D [(a,b]] = Drep a b++  we want the kind of (D [(a,b)]) to be the same as the kind of+  (Drep a b).  This ensures that applying the axiom doesn't change the+  kind.  Why is that hard?  Because the kind of (Drep a b) depends on+  the TyConBndrVis on Drep's arguments. In particular do we have+    (forall (k::*). blah) or (* -> blah)?++  We must match whatever D does!  In #15817 we had+      data family X a :: forall k. * -> *   -- Note: a forall that is not used+      data instance X Int b = MkX++  So the data instance is really+      data istance X Int @k b = MkX++  The axiom will look like+      axiom    X Int = Xrep++  and it's important that XRep :: forall k * -> *, following X.++  To achieve this we get the TyConBndrVis flags from tcbVisibilities,+  and use those flags for any eta-reduced arguments.  Sigh.++* The final turn of the knife is that tcbVisibilities is itself+  tricky to sort out.  Consider+      data family D k :: k+  Then consider D (forall k2. k2 -> k2) Type Type+  The visibilty flags on an application of D may affected by the arguments+  themselves.  Heavy sigh.  But not truly hard; that's what tcbVisibilities+  does.++-}+++{- *********************************************************************+*                                                                      *+      Class instance declarations, pass 2+*                                                                      *+********************************************************************* -}++tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn]+             -> TcM (LHsBinds GhcTc)+-- (a) From each class declaration,+--      generate any default-method bindings+-- (b) From each instance decl+--      generate the dfun binding++tcInstDecls2 tycl_decls inst_decls+  = do  { -- (a) Default methods from class decls+          let class_decls = filter (isClassDecl . unLoc) tycl_decls+        ; dm_binds_s <- mapM tcClassDecl2 class_decls+        ; let dm_binds = unionManyBags dm_binds_s++          -- (b) instance declarations+        ; let dm_ids = collectHsBindsBinders dm_binds+              -- Add the default method Ids (again)+              -- (they were arready added in TcTyDecls.tcAddImplicits)+              -- See Note [Default methods in the type environment]+        ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $+                          mapM tcInstDecl2 inst_decls++          -- Done+        ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }++{- Note [Default methods in the type environment]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The default method Ids are already in the type environment (see Note+[Default method Ids and Template Haskell] in TcTyDcls), BUT they+don't have their InlinePragmas yet.  Usually that would not matter,+because the simplifier propagates information from binding site to+use.  But, unusually, when compiling instance decls we *copy* the+INLINE pragma from the default method to the method for that+particular operation (see Note [INLINE and default methods] below).++So right here in tcInstDecls2 we must re-extend the type envt with+the default method Ids replete with their INLINE pragmas.  Urk.+-}++tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc)+            -- Returns a binding for the dfun+tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })+  = recoverM (return emptyLHsBinds)             $+    setSrcSpan loc                              $+    addErrCtxt (instDeclCtxt2 (idType dfun_id)) $+    do {  -- Instantiate the instance decl with skolem constants+       ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id+       ; dfun_ev_vars <- newEvVars dfun_theta+                     -- We instantiate the dfun_id with superSkolems.+                     -- See Note [Subtle interaction of recursion and overlap]+                     -- and Note [Binding when looking up instances]++       ; let (clas, inst_tys) = tcSplitDFunHead inst_head+             (class_tyvars, sc_theta, _, op_items) = classBigSig clas+             sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys) sc_theta++       ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta'])++                      -- Deal with 'SPECIALISE instance' pragmas+                      -- See Note [SPECIALISE instance pragmas]+       ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds++         -- Typecheck superclasses and methods+         -- See Note [Typechecking plan for instance declarations]+       ; dfun_ev_binds_var <- newTcEvBinds+       ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var+       ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics))+             <- pushTcLevelM $+                do { (sc_ids, sc_binds, sc_implics)+                        <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars+                                          inst_tys dfun_ev_binds+                                          sc_theta'++                      -- Typecheck the methods+                   ; (meth_ids, meth_binds, meth_implics)+                        <- tcMethods dfun_id clas inst_tyvars dfun_ev_vars+                                     inst_tys dfun_ev_binds spec_inst_info+                                     op_items ibinds++                   ; return ( sc_ids     ++          meth_ids+                            , sc_binds   `unionBags` meth_binds+                            , sc_implics `unionBags` meth_implics ) }++       ; imp <- newImplication+       ; emitImplication $+         imp { ic_tclvl  = tclvl+             , ic_skols  = inst_tyvars+             , ic_given  = dfun_ev_vars+             , ic_wanted = mkImplicWC sc_meth_implics+             , ic_binds  = dfun_ev_binds_var+             , ic_info   = InstSkol }++       -- Create the result bindings+       ; self_dict <- newDict clas inst_tys+       ; let class_tc      = classTyCon clas+             [dict_constr] = tyConDataCons class_tc+             dict_bind     = mkVarBind self_dict (L loc con_app_args)++                     -- We don't produce a binding for the dict_constr; instead we+                     -- rely on the simplifier to unfold this saturated application+                     -- We do this rather than generate an HsCon directly, because+                     -- it means that the special cases (e.g. dictionary with only one+                     -- member) are dealt with by the common MkId.mkDataConWrapId+                     -- code rather than needing to be repeated here.+                     --    con_app_tys  = MkD ty1 ty2+                     --    con_app_scs  = MkD ty1 ty2 sc1 sc2+                     --    con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2+             con_app_tys  = mkHsWrap (mkWpTyApps inst_tys)+                                  (HsConLikeOut noExt (RealDataCon dict_constr))+                       -- NB: We *can* have covars in inst_tys, in the case of+                       -- promoted GADT constructors.++             con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids++             app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc+             app_to_meth fun meth_id = HsApp noExt (L loc fun)+                                            (L loc (wrapId arg_wrapper meth_id))++             inst_tv_tys = mkTyVarTys inst_tyvars+             arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys++             is_newtype = isNewTyCon class_tc+             dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids+             dfun_spec_prags+                | is_newtype = SpecPrags []+                | otherwise  = SpecPrags spec_inst_prags+                    -- Newtype dfuns just inline unconditionally,+                    -- so don't attempt to specialise them++             export = ABE { abe_ext  = noExt+                          , abe_wrap = idHsWrapper+                          , abe_poly = dfun_id_w_prags+                          , abe_mono = self_dict+                          , abe_prags = dfun_spec_prags }+                          -- NB: see Note [SPECIALISE instance pragmas]+             main_bind = AbsBinds { abs_ext = noExt+                                  , abs_tvs = inst_tyvars+                                  , abs_ev_vars = dfun_ev_vars+                                  , abs_exports = [export]+                                  , abs_ev_binds = []+                                  , abs_binds = unitBag dict_bind+                                  , abs_sig = True }++       ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds)+       }+ where+   dfun_id = instanceDFunId ispec+   loc     = getSrcSpan dfun_id++addDFunPrags :: DFunId -> [Id] -> DFunId+-- DFuns need a special Unfolding and InlinePrag+--    See Note [ClassOp/DFun selection]+--    and Note [Single-method classes]+-- It's easiest to create those unfoldings right here, where+-- have all the pieces in hand, even though we are messing with+-- Core at this point, which the typechecker doesn't usually do+-- However we take care to build the unfolding using the TyVars from+-- the DFunId rather than from the skolem pieces that the typechecker+-- is messing with.+addDFunPrags dfun_id sc_meth_ids+ | is_newtype+  = dfun_id `setIdUnfolding`  mkInlineUnfoldingWithArity 0 con_app+            `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }+ | otherwise+ = dfun_id `setIdUnfolding`  mkDFunUnfolding dfun_bndrs dict_con dict_args+           `setInlinePragma` dfunInlinePragma+ where+   con_app    = mkLams dfun_bndrs $+                mkApps (Var (dataConWrapId dict_con)) dict_args+                 -- mkApps is OK because of the checkForLevPoly call in checkValidClass+                 -- See Note [Levity polymorphism checking] in DsMonad+   dict_args  = map Type inst_tys +++                [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids]++   (dfun_tvs, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id)+   ev_ids      = mkTemplateLocalsNum 1                    dfun_theta+   dfun_bndrs  = dfun_tvs ++ ev_ids+   clas_tc     = classTyCon clas+   [dict_con]  = tyConDataCons clas_tc+   is_newtype  = isNewTyCon clas_tc++wrapId :: HsWrapper -> IdP (GhcPass id) -> HsExpr (GhcPass id)+wrapId wrapper id = mkHsWrap wrapper (HsVar noExt (noLoc id))++{- Note [Typechecking plan for instance declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For instance declarations we generate the following bindings and implication+constraints.  Example:++   instance Ord a => Ord [a] where compare = <compare-rhs>++generates this:++   Bindings:+      -- Method bindings+      $ccompare :: forall a. Ord a => a -> a -> Ordering+      $ccompare = /\a \(d:Ord a). let <meth-ev-binds> in ...++      -- Superclass bindings+      $cp1Ord :: forall a. Ord a => Eq [a]+      $cp1Ord = /\a \(d:Ord a). let <sc-ev-binds>+               in dfEqList (dw :: Eq a)++   Constraints:+      forall a. Ord a =>+                -- Method constraint+             (forall. (empty) => <constraints from compare-rhs>)+                -- Superclass constraint+          /\ (forall. (empty) => dw :: Eq a)++Notice that++ * Per-meth/sc implication.  There is one inner implication per+   superclass or method, with no skolem variables or givens.  The only+   reason for this one is to gather the evidence bindings privately+   for this superclass or method.  This implication is generated+   by checkInstConstraints.++ * Overall instance implication. There is an overall enclosing+   implication for the whole instance declaration, with the expected+   skolems and givens.  We need this to get the correct "redundant+   constraint" warnings, gathering all the uses from all the methods+   and superclasses.  See TcSimplify Note [Tracking redundant+   constraints]++ * The given constraints in the outer implication may generate+   evidence, notably by superclass selection.  Since the method and+   superclass bindings are top-level, we want that evidence copied+   into *every* method or superclass definition.  (Some of it will+   be usused in some, but dead-code elimination will drop it.)++   We achieve this by putting the evidence variable for the overall+   instance implication into the AbsBinds for each method/superclass.+   Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses.+   (And that in turn is why the abs_ev_binds field of AbBinds is a+   [TcEvBinds] rather than simply TcEvBinds.++   This is a bit of a hack, but works very nicely in practice.++ * Note that if a method has a locally-polymorphic binding, there will+   be yet another implication for that, generated by tcPolyCheck+   in tcMethodBody. E.g.+          class C a where+            foo :: forall b. Ord b => blah+++************************************************************************+*                                                                      *+      Type-checking superclasses+*                                                                      *+************************************************************************+-}++tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType]+               -> TcEvBinds+               -> TcThetaType+               -> TcM ([EvVar], LHsBinds GhcTc, Bag Implication)+-- Make a new top-level function binding for each superclass,+-- something like+--    $Ordp1 :: forall a. Ord a => Eq [a]+--    $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d)+--+-- See Note [Recursive superclasses] for why this is so hard!+-- In effect, we build a special-purpose solver for the first step+-- of solving each superclass constraint+tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta+  = do { (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..])+       ; return (ids, listToBag binds, listToBag implics) }+  where+    loc = getSrcSpan dfun_id+    size = sizeTypes inst_tys+    tc_super (sc_pred, n)+      = do { (sc_implic, ev_binds_var, sc_ev_tm)+                <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred++           ; sc_top_name  <- newName (mkSuperDictAuxOcc n (getOccName cls))+           ; sc_ev_id     <- newEvVar sc_pred+           ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm+           ; let sc_top_ty = mkInvForAllTys tyvars $+                             mkPhiTy (map idType dfun_evs) sc_pred+                 sc_top_id = mkLocalId sc_top_name sc_top_ty+                 export = ABE { abe_ext  = noExt+                              , abe_wrap = idHsWrapper+                              , abe_poly = sc_top_id+                              , abe_mono = sc_ev_id+                              , abe_prags = noSpecPrags }+                 local_ev_binds = TcEvBinds ev_binds_var+                 bind = AbsBinds { abs_ext      = noExt+                                 , abs_tvs      = tyvars+                                 , abs_ev_vars  = dfun_evs+                                 , abs_exports  = [export]+                                 , abs_ev_binds = [dfun_ev_binds, local_ev_binds]+                                 , abs_binds    = emptyBag+                                 , abs_sig      = False }+           ; return (sc_top_id, L loc bind, sc_implic) }++-------------------+checkInstConstraints :: TcM result+                     -> TcM (Implication, EvBindsVar, result)+-- See Note [Typechecking plan for instance declarations]+checkInstConstraints thing_inside+  = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints  $+                                    thing_inside++       ; ev_binds_var <- newTcEvBinds+       ; implic <- newImplication+       ; let implic' = implic { ic_tclvl  = tclvl+                              , ic_wanted = wanted+                              , ic_binds  = ev_binds_var+                              , ic_info   = InstSkol }++       ; return (implic', ev_binds_var, result) }++{-+Note [Recursive superclasses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See #3731, #4809, #5751, #5913, #6117, #6161, which all+describe somewhat more complicated situations, but ones+encountered in practice.++See also tests tcrun020, tcrun021, tcrun033, and #11427.++----- THE PROBLEM --------+The problem is that it is all too easy to create a class whose+superclass is bottom when it should not be.++Consider the following (extreme) situation:+        class C a => D a where ...+        instance D [a] => D [a] where ...   (dfunD)+        instance C [a] => C [a] where ...   (dfunC)+Although this looks wrong (assume D [a] to prove D [a]), it is only a+more extreme case of what happens with recursive dictionaries, and it+can, just about, make sense because the methods do some work before+recursing.++To implement the dfunD we must generate code for the superclass C [a],+which we had better not get by superclass selection from the supplied+argument:+       dfunD :: forall a. D [a] -> D [a]+       dfunD = \d::D [a] -> MkD (scsel d) ..++Otherwise if we later encounter a situation where+we have a [Wanted] dw::D [a] we might solve it thus:+     dw := dfunD dw+Which is all fine except that now ** the superclass C is bottom **!++The instance we want is:+       dfunD :: forall a. D [a] -> D [a]+       dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ...++----- THE SOLUTION --------+The basic solution is simple: be very careful about using superclass+selection to generate a superclass witness in a dictionary function+definition.  More precisely:++  Superclass Invariant: in every class dictionary,+                        every superclass dictionary field+                        is non-bottom++To achieve the Superclass Invariant, in a dfun definition we can+generate a guaranteed-non-bottom superclass witness from:+  (sc1) one of the dictionary arguments itself (all non-bottom)+  (sc2) an immediate superclass of a smaller dictionary+  (sc3) a call of a dfun (always returns a dictionary constructor)++The tricky case is (sc2).  We proceed by induction on the size of+the (type of) the dictionary, defined by TcValidity.sizeTypes.+Let's suppose we are building a dictionary of size 3, and+suppose the Superclass Invariant holds of smaller dictionaries.+Then if we have a smaller dictionary, its immediate superclasses+will be non-bottom by induction.++What does "we have a smaller dictionary" mean?  It might be+one of the arguments of the instance, or one of its superclasses.+Here is an example, taken from CmmExpr:+       class Ord r => UserOfRegs r a where ...+(i1)   instance UserOfRegs r a => UserOfRegs r (Maybe a) where+(i2)   instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where++For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a),+since it is smaller than the thing we are building (UserOfRegs r (Maybe a).++But for (i2) that isn't the case, so we must add an explicit, and+perhaps surprising, (Ord r) argument to the instance declaration.++Here's another example from #6161:++       class       Super a => Duper a  where ...+       class Duper (Fam a) => Foo a    where ...+(i3)   instance Foo a => Duper (Fam a) where ...+(i4)   instance              Foo Float where ...++It would be horribly wrong to define+   dfDuperFam :: Foo a -> Duper (Fam a)  -- from (i3)+   dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ...++   dfFooFloat :: Foo Float               -- from (i4)+   dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ...++Now the Super superclass of Duper is definitely bottom!++This won't happen because when processing (i3) we can use the+superclasses of (Foo a), which is smaller, namely Duper (Fam a).  But+that is *not* smaller than the target so we can't take *its*+superclasses.  As a result the program is rightly rejected, unless you+add (Super (Fam a)) to the context of (i3).++Note [Solving superclass constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+How do we ensure that every superclass witness is generated by+one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses].+Answer:++  * Superclass "wanted" constraints have CtOrigin of (ScOrigin size)+    where 'size' is the size of the instance declaration. e.g.+          class C a => D a where...+          instance blah => D [a] where ...+    The wanted superclass constraint for C [a] has origin+    ScOrigin size, where size = size( D [a] ).++  * (sc1) When we rewrite such a wanted constraint, it retains its+    origin.  But if we apply an instance declaration, we can set the+    origin to (ScOrigin infinity), thus lifting any restrictions by+    making prohibitedSuperClassSolve return False.++  * (sc2) ScOrigin wanted constraints can't be solved from a+    superclass selection, except at a smaller type.  This test is+    implemented by TcInteract.prohibitedSuperClassSolve++  * The "given" constraints of an instance decl have CtOrigin+    GivenOrigin InstSkol.++  * When we make a superclass selection from InstSkol we use+    a SkolemInfo of (InstSC size), where 'size' is the size of+    the constraint whose superclass we are taking.  A similarly+    when taking the superclass of an InstSC.  This is implemented+    in TcCanonical.newSCWorkFromFlavored++Note [Silent superclass arguments] (historical interest only)+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB1: this note describes our *old* solution to the+     recursive-superclass problem. I'm keeping the Note+     for now, just as institutional memory.+     However, the code for silent superclass arguments+     was removed in late Dec 2014++NB2: the silent-superclass solution introduced new problems+     of its own, in the form of instance overlap.  Tests+     SilentParametersOverlapping, T5051, and T7862 are examples++NB3: the silent-superclass solution also generated tons of+     extra dictionaries.  For example, in monad-transformer+     code, when constructing a Monad dictionary you had to pass+     an Applicative dictionary; and to construct that you neede+     a Functor dictionary. Yet these extra dictionaries were+     often never used.  Test T3064 compiled *far* faster after+     silent superclasses were eliminated.++Our solution to this problem "silent superclass arguments".  We pass+to each dfun some ``silent superclass arguments’’, which are the+immediate superclasses of the dictionary we are trying to+construct. In our example:+       dfun :: forall a. C [a] -> D [a] -> D [a]+       dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...+Notice the extra (dc :: C [a]) argument compared to the previous version.++This gives us:++     -----------------------------------------------------------+     DFun Superclass Invariant+     ~~~~~~~~~~~~~~~~~~~~~~~~+     In the body of a DFun, every superclass argument to the+     returned dictionary is+       either   * one of the arguments of the DFun,+       or       * constant, bound at top level+     -----------------------------------------------------------++This net effect is that it is safe to treat a dfun application as+wrapping a dictionary constructor around its arguments (in particular,+a dfun never picks superclasses from the arguments under the+dictionary constructor). No superclass is hidden inside a dfun+application.++The extra arguments required to satisfy the DFun Superclass Invariant+always come first, and are called the "silent" arguments.  You can+find out how many silent arguments there are using Id.dfunNSilent;+and then you can just drop that number of arguments to see the ones+that were in the original instance declaration.++DFun types are built (only) by MkId.mkDictFunId, so that is where we+decide what silent arguments are to be added.+-}++{-+************************************************************************+*                                                                      *+      Type-checking an instance method+*                                                                      *+************************************************************************++tcMethod+- Make the method bindings, as a [(NonRec, HsBinds)], one per method+- Remembering to use fresh Name (the instance method Name) as the binder+- Bring the instance method Ids into scope, for the benefit of tcInstSig+- Use sig_fn mapping instance method Name -> instance tyvars+- Ditto prag_fn+- Use tcValBinds to do the checking+-}++tcMethods :: DFunId -> Class+          -> [TcTyVar] -> [EvVar]+          -> [TcType]+          -> TcEvBinds+          -> ([Located TcSpecPrag], TcPragEnv)+          -> [ClassOpItem]+          -> InstBindings GhcRn+          -> TcM ([Id], LHsBinds GhcTc, Bag Implication)+        -- The returned inst_meth_ids all have types starting+        --      forall tvs. theta => ...+tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys+                  dfun_ev_binds (spec_inst_prags, prag_fn) op_items+                  (InstBindings { ib_binds      = binds+                                , ib_tyvars     = lexical_tvs+                                , ib_pragmas    = sigs+                                , ib_extensions = exts+                                , ib_derived    = is_derived })+  = tcExtendNameTyVarEnv (lexical_tvs `zip` tyvars) $+       -- The lexical_tvs scope over the 'where' part+    do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)+       ; checkMinimalDefinition+       ; checkMethBindMembership+       ; (ids, binds, mb_implics) <- set_exts exts $+                                     unset_warnings_deriving $+                                     mapAndUnzip3M tc_item op_items+       ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) }+  where+    set_exts :: [LangExt.Extension] -> TcM a -> TcM a+    set_exts es thing = foldr setXOptM thing es++    -- See Note [Avoid -Winaccessible-code when deriving]+    unset_warnings_deriving :: TcM a -> TcM a+    unset_warnings_deriving+      | is_derived = unsetWOptM Opt_WarnInaccessibleCode+      | otherwise  = id++    hs_sig_fn = mkHsSigFun sigs+    inst_loc  = getSrcSpan dfun_id++    ----------------------+    tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication)+    tc_item (sel_id, dm_info)+      | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn+      = tcMethodBody clas tyvars dfun_ev_vars inst_tys+                              dfun_ev_binds is_derived hs_sig_fn+                              spec_inst_prags prags+                              sel_id user_bind bndr_loc+      | otherwise+      = do { traceTc "tc_def" (ppr sel_id)+           ; tc_default sel_id dm_info }++    ----------------------+    tc_default :: Id -> DefMethInfo+               -> TcM (TcId, LHsBind GhcTc, Maybe Implication)++    tc_default sel_id (Just (dm_name, _))+      = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name+           ; tcMethodBody clas tyvars dfun_ev_vars inst_tys+                          dfun_ev_binds is_derived hs_sig_fn+                          spec_inst_prags inline_prags+                          sel_id meth_bind inst_loc }++    tc_default sel_id Nothing     -- No default method at all+      = do { traceTc "tc_def: warn" (ppr sel_id)+           ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars+                                       inst_tys sel_id+           ; dflags <- getDynFlags+           ; let meth_bind = mkVarBind meth_id $+                             mkLHsWrap lam_wrapper (error_rhs dflags)+           ; return (meth_id, meth_bind, Nothing) }+      where+        error_rhs dflags = L inst_loc $ HsApp noExt error_fun (error_msg dflags)+        error_fun    = L inst_loc $+                       wrapId (mkWpTyApps+                                [ getRuntimeRep meth_tau, meth_tau])+                              nO_METHOD_BINDING_ERROR_ID+        error_msg dflags = L inst_loc (HsLit noExt (HsStringPrim NoSourceText+                                              (unsafeMkByteString (error_string dflags))))+        meth_tau     = funResultTy (piResultTys (idType sel_id) inst_tys)+        error_string dflags = showSDoc dflags+                              (hcat [ppr inst_loc, vbar, ppr sel_id ])+        lam_wrapper  = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars++    ----------------------+    -- Check if one of the minimal complete definitions is satisfied+    checkMinimalDefinition+      = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $+        warnUnsatisfiedMinimalDefinition++    methodExists meth = isJust (findMethodBind meth binds prag_fn)++    ----------------------+    -- Check if any method bindings do not correspond to the class.+    -- See Note [Mismatched class methods and associated type families].+    checkMethBindMembership+      = mapM_ (addErrTc . badMethodErr clas) mismatched_meths+      where+        bind_nms         = map unLoc $ collectMethodBinders binds+        cls_meth_nms     = map (idName . fst) op_items+        mismatched_meths = bind_nms `minusList` cls_meth_nms++{-+Note [Mismatched class methods and associated type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's entirely possible for someone to put methods or associated type family+instances inside of a class in which it doesn't belong. For instance, we'd+want to fail if someone wrote this:++  instance Eq () where+    type Rep () = Maybe+    compare = undefined++Since neither the type family `Rep` nor the method `compare` belong to the+class `Eq`. Normally, this is caught in the renamer when resolving RdrNames,+since that would discover that the parent class `Eq` is incorrect.++However, there is a scenario in which the renamer could fail to catch this:+if the instance was generated through Template Haskell, as in #12387. In that+case, Template Haskell will provide fully resolved names (e.g.,+`GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going+on. For this reason, we also put an extra validity check for this in the+typechecker as a last resort.++Note [Avoid -Winaccessible-code when deriving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-Winaccessible-code can be particularly noisy when deriving instances for+GADTs. Consider the following example (adapted from #8128):++  data T a where+    MkT1 :: Int -> T Int+    MkT2 :: T Bool+    MkT3 :: T Bool+  deriving instance Eq (T a)+  deriving instance Ord (T a)++In the derived Ord instance, GHC will generate the following code:++  instance Ord (T a) where+    compare x y+      = case x of+          MkT2+            -> case y of+                 MkT1 {} -> GT+                 MkT2    -> EQ+                 _       -> LT+          ...++However, that MkT1 is unreachable, since the type indices for MkT1 and MkT2+differ, so if -Winaccessible-code is enabled, then deriving this instance will+result in unwelcome warnings.++One conceivable approach to fixing this issue would be to change `deriving Ord`+such that it becomes smarter about not generating unreachable cases. This,+however, would be a highly nontrivial refactor, as we'd have to propagate+through typing information everywhere in the algorithm that generates Ord+instances in order to determine which cases were unreachable. This seems like+a lot of work for minimal gain, so we have opted not to go for this approach.++Instead, we take the much simpler approach of always disabling+-Winaccessible-code for derived code. To accomplish this, we do the following:++1. In tcMethods (which typechecks method bindings), disable+   -Winaccessible-code.+2. When creating Implications during typechecking, record the Env+   (through ic_env) at the time of creation. Since the Env also stores+   DynFlags, this will remember that -Winaccessible-code was disabled over+   the scope of that implication.+3. After typechecking comes error reporting, where GHC must decide how to+   report inaccessible code to the user, on an Implication-by-Implication+   basis. If an Implication's DynFlags indicate that -Winaccessible-code was+   disabled, then don't bother reporting it. That's it!+-}++------------------------+tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType]+             -> TcEvBinds -> Bool+             -> HsSigFun+             -> [LTcSpecPrag] -> [LSig GhcRn]+             -> Id -> LHsBind GhcRn -> SrcSpan+             -> TcM (TcId, LHsBind GhcTc, Maybe Implication)+tcMethodBody clas tyvars dfun_ev_vars inst_tys+                     dfun_ev_binds is_derived+                     sig_fn spec_inst_prags prags+                     sel_id (L bind_loc meth_bind) bndr_loc+  = add_meth_ctxt $+    do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc)+       ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $+                                            mkMethIds clas tyvars dfun_ev_vars+                                                      inst_tys sel_id++       ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }+                       -- Substitute the local_meth_name for the binder+                       -- NB: the binding is always a FunBind++            -- taking instance signature into account might change the type of+            -- the local_meth_id+       ; (meth_implic, ev_binds_var, tc_bind)+             <- checkInstConstraints $+                tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind)++       ; global_meth_id <- addInlinePrags global_meth_id prags+       ; spec_prags     <- tcSpecPrags global_meth_id prags++        ; let specs  = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags+              export = ABE { abe_ext   = noExt+                           , abe_poly  = global_meth_id+                           , abe_mono  = local_meth_id+                           , abe_wrap  = idHsWrapper+                           , abe_prags = specs }++              local_ev_binds = TcEvBinds ev_binds_var+              full_bind = AbsBinds { abs_ext      = noExt+                                   , abs_tvs      = tyvars+                                   , abs_ev_vars  = dfun_ev_vars+                                   , abs_exports  = [export]+                                   , abs_ev_binds = [dfun_ev_binds, local_ev_binds]+                                   , abs_binds    = tc_bind+                                   , abs_sig      = True }++        ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) }+  where+        -- For instance decls that come from deriving clauses+        -- we want to print out the full source code if there's an error+        -- because otherwise the user won't see the code at all+    add_meth_ctxt thing+      | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing+      | otherwise  = thing++tcMethodBodyHelp :: HsSigFun -> Id -> TcId+                 -> LHsBind GhcRn -> TcM (LHsBinds GhcTcId)+tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind+  | Just hs_sig_ty <- hs_sig_fn sel_name+              -- There is a signature in the instance+              -- See Note [Instance method signatures]+  = do { let ctxt = FunSigCtxt sel_name True+       ; (sig_ty, hs_wrap)+             <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $+                do { inst_sigs <- xoptM LangExt.InstanceSigs+                   ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty)+                   ; sig_ty  <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty+                   ; let local_meth_ty = idType local_meth_id+                   ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $+                                tcSubType_NC ctxt sig_ty local_meth_ty+                   ; return (sig_ty, hs_wrap) }++       ; inner_meth_name <- newName (nameOccName sel_name)+       ; let inner_meth_id  = mkLocalId inner_meth_name sig_ty+             inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id+                                          , sig_ctxt = ctxt+                                          , sig_loc  = getLoc (hsSigType hs_sig_ty) }+++       ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind++       ; let export = ABE { abe_ext   = noExt+                          , abe_poly  = local_meth_id+                          , abe_mono  = inner_id+                          , abe_wrap  = hs_wrap+                          , abe_prags = noSpecPrags }++       ; return (unitBag $ L (getLoc meth_bind) $+                 AbsBinds { abs_ext = noExt, abs_tvs = [], abs_ev_vars = []+                          , abs_exports = [export]+                          , abs_binds = tc_bind, abs_ev_binds = []+                          , abs_sig = True }) }++  | otherwise  -- No instance signature+  = do { let ctxt = FunSigCtxt sel_name False+                    -- False <=> don't report redundant constraints+                    -- The signature is not under the users control!+             tc_sig = completeSigFromId ctxt local_meth_id+              -- Absent a type sig, there are no new scoped type variables here+              -- Only the ones from the instance decl itself, which are already+              -- in scope.  Example:+              --      class C a where { op :: forall b. Eq b => ... }+              --      instance C [c] where { op = <rhs> }+              -- In <rhs>, 'c' is scope but 'b' is not!++       ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind+       ; return tc_bind }++  where+    sel_name   = idName sel_id+    no_prag_fn = emptyPragEnv   -- No pragmas for local_meth_id;+                                -- they are all for meth_id+++------------------------+mkMethIds :: Class -> [TcTyVar] -> [EvVar]+          -> [TcType] -> Id -> TcM (TcId, TcId)+             -- returns (poly_id, local_id), but ignoring any instance signature+             -- See Note [Instance method signatures]+mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id+  = do  { poly_meth_name  <- newName (mkClassOpAuxOcc sel_occ)+        ; local_meth_name <- newName sel_occ+                  -- Base the local_meth_name on the selector name, because+                  -- type errors from tcMethodBody come from here+        ; let poly_meth_id  = mkLocalId poly_meth_name  poly_meth_ty+              local_meth_id = mkLocalId local_meth_name local_meth_ty++        ; return (poly_meth_id, local_meth_id) }+  where+    sel_name      = idName sel_id+    sel_occ       = nameOccName sel_name+    local_meth_ty = instantiateMethod clas sel_id inst_tys+    poly_meth_ty  = mkSpecSigmaTy tyvars theta local_meth_ty+    theta         = map idType dfun_ev_vars++methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)+methSigCtxt sel_name sig_ty meth_ty env0+  = do { (env1, sig_ty)  <- zonkTidyTcType env0 sig_ty+       ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty+       ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name))+                      2 (vcat [ text "is more general than its signature in the class"+                              , text "Instance sig:" <+> ppr sig_ty+                              , text "   Class sig:" <+> ppr meth_ty ])+       ; return (env2, msg) }++misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc+misplacedInstSig name hs_ty+  = vcat [ hang (text "Illegal type signature in instance declaration:")+              2 (hang (pprPrefixName name)+                    2 (dcolon <+> ppr hs_ty))+         , text "(Use InstanceSigs to allow this)" ]++{- Note [Instance method signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With -XInstanceSigs we allow the user to supply a signature for the+method in an instance declaration.  Here is an artificial example:++       data T a = MkT a+       instance Ord a => Ord (T a) where+         (>) :: forall b. b -> b -> Bool+         (>) = error "You can't compare Ts"++The instance signature can be *more* polymorphic than the instantiated+class method (in this case: Age -> Age -> Bool), but it cannot be less+polymorphic.  Moreover, if a signature is given, the implementation+code should match the signature, and type variables bound in the+singature should scope over the method body.++We achieve this by building a TcSigInfo for the method, whether or not+there is an instance method signature, and using that to typecheck+the declaration (in tcMethodBody).  That means, conveniently,+that the type variables bound in the signature will scope over the body.++What about the check that the instance method signature is more+polymorphic than the instantiated class method type?  We just do a+tcSubType call in tcMethodBodyHelp, and generate a nested AbsBind, like+this (for the example above++ AbsBind { abs_tvs = [a], abs_ev_vars = [d:Ord a]+         , abs_exports+             = ABExport { (>) :: forall a. Ord a => T a -> T a -> Bool+                        , gr_lcl :: T a -> T a -> Bool }+         , abs_binds+             = AbsBind { abs_tvs = [], abs_ev_vars = []+                       , abs_exports = ABExport { gr_lcl :: T a -> T a -> Bool+                                                , gr_inner :: forall b. b -> b -> Bool }+                       , abs_binds = AbsBind { abs_tvs = [b], abs_ev_vars = []+                                             , ..etc.. }+               } }++Wow!  Three nested AbsBinds!+ * The outer one abstracts over the tyvars and dicts for the instance+ * The middle one is only present if there is an instance signature,+   and does the impedance matching for that signature+ * The inner one is for the method binding itself against either the+   signature from the class, or the instance signature.+-}++----------------------+mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags+        -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id+        -- There are two sources:+        --   * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}+        --   * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}+        --     These ones have the dfun inside, but [perhaps surprisingly]+        --     the correct wrapper.+        -- See Note [Handling SPECIALISE pragmas] in TcBinds+mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me+  = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)+  where+    spec_prags_from_inst+       | isInlinePragma (idInlinePragma meth_id)+       = []  -- Do not inherit SPECIALISE from the instance if the+             -- method is marked INLINE, because then it'll be inlined+             -- and the specialisation would do nothing. (Indeed it'll provoke+             -- a warning from the desugarer+       | otherwise+       = [ L inst_loc (SpecPrag meth_id wrap inl)+         | L inst_loc (SpecPrag _       wrap inl) <- spec_inst_prags]+++mkDefMethBind :: Class -> [Type] -> Id -> Name+              -> TcM (LHsBind GhcRn, [LSig GhcRn])+-- The is a default method (vanailla or generic) defined in the class+-- So make a binding   op = $dmop @t1 @t2+-- where $dmop is the name of the default method in the class,+-- and t1,t2 are the instance types.+-- See Note [Default methods in instances] for why we use+-- visible type application here+mkDefMethBind clas inst_tys sel_id dm_name+  = do  { dflags <- getDynFlags+        ; dm_id <- tcLookupId dm_name+        ; let inline_prag = idInlinePragma dm_id+              inline_prags | isAnyInlinePragma inline_prag+                           = [noLoc (InlineSig noExt fn inline_prag)]+                           | otherwise+                           = []+                 -- Copy the inline pragma (if any) from the default method+                 -- to this version. Note [INLINE and default methods]++              fn   = noLoc (idName sel_id)+              visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys+                                      , tyConBinderArgFlag tcb /= Inferred ]+              rhs  = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys+              bind = noLoc $ mkTopFunBind Generated fn $+                             [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]++        ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"+                   (vcat [ppr clas <+> ppr inst_tys,+                          nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))++       ; return (bind, inline_prags) }+  where+    mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn+    mk_vta fun ty = noLoc (HsAppType noExt fun (mkEmptyWildCardBndrs $ nlHsParTy+                                                $ noLoc $ XHsType $ NHsCoreTy ty))+       -- NB: use visible type application+       -- See Note [Default methods in instances]++----------------------+derivBindCtxt :: Id -> Class -> [Type ] -> SDoc+derivBindCtxt sel_id clas tys+   = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id)+          , nest 2 (text "in a derived instance for"+                    <+> quotes (pprClassPred clas tys) <> colon)+          , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ]++warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM ()+warnUnsatisfiedMinimalDefinition mindef+  = do { warn <- woptM Opt_WarnMissingMethods+       ; warnTc (Reason Opt_WarnMissingMethods) warn message+       }+  where+    message = vcat [text "No explicit implementation for"+                   ,nest 2 $ pprBooleanFormulaNice mindef+                   ]++{-+Note [Export helper functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We arrange to export the "helper functions" of an instance declaration,+so that they are not subject to preInlineUnconditionally, even if their+RHS is trivial.  Reason: they are mentioned in the DFunUnfolding of+the dict fun as Ids, not as CoreExprs, so we can't substitute a+non-variable for them.++We could change this by making DFunUnfoldings have CoreExprs, but it+seems a bit simpler this way.++Note [Default methods in instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this++   class Baz v x where+      foo :: x -> x+      foo y = <blah>++   instance Baz Int Int++From the class decl we get++   $dmfoo :: forall v x. Baz v x => x -> x+   $dmfoo y = <blah>++Notice that the type is ambiguous.  So we use Visible Type Application+to disambiguate:++   $dBazIntInt = MkBaz fooIntInt+   fooIntInt = $dmfoo @Int @Int++Lacking VTA we'd get ambiguity errors involving the default method.  This applies+equally to vanilla default methods (#1061) and generic default methods+(#12220).++Historical note: before we had VTA we had to generate+post-type-checked code, which took a lot more code, and didn't work for+generic default methods.++Note [INLINE and default methods]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Default methods need special case.  They are supposed to behave rather like+macros.  For example++  class Foo a where+    op1, op2 :: Bool -> a -> a++    {-# INLINE op1 #-}+    op1 b x = op2 (not b) x++  instance Foo Int where+    -- op1 via default method+    op2 b x = <blah>++The instance declaration should behave++   just as if 'op1' had been defined with the+   code, and INLINE pragma, from its original+   definition.++That is, just as if you'd written++  instance Foo Int where+    op2 b x = <blah>++    {-# INLINE op1 #-}+    op1 b x = op2 (not b) x++So for the above example we generate:++  {-# INLINE $dmop1 #-}+  -- $dmop1 has an InlineCompulsory unfolding+  $dmop1 d b x = op2 d (not b) x++  $fFooInt = MkD $cop1 $cop2++  {-# INLINE $cop1 #-}+  $cop1 = $dmop1 $fFooInt++  $cop2 = <blah>++Note carefully:++* We *copy* any INLINE pragma from the default method $dmop1 to the+  instance $cop1.  Otherwise we'll just inline the former in the+  latter and stop, which isn't what the user expected++* Regardless of its pragma, we give the default method an+  unfolding with an InlineCompulsory source. That means+  that it'll be inlined at every use site, notably in+  each instance declaration, such as $cop1.  This inlining+  must happen even though+    a) $dmop1 is not saturated in $cop1+    b) $cop1 itself has an INLINE pragma++  It's vital that $dmop1 *is* inlined in this way, to allow the mutual+  recursion between $fooInt and $cop1 to be broken++* To communicate the need for an InlineCompulsory to the desugarer+  (which makes the Unfoldings), we use the IsDefaultMethod constructor+  in TcSpecPrags.+++************************************************************************+*                                                                      *+        Specialise instance pragmas+*                                                                      *+************************************************************************++Note [SPECIALISE instance pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++   instance (Ix a, Ix b) => Ix (a,b) where+     {-# SPECIALISE instance Ix (Int,Int) #-}+     range (x,y) = ...++We make a specialised version of the dictionary function, AND+specialised versions of each *method*.  Thus we should generate+something like this:++  $dfIxPair :: (Ix a, Ix b) => Ix (a,b)+  {-# DFUN [$crangePair, ...] #-}+  {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-}+  $dfIxPair da db = Ix ($crangePair da db) (...other methods...)++  $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]+  {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}+  $crange da db = <blah>++The SPECIALISE pragmas are acted upon by the desugarer, which generate++  dii :: Ix Int+  dii = ...++  $s$dfIxPair :: Ix ((Int,Int),(Int,Int))+  {-# DFUN [$crangePair di di, ...] #-}+  $s$dfIxPair = Ix ($crangePair di di) (...)++  {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-}++  $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)]+  $c$crangePair = ...specialised RHS of $crangePair...++  {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}++Note that++  * The specialised dictionary $s$dfIxPair is very much needed, in case we+    call a function that takes a dictionary, but in a context where the+    specialised dictionary can be used.  See #7797.++  * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because+    it still has a DFunUnfolding.  See Note [ClassOp/DFun selection]++  * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways:+       --> {ClassOp rule for range}     $crangePair Int Int d1 d2+       --> {SPEC rule for $crangePair}  $s$crangePair+    or thus:+       --> {SPEC rule for $dfIxPair}    range $s$dfIxPair+       --> {ClassOpRule for range}      $s$crangePair+    It doesn't matter which way.++  * We want to specialise the RHS of both $dfIxPair and $crangePair,+    but the SAME HsWrapper will do for both!  We can call tcSpecPrag+    just once, and pass the result (in spec_inst_info) to tcMethods.+-}++tcSpecInstPrags :: DFunId -> InstBindings GhcRn+                -> TcM ([Located TcSpecPrag], TcPragEnv)+tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })+  = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $+                            filter isSpecInstLSig uprags+             -- The filter removes the pragmas for methods+       ; return (spec_inst_prags, mkPragEnv uprags binds) }++------------------------------+tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag+tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty)+  = addErrCtxt (spec_ctxt prag) $+    do  { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty+        ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty+        ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }+  where+    spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)++tcSpecInst _  _ = panic "tcSpecInst"++{-+************************************************************************+*                                                                      *+\subsection{Error messages}+*                                                                      *+************************************************************************+-}++instDeclCtxt1 :: LHsSigType GhcRn -> SDoc+instDeclCtxt1 hs_inst_ty+  = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))++instDeclCtxt2 :: Type -> SDoc+instDeclCtxt2 dfun_ty+  = inst_decl_ctxt (ppr (mkClassPred cls tys))+  where+    (_,_,cls,tys) = tcSplitDFunTy dfun_ty++inst_decl_ctxt :: SDoc -> SDoc+inst_decl_ctxt doc = hang (text "In the instance declaration for")+                        2 (quotes doc)++badBootFamInstDeclErr :: SDoc+badBootFamInstDeclErr+  = text "Illegal family instance in hs-boot file"++notFamily :: TyCon -> SDoc+notFamily tycon+  = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon)+         , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")]++assocInClassErr :: TyCon -> SDoc+assocInClassErr name+ = text "Associated type" <+> quotes (ppr name) <+>+   text "must be inside a class instance"++badFamInstDecl :: TyCon -> SDoc+badFamInstDecl tc_name+  = vcat [ text "Illegal family instance for" <+>+           quotes (ppr tc_name)+         , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ]++notOpenFamily :: TyCon -> SDoc+notOpenFamily tc+  = text "Illegal instance for closed family" <+> quotes (ppr tc)
+ compiler/typecheck/TcInstDcls.hs-boot view
@@ -0,0 +1,16 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++module TcInstDcls ( tcInstDecls1 ) where++import HsSyn+import TcRnTypes+import TcEnv( InstInfo )+import TcDeriv++-- We need this because of the mutual recursion+-- between TcTyClsDecls and TcInstDcls+tcInstDecls1 :: [LInstDecl GhcRn]+             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])
+ compiler/typecheck/TcInteract.hs view
@@ -0,0 +1,2609 @@+{-# LANGUAGE CPP #-}++module TcInteract (+     solveSimpleGivens,   -- Solves [Ct]+     solveSimpleWanteds,  -- Solves Cts+  ) where++#include "HsVersions.h"++import GhcPrelude+import BasicTypes ( SwapFlag(..), isSwapped,+                    infinity, IntWithInf, intGtLimit )+import TcCanonical+import TcFlatten+import TcUnify( canSolveByUnification )+import VarSet+import Type+import InstEnv( DFunInstType )+import CoAxiom( sfInteractTop, sfInteractInert )++import Var+import TcType+import PrelNames ( coercibleTyConKey,+                   heqTyConKey, eqTyConKey, ipClassKey )+import CoAxiom ( TypeEqn, CoAxiom(..), CoAxBranch(..), fromBranches )+import Class+import TyCon+import FunDeps+import FamInst+import ClsInst( InstanceWhat(..), safeOverlap )+import FamInstEnv+import Unify ( tcUnifyTyWithTFs, ruleMatchTyKiX )++import TcEvidence+import Outputable++import TcRnTypes+import TcSMonad+import Bag+import MonadUtils ( concatMapM, foldlM )++import CoreSyn+import Data.List( partition, deleteFirstsBy )+import SrcLoc+import VarEnv++import Control.Monad+import Maybes( isJust )+import Pair (Pair(..))+import Unique( hasKey )+import DynFlags+import Util+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad.Trans.Class+import Control.Monad.Trans.Maybe++{-+**********************************************************************+*                                                                    *+*                      Main Interaction Solver                       *+*                                                                    *+**********************************************************************++Note [Basic Simplifier Plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+1. Pick an element from the WorkList if there exists one with depth+   less than our context-stack depth.++2. Run it down the 'stage' pipeline. Stages are:+      - canonicalization+      - inert reactions+      - spontaneous reactions+      - top-level intreactions+   Each stage returns a StopOrContinue and may have sideffected+   the inerts or worklist.++   The threading of the stages is as follows:+      - If (Stop) is returned by a stage then we start again from Step 1.+      - If (ContinueWith ct) is returned by a stage, we feed 'ct' on to+        the next stage in the pipeline.+4. If the element has survived (i.e. ContinueWith x) the last stage+   then we add him in the inerts and jump back to Step 1.++If in Step 1 no such element exists, we have exceeded our context-stack+depth and will simply fail.++Note [Unflatten after solving the simple wanteds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We unflatten after solving the wc_simples of an implication, and before attempting+to float. This means that++ * The fsk/fmv flatten-skolems only survive during solveSimples.  We don't+   need to worry about them across successive passes over the constraint tree.+   (E.g. we don't need the old ic_fsk field of an implication.++ * When floating an equality outwards, we don't need to worry about floating its+   associated flattening constraints.++ * Another tricky case becomes easy: #4935+       type instance F True a b = a+       type instance F False a b = b++       [w] F c a b ~ gamma+       (c ~ True) => a ~ gamma+       (c ~ False) => b ~ gamma++   Obviously this is soluble with gamma := F c a b, and unflattening+   will do exactly that after solving the simple constraints and before+   attempting the implications.  Before, when we were not unflattening,+   we had to push Wanted funeqs in as new givens.  Yuk!++   Another example that becomes easy: indexed_types/should_fail/T7786+      [W] BuriedUnder sub k Empty ~ fsk+      [W] Intersect fsk inv ~ s+      [w] xxx[1] ~ s+      [W] forall[2] . (xxx[1] ~ Empty)+                   => Intersect (BuriedUnder sub k Empty) inv ~ Empty++Note [Running plugins on unflattened wanteds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is an annoying mismatch between solveSimpleGivens and+solveSimpleWanteds, because the latter needs to fiddle with the inert+set, unflatten and zonk the wanteds.  It passes the zonked wanteds+to runTcPluginsWanteds, which produces a replacement set of wanteds,+some additional insolubles and a flag indicating whether to go round+the loop again.  If so, prepareInertsForImplications is used to remove+the previous wanteds (which will still be in the inert set).  Note+that prepareInertsForImplications will discard the insolubles, so we+must keep track of them separately.+-}++solveSimpleGivens :: [Ct] -> TcS ()+solveSimpleGivens givens+  | null givens  -- Shortcut for common case+  = return ()+  | otherwise+  = do { traceTcS "solveSimpleGivens {" (ppr givens)+       ; go givens+       ; traceTcS "End solveSimpleGivens }" empty }+  where+    go givens = do { solveSimples (listToBag givens)+                   ; new_givens <- runTcPluginsGiven+                   ; when (notNull new_givens) $+                     go new_givens }++solveSimpleWanteds :: Cts -> TcS WantedConstraints+-- NB: 'simples' may contain /derived/ equalities, floated+--     out from a nested implication. So don't discard deriveds!+-- The result is not necessarily zonked+solveSimpleWanteds simples+  = do { traceTcS "solveSimpleWanteds {" (ppr simples)+       ; dflags <- getDynFlags+       ; (n,wc) <- go 1 (solverIterations dflags) (emptyWC { wc_simple = simples })+       ; traceTcS "solveSimpleWanteds end }" $+             vcat [ text "iterations =" <+> ppr n+                  , text "residual =" <+> ppr wc ]+       ; return wc }+  where+    go :: Int -> IntWithInf -> WantedConstraints -> TcS (Int, WantedConstraints)+    go n limit wc+      | n `intGtLimit` limit+      = failTcS (hang (text "solveSimpleWanteds: too many iterations"+                       <+> parens (text "limit =" <+> ppr limit))+                    2 (vcat [ text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"+                            , text "Simples =" <+> ppr simples+                            , text "WC ="      <+> ppr wc ]))++     | isEmptyBag (wc_simple wc)+     = return (n,wc)++     | otherwise+     = do { -- Solve+            (unif_count, wc1) <- solve_simple_wanteds wc++            -- Run plugins+          ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1+             -- See Note [Running plugins on unflattened wanteds]++          ; if unif_count == 0 && not rerun_plugin+            then return (n, wc2)             -- Done+            else do { traceTcS "solveSimple going round again:" $+                      ppr unif_count $$ ppr rerun_plugin+                    ; go (n+1) limit wc2 } }      -- Loop+++solve_simple_wanteds :: WantedConstraints -> TcS (Int, WantedConstraints)+-- Try solving these constraints+-- Affects the unification state (of course) but not the inert set+-- The result is not necessarily zonked+solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1 })+  = nestTcS $+    do { solveSimples simples1+       ; (implics2, tv_eqs, fun_eqs, others) <- getUnsolvedInerts+       ; (unif_count, unflattened_eqs) <- reportUnifications $+                                          unflattenWanteds tv_eqs fun_eqs+            -- See Note [Unflatten after solving the simple wanteds]+       ; return ( unif_count+                , WC { wc_simple = others `andCts` unflattened_eqs+                     , wc_impl   = implics1 `unionBags` implics2 }) }++{- Note [The solveSimpleWanteds loop]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Solving a bunch of simple constraints is done in a loop,+(the 'go' loop of 'solveSimpleWanteds'):+  1. Try to solve them; unflattening may lead to improvement that+     was not exploitable during solving+  2. Try the plugin+  3. If step 1 did improvement during unflattening; or if the plugin+     wants to run again, go back to step 1++Non-obviously, improvement can also take place during+the unflattening that takes place in step (1). See TcFlatten,+See Note [Unflattening can force the solver to iterate]+-}++-- The main solver loop implements Note [Basic Simplifier Plan]+---------------------------------------------------------------+solveSimples :: Cts -> TcS ()+-- Returns the final InertSet in TcS+-- Has no effect on work-list or residual-implications+-- The constraints are initially examined in left-to-right order++solveSimples cts+  = {-# SCC "solveSimples" #-}+    do { updWorkListTcS (\wl -> foldrBag extendWorkListCt wl cts)+       ; solve_loop }+  where+    solve_loop+      = {-# SCC "solve_loop" #-}+        do { sel <- selectNextWorkItem+           ; case sel of+              Nothing -> return ()+              Just ct -> do { runSolverPipeline thePipeline ct+                            ; solve_loop } }++-- | Extract the (inert) givens and invoke the plugins on them.+-- Remove solved givens from the inert set and emit insolubles, but+-- return new work produced so that 'solveSimpleGivens' can feed it back+-- into the main solver.+runTcPluginsGiven :: TcS [Ct]+runTcPluginsGiven+  = do { plugins <- getTcPlugins+       ; if null plugins then return [] else+    do { givens <- getInertGivens+       ; if null givens then return [] else+    do { p <- runTcPlugins plugins (givens,[],[])+       ; let (solved_givens, _, _) = pluginSolvedCts p+             insols                = pluginBadCts p+       ; updInertCans (removeInertCts solved_givens)+       ; updInertIrreds (\irreds -> extendCtsList irreds insols)+       ; return (pluginNewCts p) } } }++-- | Given a bag of (flattened, zonked) wanteds, invoke the plugins on+-- them and produce an updated bag of wanteds (possibly with some new+-- work) and a bag of insolubles.  The boolean indicates whether+-- 'solveSimpleWanteds' should feed the updated wanteds back into the+-- main solver.+runTcPluginsWanted :: WantedConstraints -> TcS (Bool, WantedConstraints)+runTcPluginsWanted wc@(WC { wc_simple = simples1, wc_impl = implics1 })+  | isEmptyBag simples1+  = return (False, wc)+  | otherwise+  = do { plugins <- getTcPlugins+       ; if null plugins then return (False, wc) else++    do { given <- getInertGivens+       ; simples1 <- zonkSimples simples1    -- Plugin requires zonked inputs+       ; let (wanted, derived) = partition isWantedCt (bagToList simples1)+       ; p <- runTcPlugins plugins (given, derived, wanted)+       ; let (_, _,                solved_wanted)   = pluginSolvedCts p+             (_, unsolved_derived, unsolved_wanted) = pluginInputCts p+             new_wanted                             = pluginNewCts p+             insols                                 = pluginBadCts p++-- SLPJ: I'm deeply suspicious of this+--       ; updInertCans (removeInertCts $ solved_givens ++ solved_deriveds)++       ; mapM_ setEv solved_wanted+       ; return ( notNull (pluginNewCts p)+                , WC { wc_simple = listToBag new_wanted       `andCts`+                                   listToBag unsolved_wanted  `andCts`+                                   listToBag unsolved_derived `andCts`+                                   listToBag insols+                     , wc_impl   = implics1 } ) } }+  where+    setEv :: (EvTerm,Ct) -> TcS ()+    setEv (ev,ct) = case ctEvidence ct of+      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest ev+      _ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!"++-- | A triple of (given, derived, wanted) constraints to pass to plugins+type SplitCts  = ([Ct], [Ct], [Ct])++-- | A solved triple of constraints, with evidence for wanteds+type SolvedCts = ([Ct], [Ct], [(EvTerm,Ct)])++-- | Represents collections of constraints generated by typechecker+-- plugins+data TcPluginProgress = TcPluginProgress+    { pluginInputCts  :: SplitCts+      -- ^ Original inputs to the plugins with solved/bad constraints+      -- removed, but otherwise unmodified+    , pluginSolvedCts :: SolvedCts+      -- ^ Constraints solved by plugins+    , pluginBadCts    :: [Ct]+      -- ^ Constraints reported as insoluble by plugins+    , pluginNewCts    :: [Ct]+      -- ^ New constraints emitted by plugins+    }++getTcPlugins :: TcS [TcPluginSolver]+getTcPlugins = do { tcg_env <- getGblEnv; return (tcg_tc_plugins tcg_env) }++-- | Starting from a triple of (given, derived, wanted) constraints,+-- invoke each of the typechecker plugins in turn and return+--+--  * the remaining unmodified constraints,+--  * constraints that have been solved,+--  * constraints that are insoluble, and+--  * new work.+--+-- Note that new work generated by one plugin will not be seen by+-- other plugins on this pass (but the main constraint solver will be+-- re-invoked and they will see it later).  There is no check that new+-- work differs from the original constraints supplied to the plugin:+-- the plugin itself should perform this check if necessary.+runTcPlugins :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress+runTcPlugins plugins all_cts+  = foldM do_plugin initialProgress plugins+  where+    do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress+    do_plugin p solver = do+        result <- runTcPluginTcS (uncurry3 solver (pluginInputCts p))+        return $ progress p result++    progress :: TcPluginProgress -> TcPluginResult -> TcPluginProgress+    progress p (TcPluginContradiction bad_cts) =+       p { pluginInputCts = discard bad_cts (pluginInputCts p)+         , pluginBadCts   = bad_cts ++ pluginBadCts p+         }+    progress p (TcPluginOk solved_cts new_cts) =+      p { pluginInputCts  = discard (map snd solved_cts) (pluginInputCts p)+        , pluginSolvedCts = add solved_cts (pluginSolvedCts p)+        , pluginNewCts    = new_cts ++ pluginNewCts p+        }++    initialProgress = TcPluginProgress all_cts ([], [], []) [] []++    discard :: [Ct] -> SplitCts -> SplitCts+    discard cts (xs, ys, zs) =+        (xs `without` cts, ys `without` cts, zs `without` cts)++    without :: [Ct] -> [Ct] -> [Ct]+    without = deleteFirstsBy eqCt++    eqCt :: Ct -> Ct -> Bool+    eqCt c c' = ctFlavour c == ctFlavour c'+             && ctPred c `tcEqType` ctPred c'++    add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts+    add xs scs = foldl' addOne scs xs++    addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts+    addOne (givens, deriveds, wanteds) (ev,ct) = case ctEvidence ct of+      CtGiven  {} -> (ct:givens, deriveds, wanteds)+      CtDerived{} -> (givens, ct:deriveds, wanteds)+      CtWanted {} -> (givens, deriveds, (ev,ct):wanteds)+++type WorkItem = Ct+type SimplifierStage = WorkItem -> TcS (StopOrContinue Ct)++runSolverPipeline :: [(String,SimplifierStage)] -- The pipeline+                  -> WorkItem                   -- The work item+                  -> TcS ()+-- Run this item down the pipeline, leaving behind new work and inerts+runSolverPipeline pipeline workItem+  = do { wl <- getWorkList+       ; inerts <- getTcSInerts+       ; tclevel <- getTcLevel+       ; traceTcS "----------------------------- " empty+       ; traceTcS "Start solver pipeline {" $+                  vcat [ text "tclevel =" <+> ppr tclevel+                       , text "work item =" <+> ppr workItem+                       , text "inerts =" <+> ppr inerts+                       , text "rest of worklist =" <+> ppr wl ]++       ; bumpStepCountTcS    -- One step for each constraint processed+       ; final_res  <- run_pipeline pipeline (ContinueWith workItem)++       ; case final_res of+           Stop ev s       -> do { traceFireTcS ev s+                                 ; traceTcS "End solver pipeline (discharged) }" empty+                                 ; return () }+           ContinueWith ct -> do { addInertCan ct+                                 ; traceFireTcS (ctEvidence ct) (text "Kept as inert")+                                 ; traceTcS "End solver pipeline (kept as inert) }" $+                                            (text "final_item =" <+> ppr ct) }+       }+  where run_pipeline :: [(String,SimplifierStage)] -> StopOrContinue Ct+                     -> TcS (StopOrContinue Ct)+        run_pipeline [] res        = return res+        run_pipeline _ (Stop ev s) = return (Stop ev s)+        run_pipeline ((stg_name,stg):stgs) (ContinueWith ct)+          = do { traceTcS ("runStage " ++ stg_name ++ " {")+                          (text "workitem   = " <+> ppr ct)+               ; res <- stg ct+               ; traceTcS ("end stage " ++ stg_name ++ " }") empty+               ; run_pipeline stgs res }++{-+Example 1:+  Inert:   {c ~ d, F a ~ t, b ~ Int, a ~ ty} (all given)+  Reagent: a ~ [b] (given)++React with (c~d)     ==> IR (ContinueWith (a~[b]))  True    []+React with (F a ~ t) ==> IR (ContinueWith (a~[b]))  False   [F [b] ~ t]+React with (b ~ Int) ==> IR (ContinueWith (a~[Int]) True    []++Example 2:+  Inert:  {c ~w d, F a ~g t, b ~w Int, a ~w ty}+  Reagent: a ~w [b]++React with (c ~w d)   ==> IR (ContinueWith (a~[b]))  True    []+React with (F a ~g t) ==> IR (ContinueWith (a~[b]))  True    []    (can't rewrite given with wanted!)+etc.++Example 3:+  Inert:  {a ~ Int, F Int ~ b} (given)+  Reagent: F a ~ b (wanted)++React with (a ~ Int)   ==> IR (ContinueWith (F Int ~ b)) True []+React with (F Int ~ b) ==> IR Stop True []    -- after substituting we re-canonicalize and get nothing+-}++thePipeline :: [(String,SimplifierStage)]+thePipeline = [ ("canonicalization",        TcCanonical.canonicalize)+              , ("interact with inerts",    interactWithInertsStage)+              , ("top-level reactions",     topReactionsStage) ]++{-+*********************************************************************************+*                                                                               *+                       The interact-with-inert Stage+*                                                                               *+*********************************************************************************++Note [The Solver Invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We always add Givens first.  So you might think that the solver has+the invariant++   If the work-item is Given,+   then the inert item must Given++But this isn't quite true.  Suppose we have,+    c1: [W] beta ~ [alpha], c2 : [W] blah, c3 :[W] alpha ~ Int+After processing the first two, we get+     c1: [G] beta ~ [alpha], c2 : [W] blah+Now, c3 does not interact with the given c1, so when we spontaneously+solve c3, we must re-react it with the inert set.  So we can attempt a+reaction between inert c2 [W] and work-item c3 [G].++It *is* true that [Solver Invariant]+   If the work-item is Given,+   AND there is a reaction+   then the inert item must Given+or, equivalently,+   If the work-item is Given,+   and the inert item is Wanted/Derived+   then there is no reaction+-}++-- Interaction result of  WorkItem <~> Ct++interactWithInertsStage :: WorkItem -> TcS (StopOrContinue Ct)+-- Precondition: if the workitem is a CTyEqCan then it will not be able to+-- react with anything at this stage.++interactWithInertsStage wi+  = do { inerts <- getTcSInerts+       ; let ics = inert_cans inerts+       ; case wi of+             CTyEqCan  {} -> interactTyVarEq ics wi+             CFunEqCan {} -> interactFunEq   ics wi+             CIrredCan {} -> interactIrred   ics wi+             CDictCan  {} -> interactDict    ics wi+             _ -> pprPanic "interactWithInerts" (ppr wi) }+                -- CHoleCan are put straight into inert_frozen, so never get here+                -- CNonCanonical have been canonicalised++data InteractResult+   = KeepInert   -- Keep the inert item, and solve the work item from it+                 -- (if the latter is Wanted; just discard it if not)+   | KeepWork    -- Keep the work item, and solve the intert item from it++instance Outputable InteractResult where+  ppr KeepInert = text "keep inert"+  ppr KeepWork  = text "keep work-item"++solveOneFromTheOther :: CtEvidence  -- Inert+                     -> CtEvidence  -- WorkItem+                     -> TcS InteractResult+-- Precondition:+-- * inert and work item represent evidence for the /same/ predicate+--+-- We can always solve one from the other: even if both are wanted,+-- although we don't rewrite wanteds with wanteds, we can combine+-- two wanteds into one by solving one from the other++solveOneFromTheOther ev_i ev_w+  | isDerived ev_w         -- Work item is Derived; just discard it+  = return KeepInert++  | isDerived ev_i     -- The inert item is Derived, we can just throw it away,+  = return KeepWork    -- The ev_w is inert wrt earlier inert-set items,+                       -- so it's safe to continue on from this point++  | CtWanted { ctev_loc = loc_w } <- ev_w+  , prohibitedSuperClassSolve (ctEvLoc ev_i) loc_w+  = -- inert must be Given+    do { traceTcS "prohibitedClassSolve1" (ppr ev_i $$ ppr ev_w)+       ; return KeepWork }++  | CtWanted {} <- ev_w+       -- Inert is Given or Wanted+  = return KeepInert++  -- From here on the work-item is Given++  | CtWanted { ctev_loc = loc_i } <- ev_i+  , prohibitedSuperClassSolve (ctEvLoc ev_w) loc_i+  = do { traceTcS "prohibitedClassSolve2" (ppr ev_i $$ ppr ev_w)+       ; return KeepInert }      -- Just discard the un-usable Given+                                 -- This never actually happens because+                                 -- Givens get processed first++  | CtWanted {} <- ev_i+  = return KeepWork++  -- From here on both are Given+  -- See Note [Replacement vs keeping]++  | lvl_i == lvl_w+  = do { ev_binds_var <- getTcEvBindsVar+       ; binds <- getTcEvBindsMap ev_binds_var+       ; return (same_level_strategy binds) }++  | otherwise   -- Both are Given, levels differ+  = return different_level_strategy+  where+     pred  = ctEvPred ev_i+     loc_i = ctEvLoc ev_i+     loc_w = ctEvLoc ev_w+     lvl_i = ctLocLevel loc_i+     lvl_w = ctLocLevel loc_w+     ev_id_i = ctEvEvId ev_i+     ev_id_w = ctEvEvId ev_w++     different_level_strategy  -- Both Given+       | isIPPred pred, lvl_w > lvl_i = KeepWork+       | lvl_w < lvl_i                = KeepWork+       | otherwise                    = KeepInert++     same_level_strategy binds -- Both Given+       | GivenOrigin (InstSC s_i) <- ctLocOrigin loc_i+       = case ctLocOrigin loc_w of+            GivenOrigin (InstSC s_w) | s_w < s_i -> KeepWork+                                     | otherwise -> KeepInert+            _                                    -> KeepWork++       | GivenOrigin (InstSC {}) <- ctLocOrigin loc_w+       = KeepInert++       | has_binding binds ev_id_w+       , not (has_binding binds ev_id_i)+       , not (ev_id_i `elemVarSet` findNeededEvVars binds (unitVarSet ev_id_w))+       = KeepWork++       | otherwise+       = KeepInert++     has_binding binds ev_id = isJust (lookupEvBind binds ev_id)++{-+Note [Replacement vs keeping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have two Given constraints both of type (C tys), say, which should+we keep?  More subtle than you might think!++  * Constraints come from different levels (different_level_strategy)++      - For implicit parameters we want to keep the innermost (deepest)+        one, so that it overrides the outer one.+        See Note [Shadowing of Implicit Parameters]++      - For everything else, we want to keep the outermost one.  Reason: that+        makes it more likely that the inner one will turn out to be unused,+        and can be reported as redundant.  See Note [Tracking redundant constraints]+        in TcSimplify.++        It transpires that using the outermost one is reponsible for an+        8% performance improvement in nofib cryptarithm2, compared to+        just rolling the dice.  I didn't investigate why.++  * Constraints coming from the same level (i.e. same implication)++       (a) Always get rid of InstSC ones if possible, since they are less+           useful for solving.  If both are InstSC, choose the one with+           the smallest TypeSize+           See Note [Solving superclass constraints] in TcInstDcls++       (b) Keep the one that has a non-trivial evidence binding.+              Example:  f :: (Eq a, Ord a) => blah+              then we may find [G] d3 :: Eq a+                               [G] d2 :: Eq a+                with bindings  d3 = sc_sel (d1::Ord a)+            We want to discard d2 in favour of the superclass selection from+            the Ord dictionary.+            Why? See Note [Tracking redundant constraints] in TcSimplify again.++       (c) But don't do (b) if the evidence binding depends transitively on the+           one without a binding.  Example (with RecursiveSuperClasses)+              class C a => D a+              class D a => C a+           Inert:     d1 :: C a, d2 :: D a+           Binds:     d3 = sc_sel d2, d2 = sc_sel d1+           Work item: d3 :: C a+           Then it'd be ridiculous to replace d1 with d3 in the inert set!+           Hence the findNeedEvVars test.  See #14774.++  * Finally, when there is still a choice, use KeepInert rather than+    KeepWork, for two reasons:+      - to avoid unnecessary munging of the inert set.+      - to cut off superclass loops; see Note [Superclass loops] in TcCanonical++Doing the depth-check for implicit parameters, rather than making the work item+always override, is important.  Consider++    data T a where { T1 :: (?x::Int) => T Int; T2 :: T a }++    f :: (?x::a) => T a -> Int+    f T1 = ?x+    f T2 = 3++We have a [G] (?x::a) in the inert set, and at the pattern match on T1 we add+two new givens in the work-list:  [G] (?x::Int)+                                  [G] (a ~ Int)+Now consider these steps+  - process a~Int, kicking out (?x::a)+  - process (?x::Int), the inner given, adding to inert set+  - process (?x::a), the outer given, overriding the inner given+Wrong!  The depth-check ensures that the inner implicit parameter wins.+(Actually I think that the order in which the work-list is processed means+that this chain of events won't happen, but that's very fragile.)++*********************************************************************************+*                                                                               *+                   interactIrred+*                                                                               *+*********************************************************************************++Note [Multiple matching irreds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You might think that it's impossible to have multiple irreds all match the+work item; after all, interactIrred looks for matches and solves one from the+other. However, note that interacting insoluble, non-droppable irreds does not+do this matching. We thus might end up with several insoluble, non-droppable,+matching irreds in the inert set. When another irred comes along that we have+not yet labeled insoluble, we can find multiple matches. These multiple matches+cause no harm, but it would be wrong to ASSERT that they aren't there (as we+once had done). This problem can be tickled by typecheck/should_compile/holes.++-}++-- Two pieces of irreducible evidence: if their types are *exactly identical*+-- we can rewrite them. We can never improve using this:+-- if we want ty1 :: Constraint and have ty2 :: Constraint it clearly does not+-- mean that (ty1 ~ ty2)+interactIrred :: InertCans -> Ct -> TcS (StopOrContinue Ct)++interactIrred inerts workItem@(CIrredCan { cc_ev = ev_w, cc_insol = insoluble })+  | insoluble  -- For insolubles, don't allow the constaint to be dropped+               -- which can happen with solveOneFromTheOther, so that+               -- we get distinct error messages with -fdefer-type-errors+               -- See Note [Do not add duplicate derived insolubles]+  , not (isDroppableCt workItem)+  = continueWith workItem++  | let (matching_irreds, others) = findMatchingIrreds (inert_irreds inerts) ev_w+  , ((ct_i, swap) : _rest) <- bagToList matching_irreds+        -- See Note [Multiple matching irreds]+  , let ev_i = ctEvidence ct_i+  = do { what_next <- solveOneFromTheOther ev_i ev_w+       ; traceTcS "iteractIrred" (ppr workItem $$ ppr what_next $$ ppr ct_i)+       ; case what_next of+            KeepInert -> do { setEvBindIfWanted ev_w (swap_me swap ev_i)+                            ; return (Stop ev_w (text "Irred equal" <+> parens (ppr what_next))) }+            KeepWork ->  do { setEvBindIfWanted ev_i (swap_me swap ev_w)+                            ; updInertIrreds (\_ -> others)+                            ; continueWith workItem } }++  | otherwise+  = continueWith workItem++  where+    swap_me :: SwapFlag -> CtEvidence -> EvTerm+    swap_me swap ev+      = case swap of+           NotSwapped -> ctEvTerm ev+           IsSwapped  -> evCoercion (mkTcSymCo (evTermCoercion (ctEvTerm ev)))++interactIrred _ wi = pprPanic "interactIrred" (ppr wi)++findMatchingIrreds :: Cts -> CtEvidence -> (Bag (Ct, SwapFlag), Bag Ct)+findMatchingIrreds irreds ev+  | EqPred eq_rel1 lty1 rty1 <- classifyPredType pred+    -- See Note [Solving irreducible equalities]+  = partitionBagWith (match_eq eq_rel1 lty1 rty1) irreds+  | otherwise+  = partitionBagWith match_non_eq irreds+  where+    pred = ctEvPred ev+    match_non_eq ct+      | ctPred ct `tcEqTypeNoKindCheck` pred = Left (ct, NotSwapped)+      | otherwise                            = Right ct++    match_eq eq_rel1 lty1 rty1 ct+      | EqPred eq_rel2 lty2 rty2 <- classifyPredType (ctPred ct)+      , eq_rel1 == eq_rel2+      , Just swap <- match_eq_help lty1 rty1 lty2 rty2+      = Left (ct, swap)+      | otherwise+      = Right ct++    match_eq_help lty1 rty1 lty2 rty2+      | lty1 `tcEqTypeNoKindCheck` lty2, rty1 `tcEqTypeNoKindCheck` rty2+      = Just NotSwapped+      | lty1 `tcEqTypeNoKindCheck` rty2, rty1 `tcEqTypeNoKindCheck` lty2+      = Just IsSwapped+      | otherwise+      = Nothing++{- Note [Solving irreducible equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#14333)+  [G] a b ~R# c d+  [W] c d ~R# a b+Clearly we should be able to solve this! Even though the constraints are+not decomposable. We solve this when looking up the work-item in the+irreducible constraints to look for an identical one.  When doing this+lookup, findMatchingIrreds spots the equality case, and matches either+way around. It has to return a swap-flag so we can generate evidence+that is the right way round too.++Note [Do not add duplicate derived insolubles]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general we *must* add an insoluble (Int ~ Bool) even if there is+one such there already, because they may come from distinct call+sites.  Not only do we want an error message for each, but with+-fdefer-type-errors we must generate evidence for each.  But for+*derived* insolubles, we only want to report each one once.  Why?++(a) A constraint (C r s t) where r -> s, say, may generate the same fundep+    equality many times, as the original constraint is successively rewritten.++(b) Ditto the successive iterations of the main solver itself, as it traverses+    the constraint tree. See example below.++Also for *given* insolubles we may get repeated errors, as we+repeatedly traverse the constraint tree.  These are relatively rare+anyway, so removing duplicates seems ok.  (Alternatively we could take+the SrcLoc into account.)++Note that the test does not need to be particularly efficient because+it is only used if the program has a type error anyway.++Example of (b): assume a top-level class and instance declaration:++  class D a b | a -> b+  instance D [a] [a]++Assume we have started with an implication:++  forall c. Eq c => { wc_simple = D [c] c [W] }++which we have simplified to:++  forall c. Eq c => { wc_simple = D [c] c [W]+                                  (c ~ [c]) [D] }++For some reason, e.g. because we floated an equality somewhere else,+we might try to re-solve this implication. If we do not do a+dropDerivedWC, then we will end up trying to solve the following+constraints the second time:++  (D [c] c) [W]+  (c ~ [c]) [D]++which will result in two Deriveds to end up in the insoluble set:++  wc_simple   = D [c] c [W]+               (c ~ [c]) [D], (c ~ [c]) [D]+-}++{-+*********************************************************************************+*                                                                               *+                   interactDict+*                                                                               *+*********************************************************************************++Note [Shortcut solving]+~~~~~~~~~~~~~~~~~~~~~~~+When we interact a [W] constraint with a [G] constraint that solves it, there is+a possibility that we could produce better code if instead we solved from a+top-level instance declaration (See #12791, #5835). For example:++    class M a b where m :: a -> b++    type C a b = (Num a, M a b)++    f :: C Int b => b -> Int -> Int+    f _ x = x + 1++The body of `f` requires a [W] `Num Int` instance. We could solve this+constraint from the givens because we have `C Int b` and that provides us a+solution for `Num Int`. This would let us produce core like the following+(with -O2):++    f :: forall b. C Int b => b -> Int -> Int+    f = \ (@ b) ($d(%,%) :: C Int b) _ (eta1 :: Int) ->+        + @ Int+          (GHC.Classes.$p1(%,%) @ (Num Int) @ (M Int b) $d(%,%))+          eta1+          A.f1++This is bad! We could do /much/ better if we solved [W] `Num Int` directly+from the instance that we have in scope:++    f :: forall b. C Int b => b -> Int -> Int+    f = \ (@ b) _ _ (x :: Int) ->+        case x of { GHC.Types.I# x1 -> GHC.Types.I# (GHC.Prim.+# x1 1#) }++** NB: It is important to emphasize that all this is purely an optimization:+** exactly the same programs should typecheck with or without this+** procedure.++Solving fully+~~~~~~~~~~~~~+There is a reason why the solver does not simply try to solve such+constraints with top-level instances. If the solver finds a relevant+instance declaration in scope, that instance may require a context+that can't be solved for. A good example of this is:++    f :: Ord [a] => ...+    f x = ..Need Eq [a]...++If we have instance `Eq a => Eq [a]` in scope and we tried to use it, we would+be left with the obligation to solve the constraint Eq a, which we cannot. So we+must be conservative in our attempt to use an instance declaration to solve the+[W] constraint we're interested in.++Our rule is that we try to solve all of the instance's subgoals+recursively all at once. Precisely: We only attempt to solve+constraints of the form `C1, ... Cm => C t1 ... t n`, where all the Ci+are themselves class constraints of the form `C1', ... Cm' => C' t1'+... tn'` and we only succeed if the entire tree of constraints is+solvable from instances.++An example that succeeds:++    class Eq a => C a b | b -> a where+      m :: b -> a++    f :: C [Int] b => b -> Bool+    f x = m x == []++We solve for `Eq [Int]`, which requires `Eq Int`, which we also have. This+produces the following core:++    f :: forall b. C [Int] b => b -> Bool+    f = \ (@ b) ($dC :: C [Int] b) (x :: b) ->+        GHC.Classes.$fEq[]_$s$c==+          (m @ [Int] @ b $dC x) (GHC.Types.[] @ Int)++An example that fails:++    class Eq a => C a b | b -> a where+      m :: b -> a++    f :: C [a] b => b -> Bool+    f x = m x == []++Which, because solving `Eq [a]` demands `Eq a` which we cannot solve, produces:++    f :: forall a b. C [a] b => b -> Bool+    f = \ (@ a) (@ b) ($dC :: C [a] b) (eta :: b) ->+        ==+          @ [a]+          (A.$p1C @ [a] @ b $dC)+          (m @ [a] @ b $dC eta)+          (GHC.Types.[] @ a)++Note [Shortcut solving: type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have (#13943)+  class Take (n :: Nat) where ...+  instance {-# OVERLAPPING #-}                    Take 0 where ..+  instance {-# OVERLAPPABLE #-} (Take (n - 1)) => Take n where ..++And we have [W] Take 3.  That only matches one instance so we get+[W] Take (3-1).  Really we should now flatten to reduce the (3-1) to 2, and+so on -- but that is reproducing yet more of the solver.  Sigh.  For now,+we just give up (remember all this is just an optimisation).++But we must not just naively try to lookup (Take (3-1)) in the+InstEnv, or it'll (wrongly) appear not to match (Take 0) and get a+unique match on the (Take n) instance.  That leads immediately to an+infinite loop.  Hence the check that 'preds' have no type families+(isTyFamFree).++Note [Shortcut solving: incoherence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This optimization relies on coherence of dictionaries to be correct. When we+cannot assume coherence because of IncoherentInstances then this optimization+can change the behavior of the user's code.++The following four modules produce a program whose output would change depending+on whether we apply this optimization when IncoherentInstances is in effect:++#########+    {-# LANGUAGE MultiParamTypeClasses #-}+    module A where++    class A a where+      int :: a -> Int++    class A a => C a b where+      m :: b -> a -> a++#########+    {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+    module B where++    import A++    instance A a where+      int _ = 1++    instance C a [b] where+      m _ = id++#########+    {-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FlexibleContexts #-}+    {-# LANGUAGE IncoherentInstances #-}+    module C where++    import A++    instance A Int where+      int _ = 2++    instance C Int [Int] where+      m _ = id++    intC :: C Int a => a -> Int -> Int+    intC _ x = int x++#########+    module Main where++    import A+    import B+    import C++    main :: IO ()+    main = print (intC [] (0::Int))++The output of `main` if we avoid the optimization under the effect of+IncoherentInstances is `1`. If we were to do the optimization, the output of+`main` would be `2`.++Note [Shortcut try_solve_from_instance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The workhorse of the short-cut solver is+    try_solve_from_instance :: (EvBindMap, DictMap CtEvidence)+                            -> CtEvidence       -- Solve this+                            -> MaybeT TcS (EvBindMap, DictMap CtEvidence)+Note that:++* The CtEvidence is the goal to be solved++* The MaybeT anages early failure if we find a subgoal that+  cannot be solved from instances.++* The (EvBindMap, DictMap CtEvidence) is an accumulating purely-functional+  state that allows try_solve_from_instance to augmennt the evidence+  bindings and inert_solved_dicts as it goes.++  If it succeeds, we commit all these bindings and solved dicts to the+  main TcS InertSet.  If not, we abandon it all entirely.++Passing along the solved_dicts important for two reasons:++* We need to be able to handle recursive super classes. The+  solved_dicts state  ensures that we remember what we have already+  tried to solve to avoid looping.++* As #15164 showed, it can be important to exploit sharing between+  goals. E.g. To solve G we may need G1 and G2. To solve G1 we may need H;+  and to solve G2 we may need H. If we don't spot this sharing we may+  solve H twice; and if this pattern repeats we may get exponentially bad+  behaviour.+-}++interactDict :: InertCans -> Ct -> TcS (StopOrContinue Ct)+interactDict inerts workItem@(CDictCan { cc_ev = ev_w, cc_class = cls, cc_tyargs = tys })+  | Just ev_i <- lookupInertDict inerts (ctEvLoc ev_w) cls tys+  = -- There is a matching dictionary in the inert set+    do { -- First to try to solve it /completely/ from top level instances+         -- See Note [Shortcut solving]+         dflags <- getDynFlags+       ; short_cut_worked <- shortCutSolver dflags ev_w ev_i+       ; if short_cut_worked+         then stopWith ev_w "interactDict/solved from instance"+         else++    do { -- Ths short-cut solver didn't fire, so we+         -- solve ev_w from the matching inert ev_i we found+         what_next <- solveOneFromTheOther ev_i ev_w+       ; traceTcS "lookupInertDict" (ppr what_next)+       ; case what_next of+           KeepInert -> do { setEvBindIfWanted ev_w (ctEvTerm ev_i)+                           ; return $ Stop ev_w (text "Dict equal" <+> parens (ppr what_next)) }+           KeepWork  -> do { setEvBindIfWanted ev_i (ctEvTerm ev_w)+                           ; updInertDicts $ \ ds -> delDict ds cls tys+                           ; continueWith workItem } } }++  | cls `hasKey` ipClassKey+  , isGiven ev_w+  = interactGivenIP inerts workItem++  | otherwise+  = do { addFunDepWork inerts ev_w cls+       ; continueWith workItem  }++interactDict _ wi = pprPanic "interactDict" (ppr wi)++-- See Note [Shortcut solving]+shortCutSolver :: DynFlags+               -> CtEvidence -- Work item+               -> CtEvidence -- Inert we want to try to replace+               -> TcS Bool   -- True <=> success+shortCutSolver dflags ev_w ev_i+  | isWanted ev_w+ && isGiven ev_i+ -- We are about to solve a [W] constraint from a [G] constraint. We take+ -- a moment to see if we can get a better solution using an instance.+ -- Note that we only do this for the sake of performance. Exactly the same+ -- programs should typecheck regardless of whether we take this step or+ -- not. See Note [Shortcut solving]++ && not (xopt LangExt.IncoherentInstances dflags)+ -- If IncoherentInstances is on then we cannot rely on coherence of proofs+ -- in order to justify this optimization: The proof provided by the+ -- [G] constraint's superclass may be different from the top-level proof.+ -- See Note [Shortcut solving: incoherence]++ && gopt Opt_SolveConstantDicts dflags+ -- Enabled by the -fsolve-constant-dicts flag+  = do { ev_binds_var <- getTcEvBindsVar+       ; ev_binds <- ASSERT2( not (isCoEvBindsVar ev_binds_var ), ppr ev_w )+                     getTcEvBindsMap ev_binds_var+       ; solved_dicts <- getSolvedDicts++       ; mb_stuff <- runMaybeT $ try_solve_from_instance+                                   (ev_binds, solved_dicts) ev_w++       ; case mb_stuff of+           Nothing -> return False+           Just (ev_binds', solved_dicts')+              -> do { setTcEvBindsMap ev_binds_var ev_binds'+                    ; setSolvedDicts solved_dicts'+                    ; return True } }++  | otherwise+  = return False+  where+    -- This `CtLoc` is used only to check the well-staged condition of any+    -- candidate DFun. Our subgoals all have the same stage as our root+    -- [W] constraint so it is safe to use this while solving them.+    loc_w = ctEvLoc ev_w++    try_solve_from_instance   -- See Note [Shortcut try_solve_from_instance]+      :: (EvBindMap, DictMap CtEvidence) -> CtEvidence+      -> MaybeT TcS (EvBindMap, DictMap CtEvidence)+    try_solve_from_instance (ev_binds, solved_dicts) ev+      | let pred = ctEvPred ev+            loc  = ctEvLoc  ev+      , ClassPred cls tys <- classifyPredType pred+      = do { inst_res <- lift $ matchGlobalInst dflags True cls tys+           ; case inst_res of+               OneInst { cir_new_theta = preds+                       , cir_mk_ev     = mk_ev+                       , cir_what      = what }+                 | safeOverlap what+                 , all isTyFamFree preds  -- Note [Shortcut solving: type families]+                 -> do { let solved_dicts' = addDict solved_dicts cls tys ev+                             -- solved_dicts': it is important that we add our goal+                             -- to the cache before we solve! Otherwise we may end+                             -- up in a loop while solving recursive dictionaries.++                       ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds)+                       ; loc' <- lift $ checkInstanceOK loc what pred++                       ; evc_vs <- mapM (new_wanted_cached loc' solved_dicts') preds+                                  -- Emit work for subgoals but use our local cache+                                  -- so we can solve recursive dictionaries.++                       ; let ev_tm     = mk_ev (map getEvExpr evc_vs)+                             ev_binds' = extendEvBinds ev_binds $+                                         mkWantedEvBind (ctEvEvId ev) ev_tm++                       ; foldlM try_solve_from_instance+                                (ev_binds', solved_dicts')+                                (freshGoals evc_vs) }++               _ -> mzero }+      | otherwise = mzero+++    -- Use a local cache of solved dicts while emitting EvVars for new work+    -- We bail out of the entire computation if we need to emit an EvVar for+    -- a subgoal that isn't a ClassPred.+    new_wanted_cached :: CtLoc -> DictMap CtEvidence -> TcPredType -> MaybeT TcS MaybeNew+    new_wanted_cached loc cache pty+      | ClassPred cls tys <- classifyPredType pty+      = lift $ case findDict cache loc_w cls tys of+          Just ctev -> return $ Cached (ctEvExpr ctev)+          Nothing   -> Fresh <$> newWantedNC loc pty+      | otherwise = mzero++addFunDepWork :: InertCans -> CtEvidence -> Class -> TcS ()+-- Add derived constraints from type-class functional dependencies.+addFunDepWork inerts work_ev cls+  | isImprovable work_ev+  = mapBagM_ add_fds (findDictsByClass (inert_dicts inerts) cls)+               -- No need to check flavour; fundeps work between+               -- any pair of constraints, regardless of flavour+               -- Importantly we don't throw workitem back in the+               -- worklist because this can cause loops (see #5236)+  | otherwise+  = return ()+  where+    work_pred = ctEvPred work_ev+    work_loc  = ctEvLoc work_ev++    add_fds inert_ct+      | isImprovable inert_ev+      = do { traceTcS "addFunDepWork" (vcat+                [ ppr work_ev+                , pprCtLoc work_loc, ppr (isGivenLoc work_loc)+                , pprCtLoc inert_loc, ppr (isGivenLoc inert_loc)+                , pprCtLoc derived_loc, ppr (isGivenLoc derived_loc) ]) ;++        emitFunDepDeriveds $+        improveFromAnother derived_loc inert_pred work_pred+               -- We don't really rewrite tys2, see below _rewritten_tys2, so that's ok+               -- NB: We do create FDs for given to report insoluble equations that arise+               -- from pairs of Givens, and also because of floating when we approximate+               -- implications. The relevant test is: typecheck/should_fail/FDsFromGivens.hs+        }+      | otherwise+      = return ()+      where+        inert_ev   = ctEvidence inert_ct+        inert_pred = ctEvPred inert_ev+        inert_loc  = ctEvLoc inert_ev+        derived_loc = work_loc { ctl_depth  = ctl_depth work_loc `maxSubGoalDepth`+                                              ctl_depth inert_loc+                               , ctl_origin = FunDepOrigin1 work_pred  work_loc+                                                            inert_pred inert_loc }++{-+**********************************************************************+*                                                                    *+                   Implicit parameters+*                                                                    *+**********************************************************************+-}++interactGivenIP :: InertCans -> Ct -> TcS (StopOrContinue Ct)+-- Work item is Given (?x:ty)+-- See Note [Shadowing of Implicit Parameters]+interactGivenIP inerts workItem@(CDictCan { cc_ev = ev, cc_class = cls+                                          , cc_tyargs = tys@(ip_str:_) })+  = do { updInertCans $ \cans -> cans { inert_dicts = addDict filtered_dicts cls tys workItem }+       ; stopWith ev "Given IP" }+  where+    dicts           = inert_dicts inerts+    ip_dicts        = findDictsByClass dicts cls+    other_ip_dicts  = filterBag (not . is_this_ip) ip_dicts+    filtered_dicts  = addDictsByClass dicts cls other_ip_dicts++    -- Pick out any Given constraints for the same implicit parameter+    is_this_ip (CDictCan { cc_ev = ev, cc_tyargs = ip_str':_ })+       = isGiven ev && ip_str `tcEqType` ip_str'+    is_this_ip _ = False++interactGivenIP _ wi = pprPanic "interactGivenIP" (ppr wi)++{- Note [Shadowing of Implicit Parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following example:++f :: (?x :: Char) => Char+f = let ?x = 'a' in ?x++The "let ?x = ..." generates an implication constraint of the form:++?x :: Char => ?x :: Char++Furthermore, the signature for `f` also generates an implication+constraint, so we end up with the following nested implication:++?x :: Char => (?x :: Char => ?x :: Char)++Note that the wanted (?x :: Char) constraint may be solved in+two incompatible ways:  either by using the parameter from the+signature, or by using the local definition.  Our intention is+that the local definition should "shadow" the parameter of the+signature, and we implement this as follows: when we add a new+*given* implicit parameter to the inert set, it replaces any existing+givens for the same implicit parameter.++Similarly, consider+   f :: (?x::a) => Bool -> a++   g v = let ?x::Int = 3+         in (f v, let ?x::Bool = True in f v)++This should probably be well typed, with+   g :: Bool -> (Int, Bool)++So the inner binding for ?x::Bool *overrides* the outer one.++All this works for the normal cases but it has an odd side effect in+some pathological programs like this:+-- This is accepted, the second parameter shadows+f1 :: (?x :: Int, ?x :: Char) => Char+f1 = ?x++-- This is rejected, the second parameter shadows+f2 :: (?x :: Int, ?x :: Char) => Int+f2 = ?x++Both of these are actually wrong:  when we try to use either one,+we'll get two incompatible wanted constraints (?x :: Int, ?x :: Char),+which would lead to an error.++I can think of two ways to fix this:++  1. Simply disallow multiple constraints for the same implicit+    parameter---this is never useful, and it can be detected completely+    syntactically.++  2. Move the shadowing machinery to the location where we nest+     implications, and add some code here that will produce an+     error if we get multiple givens for the same implicit parameter.+++**********************************************************************+*                                                                    *+                   interactFunEq+*                                                                    *+**********************************************************************+-}++interactFunEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)+-- Try interacting the work item with the inert set+interactFunEq inerts work_item@(CFunEqCan { cc_ev = ev, cc_fun = tc+                                          , cc_tyargs = args, cc_fsk = fsk })+  | Just inert_ct@(CFunEqCan { cc_ev = ev_i+                             , cc_fsk = fsk_i })+         <- findFunEq (inert_funeqs inerts) tc args+  , pr@(swap_flag, upgrade_flag) <- ev_i `funEqCanDischarge` ev+  = do { traceTcS "reactFunEq (rewrite inert item):" $+         vcat [ text "work_item =" <+> ppr work_item+              , text "inertItem=" <+> ppr ev_i+              , text "(swap_flag, upgrade)" <+> ppr pr ]+       ; if isSwapped swap_flag+         then do {   -- Rewrite inert using work-item+                   let work_item' | upgrade_flag = upgradeWanted work_item+                                  | otherwise    = work_item+                 ; updInertFunEqs $ \ feqs -> insertFunEq feqs tc args work_item'+                      -- Do the updInertFunEqs before the reactFunEq, so that+                      -- we don't kick out the inertItem as well as consuming it!+                 ; reactFunEq ev fsk ev_i fsk_i+                 ; stopWith ev "Work item rewrites inert" }+         else do {   -- Rewrite work-item using inert+                 ; when upgrade_flag $+                   updInertFunEqs $ \ feqs -> insertFunEq feqs tc args+                                                 (upgradeWanted inert_ct)+                 ; reactFunEq ev_i fsk_i ev fsk+                 ; stopWith ev "Inert rewrites work item" } }++  | otherwise   -- Try improvement+  = do { improveLocalFunEqs ev inerts tc args fsk+       ; continueWith work_item }++interactFunEq _ work_item = pprPanic "interactFunEq" (ppr work_item)++upgradeWanted :: Ct -> Ct+-- We are combining a [W] F tys ~ fmv1 and [D] F tys ~ fmv2+-- so upgrade the [W] to [WD] before putting it in the inert set+upgradeWanted ct = ct { cc_ev = upgrade_ev (cc_ev ct) }+  where+    upgrade_ev ev = ASSERT2( isWanted ev, ppr ct )+                    ev { ctev_nosh = WDeriv }++improveLocalFunEqs :: CtEvidence -> InertCans -> TyCon -> [TcType] -> TcTyVar+                   -> TcS ()+-- Generate derived improvement equalities, by comparing+-- the current work item with inert CFunEqs+-- E.g.   x + y ~ z,   x + y' ~ z   =>   [D] y ~ y'+--+-- See Note [FunDep and implicit parameter reactions]+improveLocalFunEqs work_ev inerts fam_tc args fsk+  | isGiven work_ev -- See Note [No FunEq improvement for Givens]+    || not (isImprovable work_ev)+  = return ()++  | not (null improvement_eqns)+  = do { traceTcS "interactFunEq improvements: " $+         vcat [ text "Eqns:" <+> ppr improvement_eqns+              , text "Candidates:" <+> ppr funeqs_for_tc+              , text "Inert eqs:" <+> ppr ieqs ]+       ; emitFunDepDeriveds improvement_eqns }++  | otherwise+  = return ()++  where+    ieqs          = inert_eqs inerts+    funeqs        = inert_funeqs inerts+    funeqs_for_tc = findFunEqsByTyCon funeqs fam_tc+    rhs           = lookupFlattenTyVar ieqs fsk+    work_loc      = ctEvLoc work_ev+    work_pred     = ctEvPred work_ev+    fam_inj_info  = tyConInjectivityInfo fam_tc++    --------------------+    improvement_eqns :: [FunDepEqn CtLoc]+    improvement_eqns+      | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc+      =    -- Try built-in families, notably for arithmethic+         concatMap (do_one_built_in ops) funeqs_for_tc++      | Injective injective_args <- fam_inj_info+      =    -- Try improvement from type families with injectivity annotations+        concatMap (do_one_injective injective_args) funeqs_for_tc++      | otherwise+      = []++    --------------------+    do_one_built_in ops (CFunEqCan { cc_tyargs = iargs, cc_fsk = ifsk, cc_ev = inert_ev })+      = mk_fd_eqns inert_ev (sfInteractInert ops args rhs iargs+                                             (lookupFlattenTyVar ieqs ifsk))++    do_one_built_in _ _ = pprPanic "interactFunEq 1" (ppr fam_tc)++    --------------------+    -- See Note [Type inference for type families with injectivity]+    do_one_injective inj_args (CFunEqCan { cc_tyargs = inert_args+                                         , cc_fsk = ifsk, cc_ev = inert_ev })+      | isImprovable inert_ev+      , rhs `tcEqType` lookupFlattenTyVar ieqs ifsk+      = mk_fd_eqns inert_ev $+            [ Pair arg iarg+            | (arg, iarg, True) <- zip3 args inert_args inj_args ]+      | otherwise+      = []++    do_one_injective _ _ = pprPanic "interactFunEq 2" (ppr fam_tc)++    --------------------+    mk_fd_eqns :: CtEvidence -> [TypeEqn] -> [FunDepEqn CtLoc]+    mk_fd_eqns inert_ev eqns+      | null eqns  = []+      | otherwise  = [ FDEqn { fd_qtvs = [], fd_eqs = eqns+                             , fd_pred1 = work_pred+                             , fd_pred2 = ctEvPred inert_ev+                             , fd_loc   = loc } ]+      where+        inert_loc = ctEvLoc inert_ev+        loc = inert_loc { ctl_depth = ctl_depth inert_loc `maxSubGoalDepth`+                                      ctl_depth work_loc }++-------------+reactFunEq :: CtEvidence -> TcTyVar    -- From this  :: F args1 ~ fsk1+           -> CtEvidence -> TcTyVar    -- Solve this :: F args2 ~ fsk2+           -> TcS ()+reactFunEq from_this fsk1 solve_this fsk2+  = do { traceTcS "reactFunEq"+            (vcat [ppr from_this, ppr fsk1, ppr solve_this, ppr fsk2])+       ; dischargeFunEq solve_this fsk2 (ctEvCoercion from_this) (mkTyVarTy fsk1)+       ; traceTcS "reactFunEq done" (ppr from_this $$ ppr fsk1 $$+                                     ppr solve_this $$ ppr fsk2) }++{- Note [Type inference for type families with injectivity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have a type family with an injectivity annotation:+    type family F a b = r | r -> b++Then if we have two CFunEqCan constraints for F with the same RHS+   F s1 t1 ~ rhs+   F s2 t2 ~ rhs+then we can use the injectivity to get a new Derived constraint on+the injective argument+  [D] t1 ~ t2++That in turn can help GHC solve constraints that would otherwise require+guessing.  For example, consider the ambiguity check for+   f :: F Int b -> Int+We get the constraint+   [W] F Int b ~ F Int beta+where beta is a unification variable.  Injectivity lets us pick beta ~ b.++Injectivity information is also used at the call sites. For example:+   g = f True+gives rise to+   [W] F Int b ~ Bool+from which we can derive b.  This requires looking at the defining equations of+a type family, ie. finding equation with a matching RHS (Bool in this example)+and infering values of type variables (b in this example) from the LHS patterns+of the matching equation.  For closed type families we have to perform+additional apartness check for the selected equation to check that the selected+is guaranteed to fire for given LHS arguments.++These new constraints are simply *Derived* constraints; they have no evidence.+We could go further and offer evidence from decomposing injective type-function+applications, but that would require new evidence forms, and an extension to+FC, so we don't do that right now (Dec 14).++See also Note [Injective type families] in TyCon+++Note [Cache-caused loops]+~~~~~~~~~~~~~~~~~~~~~~~~~+It is very dangerous to cache a rewritten wanted family equation as 'solved' in our+solved cache (which is the default behaviour or xCtEvidence), because the interaction+may not be contributing towards a solution. Here is an example:++Initial inert set:+  [W] g1 : F a ~ beta1+Work item:+  [W] g2 : F a ~ beta2+The work item will react with the inert yielding the _same_ inert set plus:+    (i)   Will set g2 := g1 `cast` g3+    (ii)  Will add to our solved cache that [S] g2 : F a ~ beta2+    (iii) Will emit [W] g3 : beta1 ~ beta2+Now, the g3 work item will be spontaneously solved to [G] g3 : beta1 ~ beta2+and then it will react the item in the inert ([W] g1 : F a ~ beta1). So it+will set+      g1 := g ; sym g3+and what is g? Well it would ideally be a new goal of type (F a ~ beta2) but+remember that we have this in our solved cache, and it is ... g2! In short we+created the evidence loop:++        g2 := g1 ; g3+        g3 := refl+        g1 := g2 ; sym g3++To avoid this situation we do not cache as solved any workitems (or inert)+which did not really made a 'step' towards proving some goal. Solved's are+just an optimization so we don't lose anything in terms of completeness of+solving.+++Note [Efficient Orientation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are interacting two FunEqCans with the same LHS:+          (inert)  ci :: (F ty ~ xi_i)+          (work)   cw :: (F ty ~ xi_w)+We prefer to keep the inert (else we pass the work item on down+the pipeline, which is a bit silly).  If we keep the inert, we+will (a) discharge 'cw'+     (b) produce a new equality work-item (xi_w ~ xi_i)+Notice the orientation (xi_w ~ xi_i) NOT (xi_i ~ xi_w):+    new_work :: xi_w ~ xi_i+    cw := ci ; sym new_work+Why?  Consider the simplest case when xi1 is a type variable.  If+we generate xi1~xi2, porcessing that constraint will kick out 'ci'.+If we generate xi2~xi1, there is less chance of that happening.+Of course it can and should still happen if xi1=a, xi1=Int, say.+But we want to avoid it happening needlessly.++Similarly, if we *can't* keep the inert item (because inert is Wanted,+and work is Given, say), we prefer to orient the new equality (xi_i ~+xi_w).++Note [Carefully solve the right CFunEqCan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   ---- OLD COMMENT, NOW NOT NEEDED+   ---- because we now allow multiple+   ---- wanted FunEqs with the same head+Consider the constraints+  c1 :: F Int ~ a      -- Arising from an application line 5+  c2 :: F Int ~ Bool   -- Arising from an application line 10+Suppose that 'a' is a unification variable, arising only from+flattening.  So there is no error on line 5; it's just a flattening+variable.  But there is (or might be) an error on line 10.++Two ways to combine them, leaving either (Plan A)+  c1 :: F Int ~ a      -- Arising from an application line 5+  c3 :: a ~ Bool       -- Arising from an application line 10+or (Plan B)+  c2 :: F Int ~ Bool   -- Arising from an application line 10+  c4 :: a ~ Bool       -- Arising from an application line 5++Plan A will unify c3, leaving c1 :: F Int ~ Bool as an error+on the *totally innocent* line 5.  An example is test SimpleFail16+where the expected/actual message comes out backwards if we use+the wrong plan.++The second is the right thing to do.  Hence the isMetaTyVarTy+test when solving pairwise CFunEqCan.+++**********************************************************************+*                                                                    *+                   interactTyVarEq+*                                                                    *+**********************************************************************+-}++inertsCanDischarge :: InertCans -> TcTyVar -> TcType -> CtFlavourRole+                   -> Maybe ( CtEvidence  -- The evidence for the inert+                            , SwapFlag    -- Whether we need mkSymCo+                            , Bool)       -- True <=> keep a [D] version+                                          --          of the [WD] constraint+inertsCanDischarge inerts tv rhs fr+  | (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i+                                    , cc_eq_rel = eq_rel }+                             <- findTyEqs inerts tv+                         , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr+                         , rhs_i `tcEqType` rhs ]+  =  -- Inert:     a ~ ty+     -- Work item: a ~ ty+    Just (ev_i, NotSwapped, keep_deriv ev_i)++  | Just tv_rhs <- getTyVar_maybe rhs+  , (ev_i : _) <- [ ev_i | CTyEqCan { cc_ev = ev_i, cc_rhs = rhs_i+                                    , cc_eq_rel = eq_rel }+                             <- findTyEqs inerts tv_rhs+                         , (ctEvFlavour ev_i, eq_rel) `eqCanDischargeFR` fr+                         , rhs_i `tcEqType` mkTyVarTy tv ]+  =  -- Inert:     a ~ b+     -- Work item: b ~ a+     Just (ev_i, IsSwapped, keep_deriv ev_i)++  | otherwise+  = Nothing++  where+    keep_deriv ev_i+      | Wanted WOnly  <- ctEvFlavour ev_i  -- inert is [W]+      , (Wanted WDeriv, _) <- fr           -- work item is [WD]+      = True   -- Keep a derived verison of the work item+      | otherwise+      = False  -- Work item is fully discharged++interactTyVarEq :: InertCans -> Ct -> TcS (StopOrContinue Ct)+-- CTyEqCans are always consumed, so always returns Stop+interactTyVarEq inerts workItem@(CTyEqCan { cc_tyvar = tv+                                          , cc_rhs = rhs+                                          , cc_ev = ev+                                          , cc_eq_rel = eq_rel })+  | Just (ev_i, swapped, keep_deriv)+       <- inertsCanDischarge inerts tv rhs (ctEvFlavour ev, eq_rel)+  = do { setEvBindIfWanted ev $+         evCoercion (maybeSym swapped $+                     tcDowngradeRole (eqRelRole eq_rel)+                                     (ctEvRole ev_i)+                                     (ctEvCoercion ev_i))++       ; let deriv_ev = CtDerived { ctev_pred = ctEvPred ev+                                  , ctev_loc  = ctEvLoc  ev }+       ; when keep_deriv $+         emitWork [workItem { cc_ev = deriv_ev }]+         -- As a Derived it might not be fully rewritten,+         -- so we emit it as new work++       ; stopWith ev "Solved from inert" }++  | ReprEq <- eq_rel   -- See Note [Do not unify representational equalities]+  = do { traceTcS "Not unifying representational equality" (ppr workItem)+       ; continueWith workItem }++  | isGiven ev         -- See Note [Touchables and givens]+  = continueWith workItem++  | otherwise+  = do { tclvl <- getTcLevel+       ; if canSolveByUnification tclvl tv rhs+         then do { solveByUnification ev tv rhs+                 ; n_kicked <- kickOutAfterUnification tv+                 ; return (Stop ev (text "Solved by unification" <+> pprKicked n_kicked)) }++         else continueWith workItem }++interactTyVarEq _ wi = pprPanic "interactTyVarEq" (ppr wi)++solveByUnification :: CtEvidence -> TcTyVar -> Xi -> TcS ()+-- Solve with the identity coercion+-- Precondition: kind(xi) equals kind(tv)+-- Precondition: CtEvidence is Wanted or Derived+-- Precondition: CtEvidence is nominal+-- Returns: workItem where+--        workItem = the new Given constraint+--+-- NB: No need for an occurs check here, because solveByUnification always+--     arises from a CTyEqCan, a *canonical* constraint.  Its invariants+--     say that in (a ~ xi), the type variable a does not appear in xi.+--     See TcRnTypes.Ct invariants.+--+-- Post: tv is unified (by side effect) with xi;+--       we often write tv := xi+solveByUnification wd tv xi+  = do { let tv_ty = mkTyVarTy tv+       ; traceTcS "Sneaky unification:" $+                       vcat [text "Unifies:" <+> ppr tv <+> text ":=" <+> ppr xi,+                             text "Coercion:" <+> pprEq tv_ty xi,+                             text "Left Kind is:" <+> ppr (tcTypeKind tv_ty),+                             text "Right Kind is:" <+> ppr (tcTypeKind xi) ]++       ; unifyTyVar tv xi+       ; setEvBindIfWanted wd (evCoercion (mkTcNomReflCo xi)) }++{- Note [Avoid double unifications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The spontaneous solver has to return a given which mentions the unified unification+variable *on the left* of the equality. Here is what happens if not:+  Original wanted:  (a ~ alpha),  (alpha ~ Int)+We spontaneously solve the first wanted, without changing the order!+      given : a ~ alpha      [having unified alpha := a]+Now the second wanted comes along, but he cannot rewrite the given, so we simply continue.+At the end we spontaneously solve that guy, *reunifying*  [alpha := Int]++We avoid this problem by orienting the resulting given so that the unification+variable is on the left.  [Note that alternatively we could attempt to+enforce this at canonicalization]++See also Note [No touchables as FunEq RHS] in TcSMonad; avoiding+double unifications is the main reason we disallow touchable+unification variables as RHS of type family equations: F xis ~ alpha.++Note [Do not unify representational equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider   [W] alpha ~R# b+where alpha is touchable. Should we unify alpha := b?++Certainly not!  Unifying forces alpha and be to be the same; but they+only need to be representationally equal types.++For example, we might have another constraint [W] alpha ~# N b+where+  newtype N b = MkN b+and we want to get alpha := N b.++See also #15144, which was caused by unifying a representational+equality (in the unflattener).+++************************************************************************+*                                                                      *+*          Functional dependencies, instantiation of equations+*                                                                      *+************************************************************************++When we spot an equality arising from a functional dependency,+we now use that equality (a "wanted") to rewrite the work-item+constraint right away.  This avoids two dangers++ Danger 1: If we send the original constraint on down the pipeline+           it may react with an instance declaration, and in delicate+           situations (when a Given overlaps with an instance) that+           may produce new insoluble goals: see #4952++ Danger 2: If we don't rewrite the constraint, it may re-react+           with the same thing later, and produce the same equality+           again --> termination worries.++To achieve this required some refactoring of FunDeps.hs (nicer+now!).++Note [FunDep and implicit parameter reactions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Currently, our story of interacting two dictionaries (or a dictionary+and top-level instances) for functional dependencies, and implicit+parameters, is that we simply produce new Derived equalities.  So for example++        class D a b | a -> b where ...+    Inert:+        d1 :g D Int Bool+    WorkItem:+        d2 :w D Int alpha++    We generate the extra work item+        cv :d alpha ~ Bool+    where 'cv' is currently unused.  However, this new item can perhaps be+    spontaneously solved to become given and react with d2,+    discharging it in favour of a new constraint d2' thus:+        d2' :w D Int Bool+        d2 := d2' |> D Int cv+    Now d2' can be discharged from d1++We could be more aggressive and try to *immediately* solve the dictionary+using those extra equalities, but that requires those equalities to carry+evidence and derived do not carry evidence.++If that were the case with the same inert set and work item we might dischard+d2 directly:++        cv :w alpha ~ Bool+        d2 := d1 |> D Int cv++But in general it's a bit painful to figure out the necessary coercion,+so we just take the first approach. Here is a better example. Consider:+    class C a b c | a -> b+And:+     [Given]  d1 : C T Int Char+     [Wanted] d2 : C T beta Int+In this case, it's *not even possible* to solve the wanted immediately.+So we should simply output the functional dependency and add this guy+[but NOT its superclasses] back in the worklist. Even worse:+     [Given] d1 : C T Int beta+     [Wanted] d2: C T beta Int+Then it is solvable, but its very hard to detect this on the spot.++It's exactly the same with implicit parameters, except that the+"aggressive" approach would be much easier to implement.++Note [Weird fundeps]+~~~~~~~~~~~~~~~~~~~~+Consider   class Het a b | a -> b where+              het :: m (f c) -> a -> m b++           class GHet (a :: * -> *) (b :: * -> *) | a -> b+           instance            GHet (K a) (K [a])+           instance Het a b => GHet (K a) (K b)++The two instances don't actually conflict on their fundeps,+although it's pretty strange.  So they are both accepted. Now+try   [W] GHet (K Int) (K Bool)+This triggers fundeps from both instance decls;+      [D] K Bool ~ K [a]+      [D] K Bool ~ K beta+And there's a risk of complaining about Bool ~ [a].  But in fact+the Wanted matches the second instance, so we never get as far+as the fundeps.++#7875 is a case in point.+-}++emitFunDepDeriveds :: [FunDepEqn CtLoc] -> TcS ()+-- See Note [FunDep and implicit parameter reactions]+emitFunDepDeriveds fd_eqns+  = mapM_ do_one_FDEqn fd_eqns+  where+    do_one_FDEqn (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = loc })+     | null tvs  -- Common shortcut+     = do { traceTcS "emitFunDepDeriveds 1" (ppr (ctl_depth loc) $$ ppr eqs $$ ppr (isGivenLoc loc))+          ; mapM_ (unifyDerived loc Nominal) eqs }+     | otherwise+     = do { traceTcS "emitFunDepDeriveds 2" (ppr (ctl_depth loc) $$ ppr tvs $$ ppr eqs)+          ; subst <- instFlexi tvs  -- Takes account of kind substitution+          ; mapM_ (do_one_eq loc subst) eqs }++    do_one_eq loc subst (Pair ty1 ty2)+       = unifyDerived loc Nominal $+         Pair (Type.substTyUnchecked subst ty1) (Type.substTyUnchecked subst ty2)++{-+**********************************************************************+*                                                                    *+                       The top-reaction Stage+*                                                                    *+**********************************************************************+-}++topReactionsStage :: WorkItem -> TcS (StopOrContinue Ct)+-- The work item does not react with the inert set,+-- so try interaction with top-level instances. Note:+topReactionsStage work_item+  = do { traceTcS "doTopReact" (ppr work_item)+       ; case work_item of+           CDictCan {}  -> do { inerts <- getTcSInerts+                              ; doTopReactDict inerts work_item }+           CFunEqCan {} -> doTopReactFunEq work_item+           CIrredCan {} -> doTopReactOther work_item+           CTyEqCan {}  -> doTopReactOther work_item+           _  -> -- Any other work item does not react with any top-level equations+                 continueWith work_item  }+++--------------------+doTopReactOther :: Ct -> TcS (StopOrContinue Ct)+-- Try local quantified constraints for+--     CTyEqCan  e.g.  (a ~# ty)+-- and CIrredCan e.g.  (c a)+--+-- Why equalities? See TcCanonical+-- Note [Equality superclasses in quantified constraints]+doTopReactOther work_item+  | isGiven ev+  = continueWith work_item++  | EqPred eq_rel t1 t2 <- classifyPredType pred+  = -- See Note [Looking up primitive equalities in quantified constraints]+    case boxEqPred eq_rel t1 t2 of+      Nothing -> continueWith work_item+      Just (cls, tys)+        -> do { res <- matchLocalInst (mkClassPred cls tys) loc+              ; case res of+                  OneInst { cir_mk_ev = mk_ev }+                    -> chooseInstance work_item+                           (res { cir_mk_ev = mk_eq_ev cls tys mk_ev })+                    where+                  _ -> continueWith work_item }++  | otherwise+  = do { res <- matchLocalInst pred loc+       ; case res of+           OneInst {} -> chooseInstance work_item res+           _          -> continueWith work_item }+  where+    ev = ctEvidence work_item+    loc  = ctEvLoc ev+    pred = ctEvPred ev++    mk_eq_ev cls tys mk_ev evs+      = case (mk_ev evs) of+          EvExpr e -> EvExpr (Var sc_id `mkTyApps` tys `App` e)+          ev       -> pprPanic "mk_eq_ev" (ppr ev)+      where+        [sc_id] = classSCSelIds cls++{- Note [Looking up primitive equalities in quantified constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For equalities (a ~# b) look up (a ~ b), and then do a superclass+selection. This avoids having to support quantified constraints whose+kind is not Constraint, such as (forall a. F a ~# b)++See+ * Note [Evidence for quantified constraints] in Type+ * Note [Equality superclasses in quantified constraints]+   in TcCanonical+-}++--------------------+doTopReactFunEq :: Ct -> TcS (StopOrContinue Ct)+doTopReactFunEq work_item@(CFunEqCan { cc_ev = old_ev, cc_fun = fam_tc+                                     , cc_tyargs = args, cc_fsk = fsk })++  | fsk `elemVarSet` tyCoVarsOfTypes args+  = no_reduction    -- See Note [FunEq occurs-check principle]++  | otherwise  -- Note [Reduction for Derived CFunEqCans]+  = do { match_res <- matchFam fam_tc args+                           -- Look up in top-level instances, or built-in axiom+                           -- See Note [MATCHING-SYNONYMS]+       ; case match_res of+           Nothing         -> no_reduction+           Just match_info -> reduce_top_fun_eq old_ev fsk match_info }+  where+    no_reduction+      = do { improveTopFunEqs old_ev fam_tc args fsk+           ; continueWith work_item }++doTopReactFunEq w = pprPanic "doTopReactFunEq" (ppr w)++reduce_top_fun_eq :: CtEvidence -> TcTyVar -> (TcCoercion, TcType)+                  -> TcS (StopOrContinue Ct)+-- We have found an applicable top-level axiom: use it to reduce+-- Precondition: fsk is not free in rhs_ty+reduce_top_fun_eq old_ev fsk (ax_co, rhs_ty)+  | not (isDerived old_ev)  -- Precondition of shortCutReduction+  , Just (tc, tc_args) <- tcSplitTyConApp_maybe rhs_ty+  , isTypeFamilyTyCon tc+  , tc_args `lengthIs` tyConArity tc    -- Short-cut+  = -- RHS is another type-family application+    -- Try shortcut; see Note [Top-level reductions for type functions]+    do { shortCutReduction old_ev fsk ax_co tc tc_args+       ; stopWith old_ev "Fun/Top (shortcut)" }++  | otherwise+  = ASSERT2( not (fsk `elemVarSet` tyCoVarsOfType rhs_ty)+           , ppr old_ev $$ ppr rhs_ty )+           -- Guaranteed by Note [FunEq occurs-check principle]+    do { dischargeFunEq old_ev fsk ax_co rhs_ty+       ; traceTcS "doTopReactFunEq" $+         vcat [ text "old_ev:" <+> ppr old_ev+              , nest 2 (text ":=") <+> ppr ax_co ]+       ; stopWith old_ev "Fun/Top" }++improveTopFunEqs :: CtEvidence -> TyCon -> [TcType] -> TcTyVar -> TcS ()+-- See Note [FunDep and implicit parameter reactions]+improveTopFunEqs ev fam_tc args fsk+  | isGiven ev            -- See Note [No FunEq improvement for Givens]+    || not (isImprovable ev)+  = return ()++  | otherwise+  = do { ieqs <- getInertEqs+       ; fam_envs <- getFamInstEnvs+       ; eqns <- improve_top_fun_eqs fam_envs fam_tc args+                                    (lookupFlattenTyVar ieqs fsk)+       ; traceTcS "improveTopFunEqs" (vcat [ ppr fam_tc <+> ppr args <+> ppr fsk+                                          , ppr eqns ])+       ; mapM_ (unifyDerived loc Nominal) eqns }+  where+    loc = ctEvLoc ev  -- ToDo: this location is wrong; it should be FunDepOrigin2+                      -- See #14778++improve_top_fun_eqs :: FamInstEnvs+                    -> TyCon -> [TcType] -> TcType+                    -> TcS [TypeEqn]+improve_top_fun_eqs fam_envs fam_tc args rhs_ty+  | Just ops <- isBuiltInSynFamTyCon_maybe fam_tc+  = return (sfInteractTop ops args rhs_ty)++  -- see Note [Type inference for type families with injectivity]+  | isOpenTypeFamilyTyCon fam_tc+  , Injective injective_args <- tyConInjectivityInfo fam_tc+  , let fam_insts = lookupFamInstEnvByTyCon fam_envs fam_tc+  = -- it is possible to have several compatible equations in an open type+    -- family but we only want to derive equalities from one such equation.+    do { let improvs = buildImprovementData fam_insts+                           fi_tvs fi_tys fi_rhs (const Nothing)++       ; traceTcS "improve_top_fun_eqs2" (ppr improvs)+       ; concatMapM (injImproveEqns injective_args) $+         take 1 improvs }++  | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe fam_tc+  , Injective injective_args <- tyConInjectivityInfo fam_tc+  = concatMapM (injImproveEqns injective_args) $+    buildImprovementData (fromBranches (co_ax_branches ax))+                         cab_tvs cab_lhs cab_rhs Just++  | otherwise+  = return []++  where+      buildImprovementData+          :: [a]                     -- axioms for a TF (FamInst or CoAxBranch)+          -> (a -> [TyVar])          -- get bound tyvars of an axiom+          -> (a -> [Type])           -- get LHS of an axiom+          -> (a -> Type)             -- get RHS of an axiom+          -> (a -> Maybe CoAxBranch) -- Just => apartness check required+          -> [( [Type], TCvSubst, [TyVar], Maybe CoAxBranch )]+             -- Result:+             -- ( [arguments of a matching axiom]+             -- , RHS-unifying substitution+             -- , axiom variables without substitution+             -- , Maybe matching axiom [Nothing - open TF, Just - closed TF ] )+      buildImprovementData axioms axiomTVs axiomLHS axiomRHS wrap =+          [ (ax_args, subst, unsubstTvs, wrap axiom)+          | axiom <- axioms+          , let ax_args = axiomLHS axiom+                ax_rhs  = axiomRHS axiom+                ax_tvs  = axiomTVs axiom+          , Just subst <- [tcUnifyTyWithTFs False ax_rhs rhs_ty]+          , let notInSubst tv = not (tv `elemVarEnv` getTvSubstEnv subst)+                unsubstTvs    = filter (notInSubst <&&> isTyVar) ax_tvs ]+                   -- The order of unsubstTvs is important; it must be+                   -- in telescope order e.g. (k:*) (a:k)++      injImproveEqns :: [Bool]+                     -> ([Type], TCvSubst, [TyCoVar], Maybe CoAxBranch)+                     -> TcS [TypeEqn]+      injImproveEqns inj_args (ax_args, subst, unsubstTvs, cabr)+        = do { subst <- instFlexiX subst unsubstTvs+                  -- If the current substitution bind [k -> *], and+                  -- one of the un-substituted tyvars is (a::k), we'd better+                  -- be sure to apply the current substitution to a's kind.+                  -- Hence instFlexiX.   #13135 was an example.++             ; return [ Pair (substTyUnchecked subst ax_arg) arg+                        -- NB: the ax_arg part is on the left+                        -- see Note [Improvement orientation]+                      | case cabr of+                          Just cabr' -> apartnessCheck (substTys subst ax_args) cabr'+                          _          -> True+                      , (ax_arg, arg, True) <- zip3 ax_args args inj_args ] }+++shortCutReduction :: CtEvidence -> TcTyVar -> TcCoercion+                  -> TyCon -> [TcType] -> TcS ()+-- See Note [Top-level reductions for type functions]+-- Previously, we flattened the tc_args here, but there's no need to do so.+-- And, if we did, this function would have all the complication of+-- TcCanonical.canCFunEqCan. See Note [canCFunEqCan]+shortCutReduction old_ev fsk ax_co fam_tc tc_args+  = ASSERT( ctEvEqRel old_ev == NomEq)+               -- ax_co :: F args ~ G tc_args+               -- old_ev :: F args ~ fsk+    do { new_ev <- case ctEvFlavour old_ev of+           Given -> newGivenEvVar deeper_loc+                         ( mkPrimEqPred (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk)+                         , evCoercion (mkTcSymCo ax_co+                                       `mkTcTransCo` ctEvCoercion old_ev) )++           Wanted {} ->+             do { (new_ev, new_co) <- newWantedEq deeper_loc Nominal+                                        (mkTyConApp fam_tc tc_args) (mkTyVarTy fsk)+                ; setWantedEq (ctev_dest old_ev) $ ax_co `mkTcTransCo` new_co+                ; return new_ev }++           Derived -> pprPanic "shortCutReduction" (ppr old_ev)++       ; let new_ct = CFunEqCan { cc_ev = new_ev, cc_fun = fam_tc+                                , cc_tyargs = tc_args, cc_fsk = fsk }+       ; updWorkListTcS (extendWorkListFunEq new_ct) }+  where+    deeper_loc = bumpCtLocDepth (ctEvLoc old_ev)++{- Note [Top-level reductions for type functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+c.f. Note [The flattening story] in TcFlatten++Suppose we have a CFunEqCan  F tys ~ fmv/fsk, and a matching axiom.+Here is what we do, in four cases:++* Wanteds: general firing rule+    (work item) [W]        x : F tys ~ fmv+    instantiate axiom: ax_co : F tys ~ rhs++   Then:+      Discharge   fmv := rhs+      Discharge   x := ax_co ; sym x2+   This is *the* way that fmv's get unified; even though they are+   "untouchable".++   NB: Given Note [FunEq occurs-check principle], fmv does not appear+   in tys, and hence does not appear in the instantiated RHS.  So+   the unification can't make an infinite type.++* Wanteds: short cut firing rule+  Applies when the RHS of the axiom is another type-function application+      (work item)        [W] x : F tys ~ fmv+      instantiate axiom: ax_co : F tys ~ G rhs_tys++  It would be a waste to create yet another fmv for (G rhs_tys).+  Instead (shortCutReduction):+      - Flatten rhs_tys (cos : rhs_tys ~ rhs_xis)+      - Add G rhs_xis ~ fmv to flat cache  (note: the same old fmv)+      - New canonical wanted   [W] x2 : G rhs_xis ~ fmv  (CFunEqCan)+      - Discharge x := ax_co ; G cos ; x2++* Givens: general firing rule+      (work item)        [G] g : F tys ~ fsk+      instantiate axiom: ax_co : F tys ~ rhs++   Now add non-canonical given (since rhs is not flat)+      [G] (sym g ; ax_co) : fsk ~ rhs  (Non-canonical)++* Givens: short cut firing rule+  Applies when the RHS of the axiom is another type-function application+      (work item)        [G] g : F tys ~ fsk+      instantiate axiom: ax_co : F tys ~ G rhs_tys++  It would be a waste to create yet another fsk for (G rhs_tys).+  Instead (shortCutReduction):+     - Flatten rhs_tys: flat_cos : tys ~ flat_tys+     - Add new Canonical given+          [G] (sym (G flat_cos) ; co ; g) : G flat_tys ~ fsk   (CFunEqCan)++Note [FunEq occurs-check principle]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+I have spent a lot of time finding a good way to deal with+CFunEqCan constraints like+    F (fuv, a) ~ fuv+where flatten-skolem occurs on the LHS.  Now in principle we+might may progress by doing a reduction, but in practice its+hard to find examples where it is useful, and easy to find examples+where we fall into an infinite reduction loop.  A rule that works+very well is this:++  *** FunEq occurs-check principle ***++      Do not reduce a CFunEqCan+          F tys ~ fsk+      if fsk appears free in tys+      Instead we treat it as stuck.++Examples:++* #5837 has [G] a ~ TF (a,Int), with an instance+    type instance TF (a,b) = (TF a, TF b)+  This readily loops when solving givens.  But with the FunEq occurs+  check principle, it rapidly gets stuck which is fine.++* #12444 is a good example, explained in comment:2.  We have+    type instance F (Succ x) = Succ (F x)+    [W] alpha ~ Succ (F alpha)+  If we allow the reduction to happen, we get an infinite loop++Note [Cached solved FunEqs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+When trying to solve, say (FunExpensive big-type ~ ty), it's important+to see if we have reduced (FunExpensive big-type) before, lest we+simply repeat it.  Hence the lookup in inert_solved_funeqs.  Moreover+we must use `funEqCanDischarge` because both uses might (say) be Wanteds,+and we *still* want to save the re-computation.++Note [MATCHING-SYNONYMS]+~~~~~~~~~~~~~~~~~~~~~~~~+When trying to match a dictionary (D tau) to a top-level instance, or a+type family equation (F taus_1 ~ tau_2) to a top-level family instance,+we do *not* need to expand type synonyms because the matcher will do that for us.++Note [Improvement orientation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A very delicate point is the orientation of derived equalities+arising from injectivity improvement (#12522).  Suppse we have+  type family F x = t | t -> x+  type instance F (a, Int) = (Int, G a)+where G is injective; and wanted constraints++  [W] TF (alpha, beta) ~ fuv+  [W] fuv ~ (Int, <some type>)++The injectivity will give rise to derived constraints++  [D] gamma1 ~ alpha+  [D] Int ~ beta++The fresh unification variable gamma1 comes from the fact that we+can only do "partial improvement" here; see Section 5.2 of+"Injective type families for Haskell" (HS'15).++Now, it's very important to orient the equations this way round,+so that the fresh unification variable will be eliminated in+favour of alpha.  If we instead had+   [D] alpha ~ gamma1+then we would unify alpha := gamma1; and kick out the wanted+constraint.  But when we grough it back in, it'd look like+   [W] TF (gamma1, beta) ~ fuv+and exactly the same thing would happen again!  Infinite loop.++This all seems fragile, and it might seem more robust to avoid+introducing gamma1 in the first place, in the case where the+actual argument (alpha, beta) partly matches the improvement+template.  But that's a bit tricky, esp when we remember that the+kinds much match too; so it's easier to let the normal machinery+handle it.  Instead we are careful to orient the new derived+equality with the template on the left.  Delicate, but it works.++Note [No FunEq improvement for Givens]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't do improvements (injectivity etc) for Givens. Why?++* It generates Derived constraints on skolems, which don't do us+  much good, except perhaps identify inaccessible branches.+  (They'd be perfectly valid though.)++* For type-nat stuff the derived constraints include type families;+  e.g.  (a < b), (b < c) ==> a < c If we generate a Derived for this,+  we'll generate a Derived/Wanted CFunEqCan; and, since the same+  InertCans (after solving Givens) are used for each iteration, that+  massively confused the unflattening step (TcFlatten.unflatten).++  In fact it led to some infinite loops:+     indexed-types/should_compile/T10806+     indexed-types/should_compile/T10507+     polykinds/T10742++Note [Reduction for Derived CFunEqCans]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You may wonder if it's important to use top-level instances to+simplify [D] CFunEqCan's.  But it is.  Here's an example (T10226).++   type instance F    Int = Int+   type instance FInv Int = Int++Suppose we have to solve+    [WD] FInv (F alpha) ~ alpha+    [WD] F alpha ~ Int++  --> flatten+    [WD] F alpha ~ fuv0+    [WD] FInv fuv0 ~ fuv1  -- (A)+    [WD] fuv1 ~ alpha+    [WD] fuv0 ~ Int        -- (B)++  --> Rewwrite (A) with (B), splitting it+    [WD] F alpha ~ fuv0+    [W] FInv fuv0 ~ fuv1+    [D] FInv Int ~ fuv1    -- (C)+    [WD] fuv1 ~ alpha+    [WD] fuv0 ~ Int++  --> Reduce (C) with top-level instance+      **** This is the key step ***+    [WD] F alpha ~ fuv0+    [W] FInv fuv0 ~ fuv1+    [D] fuv1 ~ Int        -- (D)+    [WD] fuv1 ~ alpha     -- (E)+    [WD] fuv0 ~ Int++  --> Rewrite (D) with (E)+    [WD] F alpha ~ fuv0+    [W] FInv fuv0 ~ fuv1+    [D] alpha ~ Int       -- (F)+    [WD] fuv1 ~ alpha+    [WD] fuv0 ~ Int++  --> unify (F)  alpha := Int, and that solves it++Another example is indexed-types/should_compile/T10634+-}++{- *******************************************************************+*                                                                    *+         Top-level reaction for class constraints (CDictCan)+*                                                                    *+**********************************************************************-}++doTopReactDict :: InertSet -> Ct -> TcS (StopOrContinue Ct)+-- Try to use type-class instance declarations to simplify the constraint+doTopReactDict inerts work_item@(CDictCan { cc_ev = ev, cc_class = cls+                                          , cc_tyargs = xis })+  | isGiven ev   -- Never use instances for Given constraints+  = do { try_fundep_improvement+       ; continueWith work_item }++  | Just solved_ev <- lookupSolvedDict inerts dict_loc cls xis   -- Cached+  = do { setEvBindIfWanted ev (ctEvTerm solved_ev)+       ; stopWith ev "Dict/Top (cached)" }++  | otherwise  -- Wanted or Derived, but not cached+   = do { dflags <- getDynFlags+        ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc+        ; case lkup_res of+               OneInst { cir_what = what }+                  -> do { unless (safeOverlap what) $+                          insertSafeOverlapFailureTcS work_item+                        ; when (isWanted ev) $ addSolvedDict ev cls xis+                        ; chooseInstance work_item lkup_res }+               _  ->  -- NoInstance or NotSure+                     do { when (isImprovable ev) $+                          try_fundep_improvement+                        ; continueWith work_item } }+   where+     dict_pred   = mkClassPred cls xis+     dict_loc    = ctEvLoc ev+     dict_origin = ctLocOrigin dict_loc++     -- We didn't solve it; so try functional dependencies with+     -- the instance environment, and return+     -- See also Note [Weird fundeps]+     try_fundep_improvement+        = do { traceTcS "try_fundeps" (ppr work_item)+             ; instEnvs <- getInstEnvs+             ; emitFunDepDeriveds $+               improveFromInstEnv instEnvs mk_ct_loc dict_pred }++     mk_ct_loc :: PredType   -- From instance decl+               -> SrcSpan    -- also from instance deol+               -> CtLoc+     mk_ct_loc inst_pred inst_loc+       = dict_loc { ctl_origin = FunDepOrigin2 dict_pred dict_origin+                                               inst_pred inst_loc }++doTopReactDict _ w = pprPanic "doTopReactDict" (ppr w)+++chooseInstance :: Ct -> ClsInstResult -> TcS (StopOrContinue Ct)+chooseInstance work_item+               (OneInst { cir_new_theta = theta+                        , cir_what      = what+                        , cir_mk_ev     = mk_ev })+  = do { traceTcS "doTopReact/found instance for" $ ppr ev+       ; deeper_loc <- checkInstanceOK loc what pred+       ; if isDerived ev then finish_derived deeper_loc theta+                         else finish_wanted  deeper_loc theta mk_ev }+  where+     ev         = ctEvidence work_item+     pred       = ctEvPred ev+     loc        = ctEvLoc ev++     finish_wanted :: CtLoc -> [TcPredType]+                   -> ([EvExpr] -> EvTerm) -> TcS (StopOrContinue Ct)+      -- Precondition: evidence term matches the predicate workItem+     finish_wanted loc theta mk_ev+        = do { evb <- getTcEvBindsVar+             ; if isCoEvBindsVar evb+               then -- See Note [Instances in no-evidence implications]+                    continueWith work_item+               else+          do { evc_vars <- mapM (newWanted loc) theta+             ; setEvBindIfWanted ev (mk_ev (map getEvExpr evc_vars))+             ; emitWorkNC (freshGoals evc_vars)+             ; stopWith ev "Dict/Top (solved wanted)" } }++     finish_derived loc theta+       = -- Use type-class instances for Deriveds, in the hope+         -- of generating some improvements+         -- C.f. Example 3 of Note [The improvement story]+         -- It's easy because no evidence is involved+         do { emitNewDeriveds loc theta+            ; traceTcS "finish_derived" (ppr (ctl_depth loc))+            ; stopWith ev "Dict/Top (solved derived)" }++chooseInstance work_item lookup_res+  = pprPanic "chooseInstance" (ppr work_item $$ ppr lookup_res)++checkInstanceOK :: CtLoc -> InstanceWhat -> TcPredType -> TcS CtLoc+-- Check that it's OK to use this insstance:+--    (a) the use is well staged in the Template Haskell sense+--    (b) we have not recursed too deep+-- Returns the CtLoc to used for sub-goals+checkInstanceOK loc what pred+  = do { checkWellStagedDFun loc what pred+       ; checkReductionDepth deeper_loc pred+       ; return deeper_loc }+  where+     deeper_loc = zap_origin (bumpCtLocDepth loc)+     origin     = ctLocOrigin loc++     zap_origin loc  -- After applying an instance we can set ScOrigin to+                     -- infinity, so that prohibitedSuperClassSolve never fires+       | ScOrigin {} <- origin+       = setCtLocOrigin loc (ScOrigin infinity)+       | otherwise+       = loc++{- Note [Instances in no-evidence implications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #15290 we had+  [G] forall p q. Coercible p q => Coercible (m p) (m q))+  [W] forall <no-ev> a. m (Int, IntStateT m a)+                          ~R#+                        m (Int, StateT Int m a)++The Given is an ordinary quantified constraint; the Wanted is an implication+equality that arises from+  [W] (forall a. t1) ~R# (forall a. t2)++But because the (t1 ~R# t2) is solved "inside a type" (under that forall a)+we can't generate any term evidence.  So we can't actually use that+lovely quantified constraint.  Alas!++This test arranges to ignore the instance-based solution under these+(rare) circumstances.   It's sad, but I  really don't see what else we can do.+-}+++matchClassInst :: DynFlags -> InertSet+               -> Class -> [Type]+               -> CtLoc -> TcS ClsInstResult+matchClassInst dflags inerts clas tys loc+-- First check whether there is an in-scope Given that could+-- match this constraint.  In that case, do not use any instance+-- whether top level, or local quantified constraints.+-- ee Note [Instance and Given overlap]+  | not (xopt LangExt.IncoherentInstances dflags)+  , not (naturallyCoherentClass clas)+  , let matchable_givens = matchableGivens loc pred inerts+  , not (isEmptyBag matchable_givens)+  = do { traceTcS "Delaying instance application" $+           vcat [ text "Work item=" <+> pprClassPred clas tys+                , text "Potential matching givens:" <+> ppr matchable_givens ]+       ; return NotSure }++  | otherwise+  = do { traceTcS "matchClassInst" $ text "pred =" <+> ppr pred <+> char '{'+       ; local_res <- matchLocalInst pred loc+       ; case local_res of+           OneInst {} ->  -- See Note [Local instances and incoherence]+                do { traceTcS "} matchClassInst local match" $ ppr local_res+                   ; return local_res }++           NotSure -> -- In the NotSure case for local instances+                      -- we don't want to try global instances+                do { traceTcS "} matchClassInst local not sure" empty+                   ; return local_res }++           NoInstance  -- No local instances, so try global ones+              -> do { global_res <- matchGlobalInst dflags False clas tys+                    ; traceTcS "} matchClassInst global result" $ ppr global_res+                    ; return global_res } }+  where+    pred = mkClassPred clas tys++-- | If a class is "naturally coherent", then we needn't worry at all, in any+-- way, about overlapping/incoherent instances. Just solve the thing!+-- See Note [Naturally coherent classes]+-- See also Note [The equality class story] in TysPrim.+naturallyCoherentClass :: Class -> Bool+naturallyCoherentClass cls+  = isCTupleClass cls+    || cls `hasKey` heqTyConKey+    || cls `hasKey` eqTyConKey+    || cls `hasKey` coercibleTyConKey+++{- Note [Instance and Given overlap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Example, from the OutsideIn(X) paper:+       instance P x => Q [x]+       instance (x ~ y) => R y [x]++       wob :: forall a b. (Q [b], R b a) => a -> Int++       g :: forall a. Q [a] => [a] -> Int+       g x = wob x++From 'g' we get the impliation constraint:+            forall a. Q [a] => (Q [beta], R beta [a])+If we react (Q [beta]) with its top-level axiom, we end up with a+(P beta), which we have no way of discharging. On the other hand,+if we react R beta [a] with the top-level we get  (beta ~ a), which+is solvable and can help us rewrite (Q [beta]) to (Q [a]) which is+now solvable by the given Q [a].++The partial solution is that:+  In matchClassInst (and thus in topReact), we return a matching+  instance only when there is no Given in the inerts which is+  unifiable to this particular dictionary.++  We treat any meta-tyvar as "unifiable" for this purpose,+  *including* untouchable ones.  But not skolems like 'a' in+  the implication constraint above.++The end effect is that, much as we do for overlapping instances, we+delay choosing a class instance if there is a possibility of another+instance OR a given to match our constraint later on. This fixes+#4981 and #5002.++Other notes:++* The check is done *first*, so that it also covers classes+  with built-in instance solving, such as+     - constraint tuples+     - natural numbers+     - Typeable++* Flatten-skolems: we do not treat a flatten-skolem as unifiable+  for this purpose.+  E.g.   f :: Eq (F a) => [a] -> [a]+         f xs = ....(xs==xs).....+  Here we get [W] Eq [a], and we don't want to refrain from solving+  it because of the given (Eq (F a)) constraint!++* The given-overlap problem is arguably not easy to appear in practice+  due to our aggressive prioritization of equality solving over other+  constraints, but it is possible. I've added a test case in+  typecheck/should-compile/GivenOverlapping.hs++* Another "live" example is #10195; another is #10177.++* We ignore the overlap problem if -XIncoherentInstances is in force:+  see #6002 for a worked-out example where this makes a+  difference.++* Moreover notice that our goals here are different than the goals of+  the top-level overlapping checks. There we are interested in+  validating the following principle:++      If we inline a function f at a site where the same global+      instance environment is available as the instance environment at+      the definition site of f then we should get the same behaviour.++  But for the Given Overlap check our goal is just related to completeness of+  constraint solving.++* The solution is only a partial one.  Consider the above example with+       g :: forall a. Q [a] => [a] -> Int+       g x = let v = wob x+             in v+  and suppose we have -XNoMonoLocalBinds, so that we attempt to find the most+  general type for 'v'.  When generalising v's type we'll simplify its+  Q [alpha] constraint, but we don't have Q [a] in the 'givens', so we+  will use the instance declaration after all. #11948 was a case+  in point.++All of this is disgustingly delicate, so to discourage people from writing+simplifiable class givens, we warn about signatures that contain them;+see TcValidity Note [Simplifiable given constraints].++Note [Naturally coherent classes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A few built-in classes are "naturally coherent".  This term means that+the "instance" for the class is bidirectional with its superclass(es).+For example, consider (~~), which behaves as if it was defined like+this:+  class a ~# b => a ~~ b+  instance a ~# b => a ~~ b+(See Note [The equality types story] in TysPrim.)++Faced with [W] t1 ~~ t2, it's always OK to reduce it to [W] t1 ~# t2,+without worrying about Note [Instance and Given overlap].  Why?  Because+if we had [G] s1 ~~ s2, then we'd get the superclass [G] s1 ~# s2, and+so the reduction of the [W] constraint does not risk losing any solutions.++On the other hand, it can be fatal to /fail/ to reduce such+equalities, on the grounds of Note [Instance and Given overlap],+because many good things flow from [W] t1 ~# t2.++The same reasoning applies to++* (~~)        heqTyCOn+* (~)         eqTyCon+* Coercible   coercibleTyCon++And less obviously to:++* Tuple classes.  For reasons described in TcSMonad+  Note [Tuples hiding implicit parameters], we may have a constraint+     [W] (?x::Int, C a)+  with an exactly-matching Given constraint.  We must decompose this+  tuple and solve the components separately, otherwise we won't solve+  it at all!  It is perfectly safe to decompose it, because again the+  superclasses invert the instance;  e.g.+      class (c1, c2) => (% c1, c2 %)+      instance (c1, c2) => (% c1, c2 %)+  Example in #14218++Exammples: T5853, T10432, T5315, T9222, T2627b, T3028b++PS: the term "naturally coherent" doesn't really seem helpful.+Perhaps "invertible" or something?  I left it for now though.++Note [Local instances and incoherence]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f :: forall b c. (Eq b, forall a. Eq a => Eq (c a))+                 => c b -> Bool+   f x = x==x++We get [W] Eq (c b), and we must use the local instance to solve it.++BUT that wanted also unifies with the top-level Eq [a] instance,+and Eq (Maybe a) etc.  We want the local instance to "win", otherwise+we can't solve the wanted at all.  So we mark it as Incohherent.+According to Note [Rules for instance lookup] in InstEnv, that'll+make it win even if there are other instances that unify.++Moreover this is not a hack!  The evidence for this local instance+will be constructed by GHC at a call site... from the very instances+that unify with it here.  It is not like an incoherent user-written+instance which might have utterly different behaviour.++Consdider  f :: Eq a => blah.  If we have [W] Eq a, we certainly+get it from the Eq a context, without worrying that there are+lots of top-level instances that unify with [W] Eq a!  We'll use+those instances to build evidence to pass to f. That's just the+nullary case of what's happening here.+-}++matchLocalInst :: TcPredType -> CtLoc -> TcS ClsInstResult+-- Look up the predicate in Given quantified constraints,+-- which are effectively just local instance declarations.+matchLocalInst pred loc+  = do { ics <- getInertCans+       ; case match_local_inst (inert_insts ics) of+           ([], False) -> return NoInstance+           ([(dfun_ev, inst_tys)], unifs)+             | not unifs+             -> do { let dfun_id = ctEvEvId dfun_ev+                   ; (tys, theta) <- instDFunType dfun_id inst_tys+                   ; return $ OneInst { cir_new_theta = theta+                                      , cir_mk_ev     = evDFunApp dfun_id tys+                                      , cir_what      = LocalInstance } }+           _ -> return NotSure }+  where+    pred_tv_set = tyCoVarsOfType pred++    match_local_inst :: [QCInst]+                     -> ( [(CtEvidence, [DFunInstType])]+                        , Bool )      -- True <=> Some unify but do not match+    match_local_inst []+      = ([], False)+    match_local_inst (qci@(QCI { qci_tvs = qtvs, qci_pred = qpred+                               , qci_ev = ev })+                     : qcis)+      | let in_scope = mkInScopeSet (qtv_set `unionVarSet` pred_tv_set)+      , Just tv_subst <- ruleMatchTyKiX qtv_set (mkRnEnv2 in_scope)+                                        emptyTvSubstEnv qpred pred+      , let match = (ev, map (lookupVarEnv tv_subst) qtvs)+      = (match:matches, unif)++      | otherwise+      = ASSERT2( disjointVarSet qtv_set (tyCoVarsOfType pred)+               , ppr qci $$ ppr pred )+            -- ASSERT: unification relies on the+            -- quantified variables being fresh+        (matches, unif || this_unif)+      where+        qtv_set = mkVarSet qtvs+        this_unif = mightMatchLater qpred (ctEvLoc ev) pred loc+        (matches, unif) = match_local_inst qcis+
+ compiler/typecheck/TcMType.hs view
@@ -0,0 +1,2240 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Monadic type operations++This module contains monadic operations over types that contain+mutable type variables.+-}++{-# LANGUAGE CPP, TupleSections, MultiWayIf #-}++module TcMType (+  TcTyVar, TcKind, TcType, TcTauType, TcThetaType, TcTyVarSet,++  --------------------------------+  -- Creating new mutable type variables+  newFlexiTyVar,+  newFlexiTyVarTy,              -- Kind -> TcM TcType+  newFlexiTyVarTys,             -- Int -> Kind -> TcM [TcType]+  newOpenFlexiTyVarTy, newOpenTypeKind,+  newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel,+  cloneMetaTyVar,+  newFmvTyVar, newFskTyVar,++  readMetaTyVar, writeMetaTyVar, writeMetaTyVarRef,+  newMetaDetails, isFilledMetaTyVar_maybe, isFilledMetaTyVar, isUnfilledMetaTyVar,++  --------------------------------+  -- Expected types+  ExpType(..), ExpSigmaType, ExpRhoType,+  mkCheckExpType,+  newInferExpType, newInferExpTypeInst, newInferExpTypeNoInst,+  readExpType, readExpType_maybe,+  expTypeToType, checkingExpType_maybe, checkingExpType,+  tauifyExpType, inferResultToType,++  --------------------------------+  -- Creating new evidence variables+  newEvVar, newEvVars, newDict,+  newWanted, newWanteds, newHoleCt, cloneWanted, cloneWC,+  emitWanted, emitWantedEq, emitWantedEvVar, emitWantedEvVars,+  emitDerivedEqs,+  newTcEvBinds, newNoTcEvBinds, addTcEvBind,++  newCoercionHole, fillCoercionHole, isFilledCoercionHole,+  unpackCoercionHole, unpackCoercionHole_maybe,+  checkCoercionHole,++  --------------------------------+  -- Instantiation+  newMetaTyVars, newMetaTyVarX, newMetaTyVarsX,+  newMetaTyVarTyVars, newMetaTyVarTyVarX,+  newTyVarTyVar, newPatSigTyVar, newSkolemTyVar, newWildCardX,+  tcInstType,+  tcInstSkolTyVars, tcInstSkolTyVarsX, tcInstSkolTyVarsAt,+  tcSkolDFunType, tcSuperSkolTyVars, tcInstSuperSkolTyVarsX,++  freshenTyVarBndrs, freshenCoVarBndrsX,++  --------------------------------+  -- Zonking and tidying+  zonkTidyTcType, zonkTidyTcTypes, zonkTidyOrigin,+  tidyEvVar, tidyCt, tidySkolemInfo,+    zonkTcTyVar, zonkTcTyVars,+  zonkTcTyVarToTyVar, zonkTyVarTyVarPairs,+  zonkTyCoVarsAndFV, zonkTcTypeAndFV,+  zonkTyCoVarsAndFVList,+  candidateQTyVarsOfType,  candidateQTyVarsOfKind,+  candidateQTyVarsOfTypes, candidateQTyVarsOfKinds,+  CandidatesQTvs(..), delCandidates, candidateKindVars,+  zonkAndSkolemise, skolemiseQuantifiedTyVar,+  defaultTyVar, quantifyTyVars,+  zonkTcType, zonkTcTypes, zonkCo,+  zonkTyCoVarKind,++  zonkEvVar, zonkWC, zonkSimples,+  zonkId, zonkCoVar,+  zonkCt, zonkSkolemInfo,++  tcGetGlobalTyCoVars,++  ------------------------------+  -- Levity polymorphism+  ensureNotLevPoly, checkForLevPoly, checkForLevPolyX, formatLevPolyErr+  ) where++#include "HsVersions.h"++-- friends:+import GhcPrelude++import TyCoRep+import TcType+import Type+import TyCon+import Coercion+import Class+import Var++-- others:+import TcRnMonad        -- TcType, amongst others+import TcEvidence+import Id+import Name+import VarSet+import TysWiredIn+import TysPrim+import VarEnv+import NameEnv+import PrelNames+import Util+import Outputable+import FastString+import Bag+import Pair+import UniqSet+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Maybes+import Data.List        ( mapAccumL )+import Control.Arrow    ( second )+import qualified Data.Semigroup as Semi++{-+************************************************************************+*                                                                      *+        Kind variables+*                                                                      *+************************************************************************+-}++mkKindName :: Unique -> Name+mkKindName unique = mkSystemName unique kind_var_occ++kind_var_occ :: OccName -- Just one for all MetaKindVars+                        -- They may be jiggled by tidying+kind_var_occ = mkOccName tvName "k"++newMetaKindVar :: TcM TcKind+newMetaKindVar+  = do { details <- newMetaDetails TauTv+       ; uniq <- newUnique+       ; let kv = mkTcTyVar (mkKindName uniq) liftedTypeKind details+       ; traceTc "newMetaKindVar" (ppr kv)+       ; return (mkTyVarTy kv) }++newMetaKindVars :: Int -> TcM [TcKind]+newMetaKindVars n = replicateM n newMetaKindVar++{-+************************************************************************+*                                                                      *+     Evidence variables; range over constraints we can abstract over+*                                                                      *+************************************************************************+-}++newEvVars :: TcThetaType -> TcM [EvVar]+newEvVars theta = mapM newEvVar theta++--------------++newEvVar :: TcPredType -> TcRnIf gbl lcl EvVar+-- Creates new *rigid* variables for predicates+newEvVar ty = do { name <- newSysName (predTypeOccName ty)+                 ; return (mkLocalIdOrCoVar name ty) }++newWanted :: CtOrigin -> Maybe TypeOrKind -> PredType -> TcM CtEvidence+-- Deals with both equality and non-equality predicates+newWanted orig t_or_k pty+  = do loc <- getCtLocM orig t_or_k+       d <- if isEqPrimPred pty then HoleDest  <$> newCoercionHole pty+                                else EvVarDest <$> newEvVar pty+       return $ CtWanted { ctev_dest = d+                         , ctev_pred = pty+                         , ctev_nosh = WDeriv+                         , ctev_loc = loc }++newWanteds :: CtOrigin -> ThetaType -> TcM [CtEvidence]+newWanteds orig = mapM (newWanted orig Nothing)++-- | Create a new 'CHoleCan' 'Ct'.+newHoleCt :: Hole -> Id -> Type -> TcM Ct+newHoleCt hole ev ty = do+  loc <- getCtLocM HoleOrigin Nothing+  pure $ CHoleCan { cc_ev = CtWanted { ctev_pred = ty+                                     , ctev_dest = EvVarDest ev+                                     , ctev_nosh = WDeriv+                                     , ctev_loc  = loc }+                  , cc_hole = hole }++----------------------------------------------+-- Cloning constraints+----------------------------------------------++cloneWanted :: Ct -> TcM Ct+cloneWanted ct+  | ev@(CtWanted { ctev_dest = HoleDest {}, ctev_pred = pty }) <- ctEvidence ct+  = do { co_hole <- newCoercionHole pty+       ; return (mkNonCanonical (ev { ctev_dest = HoleDest co_hole })) }+  | otherwise+  = return ct++cloneWC :: WantedConstraints -> TcM WantedConstraints+-- Clone all the evidence bindings in+--   a) the ic_bind field of any implications+--   b) the CoercionHoles of any wanted constraints+-- so that solving the WantedConstraints will not have any visible side+-- effect, /except/ from causing unifications+cloneWC wc@(WC { wc_simple = simples, wc_impl = implics })+  = do { simples' <- mapBagM cloneWanted simples+       ; implics' <- mapBagM cloneImplication implics+       ; return (wc { wc_simple = simples', wc_impl = implics' }) }++cloneImplication :: Implication -> TcM Implication+cloneImplication implic@(Implic { ic_binds = binds, ic_wanted = inner_wanted })+  = do { binds'        <- cloneEvBindsVar binds+       ; inner_wanted' <- cloneWC inner_wanted+       ; return (implic { ic_binds = binds', ic_wanted = inner_wanted' }) }++----------------------------------------------+-- Emitting constraints+----------------------------------------------++-- | Emits a new Wanted. Deals with both equalities and non-equalities.+emitWanted :: CtOrigin -> TcPredType -> TcM EvTerm+emitWanted origin pty+  = do { ev <- newWanted origin Nothing pty+       ; emitSimple $ mkNonCanonical ev+       ; return $ ctEvTerm ev }++emitDerivedEqs :: CtOrigin -> [(TcType,TcType)] -> TcM ()+-- Emit some new derived nominal equalities+emitDerivedEqs origin pairs+  | null pairs+  = return ()+  | otherwise+  = do { loc <- getCtLocM origin Nothing+       ; emitSimples (listToBag (map (mk_one loc) pairs)) }+  where+    mk_one loc (ty1, ty2)+       = mkNonCanonical $+         CtDerived { ctev_pred = mkPrimEqPred ty1 ty2+                   , ctev_loc = loc }++-- | Emits a new equality constraint+emitWantedEq :: CtOrigin -> TypeOrKind -> Role -> TcType -> TcType -> TcM Coercion+emitWantedEq origin t_or_k role ty1 ty2+  = do { hole <- newCoercionHole pty+       ; loc <- getCtLocM origin (Just t_or_k)+       ; emitSimple $ mkNonCanonical $+         CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole+                  , ctev_nosh = WDeriv, ctev_loc = loc }+       ; return (HoleCo hole) }+  where+    pty = mkPrimEqPredRole role ty1 ty2++-- | Creates a new EvVar and immediately emits it as a Wanted.+-- No equality predicates here.+emitWantedEvVar :: CtOrigin -> TcPredType -> TcM EvVar+emitWantedEvVar origin ty+  = do { new_cv <- newEvVar ty+       ; loc <- getCtLocM origin Nothing+       ; let ctev = CtWanted { ctev_dest = EvVarDest new_cv+                             , ctev_pred = ty+                             , ctev_nosh = WDeriv+                             , ctev_loc  = loc }+       ; emitSimple $ mkNonCanonical ctev+       ; return new_cv }++emitWantedEvVars :: CtOrigin -> [TcPredType] -> TcM [EvVar]+emitWantedEvVars orig = mapM (emitWantedEvVar orig)++newDict :: Class -> [TcType] -> TcM DictId+newDict cls tys+  = do { name <- newSysName (mkDictOcc (getOccName cls))+       ; return (mkLocalId name (mkClassPred cls tys)) }++predTypeOccName :: PredType -> OccName+predTypeOccName ty = case classifyPredType ty of+    ClassPred cls _ -> mkDictOcc (getOccName cls)+    EqPred {}       -> mkVarOccFS (fsLit "co")+    IrredPred {}    -> mkVarOccFS (fsLit "irred")+    ForAllPred {}   -> mkVarOccFS (fsLit "df")++{-+************************************************************************+*                                                                      *+        Coercion holes+*                                                                      *+************************************************************************+-}++newCoercionHole :: TcPredType -> TcM CoercionHole+newCoercionHole pred_ty+  = do { co_var <- newEvVar pred_ty+       ; traceTc "New coercion hole:" (ppr co_var)+       ; ref <- newMutVar Nothing+       ; return $ CoercionHole { ch_co_var = co_var, ch_ref = ref } }++-- | Put a value in a coercion hole+fillCoercionHole :: CoercionHole -> Coercion -> TcM ()+fillCoercionHole (CoercionHole { ch_ref = ref, ch_co_var = cv }) co+  = do {+#if defined(DEBUG)+       ; cts <- readTcRef ref+       ; whenIsJust cts $ \old_co ->+         pprPanic "Filling a filled coercion hole" (ppr cv $$ ppr co $$ ppr old_co)+#endif+       ; traceTc "Filling coercion hole" (ppr cv <+> text ":=" <+> ppr co)+       ; writeTcRef ref (Just co) }++-- | Is a coercion hole filled in?+isFilledCoercionHole :: CoercionHole -> TcM Bool+isFilledCoercionHole (CoercionHole { ch_ref = ref }) = isJust <$> readTcRef ref++-- | Retrieve the contents of a coercion hole. Panics if the hole+-- is unfilled+unpackCoercionHole :: CoercionHole -> TcM Coercion+unpackCoercionHole hole+  = do { contents <- unpackCoercionHole_maybe hole+       ; case contents of+           Just co -> return co+           Nothing -> pprPanic "Unfilled coercion hole" (ppr hole) }++-- | Retrieve the contents of a coercion hole, if it is filled+unpackCoercionHole_maybe :: CoercionHole -> TcM (Maybe Coercion)+unpackCoercionHole_maybe (CoercionHole { ch_ref = ref }) = readTcRef ref++-- | Check that a coercion is appropriate for filling a hole. (The hole+-- itself is needed only for printing.+-- Always returns the checked coercion, but this return value is necessary+-- so that the input coercion is forced only when the output is forced.+checkCoercionHole :: CoVar -> Coercion -> TcM Coercion+checkCoercionHole cv co+  | debugIsOn+  = do { cv_ty <- zonkTcType (varType cv)+                  -- co is already zonked, but cv might not be+       ; return $+         ASSERT2( ok cv_ty+                , (text "Bad coercion hole" <+>+                   ppr cv <> colon <+> vcat [ ppr t1, ppr t2, ppr role+                                            , ppr cv_ty ]) )+         co }+  | otherwise+  = return co++  where+    (Pair t1 t2, role) = coercionKindRole co+    ok cv_ty | EqPred cv_rel cv_t1 cv_t2 <- classifyPredType cv_ty+             =  t1 `eqType` cv_t1+             && t2 `eqType` cv_t2+             && role == eqRelRole cv_rel+             | otherwise+             = False++{-+************************************************************************+*+    Expected types+*+************************************************************************++Note [ExpType]+~~~~~~~~~~~~~~++An ExpType is used as the "expected type" when type-checking an expression.+An ExpType can hold a "hole" that can be filled in by the type-checker.+This allows us to have one tcExpr that works in both checking mode and+synthesis mode (that is, bidirectional type-checking). Previously, this+was achieved by using ordinary unification variables, but we don't need+or want that generality. (For example, #11397 was caused by doing the+wrong thing with unification variables.) Instead, we observe that these+holes should++1. never be nested+2. never appear as the type of a variable+3. be used linearly (never be duplicated)++By defining ExpType, separately from Type, we can achieve goals 1 and 2+statically.++See also [wiki:typechecking]++Note [TcLevel of ExpType]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  data G a where+    MkG :: G Bool++  foo MkG = True++This is a classic untouchable-variable / ambiguous GADT return type+scenario. But, with ExpTypes, we'll be inferring the type of the RHS.+And, because there is only one branch of the case, we won't trigger+Note [Case branches must never infer a non-tau type] of TcMatches.+We thus must track a TcLevel in an Inferring ExpType. If we try to+fill the ExpType and find that the TcLevels don't work out, we+fill the ExpType with a tau-tv at the low TcLevel, hopefully to+be worked out later by some means. This is triggered in+test gadt/gadt-escape1.++-}++-- actual data definition is in TcType++-- | Make an 'ExpType' suitable for inferring a type of kind * or #.+newInferExpTypeNoInst :: TcM ExpSigmaType+newInferExpTypeNoInst = newInferExpType False++newInferExpTypeInst :: TcM ExpRhoType+newInferExpTypeInst = newInferExpType True++newInferExpType :: Bool -> TcM ExpType+newInferExpType inst+  = do { u <- newUnique+       ; tclvl <- getTcLevel+       ; traceTc "newOpenInferExpType" (ppr u <+> ppr inst <+> ppr tclvl)+       ; ref <- newMutVar Nothing+       ; return (Infer (IR { ir_uniq = u, ir_lvl = tclvl+                           , ir_ref = ref, ir_inst = inst })) }++-- | Extract a type out of an ExpType, if one exists. But one should always+-- exist. Unless you're quite sure you know what you're doing.+readExpType_maybe :: ExpType -> TcM (Maybe TcType)+readExpType_maybe (Check ty)                   = return (Just ty)+readExpType_maybe (Infer (IR { ir_ref = ref})) = readMutVar ref++-- | Extract a type out of an ExpType. Otherwise, panics.+readExpType :: ExpType -> TcM TcType+readExpType exp_ty+  = do { mb_ty <- readExpType_maybe exp_ty+       ; case mb_ty of+           Just ty -> return ty+           Nothing -> pprPanic "Unknown expected type" (ppr exp_ty) }++-- | Returns the expected type when in checking mode.+checkingExpType_maybe :: ExpType -> Maybe TcType+checkingExpType_maybe (Check ty) = Just ty+checkingExpType_maybe _          = Nothing++-- | Returns the expected type when in checking mode. Panics if in inference+-- mode.+checkingExpType :: String -> ExpType -> TcType+checkingExpType _   (Check ty) = ty+checkingExpType err et         = pprPanic "checkingExpType" (text err $$ ppr et)++tauifyExpType :: ExpType -> TcM ExpType+-- ^ Turn a (Infer hole) type into a (Check alpha),+-- where alpha is a fresh unification variable+tauifyExpType (Check ty)      = return (Check ty)  -- No-op for (Check ty)+tauifyExpType (Infer inf_res) = do { ty <- inferResultToType inf_res+                                   ; return (Check ty) }++-- | Extracts the expected type if there is one, or generates a new+-- TauTv if there isn't.+expTypeToType :: ExpType -> TcM TcType+expTypeToType (Check ty)      = return ty+expTypeToType (Infer inf_res) = inferResultToType inf_res++inferResultToType :: InferResult -> TcM Type+inferResultToType (IR { ir_uniq = u, ir_lvl = tc_lvl+                      , ir_ref = ref })+  = do { rr  <- newMetaTyVarTyAtLevel tc_lvl runtimeRepTy+       ; tau <- newMetaTyVarTyAtLevel tc_lvl (tYPE rr)+             -- See Note [TcLevel of ExpType]+       ; writeMutVar ref (Just tau)+       ; traceTc "Forcing ExpType to be monomorphic:"+                 (ppr u <+> text ":=" <+> ppr tau)+       ; return tau }+++{- *********************************************************************+*                                                                      *+        SkolemTvs (immutable)+*                                                                      *+********************************************************************* -}++tcInstType :: ([TyVar] -> TcM (TCvSubst, [TcTyVar]))+                   -- ^ How to instantiate the type variables+           -> Id                                            -- ^ Type to instantiate+           -> TcM ([(Name, TcTyVar)], TcThetaType, TcType)  -- ^ Result+                -- (type vars, preds (incl equalities), rho)+tcInstType inst_tyvars id+  = case tcSplitForAllTys (idType id) of+        ([],    rho) -> let     -- There may be overloading despite no type variables;+                                --      (?x :: Int) => Int -> Int+                                (theta, tau) = tcSplitPhiTy rho+                            in+                            return ([], theta, tau)++        (tyvars, rho) -> do { (subst, tyvars') <- inst_tyvars tyvars+                            ; let (theta, tau) = tcSplitPhiTy (substTyAddInScope subst rho)+                                  tv_prs       = map tyVarName tyvars `zip` tyvars'+                            ; return (tv_prs, theta, tau) }++tcSkolDFunType :: DFunId -> TcM ([TcTyVar], TcThetaType, TcType)+-- Instantiate a type signature with skolem constants.+-- We could give them fresh names, but no need to do so+tcSkolDFunType dfun+  = do { (tv_prs, theta, tau) <- tcInstType tcInstSuperSkolTyVars dfun+       ; return (map snd tv_prs, theta, tau) }++tcSuperSkolTyVars :: [TyVar] -> (TCvSubst, [TcTyVar])+-- Make skolem constants, but do *not* give them new names, as above+-- Moreover, make them "super skolems"; see comments with superSkolemTv+-- see Note [Kind substitution when instantiating]+-- Precondition: tyvars should be ordered by scoping+tcSuperSkolTyVars = mapAccumL tcSuperSkolTyVar emptyTCvSubst++tcSuperSkolTyVar :: TCvSubst -> TyVar -> (TCvSubst, TcTyVar)+tcSuperSkolTyVar subst tv+  = (extendTvSubstWithClone subst tv new_tv, new_tv)+  where+    kind   = substTyUnchecked subst (tyVarKind tv)+    new_tv = mkTcTyVar (tyVarName tv) kind superSkolemTv++-- | Given a list of @['TyVar']@, skolemize the type variables,+-- returning a substitution mapping the original tyvars to the+-- skolems, and the list of newly bound skolems.+tcInstSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])+-- See Note [Skolemising type variables]+tcInstSkolTyVars = tcInstSkolTyVarsX emptyTCvSubst++tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])+-- See Note [Skolemising type variables]+tcInstSkolTyVarsX = tcInstSkolTyVarsPushLevel False++tcInstSuperSkolTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])+-- See Note [Skolemising type variables]+tcInstSuperSkolTyVars = tcInstSuperSkolTyVarsX emptyTCvSubst++tcInstSuperSkolTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])+-- See Note [Skolemising type variables]+tcInstSuperSkolTyVarsX subst = tcInstSkolTyVarsPushLevel True subst++tcInstSkolTyVarsPushLevel :: Bool -> TCvSubst -> [TyVar]+                          -> TcM (TCvSubst, [TcTyVar])+-- Skolemise one level deeper, hence pushTcLevel+-- See Note [Skolemising type variables]+tcInstSkolTyVarsPushLevel overlappable subst tvs+  = do { tc_lvl <- getTcLevel+       ; let pushed_lvl = pushTcLevel tc_lvl+       ; tcInstSkolTyVarsAt pushed_lvl overlappable subst tvs }++tcInstSkolTyVarsAt :: TcLevel -> Bool+                   -> TCvSubst -> [TyVar]+                   -> TcM (TCvSubst, [TcTyVar])+tcInstSkolTyVarsAt lvl overlappable subst tvs+  = freshenTyCoVarsX new_skol_tv subst tvs+  where+    details = SkolemTv lvl overlappable+    new_skol_tv name kind = mkTcTyVar name kind details++------------------+freshenTyVarBndrs :: [TyVar] -> TcM (TCvSubst, [TyVar])+-- ^ Give fresh uniques to a bunch of TyVars, but they stay+--   as TyVars, rather than becoming TcTyVars+-- Used in FamInst.newFamInst, and Inst.newClsInst+freshenTyVarBndrs = freshenTyCoVars mkTyVar++freshenCoVarBndrsX :: TCvSubst -> [CoVar] -> TcM (TCvSubst, [CoVar])+-- ^ Give fresh uniques to a bunch of CoVars+-- Used in FamInst.newFamInst+freshenCoVarBndrsX subst = freshenTyCoVarsX mkCoVar subst++------------------+freshenTyCoVars :: (Name -> Kind -> TyCoVar)+                -> [TyVar] -> TcM (TCvSubst, [TyCoVar])+freshenTyCoVars mk_tcv = freshenTyCoVarsX mk_tcv emptyTCvSubst++freshenTyCoVarsX :: (Name -> Kind -> TyCoVar)+                 -> TCvSubst -> [TyCoVar]+                 -> TcM (TCvSubst, [TyCoVar])+freshenTyCoVarsX mk_tcv = mapAccumLM (freshenTyCoVarX mk_tcv)++freshenTyCoVarX :: (Name -> Kind -> TyCoVar)+                -> TCvSubst -> TyCoVar -> TcM (TCvSubst, TyCoVar)+-- This a complete freshening operation:+-- the skolems have a fresh unique, and a location from the monad+-- See Note [Skolemising type variables]+freshenTyCoVarX mk_tcv subst tycovar+  = do { loc  <- getSrcSpanM+       ; uniq <- newUnique+       ; let old_name = tyVarName tycovar+             new_name = mkInternalName uniq (getOccName old_name) loc+             new_kind = substTyUnchecked subst (tyVarKind tycovar)+             new_tcv  = mk_tcv new_name new_kind+             subst1   = extendTCvSubstWithClone subst tycovar new_tcv+       ; return (subst1, new_tcv) }++{- Note [Skolemising type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The tcInstSkolTyVars family of functions instantiate a list of TyVars+to fresh skolem TcTyVars. Important notes:++a) Level allocation. We generally skolemise /before/ calling+   pushLevelAndCaptureConstraints.  So we want their level to the level+   of the soon-to-be-created implication, which has a level ONE HIGHER+   than the current level.  Hence the pushTcLevel.  It feels like a+   slight hack.++b) The [TyVar] should be ordered (kind vars first)+   See Note [Kind substitution when instantiating]++c) It's a complete freshening operation: the skolems have a fresh+   unique, and a location from the monad++d) The resulting skolems are+        non-overlappable for tcInstSkolTyVars,+   but overlappable for tcInstSuperSkolTyVars+   See TcDerivInfer Note [Overlap and deriving] for an example+   of where this matters.++Note [Kind substitution when instantiating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we instantiate a bunch of kind and type variables, first we+expect them to be topologically sorted.+Then we have to instantiate the kind variables, build a substitution+from old variables to the new variables, then instantiate the type+variables substituting the original kind.++Exemple: If we want to instantiate+  [(k1 :: *), (k2 :: *), (a :: k1 -> k2), (b :: k1)]+we want+  [(?k1 :: *), (?k2 :: *), (?a :: ?k1 -> ?k2), (?b :: ?k1)]+instead of the buggous+  [(?k1 :: *), (?k2 :: *), (?a :: k1 -> k2), (?b :: k1)]+++************************************************************************+*                                                                      *+        MetaTvs (meta type variables; mutable)+*                                                                      *+************************************************************************+-}++{-+Note [TyVarTv]+~~~~~~~~~~~~++A TyVarTv can unify with type *variables* only, including other TyVarTvs and+skolems. Sometimes, they can unify with type variables that the user would+rather keep distinct; see #11203 for an example.  So, any client of this+function needs to either allow the TyVarTvs to unify with each other or check+that they don't (say, with a call to findDubTyVarTvs).++Before #15050 this (under the name SigTv) was used for ScopedTypeVariables in+patterns, to make sure these type variables only refer to other type variables,+but this restriction was dropped, and ScopedTypeVariables can now refer to full+types (GHC Proposal 29).++The remaining uses of newTyVarTyVars are+* In kind signatures, see+  TcTyClsDecls Note [Inferring kinds for type declarations]+           and Note [Kind checking for GADTs]+* In partial type signatures, see Note [Quantified variables in partial type signatures]+-}++newMetaTyVarName :: FastString -> TcM Name+-- Makes a /System/ Name, which is eagerly eliminated by+-- the unifier; see TcUnify.nicer_to_update_tv1, and+-- TcCanonical.canEqTyVarTyVar (nicer_to_update_tv2)+newMetaTyVarName str+  = do { uniq <- newUnique+       ; return (mkSystemName uniq (mkTyVarOccFS str)) }++cloneMetaTyVarName :: Name -> TcM Name+cloneMetaTyVarName name+  = do { uniq <- newUnique+       ; return (mkSystemName uniq (nameOccName name)) }+         -- See Note [Name of an instantiated type variable]++{- Note [Name of an instantiated type variable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At the moment we give a unification variable a System Name, which+influences the way it is tidied; see TypeRep.tidyTyVarBndr.++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.+-}++newAnonMetaTyVar :: MetaInfo -> Kind -> TcM TcTyVar+-- Make a new meta tyvar out of thin air+newAnonMetaTyVar meta_info kind+  = do  { let s = case meta_info of+                        TauTv       -> fsLit "t"+                        FlatMetaTv  -> fsLit "fmv"+                        FlatSkolTv  -> fsLit "fsk"+                        TyVarTv      -> fsLit "a"+        ; name    <- newMetaTyVarName s+        ; details <- newMetaDetails meta_info+        ; let tyvar = mkTcTyVar name kind details+        ; traceTc "newAnonMetaTyVar" (ppr tyvar)+        ; return tyvar }++-- makes a new skolem tv+newSkolemTyVar :: Name -> Kind -> TcM TcTyVar+newSkolemTyVar name kind+  = do { lvl <- getTcLevel+       ; return (mkTcTyVar name kind (SkolemTv lvl False)) }++newTyVarTyVar :: Name -> Kind -> TcM TcTyVar+-- See Note [TyVarTv]+-- See Note [Unification variables need fresh Names]+newTyVarTyVar name kind+  = do { details <- newMetaDetails TyVarTv+       ; uniq <- newUnique+       ; let name' = name `setNameUnique` uniq+             tyvar = mkTcTyVar name' kind details+         -- Don't use cloneMetaTyVar, which makes a SystemName+         -- We want to keep the original more user-friendly Name+         -- In practical terms that means that in error messages,+         -- when the Name is tidied we get 'a' rather than 'a0'+       ; traceTc "newTyVarTyVar" (ppr tyvar)+       ; return tyvar }++newPatSigTyVar :: Name -> Kind -> TcM TcTyVar+newPatSigTyVar name kind+  = do { details <- newMetaDetails TauTv+       ; uniq <- newUnique+       ; let name' = name `setNameUnique` uniq+             tyvar = mkTcTyVar name' kind details+         -- Don't use cloneMetaTyVar;+         -- same reasoning as in newTyVarTyVar+       ; traceTc "newPatSigTyVar" (ppr tyvar)+       ; return tyvar }++cloneAnonMetaTyVar :: MetaInfo -> TyVar -> TcKind -> TcM TcTyVar+-- Make a fresh MetaTyVar, basing the name+-- on that of the supplied TyVar+cloneAnonMetaTyVar info tv kind+  = do  { details <- newMetaDetails info+        ; name    <- cloneMetaTyVarName (tyVarName tv)+        ; let tyvar = mkTcTyVar name kind details+        ; traceTc "cloneAnonMetaTyVar" (ppr tyvar)+        ; return tyvar }++newFskTyVar :: TcType -> TcM TcTyVar+newFskTyVar fam_ty+  = do { details <- newMetaDetails FlatSkolTv+       ; name <- newMetaTyVarName (fsLit "fsk")+       ; return (mkTcTyVar name (tcTypeKind fam_ty) details) }++newFmvTyVar :: TcType -> TcM TcTyVar+-- Very like newMetaTyVar, except sets mtv_tclvl to one less+-- so that the fmv is untouchable.+newFmvTyVar fam_ty+  = do { details <- newMetaDetails FlatMetaTv+       ; name <- newMetaTyVarName (fsLit "s")+       ; return (mkTcTyVar name (tcTypeKind fam_ty) details) }++newMetaDetails :: MetaInfo -> TcM TcTyVarDetails+newMetaDetails info+  = do { ref <- newMutVar Flexi+       ; tclvl <- getTcLevel+       ; return (MetaTv { mtv_info = info+                        , mtv_ref = ref+                        , mtv_tclvl = tclvl }) }++cloneMetaTyVar :: TcTyVar -> TcM TcTyVar+cloneMetaTyVar tv+  = ASSERT( isTcTyVar tv )+    do  { ref  <- newMutVar Flexi+        ; name' <- cloneMetaTyVarName (tyVarName tv)+        ; let details' = case tcTyVarDetails tv of+                           details@(MetaTv {}) -> details { mtv_ref = ref }+                           _ -> pprPanic "cloneMetaTyVar" (ppr tv)+              tyvar = mkTcTyVar name' (tyVarKind tv) details'+        ; traceTc "cloneMetaTyVar" (ppr tyvar)+        ; return tyvar }++-- Works for both type and kind variables+readMetaTyVar :: TyVar -> TcM MetaDetails+readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar )+                      readMutVar (metaTyVarRef tyvar)++isFilledMetaTyVar_maybe :: TcTyVar -> TcM (Maybe Type)+isFilledMetaTyVar_maybe tv+ | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv+ = do { cts <- readTcRef ref+      ; case cts of+          Indirect ty -> return (Just ty)+          Flexi       -> return Nothing }+ | otherwise+ = return Nothing++isFilledMetaTyVar :: TyVar -> TcM Bool+-- True of a filled-in (Indirect) meta type variable+isFilledMetaTyVar tv = isJust <$> isFilledMetaTyVar_maybe tv++isUnfilledMetaTyVar :: TyVar -> TcM Bool+-- True of a un-filled-in (Flexi) meta type variable+-- NB: Not the opposite of isFilledMetaTyVar+isUnfilledMetaTyVar tv+  | MetaTv { mtv_ref = ref } <- tcTyVarDetails tv+  = do  { details <- readMutVar ref+        ; return (isFlexi details) }+  | otherwise = return False++--------------------+-- Works with both type and kind variables+writeMetaTyVar :: TcTyVar -> TcType -> TcM ()+-- Write into a currently-empty MetaTyVar++writeMetaTyVar tyvar ty+  | not debugIsOn+  = writeMetaTyVarRef tyvar (metaTyVarRef tyvar) ty++-- Everything from here on only happens if DEBUG is on+  | not (isTcTyVar tyvar)+  = WARN( True, text "Writing to non-tc tyvar" <+> ppr tyvar )+    return ()++  | MetaTv { mtv_ref = ref } <- tcTyVarDetails tyvar+  = writeMetaTyVarRef tyvar ref ty++  | otherwise+  = WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar )+    return ()++--------------------+writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM ()+-- Here the tyvar is for error checking only;+-- the ref cell must be for the same tyvar+writeMetaTyVarRef tyvar ref ty+  | not debugIsOn+  = do { traceTc "writeMetaTyVar" (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)+                                   <+> text ":=" <+> ppr ty)+       ; writeTcRef ref (Indirect ty) }++  -- Everything from here on only happens if DEBUG is on+  | otherwise+  = do { meta_details <- readMutVar ref;+       -- Zonk kinds to allow the error check to work+       ; zonked_tv_kind <- zonkTcType tv_kind+       ; zonked_ty_kind <- zonkTcType ty_kind+       ; let kind_check_ok = tcIsConstraintKind zonked_tv_kind+                          || tcEqKind zonked_ty_kind zonked_tv_kind+             -- Hack alert! tcIsConstraintKind: see TcHsType+             -- Note [Extra-constraint holes in partial type signatures]++             kind_msg = hang (text "Ill-kinded update to meta tyvar")+                           2 (    ppr tyvar <+> text "::" <+> (ppr tv_kind $$ ppr zonked_tv_kind)+                              <+> text ":="+                              <+> ppr ty <+> text "::" <+> (ppr zonked_ty_kind) )++       ; traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty)++       -- Check for double updates+       ; MASSERT2( isFlexi meta_details, double_upd_msg meta_details )++       -- Check for level OK+       -- See Note [Level check when unifying]+       ; MASSERT2( level_check_ok, level_check_msg )++       -- Check Kinds ok+       ; MASSERT2( kind_check_ok, kind_msg )++       -- Do the write+       ; writeMutVar ref (Indirect ty) }+  where+    tv_kind = tyVarKind tyvar+    ty_kind = tcTypeKind ty++    tv_lvl = tcTyVarLevel tyvar+    ty_lvl = tcTypeLevel ty++    level_check_ok  = not (ty_lvl `strictlyDeeperThan` tv_lvl)+    level_check_msg = ppr ty_lvl $$ ppr tv_lvl $$ ppr tyvar $$ ppr ty++    double_upd_msg details = hang (text "Double update of meta tyvar")+                                2 (ppr tyvar $$ ppr details)++{- Note [Level check when unifying]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When unifying+     alpha:lvl := ty+we expect that the TcLevel of 'ty' will be <= lvl.+However, during unflatting we do+     fuv:l := ty:(l+1)+which is usually wrong; hence the check isFmmvTyVar in level_check_ok.+See Note [TcLevel assignment] in TcType.+-}++{-+% Generating fresh variables for pattern match check+-}+++{-+************************************************************************+*                                                                      *+        MetaTvs: TauTvs+*                                                                      *+************************************************************************++Note [Never need to instantiate coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With coercion variables sloshing around in types, it might seem that we+sometimes need to instantiate coercion variables. This would be problematic,+because coercion variables inhabit unboxed equality (~#), and the constraint+solver thinks in terms only of boxed equality (~). The solution is that+we never need to instantiate coercion variables in the first place.++The tyvars that we need to instantiate come from the types of functions,+data constructors, and patterns. These will never be quantified over+coercion variables, except for the special case of the promoted Eq#. But,+that can't ever appear in user code, so we're safe!+-}+++newFlexiTyVar :: Kind -> TcM TcTyVar+newFlexiTyVar kind = newAnonMetaTyVar TauTv kind++newFlexiTyVarTy :: Kind -> TcM TcType+newFlexiTyVarTy kind = do+    tc_tyvar <- newFlexiTyVar kind+    return (mkTyVarTy tc_tyvar)++newFlexiTyVarTys :: Int -> Kind -> TcM [TcType]+newFlexiTyVarTys n kind = replicateM n (newFlexiTyVarTy kind)++newOpenTypeKind :: TcM TcKind+newOpenTypeKind+  = do { rr <- newFlexiTyVarTy runtimeRepTy+       ; return (tYPE rr) }++-- | Create a tyvar that can be a lifted or unlifted type.+-- Returns alpha :: TYPE kappa, where both alpha and kappa are fresh+newOpenFlexiTyVarTy :: TcM TcType+newOpenFlexiTyVarTy+  = do { kind <- newOpenTypeKind+       ; newFlexiTyVarTy kind }++newMetaTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])+-- Instantiate with META type variables+-- Note that this works for a sequence of kind, type, and coercion variables+-- variables.  Eg    [ (k:*), (a:k->k) ]+--             Gives [ (k7:*), (a8:k7->k7) ]+newMetaTyVars = newMetaTyVarsX emptyTCvSubst+    -- emptyTCvSubst has an empty in-scope set, but that's fine here+    -- Since the tyvars are freshly made, they cannot possibly be+    -- captured by any existing for-alls.++newMetaTyVarsX :: TCvSubst -> [TyVar] -> TcM (TCvSubst, [TcTyVar])+-- Just like newMetaTyVars, but start with an existing substitution.+newMetaTyVarsX subst = mapAccumLM newMetaTyVarX subst++newMetaTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)+-- Make a new unification variable tyvar whose Name and Kind come from+-- an existing TyVar. We substitute kind variables in the kind.+newMetaTyVarX subst tyvar = new_meta_tv_x TauTv subst tyvar++newMetaTyVarTyVars :: [TyVar] -> TcM (TCvSubst, [TcTyVar])+newMetaTyVarTyVars = mapAccumLM newMetaTyVarTyVarX emptyTCvSubst++newMetaTyVarTyVarX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)+-- Just like newMetaTyVarX, but make a TyVarTv+newMetaTyVarTyVarX subst tyvar = new_meta_tv_x TyVarTv subst tyvar++newWildCardX :: TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)+newWildCardX subst tv+  = do { new_tv <- newAnonMetaTyVar TauTv (substTy subst (tyVarKind tv))+       ; return (extendTvSubstWithClone subst tv new_tv, new_tv) }++new_meta_tv_x :: MetaInfo -> TCvSubst -> TyVar -> TcM (TCvSubst, TcTyVar)+new_meta_tv_x info subst tv+  = do  { new_tv <- cloneAnonMetaTyVar info tv substd_kind+        ; let subst1 = extendTvSubstWithClone subst tv new_tv+        ; return (subst1, new_tv) }+  where+    substd_kind = substTyUnchecked subst (tyVarKind tv)+      -- NOTE: #12549 is fixed so we could use+      -- substTy here, but the tc_infer_args problem+      -- is not yet fixed so leaving as unchecked for now.+      -- OLD NOTE:+      -- Unchecked because we call newMetaTyVarX from+      -- tcInstTyBinder, which is called from tcInferApps+      -- which does not yet take enough trouble to ensure+      -- the in-scope set is right; e.g. #12785 trips+      -- if we use substTy here++newMetaTyVarTyAtLevel :: TcLevel -> TcKind -> TcM TcType+newMetaTyVarTyAtLevel tc_lvl kind+  = do  { ref  <- newMutVar Flexi+        ; name <- newMetaTyVarName (fsLit "p")+        ; let details = MetaTv { mtv_info  = TauTv+                               , mtv_ref   = ref+                               , mtv_tclvl = tc_lvl }+        ; return (mkTyVarTy (mkTcTyVar name kind details)) }++{- *********************************************************************+*                                                                      *+          Finding variables to quantify over+*                                                                      *+********************************************************************* -}++{- Note [Dependent type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Haskell type inference we quantify over type variables; but we only+quantify over /kind/ variables when -XPolyKinds is on.  Without -XPolyKinds+we default the kind variables to *.++So, to support this defaulting, and only for that reason, when+collecting the free vars of a type, prior to quantifying, we must keep+the type and kind variables separate.++But what does that mean in a system where kind variables /are/ type+variables? It's a fairly arbitrary distinction based on how the+variables appear:++  - "Kind variables" appear in the kind of some other free variable++     These are the ones we default to * if -XPolyKinds is off++  - "Type variables" are all free vars that are not kind variables++E.g.  In the type    T k (a::k)+      'k' is a kind variable, because it occurs in the kind of 'a',+          even though it also appears at "top level" of the type+      'a' is a type variable, because it doesn't++We gather these variables using a CandidatesQTvs record:+  DV { dv_kvs: Variables free in the kind of a free type variable+               or of a forall-bound type variable+     , dv_tvs: Variables sytactically free in the type }++So:  dv_kvs            are the kind variables of the type+     (dv_tvs - dv_kvs) are the type variable of the type++Note that++* A variable can occur in both.+      T k (x::k)    The first occurrence of k makes it+                    show up in dv_tvs, the second in dv_kvs++* We include any coercion variables in the "dependent",+  "kind-variable" set because we never quantify over them.++* The "kind variables" might depend on each other; e.g+     (k1 :: k2), (k2 :: *)+  The "type variables" do not depend on each other; if+  one did, it'd be classified as a kind variable!++Note [CandidatesQTvs determinism and order]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Determinism: when we quantify over type variables we decide the+  order in which they appear in the final type. Because the order of+  type variables in the type can end up in the interface file and+  affects some optimizations like worker-wrapper, we want this order to+  be deterministic.++  To achieve that we use deterministic sets of variables that can be+  converted to lists in a deterministic order. For more information+  about deterministic sets see Note [Deterministic UniqFM] in UniqDFM.++* Order: as well as being deterministic, we use an+  accumulating-parameter style for candidateQTyVarsOfType so that we+  add variables one at a time, left to right.  That means we tend to+  produce the variables in left-to-right order.  This is just to make+  it bit more predictable for the programmer.++Note [Naughty quantification candidates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#14880, dependent/should_compile/T14880-2), suppose+we are trying to generalise this type:++  forall arg. ... (alpha[tau]:arg) ...++We have a metavariable alpha whose kind mentions a skolem variable+boudn inside the very type we are generalising.+This can arise while type-checking a user-written type signature+(see the test case for the full code).++We cannot generalise over alpha!  That would produce a type like+  forall {a :: arg}. forall arg. ...blah...+The fact that alpha's kind mentions arg renders it completely+ineligible for generaliation.++However, we are not going to learn any new constraints on alpha,+because its kind isn't even in scope in the outer context.  So alpha+is entirely unconstrained.++What then should we do with alpha?  During generalization, every+metavariable is either (A) promoted, (B) generalized, or (C) zapped+(according again to Note [Recipe for checking a signature] in+TcHsType).++ * We can't generalise it.+ * We can't promote it, because its kind prevents that+ * We can't simply leave it be, because this type is about to+   go into the typing environment (as the type of some let-bound+   variable, say), and then chaos erupts when we try to instantiate.++So, we zap it, eagerly, to Any. We don't have to do this eager zapping+in terms (say, in `length []`) because terms are never re-examined before+the final zonk (which zaps any lingering metavariables to Any).++We do this eager zapping in candidateQTyVars, which always precedes+generalisation, because at that moment we have a clear picture of+what skolems are in scope.++-}++data CandidatesQTvs+  -- See Note [Dependent type variables]+  -- See Note [CandidatesQTvs determinism and order]+  --+  -- Invariants:+  --   * All variables stored here are MetaTvs. No exceptions.+  --   * All variables are fully zonked, including their kinds+  --+  = DV { dv_kvs :: DTyVarSet    -- "kind" metavariables (dependent)+       , dv_tvs :: DTyVarSet    -- "type" metavariables (non-dependent)+         -- A variable may appear in both sets+         -- E.g.   T k (x::k)    The first occurrence of k makes it+         --                      show up in dv_tvs, the second in dv_kvs+         -- See Note [Dependent type variables]++       , dv_cvs :: CoVarSet+         -- These are covars. We will *not* quantify over these, but+         -- we must make sure also not to quantify over any cv's kinds,+         -- so we include them here as further direction for quantifyTyVars+    }++instance Semi.Semigroup CandidatesQTvs where+   (DV { dv_kvs = kv1, dv_tvs = tv1, dv_cvs = cv1 })+     <> (DV { dv_kvs = kv2, dv_tvs = tv2, dv_cvs = cv2 })+          = DV { dv_kvs = kv1 `unionDVarSet` kv2+               , dv_tvs = tv1 `unionDVarSet` tv2+               , dv_cvs = cv1 `unionVarSet` cv2 }++instance Monoid CandidatesQTvs where+   mempty = DV { dv_kvs = emptyDVarSet, dv_tvs = emptyDVarSet, dv_cvs = emptyVarSet }+   mappend = (Semi.<>)++instance Outputable CandidatesQTvs where+  ppr (DV {dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs })+    = text "DV" <+> braces (pprWithCommas id [ text "dv_kvs =" <+> ppr kvs+                                             , text "dv_tvs =" <+> ppr tvs+                                             , text "dv_cvs =" <+> ppr cvs ])+++candidateKindVars :: CandidatesQTvs -> TyVarSet+candidateKindVars dvs = dVarSetToVarSet (dv_kvs dvs)++-- | Gathers free variables to use as quantification candidates (in+-- 'quantifyTyVars'). This might output the same var+-- in both sets, if it's used in both a type and a kind.+-- See Note [CandidatesQTvs determinism and order]+-- See Note [Dependent type variables]+candidateQTyVarsOfType :: TcType       -- not necessarily zonked+                       -> TcM CandidatesQTvs+candidateQTyVarsOfType ty = collect_cand_qtvs False emptyVarSet mempty ty++-- | Like 'splitDepVarsOfType', but over a list of types+candidateQTyVarsOfTypes :: [Type] -> TcM CandidatesQTvs+candidateQTyVarsOfTypes tys = foldlM (collect_cand_qtvs False emptyVarSet) mempty tys++-- | Like 'candidateQTyVarsOfType', but consider every free variable+-- to be dependent. This is appropriate when generalizing a *kind*,+-- instead of a type. (That way, -XNoPolyKinds will default the variables+-- to Type.)+candidateQTyVarsOfKind :: TcKind       -- Not necessarily zonked+                       -> TcM CandidatesQTvs+candidateQTyVarsOfKind ty = collect_cand_qtvs True emptyVarSet mempty ty++candidateQTyVarsOfKinds :: [TcKind]    -- Not necessarily zonked+                       -> TcM CandidatesQTvs+candidateQTyVarsOfKinds tys = foldM (collect_cand_qtvs True emptyVarSet) mempty tys++delCandidates :: CandidatesQTvs -> [Var] -> CandidatesQTvs+delCandidates (DV { dv_kvs = kvs, dv_tvs = tvs, dv_cvs = cvs }) vars+  = DV { dv_kvs = kvs `delDVarSetList` vars+       , dv_tvs = tvs `delDVarSetList` vars+       , dv_cvs = cvs `delVarSetList`  vars }++collect_cand_qtvs+  :: Bool            -- True <=> consider every fv in Type to be dependent+  -> VarSet          -- Bound variables (both locally bound and globally bound)+  -> CandidatesQTvs  -- Accumulating parameter+  -> Type            -- Not necessarily zonked+  -> TcM CandidatesQTvs++-- Key points:+--   * Looks through meta-tyvars as it goes;+--     no need to zonk in advance+--+--   * Needs to be monadic anyway, because it does the zap-naughty+--     stuff; see Note [Naughty quantification candidates]+--+--   * Returns fully-zonked CandidateQTvs, including their kinds+--     so that subsequent dependency analysis (to build a well+--     scoped telescope) works correctly++collect_cand_qtvs is_dep bound dvs ty+  = go dvs ty+  where+    is_bound tv = tv `elemVarSet` bound++    -----------------+    go :: CandidatesQTvs -> TcType -> TcM CandidatesQTvs+    -- Uses accumulating-parameter style+    go dv (AppTy t1 t2)     = foldlM go dv [t1, t2]+    go dv (TyConApp _ tys)  = foldlM go dv tys+    go dv (FunTy _ arg res) = foldlM go dv [arg, res]+    go dv (LitTy {})        = return dv+    go dv (CastTy ty co)    = do dv1 <- go dv ty+                                 collect_cand_qtvs_co bound dv1 co+    go dv (CoercionTy co)   = collect_cand_qtvs_co bound dv co++    go dv (TyVarTy tv)+      | is_bound tv = return dv+      | otherwise   = do { m_contents <- isFilledMetaTyVar_maybe tv+                         ; case m_contents of+                             Just ind_ty -> go dv ind_ty+                             Nothing     -> go_tv dv tv }++    go dv (ForAllTy (Bndr tv _) ty)+      = do { dv1 <- collect_cand_qtvs True bound dv (tyVarKind tv)+           ; collect_cand_qtvs is_dep (bound `extendVarSet` tv) dv1 ty }++    -----------------+    go_tv dv@(DV { dv_kvs = kvs, dv_tvs = tvs }) tv+      | tv `elemDVarSet` kvs = return dv  -- We have met this tyvar aleady+      | not is_dep+      , tv `elemDVarSet` tvs = return dv  -- We have met this tyvar aleady+      | otherwise+      = do { tv_kind <- zonkTcType (tyVarKind tv)+                 -- This zonk is annoying, but it is necessary, both to+                 -- ensure that the collected candidates have zonked kinds+                 -- (#15795) and to make the naughty check+                 -- (which comes next) works correctly+           ; if intersectsVarSet bound (tyCoVarsOfType tv_kind)++             then -- See Note [Naughty quantification candidates]+                  do { traceTc "Zapping naughty quantifier" (pprTyVar tv)+                     ; writeMetaTyVar tv (anyTypeOfKind tv_kind)+                     ; collect_cand_qtvs True bound dv tv_kind }++             else do { let tv' = tv `setTyVarKind` tv_kind+                           dv' | is_dep    = dv { dv_kvs = kvs `extendDVarSet` tv' }+                               | otherwise = dv { dv_tvs = tvs `extendDVarSet` tv' }+                               -- See Note [Order of accumulation]+                     ; collect_cand_qtvs True emptyVarSet dv' tv_kind } }++collect_cand_qtvs_co :: VarSet -- bound variables+                     -> CandidatesQTvs -> Coercion+                     -> TcM CandidatesQTvs+collect_cand_qtvs_co bound = go_co+  where+    go_co dv (Refl ty)             = collect_cand_qtvs True bound dv ty+    go_co dv (GRefl _ ty mco)      = do dv1 <- collect_cand_qtvs True bound dv ty+                                        go_mco dv1 mco+    go_co dv (TyConAppCo _ _ cos)  = foldlM go_co dv cos+    go_co dv (AppCo co1 co2)       = foldlM go_co dv [co1, co2]+    go_co dv (FunCo _ co1 co2)     = foldlM go_co dv [co1, co2]+    go_co dv (AxiomInstCo _ _ cos) = foldlM go_co dv cos+    go_co dv (AxiomRuleCo _ cos)   = foldlM go_co dv cos+    go_co dv (UnivCo prov _ t1 t2) = do dv1 <- go_prov dv prov+                                        dv2 <- collect_cand_qtvs True bound dv1 t1+                                        collect_cand_qtvs True bound dv2 t2+    go_co dv (SymCo co)            = go_co dv co+    go_co dv (TransCo co1 co2)     = foldlM go_co dv [co1, co2]+    go_co dv (NthCo _ _ co)        = go_co dv co+    go_co dv (LRCo _ co)           = go_co dv co+    go_co dv (InstCo co1 co2)      = foldlM go_co dv [co1, co2]+    go_co dv (KindCo co)           = go_co dv co+    go_co dv (SubCo co)            = go_co dv co++    go_co dv (HoleCo hole) = do m_co <- unpackCoercionHole_maybe hole+                                case m_co of+                                  Just co -> go_co dv co+                                  Nothing -> go_cv dv (coHoleCoVar hole)++    go_co dv (CoVarCo cv) = go_cv dv cv++    go_co dv (ForAllCo tcv kind_co co)+      = do { dv1 <- go_co dv kind_co+           ; collect_cand_qtvs_co (bound `extendVarSet` tcv) dv1 co }++    go_mco dv MRefl    = return dv+    go_mco dv (MCo co) = go_co dv co++    go_prov dv UnsafeCoerceProv    = return dv+    go_prov dv (PhantomProv co)    = go_co dv co+    go_prov dv (ProofIrrelProv co) = go_co dv co+    go_prov dv (PluginProv _)      = return dv++    go_cv :: CandidatesQTvs -> CoVar -> TcM CandidatesQTvs+    go_cv dv@(DV { dv_cvs = cvs }) cv+      | is_bound cv         = return dv+      | cv `elemVarSet` cvs = return dv+      | otherwise           = collect_cand_qtvs True emptyVarSet+                                    (dv { dv_cvs = cvs `extendVarSet` cv })+                                    (idType cv)++    is_bound tv = tv `elemVarSet` bound++{- Note [Order of accumulation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You might be tempted (like I was) to use unitDVarSet and mappend+rather than extendDVarSet.  However, the union algorithm for+deterministic sets depends on (roughly) the size of the sets. The+elements from the smaller set end up to the right of the elements from+the larger one. When sets are equal, the left-hand argument to+`mappend` goes to the right of the right-hand argument.++In our case, if we use unitDVarSet and mappend, we learn that the free+variables of (a -> b -> c -> d) are [b, a, c, d], and we then quantify+over them in that order. (The a comes after the b because we union the+singleton sets as ({a} `mappend` {b}), producing {b, a}. Thereafter,+the size criterion works to our advantage.) This is just annoying to+users, so I use `extendDVarSet`, which unambiguously puts the new+element to the right.++Note that the unitDVarSet/mappend implementation would not be wrong+against any specification -- just suboptimal and confounding to users.+-}++{- *********************************************************************+*                                                                      *+             Quantification+*                                                                      *+************************************************************************++Note [quantifyTyVars]+~~~~~~~~~~~~~~~~~~~~~+quantifyTyVars is given the free vars of a type that we+are about to wrap in a forall.++It takes these free type/kind variables (partitioned into dependent and+non-dependent variables) and+  1. Zonks them and remove globals and covars+  2. Extends kvs1 with free kind vars in the kinds of tvs (removing globals)+  3. Calls skolemiseQuantifiedTyVar on each++Step (2) is often unimportant, because the kind variable is often+also free in the type.  Eg+     Typeable k (a::k)+has free vars {k,a}.  But the type (see #7916)+    (f::k->*) (a::k)+has free vars {f,a}, but we must add 'k' as well! Hence step (2).++* This function distinguishes between dependent and non-dependent+  variables only to keep correct defaulting behavior with -XNoPolyKinds.+  With -XPolyKinds, it treats both classes of variables identically.++* quantifyTyVars never quantifies over+    - a coercion variable (or any tv mentioned in the kind of a covar)+    - a runtime-rep variable++Note [quantifyTyVars determinism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The results of quantifyTyVars are wrapped in a forall and can end up in the+interface file. One such example is inferred type signatures. They also affect+the results of optimizations, for example worker-wrapper. This means that to+get deterministic builds quantifyTyVars needs to be deterministic.++To achieve this CandidatesQTvs is backed by deterministic sets which allows them+to be later converted to a list in a deterministic order.++For more information about deterministic sets see+Note [Deterministic UniqFM] in UniqDFM.+-}++quantifyTyVars+  :: TcTyCoVarSet     -- Global tvs; already zonked+  -> CandidatesQTvs   -- See Note [Dependent type variables]+                      -- Already zonked+  -> TcM [TcTyVar]+-- See Note [quantifyTyVars]+-- Can be given a mixture of TcTyVars and TyVars, in the case of+--   associated type declarations. Also accepts covars, but *never* returns any.+quantifyTyVars gbl_tvs+               dvs@(DV{ dv_kvs = dep_tkvs, dv_tvs = nondep_tkvs, dv_cvs = covars })+  = do { outer_tclvl <- getTcLevel+       ; traceTc "quantifyTyVars 1" (vcat [ppr outer_tclvl, ppr dvs, ppr gbl_tvs])+       ; let co_tvs = closeOverKinds covars+             mono_tvs = gbl_tvs `unionVarSet` co_tvs+              -- NB: All variables in the kind of a covar must not be+              -- quantified over, as we don't quantify over the covar.++             dep_kvs = dVarSetElemsWellScoped $+                       dep_tkvs `dVarSetMinusVarSet` mono_tvs+                       -- dVarSetElemsWellScoped: put the kind variables into+                       --    well-scoped order.+                       --    E.g.  [k, (a::k)] not the other way roud++             nondep_tvs = dVarSetElems $+                          (nondep_tkvs `minusDVarSet` dep_tkvs)+                           `dVarSetMinusVarSet` mono_tvs+                 -- See Note [Dependent type variables]+                 -- The `minus` dep_tkvs removes any kind-level vars+                 --    e.g. T k (a::k)   Since k appear in a kind it'll+                 --    be in dv_kvs, and is dependent. So remove it from+                 --    dv_tvs which will also contain k+                 -- No worry about dependent covars here;+                 --    they are all in dep_tkvs+                 -- NB kinds of tvs are zonked by zonkTyCoVarsAndFV++       -- This block uses level numbers to decide what to quantify+       -- and emits a warning if the two methods do not give the same answer+       ; let dep_kvs2    = dVarSetElemsWellScoped $+                           filterDVarSet (quantifiableTv outer_tclvl) dep_tkvs+             nondep_tvs2 = filter (quantifiableTv outer_tclvl) $+                           dVarSetElems (nondep_tkvs `minusDVarSet` dep_tkvs)++             all_ok = dep_kvs == dep_kvs2 && nondep_tvs == nondep_tvs2+             bad_msg = hang (text "Quantification by level numbers would fail")+                          2 (vcat [ text "Outer level =" <+> ppr outer_tclvl+                                  , text "dep_tkvs ="    <+> ppr dep_tkvs+                                  , text "co_vars ="     <+> vcat [ ppr cv <+> dcolon <+> ppr (varType cv)+                                                                  | cv <- nonDetEltsUniqSet covars ]+                                  , text "co_tvs ="      <+> ppr co_tvs+                                  , text "dep_kvs ="     <+> ppr dep_kvs+                                  , text "dep_kvs2 ="    <+> ppr dep_kvs2+                                  , text "nondep_tvs ="  <+> ppr nondep_tvs+                                  , text "nondep_tvs2 =" <+> ppr nondep_tvs2 ])+       ; WARN( not all_ok, bad_msg ) return ()++             -- In the non-PolyKinds case, default the kind variables+             -- to *, and zonk the tyvars as usual.  Notice that this+             -- may make quantifyTyVars return a shorter list+             -- than it was passed, but that's ok+       ; poly_kinds  <- xoptM LangExt.PolyKinds+       ; dep_kvs'    <- mapMaybeM (zonk_quant (not poly_kinds)) dep_kvs+       ; nondep_tvs' <- mapMaybeM (zonk_quant False)            nondep_tvs+       ; let final_qtvs = dep_kvs' ++ nondep_tvs'+           -- Because of the order, any kind variables+           -- mentioned in the kinds of the nondep_tvs'+           -- now refer to the dep_kvs'++       ; traceTc "quantifyTyVars 2"+           (vcat [ text "globals:"    <+> ppr gbl_tvs+                 , text "mono_tvs:"   <+> ppr mono_tvs+                 , text "nondep:"     <+> pprTyVars nondep_tvs+                 , text "dep:"        <+> pprTyVars dep_kvs+                 , text "dep_kvs'"    <+> pprTyVars dep_kvs'+                 , text "nondep_tvs'" <+> pprTyVars nondep_tvs' ])++       -- We should never quantify over coercion variables; check this+       ; let co_vars = filter isCoVar final_qtvs+       ; MASSERT2( null co_vars, ppr co_vars )++       ; return final_qtvs }+  where+    -- zonk_quant returns a tyvar if it should be quantified over;+    -- otherwise, it returns Nothing. The latter case happens for+    --    * Kind variables, with -XNoPolyKinds: don't quantify over these+    --    * RuntimeRep variables: we never quantify over these+    zonk_quant default_kind tkv+      | not (isTyVar tkv)+      = return Nothing   -- this can happen for a covar that's associated with+                         -- a coercion hole. Test case: typecheck/should_compile/T2494++      | not (isTcTyVar tkv)  -- I don't think this can ever happen.+                             -- Hence the assert+      = ASSERT2( False, text "quantifying over a TyVar" <+> ppr tkv)+        return (Just tkv)++      | otherwise+      = do { deflt_done <- defaultTyVar default_kind tkv+           ; case deflt_done of+               True  -> return Nothing+               False -> do { tv <- skolemiseQuantifiedTyVar tkv+                           ; return (Just tv) } }++quantifiableTv :: TcLevel   -- Level of the context, outside the quantification+               -> TcTyVar+               -> Bool+quantifiableTv outer_tclvl tcv+  | isTcTyVar tcv  -- Might be a CoVar; change this when gather covars separately+  = tcTyVarLevel tcv > outer_tclvl+  | otherwise+  = False++zonkAndSkolemise :: TcTyCoVar -> TcM TcTyCoVar+-- A tyvar binder is never a unification variable (TauTv),+-- rather it is always a skolem. It *might* be a TyVarTv.+-- (Because non-CUSK type declarations use TyVarTvs.)+-- Regardless, it may have a kind that has not yet been zonked,+-- and may include kind unification variables.+zonkAndSkolemise tyvar+  | isTyVarTyVar tyvar+     -- We want to preserve the binding location of the original TyVarTv.+     -- This is important for error messages. If we don't do this, then+     -- we get bad locations in, e.g., typecheck/should_fail/T2688+  = do { zonked_tyvar <- zonkTcTyVarToTyVar tyvar+       ; skolemiseQuantifiedTyVar zonked_tyvar }++  | otherwise+  = ASSERT2( isImmutableTyVar tyvar || isCoVar tyvar, pprTyVar tyvar )+    zonkTyCoVarKind tyvar++skolemiseQuantifiedTyVar :: TcTyVar -> TcM TcTyVar+-- The quantified type variables often include meta type variables+-- we want to freeze them into ordinary type variables+-- The meta tyvar is updated to point to the new skolem TyVar.  Now any+-- bound occurrences of the original type variable will get zonked to+-- the immutable version.+--+-- We leave skolem TyVars alone; they are immutable.+--+-- This function is called on both kind and type variables,+-- but kind variables *only* if PolyKinds is on.++skolemiseQuantifiedTyVar tv+  = case tcTyVarDetails tv of+      SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv)+                        ; return (setTyVarKind tv kind) }+        -- It might be a skolem type variable,+        -- for example from a user type signature++      MetaTv {} -> skolemiseUnboundMetaTyVar tv++      _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk++defaultTyVar :: Bool      -- True <=> please default this kind variable to *+             -> TcTyVar   -- If it's a MetaTyVar then it is unbound+             -> TcM Bool  -- True <=> defaulted away altogether++defaultTyVar default_kind tv+  | not (isMetaTyVar tv)+  = return False++  | isTyVarTyVar tv+    -- Do not default TyVarTvs. Doing so would violate the invariants+    -- on TyVarTvs; see Note [Signature skolems] in TcType.+    -- #13343 is an example; #14555 is another+    -- See Note [Inferring kinds for type declarations] in TcTyClsDecls+  = return False+++  | isRuntimeRepVar tv  -- Do not quantify over a RuntimeRep var+                        -- unless it is a TyVarTv, handled earlier+  = do { traceTc "Defaulting a RuntimeRep var to LiftedRep" (ppr tv)+       ; writeMetaTyVar tv liftedRepTy+       ; return True }++  | default_kind            -- -XNoPolyKinds and this is a kind var+  = default_kind_var tv     -- so default it to * if possible++  | otherwise+  = return False++  where+    default_kind_var :: TyVar -> TcM Bool+       -- defaultKindVar is used exclusively with -XNoPolyKinds+       -- See Note [Defaulting with -XNoPolyKinds]+       -- It takes an (unconstrained) meta tyvar and defaults it.+       -- Works only on vars of type *; for other kinds, it issues an error.+    default_kind_var kv+      | isLiftedTypeKind (tyVarKind kv)+      = do { traceTc "Defaulting a kind var to *" (ppr kv)+           ; writeMetaTyVar kv liftedTypeKind+           ; return True }+      | otherwise+      = do { addErr (vcat [ text "Cannot default kind variable" <+> quotes (ppr kv')+                          , text "of kind:" <+> ppr (tyVarKind kv')+                          , text "Perhaps enable PolyKinds or add a kind signature" ])+           -- We failed to default it, so return False to say so.+           -- Hence, it'll get skolemised.  That might seem odd, but we must either+           -- promote, skolemise, or zap-to-Any, to satisfy TcHsType+           --    Note [Recipe for checking a signature]+           -- Otherwise we get level-number assertion failures. It doesn't matter much+           -- because we are in an error siutation anyway.+           ; return False+        }+      where+        (_, kv') = tidyOpenTyCoVar emptyTidyEnv kv++skolemiseUnboundMetaTyVar :: TcTyVar -> TcM TyVar+-- We have a Meta tyvar with a ref-cell inside it+-- Skolemise it, so that we are totally out of Meta-tyvar-land+-- We create a skolem TcTyVar, not a regular TyVar+--   See Note [Zonking to Skolem]+skolemiseUnboundMetaTyVar tv+  = ASSERT2( isMetaTyVar tv, ppr tv )+    do  { when debugIsOn (check_empty tv)+        ; span <- 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++        ; traceTc "Skolemising" (ppr tv <+> text ":=" <+> ppr final_tv)+        ; writeMetaTyVar tv (mkTyVarTy final_tv)+        ; return final_tv }++  where+    details = SkolemTv (metaTyVarTcLevel tv) False+    check_empty tv       -- [Sept 04] Check for non-empty.+      = when debugIsOn $  -- See note [Silly Type Synonym]+        do { cts <- readMetaTyVar tv+           ; case cts of+               Flexi       -> return ()+               Indirect ty -> WARN( True, ppr tv $$ ppr ty )+                              return () }++{- Note [Defaulting with -XNoPolyKinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  data Compose f g a = Mk (f (g a))++We infer++  Compose :: forall k1 k2. (k2 -> *) -> (k1 -> k2) -> k1 -> *+  Mk :: forall k1 k2 (f :: k2 -> *) (g :: k1 -> k2) (a :: k1).+        f (g a) -> Compose k1 k2 f g a++Now, in another module, we have -XNoPolyKinds -XDataKinds in effect.+What does 'Mk mean? Pre GHC-8.0 with -XNoPolyKinds,+we just defaulted all kind variables to *. But that's no good here,+because the kind variables in 'Mk aren't of kind *, so defaulting to *+is ill-kinded.++After some debate on #11334, we decided to issue an error in this case.+The code is in defaultKindVar.++Note [What is a meta variable?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A "meta type-variable", also know as a "unification variable" is a placeholder+introduced by the typechecker for an as-yet-unknown monotype.++For example, when we see a call `reverse (f xs)`, we know that we calling+    reverse :: forall a. [a] -> [a]+So we know that the argument `f xs` must be a "list of something". But what is+the "something"? We don't know until we explore the `f xs` a bit more. So we set+out what we do know at the call of `reverse` by instantiate its type with a fresh+meta tyvar, `alpha` say. So now the type of the argument `f xs`, and of the+result, is `[alpha]`. The unification variable `alpha` stands for the+as-yet-unknown type of the elements of the list.++As type inference progresses we may learn more about `alpha`. For example, suppose+`f` has the type+    f :: forall b. b -> [Maybe b]+Then we instantiate `f`'s type with another fresh unification variable, say+`beta`; and equate `f`'s result type with reverse's argument type, thus+`[alpha] ~ [Maybe beta]`.++Now we can solve this equality to learn that `alpha ~ Maybe beta`, so we've+refined our knowledge about `alpha`. And so on.++If you found this Note useful, you may also want to have a look at+Section 5 of "Practical type inference for higher rank types" (Peyton Jones,+Vytiniotis, Weirich and Shields. J. Functional Programming. 2011).++Note [What is zonking?]+~~~~~~~~~~~~~~~~~~~~~~~+GHC relies heavily on mutability in the typechecker for efficient operation.+For this reason, throughout much of the type checking process meta type+variables (the MetaTv constructor of TcTyVarDetails) are represented by mutable+variables (known as TcRefs).++Zonking is the process of ripping out these mutable variables and replacing them+with a real Type. This involves traversing the entire type expression, but the+interesting part of replacing the mutable variables occurs in zonkTyVarOcc.++There are two ways to zonk a Type:++ * zonkTcTypeToType, which is intended to be used at the end of type-checking+   for the final zonk. It has to deal with unfilled metavars, either by filling+   it with a value like Any or failing (determined by the UnboundTyVarZonker+   used).++ * zonkTcType, which will happily ignore unfilled metavars. This is the+   appropriate function to use while in the middle of type-checking.++Note [Zonking to Skolem]+~~~~~~~~~~~~~~~~~~~~~~~~+We used to zonk quantified type variables to regular TyVars.  However, this+leads to problems.  Consider this program from the regression test suite:++  eval :: Int -> String -> String -> String+  eval 0 root actual = evalRHS 0 root actual++  evalRHS :: Int -> a+  evalRHS 0 root actual = eval 0 root actual++It leads to the deferral of an equality (wrapped in an implication constraint)++  forall a. () => ((String -> String -> String) ~ a)++which is propagated up to the toplevel (see TcSimplify.tcSimplifyInferCheck).+In the meantime `a' is zonked and quantified to form `evalRHS's signature.+This has the *side effect* of also zonking the `a' in the deferred equality+(which at this point is being handed around wrapped in an implication+constraint).++Finally, the equality (with the zonked `a') will be handed back to the+simplifier by TcRnDriver.tcRnSrcDecls calling TcSimplify.tcSimplifyTop.+If we zonk `a' with a regular type variable, we will have this regular type+variable now floating around in the simplifier, which in many places assumes to+only see proper TcTyVars.++We can avoid this problem by zonking with a skolem.  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 [Silly Type Synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+        type C u a = u  -- Note 'a' unused++        foo :: (forall a. C u a -> C u a) -> u+        foo x = ...++        bar :: Num u => u+        bar = foo (\t -> t + t)++* From the (\t -> t+t) we get type  {Num d} =>  d -> d+  where d is fresh.++* Now unify with type of foo's arg, and we get:+        {Num (C d a)} =>  C d a -> C d a+  where a is fresh.++* Now abstract over the 'a', but float out the Num (C d a) constraint+  because it does not 'really' mention a.  (see exactTyVarsOfType)+  The arg to foo becomes+        \/\a -> \t -> t+t++* So we get a dict binding for Num (C d a), which is zonked to give+        a = ()+  [Note Sept 04: now that we are zonking quantified type variables+  on construction, the 'a' will be frozen as a regular tyvar on+  quantification, so the floated dict will still have type (C d a).+  Which renders this whole note moot; happily!]++* Then the \/\a abstraction has a zonked 'a' in it.++All very silly.   I think its harmless to ignore the problem.  We'll end up with+a \/\a in the final result but all the occurrences of a will be zonked to ()++************************************************************************+*                                                                      *+              Zonking types+*                                                                      *+************************************************************************++-}++-- | @tcGetGlobalTyCoVars@ returns a fully-zonked set of *scoped* tyvars free in+-- the environment. To improve subsequent calls to the same function it writes+-- the zonked set back into the environment. Note that this returns all+-- variables free in anything (term-level or type-level) in scope. We thus+-- don't have to worry about clashes with things that are not in scope, because+-- if they are reachable, then they'll be returned here.+-- NB: This is closed over kinds, so it can return unification variables mentioned+-- in the kinds of in-scope tyvars.+tcGetGlobalTyCoVars :: TcM TcTyVarSet+tcGetGlobalTyCoVars+  = do { (TcLclEnv {tcl_tyvars = gtv_var}) <- getLclEnv+       ; gbl_tvs  <- readMutVar gtv_var+       ; gbl_tvs' <- zonkTyCoVarsAndFV gbl_tvs+       ; writeMutVar gtv_var gbl_tvs'+       ; return gbl_tvs' }++zonkTcTypeAndFV :: TcType -> TcM DTyCoVarSet+-- Zonk a type and take its free variables+-- With kind polymorphism it can be essential to zonk *first*+-- so that we find the right set of free variables.  Eg+--    forall k1. forall (a:k2). a+-- where k2:=k1 is in the substitution.  We don't want+-- k2 to look free in this type!+zonkTcTypeAndFV ty+  = tyCoVarsOfTypeDSet <$> zonkTcType ty++zonkTyCoVar :: TyCoVar -> TcM TcType+-- Works on TyVars and TcTyVars+zonkTyCoVar tv | isTcTyVar tv = zonkTcTyVar tv+               | isTyVar   tv = mkTyVarTy <$> zonkTyCoVarKind tv+               | otherwise    = ASSERT2( isCoVar tv, ppr tv )+                                mkCoercionTy . mkCoVarCo <$> zonkTyCoVarKind tv+   -- Hackily, when typechecking type and class decls+   -- we have TyVars in scope added (only) in+   -- TcHsType.bindTyClTyVars, but it seems+   -- painful to make them into TcTyVars there++zonkTyCoVarsAndFV :: TyCoVarSet -> TcM TyCoVarSet+zonkTyCoVarsAndFV tycovars+  = tyCoVarsOfTypes <$> mapM zonkTyCoVar (nonDetEltsUniqSet tycovars)+  -- It's OK to use nonDetEltsUniqSet here because we immediately forget about+  -- the ordering by turning it into a nondeterministic set and the order+  -- of zonking doesn't matter for determinism.++-- Takes a list of TyCoVars, zonks them and returns a+-- deterministically ordered list of their free variables.+zonkTyCoVarsAndFVList :: [TyCoVar] -> TcM [TyCoVar]+zonkTyCoVarsAndFVList tycovars+  = tyCoVarsOfTypesList <$> mapM zonkTyCoVar tycovars++zonkTcTyVars :: [TcTyVar] -> TcM [TcType]+zonkTcTyVars tyvars = mapM zonkTcTyVar tyvars++-----------------  Types+zonkTyCoVarKind :: TyCoVar -> TcM TyCoVar+zonkTyCoVarKind tv = do { kind' <- zonkTcType (tyVarKind tv)+                        ; return (setTyVarKind tv kind') }++zonkTcTypes :: [TcType] -> TcM [TcType]+zonkTcTypes tys = mapM zonkTcType tys++{-+************************************************************************+*                                                                      *+              Zonking constraints+*                                                                      *+************************************************************************+-}++zonkImplication :: Implication -> TcM Implication+zonkImplication implic@(Implic { ic_skols  = skols+                               , ic_given  = given+                               , ic_wanted = wanted+                               , ic_info   = info })+  = do { skols'  <- mapM zonkTyCoVarKind skols  -- Need to zonk their kinds!+                                                -- as #7230 showed+       ; given'  <- mapM zonkEvVar given+       ; info'   <- zonkSkolemInfo info+       ; wanted' <- zonkWCRec wanted+       ; return (implic { ic_skols  = skols'+                        , ic_given  = given'+                        , ic_wanted = wanted'+                        , ic_info   = info' }) }++zonkEvVar :: EvVar -> TcM EvVar+zonkEvVar var = do { ty' <- zonkTcType (varType var)+                   ; return (setVarType var ty') }+++zonkWC :: WantedConstraints -> TcM WantedConstraints+zonkWC wc = zonkWCRec wc++zonkWCRec :: WantedConstraints -> TcM WantedConstraints+zonkWCRec (WC { wc_simple = simple, wc_impl = implic })+  = do { simple' <- zonkSimples simple+       ; implic' <- mapBagM zonkImplication implic+       ; return (WC { wc_simple = simple', wc_impl = implic' }) }++zonkSimples :: Cts -> TcM Cts+zonkSimples cts = do { cts' <- mapBagM zonkCt' cts+                     ; traceTc "zonkSimples done:" (ppr cts')+                     ; return cts' }++zonkCt' :: Ct -> TcM Ct+zonkCt' ct = zonkCt ct++{- Note [zonkCt behaviour]+~~~~~~~~~~~~~~~~~~~~~~~~~~+zonkCt tries to maintain the canonical form of a Ct.  For example,+  - a CDictCan should stay a CDictCan;+  - a CTyEqCan should stay a CTyEqCan (if the LHS stays as a variable.).+  - a CHoleCan should stay a CHoleCan+  - a CIrredCan should stay a CIrredCan with its cc_insol flag intact++Why?, for example:+- For CDictCan, the @TcSimplify.expandSuperClasses@ step, which runs after the+  simple wanted and plugin loop, looks for @CDictCan@s. If a plugin is in use,+  constraints are zonked before being passed to the plugin. This means if we+  don't preserve a canonical form, @expandSuperClasses@ fails to expand+  superclasses. This is what happened in #11525.++- For CHoleCan, once we forget that it's a hole, we can never recover that info.++- For CIrredCan we want to see if a constraint is insoluble with insolubleWC++NB: we do not expect to see any CFunEqCans, because zonkCt is only+called on unflattened constraints.++NB: Constraints are always re-flattened etc by the canonicaliser in+@TcCanonical@ even if they come in as CDictCan. Only canonical constraints that+are actually in the inert set carry all the guarantees. So it is okay if zonkCt+creates e.g. a CDictCan where the cc_tyars are /not/ function free.+-}++zonkCt :: Ct -> TcM Ct+zonkCt ct@(CHoleCan { cc_ev = ev })+  = do { ev' <- zonkCtEvidence ev+       ; return $ ct { cc_ev = ev' } }++zonkCt ct@(CDictCan { cc_ev = ev, cc_tyargs = args })+  = do { ev'   <- zonkCtEvidence ev+       ; args' <- mapM zonkTcType args+       ; return $ ct { cc_ev = ev', cc_tyargs = args' } }++zonkCt ct@(CTyEqCan { cc_ev = ev, cc_tyvar = tv, cc_rhs = rhs })+  = do { ev'    <- zonkCtEvidence ev+       ; tv_ty' <- zonkTcTyVar tv+       ; case getTyVar_maybe tv_ty' of+           Just tv' -> do { rhs' <- zonkTcType rhs+                          ; return ct { cc_ev    = ev'+                                      , cc_tyvar = tv'+                                      , cc_rhs   = rhs' } }+           Nothing  -> return (mkNonCanonical ev') }++zonkCt ct@(CIrredCan { cc_ev = ev }) -- Preserve the cc_insol flag+  = do { ev' <- zonkCtEvidence ev+       ; return (ct { cc_ev = ev' }) }++zonkCt ct+  = ASSERT( not (isCFunEqCan ct) )+  -- We do not expect to see any CFunEqCans, because zonkCt is only called on+  -- unflattened constraints.+    do { fl' <- zonkCtEvidence (ctEvidence ct)+       ; return (mkNonCanonical fl') }++zonkCtEvidence :: CtEvidence -> TcM CtEvidence+zonkCtEvidence ctev@(CtGiven { ctev_pred = pred })+  = do { pred' <- zonkTcType pred+       ; return (ctev { ctev_pred = pred'}) }+zonkCtEvidence ctev@(CtWanted { ctev_pred = pred, ctev_dest = dest })+  = do { pred' <- zonkTcType pred+       ; let dest' = case dest of+                       EvVarDest ev -> EvVarDest $ setVarType ev pred'+                         -- necessary in simplifyInfer+                       HoleDest h   -> HoleDest h+       ; return (ctev { ctev_pred = pred', ctev_dest = dest' }) }+zonkCtEvidence ctev@(CtDerived { ctev_pred = pred })+  = do { pred' <- zonkTcType pred+       ; return (ctev { ctev_pred = pred' }) }++zonkSkolemInfo :: SkolemInfo -> TcM SkolemInfo+zonkSkolemInfo (SigSkol cx ty tv_prs)  = do { ty' <- zonkTcType ty+                                            ; return (SigSkol cx ty' tv_prs) }+zonkSkolemInfo (InferSkol ntys) = do { ntys' <- mapM do_one ntys+                                     ; return (InferSkol ntys') }+  where+    do_one (n, ty) = do { ty' <- zonkTcType ty; return (n, ty') }+zonkSkolemInfo skol_info = return skol_info++{-+%************************************************************************+%*                                                                      *+\subsection{Zonking -- the main work-horses: zonkTcType, zonkTcTyVar}+*                                                                      *+*              For internal use only!                                  *+*                                                                      *+************************************************************************++-}++-- zonkId is used *during* typechecking just to zonk the Id's type+zonkId :: TcId -> TcM TcId+zonkId id+  = do { ty' <- zonkTcType (idType id)+       ; return (Id.setIdType id ty') }++zonkCoVar :: CoVar -> TcM CoVar+zonkCoVar = zonkId++-- | A suitable TyCoMapper for zonking a type during type-checking,+-- before all metavars are filled in.+zonkTcTypeMapper :: TyCoMapper () TcM+zonkTcTypeMapper = TyCoMapper+  { tcm_tyvar = const zonkTcTyVar+  , tcm_covar = const (\cv -> mkCoVarCo <$> zonkTyCoVarKind cv)+  , tcm_hole  = hole+  , tcm_tycobinder = \_env tv _vis -> ((), ) <$> zonkTyCoVarKind tv+  , tcm_tycon      = zonkTcTyCon }+  where+    hole :: () -> CoercionHole -> TcM Coercion+    hole _ hole@(CoercionHole { ch_ref = ref, ch_co_var = cv })+      = do { contents <- readTcRef ref+           ; case contents of+               Just co -> do { co' <- zonkCo co+                             ; checkCoercionHole cv co' }+               Nothing -> do { cv' <- zonkCoVar cv+                             ; return $ HoleCo (hole { ch_co_var = cv' }) } }++zonkTcTyCon :: TcTyCon -> TcM TcTyCon+-- Only called on TcTyCons+-- A non-poly TcTyCon may have unification+-- variables that need zonking, but poly ones cannot+zonkTcTyCon tc+ | tcTyConIsPoly tc = return tc+ | otherwise        = do { tck' <- zonkTcType (tyConKind tc)+                         ; return (setTcTyConKind tc tck') }++-- For unbound, mutable tyvars, zonkType uses the function given to it+-- For tyvars bound at a for-all, zonkType zonks them to an immutable+--      type variable and zonks the kind too+zonkTcType :: TcType -> TcM TcType+zonkTcType = mapType zonkTcTypeMapper ()++-- | "Zonk" a coercion -- really, just zonk any types in the coercion+zonkCo :: Coercion -> TcM Coercion+zonkCo = mapCoercion zonkTcTypeMapper ()++zonkTcTyVar :: TcTyVar -> TcM TcType+-- Simply look through all Flexis+zonkTcTyVar tv+  | isTcTyVar tv+  = case tcTyVarDetails tv of+      SkolemTv {}   -> zonk_kind_and_return+      RuntimeUnk {} -> zonk_kind_and_return+      MetaTv { mtv_ref = ref }+         -> do { cts <- readMutVar ref+               ; case cts of+                    Flexi       -> zonk_kind_and_return+                    Indirect ty -> do { zty <- zonkTcType ty+                                      ; writeTcRef ref (Indirect zty)+                                        -- See Note [Sharing in zonking]+                                      ; return zty } }++  | otherwise -- coercion variable+  = zonk_kind_and_return+  where+    zonk_kind_and_return = do { z_tv <- zonkTyCoVarKind tv+                              ; return (mkTyVarTy z_tv) }++-- Variant that assumes that any result of zonking is still a TyVar.+-- Should be used only on skolems and TyVarTvs+zonkTcTyVarToTyVar :: HasDebugCallStack => TcTyVar -> TcM TcTyVar+zonkTcTyVarToTyVar tv+  = do { ty <- zonkTcTyVar tv+       ; let tv' = case tcGetTyVar_maybe ty of+                     Just tv' -> tv'+                     Nothing  -> pprPanic "zonkTcTyVarToTyVar"+                                          (ppr tv $$ ppr ty)+       ; return tv' }++zonkTyVarTyVarPairs :: [(Name,TcTyVar)] -> TcM [(Name,TcTyVar)]+zonkTyVarTyVarPairs prs+  = mapM do_one prs+  where+    do_one (nm, tv) = do { tv' <- zonkTcTyVarToTyVar tv+                         ; return (nm, tv') }++{- Note [Sharing in zonking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   alpha :-> beta :-> gamma :-> ty+where the ":->" means that the unification variable has been+filled in with Indirect. Then when zonking alpha, it'd be nice+to short-circuit beta too, so we end up with+   alpha :-> zty+   beta  :-> zty+   gamma :-> zty+where zty is the zonked version of ty.  That way, if we come across+beta later, we'll have less work to do.  (And indeed the same for+alpha.)++This is easily achieved: just overwrite (Indirect ty) with (Indirect+zty).  Non-systematic perf comparisons suggest that this is a modest+win.++But c.f Note [Sharing when zonking to Type] in TcHsSyn.++%************************************************************************+%*                                                                      *+                 Tidying+*                                                                      *+************************************************************************+-}++zonkTidyTcType :: TidyEnv -> TcType -> TcM (TidyEnv, TcType)+zonkTidyTcType env ty = do { ty' <- zonkTcType ty+                           ; return (tidyOpenType env ty') }++zonkTidyTcTypes :: TidyEnv -> [TcType] -> TcM (TidyEnv, [TcType])+zonkTidyTcTypes = zonkTidyTcTypes' []+  where zonkTidyTcTypes' zs env [] = return (env, reverse zs)+        zonkTidyTcTypes' zs env (ty:tys)+          = do { (env', ty') <- zonkTidyTcType env ty+               ; zonkTidyTcTypes' (ty':zs) env' tys }++zonkTidyOrigin :: TidyEnv -> CtOrigin -> TcM (TidyEnv, CtOrigin)+zonkTidyOrigin env (GivenOrigin skol_info)+  = do { skol_info1 <- zonkSkolemInfo skol_info+       ; let skol_info2 = tidySkolemInfo env skol_info1+       ; return (env, GivenOrigin skol_info2) }+zonkTidyOrigin env orig@(TypeEqOrigin { uo_actual   = act+                                      , uo_expected = exp })+  = do { (env1, act') <- zonkTidyTcType env  act+       ; (env2, exp') <- zonkTidyTcType env1 exp+       ; return ( env2, orig { uo_actual   = act'+                             , uo_expected = exp' }) }+zonkTidyOrigin env (KindEqOrigin ty1 m_ty2 orig t_or_k)+  = do { (env1, ty1')   <- zonkTidyTcType env  ty1+       ; (env2, m_ty2') <- case m_ty2 of+                             Just ty2 -> second Just <$> zonkTidyTcType env1 ty2+                             Nothing  -> return (env1, Nothing)+       ; (env3, orig')  <- zonkTidyOrigin env2 orig+       ; return (env3, KindEqOrigin ty1' m_ty2' orig' t_or_k) }+zonkTidyOrigin env (FunDepOrigin1 p1 l1 p2 l2)+  = do { (env1, p1') <- zonkTidyTcType env  p1+       ; (env2, p2') <- zonkTidyTcType env1 p2+       ; return (env2, FunDepOrigin1 p1' l1 p2' l2) }+zonkTidyOrigin env (FunDepOrigin2 p1 o1 p2 l2)+  = do { (env1, p1') <- zonkTidyTcType env  p1+       ; (env2, p2') <- zonkTidyTcType env1 p2+       ; (env3, o1') <- zonkTidyOrigin env2 o1+       ; return (env3, FunDepOrigin2 p1' o1' p2' l2) }+zonkTidyOrigin env orig = return (env, orig)++----------------+tidyCt :: TidyEnv -> Ct -> Ct+-- Used only in error reporting+-- Also converts it to non-canonical+tidyCt env ct+  = case ct of+     CHoleCan { cc_ev = ev }+       -> ct { cc_ev = tidy_ev env ev }+     _ -> mkNonCanonical (tidy_ev env (ctEvidence ct))+  where+    tidy_ev :: TidyEnv -> CtEvidence -> CtEvidence+     -- NB: we do not tidy the ctev_evar field because we don't+     --     show it in error messages+    tidy_ev env ctev@(CtGiven { ctev_pred = pred })+      = ctev { ctev_pred = tidyType env pred }+    tidy_ev env ctev@(CtWanted { ctev_pred = pred })+      = ctev { ctev_pred = tidyType env pred }+    tidy_ev env ctev@(CtDerived { ctev_pred = pred })+      = ctev { ctev_pred = tidyType env pred }++----------------+tidyEvVar :: TidyEnv -> EvVar -> EvVar+tidyEvVar env var = setVarType var (tidyType env (varType var))++----------------+tidySkolemInfo :: TidyEnv -> SkolemInfo -> SkolemInfo+tidySkolemInfo env (DerivSkol ty)         = DerivSkol (tidyType env ty)+tidySkolemInfo env (SigSkol cx ty tv_prs) = tidySigSkol env cx ty tv_prs+tidySkolemInfo env (InferSkol ids)        = InferSkol (mapSnd (tidyType env) ids)+tidySkolemInfo env (UnifyForAllSkol ty)   = UnifyForAllSkol (tidyType env ty)+tidySkolemInfo _   info                   = info++tidySigSkol :: TidyEnv -> UserTypeCtxt+            -> TcType -> [(Name,TcTyVar)] -> SkolemInfo+-- We need to take special care when tidying SigSkol+-- See Note [SigSkol SkolemInfo] in TcRnTypes+tidySigSkol env cx ty tv_prs+  = SigSkol cx (tidy_ty env ty) tv_prs'+  where+    tv_prs' = mapSnd (tidyTyCoVarOcc env) tv_prs+    inst_env = mkNameEnv tv_prs'++    tidy_ty env (ForAllTy (Bndr tv vis) ty)+      = ForAllTy (Bndr tv' vis) (tidy_ty env' ty)+      where+        (env', tv') = tidy_tv_bndr env tv++    tidy_ty env ty@(FunTy _ arg res)+      = ty { ft_arg = tidyType env arg, ft_res = tidy_ty env res }++    tidy_ty env ty = tidyType env ty++    tidy_tv_bndr :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)+    tidy_tv_bndr env@(occ_env, subst) tv+      | Just tv' <- lookupNameEnv inst_env (tyVarName tv)+      = ((occ_env, extendVarEnv subst tv tv'), tv')++      | otherwise+      = tidyVarBndr env tv++-------------------------------------------------------------------------+{-+%************************************************************************+%*                                                                      *+             Levity polymorphism checks+*                                                                      *+************************************************************************++See Note [Levity polymorphism checking] in DsMonad++-}++-- | According to the rules around representation polymorphism+-- (see https://gitlab.haskell.org/ghc/ghc/wikis/no-sub-kinds), no binder+-- can have a representation-polymorphic type. This check ensures+-- that we respect this rule. It is a bit regrettable that this error+-- occurs in zonking, after which we should have reported all errors.+-- But it's hard to see where else to do it, because this can be discovered+-- only after all solving is done. And, perhaps most importantly, this+-- isn't really a compositional property of a type system, so it's+-- not a terrible surprise that the check has to go in an awkward spot.+ensureNotLevPoly :: Type  -- its zonked type+                 -> SDoc  -- where this happened+                 -> TcM ()+ensureNotLevPoly ty doc+  = whenNoErrs $   -- sometimes we end up zonking bogus definitions of type+                   -- forall a. a. See, for example, test ghci/scripts/T9140+    checkForLevPoly doc ty++  -- See Note [Levity polymorphism checking] in DsMonad+checkForLevPoly :: SDoc -> Type -> TcM ()+checkForLevPoly = checkForLevPolyX addErr++checkForLevPolyX :: Monad m+                 => (SDoc -> m ())  -- how to report an error+                 -> SDoc -> Type -> m ()+checkForLevPolyX add_err extra ty+  | isTypeLevPoly ty+  = add_err (formatLevPolyErr ty $$ extra)+  | otherwise+  = return ()++formatLevPolyErr :: Type  -- levity-polymorphic type+                 -> SDoc+formatLevPolyErr ty+  = hang (text "A levity-polymorphic type is not allowed here:")+       2 (vcat [ text "Type:" <+> pprWithTYPE tidy_ty+               , text "Kind:" <+> pprWithTYPE tidy_ki ])+  where+    (tidy_env, tidy_ty) = tidyOpenType emptyTidyEnv ty+    tidy_ki             = tidyType tidy_env (tcTypeKind ty)
+ compiler/typecheck/TcMatches.hs view
@@ -0,0 +1,1100 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++TcMatches: Typecheck some @Matches@+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}++module TcMatches ( tcMatchesFun, tcGRHS, tcGRHSsPat, tcMatchesCase, tcMatchLambda,+                   TcMatchCtxt(..), TcStmtChecker, TcExprStmtChecker, TcCmdStmtChecker,+                   tcStmts, tcStmtsAndThen, tcDoStmts, tcBody,+                   tcDoStmt, tcGuardStmt+       ) where++import GhcPrelude++import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcInferSigmaNC, tcInferSigma+                              , tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr )++import BasicTypes (LexicalFixity(..))+import HsSyn+import TcRnMonad+import TcEnv+import TcPat+import TcMType+import TcType+import TcBinds+import TcUnify+import Name+import TysWiredIn+import Id+import TyCon+import TysPrim+import TcEvidence+import Outputable+import Util+import SrcLoc++-- Create chunkified tuple tybes for monad comprehensions+import MkCore++import Control.Monad+import Control.Arrow ( second )++#include "HsVersions.h"++{-+************************************************************************+*                                                                      *+\subsection{tcMatchesFun, tcMatchesCase}+*                                                                      *+************************************************************************++@tcMatchesFun@ typechecks a @[Match]@ list which occurs in a+@FunMonoBind@.  The second argument is the name of the function, which+is used in error messages.  It checks that all the equations have the+same number of arguments before using @tcMatches@ to do the work.++Note [Polymorphic expected type for tcMatchesFun]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcMatchesFun may be given a *sigma* (polymorphic) type+so it must be prepared to use tcSkolemise to skolemise it.+See Note [sig_tau may be polymorphic] in TcPat.+-}++tcMatchesFun :: Located Name+             -> MatchGroup GhcRn (LHsExpr GhcRn)+             -> ExpRhoType     -- Expected type of function+             -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))+                                -- Returns type of body+tcMatchesFun fn@(L _ fun_name) matches exp_ty+  = do  {  -- Check that they all have the same no of arguments+           -- Location is in the monad, set the caller so that+           -- any inter-equation error messages get some vaguely+           -- sensible location.        Note: we have to do this odd+           -- ann-grabbing, because we don't always have annotations in+           -- hand when we call tcMatchesFun...+          traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)+        ; checkArgs fun_name matches++        ; (wrap_gen, (wrap_fun, group))+            <- tcSkolemiseET (FunSigCtxt fun_name True) exp_ty $ \ exp_rho ->+                  -- Note [Polymorphic expected type for tcMatchesFun]+               do { (matches', wrap_fun)+                       <- matchExpectedFunTys herald arity exp_rho $+                          \ pat_tys rhs_ty ->+                          tcMatches match_ctxt pat_tys rhs_ty matches+                  ; return (wrap_fun, matches') }+        ; return (wrap_gen <.> wrap_fun, group) }+  where+    arity = matchGroupArity matches+    herald = text "The equation(s) for"+             <+> quotes (ppr fun_name) <+> text "have"+    what = FunRhs { mc_fun = fn, mc_fixity = Prefix, mc_strictness = strictness }+    match_ctxt = MC { mc_what = what, mc_body = tcBody }+    strictness+      | [L _ match] <- unLoc $ mg_alts matches+      , FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match+      = SrcStrict+      | otherwise+      = NoSrcStrict++{-+@tcMatchesCase@ doesn't do the argument-count check because the+parser guarantees that each equation has exactly one argument.+-}++tcMatchesCase :: (Outputable (body GhcRn)) =>+                TcMatchCtxt body                        -- Case context+             -> TcSigmaType                             -- Type of scrutinee+             -> MatchGroup GhcRn (Located (body GhcRn)) -- The case alternatives+             -> ExpRhoType                    -- Type of whole case expressions+             -> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))+                -- Translated alternatives+                -- wrapper goes from MatchGroup's ty to expected ty++tcMatchesCase ctxt scrut_ty matches res_ty+  = tcMatches ctxt [mkCheckExpType scrut_ty] res_ty matches++tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in TcUnify+              -> TcMatchCtxt HsExpr+              -> MatchGroup GhcRn (LHsExpr GhcRn)+              -> ExpRhoType   -- deeply skolemised+              -> TcM (MatchGroup GhcTcId (LHsExpr GhcTcId), HsWrapper)+tcMatchLambda herald match_ctxt match res_ty+  = matchExpectedFunTys herald n_pats res_ty $ \ pat_tys rhs_ty ->+    tcMatches match_ctxt pat_tys rhs_ty match+  where+    n_pats | isEmptyMatchGroup match = 1   -- must be lambda-case+           | otherwise               = matchGroupArity match++-- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.++tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> TcRhoType+           -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId))+-- Used for pattern bindings+tcGRHSsPat grhss res_ty = tcGRHSs match_ctxt grhss (mkCheckExpType res_ty)+  where+    match_ctxt = MC { mc_what = PatBindRhs,+                      mc_body = tcBody }++{-+************************************************************************+*                                                                      *+\subsection{tcMatch}+*                                                                      *+************************************************************************++Note [Case branches must never infer a non-tau type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  case ... of+    ... -> \(x :: forall a. a -> a) -> x+    ... -> \y -> y++Should that type-check? The problem is that, if we check the second branch+first, then we'll get a type (b -> b) for the branches, which won't unify+with the polytype in the first branch. If we check the first branch first,+then everything is OK. This order-dependency is terrible. So we want only+proper tau-types in branches (unless a sigma-type is pushed down).+This is what expTypeToType ensures: it replaces an Infer with a fresh+tau-type.++An even trickier case looks like++  f x True  = x undefined+  f x False = x ()++Here, we see that the arguments must also be non-Infer. Thus, we must+use expTypeToType on the output of matchExpectedFunTys, not the input.++But we make a special case for a one-branch case. This is so that++  f = \(x :: forall a. a -> a) -> x++still gets assigned a polytype.+-}++-- | When the MatchGroup has multiple RHSs, convert an Infer ExpType in the+-- expected type into TauTvs.+-- See Note [Case branches must never infer a non-tau type]+tauifyMultipleMatches :: [LMatch id body]+                      -> [ExpType] -> TcM [ExpType]+tauifyMultipleMatches group exp_tys+  | isSingletonMatchGroup group = return exp_tys+  | otherwise                   = mapM tauifyExpType exp_tys+  -- NB: In the empty-match case, this ensures we fill in the ExpType++-- | Type-check a MatchGroup.+tcMatches :: (Outputable (body GhcRn)) => TcMatchCtxt body+          -> [ExpSigmaType]      -- Expected pattern types+          -> ExpRhoType          -- Expected result-type of the Match.+          -> MatchGroup GhcRn (Located (body GhcRn))+          -> TcM (MatchGroup GhcTcId (Located (body GhcTcId)))++data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module+  = MC { mc_what :: HsMatchContext Name,  -- What kind of thing this is+         mc_body :: Located (body GhcRn)         -- Type checker for a body of+                                                -- an alternative+                 -> ExpRhoType+                 -> TcM (Located (body GhcTcId)) }++tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches+                                  , mg_origin = origin })+  = do { rhs_ty:pat_tys <- tauifyMultipleMatches matches (rhs_ty:pat_tys)+            -- See Note [Case branches must never infer a non-tau type]++       ; matches' <- mapM (tcMatch ctxt pat_tys rhs_ty) matches+       ; pat_tys  <- mapM readExpType pat_tys+       ; rhs_ty   <- readExpType rhs_ty+       ; return (MG { mg_alts = L l matches'+                    , mg_ext = MatchGroupTc pat_tys rhs_ty+                    , mg_origin = origin }) }+tcMatches _ _ _ (XMatchGroup {}) = panic "tcMatches"++-------------+tcMatch :: (Outputable (body GhcRn)) => TcMatchCtxt body+        -> [ExpSigmaType]        -- Expected pattern types+        -> ExpRhoType            -- Expected result-type of the Match.+        -> LMatch GhcRn (Located (body GhcRn))+        -> TcM (LMatch GhcTcId (Located (body GhcTcId)))++tcMatch ctxt pat_tys rhs_ty match+  = wrapLocM (tc_match ctxt pat_tys rhs_ty) match+  where+    tc_match ctxt pat_tys rhs_ty+             match@(Match { m_pats = pats, m_grhss = grhss })+      = add_match_ctxt match $+        do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $+                                tcGRHSs ctxt grhss rhs_ty+           ; return (Match { m_ext = noExt+                           , m_ctxt = mc_what ctxt, m_pats = pats'+                           , m_grhss = grhss' }) }+    tc_match  _ _ _ (XMatch _) = panic "tcMatch"++        -- For (\x -> e), tcExpr has already said "In the expression \x->e"+        -- so we don't want to add "In the lambda abstraction \x->e"+    add_match_ctxt match thing_inside+        = case mc_what ctxt of+            LambdaExpr -> thing_inside+            _          -> addErrCtxt (pprMatchInCtxt match) thing_inside++-------------+tcGRHSs :: TcMatchCtxt body -> GRHSs GhcRn (Located (body GhcRn)) -> ExpRhoType+        -> TcM (GRHSs GhcTcId (Located (body GhcTcId)))++-- Notice that we pass in the full res_ty, so that we get+-- good inference from simple things like+--      f = \(x::forall a.a->a) -> <stuff>+-- We used to force it to be a monotype when there was more than one guard+-- but we don't need to do that any more++tcGRHSs ctxt (GRHSs _ grhss (L l binds)) res_ty+  = do  { (binds', grhss')+            <- tcLocalBinds binds $+               mapM (wrapLocM (tcGRHS ctxt res_ty)) grhss++        ; return (GRHSs noExt grhss' (L l binds')) }+tcGRHSs _ (XGRHSs _) _ = panic "tcGRHSs"++-------------+tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (Located (body GhcRn))+       -> TcM (GRHS GhcTcId (Located (body GhcTcId)))++tcGRHS ctxt res_ty (GRHS _ guards rhs)+  = do  { (guards', rhs')+            <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $+               mc_body ctxt rhs+        ; return (GRHS noExt guards' rhs') }+  where+    stmt_ctxt  = PatGuard (mc_what ctxt)+tcGRHS _ _ (XGRHS _) = panic "tcGRHS"++{-+************************************************************************+*                                                                      *+\subsection{@tcDoStmts@ typechecks a {\em list} of do statements}+*                                                                      *+************************************************************************+-}++tcDoStmts :: HsStmtContext Name+          -> Located [LStmt GhcRn (LHsExpr GhcRn)]+          -> ExpRhoType+          -> TcM (HsExpr GhcTcId)          -- Returns a HsDo+tcDoStmts ListComp (L l stmts) res_ty+  = do  { res_ty <- expTypeToType res_ty+        ; (co, elt_ty) <- matchExpectedListTy res_ty+        ; let list_ty = mkListTy elt_ty+        ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts+                            (mkCheckExpType elt_ty)+        ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }++tcDoStmts DoExpr (L l stmts) res_ty+  = do  { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty+        ; res_ty <- readExpType res_ty+        ; return (HsDo res_ty DoExpr (L l stmts')) }++tcDoStmts MDoExpr (L l stmts) res_ty+  = do  { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty+        ; res_ty <- readExpType res_ty+        ; return (HsDo res_ty MDoExpr (L l stmts')) }++tcDoStmts MonadComp (L l stmts) res_ty+  = do  { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty+        ; res_ty <- readExpType res_ty+        ; return (HsDo res_ty MonadComp (L l stmts')) }++tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt)++tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTcId)+tcBody body res_ty+  = do  { traceTc "tcBody" (ppr res_ty)+        ; tcMonoExpr body res_ty+        }++{-+************************************************************************+*                                                                      *+\subsection{tcStmts}+*                                                                      *+************************************************************************+-}++type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType+type TcCmdStmtChecker  = TcStmtChecker HsCmd  TcRhoType++type TcStmtChecker body rho_type+  =  forall thing. HsStmtContext Name+                -> Stmt GhcRn (Located (body GhcRn))+                -> rho_type                 -- Result type for comprehension+                -> (rho_type -> TcM thing)  -- Checker for what follows the stmt+                -> TcM (Stmt GhcTcId (Located (body GhcTcId)), thing)++tcStmts :: (Outputable (body GhcRn)) => HsStmtContext Name+        -> TcStmtChecker body rho_type   -- NB: higher-rank type+        -> [LStmt GhcRn (Located (body GhcRn))]+        -> rho_type+        -> TcM [LStmt GhcTcId (Located (body GhcTcId))]+tcStmts ctxt stmt_chk stmts res_ty+  = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $+                        const (return ())+       ; return stmts' }++tcStmtsAndThen :: (Outputable (body GhcRn)) => HsStmtContext Name+               -> TcStmtChecker body rho_type    -- NB: higher-rank type+               -> [LStmt GhcRn (Located (body GhcRn))]+               -> rho_type+               -> (rho_type -> TcM thing)+               -> TcM ([LStmt GhcTcId (Located (body GhcTcId))], thing)++-- Note the higher-rank type.  stmt_chk is applied at different+-- types in the equations for tcStmts++tcStmtsAndThen _ _ [] res_ty thing_inside+  = do  { thing <- thing_inside res_ty+        ; return ([], thing) }++-- LetStmts are handled uniformly, regardless of context+tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x (L l binds)) : stmts)+                                                             res_ty thing_inside+  = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $+              tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside+        ; return (L loc (LetStmt x (L l binds')) : stmts', thing) }++-- Don't set the error context for an ApplicativeStmt.  It ought to be+-- possible to do this with a popErrCtxt in the tcStmt case for+-- ApplicativeStmt, but it did someting strange and broke a test (ado002).+tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside+  | ApplicativeStmt{} <- stmt+  = do  { (stmt', (stmts', thing)) <-+             stmt_chk ctxt stmt res_ty $ \ res_ty' ->+               tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $+                 thing_inside+        ; return (L loc stmt' : stmts', thing) }++  -- For the vanilla case, handle the location-setting part+  | otherwise+  = do  { (stmt', (stmts', thing)) <-+                setSrcSpan loc                              $+                addErrCtxt (pprStmtInCtxt ctxt stmt)        $+                stmt_chk ctxt stmt res_ty                   $ \ res_ty' ->+                popErrCtxt                                  $+                tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $+                thing_inside+        ; return (L loc stmt' : stmts', thing) }++---------------------------------------------------+--              Pattern guards+---------------------------------------------------++tcGuardStmt :: TcExprStmtChecker+tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside+  = do  { guard' <- tcMonoExpr guard (mkCheckExpType boolTy)+        ; thing  <- thing_inside res_ty+        ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) }++tcGuardStmt ctxt (BindStmt _ pat rhs _ _) res_ty thing_inside+  = do  { (rhs', rhs_ty) <- tcInferSigmaNC rhs+                                   -- Stmt has a context already+        ; (pat', thing)  <- tcPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)+                                    pat (mkCheckExpType rhs_ty) $+                            thing_inside res_ty+        ; return (mkTcBindStmt pat' rhs', thing) }++tcGuardStmt _ stmt _ _+  = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)+++---------------------------------------------------+--           List comprehensions+--               (no rebindable syntax)+---------------------------------------------------++-- Dealt with separately, rather than by tcMcStmt, because+--   a) We have special desugaring rules for list comprehensions,+--      which avoid creating intermediate lists.  They in turn+--      assume that the bind/return operations are the regular+--      polymorphic ones, and in particular don't have any+--      coercion matching stuff in them.  It's hard to avoid the+--      potential for non-trivial coercions in tcMcStmt++tcLcStmt :: TyCon       -- The list type constructor ([])+         -> TcExprStmtChecker++tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside+  = do { body' <- tcMonoExprNC body elt_ty+       ; thing <- thing_inside (panic "tcLcStmt: thing_inside")+       ; return (LastStmt x body' noret noSyntaxExpr, thing) }++-- A generator, pat <- rhs+tcLcStmt m_tc ctxt (BindStmt _ pat rhs _ _) elt_ty thing_inside+ = do   { pat_ty <- newFlexiTyVarTy liftedTypeKind+        ; rhs'   <- tcMonoExpr rhs (mkCheckExpType $ mkTyConApp m_tc [pat_ty])+        ; (pat', thing)  <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $+                            thing_inside elt_ty+        ; return (mkTcBindStmt pat' rhs', thing) }++-- A boolean guard+tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside+  = do  { rhs'  <- tcMonoExpr rhs (mkCheckExpType boolTy)+        ; thing <- thing_inside elt_ty+        ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) }++-- ParStmt: See notes with tcMcStmt+tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside+  = do  { (pairs', thing) <- loop bndr_stmts_s+        ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) }+  where+    -- loop :: [([LStmt GhcRn], [GhcRn])]+    --      -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)+    loop [] = do { thing <- thing_inside elt_ty+                 ; return ([], thing) }         -- matching in the branches++    loop (ParStmtBlock x stmts names _ : pairs)+      = do { (stmts', (ids, pairs', thing))+                <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->+                   do { ids <- tcLookupLocalIds names+                      ; (pairs', thing) <- loop pairs+                      ; return (ids, pairs', thing) }+           ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }+    loop (XParStmtBlock{}:_) = panic "tcLcStmt"++tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts+                              , trS_bndrs =  bindersMap+                              , trS_by = by, trS_using = using }) elt_ty thing_inside+  = do { let (bndr_names, n_bndr_names) = unzip bindersMap+             unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)+             -- The inner 'stmts' lack a LastStmt, so the element type+             --  passed in to tcStmtsAndThen is never looked at+       ; (stmts', (bndr_ids, by'))+            <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do+               { by' <- traverse tcInferSigma by+               ; bndr_ids <- tcLookupLocalIds bndr_names+               ; return (bndr_ids, by') }++       ; let m_app ty = mkTyConApp m_tc [ty]++       --------------- Typecheck the 'using' function -------------+       -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m      (ThenForm)+       --       :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c)))  (GroupForm)++         -- n_app :: Type -> Type   -- Wraps a 'ty' into '[ty]' for GroupForm+       ; let n_app = case form of+                       ThenForm -> (\ty -> ty)+                       _        -> m_app++             by_arrow :: Type -> Type     -- Wraps 'ty' to '(a->t) -> ty' if the By is present+             by_arrow = case by' of+                          Nothing       -> \ty -> ty+                          Just (_,e_ty) -> \ty -> (alphaTy `mkVisFunTy` e_ty) `mkVisFunTy` ty++             tup_ty        = mkBigCoreVarTupTy bndr_ids+             poly_arg_ty   = m_app alphaTy+             poly_res_ty   = m_app (n_app alphaTy)+             using_poly_ty = mkInvForAllTy alphaTyVar $+                             by_arrow $+                             poly_arg_ty `mkVisFunTy` poly_res_ty++       ; using' <- tcPolyExpr using using_poly_ty+       ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'++             -- 'stmts' returns a result of type (m1_ty tuple_ty),+             -- typically something like [(Int,Bool,Int)]+             -- We don't know what tuple_ty is yet, so we use a variable+       ; let mk_n_bndr :: Name -> TcId -> TcId+             mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))++             -- Ensure that every old binder of type `b` is linked up with its+             -- new binder which should have type `n b`+             -- See Note [GroupStmt binder map] in HsExpr+             n_bndr_ids  = zipWith mk_n_bndr n_bndr_names bndr_ids+             bindersMap' = bndr_ids `zip` n_bndr_ids++       -- Type check the thing in the environment with+       -- these new binders and return the result+       ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)++       ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'+                           , trS_by = fmap fst by', trS_using = final_using+                           , trS_ret = noSyntaxExpr+                           , trS_bind = noSyntaxExpr+                           , trS_fmap = noExpr+                           , trS_ext = unitTy+                           , trS_form = form }, thing) }++tcLcStmt _ _ stmt _ _+  = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)+++---------------------------------------------------+--           Monad comprehensions+--        (supports rebindable syntax)+---------------------------------------------------++tcMcStmt :: TcExprStmtChecker++tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside+  = do  { (body', return_op')+            <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $+               \ [a_ty] ->+               tcMonoExprNC body (mkCheckExpType a_ty)+        ; thing      <- thing_inside (panic "tcMcStmt: thing_inside")+        ; return (LastStmt x body' noret return_op', thing) }++-- Generators for monad comprehensions ( pat <- rhs )+--+--   [ body | q <- gen ]  ->  gen :: m a+--                            q   ::   a+--++tcMcStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside+           -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty+  = do  { ((rhs', pat', thing, new_res_ty), bind_op')+            <- tcSyntaxOp MCompOrigin bind_op+                          [SynRho, SynFun SynAny SynRho] res_ty $+               \ [rhs_ty, pat_ty, new_res_ty] ->+               do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)+                  ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat+                                           (mkCheckExpType pat_ty) $+                                     thing_inside (mkCheckExpType new_res_ty)+                  ; return (rhs', pat', thing, new_res_ty) }++        -- If (but only if) the pattern can fail, typecheck the 'fail' operator+        ; fail_op' <- tcMonadFailOp (MCompPatOrigin pat) pat' fail_op new_res_ty++        ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }++-- Boolean expressions.+--+--   [ body | stmts, expr ]  ->  expr :: m Bool+--+tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside+  = do  { -- Deal with rebindable syntax:+          --    guard_op :: test_ty -> rhs_ty+          --    then_op  :: rhs_ty -> new_res_ty -> res_ty+          -- Where test_ty is, for example, Bool+        ; ((thing, rhs', rhs_ty, guard_op'), then_op')+            <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $+               \ [rhs_ty, new_res_ty] ->+               do { (rhs', guard_op')+                      <- tcSyntaxOp MCompOrigin guard_op [SynAny]+                                    (mkCheckExpType rhs_ty) $+                         \ [test_ty] ->+                         tcMonoExpr rhs (mkCheckExpType test_ty)+                  ; thing <- thing_inside (mkCheckExpType new_res_ty)+                  ; return (thing, rhs', rhs_ty, guard_op') }+        ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) }++-- Grouping statements+--+--   [ body | stmts, then group by e using f ]+--     ->  e :: t+--         f :: forall a. (a -> t) -> m a -> m (m a)+--   [ body | stmts, then group using f ]+--     ->  f :: forall a. m a -> m (m a)++-- We type [ body | (stmts, group by e using f), ... ]+--     f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....+--+-- We type the functions as follows:+--     f <optional by> :: m1 (a,b,c) -> m2 (a,b,c)              (ThenForm)+--                     :: m1 (a,b,c) -> m2 (n (a,b,c))          (GroupForm)+--     (>>=) :: m2 (a,b,c)     -> ((a,b,c)   -> res) -> res     (ThenForm)+--           :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res     (GroupForm)+--+tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap+                         , trS_by = by, trS_using = using, trS_form = form+                         , trS_ret = return_op, trS_bind = bind_op+                         , trS_fmap = fmap_op }) res_ty thing_inside+  = do { let star_star_kind = liftedTypeKind `mkVisFunTy` liftedTypeKind+       ; m1_ty   <- newFlexiTyVarTy star_star_kind+       ; m2_ty   <- newFlexiTyVarTy star_star_kind+       ; tup_ty  <- newFlexiTyVarTy liftedTypeKind+       ; by_e_ty <- newFlexiTyVarTy liftedTypeKind  -- The type of the 'by' expression (if any)++         -- n_app :: Type -> Type   -- Wraps a 'ty' into '(n ty)' for GroupForm+       ; n_app <- case form of+                    ThenForm -> return (\ty -> ty)+                    _        -> do { n_ty <- newFlexiTyVarTy star_star_kind+                                   ; return (n_ty `mkAppTy`) }+       ; let by_arrow :: Type -> Type+             -- (by_arrow res) produces ((alpha->e_ty) -> res)     ('by' present)+             --                          or res                    ('by' absent)+             by_arrow = case by of+                          Nothing -> \res -> res+                          Just {} -> \res -> (alphaTy `mkVisFunTy` by_e_ty) `mkVisFunTy` res++             poly_arg_ty  = m1_ty `mkAppTy` alphaTy+             using_arg_ty = m1_ty `mkAppTy` tup_ty+             poly_res_ty  = m2_ty `mkAppTy` n_app alphaTy+             using_res_ty = m2_ty `mkAppTy` n_app tup_ty+             using_poly_ty = mkInvForAllTy alphaTyVar $+                             by_arrow $+                             poly_arg_ty `mkVisFunTy` poly_res_ty++             -- 'stmts' returns a result of type (m1_ty tuple_ty),+             -- typically something like [(Int,Bool,Int)]+             -- We don't know what tuple_ty is yet, so we use a variable+       ; let (bndr_names, n_bndr_names) = unzip bindersMap+       ; (stmts', (bndr_ids, by', return_op')) <-+            tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts+                           (mkCheckExpType using_arg_ty) $ \res_ty' -> do+                { by' <- case by of+                           Nothing -> return Nothing+                           Just e  -> do { e' <- tcMonoExpr e+                                                   (mkCheckExpType by_e_ty)+                                         ; return (Just e') }++                -- Find the Ids (and hence types) of all old binders+                ; bndr_ids <- tcLookupLocalIds bndr_names++                -- 'return' is only used for the binders, so we know its type.+                --   return :: (a,b,c,..) -> m (a,b,c,..)+                ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op+                                       [synKnownType (mkBigCoreVarTupTy bndr_ids)]+                                       res_ty' $ \ _ -> return ()++                ; return (bndr_ids, by', return_op') }++       --------------- Typecheck the 'bind' function -------------+       -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty+       ; new_res_ty <- newFlexiTyVarTy liftedTypeKind+       ; (_, bind_op')  <- tcSyntaxOp MCompOrigin bind_op+                             [ synKnownType using_res_ty+                             , synKnownType (n_app tup_ty `mkVisFunTy` new_res_ty) ]+                             res_ty $ \ _ -> return ()++       --------------- Typecheck the 'fmap' function -------------+       ; fmap_op' <- case form of+                       ThenForm -> return noExpr+                       _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $+                            mkInvForAllTy alphaTyVar $+                            mkInvForAllTy betaTyVar  $+                            (alphaTy `mkVisFunTy` betaTy)+                            `mkVisFunTy` (n_app alphaTy)+                            `mkVisFunTy` (n_app betaTy)++       --------------- Typecheck the 'using' function -------------+       -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))++       ; using' <- tcPolyExpr using using_poly_ty+       ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'++       --------------- Bulding the bindersMap ----------------+       ; let mk_n_bndr :: Name -> TcId -> TcId+             mk_n_bndr n_bndr_name bndr_id = mkLocalIdOrCoVar n_bndr_name (n_app (idType bndr_id))++             -- Ensure that every old binder of type `b` is linked up with its+             -- new binder which should have type `n b`+             -- See Note [GroupStmt binder map] in HsExpr+             n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids+             bindersMap' = bndr_ids `zip` n_bndr_ids++       -- Type check the thing in the environment with+       -- these new binders and return the result+       ; thing <- tcExtendIdEnv n_bndr_ids $+                  thing_inside (mkCheckExpType new_res_ty)++       ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'+                           , trS_by = by', trS_using = final_using+                           , trS_ret = return_op', trS_bind = bind_op'+                           , trS_ext = n_app tup_ty+                           , trS_fmap = fmap_op', trS_form = form }, thing) }++-- A parallel set of comprehensions+--      [ (g x, h x) | ... ; let g v = ...+--                   | ... ; let h v = ... ]+--+-- It's possible that g,h are overloaded, so we need to feed the LIE from the+-- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).+-- Similarly if we had an existential pattern match:+--+--      data T = forall a. Show a => C a+--+--      [ (show x, show y) | ... ; C x <- ...+--                         | ... ; C y <- ... ]+--+-- Then we need the LIE from (show x, show y) to be simplified against+-- the bindings for x and y.+--+-- It's difficult to do this in parallel, so we rely on the renamer to+-- ensure that g,h and x,y don't duplicate, and simply grow the environment.+-- So the binders of the first parallel group will be in scope in the second+-- group.  But that's fine; there's no shadowing to worry about.+--+-- Note: The `mzip` function will get typechecked via:+--+--   ParStmt [st1::t1, st2::t2, st3::t3]+--+--   mzip :: m st1+--        -> (m st2 -> m st3 -> m (st2, st3))   -- recursive call+--        -> m (st1, (st2, st3))+--+tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside+  = do { let star_star_kind = liftedTypeKind `mkVisFunTy` liftedTypeKind+       ; m_ty   <- newFlexiTyVarTy star_star_kind++       ; let mzip_ty  = mkInvForAllTys [alphaTyVar, betaTyVar] $+                        (m_ty `mkAppTy` alphaTy)+                        `mkVisFunTy`+                        (m_ty `mkAppTy` betaTy)+                        `mkVisFunTy`+                        (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])+       ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty++        -- type dummies since we don't know all binder types yet+       ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))+                       [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ]++       -- Typecheck bind:+       ; let tup_tys  = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]+             tuple_ty = mk_tuple_ty tup_tys++       ; (((blocks', thing), inner_res_ty), bind_op')+           <- tcSyntaxOp MCompOrigin bind_op+                         [ synKnownType (m_ty `mkAppTy` tuple_ty)+                         , SynFun (synKnownType tuple_ty) SynRho ] res_ty $+              \ [inner_res_ty] ->+              do { stuff <- loop m_ty (mkCheckExpType inner_res_ty)+                                 tup_tys bndr_stmts_s+                 ; return (stuff, inner_res_ty) }++       ; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) }++  where+    mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys++       -- loop :: Type                                  -- m_ty+       --      -> ExpRhoType                            -- inner_res_ty+       --      -> [TcType]                              -- tup_tys+       --      -> [ParStmtBlock Name]+       --      -> TcM ([([LStmt GhcTcId], [GhcTcId])], thing)+    loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty+                                   ; return ([], thing) }+                                   -- matching in the branches++    loop m_ty inner_res_ty (tup_ty_in : tup_tys_in)+                           (ParStmtBlock x stmts names return_op : pairs)+      = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in+           ; (stmts', (ids, return_op', pairs', thing))+                <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $+                   \m_tup_ty' ->+                   do { ids <- tcLookupLocalIds names+                      ; let tup_ty = mkBigCoreVarTupTy ids+                      ; (_, return_op') <-+                          tcSyntaxOp MCompOrigin return_op+                                     [synKnownType tup_ty] m_tup_ty' $+                                     \ _ -> return ()+                      ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs+                      ; return (ids, return_op', pairs', thing) }+           ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) }+    loop _ _ _ _ = panic "tcMcStmt.loop"++tcMcStmt _ stmt _ _+  = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)+++---------------------------------------------------+--           Do-notation+--        (supports rebindable syntax)+---------------------------------------------------++tcDoStmt :: TcExprStmtChecker++tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside+  = do { body' <- tcMonoExprNC body res_ty+       ; thing <- thing_inside (panic "tcDoStmt: thing_inside")+       ; return (LastStmt x body' noret noSyntaxExpr, thing) }++tcDoStmt ctxt (BindStmt _ pat rhs bind_op fail_op) res_ty thing_inside+  = do  {       -- Deal with rebindable syntax:+                --       (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty+                -- This level of generality is needed for using do-notation+                -- in full generality; see #1537++          ((rhs', pat', new_res_ty, thing), bind_op')+            <- tcSyntaxOp DoOrigin bind_op [SynRho, SynFun SynAny SynRho] res_ty $+                \ [rhs_ty, pat_ty, new_res_ty] ->+                do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)+                   ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat+                                            (mkCheckExpType pat_ty) $+                                      thing_inside (mkCheckExpType new_res_ty)+                   ; return (rhs', pat', new_res_ty, thing) }++        -- If (but only if) the pattern can fail, typecheck the 'fail' operator+        ; fail_op' <- tcMonadFailOp (DoPatOrigin pat) pat' fail_op new_res_ty++        ; return (BindStmt new_res_ty pat' rhs' bind_op' fail_op', thing) }++tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside+  = do  { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $+                                thing_inside . mkCheckExpType+        ; ((pairs', body_ty, thing), mb_join') <- case mb_join of+            Nothing -> (, Nothing) <$> tc_app_stmts res_ty+            Just join_op ->+              second Just <$>+              (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $+               \ [rhs_ty] -> tc_app_stmts (mkCheckExpType rhs_ty))++        ; return (ApplicativeStmt body_ty pairs' mb_join', thing) }++tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside+  = do  {       -- Deal with rebindable syntax;+                --   (>>) :: rhs_ty -> new_res_ty -> res_ty+        ; ((rhs', rhs_ty, thing), then_op')+            <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $+               \ [rhs_ty, new_res_ty] ->+               do { rhs' <- tcMonoExprNC rhs (mkCheckExpType rhs_ty)+                  ; thing <- thing_inside (mkCheckExpType new_res_ty)+                  ; return (rhs', rhs_ty, thing) }+        ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) }++tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names+                       , recS_rec_ids = rec_names, recS_ret_fn = ret_op+                       , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })+         res_ty thing_inside+  = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names+        ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind+        ; let tup_ids = zipWith mkLocalId tup_names tup_elt_tys+              tup_ty  = mkBigCoreTupTy tup_elt_tys++        ; tcExtendIdEnv tup_ids $ do+        { ((stmts', (ret_op', tup_rets)), stmts_ty)+                <- tcInferInst $ \ exp_ty ->+                   tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty ->+                   do { tup_rets <- zipWithM tcCheckId tup_names+                                      (map mkCheckExpType tup_elt_tys)+                             -- Unify the types of the "final" Ids (which may+                             -- be polymorphic) with those of "knot-tied" Ids+                      ; (_, ret_op')+                          <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty]+                                        inner_res_ty $ \_ -> return ()+                      ; return (ret_op', tup_rets) }++        ; ((_, mfix_op'), mfix_res_ty)+            <- tcInferInst $ \ exp_ty ->+               tcSyntaxOp DoOrigin mfix_op+                          [synKnownType (mkVisFunTy tup_ty stmts_ty)] exp_ty $+               \ _ -> return ()++        ; ((thing, new_res_ty), bind_op')+            <- tcSyntaxOp DoOrigin bind_op+                          [ synKnownType mfix_res_ty+                          , synKnownType tup_ty `SynFun` SynRho ]+                          res_ty $+               \ [new_res_ty] ->+               do { thing <- thing_inside (mkCheckExpType new_res_ty)+                  ; return (thing, new_res_ty) }++        ; let rec_ids = takeList rec_names tup_ids+        ; later_ids <- tcLookupLocalIds later_names+        ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),+                                 ppr later_ids <+> ppr (map idType later_ids)]+        ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids+                          , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'+                          , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'+                          , recS_ext = RecStmtTc+                            { recS_bind_ty = new_res_ty+                            , recS_later_rets = []+                            , recS_rec_rets = tup_rets+                            , recS_ret_ty = stmts_ty} }, thing)+        }}++tcDoStmt _ stmt _ _+  = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)++++---------------------------------------------------+-- MonadFail Proposal warnings+---------------------------------------------------++-- The idea behind issuing MonadFail warnings is that we add them whenever a+-- failable pattern is encountered. However, instead of throwing a type error+-- when the constraint cannot be satisfied, we only issue a warning in+-- TcErrors.hs.++tcMonadFailOp :: CtOrigin+              -> LPat GhcTcId+              -> SyntaxExpr GhcRn    -- The fail op+              -> TcType              -- Type of the whole do-expression+              -> TcRn (SyntaxExpr GhcTcId)  -- Typechecked fail op+-- Get a 'fail' operator expression, to use if the pattern+-- match fails. If the pattern is irrefutatable, just return+-- noSyntaxExpr; it won't be used+tcMonadFailOp orig pat fail_op res_ty+  | isIrrefutableHsPat pat+  = return noSyntaxExpr++  | otherwise+  = snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]+                             (mkCheckExpType res_ty) $ \_ -> return ())++{-+Note [Treat rebindable syntax first]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When typechecking+        do { bar; ... } :: IO ()+we want to typecheck 'bar' in the knowledge that it should be an IO thing,+pushing info from the context into the RHS.  To do this, we check the+rebindable syntax first, and push that information into (tcMonoExprNC rhs).+Otherwise the error shows up when checking the rebindable syntax, and+the expected/inferred stuff is back to front (see #3613).++Note [typechecking ApplicativeStmt]++join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en)++fresh type variables:+   pat_ty_1..pat_ty_n+   exp_ty_1..exp_ty_n+   t_1..t_(n-1)++body  :: body_ty+(\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty+pat_i :: pat_ty_i+e_i   :: exp_ty_i+<$>   :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1+<*>_i :: t_(i-1) -> exp_ty_i -> t_i+join :: tn -> res_ty+-}++tcApplicativeStmts+  :: HsStmtContext Name+  -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]+  -> ExpRhoType                         -- rhs_ty+  -> (TcRhoType -> TcM t)               -- thing_inside+  -> TcM ([(SyntaxExpr GhcTcId, ApplicativeArg GhcTcId)], Type, t)++tcApplicativeStmts ctxt pairs rhs_ty thing_inside+ = do { body_ty <- newFlexiTyVarTy liftedTypeKind+      ; let arity = length pairs+      ; ts <- replicateM (arity-1) $ newInferExpTypeInst+      ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind+      ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind+      ; let fun_ty = mkVisFunTys pat_tys body_ty++       -- NB. do the <$>,<*> operators first, we don't want type errors here+       --     i.e. goOps before goArgs+       -- See Note [Treat rebindable syntax first]+      ; let (ops, args) = unzip pairs+      ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)++      -- Typecheck each ApplicativeArg separately+      -- See Note [ApplicativeDo and constraints]+      ; args' <- mapM goArg (zip3 args pat_tys exp_tys)++      -- Bring into scope all the things bound by the args,+      -- and typecheck the thing_inside+      -- See Note [ApplicativeDo and constraints]+      ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $+               thing_inside body_ty++      ; return (zip ops' args', body_ty, res) }+  where+    goOps _ [] = return []+    goOps t_left ((op,t_i,exp_ty) : ops)+      = do { (_, op')+               <- tcSyntaxOp DoOrigin op+                             [synKnownType t_left, synKnownType exp_ty] t_i $+                   \ _ -> return ()+           ; t_i <- readExpType t_i+           ; ops' <- goOps t_i ops+           ; return (op' : ops') }++    goArg :: (ApplicativeArg GhcRn, Type, Type)+          -> TcM (ApplicativeArg GhcTcId)++    goArg (ApplicativeArgOne x pat rhs isBody, pat_ty, exp_ty)+      = setSrcSpan (combineSrcSpans (getLoc pat) (getLoc rhs)) $+        addErrCtxt (pprStmtInCtxt ctxt (mkBindStmt pat rhs))   $+        do { rhs' <- tcMonoExprNC rhs (mkCheckExpType exp_ty)+           ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $+                          return ()+           ; return (ApplicativeArgOne x pat' rhs' isBody) }++    goArg (ApplicativeArgMany x stmts ret pat, pat_ty, exp_ty)+      = do { (stmts', (ret',pat')) <-+                tcStmtsAndThen ctxt tcDoStmt stmts (mkCheckExpType exp_ty) $+                \res_ty  -> do+                  { L _ ret' <- tcMonoExprNC (noLoc ret) res_ty+                  ; (pat', _) <- tcPat (StmtCtxt ctxt) pat (mkCheckExpType pat_ty) $+                                 return ()+                  ; return (ret', pat')+                  }+           ; return (ApplicativeArgMany x stmts' ret' pat') }++    goArg (XApplicativeArg _, _, _) = panic "tcApplicativeStmts"++    get_arg_bndrs :: ApplicativeArg GhcTcId -> [Id]+    get_arg_bndrs (ApplicativeArgOne _ pat _ _)  = collectPatBinders pat+    get_arg_bndrs (ApplicativeArgMany _ _ _ pat) = collectPatBinders pat+    get_arg_bndrs (XApplicativeArg _)            = panic "tcApplicativeStmts"+++{- Note [ApplicativeDo and constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An applicative-do is supposed to take place in parallel, so+constraints bound in one arm can't possibly be available in another+(#13242).  Our current rule is this (more details and discussion+on the ticket). Consider++   ...stmts...+   ApplicativeStmts [arg1, arg2, ... argN]+   ...more stmts...++where argi :: ApplicativeArg. Each 'argi' itself contains one or more Stmts.+Now, we say that:++* Constraints required by the argi can be solved from+  constraint bound by ...stmts...++* Constraints and existentials bound by the argi are not available+  to solve constraints required either by argj (where i /= j),+  or by ...more stmts....++* Within the stmts of each 'argi' individually, however, constraints bound+  by earlier stmts can be used to solve later ones.++To achieve this, we just typecheck each 'argi' separately, bring all+the variables they bind into scope, and typecheck the thing_inside.++************************************************************************+*                                                                      *+\subsection{Errors and contexts}+*                                                                      *+************************************************************************++@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same+number of args are used in each equation.+-}++checkArgs :: Name -> MatchGroup GhcRn body -> TcM ()+checkArgs _ (MG { mg_alts = L _ [] })+    = return ()+checkArgs fun (MG { mg_alts = L _ (match1:matches) })+    | null bad_matches+    = return ()+    | otherwise+    = failWithTc (vcat [ text "Equations for" <+> quotes (ppr fun) <+>+                         text "have different numbers of arguments"+                       , nest 2 (ppr (getLoc match1))+                       , nest 2 (ppr (getLoc (head bad_matches)))])+  where+    n_args1 = args_in_match match1+    bad_matches = [m | m <- matches, args_in_match m /= n_args1]++    args_in_match :: LMatch GhcRn body -> Int+    args_in_match (L _ (Match { m_pats = pats })) = length pats+    args_in_match (L _ (XMatch _)) = panic "checkArgs"+checkArgs _ (XMatchGroup{}) = panic "checkArgs"
+ compiler/typecheck/TcMatches.hs-boot view
@@ -0,0 +1,17 @@+module TcMatches where+import HsSyn    ( GRHSs, MatchGroup, LHsExpr )+import TcEvidence( HsWrapper )+import Name     ( Name )+import TcType   ( ExpRhoType, TcRhoType )+import TcRnTypes( TcM )+import SrcLoc   ( Located )+import HsExtension ( GhcRn, GhcTcId )++tcGRHSsPat    :: GRHSs GhcRn (LHsExpr GhcRn)+              -> TcRhoType+              -> TcM (GRHSs GhcTcId (LHsExpr GhcTcId))++tcMatchesFun :: Located Name+             -> MatchGroup GhcRn (LHsExpr GhcRn)+             -> ExpRhoType+             -> TcM (HsWrapper, MatchGroup GhcTcId (LHsExpr GhcTcId))
+ compiler/typecheck/TcPat.hs view
@@ -0,0 +1,1193 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++TcPat: Typechecking patterns+-}++{-# LANGUAGE CPP, RankNTypes, TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module TcPat ( tcLetPat, newLetBndr, LetBndrSpec(..)+             , tcPat, tcPat_O, tcPats+             , addDataConStupidTheta, badFieldCon, polyPatSig ) where++#include "HsVersions.h"++import GhcPrelude++import {-# SOURCE #-}   TcExpr( tcSyntaxOp, tcSyntaxOpGen, tcInferSigma )++import HsSyn+import TcHsSyn+import TcSigs( TcPragEnv, lookupPragEnv, addInlinePrags )+import TcRnMonad+import Inst+import Id+import Var+import Name+import RdrName+import TcEnv+import TcMType+import TcValidity( arityErr )+import Type ( pprTyVars )+import TcType+import TcUnify+import TcHsType+import TysWiredIn+import TcEvidence+import TyCon+import DataCon+import PatSyn+import ConLike+import PrelNames+import BasicTypes hiding (SuccessFlag(..))+import DynFlags+import SrcLoc+import VarSet+import Util+import Outputable+import qualified GHC.LanguageExtensions as LangExt+import Control.Arrow  ( second )+import ListSetOps ( getNth )++{-+************************************************************************+*                                                                      *+                External interface+*                                                                      *+************************************************************************+-}++tcLetPat :: (Name -> Maybe TcId)+         -> LetBndrSpec+         -> LPat GhcRn -> ExpSigmaType+         -> TcM a+         -> TcM (LPat GhcTcId, a)+tcLetPat sig_fn no_gen pat pat_ty thing_inside+  = do { bind_lvl <- getTcLevel+       ; let ctxt = LetPat { pc_lvl    = bind_lvl+                           , pc_sig_fn = sig_fn+                           , pc_new    = no_gen }+             penv = PE { pe_lazy = True+                       , pe_ctxt = ctxt+                       , pe_orig = PatOrigin }++       ; tc_lpat pat pat_ty penv thing_inside }++-----------------+tcPats :: HsMatchContext Name+       -> [LPat GhcRn]            -- Patterns,+       -> [ExpSigmaType]         --   and their types+       -> TcM a                  --   and the checker for the body+       -> TcM ([LPat GhcTcId], a)++-- This is the externally-callable wrapper function+-- Typecheck the patterns, extend the environment to bind the variables,+-- do the thing inside, use any existentially-bound dictionaries to+-- discharge parts of the returning LIE, and deal with pattern type+-- signatures++--   1. Initialise the PatState+--   2. Check the patterns+--   3. Check the body+--   4. Check that no existentials escape++tcPats ctxt pats pat_tys thing_inside+  = tc_lpats penv pats pat_tys thing_inside+  where+    penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }++tcPat :: HsMatchContext Name+      -> LPat GhcRn -> ExpSigmaType+      -> TcM a                     -- Checker for body+      -> TcM (LPat GhcTcId, a)+tcPat ctxt = tcPat_O ctxt PatOrigin++-- | A variant of 'tcPat' that takes a custom origin+tcPat_O :: HsMatchContext Name+        -> CtOrigin              -- ^ origin to use if the type needs inst'ing+        -> LPat GhcRn -> ExpSigmaType+        -> TcM a                 -- Checker for body+        -> TcM (LPat GhcTcId, a)+tcPat_O ctxt orig pat pat_ty thing_inside+  = tc_lpat pat pat_ty penv thing_inside+  where+    penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = orig }+++{-+************************************************************************+*                                                                      *+                PatEnv, PatCtxt, LetBndrSpec+*                                                                      *+************************************************************************+-}++data PatEnv+  = PE { pe_lazy :: Bool        -- True <=> lazy context, so no existentials allowed+       , pe_ctxt :: PatCtxt     -- Context in which the whole pattern appears+       , pe_orig :: CtOrigin    -- origin to use if the pat_ty needs inst'ing+       }++data PatCtxt+  = LamPat   -- Used for lambdas, case etc+       (HsMatchContext Name)++  | LetPat   -- Used only for let(rec) pattern bindings+             -- See Note [Typing patterns in pattern bindings]+       { pc_lvl    :: TcLevel+                   -- Level of the binding group++       , pc_sig_fn :: Name -> Maybe TcId+                   -- Tells the expected type+                   -- for binders with a signature++       , pc_new :: LetBndrSpec+                -- How to make a new binder+       }        -- for binders without signatures++data LetBndrSpec+  = LetLclBndr            -- We are going to generalise, and wrap in an AbsBinds+                          -- so clone a fresh binder for the local monomorphic Id++  | LetGblBndr TcPragEnv  -- Generalisation plan is NoGen, so there isn't going+                          -- to be an AbsBinds; So we must bind the global version+                          -- of the binder right away.+                          -- And here is the inline-pragma information++instance Outputable LetBndrSpec where+  ppr LetLclBndr      = text "LetLclBndr"+  ppr (LetGblBndr {}) = text "LetGblBndr"++makeLazy :: PatEnv -> PatEnv+makeLazy penv = penv { pe_lazy = True }++inPatBind :: PatEnv -> Bool+inPatBind (PE { pe_ctxt = LetPat {} }) = True+inPatBind (PE { pe_ctxt = LamPat {} }) = False++{- *********************************************************************+*                                                                      *+                Binders+*                                                                      *+********************************************************************* -}++tcPatBndr :: PatEnv -> Name -> ExpSigmaType -> TcM (HsWrapper, TcId)+-- (coi, xp) = tcPatBndr penv x pat_ty+-- Then coi : pat_ty ~ typeof(xp)+--+tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl    = bind_lvl+                                      , pc_sig_fn = sig_fn+                                      , pc_new    = no_gen } })+          bndr_name exp_pat_ty+  -- For the LetPat cases, see+  -- Note [Typechecking pattern bindings] in TcBinds++  | Just bndr_id <- sig_fn bndr_name   -- There is a signature+  = do { wrap <- tcSubTypePat penv exp_pat_ty (idType bndr_id)+           -- See Note [Subsumption check at pattern variables]+       ; traceTc "tcPatBndr(sig)" (ppr bndr_id $$ ppr (idType bndr_id) $$ ppr exp_pat_ty)+       ; return (wrap, bndr_id) }++  | otherwise                          -- No signature+  = do { (co, bndr_ty) <- case exp_pat_ty of+             Check pat_ty    -> promoteTcType bind_lvl pat_ty+             Infer infer_res -> ASSERT( bind_lvl == ir_lvl infer_res )+                                -- If we were under a constructor that bumped+                                -- the level, we'd be in checking mode+                                do { bndr_ty <- inferResultToType infer_res+                                   ; return (mkTcNomReflCo bndr_ty, bndr_ty) }+       ; bndr_id <- newLetBndr no_gen bndr_name bndr_ty+       ; traceTc "tcPatBndr(nosig)" (vcat [ ppr bind_lvl+                                          , ppr exp_pat_ty, ppr bndr_ty, ppr co+                                          , ppr bndr_id ])+       ; return (mkWpCastN co, bndr_id) }++tcPatBndr _ bndr_name pat_ty+  = do { pat_ty <- expTypeToType pat_ty+       ; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty)+       ; return (idHsWrapper, mkLocalId bndr_name pat_ty) }+               -- Whether or not there is a sig is irrelevant,+               -- as this is local++newLetBndr :: LetBndrSpec -> Name -> TcType -> TcM TcId+-- Make up a suitable Id for the pattern-binder.+-- See Note [Typechecking pattern bindings], item (4) in TcBinds+--+-- In the polymorphic case when we are going to generalise+--    (plan InferGen, no_gen = LetLclBndr), generate a "monomorphic version"+--    of the Id; the original name will be bound to the polymorphic version+--    by the AbsBinds+-- In the monomorphic case when we are not going to generalise+--    (plan NoGen, no_gen = LetGblBndr) there is no AbsBinds,+--    and we use the original name directly+newLetBndr LetLclBndr name ty+  = do { mono_name <- cloneLocalName name+       ; return (mkLocalId mono_name ty) }+newLetBndr (LetGblBndr prags) name ty+  = addInlinePrags (mkLocalId name ty) (lookupPragEnv prags name)++tcSubTypePat :: PatEnv -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper+-- tcSubTypeET with the UserTypeCtxt specialised to GenSigCtxt+-- Used when typechecking patterns+tcSubTypePat penv t1 t2 = tcSubTypeET (pe_orig penv) GenSigCtxt t1 t2++{- Note [Subsumption check at pattern variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we come across a variable with a type signature, we need to do a+subsumption, not equality, check against the context type.  e.g.++    data T = MkT (forall a. a->a)+      f :: forall b. [b]->[b]+      MkT f = blah++Since 'blah' returns a value of type T, its payload is a polymorphic+function of type (forall a. a->a).  And that's enough to bind the+less-polymorphic function 'f', but we need some impedance matching+to witness the instantiation.+++************************************************************************+*                                                                      *+                The main worker functions+*                                                                      *+************************************************************************++Note [Nesting]+~~~~~~~~~~~~~~+tcPat takes a "thing inside" over which the pattern scopes.  This is partly+so that tcPat can extend the environment for the thing_inside, but also+so that constraints arising in the thing_inside can be discharged by the+pattern.++This does not work so well for the ErrCtxt carried by the monad: we don't+want the error-context for the pattern to scope over the RHS.+Hence the getErrCtxt/setErrCtxt stuff in tcMultiple+-}++--------------------+type Checker inp out =  forall r.+                          inp+                       -> PatEnv+                       -> TcM r+                       -> TcM (out, r)++tcMultiple :: Checker inp out -> Checker [inp] [out]+tcMultiple tc_pat args penv thing_inside+  = do  { err_ctxt <- getErrCtxt+        ; let loop _ []+                = do { res <- thing_inside+                     ; return ([], res) }++              loop penv (arg:args)+                = do { (p', (ps', res))+                                <- tc_pat arg penv $+                                   setErrCtxt err_ctxt $+                                   loop penv args+                -- setErrCtxt: restore context before doing the next pattern+                -- See note [Nesting] above++                     ; return (p':ps', res) }++        ; loop penv args }++--------------------+tc_lpat :: LPat GhcRn+        -> ExpSigmaType+        -> PatEnv+        -> TcM a+        -> TcM (LPat GhcTcId, a)+tc_lpat (dL->L span pat) pat_ty penv thing_inside+  = setSrcSpan span $+    do  { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty)+                                          thing_inside+        ; return (cL span pat', res) }++tc_lpats :: PatEnv+         -> [LPat GhcRn] -> [ExpSigmaType]+         -> TcM a+         -> TcM ([LPat GhcTcId], a)+tc_lpats penv pats tys thing_inside+  = ASSERT2( equalLength pats tys, ppr pats $$ ppr tys )+    tcMultiple (\(p,t) -> tc_lpat p t)+                (zipEqual "tc_lpats" pats tys)+                penv thing_inside++--------------------+tc_pat  :: PatEnv+        -> Pat GhcRn+        -> ExpSigmaType  -- Fully refined result type+        -> TcM a                -- Thing inside+        -> TcM (Pat GhcTcId,    -- Translated pattern+                a)              -- Result of thing inside++tc_pat penv (VarPat x (dL->L l name)) pat_ty thing_inside+  = do  { (wrap, id) <- tcPatBndr penv name pat_ty+        ; res <- tcExtendIdEnv1 name id thing_inside+        ; pat_ty <- readExpType pat_ty+        ; return (mkHsWrapPat wrap (VarPat x (cL l id)) pat_ty, res) }++tc_pat penv (ParPat x pat) pat_ty thing_inside+  = do  { (pat', res) <- tc_lpat pat pat_ty penv thing_inside+        ; return (ParPat x pat', res) }++tc_pat penv (BangPat x pat) pat_ty thing_inside+  = do  { (pat', res) <- tc_lpat pat pat_ty penv thing_inside+        ; return (BangPat x pat', res) }++tc_pat penv (LazyPat x pat) pat_ty thing_inside+  = do  { (pat', (res, pat_ct))+                <- tc_lpat pat pat_ty (makeLazy penv) $+                   captureConstraints thing_inside+                -- Ignore refined penv', revert to penv++        ; emitConstraints pat_ct+        -- captureConstraints/extendConstraints:+        --   see Note [Hopping the LIE in lazy patterns]++        -- Check that the expected pattern type is itself lifted+        ; pat_ty <- readExpType pat_ty+        ; _ <- unifyType Nothing (tcTypeKind pat_ty) liftedTypeKind++        ; return (LazyPat x pat', res) }++tc_pat _ (WildPat _) pat_ty thing_inside+  = do  { res <- thing_inside+        ; pat_ty <- expTypeToType pat_ty+        ; return (WildPat pat_ty, res) }++tc_pat penv (AsPat x (dL->L nm_loc name) pat) pat_ty thing_inside+  = do  { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty)+        ; (pat', res) <- tcExtendIdEnv1 name bndr_id $+                         tc_lpat pat (mkCheckExpType $ idType bndr_id)+                                 penv thing_inside+            -- NB: if we do inference on:+            --          \ (y@(x::forall a. a->a)) = e+            -- we'll fail.  The as-pattern infers a monotype for 'y', which then+            -- fails to unify with the polymorphic type for 'x'.  This could+            -- perhaps be fixed, but only with a bit more work.+            --+            -- If you fix it, don't forget the bindInstsOfPatIds!+        ; pat_ty <- readExpType pat_ty+        ; return (mkHsWrapPat wrap (AsPat x (cL nm_loc bndr_id) pat') pat_ty,+                  res) }++tc_pat penv (ViewPat _ expr pat) overall_pat_ty thing_inside+  = do  {+         -- Expr must have type `forall a1...aN. OPT' -> B`+         -- where overall_pat_ty is an instance of OPT'.+        ; (expr',expr'_inferred) <- tcInferSigma expr++         -- expression must be a function+        ; let expr_orig = lexprCtOrigin expr+              herald    = text "A view pattern expression expects"+        ; (expr_wrap1, [inf_arg_ty], inf_res_ty)+            <- matchActualFunTys herald expr_orig (Just (unLoc expr)) 1 expr'_inferred+            -- expr_wrap1 :: expr'_inferred "->" (inf_arg_ty -> inf_res_ty)++         -- check that overall pattern is more polymorphic than arg type+        ; expr_wrap2 <- tcSubTypePat penv overall_pat_ty inf_arg_ty+            -- expr_wrap2 :: overall_pat_ty "->" inf_arg_ty++         -- pattern must have inf_res_ty+        ; (pat', res) <- tc_lpat pat (mkCheckExpType inf_res_ty) penv thing_inside++        ; overall_pat_ty <- readExpType overall_pat_ty+        ; let expr_wrap2' = mkWpFun expr_wrap2 idHsWrapper+                                    overall_pat_ty inf_res_ty doc+               -- expr_wrap2' :: (inf_arg_ty -> inf_res_ty) "->"+               --                (overall_pat_ty -> inf_res_ty)+              expr_wrap = expr_wrap2' <.> expr_wrap1+              doc = text "When checking the view pattern function:" <+> (ppr expr)+        ; return (ViewPat overall_pat_ty (mkLHsWrap expr_wrap expr') pat', res)}++-- Type signatures in patterns+-- See Note [Pattern coercions] below+tc_pat penv (SigPat _ pat sig_ty) pat_ty thing_inside+  = do  { (inner_ty, tv_binds, wcs, wrap) <- tcPatSig (inPatBind penv)+                                                            sig_ty pat_ty+                -- Using tcExtendNameTyVarEnv is appropriate here+                -- because we're not really bringing fresh tyvars into scope.+                -- We're *naming* existing tyvars. Note that it is OK for a tyvar+                -- from an outer scope to mention one of these tyvars in its kind.+        ; (pat', res) <- tcExtendNameTyVarEnv wcs      $+                         tcExtendNameTyVarEnv tv_binds $+                         tc_lpat pat (mkCheckExpType inner_ty) penv thing_inside+        ; pat_ty <- readExpType pat_ty+        ; return (mkHsWrapPat wrap (SigPat inner_ty pat' sig_ty) pat_ty, res) }++------------------------+-- Lists, tuples, arrays+tc_pat penv (ListPat Nothing pats) pat_ty thing_inside+  = do  { (coi, elt_ty) <- matchExpectedPatTy matchExpectedListTy penv pat_ty+        ; (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))+                                     pats penv thing_inside+        ; pat_ty <- readExpType pat_ty+        ; return (mkHsWrapPat coi+                         (ListPat (ListPatTc elt_ty Nothing) pats') pat_ty, res)+}++tc_pat penv (ListPat (Just e) pats) pat_ty thing_inside+  = do  { tau_pat_ty <- expTypeToType pat_ty+        ; ((pats', res, elt_ty), e')+            <- tcSyntaxOpGen ListOrigin e [SynType (mkCheckExpType tau_pat_ty)]+                                          SynList $+                 \ [elt_ty] ->+                 do { (pats', res) <- tcMultiple (\p -> tc_lpat p (mkCheckExpType elt_ty))+                                                 pats penv thing_inside+                    ; return (pats', res, elt_ty) }+        ; return (ListPat (ListPatTc elt_ty (Just (tau_pat_ty,e'))) pats', res)+}++tc_pat penv (TuplePat _ pats boxity) pat_ty thing_inside+  = do  { let arity = length pats+              tc = tupleTyCon boxity arity+        ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)+                                               penv pat_ty+                     -- Unboxed tuples have RuntimeRep vars, which we discard:+                     -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+        ; let con_arg_tys = case boxity of Unboxed -> drop arity arg_tys+                                           Boxed   -> arg_tys+        ; (pats', res) <- tc_lpats penv pats (map mkCheckExpType con_arg_tys)+                                   thing_inside++        ; dflags <- getDynFlags++        -- Under flag control turn a pattern (x,y,z) into ~(x,y,z)+        -- so that we can experiment with lazy tuple-matching.+        -- This is a pretty odd place to make the switch, but+        -- it was easy to do.+        ; let+              unmangled_result = TuplePat con_arg_tys pats' boxity+                                 -- pat_ty /= pat_ty iff coi /= IdCo+              possibly_mangled_result+                | gopt Opt_IrrefutableTuples dflags &&+                  isBoxed boxity      = LazyPat noExt (noLoc unmangled_result)+                | otherwise           = unmangled_result++        ; pat_ty <- readExpType pat_ty+        ; ASSERT( con_arg_tys `equalLength` pats ) -- Syntactically enforced+          return (mkHsWrapPat coi possibly_mangled_result pat_ty, res)+        }++tc_pat penv (SumPat _ pat alt arity ) pat_ty thing_inside+  = do  { let tc = sumTyCon arity+        ; (coi, arg_tys) <- matchExpectedPatTy (matchExpectedTyConApp tc)+                                               penv pat_ty+        ; -- Drop levity vars, we don't care about them here+          let con_arg_tys = drop arity arg_tys+        ; (pat', res) <- tc_lpat pat (mkCheckExpType (con_arg_tys `getNth` (alt - 1)))+                                 penv thing_inside+        ; pat_ty <- readExpType pat_ty+        ; return (mkHsWrapPat coi (SumPat con_arg_tys pat' alt arity) pat_ty+                 , res)+        }++------------------------+-- Data constructors+tc_pat penv (ConPatIn con arg_pats) pat_ty thing_inside+  = tcConPat penv con pat_ty arg_pats thing_inside++------------------------+-- Literal patterns+tc_pat penv (LitPat x simple_lit) pat_ty thing_inside+  = do  { let lit_ty = hsLitType simple_lit+        ; wrap   <- tcSubTypePat penv pat_ty lit_ty+        ; res    <- thing_inside+        ; pat_ty <- readExpType pat_ty+        ; return ( mkHsWrapPat wrap (LitPat x (convertLit simple_lit)) pat_ty+                 , res) }++------------------------+-- Overloaded patterns: n, and n+k++-- In the case of a negative literal (the more complicated case),+-- we get+--+--   case v of (-5) -> blah+--+-- becoming+--+--   if v == (negate (fromInteger 5)) then blah else ...+--+-- There are two bits of rebindable syntax:+--   (==)   :: pat_ty -> neg_lit_ty -> Bool+--   negate :: lit_ty -> neg_lit_ty+-- where lit_ty is the type of the overloaded literal 5.+--+-- When there is no negation, neg_lit_ty and lit_ty are the same+tc_pat _ (NPat _ (dL->L l over_lit) mb_neg eq) pat_ty thing_inside+  = do  { let orig = LiteralOrigin over_lit+        ; ((lit', mb_neg'), eq')+            <- tcSyntaxOp orig eq [SynType pat_ty, SynAny]+                          (mkCheckExpType boolTy) $+               \ [neg_lit_ty] ->+               let new_over_lit lit_ty = newOverloadedLit over_lit+                                           (mkCheckExpType lit_ty)+               in case mb_neg of+                 Nothing  -> (, Nothing) <$> new_over_lit neg_lit_ty+                 Just neg -> -- Negative literal+                             -- The 'negate' is re-mappable syntax+                   second Just <$>+                   (tcSyntaxOp orig neg [SynRho] (mkCheckExpType neg_lit_ty) $+                    \ [lit_ty] -> new_over_lit lit_ty)++        ; res <- thing_inside+        ; pat_ty <- readExpType pat_ty+        ; return (NPat pat_ty (cL l lit') mb_neg' eq', res) }++{-+Note [NPlusK patterns]+~~~~~~~~~~~~~~~~~~~~~~+From++  case v of x + 5 -> blah++we get++  if v >= 5 then (\x -> blah) (v - 5) else ...++There are two bits of rebindable syntax:+  (>=) :: pat_ty -> lit1_ty -> Bool+  (-)  :: pat_ty -> lit2_ty -> var_ty++lit1_ty and lit2_ty could conceivably be different.+var_ty is the type inferred for x, the variable in the pattern.++If the pushed-down pattern type isn't a tau-type, the two pat_ty's above+could conceivably be different specializations. But this is very much+like the situation in Note [Case branches must be taus] in TcMatches.+So we tauify the pat_ty before proceeding.++Note that we need to type-check the literal twice, because it is used+twice, and may be used at different types. The second HsOverLit stored in the+AST is used for the subtraction operation.+-}++-- See Note [NPlusK patterns]+tc_pat penv (NPlusKPat _ (dL->L nm_loc name)+               (dL->L loc lit) _ ge minus) pat_ty+              thing_inside+  = do  { pat_ty <- expTypeToType pat_ty+        ; let orig = LiteralOrigin lit+        ; (lit1', ge')+            <- tcSyntaxOp orig ge [synKnownType pat_ty, SynRho]+                                  (mkCheckExpType boolTy) $+               \ [lit1_ty] ->+               newOverloadedLit lit (mkCheckExpType lit1_ty)+        ; ((lit2', minus_wrap, bndr_id), minus')+            <- tcSyntaxOpGen orig minus [synKnownType pat_ty, SynRho] SynAny $+               \ [lit2_ty, var_ty] ->+               do { lit2' <- newOverloadedLit lit (mkCheckExpType lit2_ty)+                  ; (wrap, bndr_id) <- setSrcSpan nm_loc $+                                     tcPatBndr penv name (mkCheckExpType var_ty)+                           -- co :: var_ty ~ idType bndr_id++                           -- minus_wrap is applicable to minus'+                  ; return (lit2', wrap, bndr_id) }++        -- The Report says that n+k patterns must be in Integral+        -- but it's silly to insist on this in the RebindableSyntax case+        ; unlessM (xoptM LangExt.RebindableSyntax) $+          do { icls <- tcLookupClass integralClassName+             ; instStupidTheta orig [mkClassPred icls [pat_ty]] }++        ; res <- tcExtendIdEnv1 name bndr_id thing_inside++        ; let minus'' = minus' { syn_res_wrap =+                                    minus_wrap <.> syn_res_wrap minus' }+              pat' = NPlusKPat pat_ty (cL nm_loc bndr_id) (cL loc lit1') lit2'+                               ge' minus''+        ; return (pat', res) }++-- HsSpliced is an annotation produced by 'RnSplice.rnSplicePat'.+-- Here we get rid of it and add the finalizers to the global environment.+--+-- See Note [Delaying modFinalizers in untyped splices] in RnSplice.+tc_pat penv (SplicePat _ (HsSpliced _ mod_finalizers (HsSplicedPat pat)))+            pat_ty thing_inside+  = do addModFinalizersWithLclEnv mod_finalizers+       tc_pat penv pat pat_ty thing_inside++tc_pat _ _other_pat _ _ = panic "tc_pat"        -- ConPatOut, SigPatOut+++{-+Note [Hopping the LIE in lazy patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a lazy pattern, we must *not* discharge constraints from the RHS+from dictionaries bound in the pattern.  E.g.+        f ~(C x) = 3+We can't discharge the Num constraint from dictionaries bound by+the pattern C!++So we have to make the constraints from thing_inside "hop around"+the pattern.  Hence the captureConstraints and emitConstraints.++The same thing ensures that equality constraints in a lazy match+are not made available in the RHS of the match. For example+        data T a where { T1 :: Int -> T Int; ... }+        f :: T a -> Int -> a+        f ~(T1 i) y = y+It's obviously not sound to refine a to Int in the right+hand side, because the argument might not match T1 at all!++Finally, a lazy pattern should not bind any existential type variables+because they won't be in scope when we do the desugaring+++************************************************************************+*                                                                      *+        Most of the work for constructors is here+        (the rest is in the ConPatIn case of tc_pat)+*                                                                      *+************************************************************************++[Pattern matching indexed data types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following declarations:++  data family Map k :: * -> *+  data instance Map (a, b) v = MapPair (Map a (Pair b v))++and a case expression++  case x :: Map (Int, c) w of MapPair m -> ...++As explained by [Wrappers for data instance tycons] in MkIds.hs, the+worker/wrapper types for MapPair are++  $WMapPair :: forall a b v. Map a (Map a b v) -> Map (a, b) v+  $wMapPair :: forall a b v. Map a (Map a b v) -> :R123Map a b v++So, the type of the scrutinee is Map (Int, c) w, but the tycon of MapPair is+:R123Map, which means the straight use of boxySplitTyConApp would give a type+error.  Hence, the smart wrapper function boxySplitTyConAppWithFamily calls+boxySplitTyConApp with the family tycon Map instead, which gives us the family+type list {(Int, c), w}.  To get the correct split for :R123Map, we need to+unify the family type list {(Int, c), w} with the instance types {(a, b), v}+(provided by tyConFamInst_maybe together with the family tycon).  This+unification yields the substitution [a -> Int, b -> c, v -> w], which gives us+the split arguments for the representation tycon :R123Map as {Int, c, w}++In other words, boxySplitTyConAppWithFamily implicitly takes the coercion++  Co123Map a b v :: {Map (a, b) v ~ :R123Map a b v}++moving between representation and family type into account.  To produce type+correct Core, this coercion needs to be used to case the type of the scrutinee+from the family to the representation type.  This is achieved by+unwrapFamInstScrutinee using a CoPat around the result pattern.++Now it might appear seem as if we could have used the previous GADT type+refinement infrastructure of refineAlt and friends instead of the explicit+unification and CoPat generation.  However, that would be wrong.  Why?  The+whole point of GADT refinement is that the refinement is local to the case+alternative.  In contrast, the substitution generated by the unification of+the family type list and instance types needs to be propagated to the outside.+Imagine that in the above example, the type of the scrutinee would have been+(Map x w), then we would have unified {x, w} with {(a, b), v}, yielding the+substitution [x -> (a, b), v -> w].  In contrast to GADT matching, the+instantiation of x with (a, b) must be global; ie, it must be valid in *all*+alternatives of the case expression, whereas in the GADT case it might vary+between alternatives.++RIP GADT refinement: refinements have been replaced by the use of explicit+equality constraints that are used in conjunction with implication constraints+to express the local scope of GADT refinements.+-}++--      Running example:+-- MkT :: forall a b c. (a~[b]) => b -> c -> T a+--       with scrutinee of type (T ty)++tcConPat :: PatEnv -> Located Name+         -> ExpSigmaType           -- Type of the pattern+         -> HsConPatDetails GhcRn -> TcM a+         -> TcM (Pat GhcTcId, a)+tcConPat penv con_lname@(dL->L _ con_name) pat_ty arg_pats thing_inside+  = do  { con_like <- tcLookupConLike con_name+        ; case con_like of+            RealDataCon data_con -> tcDataConPat penv con_lname data_con+                                                 pat_ty arg_pats thing_inside+            PatSynCon pat_syn -> tcPatSynPat penv con_lname pat_syn+                                             pat_ty arg_pats thing_inside+        }++tcDataConPat :: PatEnv -> Located Name -> DataCon+             -> ExpSigmaType               -- Type of the pattern+             -> HsConPatDetails GhcRn -> TcM a+             -> TcM (Pat GhcTcId, a)+tcDataConPat penv (dL->L con_span con_name) data_con pat_ty+             arg_pats thing_inside+  = do  { let tycon = dataConTyCon data_con+                  -- For data families this is the representation tycon+              (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _)+                = dataConFullSig data_con+              header = cL con_span (RealDataCon data_con)++          -- Instantiate the constructor type variables [a->ty]+          -- This may involve doing a family-instance coercion,+          -- and building a wrapper+        ; (wrap, ctxt_res_tys) <- matchExpectedConTy penv tycon pat_ty+        ; pat_ty <- readExpType pat_ty++          -- Add the stupid theta+        ; setSrcSpan con_span $ addDataConStupidTheta data_con ctxt_res_tys++        ; let all_arg_tys = eqSpecPreds eq_spec ++ theta ++ arg_tys+        ; checkExistentials ex_tvs all_arg_tys penv++        ; tenv <- instTyVarsWith PatOrigin univ_tvs ctxt_res_tys+                  -- NB: Do not use zipTvSubst!  See #14154+                  -- We want to create a well-kinded substitution, so+                  -- that the instantiated type is well-kinded++        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX tenv ex_tvs+                     -- Get location from monad, not from ex_tvs++        ; let -- pat_ty' = mkTyConApp tycon ctxt_res_tys+              -- pat_ty' is type of the actual constructor application+              -- pat_ty' /= pat_ty iff coi /= IdCo++              arg_tys' = substTys tenv arg_tys++        ; traceTc "tcConPat" (vcat [ ppr con_name+                                   , pprTyVars univ_tvs+                                   , pprTyVars ex_tvs+                                   , ppr eq_spec+                                   , ppr theta+                                   , pprTyVars ex_tvs'+                                   , ppr ctxt_res_tys+                                   , ppr arg_tys'+                                   , ppr arg_pats ])+        ; if null ex_tvs && null eq_spec && null theta+          then do { -- The common case; no class bindings etc+                    -- (see Note [Arrows and patterns])+                    (arg_pats', res) <- tcConArgs (RealDataCon data_con) arg_tys'+                                                  arg_pats penv thing_inside+                  ; let res_pat = ConPatOut { pat_con = header,+                                              pat_tvs = [], pat_dicts = [],+                                              pat_binds = emptyTcEvBinds,+                                              pat_args = arg_pats',+                                              pat_arg_tys = ctxt_res_tys,+                                              pat_wrap = idHsWrapper }++                  ; return (mkHsWrapPat wrap res_pat pat_ty, res) }++          else do   -- The general case, with existential,+                    -- and local equality constraints+        { let theta'     = substTheta tenv (eqSpecPreds eq_spec ++ theta)+                           -- order is *important* as we generate the list of+                           -- dictionary binders from theta'+              no_equalities = null eq_spec && not (any isEqPred theta)+              skol_info = PatSkol (RealDataCon data_con) mc+              mc = case pe_ctxt penv of+                     LamPat mc -> mc+                     LetPat {} -> PatBindRhs++        ; gadts_on    <- xoptM LangExt.GADTs+        ; families_on <- xoptM LangExt.TypeFamilies+        ; checkTc (no_equalities || gadts_on || families_on)+                  (text "A pattern match on a GADT requires the" <+>+                   text "GADTs or TypeFamilies language extension")+                  -- #2905 decided that a *pattern-match* of a GADT+                  -- should require the GADT language flag.+                  -- Re TypeFamilies see also #7156++        ; given <- newEvVars theta'+        ; (ev_binds, (arg_pats', res))+             <- checkConstraints skol_info ex_tvs' given $+                tcConArgs (RealDataCon data_con) arg_tys' arg_pats penv thing_inside++        ; let res_pat = ConPatOut { pat_con   = header,+                                    pat_tvs   = ex_tvs',+                                    pat_dicts = given,+                                    pat_binds = ev_binds,+                                    pat_args  = arg_pats',+                                    pat_arg_tys = ctxt_res_tys,+                                    pat_wrap  = idHsWrapper }+        ; return (mkHsWrapPat wrap res_pat pat_ty, res)+        } }++tcPatSynPat :: PatEnv -> Located Name -> PatSyn+            -> ExpSigmaType                -- Type of the pattern+            -> HsConPatDetails GhcRn -> TcM a+            -> TcM (Pat GhcTcId, a)+tcPatSynPat penv (dL->L con_span _) pat_syn pat_ty arg_pats thing_inside+  = do  { let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, ty) = patSynSig pat_syn++        ; (subst, univ_tvs') <- newMetaTyVars univ_tvs++        ; let all_arg_tys = ty : prov_theta ++ arg_tys+        ; checkExistentials ex_tvs all_arg_tys penv+        ; (tenv, ex_tvs') <- tcInstSuperSkolTyVarsX subst ex_tvs+        ; let ty'         = substTy tenv ty+              arg_tys'    = substTys tenv arg_tys+              prov_theta' = substTheta tenv prov_theta+              req_theta'  = substTheta tenv req_theta++        ; wrap <- tcSubTypePat penv pat_ty ty'+        ; traceTc "tcPatSynPat" (ppr pat_syn $$+                                 ppr pat_ty $$+                                 ppr ty' $$+                                 ppr ex_tvs' $$+                                 ppr prov_theta' $$+                                 ppr req_theta' $$+                                 ppr arg_tys')++        ; prov_dicts' <- newEvVars prov_theta'++        ; let skol_info = case pe_ctxt penv of+                            LamPat mc -> PatSkol (PatSynCon pat_syn) mc+                            LetPat {} -> UnkSkol -- Doesn't matter++        ; req_wrap <- instCall PatOrigin (mkTyVarTys univ_tvs') req_theta'+        ; traceTc "instCall" (ppr req_wrap)++        ; traceTc "checkConstraints {" Outputable.empty+        ; (ev_binds, (arg_pats', res))+             <- checkConstraints skol_info ex_tvs' prov_dicts' $+                tcConArgs (PatSynCon pat_syn) arg_tys' arg_pats penv thing_inside++        ; traceTc "checkConstraints }" (ppr ev_binds)+        ; let res_pat = ConPatOut { pat_con   = cL con_span $ PatSynCon pat_syn,+                                    pat_tvs   = ex_tvs',+                                    pat_dicts = prov_dicts',+                                    pat_binds = ev_binds,+                                    pat_args  = arg_pats',+                                    pat_arg_tys = mkTyVarTys univ_tvs',+                                    pat_wrap  = req_wrap }+        ; pat_ty <- readExpType pat_ty+        ; return (mkHsWrapPat wrap res_pat pat_ty, res) }++----------------------------+-- | Convenient wrapper for calling a matchExpectedXXX function+matchExpectedPatTy :: (TcRhoType -> TcM (TcCoercionN, a))+                    -> PatEnv -> ExpSigmaType -> TcM (HsWrapper, a)+-- See Note [Matching polytyped patterns]+-- Returns a wrapper : pat_ty ~R inner_ty+matchExpectedPatTy inner_match (PE { pe_orig = orig }) pat_ty+  = do { pat_ty <- expTypeToType pat_ty+       ; (wrap, pat_rho) <- topInstantiate orig pat_ty+       ; (co, res) <- inner_match pat_rho+       ; traceTc "matchExpectedPatTy" (ppr pat_ty $$ ppr wrap)+       ; return (mkWpCastN (mkTcSymCo co) <.> wrap, res) }++----------------------------+matchExpectedConTy :: PatEnv+                   -> TyCon      -- The TyCon that this data+                                 -- constructor actually returns+                                 -- In the case of a data family this is+                                 -- the /representation/ TyCon+                   -> ExpSigmaType  -- The type of the pattern; in the case+                                    -- of a data family this would mention+                                    -- the /family/ TyCon+                   -> TcM (HsWrapper, [TcSigmaType])+-- See Note [Matching constructor patterns]+-- Returns a wrapper : pat_ty "->" T ty1 ... tyn+matchExpectedConTy (PE { pe_orig = orig }) data_tc exp_pat_ty+  | Just (fam_tc, fam_args, co_tc) <- tyConFamInstSig_maybe data_tc+         -- Comments refer to Note [Matching constructor patterns]+         -- co_tc :: forall a. T [a] ~ T7 a+  = do { pat_ty <- expTypeToType exp_pat_ty+       ; (wrap, pat_rho) <- topInstantiate orig pat_ty++       ; (subst, tvs') <- newMetaTyVars (tyConTyVars data_tc)+             -- tys = [ty1,ty2]++       ; traceTc "matchExpectedConTy" (vcat [ppr data_tc,+                                             ppr (tyConTyVars data_tc),+                                             ppr fam_tc, ppr fam_args,+                                             ppr exp_pat_ty,+                                             ppr pat_ty,+                                             ppr pat_rho, ppr wrap])+       ; co1 <- unifyType Nothing (mkTyConApp fam_tc (substTys subst fam_args)) pat_rho+             -- co1 : T (ty1,ty2) ~N pat_rho+             -- could use tcSubType here... but it's the wrong way round+             -- for actual vs. expected in error messages.++       ; let tys' = mkTyVarTys tvs'+             co2 = mkTcUnbranchedAxInstCo co_tc tys' []+             -- co2 : T (ty1,ty2) ~R T7 ty1 ty2++             full_co = mkTcSubCo (mkTcSymCo co1) `mkTcTransCo` co2+             -- full_co :: pat_rho ~R T7 ty1 ty2++       ; return ( mkWpCastR full_co <.> wrap, tys') }++  | otherwise+  = do { pat_ty <- expTypeToType exp_pat_ty+       ; (wrap, pat_rho) <- topInstantiate orig pat_ty+       ; (coi, tys) <- matchExpectedTyConApp data_tc pat_rho+       ; return (mkWpCastN (mkTcSymCo coi) <.> wrap, tys) }++{-+Note [Matching constructor patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose (coi, tys) = matchExpectedConType data_tc pat_ty++ * In the simple case, pat_ty = tc tys++ * If pat_ty is a polytype, we want to instantiate it+   This is like part of a subsumption check.  Eg+      f :: (forall a. [a]) -> blah+      f [] = blah++ * In a type family case, suppose we have+          data family T a+          data instance T (p,q) = A p | B q+       Then we'll have internally generated+              data T7 p q = A p | B q+              axiom coT7 p q :: T (p,q) ~ T7 p q++       So if pat_ty = T (ty1,ty2), we return (coi, [ty1,ty2]) such that+           coi = coi2 . coi1 : T7 t ~ pat_ty+           coi1 : T (ty1,ty2) ~ pat_ty+           coi2 : T7 ty1 ty2 ~ T (ty1,ty2)++   For families we do all this matching here, not in the unifier,+   because we never want a whisper of the data_tycon to appear in+   error messages; it's a purely internal thing+-}++tcConArgs :: ConLike -> [TcSigmaType]+          -> Checker (HsConPatDetails GhcRn) (HsConPatDetails GhcTc)++tcConArgs con_like arg_tys (PrefixCon arg_pats) penv thing_inside+  = do  { checkTc (con_arity == no_of_args)     -- Check correct arity+                  (arityErr (text "constructor") con_like con_arity no_of_args)+        ; let pats_w_tys = zipEqual "tcConArgs" arg_pats arg_tys+        ; (arg_pats', res) <- tcMultiple tcConArg pats_w_tys+                                              penv thing_inside+        ; return (PrefixCon arg_pats', res) }+  where+    con_arity  = conLikeArity con_like+    no_of_args = length arg_pats++tcConArgs con_like arg_tys (InfixCon p1 p2) penv thing_inside+  = do  { checkTc (con_arity == 2)      -- Check correct arity+                  (arityErr (text "constructor") con_like con_arity 2)+        ; let [arg_ty1,arg_ty2] = arg_tys       -- This can't fail after the arity check+        ; ([p1',p2'], res) <- tcMultiple tcConArg [(p1,arg_ty1),(p2,arg_ty2)]+                                              penv thing_inside+        ; return (InfixCon p1' p2', res) }+  where+    con_arity  = conLikeArity con_like++tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside+  = do  { (rpats', res) <- tcMultiple tc_field rpats penv thing_inside+        ; return (RecCon (HsRecFields rpats' dd), res) }+  where+    tc_field :: Checker (LHsRecField GhcRn (LPat GhcRn))+                        (LHsRecField GhcTcId (LPat GhcTcId))+    tc_field (dL->L l (HsRecField (dL->L loc+                                    (FieldOcc sel (dL->L lr rdr))) pat pun))+             penv thing_inside+      = do { sel'   <- tcLookupId sel+           ; pat_ty <- setSrcSpan loc $ find_field_ty sel+                                          (occNameFS $ rdrNameOcc rdr)+           ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside+           ; return (cL l (HsRecField (cL loc (FieldOcc sel' (cL lr rdr))) pat'+                                                                    pun), res) }+    tc_field (dL->L _ (HsRecField (dL->L _ (XFieldOcc _)) _ _)) _ _+           = panic "tcConArgs"+    tc_field _ _ _ = panic "tc_field: Impossible Match"+                             -- due to #15884+++    find_field_ty :: Name -> FieldLabelString -> TcM TcType+    find_field_ty sel lbl+        = case [ty | (fl, ty) <- field_tys, flSelector fl == sel] of++                -- No matching field; chances are this field label comes from some+                -- other record type (or maybe none).  If this happens, just fail,+                -- otherwise we get crashes later (#8570), and similar:+                --      f (R { foo = (a,b) }) = a+b+                -- If foo isn't one of R's fields, we don't want to crash when+                -- typechecking the "a+b".+           [] -> failWith (badFieldCon con_like lbl)++                -- The normal case, when the field comes from the right constructor+           (pat_ty : extras) -> do+                traceTc "find_field" (ppr pat_ty <+> ppr extras)+                ASSERT( null extras ) (return pat_ty)++    field_tys :: [(FieldLabel, TcType)]+    field_tys = zip (conLikeFieldLabels con_like) arg_tys+          -- Don't use zipEqual! If the constructor isn't really a record, then+          -- dataConFieldLabels will be empty (and each field in the pattern+          -- will generate an error below).++tcConArg :: Checker (LPat GhcRn, TcSigmaType) (LPat GhcTc)+tcConArg (arg_pat, arg_ty) penv thing_inside+  = tc_lpat arg_pat (mkCheckExpType arg_ty) penv thing_inside++addDataConStupidTheta :: DataCon -> [TcType] -> TcM ()+-- Instantiate the "stupid theta" of the data con, and throw+-- the constraints into the constraint set+addDataConStupidTheta data_con inst_tys+  | null stupid_theta = return ()+  | otherwise         = instStupidTheta origin inst_theta+  where+    origin = OccurrenceOf (dataConName data_con)+        -- The origin should always report "occurrence of C"+        -- even when C occurs in a pattern+    stupid_theta = dataConStupidTheta data_con+    univ_tvs     = dataConUnivTyVars data_con+    tenv = zipTvSubst univ_tvs (takeList univ_tvs inst_tys)+         -- NB: inst_tys can be longer than the univ tyvars+         --     because the constructor might have existentials+    inst_theta = substTheta tenv stupid_theta++{-+Note [Arrows and patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~+(Oct 07) Arrow notation has the odd property that it involves+"holes in the scope". For example:+  expr :: Arrow a => a () Int+  expr = proc (y,z) -> do+          x <- term -< y+          expr' -< x++Here the 'proc (y,z)' binding scopes over the arrow tails but not the+arrow body (e.g 'term').  As things stand (bogusly) all the+constraints from the proc body are gathered together, so constraints+from 'term' will be seen by the tcPat for (y,z).  But we must *not*+bind constraints from 'term' here, because the desugarer will not make+these bindings scope over 'term'.++The Right Thing is not to confuse these constraints together. But for+now the Easy Thing is to ensure that we do not have existential or+GADT constraints in a 'proc', and to short-cut the constraint+simplification for such vanilla patterns so that it binds no+constraints. Hence the 'fast path' in tcConPat; but it's also a good+plan for ordinary vanilla patterns to bypass the constraint+simplification step.++************************************************************************+*                                                                      *+                Note [Pattern coercions]+*                                                                      *+************************************************************************++In principle, these program would be reasonable:++        f :: (forall a. a->a) -> Int+        f (x :: Int->Int) = x 3++        g :: (forall a. [a]) -> Bool+        g [] = True++In both cases, the function type signature restricts what arguments can be passed+in a call (to polymorphic ones).  The pattern type signature then instantiates this+type.  For example, in the first case,  (forall a. a->a) <= Int -> Int, and we+generate the translated term+        f = \x' :: (forall a. a->a).  let x = x' Int in x 3++From a type-system point of view, this is perfectly fine, but it's *very* seldom useful.+And it requires a significant amount of code to implement, because we need to decorate+the translated pattern with coercion functions (generated from the subsumption check+by tcSub).++So for now I'm just insisting on type *equality* in patterns.  No subsumption.++Old notes about desugaring, at a time when pattern coercions were handled:++A SigPat is a type coercion and must be handled one at at time.  We can't+combine them unless the type of the pattern inside is identical, and we don't+bother to check for that.  For example:++        data T = T1 Int | T2 Bool+        f :: (forall a. a -> a) -> T -> t+        f (g::Int->Int)   (T1 i) = T1 (g i)+        f (g::Bool->Bool) (T2 b) = T2 (g b)++We desugar this as follows:++        f = \ g::(forall a. a->a) t::T ->+            let gi = g Int+            in case t of { T1 i -> T1 (gi i)+                           other ->+            let gb = g Bool+            in case t of { T2 b -> T2 (gb b)+                           other -> fail }}++Note that we do not treat the first column of patterns as a+column of variables, because the coerced variables (gi, gb)+would be of different types.  So we get rather grotty code.+But I don't think this is a common case, and if it was we could+doubtless improve it.++Meanwhile, the strategy is:+        * treat each SigPat coercion (always non-identity coercions)+                as a separate block+        * deal with the stuff inside, and then wrap a binding round+                the result to bind the new variable (gi, gb, etc)+++************************************************************************+*                                                                      *+\subsection{Errors and contexts}+*                                                                      *+************************************************************************++Note [Existential check]+~~~~~~~~~~~~~~~~~~~~~~~~+Lazy patterns can't bind existentials.  They arise in two ways:+  * Let bindings      let { C a b = e } in b+  * Twiddle patterns  f ~(C a b) = e+The pe_lazy field of PatEnv says whether we are inside a lazy+pattern (perhaps deeply)++See also Note [Typechecking pattern bindings] in TcBinds+-}++maybeWrapPatCtxt :: Pat GhcRn -> (TcM a -> TcM b) -> TcM a -> TcM b+-- Not all patterns are worth pushing a context+maybeWrapPatCtxt pat tcm thing_inside+  | not (worth_wrapping pat) = tcm thing_inside+  | otherwise                = addErrCtxt msg $ tcm $ popErrCtxt thing_inside+                               -- Remember to pop before doing thing_inside+  where+   worth_wrapping (VarPat {}) = False+   worth_wrapping (ParPat {}) = False+   worth_wrapping (AsPat {})  = False+   worth_wrapping _           = True+   msg = hang (text "In the pattern:") 2 (ppr pat)++-----------------------------------------------+checkExistentials :: [TyVar]   -- existentials+                  -> [Type]    -- argument types+                  -> PatEnv -> TcM ()+    -- See Note [Existential check]]+    -- See Note [Arrows and patterns]+checkExistentials ex_tvs tys _+  | all (not . (`elemVarSet` tyCoVarsOfTypes tys)) ex_tvs = return ()+checkExistentials _ _ (PE { pe_ctxt = LetPat {}})         = return ()+checkExistentials _ _ (PE { pe_ctxt = LamPat ProcExpr })  = failWithTc existentialProcPat+checkExistentials _ _ (PE { pe_lazy = True })             = failWithTc existentialLazyPat+checkExistentials _ _ _                                   = return ()++existentialLazyPat :: SDoc+existentialLazyPat+  = hang (text "An existential or GADT data constructor cannot be used")+       2 (text "inside a lazy (~) pattern")++existentialProcPat :: SDoc+existentialProcPat+  = text "Proc patterns cannot use existential or GADT data constructors"++badFieldCon :: ConLike -> FieldLabelString -> SDoc+badFieldCon con field+  = hsep [text "Constructor" <+> quotes (ppr con),+          text "does not have field", quotes (ppr field)]++polyPatSig :: TcType -> SDoc+polyPatSig sig_ty+  = hang (text "Illegal polymorphic type signature in pattern:")+       2 (ppr sig_ty)
+ compiler/typecheck/TcPatSyn.hs view
@@ -0,0 +1,1148 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[TcPatSyn]{Typechecking pattern synonym declarations}+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module TcPatSyn ( tcPatSynDecl, tcPatSynBuilderBind+                , tcPatSynBuilderOcc, nonBidirectionalErr+  ) where++import GhcPrelude++import HsSyn+import TcPat+import Type( tidyTyCoVarBinders, tidyTypes, tidyType )+import TcRnMonad+import TcSigs( emptyPragEnv, completeSigFromId )+import TcEnv+import TcMType+import TcHsSyn+import TysPrim+import Name+import SrcLoc+import PatSyn+import NameSet+import Panic+import Outputable+import FastString+import Var+import VarEnv( emptyTidyEnv, mkInScopeSet )+import Id+import IdInfo( RecSelParent(..), setLevityInfoWithType )+import TcBinds+import BasicTypes+import TcSimplify+import TcUnify+import Type( PredTree(..), EqRel(..), classifyPredType )+import TysWiredIn+import TcType+import TcEvidence+import BuildTyCl+import VarSet+import MkId+import TcTyDecls+import ConLike+import FieldLabel+import Bag+import Util+import ErrUtils+import Data.Maybe( mapMaybe )+import Control.Monad ( zipWithM )+import Data.List( partition )++#include "HsVersions.h"++{-+************************************************************************+*                                                                      *+                    Type checking a pattern synonym+*                                                                      *+************************************************************************+-}++tcPatSynDecl :: PatSynBind GhcRn GhcRn+             -> Maybe TcSigInfo+             -> TcM (LHsBinds GhcTc, TcGblEnv)+tcPatSynDecl psb mb_sig+  = recoverM (recoverPSB psb) $+    case mb_sig of+      Nothing                 -> tcInferPatSynDecl psb+      Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi+      _                       -> panic "tcPatSynDecl"++recoverPSB :: PatSynBind GhcRn GhcRn+           -> TcM (LHsBinds GhcTc, TcGblEnv)+-- See Note [Pattern synonym error recovery]+recoverPSB (PSB { psb_id = (dL->L _ name)+                , psb_args = details })+ = do { matcher_name <- newImplicitBinder name mkMatcherOcc+      ; let placeholder = AConLike $ PatSynCon $+                          mk_placeholder matcher_name+      ; gbl_env <- tcExtendGlobalEnv [placeholder] getGblEnv+      ; return (emptyBag, gbl_env) }+  where+    (_arg_names, _rec_fields, is_infix) = collectPatSynArgInfo details+    mk_placeholder matcher_name+      = mkPatSyn name is_infix+                        ([mkTyVarBinder Specified alphaTyVar], []) ([], [])+                        [] -- Arg tys+                        alphaTy+                        (matcher_id, True) Nothing+                        []  -- Field labels+       where+         -- The matcher_id is used only by the desugarer, so actually+         -- and error-thunk would probably do just as well here.+         matcher_id = mkLocalId matcher_name $+                      mkSpecForAllTys [alphaTyVar] alphaTy++recoverPSB (XPatSynBind {}) = panic "recoverPSB"++{- Note [Pattern synonym error recovery]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If type inference for a pattern synonym fails, we can't continue with+the rest of tc_patsyn_finish, because we may get knock-on errors, or+even a crash.  E.g. from+   pattern What = True :: Maybe+we get a kind error; and we must stop right away (#15289).++We stop if there are /any/ unsolved constraints, not just insoluble+ones; because pattern synonyms are top-level things, we will never+solve them later if we can't solve them now.  And if we were to carry+on, tc_patsyn_finish does zonkTcTypeToType, which defaults any+unsolved unificatdion variables to Any, which confuses the error+reporting no end (#15685).++So we use simplifyTop to completely solve the constraint, report+any errors, throw an exception.++Even in the event of such an error we can recover and carry on, just+as we do for value bindings, provided we plug in placeholder for the+pattern synonym: see recoverPSB.  The goal of the placeholder is not+to cause a raft of follow-on errors.  I've used the simplest thing for+now, but we might need to elaborate it a bit later.  (e.g.  I've given+it zero args, which may cause knock-on errors if it is used in a+pattern.) But it'll do for now.++-}++tcInferPatSynDecl :: PatSynBind GhcRn GhcRn+                  -> TcM (LHsBinds GhcTc, TcGblEnv)+tcInferPatSynDecl (PSB { psb_id = lname@(dL->L _ name), psb_args = details+                       , psb_def = lpat, psb_dir = dir })+  = addPatSynCtxt lname $+    do { traceTc "tcInferPatSynDecl {" $ ppr name++       ; let (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details+       ; (tclvl, wanted, ((lpat', args), pat_ty))+            <- pushLevelAndCaptureConstraints  $+               tcInferNoInst                   $ \ exp_ty ->+               tcPat PatSyn lpat exp_ty        $+               mapM tcLookupId arg_names++       ; let (ex_tvs, prov_dicts) = tcCollectEx lpat'++             named_taus = (name, pat_ty) : map mk_named_tau args+             mk_named_tau arg+               = (getName arg, mkSpecForAllTys ex_tvs (varType arg))+               -- The mkSpecForAllTys is important (#14552), albeit+               -- slightly artifical (there is no variable with this funny type).+               -- We do not want to quantify over variable (alpha::k)+               -- that mention the existentially-bound type variables+               -- ex_tvs in its kind k.+               -- See Note [Type variables whose kind is captured]++       ; (univ_tvs, req_dicts, ev_binds, residual, _)+               <- simplifyInfer tclvl NoRestrictions [] named_taus wanted+       ; top_ev_binds <- checkNoErrs (simplifyTop residual)+       ; addTopEvBinds top_ev_binds $++    do { prov_dicts <- mapM zonkId prov_dicts+       ; let filtered_prov_dicts = mkMinimalBySCs evVarPred prov_dicts+             -- Filtering: see Note [Remove redundant provided dicts]+             (prov_theta, prov_evs)+                 = unzip (mapMaybe mkProvEvidence filtered_prov_dicts)+             req_theta = map evVarPred req_dicts++       -- Report coercions that esacpe+       -- See Note [Coercions that escape]+       ; args <- mapM zonkId args+       ; let bad_args = [ (arg, bad_cos) | arg <- args ++ prov_dicts+                              , let bad_cos = filterDVarSet isId $+                                              (tyCoVarsOfTypeDSet (idType arg))+                              , not (isEmptyDVarSet bad_cos) ]+       ; mapM_ dependentArgErr bad_args++       ; traceTc "tcInferPatSynDecl }" $ (ppr name $$ ppr ex_tvs)+       ; tc_patsyn_finish lname dir is_infix lpat'+                          (mkTyVarBinders Inferred univ_tvs+                            , req_theta,  ev_binds, req_dicts)+                          (mkTyVarBinders Inferred ex_tvs+                            , mkTyVarTys ex_tvs, prov_theta, prov_evs)+                          (map nlHsVar args, map idType args)+                          pat_ty rec_fields } }+tcInferPatSynDecl (XPatSynBind _) = panic "tcInferPatSynDecl"++mkProvEvidence :: EvId -> Maybe (PredType, EvTerm)+-- See Note [Equality evidence in pattern synonyms]+mkProvEvidence ev_id+  | EqPred r ty1 ty2 <- classifyPredType pred+  , let k1 = tcTypeKind ty1+        k2 = tcTypeKind ty2+        is_homo = k1 `tcEqType` k2+        homo_tys   = [k1, ty1, ty2]+        hetero_tys = [k1, k2, ty1, ty2]+  = case r of+      ReprEq | is_homo+             -> Just ( mkClassPred coercibleClass    homo_tys+                     , evDataConApp coercibleDataCon homo_tys eq_con_args )+             | otherwise -> Nothing+      NomEq  | is_homo+             -> Just ( mkClassPred eqClass    homo_tys+                     , evDataConApp eqDataCon homo_tys eq_con_args )+             | otherwise+             -> Just ( mkClassPred heqClass    hetero_tys+                     , evDataConApp heqDataCon hetero_tys eq_con_args )++  | otherwise+  = Just (pred, EvExpr (evId ev_id))+  where+    pred = evVarPred ev_id+    eq_con_args = [evId ev_id]++dependentArgErr :: (Id, DTyCoVarSet) -> TcM ()+-- See Note [Coercions that escape]+dependentArgErr (arg, bad_cos)+  = addErrTc $+    vcat [ text "Iceland Jack!  Iceland Jack! Stop torturing me!"+         , hang (text "Pattern-bound variable")+              2 (ppr arg <+> dcolon <+> ppr (idType arg))+         , nest 2 $+           hang (text "has a type that mentions pattern-bound coercion"+                 <> plural bad_co_list <> colon)+              2 (pprWithCommas ppr bad_co_list)+         , text "Hint: use -fprint-explicit-coercions to see the coercions"+         , text "Probable fix: add a pattern signature" ]+  where+    bad_co_list = dVarSetElems bad_cos++{- Note [Type variables whose kind is captured]+~~-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data AST a = Sym [a]+  class Prj s where { prj :: [a] -> Maybe (s a)+  pattern P x <= Sym (prj -> Just x)++Here we get a matcher with this type+  $mP :: forall s a. Prj s => AST a -> (s a -> r) -> r -> r++No problem.  But note that 's' is not fixed by the type of the+pattern (AST a), nor is it existentially bound.  It's really only+fixed by the type of the continuation.++#14552 showed that this can go wrong if the kind of 's' mentions+existentially bound variables.  We obviously can't make a type like+  $mP :: forall (s::k->*) a. Prj s => AST a -> (forall k. s a -> r)+                                   -> r -> r+But neither is 's' itself existentially bound, so the forall (s::k->*)+can't go in the inner forall either.  (What would the matcher apply+the continuation to?)++Solution: do not quantiify over any unification variable whose kind+mentions the existentials.  We can conveniently do that by making the+"taus" passed to simplifyInfer look like+   forall ex_tvs. arg_ty++After that, Note [Naughty quantification candidates] in TcMType takes+over, and zonks any such naughty variables to Any.++Note [Remove redundant provided dicts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Recall that+   HRefl :: forall k1 k2 (a1:k1) (a2:k2). (k1 ~ k2, a1 ~ a2)+                                       => a1 :~~: a2+(NB: technically the (k1~k2) existential dictionary is not necessary,+but it's there at the moment.)++Now consider (#14394):+   pattern Foo = HRefl+in a non-poly-kinded module.  We don't want to get+    pattern Foo :: () => (* ~ *, b ~ a) => a :~~: b+with that redundant (* ~ *).  We'd like to remove it; hence the call to+mkMinimalWithSCs.++Similarly consider+  data S a where { MkS :: Ord a => a -> S a }+  pattern Bam x y <- (MkS (x::a), MkS (y::a)))++The pattern (Bam x y) binds two (Ord a) dictionaries, but we only+need one.  Agian mkMimimalWithSCs removes the redundant one.++Note [Equality evidence in pattern synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data X a where+     MkX :: Eq a => [a] -> X (Maybe a)+  pattern P x = MkG x++Then there is a danger that GHC will infer+  P :: forall a.  () =>+       forall b. (a ~# Maybe b, Eq b) => [b] -> X a++The 'builder' for P, which is called in user-code, will then+have type+  $bP :: forall a b. (a ~# Maybe b, Eq b) => [b] -> X a++and that is bad because (a ~# Maybe b) is not a predicate type+(see Note [Types for coercions, predicates, and evidence] in Type)+and is not implicitly instantiated.++So in mkProvEvidence we lift (a ~# b) to (a ~ b).  Tiresome, and+marginally less efficient, if the builder/martcher are not inlined.++See also Note [Lift equality constaints when quantifying] in TcType++Note [Coercions that escape]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+#14507 showed an example where the inferred type of the matcher+for the pattern synonym was somethign like+   $mSO :: forall (r :: TYPE rep) kk (a :: k).+           TypeRep k a+           -> ((Bool ~ k) => TypeRep Bool (a |> co_a2sv) -> r)+           -> (Void# -> r)+           -> r++What is that co_a2sv :: Bool ~# *??  It was bound (via a superclass+selection) by the pattern being matched; and indeed it is implicit in+the context (Bool ~ k).  You could imagine trying to extract it like+this:+   $mSO :: forall (r :: TYPE rep) kk (a :: k).+           TypeRep k a+           -> ( co :: ((Bool :: *) ~ (k :: *)) =>+                  let co_a2sv = sc_sel co+                  in TypeRep Bool (a |> co_a2sv) -> r)+           -> (Void# -> r)+           -> r++But we simply don't allow that in types.  Maybe one day but not now.++How to detect this situation?  We just look for free coercion variables+in the types of any of the arguments to the matcher.  The error message+is not very helpful, but at least we don't get a Lint error.+-}++tcCheckPatSynDecl :: PatSynBind GhcRn GhcRn+                  -> TcPatSynInfo+                  -> TcM (LHsBinds GhcTc, TcGblEnv)+tcCheckPatSynDecl psb@PSB{ psb_id = lname@(dL->L _ name), psb_args = details+                         , psb_def = lpat, psb_dir = dir }+                  TPSI{ patsig_implicit_bndrs = implicit_tvs+                      , patsig_univ_bndrs = explicit_univ_tvs, patsig_prov = prov_theta+                      , patsig_ex_bndrs   = explicit_ex_tvs,   patsig_req  = req_theta+                      , patsig_body_ty    = sig_body_ty }+  = addPatSynCtxt lname $+    do { let decl_arity = length arg_names+             (arg_names, rec_fields, is_infix) = collectPatSynArgInfo details++       ; traceTc "tcCheckPatSynDecl" $+         vcat [ ppr implicit_tvs, ppr explicit_univ_tvs, ppr req_theta+              , ppr explicit_ex_tvs, ppr prov_theta, ppr sig_body_ty ]++       ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of+                                 Right stuff  -> return stuff+                                 Left missing -> wrongNumberOfParmsErr name decl_arity missing++       -- Complain about:  pattern P :: () => forall x. x -> P x+       -- The existential 'x' should not appear in the result type+       -- Can't check this until we know P's arity+       ; let bad_tvs = filter (`elemVarSet` tyCoVarsOfType pat_ty) explicit_ex_tvs+       ; checkTc (null bad_tvs) $+         hang (sep [ text "The result type of the signature for" <+> quotes (ppr name) <> comma+                   , text "namely" <+> quotes (ppr pat_ty) ])+            2 (text "mentions existential type variable" <> plural bad_tvs+               <+> pprQuotedList bad_tvs)++         -- See Note [The pattern-synonym signature splitting rule] in TcSigs+       ; let univ_fvs = closeOverKinds $+                        (tyCoVarsOfTypes (pat_ty : req_theta) `extendVarSetList` explicit_univ_tvs)+             (extra_univ, extra_ex) = partition ((`elemVarSet` univ_fvs) . binderVar) implicit_tvs+             univ_bndrs = extra_univ ++ mkTyVarBinders Specified explicit_univ_tvs+             ex_bndrs   = extra_ex   ++ mkTyVarBinders Specified explicit_ex_tvs+             univ_tvs   = binderVars univ_bndrs+             ex_tvs     = binderVars ex_bndrs++       -- Right!  Let's check the pattern against the signature+       -- See Note [Checking against a pattern signature]+       ; req_dicts <- newEvVars req_theta+       ; (tclvl, wanted, (lpat', (ex_tvs', prov_dicts, args'))) <-+           ASSERT2( equalLength arg_names arg_tys, ppr name $$ ppr arg_names $$ ppr arg_tys )+           pushLevelAndCaptureConstraints            $+           tcExtendTyVarEnv univ_tvs                 $+           tcPat PatSyn lpat (mkCheckExpType pat_ty) $+           do { let in_scope    = mkInScopeSet (mkVarSet univ_tvs)+                    empty_subst = mkEmptyTCvSubst in_scope+              ; (subst, ex_tvs') <- mapAccumLM newMetaTyVarX empty_subst ex_tvs+                    -- newMetaTyVarX: see the "Existential type variables"+                    -- part of Note [Checking against a pattern signature]+              ; traceTc "tcpatsyn1" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs])+              ; traceTc "tcpatsyn2" (vcat [ ppr v <+> dcolon <+> ppr (tyVarKind v) | v <- ex_tvs'])+              ; let prov_theta' = substTheta subst prov_theta+                  -- Add univ_tvs to the in_scope set to+                  -- satisfy the substitution invariant. There's no need to+                  -- add 'ex_tvs' as they are already in the domain of the+                  -- substitution.+                  -- See also Note [The substitution invariant] in TyCoRep.+              ; prov_dicts <- mapM (emitWanted (ProvCtxtOrigin psb)) prov_theta'+              ; args'      <- zipWithM (tc_arg subst) arg_names arg_tys+              ; return (ex_tvs', prov_dicts, args') }++       ; let skol_info = SigSkol (PatSynCtxt name) pat_ty []+                         -- The type here is a bit bogus, but we do not print+                         -- the type for PatSynCtxt, so it doesn't matter+                         -- See TcRnTypes Note [Skolem info for pattern synonyms]+       ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info univ_tvs req_dicts wanted++       -- Solve the constraints now, because we are about to make a PatSyn,+       -- which should not contain unification variables and the like (#10997)+       ; simplifyTopImplic implics++       -- ToDo: in the bidirectional case, check that the ex_tvs' are all distinct+       -- Otherwise we may get a type error when typechecking the builder,+       -- when that should be impossible++       ; traceTc "tcCheckPatSynDecl }" $ ppr name+       ; tc_patsyn_finish lname dir is_infix lpat'+                          (univ_bndrs, req_theta, ev_binds, req_dicts)+                          (ex_bndrs, mkTyVarTys ex_tvs', prov_theta, prov_dicts)+                          (args', arg_tys)+                          pat_ty rec_fields }+  where+    tc_arg :: TCvSubst -> Name -> Type -> TcM (LHsExpr GhcTcId)+    tc_arg subst arg_name arg_ty+      = do {   -- Look up the variable actually bound by lpat+               -- and check that it has the expected type+             arg_id <- tcLookupId arg_name+           ; wrap <- tcSubType_NC GenSigCtxt+                                 (idType arg_id)+                                 (substTyUnchecked subst arg_ty)+                -- Why do we need tcSubType here?+                -- See Note [Pattern synonyms and higher rank types]+           ; return (mkLHsWrap wrap $ nlHsVar arg_id) }+tcCheckPatSynDecl (XPatSynBind _) _ = panic "tcCheckPatSynDecl"++{- [Pattern synonyms and higher rank types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data T = MkT (forall a. a->a)++  pattern P :: (Int -> Int) -> T+  pattern P x <- MkT x++This should work.  But in the matcher we must match against MkT, and then+instantiate its argument 'x', to get a function of type (Int -> Int).+Equality is not enough!  #13752 was an example.+++Note [The pattern-synonym signature splitting rule]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a pattern signature, we must split+     the kind-generalised variables, and+     the implicitly-bound variables+into universal and existential.  The rule is this+(see discussion on #11224):++     The universal tyvars are the ones mentioned in+          - univ_tvs: the user-specified (forall'd) universals+          - req_theta+          - res_ty+     The existential tyvars are all the rest++For example++   pattern P :: () => b -> T a+   pattern P x = ...++Here 'a' is universal, and 'b' is existential.  But there is a wrinkle:+how do we split the arg_tys from req_ty?  Consider++   pattern Q :: () => b -> S c -> T a+   pattern Q x = ...++This is an odd example because Q has only one syntactic argument, and+so presumably is defined by a view pattern matching a function.  But+it can happen (#11977, #12108).++We don't know Q's arity from the pattern signature, so we have to wait+until we see the pattern declaration itself before deciding res_ty is,+and hence which variables are existential and which are universal.++And that in turn is why TcPatSynInfo has a separate field,+patsig_implicit_bndrs, to capture the implicitly bound type variables,+because we don't yet know how to split them up.++It's a slight compromise, because it means we don't really know the+pattern synonym's real signature until we see its declaration.  So,+for example, in hs-boot file, we may need to think what to do...+(eg don't have any implicitly-bound variables).+++Note [Checking against a pattern signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When checking the actual supplied pattern against the pattern synonym+signature, we need to be quite careful.++----- Provided constraints+Example++    data T a where+      MkT :: Ord a => a -> T a++    pattern P :: () => Eq a => a -> [T a]+    pattern P x = [MkT x]++We must check that the (Eq a) that P claims to bind (and to+make available to matches against P), is derivable from the+actual pattern.  For example:+    f (P (x::a)) = ...here (Eq a) should be available...+And yes, (Eq a) is derivable from the (Ord a) bound by P's rhs.++----- Existential type variables+Unusually, we instantiate the existential tyvars of the pattern with+*meta* type variables.  For example++    data S where+      MkS :: Eq a => [a] -> S++    pattern P :: () => Eq x => x -> S+    pattern P x <- MkS x++The pattern synonym conceals from its client the fact that MkS has a+list inside it.  The client just thinks it's a type 'x'.  So we must+unify x := [a] during type checking, and then use the instantiating type+[a] (called ex_tys) when building the matcher.  In this case we'll get++   $mP :: S -> (forall x. Ex x => x -> r) -> r -> r+   $mP x k = case x of+               MkS a (d:Eq a) (ys:[a]) -> let dl :: Eq [a]+                                              dl = $dfunEqList d+                                          in k [a] dl ys++All this applies when type-checking the /matching/ side of+a pattern synonym.  What about the /building/ side?++* For Unidirectional, there is no builder++* For ExplicitBidirectional, the builder is completely separate+  code, typechecked in tcPatSynBuilderBind++* For ImplicitBidirectional, the builder is still typechecked in+  tcPatSynBuilderBind, by converting the pattern to an expression and+  typechecking it.++  At one point, for ImplicitBidirectional I used TyVarTvs (instead of+  TauTvs) in tcCheckPatSynDecl.  But (a) strengthening the check here+  is redundant since tcPatSynBuilderBind does the job, (b) it was+  still incomplete (TyVarTvs can unify with each other), and (c) it+  didn't even work (#13441 was accepted with+  ExplicitBidirectional, but rejected if expressed in+  ImplicitBidirectional form.  Conclusion: trying to be too clever is+  a bad idea.+-}++collectPatSynArgInfo :: HsPatSynDetails (Located Name)+                     -> ([Name], [Name], Bool)+collectPatSynArgInfo details =+  case details of+    PrefixCon names      -> (map unLoc names, [], False)+    InfixCon name1 name2 -> (map unLoc [name1, name2], [], True)+    RecCon names         -> (vars, sels, False)+                         where+                            (vars, sels) = unzip (map splitRecordPatSyn names)+  where+    splitRecordPatSyn :: RecordPatSynField (Located Name)+                      -> (Name, Name)+    splitRecordPatSyn (RecordPatSynField+                       { recordPatSynPatVar     = (dL->L _ patVar)+                       , recordPatSynSelectorId = (dL->L _ selId) })+      = (patVar, selId)++addPatSynCtxt :: Located Name -> TcM a -> TcM a+addPatSynCtxt (dL->L loc name) thing_inside+  = setSrcSpan loc $+    addErrCtxt (text "In the declaration for pattern synonym"+                <+> quotes (ppr name)) $+    thing_inside++wrongNumberOfParmsErr :: Name -> Arity -> Arity -> TcM a+wrongNumberOfParmsErr name decl_arity missing+  = failWithTc $+    hang (text "Pattern synonym" <+> quotes (ppr name) <+> ptext (sLit "has")+          <+> speakNOf decl_arity (text "argument"))+       2 (text "but its type signature has" <+> int missing <+> text "fewer arrows")++-------------------------+-- Shared by both tcInferPatSyn and tcCheckPatSyn+tc_patsyn_finish :: Located Name      -- ^ PatSyn Name+                 -> HsPatSynDir GhcRn -- ^ PatSyn type (Uni/Bidir/ExplicitBidir)+                 -> Bool              -- ^ Whether infix+                 -> LPat GhcTc        -- ^ Pattern of the PatSyn+                 -> ([TcTyVarBinder], [PredType], TcEvBinds, [EvVar])+                 -> ([TcTyVarBinder], [TcType], [PredType], [EvTerm])+                 -> ([LHsExpr GhcTcId], [TcType])   -- ^ Pattern arguments and+                                                    -- types+                 -> TcType            -- ^ Pattern type+                 -> [Name]            -- ^ Selector names+                 -- ^ Whether fields, empty if not record PatSyn+                 -> TcM (LHsBinds GhcTc, TcGblEnv)+tc_patsyn_finish lname dir is_infix lpat'+                 (univ_tvs, req_theta, req_ev_binds, req_dicts)+                 (ex_tvs,   ex_tys,    prov_theta,   prov_dicts)+                 (args, arg_tys)+                 pat_ty field_labels+  = do { -- Zonk everything.  We are about to build a final PatSyn+         -- so there had better be no unification variables in there++         (ze, univ_tvs') <- zonkTyVarBinders univ_tvs+       ; req_theta'      <- zonkTcTypesToTypesX ze req_theta+       ; (ze, ex_tvs')   <- zonkTyVarBindersX ze ex_tvs+       ; prov_theta'     <- zonkTcTypesToTypesX ze prov_theta+       ; pat_ty'         <- zonkTcTypeToTypeX ze pat_ty+       ; arg_tys'        <- zonkTcTypesToTypesX ze arg_tys++       ; let (env1, univ_tvs) = tidyTyCoVarBinders emptyTidyEnv univ_tvs'+             (env2, ex_tvs)   = tidyTyCoVarBinders env1 ex_tvs'+             req_theta  = tidyTypes env2 req_theta'+             prov_theta = tidyTypes env2 prov_theta'+             arg_tys    = tidyTypes env2 arg_tys'+             pat_ty     = tidyType  env2 pat_ty'++       ; traceTc "tc_patsyn_finish {" $+           ppr (unLoc lname) $$ ppr (unLoc lpat') $$+           ppr (univ_tvs, req_theta, req_ev_binds, req_dicts) $$+           ppr (ex_tvs, prov_theta, prov_dicts) $$+           ppr args $$+           ppr arg_tys $$+           ppr pat_ty++       -- Make the 'matcher'+       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'+                                         (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts)+                                         (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts)+                                         (args, arg_tys)+                                         pat_ty++       -- Make the 'builder'+       ; builder_id <- mkPatSynBuilderId dir lname+                                         univ_tvs req_theta+                                         ex_tvs   prov_theta+                                         arg_tys pat_ty++         -- TODO: Make this have the proper information+       ; let mkFieldLabel name = FieldLabel { flLabel = occNameFS (nameOccName name)+                                            , flIsOverloaded = False+                                            , flSelector = name }+             field_labels' = map mkFieldLabel field_labels+++       -- Make the PatSyn itself+       ; let patSyn = mkPatSyn (unLoc lname) is_infix+                        (univ_tvs, req_theta)+                        (ex_tvs, prov_theta)+                        arg_tys+                        pat_ty+                        matcher_id builder_id+                        field_labels'++       -- Selectors+       ; let rn_rec_sel_binds = mkPatSynRecSelBinds patSyn (patSynFieldLabels patSyn)+             tything = AConLike (PatSynCon patSyn)+       ; tcg_env <- tcExtendGlobalEnv [tything] $+                    tcRecSelBinds rn_rec_sel_binds++       ; traceTc "tc_patsyn_finish }" empty+       ; return (matcher_bind, tcg_env) }++{-+************************************************************************+*                                                                      *+         Constructing the "matcher" Id and its binding+*                                                                      *+************************************************************************+-}++tcPatSynMatcher :: Located Name+                -> LPat GhcTc+                -> ([TcTyVar], ThetaType, TcEvBinds, [EvVar])+                -> ([TcTyVar], [TcType], ThetaType, [EvTerm])+                -> ([LHsExpr GhcTcId], [TcType])+                -> TcType+                -> TcM ((Id, Bool), LHsBinds GhcTc)+-- See Note [Matchers and builders for pattern synonyms] in PatSyn+tcPatSynMatcher (dL->L loc name) lpat+                (univ_tvs, req_theta, req_ev_binds, req_dicts)+                (ex_tvs, ex_tys, prov_theta, prov_dicts)+                (args, arg_tys) pat_ty+  = do { rr_name <- newNameAt (mkTyVarOcc "rep") loc+       ; tv_name <- newNameAt (mkTyVarOcc "r")   loc+       ; let rr_tv  = mkTyVar rr_name runtimeRepTy+             rr     = mkTyVarTy rr_tv+             res_tv = mkTyVar tv_name (tYPE rr)+             res_ty = mkTyVarTy res_tv+             is_unlifted = null args && null prov_dicts+             (cont_args, cont_arg_tys)+               | is_unlifted = ([nlHsVar voidPrimId], [voidPrimTy])+               | otherwise   = (args,                 arg_tys)+             cont_ty = mkInfSigmaTy ex_tvs prov_theta $+                       mkVisFunTys cont_arg_tys res_ty++             fail_ty  = mkVisFunTy voidPrimTy res_ty++       ; matcher_name <- newImplicitBinder name mkMatcherOcc+       ; scrutinee    <- newSysLocalId (fsLit "scrut") pat_ty+       ; cont         <- newSysLocalId (fsLit "cont")  cont_ty+       ; fail         <- newSysLocalId (fsLit "fail")  fail_ty++       ; let matcher_tau   = mkVisFunTys [pat_ty, cont_ty, fail_ty] res_ty+             matcher_sigma = mkInfSigmaTy (rr_tv:res_tv:univ_tvs) req_theta matcher_tau+             matcher_id    = mkExportedVanillaId matcher_name matcher_sigma+                             -- See Note [Exported LocalIds] in Id++             inst_wrap = mkWpEvApps prov_dicts <.> mkWpTyApps ex_tys+             cont' = foldl' nlHsApp (mkLHsWrap inst_wrap (nlHsVar cont)) cont_args++             fail' = nlHsApps fail [nlHsVar voidPrimId]++             args = map nlVarPat [scrutinee, cont, fail]+             lwpat = noLoc $ WildPat pat_ty+             cases = if isIrrefutableHsPat lpat+                     then [mkHsCaseAlt lpat  cont']+                     else [mkHsCaseAlt lpat  cont',+                           mkHsCaseAlt lwpat fail']+             body = mkLHsWrap (mkWpLet req_ev_binds) $+                    cL (getLoc lpat) $+                    HsCase noExt (nlHsVar scrutinee) $+                    MG{ mg_alts = cL (getLoc lpat) cases+                      , mg_ext = MatchGroupTc [pat_ty] res_ty+                      , mg_origin = Generated+                      }+             body' = noLoc $+                     HsLam noExt $+                     MG{ mg_alts = noLoc [mkSimpleMatch LambdaExpr+                                                        args body]+                       , mg_ext = MatchGroupTc [pat_ty, cont_ty, fail_ty] res_ty+                       , mg_origin = Generated+                       }+             match = mkMatch (mkPrefixFunRhs (cL loc name)) []+                             (mkHsLams (rr_tv:res_tv:univ_tvs)+                                       req_dicts body')+                             (noLoc (EmptyLocalBinds noExt))+             mg :: MatchGroup GhcTc (LHsExpr GhcTc)+             mg = MG{ mg_alts = cL (getLoc match) [match]+                    , mg_ext = MatchGroupTc [] res_ty+                    , mg_origin = Generated+                    }++       ; let bind = FunBind{ fun_ext = emptyNameSet+                           , fun_id = cL loc matcher_id+                           , fun_matches = mg+                           , fun_co_fn = idHsWrapper+                           , fun_tick = [] }+             matcher_bind = unitBag (noLoc bind)++       ; traceTc "tcPatSynMatcher" (ppr name $$ ppr (idType matcher_id))+       ; traceTc "tcPatSynMatcher" (ppr matcher_bind)++       ; return ((matcher_id, is_unlifted), matcher_bind) }++mkPatSynRecSelBinds :: PatSyn+                    -> [FieldLabel]  -- ^ Visible field labels+                    -> [(Id, LHsBind GhcRn)]+mkPatSynRecSelBinds ps fields+  = [ mkOneRecordSelector [PatSynCon ps] (RecSelPatSyn ps) fld_lbl+    | fld_lbl <- fields ]++isUnidirectional :: HsPatSynDir a -> Bool+isUnidirectional Unidirectional          = True+isUnidirectional ImplicitBidirectional   = False+isUnidirectional ExplicitBidirectional{} = False++{-+************************************************************************+*                                                                      *+         Constructing the "builder" Id+*                                                                      *+************************************************************************+-}++mkPatSynBuilderId :: HsPatSynDir a -> Located Name+                  -> [TyVarBinder] -> ThetaType+                  -> [TyVarBinder] -> ThetaType+                  -> [Type] -> Type+                  -> TcM (Maybe (Id, Bool))+mkPatSynBuilderId dir (dL->L _ name)+                  univ_bndrs req_theta ex_bndrs prov_theta+                  arg_tys pat_ty+  | isUnidirectional dir+  = return Nothing+  | otherwise+  = do { builder_name <- newImplicitBinder name mkBuilderOcc+       ; let theta          = req_theta ++ prov_theta+             need_dummy_arg = isUnliftedType pat_ty && null arg_tys && null theta+             builder_sigma  = add_void need_dummy_arg $+                              mkForAllTys univ_bndrs $+                              mkForAllTys ex_bndrs $+                              mkPhiTy theta $+                              mkVisFunTys arg_tys $+                              pat_ty+             builder_id     = mkExportedVanillaId builder_name builder_sigma+              -- See Note [Exported LocalIds] in Id++             builder_id'    = modifyIdInfo (`setLevityInfoWithType` pat_ty) builder_id++       ; return (Just (builder_id', need_dummy_arg)) }+  where++tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn+                    -> TcM (LHsBinds GhcTc)+-- See Note [Matchers and builders for pattern synonyms] in PatSyn+tcPatSynBuilderBind (PSB { psb_id = (dL->L loc name)+                         , psb_def = lpat+                         , psb_dir = dir+                         , psb_args = details })+  | isUnidirectional dir+  = return emptyBag++  | Left why <- mb_match_group       -- Can't invert the pattern+  = setSrcSpan (getLoc lpat) $ failWithTc $+    vcat [ hang (text "Invalid right-hand side of bidirectional pattern synonym"+                 <+> quotes (ppr name) <> colon)+              2 why+         , text "RHS pattern:" <+> ppr lpat ]++  | Right match_group <- mb_match_group  -- Bidirectional+  = do { patsyn <- tcLookupPatSyn name+       ; case patSynBuilder patsyn of {+           Nothing -> return emptyBag ;+             -- This case happens if we found a type error in the+             -- pattern synonym, recovered, and put a placeholder+             -- with patSynBuilder=Nothing in the environment++           Just (builder_id, need_dummy_arg) ->  -- Normal case+    do { -- Bidirectional, so patSynBuilder returns Just+         let match_group' | need_dummy_arg = add_dummy_arg match_group+                          | otherwise      = match_group++             bind = FunBind { fun_ext = placeHolderNamesTc+                            , fun_id      = cL loc (idName builder_id)+                            , fun_matches = match_group'+                            , fun_co_fn   = idHsWrapper+                            , fun_tick    = [] }++             sig = completeSigFromId (PatSynCtxt name) builder_id++       ; traceTc "tcPatSynBuilderBind {" $+         ppr patsyn $$ ppr builder_id <+> dcolon <+> ppr (idType builder_id)+       ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind)+       ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds+       ; return builder_binds } } }++  | otherwise = panic "tcPatSynBuilderBind"  -- Both cases dealt with+  where+    mb_match_group+       = case dir of+           ExplicitBidirectional explicit_mg -> Right explicit_mg+           ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat)+           Unidirectional -> panic "tcPatSynBuilderBind"++    mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)+    mk_mg body = mkMatchGroup Generated [builder_match]+          where+            builder_args  = [cL loc (VarPat noExt (cL loc n))+                            | (dL->L loc n) <- args]+            builder_match = mkMatch (mkPrefixFunRhs (cL loc name))+                                    builder_args body+                                    (noLoc (EmptyLocalBinds noExt))++    args = case details of+              PrefixCon args     -> args+              InfixCon arg1 arg2 -> [arg1, arg2]+              RecCon args        -> map recordPatSynPatVar args++    add_dummy_arg :: MatchGroup GhcRn (LHsExpr GhcRn)+                  -> MatchGroup GhcRn (LHsExpr GhcRn)+    add_dummy_arg mg@(MG { mg_alts =+                           (dL->L l [dL->L loc+                                           match@(Match { m_pats = pats })]) })+      = mg { mg_alts = cL l [cL loc (match { m_pats = nlWildPatName : pats })] }+    add_dummy_arg other_mg = pprPanic "add_dummy_arg" $+                             pprMatches other_mg+tcPatSynBuilderBind (XPatSynBind _) = panic "tcPatSynBuilderBind"++tcPatSynBuilderOcc :: PatSyn -> TcM (HsExpr GhcTcId, TcSigmaType)+-- monadic only for failure+tcPatSynBuilderOcc ps+  | Just (builder_id, add_void_arg) <- builder+  , let builder_expr = HsConLikeOut noExt (PatSynCon ps)+        builder_ty   = idType builder_id+  = return $+    if add_void_arg+    then ( builder_expr   -- still just return builder_expr; the void# arg is added+                          -- by dsConLike in the desugarer+         , tcFunResultTy builder_ty )+    else (builder_expr, builder_ty)++  | otherwise  -- Unidirectional+  = nonBidirectionalErr name+  where+    name    = patSynName ps+    builder = patSynBuilder ps++add_void :: Bool -> Type -> Type+add_void need_dummy_arg ty+  | need_dummy_arg = mkVisFunTy voidPrimTy ty+  | otherwise      = ty++tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn+            -> Either MsgDoc (LHsExpr GhcRn)+-- Given a /pattern/, return an /expression/ that builds a value+-- that matches the pattern.  E.g. if the pattern is (Just [x]),+-- the expression is (Just [x]).  They look the same, but the+-- input uses constructors from HsPat and the output uses constructors+-- from HsExpr.+--+-- Returns (Left r) if the pattern is not invertible, for reason r.+-- See Note [Builder for a bidirectional pattern synonym]+tcPatToExpr name args pat = go pat+  where+    lhsVars = mkNameSet (map unLoc args)++    -- Make a prefix con for prefix and infix patterns for simplicity+    mkPrefixConExpr :: Located Name -> [LPat GhcRn]+                    -> Either MsgDoc (HsExpr GhcRn)+    mkPrefixConExpr lcon@(dL->L loc _) pats+      = do { exprs <- mapM go pats+           ; return (foldl' (\x y -> HsApp noExt (cL loc x) y)+                            (HsVar noExt lcon) exprs) }++    mkRecordConExpr :: Located Name -> HsRecFields GhcRn (LPat GhcRn)+                    -> Either MsgDoc (HsExpr GhcRn)+    mkRecordConExpr con fields+      = do { exprFields <- mapM go fields+           ; return (RecordCon noExt con exprFields) }++    go :: LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)+    go (dL->L loc p) = cL loc <$> go1 p++    go1 :: Pat GhcRn -> Either MsgDoc (HsExpr GhcRn)+    go1 (ConPatIn con info)+      = case info of+          PrefixCon ps  -> mkPrefixConExpr con ps+          InfixCon l r  -> mkPrefixConExpr con [l,r]+          RecCon fields -> mkRecordConExpr con fields++    go1 (SigPat _ pat _) = go1 (unLoc pat)+        -- See Note [Type signatures and the builder expression]++    go1 (VarPat _ (dL->L l var))+        | var `elemNameSet` lhsVars+        = return $ HsVar noExt (cL l var)+        | otherwise+        = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")+    go1 (ParPat _ pat)          = fmap (HsPar noExt) $ go pat+    go1 p@(ListPat reb pats)+      | Nothing <- reb = do { exprs <- mapM go pats+                            ; return $ ExplicitList noExt Nothing exprs }+      | otherwise                   = notInvertibleListPat p+    go1 (TuplePat _ pats box)       = do { exprs <- mapM go pats+                                         ; return $ ExplicitTuple noExt+                                           (map (noLoc . (Present noExt)) exprs)+                                                                           box }+    go1 (SumPat _ pat alt arity)    = do { expr <- go1 (unLoc pat)+                                         ; return $ ExplicitSum noExt alt arity+                                                                   (noLoc expr)+                                         }+    go1 (LitPat _ lit)              = return $ HsLit noExt lit+    go1 (NPat _ (dL->L _ n) mb_neg _)+        | Just neg <- mb_neg        = return $ unLoc $ nlHsSyntaxApps neg+                                                     [noLoc (HsOverLit noExt n)]+        | otherwise                 = return $ HsOverLit noExt n+    go1 (ConPatOut{})               = panic "ConPatOut in output of renamer"+    go1 (CoPat{})                   = panic "CoPat in output of renamer"+    go1 (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))+                                    = go1 pat+    go1 (SplicePat _ (HsSpliced{})) = panic "Invalid splice variety"+    go1 (SplicePat _ (HsSplicedT{})) = panic "Invalid splice variety"++    -- The following patterns are not invertible.+    go1 p@(BangPat {})                       = notInvertible p -- #14112+    go1 p@(LazyPat {})                       = notInvertible p+    go1 p@(WildPat {})                       = notInvertible p+    go1 p@(AsPat {})                         = notInvertible p+    go1 p@(ViewPat {})                       = notInvertible p+    go1 p@(NPlusKPat {})                     = notInvertible p+    go1 p@(XPat {})                          = notInvertible p+    go1 p@(SplicePat _ (HsTypedSplice {}))   = notInvertible p+    go1 p@(SplicePat _ (HsUntypedSplice {})) = notInvertible p+    go1 p@(SplicePat _ (HsQuasiQuote {}))    = notInvertible p+    go1 p@(SplicePat _ (XSplice {}))         = notInvertible p++    notInvertible p = Left (not_invertible_msg p)++    not_invertible_msg p+      =   text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"+      $+$ hang (text "Suggestion: instead use an explicitly bidirectional"+                <+> text "pattern synonym, e.g.")+             2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow+                      <+> ppr pat <+> text "where")+                   2 (pp_name <+> pp_args <+> equals <+> text "..."))+      where+        pp_name = ppr name+        pp_args = hsep (map ppr args)++    -- We should really be able to invert list patterns, even when+    -- rebindable syntax is on, but doing so involves a bit of+    -- refactoring; see #14380.  Until then we reject with a+    -- helpful error message.+    notInvertibleListPat p+      = Left (vcat [ not_invertible_msg p+                   , text "Reason: rebindable syntax is on."+                   , text "This is fixable: add use-case to #14380" ])++{- Note [Builder for a bidirectional pattern synonym]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For a bidirectional pattern synonym we need to produce an /expression/+that matches the supplied /pattern/, given values for the arguments+of the pattern synonym.  For example+  pattern F x y = (Just x, [y])+The 'builder' for F looks like+  $builderF x y = (Just x, [y])++We can't always do this:+ * Some patterns aren't invertible; e.g. view patterns+      pattern F x = (reverse -> x:_)++ * The RHS pattern might bind more variables than the pattern+   synonym, so again we can't invert it+      pattern F x = (x,y)++ * Ditto wildcards+      pattern F x = (x,_)+++Note [Redundant constraints for builder]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The builder can have redundant constraints, which are awkard to eliminate.+Consider+   pattern P = Just 34+To match against this pattern we need (Eq a, Num a).  But to build+(Just 34) we need only (Num a).  Fortunately instTcSigFromId sets+sig_warn_redundant to False.++************************************************************************+*                                                                      *+         Helper functions+*                                                                      *+************************************************************************++Note [As-patterns in pattern synonym definitions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The rationale for rejecting as-patterns in pattern synonym definitions+is that an as-pattern would introduce nonindependent pattern synonym+arguments, e.g. given a pattern synonym like:++        pattern K x y = x@(Just y)++one could write a nonsensical function like++        f (K Nothing x) = ...++or+        g (K (Just True) False) = ...++Note [Type signatures and the builder expression]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   pattern L x = Left x :: Either [a] [b]++In tc{Infer/Check}PatSynDecl we will check that the pattern has the+specified type.  We check the pattern *as a pattern*, so the type+signature is a pattern signature, and so brings 'a' and 'b' into+scope.  But we don't have a way to bind 'a, b' in the LHS, as we do+'x', say.  Nevertheless, the sigature may be useful to constrain+the type.++When making the binding for the *builder*, though, we don't want+  $buildL x = Left x :: Either [a] [b]+because that wil either mean (forall a b. Either [a] [b]), or we'll+get a complaint that 'a' and 'b' are out of scope. (Actually the+latter; #9867.)  No, the job of the signature is done, so when+converting the pattern to an expression (for the builder RHS) we+simply discard the signature.++Note [Record PatSyn Desugaring]+-------------------------------+It is important that prov_theta comes before req_theta as this ordering is used+when desugaring record pattern synonym updates.++Any change to this ordering should make sure to change deSugar/DsExpr.hs if you+want to avoid difficult to decipher core lint errors!+ -}+++nonBidirectionalErr :: Outputable name => name -> TcM a+nonBidirectionalErr name = failWithTc $+    text "non-bidirectional pattern synonym"+    <+> quotes (ppr name) <+> text "used in an expression"++-- Walk the whole pattern and for all ConPatOuts, collect the+-- existentially-bound type variables and evidence binding variables.+--+-- These are used in computing the type of a pattern synonym and also+-- in generating matcher functions, since success continuations need+-- to be passed these pattern-bound evidences.+tcCollectEx+  :: LPat GhcTc+  -> ( [TyVar]        -- Existentially-bound type variables+                      -- in correctly-scoped order; e.g. [ k:*, x:k ]+     , [EvVar] )      -- and evidence variables++tcCollectEx pat = go pat+  where+    go :: LPat GhcTc -> ([TyVar], [EvVar])+    go = go1 . unLoc++    go1 :: Pat GhcTc -> ([TyVar], [EvVar])+    go1 (LazyPat _ p)      = go p+    go1 (AsPat _ _ p)      = go p+    go1 (ParPat _ p)       = go p+    go1 (BangPat _ p)      = go p+    go1 (ListPat _ ps)     = mergeMany . map go $ ps+    go1 (TuplePat _ ps _)  = mergeMany . map go $ ps+    go1 (SumPat _ p _ _)   = go p+    go1 (ViewPat _ _ p)    = go p+    go1 con@ConPatOut{}    = merge (pat_tvs con, pat_dicts con) $+                              goConDetails $ pat_args con+    go1 (SigPat _ p _)     = go p+    go1 (CoPat _ _ p _)    = go1 p+    go1 (NPlusKPat _ n k _ geq subtract)+      = pprPanic "TODO: NPlusKPat" $ ppr n $$ ppr k $$ ppr geq $$ ppr subtract+    go1 _                   = empty++    goConDetails :: HsConPatDetails GhcTc -> ([TyVar], [EvVar])+    goConDetails (PrefixCon ps) = mergeMany . map go $ ps+    goConDetails (InfixCon p1 p2) = go p1 `merge` go p2+    goConDetails (RecCon HsRecFields{ rec_flds = flds })+      = mergeMany . map goRecFd $ flds++    goRecFd :: LHsRecField GhcTc (LPat GhcTc) -> ([TyVar], [EvVar])+    goRecFd (dL->L _ HsRecField{ hsRecFieldArg = p }) = go p++    merge (vs1, evs1) (vs2, evs2) = (vs1 ++ vs2, evs1 ++ evs2)+    mergeMany = foldr merge empty+    empty     = ([], [])
+ compiler/typecheck/TcPatSyn.hs-boot view
@@ -0,0 +1,16 @@+module TcPatSyn where++import HsSyn     ( PatSynBind, LHsBinds )+import TcRnTypes ( TcM, TcSigInfo )+import TcRnMonad ( TcGblEnv)+import Outputable ( Outputable )+import HsExtension ( GhcRn, GhcTc )+import Data.Maybe  ( Maybe )++tcPatSynDecl :: PatSynBind GhcRn GhcRn+             -> Maybe TcSigInfo+             -> TcM (LHsBinds GhcTc, TcGblEnv)++tcPatSynBuilderBind :: PatSynBind GhcRn GhcRn -> TcM (LHsBinds GhcTc)++nonBidirectionalErr :: Outputable name => name -> TcM a
+ compiler/typecheck/TcPluginM.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE CPP #-}+-- | This module provides an interface for typechecker plugins to+-- access select functions of the 'TcM', principally those to do with+-- reading parts of the state.+module TcPluginM (+#if defined(GHCI)+        -- * Basic TcPluginM functionality+        TcPluginM,+        tcPluginIO,+        tcPluginTrace,+        unsafeTcPluginTcM,++        -- * Finding Modules and Names+        FindResult(..),+        findImportedModule,+        lookupOrig,++        -- * Looking up Names in the typechecking environment+        tcLookupGlobal,+        tcLookupTyCon,+        tcLookupDataCon,+        tcLookupClass,+        tcLookup,+        tcLookupId,++        -- * Getting the TcM state+        getTopEnv,+        getEnvs,+        getInstEnvs,+        getFamInstEnvs,+        matchFam,++        -- * Type variables+        newUnique,+        newFlexiTyVar,+        isTouchableTcPluginM,++        -- * Zonking+        zonkTcType,+        zonkCt,++        -- * Creating constraints+        newWanted,+        newDerived,+        newGiven,+        newCoercionHole,++        -- * Manipulating evidence bindings+        newEvVar,+        setEvBind,+        getEvBindsTcPluginM+#endif+    ) where++#if defined(GHCI)+import GhcPrelude++import qualified TcRnMonad as TcM+import qualified TcSMonad  as TcS+import qualified TcEnv     as TcM+import qualified TcMType   as TcM+import qualified FamInst   as TcM+import qualified IfaceEnv+import qualified Finder++import FamInstEnv ( FamInstEnv )+import TcRnMonad  ( TcGblEnv, TcLclEnv, Ct, CtLoc, TcPluginM+                  , unsafeTcPluginTcM, getEvBindsTcPluginM+                  , liftIO, traceTc )+import TcMType    ( TcTyVar, TcType )+import TcEnv      ( TcTyThing )+import TcEvidence ( TcCoercion, CoercionHole, EvTerm(..)+                  , EvExpr, EvBind, mkGivenEvBind )+import TcRnTypes  ( CtEvidence(..) )+import Var        ( EvVar )++import Module+import Name+import TyCon+import DataCon+import Class+import HscTypes+import Outputable+import Type+import Id+import InstEnv+import FastString+import Unique+++-- | Perform some IO, typically to interact with an external tool.+tcPluginIO :: IO a -> TcPluginM a+tcPluginIO a = unsafeTcPluginTcM (liftIO a)++-- | Output useful for debugging the compiler.+tcPluginTrace :: String -> SDoc -> TcPluginM ()+tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)+++findImportedModule :: ModuleName -> Maybe FastString -> TcPluginM FindResult+findImportedModule mod_name mb_pkg = do+    hsc_env <- getTopEnv+    tcPluginIO $ Finder.findImportedModule hsc_env mod_name mb_pkg++lookupOrig :: Module -> OccName -> TcPluginM Name+lookupOrig mod = unsafeTcPluginTcM . IfaceEnv.lookupOrig mod+++tcLookupGlobal :: Name -> TcPluginM TyThing+tcLookupGlobal = unsafeTcPluginTcM . TcM.tcLookupGlobal++tcLookupTyCon :: Name -> TcPluginM TyCon+tcLookupTyCon = unsafeTcPluginTcM . TcM.tcLookupTyCon++tcLookupDataCon :: Name -> TcPluginM DataCon+tcLookupDataCon = unsafeTcPluginTcM . TcM.tcLookupDataCon++tcLookupClass :: Name -> TcPluginM Class+tcLookupClass = unsafeTcPluginTcM . TcM.tcLookupClass++tcLookup :: Name -> TcPluginM TcTyThing+tcLookup = unsafeTcPluginTcM . TcM.tcLookup++tcLookupId :: Name -> TcPluginM Id+tcLookupId = unsafeTcPluginTcM . TcM.tcLookupId+++getTopEnv :: TcPluginM HscEnv+getTopEnv = unsafeTcPluginTcM TcM.getTopEnv++getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)+getEnvs = unsafeTcPluginTcM TcM.getEnvs++getInstEnvs :: TcPluginM InstEnvs+getInstEnvs = unsafeTcPluginTcM TcM.tcGetInstEnvs++getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)+getFamInstEnvs = unsafeTcPluginTcM TcM.tcGetFamInstEnvs++matchFam :: TyCon -> [Type]+         -> TcPluginM (Maybe (TcCoercion, TcType))+matchFam tycon args = unsafeTcPluginTcM $ TcS.matchFamTcM tycon args++newUnique :: TcPluginM Unique+newUnique = unsafeTcPluginTcM TcM.newUnique++newFlexiTyVar :: Kind -> TcPluginM TcTyVar+newFlexiTyVar = unsafeTcPluginTcM . TcM.newFlexiTyVar++isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool+isTouchableTcPluginM = unsafeTcPluginTcM . TcM.isTouchableTcM++-- Confused by zonking? See Note [What is zonking?] in TcMType.+zonkTcType :: TcType -> TcPluginM TcType+zonkTcType = unsafeTcPluginTcM . TcM.zonkTcType++zonkCt :: Ct -> TcPluginM Ct+zonkCt = unsafeTcPluginTcM . TcM.zonkCt+++-- | Create a new wanted constraint.+newWanted  :: CtLoc -> PredType -> TcPluginM CtEvidence+newWanted loc pty+  = unsafeTcPluginTcM (TcM.newWanted (TcM.ctLocOrigin loc) Nothing pty)++-- | Create a new derived constraint.+newDerived :: CtLoc -> PredType -> TcPluginM CtEvidence+newDerived loc pty = return CtDerived { ctev_pred = pty, ctev_loc = loc }++-- | Create a new given constraint, with the supplied evidence.  This+-- must not be invoked from 'tcPluginInit' or 'tcPluginStop', or it+-- will panic.+newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM CtEvidence+newGiven loc pty evtm = do+   new_ev <- newEvVar pty+   setEvBind $ mkGivenEvBind new_ev (EvExpr evtm)+   return CtGiven { ctev_pred = pty, ctev_evar = new_ev, ctev_loc = loc }++-- | Create a fresh evidence variable.+newEvVar :: PredType -> TcPluginM EvVar+newEvVar = unsafeTcPluginTcM . TcM.newEvVar++-- | Create a fresh coercion hole.+newCoercionHole :: PredType -> TcPluginM CoercionHole+newCoercionHole = unsafeTcPluginTcM . TcM.newCoercionHole++-- | Bind an evidence variable.  This must not be invoked from+-- 'tcPluginInit' or 'tcPluginStop', or it will panic.+setEvBind :: EvBind -> TcPluginM ()+setEvBind ev_bind = do+    tc_evbinds <- getEvBindsTcPluginM+    unsafeTcPluginTcM $ TcM.addTcEvBind tc_evbinds ev_bind+#else+-- this dummy import is needed as a consequence of NoImplicitPrelude+import GhcPrelude ()+#endif
+ compiler/typecheck/TcRnDriver.hs view
@@ -0,0 +1,2916 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[TcRnDriver]{Typechecking a whole module}++https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/type-checker+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}++module TcRnDriver (+        tcRnStmt, tcRnExpr, TcRnExprMode(..), tcRnType,+        tcRnImportDecls,+        tcRnLookupRdrName,+        getModuleInterface,+        tcRnDeclsi,+        isGHCiMonad,+        runTcInteractive,    -- Used by GHC API clients (#8878)+        tcRnLookupName,+        tcRnGetInfo,+        tcRnModule, tcRnModuleTcRnM,+        tcTopSrcDecls,+        rnTopSrcDecls,+        checkBootDecl, checkHiBootIface',+        findExtraSigImports,+        implicitRequirements,+        checkUnitId,+        mergeSignatures,+        tcRnMergeSignatures,+        instantiateSignature,+        tcRnInstantiateSignature,+        loadUnqualIfaces,+        -- More private...+        badReexportedBootThing,+        checkBootDeclM,+        missingBootThing,+        getRenamedStuff, RenamedStuff+    ) where++import GhcPrelude++import {-# SOURCE #-} TcSplice ( finishTH, runRemoteModFinalizers )+import RnSplice ( rnTopSpliceDecls, traceSplice, SpliceInfo(..) )+import IfaceEnv( externaliseName )+import TcHsType+import TcValidity( checkValidType )+import TcMatches+import Inst( deeplyInstantiate )+import TcUnify( checkConstraints )+import RnTypes+import RnExpr+import RnUtils ( HsDocContext(..) )+import RnFixity ( lookupFixityRn )+import MkId+import TidyPgm    ( globaliseAndTidyId )+import TysWiredIn ( unitTy, mkListTy )+import Plugins+import DynFlags+import HsSyn+import IfaceSyn ( ShowSub(..), showToHeader )+import IfaceType( ShowForAllFlag(..) )+import PatSyn( pprPatSynType )+import PrelNames+import PrelInfo+import RdrName+import TcHsSyn+import TcExpr+import TcRnMonad+import TcRnExports+import TcEvidence+import qualified BooleanFormula as BF+import PprTyThing( pprTyThingInContext )+import CoreFVs( orphNamesOfFamInst )+import FamInst+import InstEnv+import FamInstEnv( FamInst, pprFamInst, famInstsRepTyCons+                 , famInstEnvElts, extendFamInstEnvList, normaliseType )+import TcAnnotations+import TcBinds+import MkIface          ( coAxiomToIfaceDecl )+import HeaderInfo       ( mkPrelImports )+import TcDefaults+import TcEnv+import TcRules+import TcForeign+import TcInstDcls+import TcIface+import TcMType+import TcType+import TcSimplify+import TcTyClsDecls+import TcTypeable ( mkTypeableBinds )+import TcBackpack+import LoadIface+import RnNames+import RnEnv+import RnSource+import ErrUtils+import Id+import IdInfo( IdDetails(..) )+import VarEnv+import Module+import UniqFM+import Name+import NameEnv+import NameSet+import Avail+import TyCon+import SrcLoc+import HscTypes+import ListSetOps+import Outputable+import ConLike+import DataCon+import Type+import Class+import BasicTypes hiding( SuccessFlag(..) )+import CoAxiom+import Annotations+import Data.List ( sortBy, sort )+import Data.Ord+import FastString+import Maybes+import Util+import Bag+import Inst (tcGetInsts)+import qualified GHC.LanguageExtensions as LangExt+import Data.Data ( Data )+import HsDumpAst+import qualified Data.Set as S++import Control.DeepSeq+import Control.Monad++#include "HsVersions.h"++{-+************************************************************************+*                                                                      *+        Typecheck and rename a module+*                                                                      *+************************************************************************+-}++-- | Top level entry point for typechecker and renamer+tcRnModule :: HscEnv+           -> ModSummary+           -> Bool              -- True <=> save renamed syntax+           -> HsParsedModule+           -> IO (Messages, Maybe TcGblEnv)++tcRnModule hsc_env mod_sum save_rn_syntax+   parsedModule@HsParsedModule {hpm_module= (dL->L loc this_module)}+ | RealSrcSpan real_loc <- loc+ = withTiming (pure dflags)+              (text "Renamer/typechecker"<+>brackets (ppr this_mod))+              (const ()) $+   initTc hsc_env hsc_src save_rn_syntax this_mod real_loc $+          withTcPlugins hsc_env $++          tcRnModuleTcRnM hsc_env mod_sum parsedModule pair++  | otherwise+  = return ((emptyBag, unitBag err_msg), Nothing)++  where+    hsc_src = ms_hsc_src mod_sum+    dflags = hsc_dflags hsc_env+    err_msg = mkPlainErrMsg (hsc_dflags hsc_env) loc $+              text "Module does not have a RealSrcSpan:" <+> ppr this_mod++    this_pkg = thisPackage (hsc_dflags hsc_env)++    pair :: (Module, SrcSpan)+    pair@(this_mod,_)+      | Just (dL->L mod_loc mod) <- hsmodName this_module+      = (mkModule this_pkg mod, mod_loc)++      | otherwise   -- 'module M where' is omitted+      = (mAIN, srcLocSpan (srcSpanStart loc))+++++tcRnModuleTcRnM :: HscEnv+                -> ModSummary+                -> HsParsedModule+                -> (Module, SrcSpan)+                -> TcRn TcGblEnv+-- Factored out separately from tcRnModule so that a Core plugin can+-- call the type checker directly+tcRnModuleTcRnM hsc_env mod_sum+                (HsParsedModule {+                   hpm_module =+                      (dL->L loc (HsModule maybe_mod export_ies+                                       import_decls local_decls mod_deprec+                                       maybe_doc_hdr)),+                   hpm_src_files = src_files+                })+                (this_mod, prel_imp_loc)+ = setSrcSpan loc $+   do { let { explicit_mod_hdr = isJust maybe_mod+            ; hsc_src          = ms_hsc_src mod_sum }+      ; -- Load the hi-boot interface for this module, if any+        -- We do this now so that the boot_names can be passed+        -- to tcTyAndClassDecls, because the boot_names are+        -- automatically considered to be loop breakers+        tcg_env <- getGblEnv+      ; boot_info <- tcHiBootIface hsc_src this_mod+      ; setGblEnv (tcg_env { tcg_self_boot = boot_info })+        $ do+        { -- Deal with imports; first add implicit prelude+          implicit_prelude <- xoptM LangExt.ImplicitPrelude+        ; let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc+                               implicit_prelude import_decls }++        ; whenWOptM Opt_WarnImplicitPrelude $+             when (notNull prel_imports) $+                addWarn (Reason Opt_WarnImplicitPrelude) (implicitPreludeWarn)++        ; -- TODO This is a little skeevy; maybe handle a bit more directly+          let { simplifyImport (dL->L _ idecl) =+                  ( fmap sl_fs (ideclPkgQual idecl) , ideclName idecl)+              }+        ; raw_sig_imports <- liftIO+                             $ findExtraSigImports hsc_env hsc_src+                                 (moduleName this_mod)+        ; raw_req_imports <- liftIO+                             $ implicitRequirements hsc_env+                                (map simplifyImport (prel_imports+                                                     ++ import_decls))+        ; let { mkImport (Nothing, dL->L _ mod_name) = noLoc+                $ (simpleImportDecl mod_name)+                  { ideclHiding = Just (False, noLoc [])}+              ; mkImport _ = panic "mkImport" }+        ; let { all_imports = prel_imports ++ import_decls+                       ++ map mkImport (raw_sig_imports ++ raw_req_imports) }+        ; -- OK now finally rename the imports+          tcg_env <- {-# SCC "tcRnImports" #-}+                     tcRnImports hsc_env all_imports++        ; -- If the whole module is warned about or deprecated+          -- (via mod_deprec) record that in tcg_warns. If we do thereby add+          -- a WarnAll, it will override any subsequent deprecations added to tcg_warns+          let { tcg_env1 = case mod_deprec of+                             Just (dL->L _ txt) ->+                               tcg_env {tcg_warns = WarnAll txt}+                             Nothing            -> tcg_env+              }+        ; setGblEnv tcg_env1+          $ do { -- Rename and type check the declarations+                 traceRn "rn1a" empty+               ; tcg_env <- if isHsBootOrSig hsc_src+                            then tcRnHsBootDecls hsc_src local_decls+                            else {-# SCC "tcRnSrcDecls" #-}+                                 tcRnSrcDecls explicit_mod_hdr local_decls+               ; setGblEnv tcg_env+                 $ do { -- Process the export list+                        traceRn "rn4a: before exports" empty+                      ; tcg_env <- tcRnExports explicit_mod_hdr export_ies+                                     tcg_env+                      ; traceRn "rn4b: after exports" empty+                      ; -- Check main is exported(must be after tcRnExports)+                        checkMainExported tcg_env+                      ; -- Compare hi-boot iface (if any) with the real thing+                        -- Must be done after processing the exports+                        tcg_env <- checkHiBootIface tcg_env boot_info+                      ; -- The new type env is already available to stuff+                        -- slurped from interface files, via+                        -- TcEnv.setGlobalTypeEnv. It's important that this+                        -- includes the stuff in checkHiBootIface,+                        -- because the latter might add new bindings for+                        -- boot_dfuns, which may be mentioned in imported+                        -- unfoldings.++                        -- Don't need to rename the Haddock documentation,+                        -- it's not parsed by GHC anymore.+                        tcg_env <- return (tcg_env+                                           { tcg_doc_hdr = maybe_doc_hdr })+                      ; -- Report unused names+                        -- Do this /after/ typeinference, so that when reporting+                        -- a function with no type signature we can give the+                        -- inferred type+                        reportUnusedNames export_ies tcg_env+                      ; -- add extra source files to tcg_dependent_files+                        addDependentFiles src_files+                      ; tcg_env <- runTypecheckerPlugin mod_sum hsc_env tcg_env+                      ; -- Dump output and return+                        tcDump tcg_env+                      ; return tcg_env }+               }+        }+      }++implicitPreludeWarn :: SDoc+implicitPreludeWarn+  = text "Module `Prelude' implicitly imported"++{-+************************************************************************+*                                                                      *+                Import declarations+*                                                                      *+************************************************************************+-}++tcRnImports :: HscEnv -> [LImportDecl GhcPs] -> TcM TcGblEnv+tcRnImports hsc_env import_decls+  = do  { (rn_imports, rdr_env, imports, hpc_info) <- rnImports import_decls ;++        ; this_mod <- getModule+        ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)+              ; dep_mods = imp_dep_mods imports++                -- We want instance declarations from all home-package+                -- modules below this one, including boot modules, except+                -- ourselves.  The 'except ourselves' is so that we don't+                -- get the instances from this module's hs-boot file.  This+                -- filtering also ensures that we don't see instances from+                -- modules batch (@--make@) compiled before this one, but+                -- which are not below this one.+              ; want_instances :: ModuleName -> Bool+              ; want_instances mod = mod `elemUFM` dep_mods+                                   && mod /= moduleName this_mod+              ; (home_insts, home_fam_insts) = hptInstances hsc_env+                                                            want_instances+              } ;++                -- Record boot-file info in the EPS, so that it's+                -- visible to loadHiBootInterface in tcRnSrcDecls,+                -- and any other incrementally-performed imports+        ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;++                -- Update the gbl env+        ; updGblEnv ( \ gbl ->+            gbl {+              tcg_rdr_env      = tcg_rdr_env gbl `plusGlobalRdrEnv` rdr_env,+              tcg_imports      = tcg_imports gbl `plusImportAvails` imports,+              tcg_rn_imports   = rn_imports,+              tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,+              tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)+                                                      home_fam_insts,+              tcg_hpc          = hpc_info+            }) $ do {++        ; traceRn "rn1" (ppr (imp_dep_mods imports))+                -- Fail if there are any errors so far+                -- The error printing (if needed) takes advantage+                -- of the tcg_env we have now set+--      ; traceIf (text "rdr_env: " <+> ppr rdr_env)+        ; failIfErrsM++                -- Load any orphan-module (including orphan family+                -- instance-module) interfaces, so that their rules and+                -- instance decls will be found.  But filter out a+                -- self hs-boot: these instances will be checked when+                -- we define them locally.+                -- (We don't need to load non-orphan family instance+                -- modules until we either try to use the instances they+                -- define, or define our own family instances, at which+                -- point we need to check them for consistency.)+        ; loadModuleInterfaces (text "Loading orphan modules")+                               (filter (/= this_mod) (imp_orphs imports))++                -- Check type-family consistency between imports.+                -- See Note [The type family instance consistency story]+        ; traceRn "rn1: checking family instance consistency {" empty+        ; let { dir_imp_mods = moduleEnvKeys+                             . imp_mods+                             $ imports }+        ; checkFamInstConsistency dir_imp_mods+        ; traceRn "rn1: } checking family instance consistency" empty++        ; getGblEnv } }++{-+************************************************************************+*                                                                      *+        Type-checking the top level of a module+*                                                                      *+************************************************************************+-}++tcRnSrcDecls :: Bool  -- False => no 'module M(..) where' header at all+             -> [LHsDecl GhcPs]               -- Declarations+             -> TcM TcGblEnv+tcRnSrcDecls explicit_mod_hdr decls+ = do { -- Do all the declarations+      ; (tcg_env, tcl_env, lie) <- tc_rn_src_decls decls++        -- Check for the 'main' declaration+        -- Must do this inside the captureTopConstraints+        -- NB: always set envs *before* captureTopConstraints+      ; (tcg_env, lie_main) <- setEnvs (tcg_env, tcl_env) $+                               captureTopConstraints $+                               checkMain explicit_mod_hdr++      ; setEnvs (tcg_env, tcl_env) $ do {++             --         Simplify constraints+             --+             -- We do this after checkMain, so that we use the type info+             -- that checkMain adds+             --+             -- We do it with both global and local env in scope:+             --  * the global env exposes the instances to simplifyTop+             --  * the local env exposes the local Ids to simplifyTop,+             --    so that we get better error messages (monomorphism restriction)+      ; new_ev_binds <- {-# SCC "simplifyTop" #-}+                        simplifyTop (lie `andWC` lie_main)++        -- Emit Typeable bindings+      ; tcg_env <- mkTypeableBinds+++      ; traceTc "Tc9" empty++      ; failIfErrsM     -- Don't zonk if there have been errors+                        -- It's a waste of time; and we may get debug warnings+                        -- about strangely-typed TyCons!+      ; traceTc "Tc10" empty++        -- Zonk the final code.  This must be done last.+        -- Even simplifyTop may do some unification.+        -- This pass also warns about missing type signatures+      ; (bind_env, ev_binds', binds', fords', imp_specs', rules')+            <- zonkTcGblEnv new_ev_binds tcg_env++        -- Finalizers must run after constraints are simplified, or some types+        -- might not be complete when using reify (see #12777).+        -- and also after we zonk the first time because we run typed splices+        -- in the zonker which gives rise to the finalisers.+      ; (tcg_env_mf, _) <- setGblEnv (clearTcGblEnv tcg_env)+                                     run_th_modfinalizers+      ; finishTH+      ; traceTc "Tc11" empty++      ; -- zonk the new bindings arising from running the finalisers.+        -- This won't give rise to any more finalisers as you can't nest+        -- finalisers inside finalisers.+      ; (bind_env_mf, ev_binds_mf, binds_mf, fords_mf, imp_specs_mf, rules_mf)+            <- zonkTcGblEnv emptyBag tcg_env_mf+++      ; let { final_type_env = plusTypeEnv (tcg_type_env tcg_env)+                                (plusTypeEnv bind_env_mf bind_env)+            ; tcg_env' = tcg_env_mf+                          { tcg_binds    = binds' `unionBags` binds_mf,+                            tcg_ev_binds = ev_binds' `unionBags` ev_binds_mf ,+                            tcg_imp_specs = imp_specs' ++ imp_specs_mf ,+                            tcg_rules    = rules' ++ rules_mf ,+                            tcg_fords    = fords' ++ fords_mf } } ;++      ; setGlobalTypeEnv tcg_env' final_type_env++   } }++zonkTcGblEnv :: Bag EvBind -> TcGblEnv+             -> TcM (TypeEnv, Bag EvBind, LHsBinds GhcTc,+                       [LForeignDecl GhcTc], [LTcSpecPrag], [LRuleDecl GhcTc])+zonkTcGblEnv new_ev_binds tcg_env =+  let TcGblEnv {   tcg_binds     = binds,+                   tcg_ev_binds  = cur_ev_binds,+                   tcg_imp_specs = imp_specs,+                   tcg_rules     = rules,+                   tcg_fords     = fords } = tcg_env++      all_ev_binds = cur_ev_binds `unionBags` new_ev_binds++  in {-# SCC "zonkTopDecls" #-}+      zonkTopDecls all_ev_binds binds rules imp_specs fords+++-- | Remove accumulated bindings, rules and so on from TcGblEnv+clearTcGblEnv :: TcGblEnv -> TcGblEnv+clearTcGblEnv tcg_env+  = tcg_env { tcg_binds    = emptyBag,+              tcg_ev_binds = emptyBag ,+              tcg_imp_specs = [],+              tcg_rules    = [],+              tcg_fords    = [] }++-- | Runs TH finalizers and renames and typechecks the top-level declarations+-- that they could introduce.+run_th_modfinalizers :: TcM (TcGblEnv, TcLclEnv)+run_th_modfinalizers = do+  th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv+  th_modfinalizers <- readTcRef th_modfinalizers_var+  if null th_modfinalizers+  then getEnvs+  else do+    writeTcRef th_modfinalizers_var []+    let run_finalizer (lcl_env, f) =+            setLclEnv lcl_env (runRemoteModFinalizers f)++    (_, lie_th) <- captureTopConstraints $+                   mapM_ run_finalizer th_modfinalizers++      -- Finalizers can add top-level declarations with addTopDecls, so+      -- we have to run tc_rn_src_decls to get them+    (tcg_env, tcl_env, lie_top_decls) <- tc_rn_src_decls []++    setEnvs (tcg_env, tcl_env) $ do+      -- Subsequent rounds of finalizers run after any new constraints are+      -- simplified, or some types might not be complete when using reify+      -- (see #12777).+      new_ev_binds <- {-# SCC "simplifyTop2" #-}+                      simplifyTop (lie_th `andWC` lie_top_decls)+      addTopEvBinds new_ev_binds run_th_modfinalizers+        -- addTopDecls can add declarations which add new finalizers.++tc_rn_src_decls :: [LHsDecl GhcPs]+                -> TcM (TcGblEnv, TcLclEnv, WantedConstraints)+-- Loops around dealing with each top level inter-splice group+-- in turn, until it's dealt with the entire module+-- Never emits constraints; calls captureTopConstraints internally+tc_rn_src_decls ds+ = {-# SCC "tc_rn_src_decls" #-}+   do { (first_group, group_tail) <- findSplice ds+                -- If ds is [] we get ([], Nothing)++        -- Deal with decls up to, but not including, the first splice+      ; (tcg_env, rn_decls) <- rnTopSrcDecls first_group+                -- rnTopSrcDecls fails if there are any errors++        -- Get TH-generated top-level declarations and make sure they don't+        -- contain any splices since we don't handle that at the moment+        --+        -- The plumbing here is a bit odd: see #10853+      ; th_topdecls_var <- fmap tcg_th_topdecls getGblEnv+      ; th_ds <- readTcRef th_topdecls_var+      ; writeTcRef th_topdecls_var []++      ; (tcg_env, rn_decls) <-+            if null th_ds+            then return (tcg_env, rn_decls)+            else do { (th_group, th_group_tail) <- findSplice th_ds+                    ; case th_group_tail of+                        { Nothing -> return ()+                        ; Just (SpliceDecl _ (dL->L loc _) _, _) ->+                            setSrcSpan loc+                            $ addErr (text+                                ("Declaration splices are not "+                                  ++ "permitted inside top-level "+                                  ++ "declarations added with addTopDecls"))+                        ; Just (XSpliceDecl _, _) -> panic "tc_rn_src_decls"+                        }+                      -- Rename TH-generated top-level declarations+                    ; (tcg_env, th_rn_decls) <- setGblEnv tcg_env+                        $ rnTopSrcDecls th_group++                      -- Dump generated top-level declarations+                    ; let msg = "top-level declarations added with addTopDecls"+                    ; traceSplice+                        $ SpliceInfo { spliceDescription = msg+                                     , spliceIsDecl    = True+                                     , spliceSource    = Nothing+                                     , spliceGenerated = ppr th_rn_decls }+                    ; return (tcg_env, appendGroups rn_decls th_rn_decls)+                    }++      -- Type check all declarations+      -- NB: set the env **before** captureTopConstraints so that error messages+      -- get reported w.r.t. the right GlobalRdrEnv. It is for this reason that+      -- the captureTopConstraints must go here, not in tcRnSrcDecls.+      ; ((tcg_env, tcl_env), lie1) <- setGblEnv tcg_env $+                                      captureTopConstraints $+                                      tcTopSrcDecls rn_decls++        -- If there is no splice, we're nearly done+      ; setEnvs (tcg_env, tcl_env) $+        case group_tail of+          { Nothing -> return (tcg_env, tcl_env, lie1)++            -- If there's a splice, we must carry on+          ; Just (SpliceDecl _ (dL->L loc splice) _, rest_ds) ->+            do { recordTopLevelSpliceLoc loc++                 -- Rename the splice expression, and get its supporting decls+               ; (spliced_decls, splice_fvs) <- rnTopSpliceDecls splice++                 -- Glue them on the front of the remaining decls and loop+               ; (tcg_env, tcl_env, lie2) <-+                   setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $+                   tc_rn_src_decls (spliced_decls ++ rest_ds)++               ; return (tcg_env, tcl_env, lie1 `andWC` lie2)+               }+          ; Just (XSpliceDecl _, _) -> panic "tc_rn_src_decls"+          }+      }++{-+************************************************************************+*                                                                      *+        Compiling hs-boot source files, and+        comparing the hi-boot interface with the real thing+*                                                                      *+************************************************************************+-}++tcRnHsBootDecls :: HscSource -> [LHsDecl GhcPs] -> TcM TcGblEnv+tcRnHsBootDecls hsc_src decls+   = do { (first_group, group_tail) <- findSplice decls++                -- Rename the declarations+        ; (tcg_env, HsGroup { hs_tyclds = tycl_decls+                            , hs_derivds = deriv_decls+                            , hs_fords  = for_decls+                            , hs_defds  = def_decls+                            , hs_ruleds = rule_decls+                            , hs_annds  = _+                            , hs_valds  = XValBindsLR (NValBinds val_binds val_sigs) })+              <- rnTopSrcDecls first_group++        -- The empty list is for extra dependencies coming from .hs-boot files+        -- See Note [Extra dependencies from .hs-boot files] in RnSource++        ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do {+              -- NB: setGblEnv **before** captureTopConstraints so that+              -- if the latter reports errors, it knows what's in scope++                -- Check for illegal declarations+        ; case group_tail of+             Just (SpliceDecl _ d _, _) -> badBootDecl hsc_src "splice" d+             Just (XSpliceDecl _, _) -> panic "tcRnHsBootDecls"+             Nothing                  -> return ()+        ; mapM_ (badBootDecl hsc_src "foreign") for_decls+        ; mapM_ (badBootDecl hsc_src "default") def_decls+        ; mapM_ (badBootDecl hsc_src "rule")    rule_decls++                -- Typecheck type/class/instance decls+        ; traceTc "Tc2 (boot)" empty+        ; (tcg_env, inst_infos, _deriv_binds)+             <- tcTyClsInstDecls tycl_decls deriv_decls val_binds+        ; setGblEnv tcg_env     $ do {++        -- Emit Typeable bindings+        ; tcg_env <- mkTypeableBinds+        ; setGblEnv tcg_env $ do {++                -- Typecheck value declarations+        ; traceTc "Tc5" empty+        ; val_ids <- tcHsBootSigs val_binds val_sigs++                -- Wrap up+                -- No simplification or zonking to do+        ; traceTc "Tc7a" empty+        ; gbl_env <- getGblEnv++                -- Make the final type-env+                -- Include the dfun_ids so that their type sigs+                -- are written into the interface file.+        ; let { type_env0 = tcg_type_env gbl_env+              ; type_env1 = extendTypeEnvWithIds type_env0 val_ids+              ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids+              ; dfun_ids = map iDFunId inst_infos+              }++        ; setGlobalTypeEnv gbl_env type_env2+   }}}+   ; traceTc "boot" (ppr lie); return gbl_env }++badBootDecl :: HscSource -> String -> Located decl -> TcM ()+badBootDecl hsc_src what (dL->L loc _)+  = addErrAt loc (char 'A' <+> text what+      <+> text "declaration is not (currently) allowed in a"+      <+> (case hsc_src of+            HsBootFile -> text "hs-boot"+            HsigFile -> text "hsig"+            _ -> panic "badBootDecl: should be an hsig or hs-boot file")+      <+> text "file")++{-+Once we've typechecked the body of the module, we want to compare what+we've found (gathered in a TypeEnv) with the hi-boot details (if any).+-}++checkHiBootIface :: TcGblEnv -> SelfBootInfo -> TcM TcGblEnv+-- Compare the hi-boot file for this module (if there is one)+-- with the type environment we've just come up with+-- In the common case where there is no hi-boot file, the list+-- of boot_names is empty.++checkHiBootIface tcg_env boot_info+  | NoSelfBoot <- boot_info  -- Common case+  = return tcg_env++  | HsBootFile <- tcg_src tcg_env   -- Current module is already a hs-boot file!+  = return tcg_env++  | SelfBoot { sb_mds = boot_details } <- boot_info+  , TcGblEnv { tcg_binds    = binds+             , tcg_insts    = local_insts+             , tcg_type_env = local_type_env+             , tcg_exports  = local_exports } <- tcg_env+  = do  { -- This code is tricky, see Note [DFun knot-tying]+        ; dfun_prs <- checkHiBootIface' local_insts local_type_env+                                        local_exports boot_details++        -- Now add the boot-dfun bindings  $fxblah = $fblah+        -- to (a) the type envt, and (b) the top-level bindings+        ; let boot_dfuns = map fst dfun_prs+              type_env'  = extendTypeEnvWithIds local_type_env boot_dfuns+              dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)+                                     | (boot_dfun, dfun) <- dfun_prs ]+              tcg_env_w_binds+                = tcg_env { tcg_binds = binds `unionBags` dfun_binds }++        ; type_env' `seq`+             -- Why the seq?  Without, we will put a TypeEnv thunk in+             -- tcg_type_env_var.  That thunk will eventually get+             -- forced if we are typechecking interfaces, but that+             -- is no good if we are trying to typecheck the very+             -- DFun we were going to put in.+             -- TODO: Maybe setGlobalTypeEnv should be strict.+          setGlobalTypeEnv tcg_env_w_binds type_env' }++  | otherwise = panic "checkHiBootIface: unreachable code"++{- Note [DFun impedance matching]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We return a list of "impedance-matching" bindings for the dfuns+defined in the hs-boot file, such as+          $fxEqT = $fEqT+We need these because the module and hi-boot file might differ in+the name it chose for the dfun: the name of a dfun is not+uniquely determined by its type; there might be multiple dfuns+which, individually, would map to the same name (in which case+we have to disambiguate them.)  There's no way for the hi file+to know exactly what disambiguation to use... without looking+at the hi-boot file itself.++In fact, the names will always differ because we always pick names+prefixed with "$fx" for boot dfuns, and "$f" for real dfuns+(so that this impedance matching is always possible).++Note [DFun knot-tying]+~~~~~~~~~~~~~~~~~~~~~~+The 'SelfBootInfo' that is fed into 'checkHiBootIface' comes from+typechecking the hi-boot file that we are presently implementing.+Suppose we are typechecking the module A: when we typecheck the+hi-boot file, whenever we see an identifier A.T, we knot-tie this+identifier to the *local* type environment (via if_rec_types.)  The+contract then is that we don't *look* at 'SelfBootInfo' until we've+finished typechecking the module and updated the type environment with+the new tycons and ids.++This most works well, but there is one problem: DFuns!  We do not want+to look at the mb_insts of the ModDetails in SelfBootInfo, because a+dfun in one of those ClsInsts is gotten (in TcIface.tcIfaceInst) by a+(lazily evaluated) lookup in the if_rec_types.  We could extend the+type env, do a setGloblaTypeEnv etc; but that all seems very indirect.+It is much more directly simply to extract the DFunIds from the+md_types of the SelfBootInfo.++See #4003, #16038 for why we need to take care here.+-}++checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]+                  -> ModDetails -> TcM [(Id, Id)]+-- Variant which doesn't require a full TcGblEnv; you could get the+-- local components from another ModDetails.+checkHiBootIface'+        local_insts local_type_env local_exports+        (ModDetails { md_types = boot_type_env+                    , md_fam_insts = boot_fam_insts+                    , md_exports = boot_exports })+  = do  { traceTc "checkHiBootIface" $ vcat+             [ ppr boot_type_env, ppr boot_exports]++                -- Check the exports of the boot module, one by one+        ; mapM_ check_export boot_exports++                -- Check for no family instances+        ; unless (null boot_fam_insts) $+            panic ("TcRnDriver.checkHiBootIface: Cannot handle family " +++                   "instances in boot files yet...")+            -- FIXME: Why?  The actual comparison is not hard, but what would+            --        be the equivalent to the dfun bindings returned for class+            --        instances?  We can't easily equate tycons...++                -- Check instance declarations+                -- and generate an impedance-matching binding+        ; mb_dfun_prs <- mapM check_cls_inst boot_dfuns++        ; failIfErrsM++        ; return (catMaybes mb_dfun_prs) }++  where+    boot_dfun_names = map idName boot_dfuns+    boot_dfuns      = filter isDFunId $ typeEnvIds boot_type_env+       -- NB: boot_dfuns is /not/ defined thus: map instanceDFunId md_insts+       --     We don't want to look at md_insts!+       --     Why not?  See Note [DFun knot-tying]++    check_export boot_avail     -- boot_avail is exported by the boot iface+      | name `elem` boot_dfun_names = return ()+      | isWiredInName name          = return () -- No checking for wired-in names.  In particular,+                                                -- 'error' is handled by a rather gross hack+                                                -- (see comments in GHC.Err.hs-boot)++        -- Check that the actual module exports the same thing+      | not (null missing_names)+      = addErrAt (nameSrcSpan (head missing_names))+                 (missingBootThing True (head missing_names) "exported by")++        -- If the boot module does not *define* the thing, we are done+        -- (it simply re-exports it, and names match, so nothing further to do)+      | isNothing mb_boot_thing = return ()++        -- Check that the actual module also defines the thing, and+        -- then compare the definitions+      | Just real_thing <- lookupTypeEnv local_type_env name,+        Just boot_thing <- mb_boot_thing+      = checkBootDeclM True boot_thing real_thing++      | otherwise+      = addErrTc (missingBootThing True name "defined in")+      where+        name          = availName boot_avail+        mb_boot_thing = lookupTypeEnv boot_type_env name+        missing_names = case lookupNameEnv local_export_env name of+                          Nothing    -> [name]+                          Just avail -> availNames boot_avail `minusList` availNames avail++    local_export_env :: NameEnv AvailInfo+    local_export_env = availsToNameEnv local_exports++    check_cls_inst :: DFunId -> TcM (Maybe (Id, Id))+        -- Returns a pair of the boot dfun in terms of the equivalent+        -- real dfun. Delicate (like checkBootDecl) because it depends+        -- on the types lining up precisely even to the ordering of+        -- the type variables in the foralls.+    check_cls_inst boot_dfun+      | (real_dfun : _) <- find_real_dfun boot_dfun+      , let local_boot_dfun = Id.mkExportedVanillaId+                                  (idName boot_dfun) (idType real_dfun)+      = return (Just (local_boot_dfun, real_dfun))+          -- Two tricky points here:+          --+          --  * The local_boot_fun should have a Name from the /boot-file/,+          --    but type from the dfun defined in /this module/.+          --    That ensures that the TyCon etc inside the type are+          --    the ones defined in this module, not the ones gotten+          --    from the hi-boot file, which may have a lot less info+          --    (#8743, comment:10).+          --+          --  * The DFunIds from boot_details are /GlobalIds/, because+          --    they come from typechecking M.hi-boot.+          --    But all bindings in this module should be for /LocalIds/,+          --    otherwise dependency analysis fails (#16038). This+          --    is another reason for using mkExportedVanillaId, rather+          --    that modifying boot_dfun, to make local_boot_fun.++      | otherwise+      = setSrcSpan (getLoc (getName boot_dfun)) $+        do { traceTc "check_cls_inst" $ vcat+                [ text "local_insts"  <+>+                     vcat (map (ppr . idType . instanceDFunId) local_insts)+                , text "boot_dfun_ty" <+> ppr (idType boot_dfun) ]++           ; addErrTc (instMisMatch boot_dfun)+           ; return Nothing }++    find_real_dfun :: DFunId -> [DFunId]+    find_real_dfun boot_dfun+       = [dfun | inst <- local_insts+               , let dfun = instanceDFunId inst+               , idType dfun `eqType` boot_dfun_ty ]+       where+          boot_dfun_ty   = idType boot_dfun+++-- In general, to perform these checks we have to+-- compare the TyThing from the .hi-boot file to the TyThing+-- in the current source file.  We must be careful to allow alpha-renaming+-- where appropriate, and also the boot declaration is allowed to omit+-- constructors and class methods.+--+-- See rnfail055 for a good test of this stuff.++-- | Compares two things for equivalence between boot-file and normal code,+-- reporting an error if they don't match up.+checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)+               -> TyThing -> TyThing -> TcM ()+checkBootDeclM is_boot boot_thing real_thing+  = whenIsJust (checkBootDecl is_boot boot_thing real_thing) $ \ err ->+       addErrAt span+                (bootMisMatch is_boot err real_thing boot_thing)+  where+    -- Here we use the span of the boot thing or, if it doesn't have a sensible+    -- span, that of the real thing,+    span+      | let span = nameSrcSpan (getName boot_thing)+      , isGoodSrcSpan span+      = span+      | otherwise+      = nameSrcSpan (getName real_thing)++-- | Compares the two things for equivalence between boot-file and normal+-- code. Returns @Nothing@ on success or @Just "some helpful info for user"@+-- failure. If the difference will be apparent to the user, @Just empty@ is+-- perfectly suitable.+checkBootDecl :: Bool -> TyThing -> TyThing -> Maybe SDoc++checkBootDecl _ (AnId id1) (AnId id2)+  = ASSERT(id1 == id2)+    check (idType id1 `eqType` idType id2)+          (text "The two types are different")++checkBootDecl is_boot (ATyCon tc1) (ATyCon tc2)+  = checkBootTyCon is_boot tc1 tc2++checkBootDecl _ (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _))+  = pprPanic "checkBootDecl" (ppr dc1)++checkBootDecl _ _ _ = Just empty -- probably shouldn't happen++-- | Combines two potential error messages+andThenCheck :: Maybe SDoc -> Maybe SDoc -> Maybe SDoc+Nothing `andThenCheck` msg     = msg+msg     `andThenCheck` Nothing = msg+Just d1 `andThenCheck` Just d2 = Just (d1 $$ d2)+infixr 0 `andThenCheck`++-- | If the test in the first parameter is True, succeed with @Nothing@;+-- otherwise, return the provided check+checkUnless :: Bool -> Maybe SDoc -> Maybe SDoc+checkUnless True  _ = Nothing+checkUnless False k = k++-- | Run the check provided for every pair of elements in the lists.+-- The provided SDoc should name the element type, in the plural.+checkListBy :: (a -> a -> Maybe SDoc) -> [a] -> [a] -> SDoc+            -> Maybe SDoc+checkListBy check_fun as bs whats = go [] as bs+  where+    herald = text "The" <+> whats <+> text "do not match"++    go []   [] [] = Nothing+    go docs [] [] = Just (hang (herald <> colon) 2 (vcat $ reverse docs))+    go docs (x:xs) (y:ys) = case check_fun x y of+      Just doc -> go (doc:docs) xs ys+      Nothing  -> go docs       xs ys+    go _    _  _ = Just (hang (herald <> colon)+                            2 (text "There are different numbers of" <+> whats))++-- | If the test in the first parameter is True, succeed with @Nothing@;+-- otherwise, fail with the given SDoc.+check :: Bool -> SDoc -> Maybe SDoc+check True  _   = Nothing+check False doc = Just doc++-- | A more perspicuous name for @Nothing@, for @checkBootDecl@ and friends.+checkSuccess :: Maybe SDoc+checkSuccess = Nothing++----------------+checkBootTyCon :: Bool -> TyCon -> TyCon -> Maybe SDoc+checkBootTyCon is_boot tc1 tc2+  | not (eqType (tyConKind tc1) (tyConKind tc2))+  = Just $ text "The types have different kinds"    -- First off, check the kind++  | Just c1 <- tyConClass_maybe tc1+  , Just c2 <- tyConClass_maybe tc2+  , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1)+          = classExtraBigSig c1+        (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2)+          = classExtraBigSig c2+  , Just env <- eqVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2+  = let+       eqSig (id1, def_meth1) (id2, def_meth2)+         = check (name1 == name2)+                 (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>+                  text "are different") `andThenCheck`+           check (eqTypeX env op_ty1 op_ty2)+                 (text "The types of" <+> pname1 <+>+                  text "are different") `andThenCheck`+           if is_boot+               then check (eqMaybeBy eqDM def_meth1 def_meth2)+                          (text "The default methods associated with" <+> pname1 <+>+                           text "are different")+               else check (subDM op_ty1 def_meth1 def_meth2)+                          (text "The default methods associated with" <+> pname1 <+>+                           text "are not compatible")+         where+          name1 = idName id1+          name2 = idName id2+          pname1 = quotes (ppr name1)+          pname2 = quotes (ppr name2)+          (_, rho_ty1) = splitForAllTys (idType id1)+          op_ty1 = funResultTy rho_ty1+          (_, rho_ty2) = splitForAllTys (idType id2)+          op_ty2 = funResultTy rho_ty2++       eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2)+         = checkBootTyCon is_boot tc1 tc2 `andThenCheck`+           check (eqATDef def_ats1 def_ats2)+                 (text "The associated type defaults differ")++       eqDM (_, VanillaDM)    (_, VanillaDM)    = True+       eqDM (_, GenericDM t1) (_, GenericDM t2) = eqTypeX env t1 t2+       eqDM _ _ = False++       -- NB: first argument is from hsig, second is from real impl.+       -- Order of pattern matching matters.+       subDM _ Nothing _ = True+       subDM _ _ Nothing = False+       -- If the hsig wrote:+       --+       --   f :: a -> a+       --   default f :: a -> a+       --+       -- this should be validly implementable using an old-fashioned+       -- vanilla default method.+       subDM t1 (Just (_, GenericDM t2)) (Just (_, VanillaDM))+        = eqTypeX env t1 t2+       -- This case can occur when merging signatures+       subDM t1 (Just (_, VanillaDM)) (Just (_, GenericDM t2))+        = eqTypeX env t1 t2+       subDM _ (Just (_, VanillaDM)) (Just (_, VanillaDM)) = True+       subDM _ (Just (_, GenericDM t1)) (Just (_, GenericDM t2))+        = eqTypeX env t1 t2++       -- Ignore the location of the defaults+       eqATDef Nothing             Nothing             = True+       eqATDef (Just (ty1, _loc1)) (Just (ty2, _loc2)) = eqTypeX env ty1 ty2+       eqATDef _ _ = False++       eqFD (as1,bs1) (as2,bs2) =+         eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&+         eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)+    in+    checkRoles roles1 roles2 `andThenCheck`+          -- Checks kind of class+    check (eqListBy eqFD clas_fds1 clas_fds2)+          (text "The functional dependencies do not match") `andThenCheck`+    checkUnless (isAbstractTyCon tc1) $+    check (eqListBy (eqTypeX env) sc_theta1 sc_theta2)+          (text "The class constraints do not match") `andThenCheck`+    checkListBy eqSig op_stuff1 op_stuff2 (text "methods") `andThenCheck`+    checkListBy eqAT ats1 ats2 (text "associated types") `andThenCheck`+    check (classMinimalDef c1 `BF.implies` classMinimalDef c2)+        (text "The MINIMAL pragmas are not compatible")++  | Just syn_rhs1 <- synTyConRhs_maybe tc1+  , Just syn_rhs2 <- synTyConRhs_maybe tc2+  , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)+  = ASSERT(tc1 == tc2)+    checkRoles roles1 roles2 `andThenCheck`+    check (eqTypeX env syn_rhs1 syn_rhs2) empty   -- nothing interesting to say+  -- This allows abstract 'data T a' to be implemented using 'type T = ...'+  -- and abstract 'class K a' to be implement using 'type K = ...'+  -- See Note [Synonyms implement abstract data]+  | not is_boot -- don't support for hs-boot yet+  , isAbstractTyCon tc1+  , Just (tvs, ty) <- synTyConDefn_maybe tc2+  , Just (tc2', args) <- tcSplitTyConApp_maybe ty+  = checkSynAbsData tvs ty tc2' args+    -- TODO: When it's a synonym implementing a class, we really+    -- should check if the fundeps are satisfied, but+    -- there is not an obvious way to do this for a constraint synonym.+    -- So for now, let it all through (it won't cause segfaults, anyway).+    -- Tracked at #12704.++  -- This allows abstract 'data T :: Nat' to be implemented using+  -- 'type T = 42' Since the kinds already match (we have checked this+  -- upfront) all we need to check is that the implementation 'type T+  -- = ...' defined an actual literal.  See #15138 for the case this+  -- handles.+  | not is_boot+  , isAbstractTyCon tc1+  , Just (_,ty2) <- synTyConDefn_maybe tc2+  , isJust (isLitTy ty2)+  = Nothing++  | Just fam_flav1 <- famTyConFlav_maybe tc1+  , Just fam_flav2 <- famTyConFlav_maybe tc2+  = ASSERT(tc1 == tc2)+    let eqFamFlav OpenSynFamilyTyCon   OpenSynFamilyTyCon = True+        eqFamFlav (DataFamilyTyCon {}) (DataFamilyTyCon {}) = True+        -- This case only happens for hsig merging:+        eqFamFlav AbstractClosedSynFamilyTyCon AbstractClosedSynFamilyTyCon = True+        eqFamFlav AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True+        eqFamFlav (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True+        eqFamFlav (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)+            = eqClosedFamilyAx ax1 ax2+        eqFamFlav (BuiltInSynFamTyCon {}) (BuiltInSynFamTyCon {}) = tc1 == tc2+        eqFamFlav _ _ = False+        injInfo1 = tyConInjectivityInfo tc1+        injInfo2 = tyConInjectivityInfo tc2+    in+    -- check equality of roles, family flavours and injectivity annotations+    -- (NB: Type family roles are always nominal. But the check is+    -- harmless enough.)+    checkRoles roles1 roles2 `andThenCheck`+    check (eqFamFlav fam_flav1 fam_flav2)+        (whenPprDebug $+            text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+>+            text "do not match") `andThenCheck`+    check (injInfo1 == injInfo2) (text "Injectivities do not match")++  | isAlgTyCon tc1 && isAlgTyCon tc2+  , Just env <- eqVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)+  = ASSERT(tc1 == tc2)+    checkRoles roles1 roles2 `andThenCheck`+    check (eqListBy (eqTypeX env)+                     (tyConStupidTheta tc1) (tyConStupidTheta tc2))+          (text "The datatype contexts do not match") `andThenCheck`+    eqAlgRhs tc1 (algTyConRhs tc1) (algTyConRhs tc2)++  | otherwise = Just empty   -- two very different types -- should be obvious+  where+    roles1 = tyConRoles tc1 -- the abstract one+    roles2 = tyConRoles tc2+    roles_msg = text "The roles do not match." $$+                (text "Roles on abstract types default to" <+>+                 quotes (text "representational") <+> text "in boot files.")++    roles_subtype_msg = text "The roles are not compatible:" $$+                        text "Main module:" <+> ppr roles2 $$+                        text "Hsig file:" <+> ppr roles1++    checkRoles r1 r2+      | is_boot || isInjectiveTyCon tc1 Representational -- See Note [Role subtyping]+      = check (r1 == r2) roles_msg+      | otherwise = check (r2 `rolesSubtypeOf` r1) roles_subtype_msg++    -- Note [Role subtyping]+    -- ~~~~~~~~~~~~~~~~~~~~~+    -- In the current formulation of roles, role subtyping is only OK if the+    -- "abstract" TyCon was not representationally injective.  Among the most+    -- notable examples of non representationally injective TyCons are abstract+    -- data, which can be implemented via newtypes (which are not+    -- representationally injective).  The key example is+    -- in this example from #13140:+    --+    --      -- In an hsig file+    --      data T a -- abstract!+    --      type role T nominal+    --+    --      -- Elsewhere+    --      foo :: Coercible (T a) (T b) => a -> b+    --      foo x = x+    --+    -- We must NOT allow foo to typecheck, because if we instantiate+    -- T with a concrete data type with a phantom role would cause+    -- Coercible (T a) (T b) to be provable.  Fortunately, if T is not+    -- representationally injective, we cannot make the inference that a ~N b if+    -- T a ~R T b.+    --+    -- Unconditional role subtyping would be possible if we setup+    -- an extra set of roles saying when we can project out coercions+    -- (we call these proj-roles); then it would NOT be valid to instantiate T+    -- with a data type at phantom since the proj-role subtyping check+    -- would fail.  See #13140 for more details.+    --+    -- One consequence of this is we get no role subtyping for non-abstract+    -- data types in signatures. Suppose you have:+    --+    --      signature A where+    --          type role T nominal+    --          data T a = MkT+    --+    -- If you write this, we'll treat T as injective, and make inferences+    -- like T a ~R T b ==> a ~N b (mkNthCo).  But if we can+    -- subsequently replace T with one at phantom role, we would then be able to+    -- infer things like T Int ~R T Bool which is bad news.+    --+    -- We could allow role subtyping here if we didn't treat *any* data types+    -- defined in signatures as injective.  But this would be a bit surprising,+    -- replacing a data type in a module with one in a signature could cause+    -- your code to stop typechecking (whereas if you made the type abstract,+    -- it is more understandable that the type checker knows less).+    --+    -- It would have been best if this was purely a question of defaults+    -- (i.e., a user could explicitly ask for one behavior or another) but+    -- the current role system isn't expressive enough to do this.+    -- Having explict proj-roles would solve this problem.++    rolesSubtypeOf [] [] = True+    -- NB: this relation is the OPPOSITE of the subroling relation+    rolesSubtypeOf (x:xs) (y:ys) = x >= y && rolesSubtypeOf xs ys+    rolesSubtypeOf _ _ = False++    -- Note [Synonyms implement abstract data]+    -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    -- An abstract data type or class can be implemented using a type synonym,+    -- but ONLY if the type synonym is nullary and has no type family+    -- applications.  This arises from two properties of skolem abstract data:+    --+    --    For any T (with some number of paramaters),+    --+    --    1. T is a valid type (it is "curryable"), and+    --+    --    2. T is valid in an instance head (no type families).+    --+    -- See also 'HowAbstract' and Note [Skolem abstract data].++    -- | Given @type T tvs = ty@, where @ty@ decomposes into @tc2' args@,+    -- check that this synonym is an acceptable implementation of @tc1@.+    -- See Note [Synonyms implement abstract data]+    checkSynAbsData :: [TyVar] -> Type -> TyCon -> [Type] -> Maybe SDoc+    checkSynAbsData tvs ty tc2' args =+        check (null (tcTyFamInsts ty))+              (text "Illegal type family application in implementation of abstract data.")+                `andThenCheck`+        check (null tvs)+              (text "Illegal parameterized type synonym in implementation of abstract data." $$+               text "(Try eta reducing your type synonym so that it is nullary.)")+                `andThenCheck`+        -- Don't report roles errors unless the type synonym is nullary+        checkUnless (not (null tvs)) $+            ASSERT( null roles2 )+            -- If we have something like:+            --+            --  signature H where+            --      data T a+            --  module H where+            --      data K a b = ...+            --      type T = K Int+            --+            -- we need to drop the first role of K when comparing!+            checkRoles roles1 (drop (length args) (tyConRoles tc2'))+{-+        -- Hypothetically, if we were allow to non-nullary type synonyms, here+        -- is how you would check the roles+        if length tvs == length roles1+            then checkRoles roles1 roles2+            else case tcSplitTyConApp_maybe ty of+                    Just (tc2', args) ->+                        checkRoles roles1 (drop (length args) (tyConRoles tc2') ++ roles2)+                    Nothing -> Just roles_msg+-}++    eqAlgRhs _ AbstractTyCon _rhs2+      = checkSuccess -- rhs2 is guaranteed to be injective, since it's an AlgTyCon+    eqAlgRhs _  tc1@DataTyCon{} tc2@DataTyCon{} =+        checkListBy eqCon (data_cons tc1) (data_cons tc2) (text "constructors")+    eqAlgRhs _  tc1@NewTyCon{} tc2@NewTyCon{} =+        eqCon (data_con tc1) (data_con tc2)+    eqAlgRhs _ _ _ = Just (text "Cannot match a" <+> quotes (text "data") <+>+                           text "definition with a" <+> quotes (text "newtype") <+>+                           text "definition")++    eqCon c1 c2+      =  check (name1 == name2)+               (text "The names" <+> pname1 <+> text "and" <+> pname2 <+>+                text "differ") `andThenCheck`+         check (dataConIsInfix c1 == dataConIsInfix c2)+               (text "The fixities of" <+> pname1 <+>+                text "differ") `andThenCheck`+         check (eqListBy eqHsBang (dataConImplBangs c1) (dataConImplBangs c2))+               (text "The strictness annotations for" <+> pname1 <+>+                text "differ") `andThenCheck`+         check (map flSelector (dataConFieldLabels c1) == map flSelector (dataConFieldLabels c2))+               (text "The record label lists for" <+> pname1 <+>+                text "differ") `andThenCheck`+         check (eqType (dataConUserType c1) (dataConUserType c2))+               (text "The types for" <+> pname1 <+> text "differ")+      where+        name1 = dataConName c1+        name2 = dataConName c2+        pname1 = quotes (ppr name1)+        pname2 = quotes (ppr name2)++    eqClosedFamilyAx Nothing Nothing  = True+    eqClosedFamilyAx Nothing (Just _) = False+    eqClosedFamilyAx (Just _) Nothing = False+    eqClosedFamilyAx (Just (CoAxiom { co_ax_branches = branches1 }))+                     (Just (CoAxiom { co_ax_branches = branches2 }))+      =  numBranches branches1 == numBranches branches2+      && (and $ zipWith eqClosedFamilyBranch branch_list1 branch_list2)+      where+        branch_list1 = fromBranches branches1+        branch_list2 = fromBranches branches2++    eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_cvs = cvs1+                                     , cab_lhs = lhs1, cab_rhs = rhs1 })+                         (CoAxBranch { cab_tvs = tvs2, cab_cvs = cvs2+                                     , cab_lhs = lhs2, cab_rhs = rhs2 })+      | Just env1 <- eqVarBndrs emptyRnEnv2 tvs1 tvs2+      , Just env  <- eqVarBndrs env1        cvs1 cvs2+      = eqListBy (eqTypeX env) lhs1 lhs2 &&+        eqTypeX env rhs1 rhs2++      | otherwise = False++emptyRnEnv2 :: RnEnv2+emptyRnEnv2 = mkRnEnv2 emptyInScopeSet++----------------+missingBootThing :: Bool -> Name -> String -> SDoc+missingBootThing is_boot name what+  = quotes (ppr name) <+> text "is exported by the"+    <+> (if is_boot then text "hs-boot" else text "hsig")+    <+> text "file, but not"+    <+> text what <+> text "the module"++badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc+badReexportedBootThing dflags is_boot name name'+  = withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $ vcat+        [ text "The" <+> (if is_boot then text "hs-boot" else text "hsig")+           <+> text "file (re)exports" <+> quotes (ppr name)+        , text "but the implementing module exports a different identifier" <+> quotes (ppr name')+        ]++bootMisMatch :: Bool -> SDoc -> TyThing -> TyThing -> SDoc+bootMisMatch is_boot extra_info real_thing boot_thing+  = pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc+  where+    to_doc+      = pprTyThingInContext $ showToHeader { ss_forall =+                                              if is_boot+                                                then ShowForAllMust+                                                else ShowForAllWhen }++    real_doc = to_doc real_thing+    boot_doc = to_doc boot_thing++    pprBootMisMatch :: Bool -> SDoc -> TyThing -> SDoc -> SDoc -> SDoc+    pprBootMisMatch is_boot extra_info real_thing real_doc boot_doc+      = vcat+          [ ppr real_thing <+>+            text "has conflicting definitions in the module",+            text "and its" <+>+              (if is_boot+                then text "hs-boot file"+                else text "hsig file"),+            text "Main module:" <+> real_doc,+              (if is_boot+                then text "Boot file:  "+                else text "Hsig file: ")+                <+> boot_doc,+            extra_info+          ]++instMisMatch :: DFunId -> SDoc+instMisMatch dfun+  = hang (text "instance" <+> ppr (idType dfun))+       2 (text "is defined in the hs-boot file, but not in the module itself")++{-+************************************************************************+*                                                                      *+        Type-checking the top level of a module (continued)+*                                                                      *+************************************************************************+-}++rnTopSrcDecls :: HsGroup GhcPs -> TcM (TcGblEnv, HsGroup GhcRn)+-- Fails if there are any errors+rnTopSrcDecls group+ = do { -- Rename the source decls+        traceRn "rn12" empty ;+        (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;+        traceRn "rn13" empty ;+        (tcg_env, rn_decls) <- runRenamerPlugin tcg_env rn_decls ;+        traceRn "rn13-plugin" empty ;++        -- save the renamed syntax, if we want it+        let { tcg_env'+                | Just grp <- tcg_rn_decls tcg_env+                  = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }+                | otherwise+                   = tcg_env };++                -- Dump trace of renaming part+        rnDump rn_decls ;+        return (tcg_env', rn_decls)+   }++tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv)+tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,+                         hs_derivds = deriv_decls,+                         hs_fords  = foreign_decls,+                         hs_defds  = default_decls,+                         hs_annds  = annotation_decls,+                         hs_ruleds = rule_decls,+                         hs_valds  = hs_val_binds@(XValBindsLR+                                              (NValBinds val_binds val_sigs)) })+ = do {         -- Type-check the type and class decls, and all imported decls+                -- The latter come in via tycl_decls+        traceTc "Tc2 (src)" empty ;++                -- Source-language instances, including derivings,+                -- and import the supporting declarations+        traceTc "Tc3" empty ;+        (tcg_env, inst_infos, XValBindsLR (NValBinds deriv_binds deriv_sigs))+            <- tcTyClsInstDecls tycl_decls deriv_decls val_binds ;++        setGblEnv tcg_env       $ do {++                -- Generate Applicative/Monad proposal (AMP) warnings+        traceTc "Tc3b" empty ;++                -- Generate Semigroup/Monoid warnings+        traceTc "Tc3c" empty ;+        tcSemigroupWarnings ;++                -- Foreign import declarations next.+        traceTc "Tc4" empty ;+        (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;+        tcExtendGlobalValEnv fi_ids     $ do {++                -- Default declarations+        traceTc "Tc4a" empty ;+        default_tys <- tcDefaults default_decls ;+        updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {++                -- Value declarations next.+                -- It is important that we check the top-level value bindings+                -- before the GHC-generated derived bindings, since the latter+                -- may be defined in terms of the former. (For instance,+                -- the bindings produced in a Data instance.)+        traceTc "Tc5" empty ;+        tc_envs <- tcTopBinds val_binds val_sigs;+        setEnvs tc_envs $ do {++                -- Now GHC-generated derived bindings, generics, and selectors+                -- Do not generate warnings from compiler-generated code;+                -- hence the use of discardWarnings+        tc_envs@(tcg_env, tcl_env)+            <- discardWarnings (tcTopBinds deriv_binds deriv_sigs) ;+        setEnvs tc_envs $ do {  -- Environment doesn't change now++                -- Second pass over class and instance declarations,+                -- now using the kind-checked decls+        traceTc "Tc6" empty ;+        inst_binds <- tcInstDecls2 (tyClGroupTyClDecls tycl_decls) inst_infos ;++                -- Foreign exports+        traceTc "Tc7" empty ;+        (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ;++                -- Annotations+        annotations <- tcAnnotations annotation_decls ;++                -- Rules+        rules <- tcRules rule_decls ;++                -- Wrap up+        traceTc "Tc7a" empty ;+        let { all_binds = inst_binds     `unionBags`+                          foe_binds++            ; fo_gres = fi_gres `unionBags` foe_gres+            ; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre)+                                emptyFVs fo_gres++            ; sig_names = mkNameSet (collectHsValBinders hs_val_binds)+                          `minusNameSet` getTypeSigNames val_sigs++                -- Extend the GblEnv with the (as yet un-zonked)+                -- bindings, rules, foreign decls+            ; tcg_env' = tcg_env { tcg_binds   = tcg_binds tcg_env `unionBags` all_binds+                                 , tcg_sigs    = tcg_sigs tcg_env `unionNameSet` sig_names+                                 , tcg_rules   = tcg_rules tcg_env+                                                      ++ flattenRuleDecls rules+                                 , tcg_anns    = tcg_anns tcg_env ++ annotations+                                 , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations+                                 , tcg_fords   = tcg_fords tcg_env ++ foe_decls ++ fi_decls+                                 , tcg_dus     = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ;+                                 -- tcg_dus: see Note [Newtype constructor usage in foreign declarations]++        -- See Note [Newtype constructor usage in foreign declarations]+        addUsedGREs (bagToList fo_gres) ;++        return (tcg_env', tcl_env)+    }}}}}}++tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn"+++tcSemigroupWarnings :: TcM ()+tcSemigroupWarnings = do+    traceTc "tcSemigroupWarnings" empty+    let warnFlag = Opt_WarnSemigroup+    tcPreludeClashWarn warnFlag sappendName+    tcMissingParentClassWarn warnFlag monoidClassName semigroupClassName+++-- | Warn on local definitions of names that would clash with future Prelude+-- elements.+--+--   A name clashes if the following criteria are met:+--       1. It would is imported (unqualified) from Prelude+--       2. It is locally defined in the current module+--       3. It has the same literal name as the reference function+--       4. It is not identical to the reference function+tcPreludeClashWarn :: WarningFlag+                   -> Name+                   -> TcM ()+tcPreludeClashWarn warnFlag name = do+    { warn <- woptM warnFlag+    ; when warn $ do+    { traceTc "tcPreludeClashWarn/wouldBeImported" empty+    -- Is the name imported (unqualified) from Prelude? (Point 4 above)+    ; rnImports <- fmap (map unLoc . tcg_rn_imports) getGblEnv+    -- (Note that this automatically handles -XNoImplicitPrelude, as Prelude+    -- will not appear in rnImports automatically if it is set.)++    -- Continue only the name is imported from Prelude+    ; when (importedViaPrelude name rnImports) $ do+      -- Handle 2.-4.+    { rdrElts <- fmap (concat . occEnvElts . tcg_rdr_env) getGblEnv++    ; let clashes :: GlobalRdrElt -> Bool+          clashes x = isLocalDef && nameClashes && isNotInProperModule+            where+              isLocalDef = gre_lcl x == True+              -- Names are identical ...+              nameClashes = nameOccName (gre_name x) == nameOccName name+              -- ... but not the actual definitions, because we don't want to+              -- warn about a bad definition of e.g. <> in Data.Semigroup, which+              -- is the (only) proper place where this should be defined+              isNotInProperModule = gre_name x /= name++          -- List of all offending definitions+          clashingElts :: [GlobalRdrElt]+          clashingElts = filter clashes rdrElts++    ; traceTc "tcPreludeClashWarn/prelude_functions"+                (hang (ppr name) 4 (sep [ppr clashingElts]))++    ; let warn_msg x = addWarnAt (Reason warnFlag) (nameSrcSpan (gre_name x)) (hsep+              [ text "Local definition of"+              , (quotes . ppr . nameOccName . gre_name) x+              , text "clashes with a future Prelude name." ]+              $$+              text "This will become an error in a future release." )+    ; mapM_ warn_msg clashingElts+    }}}++  where++    -- Is the given name imported via Prelude?+    --+    -- Possible scenarios:+    --   a) Prelude is imported implicitly, issue warnings.+    --   b) Prelude is imported explicitly, but without mentioning the name in+    --      question. Issue no warnings.+    --   c) Prelude is imported hiding the name in question. Issue no warnings.+    --   d) Qualified import of Prelude, no warnings.+    importedViaPrelude :: Name+                       -> [ImportDecl GhcRn]+                       -> Bool+    importedViaPrelude name = any importViaPrelude+      where+        isPrelude :: ImportDecl GhcRn -> Bool+        isPrelude imp = unLoc (ideclName imp) == pRELUDE_NAME++        -- Implicit (Prelude) import?+        isImplicit :: ImportDecl GhcRn -> Bool+        isImplicit = ideclImplicit++        -- Unqualified import?+        isUnqualified :: ImportDecl GhcRn -> Bool+        isUnqualified = not . isImportDeclQualified . ideclQualified++        -- List of explicitly imported (or hidden) Names from a single import.+        --   Nothing -> No explicit imports+        --   Just (False, <names>) -> Explicit import list of <names>+        --   Just (True , <names>) -> Explicit hiding of <names>+        importListOf :: ImportDecl GhcRn -> Maybe (Bool, [Name])+        importListOf = fmap toImportList . ideclHiding+          where+            toImportList (h, loc) = (h, map (ieName . unLoc) (unLoc loc))++        isExplicit :: ImportDecl GhcRn -> Bool+        isExplicit x = case importListOf x of+            Nothing -> False+            Just (False, explicit)+                -> nameOccName name `elem`    map nameOccName explicit+            Just (True, hidden)+                -> nameOccName name `notElem` map nameOccName hidden++        -- Check whether the given name would be imported (unqualified) from+        -- an import declaration.+        importViaPrelude :: ImportDecl GhcRn -> Bool+        importViaPrelude x = isPrelude x+                          && isUnqualified x+                          && (isImplicit x || isExplicit x)+++-- Notation: is* is for classes the type is an instance of, should* for those+--           that it should also be an instance of based on the corresponding+--           is*.+tcMissingParentClassWarn :: WarningFlag+                         -> Name -- ^ Instances of this ...+                         -> Name -- ^ should also be instances of this+                         -> TcM ()+tcMissingParentClassWarn warnFlag isName shouldName+  = do { warn <- woptM warnFlag+       ; when warn $ do+       { traceTc "tcMissingParentClassWarn" empty+       ; isClass'     <- tcLookupClass_maybe isName+       ; shouldClass' <- tcLookupClass_maybe shouldName+       ; case (isClass', shouldClass') of+              (Just isClass, Just shouldClass) -> do+                  { localInstances <- tcGetInsts+                  ; let isInstance m = is_cls m == isClass+                        isInsts = filter isInstance localInstances+                  ; traceTc "tcMissingParentClassWarn/isInsts" (ppr isInsts)+                  ; forM_ isInsts (checkShouldInst isClass shouldClass)+                  }+              (is',should') ->+                  traceTc "tcMissingParentClassWarn/notIsShould"+                          (hang (ppr isName <> text "/" <> ppr shouldName) 2 (+                            (hsep [ quotes (text "Is"), text "lookup for"+                                  , ppr isName+                                  , text "resulted in", ppr is' ])+                            $$+                            (hsep [ quotes (text "Should"), text "lookup for"+                                  , ppr shouldName+                                  , text "resulted in", ppr should' ])))+       }}+  where+    -- Check whether the desired superclass exists in a given environment.+    checkShouldInst :: Class   -- ^ Class of existing instance+                    -> Class   -- ^ Class there should be an instance of+                    -> ClsInst -- ^ Existing instance+                    -> TcM ()+    checkShouldInst isClass shouldClass isInst+      = do { instEnv <- tcGetInstEnvs+           ; let (instanceMatches, shouldInsts, _)+                    = lookupInstEnv False instEnv shouldClass (is_tys isInst)++           ; traceTc "tcMissingParentClassWarn/checkShouldInst"+                     (hang (ppr isInst) 4+                         (sep [ppr instanceMatches, ppr shouldInsts]))++           -- "<location>: Warning: <type> is an instance of <is> but not+           -- <should>" e.g. "Foo is an instance of Monad but not Applicative"+           ; let instLoc = srcLocSpan . nameSrcLoc $ getName isInst+                 warnMsg (Just name:_) =+                      addWarnAt (Reason warnFlag) instLoc $+                           hsep [ (quotes . ppr . nameOccName) name+                                , text "is an instance of"+                                , (ppr . nameOccName . className) isClass+                                , text "but not"+                                , (ppr . nameOccName . className) shouldClass ]+                                <> text "."+                           $$+                           hsep [ text "This will become an error in"+                                , text "a future release." ]+                 warnMsg _ = pure ()+           ; when (null shouldInsts && null instanceMatches) $+                  warnMsg (is_tcs isInst)+           }++    tcLookupClass_maybe :: Name -> TcM (Maybe Class)+    tcLookupClass_maybe name = tcLookupImported_maybe name >>= \case+        Succeeded (ATyCon tc) | cls@(Just _) <- tyConClass_maybe tc -> pure cls+        _else -> pure Nothing+++---------------------------+tcTyClsInstDecls :: [TyClGroup GhcRn]+                 -> [LDerivDecl GhcRn]+                 -> [(RecFlag, LHsBinds GhcRn)]+                 -> TcM (TcGblEnv,            -- The full inst env+                         [InstInfo GhcRn],    -- Source-code instance decls to+                                              -- process; contains all dfuns for+                                              -- this module+                          HsValBinds GhcRn)   -- Supporting bindings for derived+                                              -- instances++tcTyClsInstDecls tycl_decls deriv_decls binds+ = tcAddDataFamConPlaceholders (tycl_decls >>= group_instds) $+   tcAddPatSynPlaceholders (getPatSynBinds binds) $+   do { (tcg_env, inst_info, datafam_deriv_info)+          <- tcTyAndClassDecls tycl_decls ;+      ; setGblEnv tcg_env $ do {+          -- With the @TyClDecl@s and @InstDecl@s checked we're ready to+          -- process the deriving clauses, including data family deriving+          -- clauses discovered in @tcTyAndClassDecls@.+          --+          -- Careful to quit now in case there were instance errors, so that+          -- the deriving errors don't pile up as well.+          ; failIfErrsM+          ; let tyclds = tycl_decls >>= group_tyclds+          ; (tcg_env', inst_info', val_binds)+              <- tcInstDeclsDeriv datafam_deriv_info tyclds deriv_decls+          ; setGblEnv tcg_env' $ do {+                failIfErrsM+              ; pure (tcg_env', inst_info' ++ inst_info, val_binds)+      }}}++{- *********************************************************************+*                                                                      *+        Checking for 'main'+*                                                                      *+************************************************************************+-}++checkMain :: Bool  -- False => no 'module M(..) where' header at all+          -> TcM TcGblEnv+-- If we are in module Main, check that 'main' is defined.+checkMain explicit_mod_hdr+ = do   { dflags  <- getDynFlags+        ; tcg_env <- getGblEnv+        ; check_main dflags tcg_env explicit_mod_hdr }++check_main :: DynFlags -> TcGblEnv -> Bool -> TcM TcGblEnv+check_main dflags tcg_env explicit_mod_hdr+ | mod /= main_mod+ = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>+   return tcg_env++ | otherwise+ = do   { mb_main <- lookupGlobalOccRn_maybe main_fn+                -- Check that 'main' is in scope+                -- It might be imported from another module!+        ; case mb_main of {+             Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)+                           ; complain_no_main+                           ; return tcg_env } ;+             Just main_name -> do++        { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)+        ; let loc       = srcLocSpan (getSrcLoc main_name)+        ; ioTyCon <- tcLookupTyCon ioTyConName+        ; res_ty <- newFlexiTyVarTy liftedTypeKind+        ; let io_ty = mkTyConApp ioTyCon [res_ty]+              skol_info = SigSkol (FunSigCtxt main_name False) io_ty []+        ; (ev_binds, main_expr)+               <- checkConstraints skol_info [] [] $+                  addErrCtxt mainCtxt    $+                  tcMonoExpr (cL loc (HsVar noExt (cL loc main_name)))+                             (mkCheckExpType io_ty)++                -- See Note [Root-main Id]+                -- Construct the binding+                --      :Main.main :: IO res_ty = runMainIO res_ty main+        ; run_main_id <- tcLookupId runMainIOName+        ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN+                                   (mkVarOccFS (fsLit "main"))+                                   (getSrcSpan main_name)+              ; root_main_id = Id.mkExportedVanillaId root_main_name+                                                      (mkTyConApp ioTyCon [res_ty])+              ; co  = mkWpTyApps [res_ty]+              -- The ev_binds of the `main` function may contain deferred+              -- type error when type of `main` is not `IO a`. The `ev_binds`+              -- must be put inside `runMainIO` to ensure the deferred type+              -- error can be emitted correctly. See #13838.+              ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) $+                        mkHsDictLet ev_binds main_expr+              ; main_bind = mkVarBind root_main_id rhs }++        ; return (tcg_env { tcg_main  = Just main_name,+                            tcg_binds = tcg_binds tcg_env+                                        `snocBag` main_bind,+                            tcg_dus   = tcg_dus tcg_env+                                        `plusDU` usesOnly (unitFV main_name)+                        -- Record the use of 'main', so that we don't+                        -- complain about it being defined but not used+                 })+    }}}+  where+    mod         = tcg_mod tcg_env+    main_mod    = mainModIs dflags+    main_fn     = getMainFun dflags+    interactive = ghcLink dflags == LinkInMemory++    complain_no_main = unless (interactive && not explicit_mod_hdr)+                              (addErrTc noMainMsg)                  -- #12906+        -- Without an explicit module header...+          -- in interactive mode, don't worry about the absence of 'main'.+          -- in other modes, add error message and go on with typechecking.++    mainCtxt  = text "When checking the type of the" <+> pp_main_fn+    noMainMsg = text "The" <+> pp_main_fn+                <+> text "is not defined in module" <+> quotes (ppr main_mod)+    pp_main_fn = ppMainFn main_fn++-- | Get the unqualified name of the function to use as the \"main\" for the main module.+-- Either returns the default name or the one configured on the command line with -main-is+getMainFun :: DynFlags -> RdrName+getMainFun dflags = case mainFunIs dflags of+                      Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))+                      Nothing -> main_RDR_Unqual++-- If we are in module Main, check that 'main' is exported.+checkMainExported :: TcGblEnv -> TcM ()+checkMainExported tcg_env+  = case tcg_main tcg_env of+      Nothing -> return () -- not the main module+      Just main_name ->+         do { dflags <- getDynFlags+            ; let main_mod = mainModIs dflags+            ; when (ghcLink dflags /= LinkInMemory) $      -- #11647+                checkTc (main_name `elem`+                           concatMap availNames (tcg_exports tcg_env)) $+                   text "The" <+> ppMainFn (nameRdrName main_name) <+>+                   text "is not exported by module" <+> quotes (ppr main_mod) }++ppMainFn :: RdrName -> SDoc+ppMainFn main_fn+  | rdrNameOcc main_fn == mainOcc+  = text "IO action" <+> quotes (ppr main_fn)+  | otherwise+  = text "main IO action" <+> quotes (ppr main_fn)++mainOcc :: OccName+mainOcc = mkVarOccFS (fsLit "main")++{-+Note [Root-main Id]+~~~~~~~~~~~~~~~~~~~+The function that the RTS invokes is always :Main.main, which we call+root_main_id.  (Because GHC allows the user to have a module not+called Main as the main module, we can't rely on the main function+being called "Main.main".  That's why root_main_id has a fixed module+":Main".)++This is unusual: it's a LocalId whose Name has a Module from another+module.  Tiresomely, we must filter it out again in MkIface, les we+get two defns for 'main' in the interface file!+++*********************************************************+*                                                       *+                GHCi stuff+*                                                       *+*********************************************************+-}++runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)+-- Initialise the tcg_inst_env with instances from all home modules.+-- This mimics the more selective call to hptInstances in tcRnImports+runTcInteractive hsc_env thing_inside+  = initTcInteractive hsc_env $ withTcPlugins hsc_env $+    do { traceTc "setInteractiveContext" $+            vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))+                 , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)+                 , text "ic_rn_gbl_env (LocalDef)" <+>+                      vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt)+                                                 , let local_gres = filter isLocalGRE gres+                                                 , not (null local_gres) ]) ]++       ; let getOrphans m mb_pkg = fmap (\iface -> mi_module iface+                                          : dep_orphs (mi_deps iface))+                                 (loadSrcInterface (text "runTcInteractive") m+                                                   False mb_pkg)++       ; !orphs <- fmap (force . concat) . forM (ic_imports icxt) $ \i ->+            case i of                   -- force above: see #15111+                IIModule n -> getOrphans n Nothing+                IIDecl i ->+                  let mb_pkg = sl_fs <$> ideclPkgQual i in+                  getOrphans (unLoc (ideclName i)) mb_pkg++       ; let imports = emptyImportAvails {+                            imp_orphs = orphs+                        }++       ; (gbl_env, lcl_env) <- getEnvs+       ; let gbl_env' = gbl_env {+                           tcg_rdr_env      = ic_rn_gbl_env icxt+                         , tcg_type_env     = type_env+                         , tcg_inst_env     = extendInstEnvList+                                               (extendInstEnvList (tcg_inst_env gbl_env) ic_insts)+                                               home_insts+                         , tcg_fam_inst_env = extendFamInstEnvList+                                               (extendFamInstEnvList (tcg_fam_inst_env gbl_env)+                                                                     ic_finsts)+                                               home_fam_insts+                         , tcg_field_env    = mkNameEnv con_fields+                              -- setting tcg_field_env is necessary+                              -- to make RecordWildCards work (test: ghci049)+                         , tcg_fix_env      = ic_fix_env icxt+                         , tcg_default      = ic_default icxt+                              -- must calculate imp_orphs of the ImportAvails+                              -- so that instance visibility is done correctly+                         , tcg_imports      = imports+                         }++       ; lcl_env' <- tcExtendLocalTypeEnv lcl_env lcl_ids+       ; setEnvs (gbl_env', lcl_env') thing_inside }+  where+    (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)++    icxt                     = hsc_IC hsc_env+    (ic_insts, ic_finsts)    = ic_instances icxt+    (lcl_ids, top_ty_things) = partitionWith is_closed (ic_tythings icxt)++    is_closed :: TyThing -> Either (Name, TcTyThing) TyThing+    -- Put Ids with free type variables (always RuntimeUnks)+    -- in the *local* type environment+    -- See Note [Initialising the type environment for GHCi]+    is_closed thing+      | AnId id <- thing+      , not (isTypeClosedLetBndr id)+      = Left (idName id, ATcId { tct_id = id+                               , tct_info = NotLetBound })+      | otherwise+      = Right thing++    type_env1 = mkTypeEnvWithImplicits top_ty_things+    type_env  = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts)+                -- Putting the dfuns in the type_env+                -- is just to keep Core Lint happy++    con_fields = [ (dataConName c, dataConFieldLabels c)+                 | ATyCon t <- top_ty_things+                 , c <- tyConDataCons t ]+++{- Note [Initialising the type environment for GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Most of the Ids in ic_things, defined by the user in 'let' stmts,+have closed types. E.g.+   ghci> let foo x y = x && not y++However the GHCi debugger creates top-level bindings for Ids whose+types have free RuntimeUnk skolem variables, standing for unknown+types.  If we don't register these free TyVars as global TyVars then+the typechecker will try to quantify over them and fall over in+skolemiseQuantifiedTyVar. so we must add any free TyVars to the+typechecker's global TyVar set.  That is most conveniently by using+tcExtendLocalTypeEnv, which automatically extends the global TyVar+set.++We do this by splitting out the Ids with open types, using 'is_closed'+to do the partition.  The top-level things go in the global TypeEnv;+the open, NotTopLevel, Ids, with free RuntimeUnk tyvars, go in the+local TypeEnv.++Note that we don't extend the local RdrEnv (tcl_rdr); all the in-scope+things are already in the interactive context's GlobalRdrEnv.+Extending the local RdrEnv isn't terrible, but it means there is an+entry for the same Name in both global and local RdrEnvs, and that+lead to duplicate "perhaps you meant..." suggestions (e.g. T5564).++We don't bother with the tcl_th_bndrs environment either.+-}++-- | The returned [Id] is the list of new Ids bound by this statement. It can+-- be used to extend the InteractiveContext via extendInteractiveContext.+--+-- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound+-- values, coerced to ().+tcRnStmt :: HscEnv -> GhciLStmt GhcPs+         -> IO (Messages, Maybe ([Id], LHsExpr GhcTc, FixityEnv))+tcRnStmt hsc_env rdr_stmt+  = runTcInteractive hsc_env $ do {++    -- The real work is done here+    ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ;+    zonked_expr <- zonkTopLExpr tc_expr ;+    zonked_ids  <- zonkTopBndrs bound_ids ;++    failIfErrsM ;  -- we can't do the next step if there are levity polymorphism errors+                   -- test case: ghci/scripts/T13202{,a}++        -- None of the Ids should be of unboxed type, because we+        -- cast them all to HValues in the end!+    mapM_ bad_unboxed (filter (isUnliftedType . idType) zonked_ids) ;++    traceTc "tcs 1" empty ;+    this_mod <- getModule ;+    global_ids <- mapM (externaliseAndTidyId this_mod) zonked_ids ;+        -- Note [Interactively-bound Ids in GHCi] in HscTypes++{- ---------------------------------------------+   At one stage I removed any shadowed bindings from the type_env;+   they are inaccessible but might, I suppose, cause a space leak if we leave them there.+   However, with Template Haskell they aren't necessarily inaccessible.  Consider this+   GHCi session+         Prelude> let f n = n * 2 :: Int+         Prelude> fName <- runQ [| f |]+         Prelude> $(return $ AppE fName (LitE (IntegerL 7)))+         14+         Prelude> let f n = n * 3 :: Int+         Prelude> $(return $ AppE fName (LitE (IntegerL 7)))+   In the last line we use 'fName', which resolves to the *first* 'f'+   in scope. If we delete it from the type env, GHCi crashes because+   it doesn't expect that.++   Hence this code is commented out++-------------------------------------------------- -}++    traceOptTcRn Opt_D_dump_tc+        (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,+               text "Typechecked expr" <+> ppr zonked_expr]) ;++    return (global_ids, zonked_expr, fix_env)+    }+  where+    bad_unboxed id = addErr (sep [text "GHCi can't bind a variable of unlifted type:",+                                  nest 2 (ppr id <+> dcolon <+> ppr (idType id))])++{-+--------------------------------------------------------------------------+                Typechecking Stmts in GHCi++Here is the grand plan, implemented in tcUserStmt++        What you type                   The IO [HValue] that hscStmt returns+        -------------                   ------------------------------------+        let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]+                                        bindings: [x,y,...]++        pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]+                                        bindings: [x,y,...]++        expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]+          [NB: result not printed]      bindings: [it]++        expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]+          result showable)              bindings: [it]++        expr (of non-IO type,+          result not showable)  ==>     error+-}++-- | A plan is an attempt to lift some code into the IO monad.+type PlanResult = ([Id], LHsExpr GhcTc)+type Plan = TcM PlanResult++-- | Try the plans in order. If one fails (by raising an exn), try the next.+-- If one succeeds, take it.+runPlans :: [Plan] -> TcM PlanResult+runPlans []     = panic "runPlans"+runPlans [p]    = p+runPlans (p:ps) = tryTcDiscardingErrs (runPlans ps) p++-- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the+-- GHCi 'environment'.+--+-- By 'lift' and 'environment we mean that the code is changed to+-- execute properly in an IO monad. See Note [Interactively-bound Ids+-- in GHCi] in HscTypes for more details. We do this lifting by trying+-- different ways ('plans') of lifting the code into the IO monad and+-- type checking each plan until one succeeds.+tcUserStmt :: GhciLStmt GhcPs -> TcM (PlanResult, FixityEnv)++-- An expression typed at the prompt is treated very specially+tcUserStmt (dL->L loc (BodyStmt _ expr _ _))+  = do  { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)+               -- Don't try to typecheck if the renamer fails!+        ; ghciStep <- getGhciStepIO+        ; uniq <- newUnique+        ; interPrintName <- getInteractivePrintName+        ; let fresh_it  = itName uniq loc+              matches   = [mkMatch (mkPrefixFunRhs (cL loc fresh_it)) [] rn_expr+                                   (noLoc emptyLocalBinds)]+              -- [it = expr]+              the_bind  = cL loc $ (mkTopFunBind FromSource+                                     (cL loc fresh_it) matches)+                                         { fun_ext = fvs }+              -- Care here!  In GHCi the expression might have+              -- free variables, and they in turn may have free type variables+              -- (if we are at a breakpoint, say).  We must put those free vars++              -- [let it = expr]+              let_stmt  = cL loc $ LetStmt noExt $ noLoc $ HsValBinds noExt+                           $ XValBindsLR+                               (NValBinds [(NonRecursive,unitBag the_bind)] [])++              -- [it <- e]+              bind_stmt = cL loc $ BindStmt noExt+                                       (cL loc (VarPat noExt (cL loc fresh_it)))+                                       (nlHsApp ghciStep rn_expr)+                                       (mkRnSyntaxExpr bindIOName)+                                       noSyntaxExpr++              -- [; print it]+              print_it  = cL loc $ BodyStmt noExt+                                           (nlHsApp (nlHsVar interPrintName)+                                           (nlHsVar fresh_it))+                                           (mkRnSyntaxExpr thenIOName)+                                                  noSyntaxExpr++              -- NewA+              no_it_a = cL loc $ BodyStmt noExt (nlHsApps bindIOName+                                       [rn_expr , nlHsVar interPrintName])+                                       (mkRnSyntaxExpr thenIOName)+                                       noSyntaxExpr++              no_it_b = cL loc $ BodyStmt noExt (rn_expr)+                                       (mkRnSyntaxExpr thenIOName)+                                       noSyntaxExpr++              no_it_c = cL loc $ BodyStmt noExt+                                      (nlHsApp (nlHsVar interPrintName) rn_expr)+                                      (mkRnSyntaxExpr thenIOName)+                                      noSyntaxExpr++              -- See Note [GHCi Plans]++              it_plans = [+                    -- Plan A+                    do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]+                       ; it_ty <- zonkTcType (idType it_id)+                       ; when (isUnitTy $ it_ty) failM+                       ; return stuff },++                        -- Plan B; a naked bind statement+                    tcGhciStmts [bind_stmt],++                        -- Plan C; check that the let-binding is typeable all by itself.+                        -- If not, fail; if so, try to print it.+                        -- The two-step process avoids getting two errors: one from+                        -- the expression itself, and one from the 'print it' part+                        -- This two-step story is very clunky, alas+                    do { _ <- checkNoErrs (tcGhciStmts [let_stmt])+                                --- checkNoErrs defeats the error recovery of let-bindings+                       ; tcGhciStmts [let_stmt, print_it] } ]++              -- Plans where we don't bind "it"+              no_it_plans = [+                    tcGhciStmts [no_it_a] ,+                    tcGhciStmts [no_it_b] ,+                    tcGhciStmts [no_it_c] ]++        ; generate_it <- goptM Opt_NoIt++        -- We disable `-fdefer-type-errors` in GHCi for naked expressions.+        -- See Note [Deferred type errors in GHCi]++        -- NB: The flag `-fdefer-type-errors` implies `-fdefer-type-holes`+        -- and `-fdefer-out-of-scope-variables`. However the flag+        -- `-fno-defer-type-errors` doesn't imply `-fdefer-type-holes` and+        -- `-fno-defer-out-of-scope-variables`. Thus the later two flags+        -- also need to be unset here.+        ; plan <- unsetGOptM Opt_DeferTypeErrors $+                  unsetGOptM Opt_DeferTypedHoles $+                  unsetGOptM Opt_DeferOutOfScopeVariables $+                    runPlans $ if generate_it+                                 then no_it_plans+                                 else it_plans++        ; fix_env <- getFixityEnv+        ; return (plan, fix_env) }++{- Note [Deferred type errors in GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In GHCi, we ensure that type errors don't get deferred when type checking the+naked expressions. Deferring type errors here is unhelpful because the+expression gets evaluated right away anyway. It also would potentially emit+two redundant type-error warnings, one from each plan.++#14963 reveals another bug that when deferred type errors is enabled+in GHCi, any reference of imported/loaded variables (directly or indirectly)+in interactively issued naked expressions will cause ghc panic. See more+detailed dicussion in #14963.++The interactively issued declarations, statements, as well as the modules+loaded into GHCi, are not affected. That means, for declaration, you could+have++    Prelude> :set -fdefer-type-errors+    Prelude> x :: IO (); x = putStrLn True+    <interactive>:14:26: warning: [-Wdeferred-type-errors]+        ? Couldn't match type ‘Bool’ with ‘[Char]’+          Expected type: String+            Actual type: Bool+        ? In the first argument of ‘putStrLn’, namely ‘True’+          In the expression: putStrLn True+          In an equation for ‘x’: x = putStrLn True++But for naked expressions, you will have++    Prelude> :set -fdefer-type-errors+    Prelude> putStrLn True+    <interactive>:2:10: error:+        ? Couldn't match type ‘Bool’ with ‘[Char]’+          Expected type: String+            Actual type: Bool+        ? In the first argument of ‘putStrLn’, namely ‘True’+          In the expression: putStrLn True+          In an equation for ‘it’: it = putStrLn True++    Prelude> let x = putStrLn True+    <interactive>:2:18: warning: [-Wdeferred-type-errors]+        ? Couldn't match type ‘Bool’ with ‘[Char]’+          Expected type: String+            Actual type: Bool+        ? In the first argument of ‘putStrLn’, namely ‘True’+          In the expression: putStrLn True+          In an equation for ‘x’: x = putStrLn True+-}++tcUserStmt rdr_stmt@(dL->L loc _)+  = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $+           rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do+             fix_env <- getFixityEnv+             return (fix_env, emptyFVs)+            -- Don't try to typecheck if the renamer fails!+       ; traceRn "tcRnStmt" (vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])+       ; rnDump rn_stmt ;++       ; ghciStep <- getGhciStepIO+       ; let gi_stmt+               | (dL->L loc (BindStmt ty pat expr op1 op2)) <- rn_stmt+                     = cL loc $ BindStmt ty pat (nlHsApp ghciStep expr) op1 op2+               | otherwise = rn_stmt++       ; opt_pr_flag <- goptM Opt_PrintBindResult+       ; let print_result_plan+               | opt_pr_flag                         -- The flag says "print result"+               , [v] <- collectLStmtBinders gi_stmt  -- One binder+                           =  [mk_print_result_plan gi_stmt v]+               | otherwise = []++        -- The plans are:+        --      [stmt; print v]         if one binder and not v::()+        --      [stmt]                  otherwise+       ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]])+       ; return (plan, fix_env) }+  where+    mk_print_result_plan stmt v+      = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]+           ; v_ty <- zonkTcType (idType v_id)+           ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM+           ; return stuff }+      where+        print_v  = cL loc $ BodyStmt noExt (nlHsApp (nlHsVar printName)+                                    (nlHsVar v))+                                    (mkRnSyntaxExpr thenIOName) noSyntaxExpr++{-+Note [GHCi Plans]+~~~~~~~~~~~~~~~~~+When a user types an expression in the repl we try to print it in three different+ways. Also, depending on whether -fno-it is set, we bind a variable called `it`+which can be used to refer to the result of the expression subsequently in the repl.++The normal plans are :+  A. [it <- e; print e]     but not if it::()+  B. [it <- e]+  C. [let it = e; print it]++When -fno-it is set, the plans are:+  A. [e >>= print]+  B. [e]+  C. [let it = e in print it]++The reason for -fno-it is explained in #14336. `it` can lead to the repl+leaking memory as it is repeatedly queried.+-}++-- | Typecheck the statements given and then return the results of the+-- statement in the form 'IO [()]'.+tcGhciStmts :: [GhciLStmt GhcRn] -> TcM PlanResult+tcGhciStmts stmts+ = do { ioTyCon <- tcLookupTyCon ioTyConName ;+        ret_id  <- tcLookupId returnIOName ;            -- return @ IO+        let {+            ret_ty      = mkListTy unitTy ;+            io_ret_ty   = mkTyConApp ioTyCon [ret_ty] ;+            tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts+                                         (mkCheckExpType io_ret_ty) ;+            names = collectLStmtsBinders stmts ;+         } ;++        -- OK, we're ready to typecheck the stmts+        traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;+        ((tc_stmts, ids), lie) <- captureTopConstraints $+                                  tc_io_stmts $ \ _ ->+                                  mapM tcLookupId names  ;+                        -- Look up the names right in the middle,+                        -- where they will all be in scope++        -- Simplify the context+        traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;+        const_binds <- checkNoErrs (simplifyInteractive lie) ;+                -- checkNoErrs ensures that the plan fails if context redn fails++        traceTc "TcRnDriver.tcGhciStmts: done" empty ;+        let {   -- mk_return builds the expression+                --      returnIO @ [()] [coerce () x, ..,  coerce () z]+                --+                -- Despite the inconvenience of building the type applications etc,+                -- this *has* to be done in type-annotated post-typecheck form+                -- because we are going to return a list of *polymorphic* values+                -- coerced to type (). If we built a *source* stmt+                --      return [coerce x, ..., coerce z]+                -- then the type checker would instantiate x..z, and we wouldn't+                -- get their *polymorphic* values.  (And we'd get ambiguity errs+                -- if they were overloaded, since they aren't applied to anything.)+            ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty])+                       (noLoc $ ExplicitList unitTy Nothing+                                                            (map mk_item ids)) ;+            mk_item id = let ty_args = [idType id, unitTy] in+                         nlHsApp (nlHsTyApp unsafeCoerceId+                                   (map getRuntimeRep ty_args ++ ty_args))+                                 (nlHsVar id) ;+            stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]+        } ;+        return (ids, mkHsDictLet (EvBinds const_binds) $+                     noLoc (HsDo io_ret_ty GhciStmtCtxt (noLoc stmts)))+    }++-- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)+getGhciStepIO :: TcM (LHsExpr GhcRn)+getGhciStepIO = do+    ghciTy <- getGHCiMonad+    a_tv <- newName (mkTyVarOccFS (fsLit "a"))+    let ghciM   = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)+        ioM     = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)++        step_ty = noLoc $ HsForAllTy+                     { hst_fvf = ForallInvis+                     , hst_bndrs = [noLoc $ UserTyVar noExt (noLoc a_tv)]+                     , hst_xforall = noExt+                     , hst_body  = nlHsFunTy ghciM ioM }++        stepTy :: LHsSigWcType GhcRn+        stepTy = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs step_ty)++    return (noLoc $ ExprWithTySig noExt (nlHsVar ghciStepIoMName) stepTy)++isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name)+isGHCiMonad hsc_env ty+  = runTcInteractive hsc_env $ do+        rdrEnv <- getGlobalRdrEnv+        let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty)+        case occIO of+            Just [n] -> do+                let name = gre_name n+                ghciClass <- tcLookupClass ghciIoClassName+                userTyCon <- tcLookupTyCon name+                let userTy = mkTyConApp userTyCon []+                _ <- tcLookupInstance ghciClass [userTy]+                return name++            Just _  -> failWithTc $ text "Ambiguous type!"+            Nothing -> failWithTc $ text ("Can't find type:" ++ ty)++-- | How should we infer a type? See Note [TcRnExprMode]+data TcRnExprMode = TM_Inst    -- ^ Instantiate the type fully (:type)+                  | TM_NoInst  -- ^ Do not instantiate the type (:type +v)+                  | TM_Default -- ^ Default the type eagerly (:type +d)++-- | tcRnExpr just finds the type of an expression+tcRnExpr :: HscEnv+         -> TcRnExprMode+         -> LHsExpr GhcPs+         -> IO (Messages, Maybe Type)+tcRnExpr hsc_env mode rdr_expr+  = runTcInteractive hsc_env $+    do {++    (rn_expr, _fvs) <- rnLExpr rdr_expr ;+    failIfErrsM ;++        -- Now typecheck the expression, and generalise its type+        -- it might have a rank-2 type (e.g. :t runST)+    uniq <- newUnique ;+    let { fresh_it  = itName uniq (getLoc rdr_expr)+        ; orig = lexprCtOrigin rn_expr } ;+    ((tclvl, res_ty), lie)+          <- captureTopConstraints $+             pushTcLevelM          $+             do { (_tc_expr, expr_ty) <- tcInferSigma rn_expr+                ; if inst+                  then snd <$> deeplyInstantiate orig expr_ty+                  else return expr_ty } ;++    -- Generalise+    (qtvs, dicts, _, residual, _)+         <- simplifyInfer tclvl infer_mode+                          []    {- No sig vars -}+                          [(fresh_it, res_ty)]+                          lie ;++    -- Ignore the dictionary bindings+    _ <- perhaps_disable_default_warnings $+         simplifyInteractive residual ;++    let { all_expr_ty = mkInvForAllTys qtvs $+                        mkPhiTy (map idType dicts) res_ty } ;+    ty <- zonkTcType all_expr_ty ;++    -- We normalise type families, so that the type of an expression is the+    -- same as of a bound expression (TcBinds.mkInferredPolyId). See Trac+    -- #10321 for further discussion.+    fam_envs <- tcGetFamInstEnvs ;+    -- normaliseType returns a coercion which we discard, so the Role is+    -- irrelevant+    return (snd (normaliseType fam_envs Nominal ty))+    }+  where+    -- See Note [TcRnExprMode]+    (inst, infer_mode, perhaps_disable_default_warnings) = case mode of+      TM_Inst    -> (True,  NoRestrictions, id)+      TM_NoInst  -> (False, NoRestrictions, id)+      TM_Default -> (True,  EagerDefaulting, unsetWOptM Opt_WarnTypeDefaults)++--------------------------+tcRnImportDecls :: HscEnv+                -> [LImportDecl GhcPs]+                -> IO (Messages, Maybe GlobalRdrEnv)+-- Find the new chunk of GlobalRdrEnv created by this list of import+-- decls.  In contract tcRnImports *extends* the TcGblEnv.+tcRnImportDecls hsc_env import_decls+ =  runTcInteractive hsc_env $+    do { gbl_env <- updGblEnv zap_rdr_env $+                    tcRnImports hsc_env import_decls+       ; return (tcg_rdr_env gbl_env) }+  where+    zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv }++-- tcRnType just finds the kind of a type+tcRnType :: HscEnv+         -> Bool        -- Normalise the returned type+         -> LHsType GhcPs+         -> IO (Messages, Maybe (Type, Kind))+tcRnType hsc_env normalise rdr_type+  = runTcInteractive hsc_env $+    setXOptM LangExt.PolyKinds $   -- See Note [Kind-generalise in tcRnType]+    do { (HsWC { hswc_ext = wcs, hswc_body = rn_type }, _fvs)+               <- rnHsWcType GHCiCtx (mkHsWildCardBndrs rdr_type)+                  -- The type can have wild cards, but no implicit+                  -- generalisation; e.g.   :kind (T _)+       ; failIfErrsM++        -- Now kind-check the type+        -- It can have any rank or kind+        -- First bring into scope any wildcards+       ; traceTc "tcRnType" (vcat [ppr wcs, ppr rn_type])+       ; ((ty, kind), lie)  <-+                       captureTopConstraints $+                       tcWildCardBinders wcs $ \ wcs' ->+                       do { emitWildCardHoleConstraints wcs'+                          ; tcLHsTypeUnsaturated rn_type }+       ; _ <- checkNoErrs (simplifyInteractive lie)++       -- Do kind generalisation; see Note [Kind-generalise in tcRnType]+       ; kind <- zonkTcType kind+       ; kvs <- kindGeneralize kind+       ; ty  <- zonkTcTypeToType ty++       -- Do validity checking on type+       ; checkValidType (GhciCtxt True) ty++       ; ty' <- if normalise+                then do { fam_envs <- tcGetFamInstEnvs+                        ; let (_, ty')+                                = normaliseType fam_envs Nominal ty+                        ; return ty' }+                else return ty ;++       ; return (ty', mkInvForAllTys kvs (tcTypeKind ty')) }++{- Note [TcRnExprMode]+~~~~~~~~~~~~~~~~~~~~~~+How should we infer a type when a user asks for the type of an expression e+at the GHCi prompt? We offer 3 different possibilities, described below. Each+considers this example, with -fprint-explicit-foralls enabled:++  foo :: forall a f b. (Show a, Num b, Foldable f) => a -> f b -> String+  :type{,-spec,-def} foo @Int++:type / TM_Inst++  In this mode, we report the type that would be inferred if a variable+  were assigned to expression e, without applying the monomorphism restriction.+  This means we deeply instantiate the type and then regeneralize, as discussed+  in #11376.++  > :type foo @Int+  forall {b} {f :: * -> *}. (Foldable f, Num b) => Int -> f b -> String++  Note that the variables and constraints are reordered here, because this+  is possible during regeneralization. Also note that the variables are+  reported as Inferred instead of Specified.++:type +v / TM_NoInst++  This mode is for the benefit of users using TypeApplications. It does no+  instantiation whatsoever, sometimes meaning that class constraints are not+  solved.++  > :type +v foo @Int+  forall f b. (Show Int, Num b, Foldable f) => Int -> f b -> String++  Note that Show Int is still reported, because the solver never got a chance+  to see it.++:type +d / TM_Default++  This mode is for the benefit of users who wish to see instantiations of+  generalized types, and in particular to instantiate Foldable and Traversable.+  In this mode, any type variable that can be defaulted is defaulted. Because+  GHCi uses -XExtendedDefaultRules, this means that Foldable and Traversable are+  defaulted.++  > :type +d foo @Int+  Int -> [Integer] -> String++  Note that this mode can sometimes lead to a type error, if a type variable is+  used with a defaultable class but cannot actually be defaulted:++  bar :: (Num a, Monoid a) => a -> a+  > :type +d bar+  ** error **++  The error arises because GHC tries to default a but cannot find a concrete+  type in the defaulting list that is both Num and Monoid. (If this list is+  modified to include an element that is both Num and Monoid, the defaulting+  would succeed, of course.)++Note [Kind-generalise in tcRnType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We switch on PolyKinds when kind-checking a user type, so that we will+kind-generalise the type, even when PolyKinds is not otherwise on.+This gives the right default behaviour at the GHCi prompt, where if+you say ":k T", and T has a polymorphic kind, you'd like to see that+polymorphism. Of course.  If T isn't kind-polymorphic you won't get+anything unexpected, but the apparent *loss* of polymorphism, for+types that you know are polymorphic, is quite surprising.  See Trac+#7688 for a discussion.++Note that the goal is to generalise the *kind of the type*, not+the type itself! Example:+  ghci> data SameKind :: k -> k -> Type+  ghci> :k SameKind _++We want to get `k -> Type`, not `Any -> Type`, which is what we would+get without kind-generalisation. Note that `:k SameKind` is OK, as+GHC will not instantiate SameKind here, and so we see its full kind+of `forall k. k -> k -> Type`.++************************************************************************+*                                                                      *+                 tcRnDeclsi+*                                                                      *+************************************************************************++tcRnDeclsi exists to allow class, data, and other declarations in GHCi.+-}++tcRnDeclsi :: HscEnv+           -> [LHsDecl GhcPs]+           -> IO (Messages, Maybe TcGblEnv)+tcRnDeclsi hsc_env local_decls+  = runTcInteractive hsc_env $+    tcRnSrcDecls False local_decls++externaliseAndTidyId :: Module -> Id -> TcM Id+externaliseAndTidyId this_mod id+  = do { name' <- externaliseName this_mod (idName id)+       ; return (globaliseAndTidyId (setIdName id name')) }+++{-+************************************************************************+*                                                                      *+        More GHCi stuff, to do with browsing and getting info+*                                                                      *+************************************************************************+-}++-- | ASSUMES that the module is either in the 'HomePackageTable' or is+-- a package module with an interface on disk.  If neither of these is+-- true, then the result will be an error indicating the interface+-- could not be found.+getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)+getModuleInterface hsc_env mod+  = runTcInteractive hsc_env $+    loadModuleInterface (text "getModuleInterface") mod++tcRnLookupRdrName :: HscEnv -> Located RdrName+                  -> IO (Messages, Maybe [Name])+-- ^ Find all the Names that this RdrName could mean, in GHCi+tcRnLookupRdrName hsc_env (dL->L loc rdr_name)+  = runTcInteractive hsc_env $+    setSrcSpan loc           $+    do {   -- If the identifier is a constructor (begins with an+           -- upper-case letter), then we need to consider both+           -- constructor and type class identifiers.+         let rdr_names = dataTcOccs rdr_name+       ; names_s <- mapM lookupInfoOccRn rdr_names+       ; let names = concat names_s+       ; when (null names) (addErrTc (text "Not in scope:" <+> quotes (ppr rdr_name)))+       ; return names }++tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)+tcRnLookupName hsc_env name+  = runTcInteractive hsc_env $+    tcRnLookupName' name++-- To look up a name we have to look in the local environment (tcl_lcl)+-- as well as the global environment, which is what tcLookup does.+-- But we also want a TyThing, so we have to convert:++tcRnLookupName' :: Name -> TcRn TyThing+tcRnLookupName' name = do+   tcthing <- tcLookup name+   case tcthing of+     AGlobal thing    -> return thing+     ATcId{tct_id=id} -> return (AnId id)+     _ -> panic "tcRnLookupName'"++tcRnGetInfo :: HscEnv+            -> Name+            -> IO ( Messages+                  , Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))++-- Used to implement :info in GHCi+--+-- Look up a RdrName and return all the TyThings it might be+-- A capitalised RdrName is given to us in the DataName namespace,+-- but we want to treat it as *both* a data constructor+--  *and* as a type or class constructor;+-- hence the call to dataTcOccs, and we return up to two results+tcRnGetInfo hsc_env name+  = runTcInteractive hsc_env $+    do { loadUnqualIfaces hsc_env (hsc_IC hsc_env)+           -- Load the interface for all unqualified types and classes+           -- That way we will find all the instance declarations+           -- (Packages have not orphan modules, and we assume that+           --  in the home package all relevant modules are loaded.)++       ; thing  <- tcRnLookupName' name+       ; fixity <- lookupFixityRn name+       ; (cls_insts, fam_insts) <- lookupInsts thing+       ; let info = lookupKnownNameInfo name+       ; return (thing, fixity, cls_insts, fam_insts, info) }+++-- Lookup all class and family instances for a type constructor.+--+-- This function filters all instances in the type environment, so there+-- is a lot of duplicated work if it is called many times in the same+-- type environment. If this becomes a problem, the NameEnv computed+-- in GHC.getNameToInstancesIndex could be cached in TcM and both functions+-- could be changed to consult that index.+lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst])+lookupInsts (ATyCon tc)+  = do  { InstEnvs { ie_global = pkg_ie, ie_local = home_ie, ie_visible = vis_mods } <- tcGetInstEnvs+        ; (pkg_fie, home_fie) <- tcGetFamInstEnvs+                -- Load all instances for all classes that are+                -- in the type environment (which are all the ones+                -- we've seen in any interface file so far)++          -- Return only the instances relevant to the given thing, i.e.+          -- the instances whose head contains the thing's name.+        ; let cls_insts =+                 [ ispec        -- Search all+                 | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie+                 , instIsVisible vis_mods ispec+                 , tc_name `elemNameSet` orphNamesOfClsInst ispec ]+        ; let fam_insts =+                 [ fispec+                 | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie+                 , tc_name `elemNameSet` orphNamesOfFamInst fispec ]+        ; return (cls_insts, fam_insts) }+  where+    tc_name     = tyConName tc++lookupInsts _ = return ([],[])++loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM ()+-- Load the interface for everything that is in scope unqualified+-- This is so that we can accurately report the instances for+-- something+loadUnqualIfaces hsc_env ictxt+  = initIfaceTcRn $ do+    mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))+  where+    this_pkg = thisPackage (hsc_dflags hsc_env)++    unqual_mods = [ nameModule name+                  | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt)+                  , let name = gre_name gre+                  , nameIsFromExternalPackage this_pkg name+                  , isTcOcc (nameOccName name)   -- Types and classes only+                  , unQualOK gre ]               -- In scope unqualified+    doc = text "Need interface for module whose export(s) are in scope unqualified"++++{-+************************************************************************+*                                                                      *+                Debugging output+      This is what happens when you do -ddump-types+*                                                                      *+************************************************************************+-}++rnDump :: (Outputable a, Data a) => a -> TcRn ()+-- Dump, with a banner, if -ddump-rn+rnDump rn = do { traceOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" (ppr rn)) }++tcDump :: TcGblEnv -> TcRn ()+tcDump env+ = do { dflags <- getDynFlags ;++        -- Dump short output if -ddump-types or -ddump-tc+        when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)+          (traceTcRnForUser Opt_D_dump_types short_dump) ;++        -- Dump bindings if -ddump-tc+        traceOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump);++        -- Dump bindings as an hsSyn AST if -ddump-tc-ast+        traceOptTcRn Opt_D_dump_tc_ast (mkDumpDoc "Typechecker" ast_dump)+   }+  where+    short_dump = pprTcGblEnv env+    full_dump  = pprLHsBinds (tcg_binds env)+        -- NB: foreign x-d's have undefined's in their types;+        --     hence can't show the tc_fords+    ast_dump = showAstData NoBlankSrcSpan (tcg_binds env)++-- It's unpleasant having both pprModGuts and pprModDetails here+pprTcGblEnv :: TcGblEnv -> SDoc+pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,+                        tcg_insts     = insts,+                        tcg_fam_insts = fam_insts,+                        tcg_rules     = rules,+                        tcg_imports   = imports })+  = getPprDebug $ \debug ->+    vcat [ ppr_types debug type_env+         , ppr_tycons debug fam_insts type_env+         , ppr_datacons debug type_env+         , ppr_patsyns type_env+         , ppr_insts insts+         , ppr_fam_insts fam_insts+         , ppr_rules rules+         , text "Dependent modules:" <+>+                pprUFM (imp_dep_mods imports) (ppr . sort)+         , text "Dependent packages:" <+>+                ppr (S.toList $ imp_dep_pkgs imports)]+  where         -- The use of sort is just to reduce unnecessary+                -- wobbling in testsuite output++ppr_rules :: [LRuleDecl GhcTc] -> SDoc+ppr_rules rules+  = ppUnless (null rules) $+    hang (text "RULES")+       2 (vcat (map ppr rules))++ppr_types :: Bool -> TypeEnv -> SDoc+ppr_types debug type_env+  = ppr_things "TYPE SIGNATURES" ppr_sig+             (sortBy (comparing getOccName) ids)+  where+    ids = [id | id <- typeEnvIds type_env, want_sig id]+    want_sig id+      | debug     = True+      | otherwise = hasTopUserName id+                    && case idDetails id of+                         VanillaId    -> True+                         RecSelId {}  -> True+                         ClassOpId {} -> True+                         FCallId {}   -> True+                         _            -> False+             -- Data cons (workers and wrappers), pattern synonyms,+             -- etc are suppressed (unless -dppr-debug),+             -- because they appear elsehwere++    ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id)))++ppr_tycons :: Bool -> [FamInst] -> TypeEnv -> SDoc+ppr_tycons debug fam_insts type_env+  = vcat [ ppr_things "TYPE CONSTRUCTORS" ppr_tc tycons+         , ppr_things "COERCION AXIOMS" ppr_ax+                      (typeEnvCoAxioms type_env) ]+  where+    fi_tycons = famInstsRepTyCons fam_insts++    tycons = sortBy (comparing getOccName) $+             [tycon | tycon <- typeEnvTyCons type_env+                    , want_tycon tycon]+             -- Sort by OccName to reduce unnecessary changes+    want_tycon tycon | debug      = True+                     | otherwise  = isExternalName (tyConName tycon) &&+                                    not (tycon `elem` fi_tycons)+    ppr_tc tc+       = vcat [ hang (ppr (tyConFlavour tc) <+> ppr tc+                      <> braces (ppr (tyConArity tc)) <+> dcolon)+                   2 (ppr (tidyTopType (tyConKind tc)))+              , nest 2 $+                ppWhen show_roles $+                text "roles" <+> (sep (map ppr roles)) ]+       where+         show_roles = debug || not (all (== boring_role) roles)+         roles = tyConRoles tc+         boring_role | isClassTyCon tc = Nominal+                     | otherwise       = Representational+            -- Matches the choice in IfaceSyn, calls to pprRoles++    ppr_ax ax = ppr (coAxiomToIfaceDecl ax)+      -- We go via IfaceDecl rather than using pprCoAxiom+      -- This way we get the full axiom (both LHS and RHS) with+      -- wildcard binders tidied to _1, _2, etc.++ppr_datacons :: Bool -> TypeEnv -> SDoc+ppr_datacons debug type_env+  = ppr_things "DATA CONSTRUCTORS" ppr_dc wanted_dcs+      -- The filter gets rid of class data constructors+  where+    ppr_dc dc = ppr dc <+> dcolon <+> ppr (dataConUserType dc)+    all_dcs    = typeEnvDataCons type_env+    wanted_dcs | debug     = all_dcs+               | otherwise = filterOut is_cls_dc all_dcs+    is_cls_dc dc = isClassTyCon (dataConTyCon dc)++ppr_patsyns :: TypeEnv -> SDoc+ppr_patsyns type_env+  = ppr_things "PATTERN SYNONYMS" ppr_ps+               (typeEnvPatSyns type_env)+  where+    ppr_ps ps = ppr ps <+> dcolon <+> pprPatSynType ps++ppr_insts :: [ClsInst] -> SDoc+ppr_insts ispecs+  = ppr_things "CLASS INSTANCES" pprInstance ispecs++ppr_fam_insts :: [FamInst] -> SDoc+ppr_fam_insts fam_insts+  = ppr_things "FAMILY INSTANCES" pprFamInst fam_insts++ppr_things :: String -> (a -> SDoc) -> [a] -> SDoc+ppr_things herald ppr_one things+  | null things = empty+  | otherwise   = text herald $$ nest 2 (vcat (map ppr_one things))++hasTopUserName :: NamedThing x => x -> Bool+-- A top-level thing whose name is not "derived"+-- Thus excluding things like $tcX, from Typeable boilerplate+-- and C:Coll from class-dictionary data constructors+hasTopUserName x+  = isExternalName name && not (isDerivedOccName (nameOccName name))+  where+    name = getName x++{-+********************************************************************************++Type Checker Plugins++********************************************************************************+-}++withTcPlugins :: HscEnv -> TcM a -> TcM a+withTcPlugins hsc_env m =+  do let plugins = getTcPlugins (hsc_dflags hsc_env)+     case plugins of+       [] -> m  -- Common fast case+       _  -> do ev_binds_var <- newTcEvBinds+                (solvers,stops) <- unzip `fmap` mapM (startPlugin ev_binds_var) plugins+                -- This ensures that tcPluginStop is called even if a type+                -- error occurs during compilation (Fix of #10078)+                eitherRes <- tryM $ do+                  updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m+                mapM_ (flip runTcPluginM ev_binds_var) stops+                case eitherRes of+                  Left _ -> failM+                  Right res -> return res+  where+  startPlugin ev_binds_var (TcPlugin start solve stop) =+    do s <- runTcPluginM start ev_binds_var+       return (solve s, stop s)++getTcPlugins :: DynFlags -> [TcRnMonad.TcPlugin]+getTcPlugins dflags = catMaybes $ mapPlugins dflags (\p args -> tcPlugin p args)++runRenamerPlugin :: TcGblEnv+                 -> HsGroup GhcRn+                 -> TcM (TcGblEnv, HsGroup GhcRn)+runRenamerPlugin gbl_env hs_group = do+    dflags <- getDynFlags+    withPlugins dflags+      (\p opts (e, g) -> ( mark_plugin_unsafe dflags >> renamedResultAction p opts e g))+      (gbl_env, hs_group)+++-- XXX: should this really be a Maybe X?  Check under which circumstances this+-- can become a Nothing and decide whether this should instead throw an+-- exception/signal an error.+type RenamedStuff =+        (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],+                Maybe LHsDocString))++-- | Extract the renamed information from TcGblEnv.+getRenamedStuff :: TcGblEnv -> RenamedStuff+getRenamedStuff tc_result+  = fmap (\decls -> ( decls, tcg_rn_imports tc_result+                    , tcg_rn_exports tc_result, tcg_doc_hdr tc_result ) )+         (tcg_rn_decls tc_result)++runTypecheckerPlugin :: ModSummary -> HscEnv -> TcGblEnv -> TcM TcGblEnv+runTypecheckerPlugin sum hsc_env gbl_env = do+    let dflags = hsc_dflags hsc_env+    withPlugins dflags+      (\p opts env -> mark_plugin_unsafe dflags+                        >> typeCheckResultAction p opts sum env)+      gbl_env++mark_plugin_unsafe :: DynFlags -> TcM ()+mark_plugin_unsafe dflags = unless (gopt Opt_PluginTrustworthy dflags) $+  recordUnsafeInfer pluginUnsafe+  where+    unsafeText = "Use of plugins makes the module unsafe"+    pluginUnsafe = unitBag ( mkPlainWarnMsg dflags noSrcSpan+                                   (Outputable.text unsafeText) )
+ compiler/typecheck/TcRnDriver.hs-boot view
@@ -0,0 +1,13 @@+module TcRnDriver where++import GhcPrelude+import DynFlags (DynFlags)+import Type (TyThing)+import TcRnTypes (TcM)+import Outputable (SDoc)+import Name (Name)++checkBootDeclM :: Bool  -- ^ True <=> an hs-boot file (could also be a sig)+               -> TyThing -> TyThing -> TcM ()+missingBootThing :: Bool -> Name -> String -> SDoc+badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc
+ compiler/typecheck/TcRnExports.hs view
@@ -0,0 +1,849 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module TcRnExports (tcRnExports, exports_from_avail) where++import GhcPrelude++import HsSyn+import PrelNames+import RdrName+import TcRnMonad+import TcEnv+import TcType+import RnNames+import RnEnv+import RnUnbound ( reportUnboundName )+import ErrUtils+import Id+import IdInfo+import Module+import Name+import NameEnv+import NameSet+import Avail+import TyCon+import SrcLoc+import HscTypes+import Outputable+import ConLike+import DataCon+import PatSyn+import Maybes+import UniqSet+import Util (capitalise)+import FastString (fsLit)++import Control.Monad+import DynFlags+import RnHsDoc          ( rnHsDoc )+import RdrHsSyn        ( setRdrNameSpace )+import Data.Either      ( partitionEithers )++{-+************************************************************************+*                                                                      *+\subsection{Export list processing}+*                                                                      *+************************************************************************++Processing the export list.++You might think that we should record things that appear in the export+list as ``occurrences'' (using @addOccurrenceName@), but you'd be+wrong.  We do check (here) that they are in scope, but there is no+need to slurp in their actual declaration (which is what+@addOccurrenceName@ forces).++Indeed, doing so would big trouble when compiling @PrelBase@, because+it re-exports @GHC@, which includes @takeMVar#@, whose type includes+@ConcBase.StateAndSynchVar#@, and so on...++Note [Exports of data families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose you see (#5306)+        module M where+          import X( F )+          data instance F Int = FInt+What does M export?  AvailTC F [FInt]+                  or AvailTC F [F,FInt]?+The former is strictly right because F isn't defined in this module.+But then you can never do an explicit import of M, thus+    import M( F( FInt ) )+because F isn't exported by M.  Nor can you import FInt alone from here+    import M( FInt )+because we don't have syntax to support that.  (It looks like an import of+the type FInt.)++At one point I implemented a compromise:+  * When constructing exports with no export list, or with module M(+    module M ), we add the parent to the exports as well.+  * But not when you see module M( f ), even if f is a+    class method with a parent.+  * Nor when you see module M( module N ), with N /= M.++But the compromise seemed too much of a hack, so we backed it out.+You just have to use an explicit export list:+    module M( F(..) ) where ...++Note [Avails of associated data families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose you have (#16077)++    {-# LANGUAGE TypeFamilies #-}+    module A (module A) where++    class    C a  where { data T a }+    instance C () where { data T () = D }++Because @A@ is exported explicitly, GHC tries to produce an export list+from the @GlobalRdrEnv@. In this case, it pulls out the following:++    [ C defined at A.hs:4:1+    , T parent:C defined at A.hs:4:23+    , D parent:T defined at A.hs:5:35 ]++If map these directly into avails, (via 'availFromGRE'), we get+@[C{C;}, C{T;}, T{D;}]@, which eventually gets merged into @[C{C, T;}, T{D;}]@.+That's not right, because @T{D;}@ violates the AvailTC invariant: @T@ is+exported, but it isn't the first entry in the avail!++We work around this issue by expanding GREs where the parent and child+are both type constructors into two GRES.++    T parent:C defined at A.hs:4:23++      =>++    [ T parent:C defined at A.hs:4:23+    , T defined at A.hs:4:23 ]++Then, we get  @[C{C;}, C{T;}, T{T;}, T{D;}]@, which eventually gets merged+into @[C{C, T;}, T{T, D;}]@ (which satsifies the AvailTC invariant).+-}++data ExportAccum        -- The type of the accumulating parameter of+                        -- the main worker function in rnExports+     = ExportAccum+        ExportOccMap           --  Tracks exported occurrence names+        (UniqSet ModuleName)   --  Tracks (re-)exported module names++emptyExportAccum :: ExportAccum+emptyExportAccum = ExportAccum emptyOccEnv emptyUniqSet++accumExports :: (ExportAccum -> x -> TcRn (Maybe (ExportAccum, y)))+             -> [x]+             -> TcRn [y]+accumExports f = fmap (catMaybes . snd) . mapAccumLM f' emptyExportAccum+  where f' acc x = do+          m <- attemptM (f acc x)+          pure $ case m of+            Just (Just (acc', y)) -> (acc', Just y)+            _                     -> (acc, Nothing)++type ExportOccMap = OccEnv (Name, IE GhcPs)+        -- Tracks what a particular exported OccName+        --   in an export list refers to, and which item+        --   it came from.  It's illegal to export two distinct things+        --   that have the same occurrence name++tcRnExports :: Bool       -- False => no 'module M(..) where' header at all+          -> Maybe (Located [LIE GhcPs]) -- Nothing => no explicit export list+          -> TcGblEnv+          -> RnM TcGblEnv++        -- Complains if two distinct exports have same OccName+        -- Warns about identical exports.+        -- Complains about exports items not in scope++tcRnExports explicit_mod exports+          tcg_env@TcGblEnv { tcg_mod     = this_mod,+                              tcg_rdr_env = rdr_env,+                              tcg_imports = imports,+                              tcg_src     = hsc_src }+ = unsetWOptM Opt_WarnWarningsDeprecations $+       -- Do not report deprecations arising from the export+       -- list, to avoid bleating about re-exporting a deprecated+       -- thing (especially via 'module Foo' export item)+   do   {+        ; dflags <- getDynFlags+        ; let is_main_mod = mainModIs dflags == this_mod+        ; let default_main = case mainFunIs dflags of+                 Just main_fun+                     | is_main_mod -> mkUnqual varName (fsLit main_fun)+                 _                 -> main_RDR_Unqual+        ; has_main <- 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)+        -- See Note [Modules without a module header]+        ; let real_exports+                 | explicit_mod = exports+                 | has_main+                          = Just (noLoc [noLoc (IEVar noExt+                                     (noLoc (IEName $ noLoc default_main)))])+                        -- ToDo: the 'noLoc' here is unhelpful if 'main'+                        --       turns out to be out of scope+                 | otherwise = Nothing++        ; let do_it = exports_from_avail real_exports rdr_env imports this_mod+        ; (rn_exports, final_avails)+            <- if hsc_src == HsigFile+                then do (mb_r, msgs) <- tryTc do_it+                        case mb_r of+                            Just r  -> return r+                            Nothing -> addMessages msgs >> failM+                else checkNoErrs do_it+        ; let final_ns     = availsToNameSetWithSelectors final_avails++        ; traceRn "rnExports: Exports:" (ppr final_avails)++        ; let new_tcg_env =+                  tcg_env { tcg_exports    = final_avails,+                             tcg_rn_exports = case tcg_rn_exports tcg_env of+                                                Nothing -> Nothing+                                                Just _  -> rn_exports,+                            tcg_dus = tcg_dus tcg_env `plusDU`+                                      usesOnly final_ns }+        ; failIfErrsM+        ; return new_tcg_env }++exports_from_avail :: Maybe (Located [LIE GhcPs])+                         -- ^ 'Nothing' means no explicit export list+                   -> GlobalRdrEnv+                   -> ImportAvails+                         -- ^ Imported modules; this is used to test if a+                         -- @module Foo@ export is valid (it's not valid+                         -- if we didn't import @Foo@!)+                   -> Module+                   -> RnM (Maybe [(LIE GhcRn, Avails)], Avails)+                         -- (Nothing, _) <=> no explicit export list+                         -- if explicit export list is present it contains+                         -- each renamed export item together with its exported+                         -- names.++exports_from_avail Nothing rdr_env _imports _this_mod+   -- The same as (module M) where M is the current module name,+   -- so that's how we handle it, except we also export the data family+   -- when a data instance is exported.+  = do {+    ; warnMissingExportList <- woptM Opt_WarnMissingExportList+    ; warnIfFlag Opt_WarnMissingExportList+        warnMissingExportList+        (missingModuleExportWarn $ moduleName _this_mod)+    ; let avails =+            map fix_faminst . gresToAvailInfo+              . filter isLocalGRE . globalRdrEnvElts $ rdr_env+    ; return (Nothing, avails) }+  where+    -- #11164: when we define a data instance+    -- but not data family, re-export the family+    -- Even though we don't check whether this is actually a data family+    -- only data families can locally define subordinate things (`ns` here)+    -- without locally defining (and instead importing) the parent (`n`)+    fix_faminst (AvailTC n ns flds) =+      let new_ns =+            case ns of+              [] -> [n]+              (p:_) -> if p == n then ns else n:ns+      in AvailTC n new_ns flds++    fix_faminst avail = avail+++exports_from_avail (Just (dL->L _ rdr_items)) rdr_env imports this_mod+  = do ie_avails <- accumExports do_litem rdr_items+       let final_exports = nubAvails (concat (map snd ie_avails)) -- Combine families+       return (Just ie_avails, final_exports)+  where+    do_litem :: ExportAccum -> LIE GhcPs+             -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails)))+    do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie)++    -- Maps a parent to its in-scope children+    kids_env :: NameEnv [GlobalRdrElt]+    kids_env = mkChildEnv (globalRdrEnvElts rdr_env)++    -- See Note [Avails of associated data families]+    expand_tyty_gre :: GlobalRdrElt -> [GlobalRdrElt]+    expand_tyty_gre (gre @ GRE { gre_name = me, gre_par = ParentIs p })+      | isTyConName p, isTyConName me = [gre, gre{ gre_par = NoParent }]+    expand_tyty_gre gre = [gre]++    imported_modules = [ imv_name imv+                       | xs <- moduleEnvElts $ imp_mods imports+                       , imv <- importedByUser xs ]++    exports_from_item :: ExportAccum -> LIE GhcPs+                      -> RnM (Maybe (ExportAccum, (LIE GhcRn, Avails)))+    exports_from_item (ExportAccum occs earlier_mods)+                      (dL->L loc ie@(IEModuleContents _ lmod@(dL->L _ mod)))+        | mod `elementOfUniqSet` earlier_mods    -- Duplicate export of M+        = do { warnIfFlag Opt_WarnDuplicateExports True+                          (dupModuleExport mod) ;+               return Nothing }++        | otherwise+        = do { let { exportValid = (mod `elem` imported_modules)+                                || (moduleName this_mod == mod)+                   ; gre_prs     = pickGREsModExp mod (globalRdrEnvElts rdr_env)+                   ; new_exports = [ availFromGRE gre'+                                   | (gre, _) <- gre_prs+                                   , gre' <- expand_tyty_gre gre ]+                   ; all_gres    = foldr (\(gre1,gre2) gres -> gre1 : gre2 : gres) [] gre_prs+                   ; mods        = addOneToUniqSet earlier_mods mod+                   }++             ; checkErr exportValid (moduleNotImported mod)+             ; warnIfFlag Opt_WarnDodgyExports+                          (exportValid && null gre_prs)+                          (nullModuleExport mod)++             ; traceRn "efa" (ppr mod $$ ppr all_gres)+             ; addUsedGREs all_gres++             ; occs' <- check_occs ie occs new_exports+                      -- This check_occs not only finds conflicts+                      -- between this item and others, but also+                      -- internally within this item.  That is, if+                      -- 'M.x' is in scope in several ways, we'll have+                      -- several members of mod_avails with the same+                      -- OccName.+             ; traceRn "export_mod"+                       (vcat [ ppr mod+                             , ppr new_exports ])++             ; return (Just ( ExportAccum occs' mods+                            , ( cL loc (IEModuleContents noExt lmod)+                              , new_exports))) }++    exports_from_item acc@(ExportAccum occs mods) (dL->L loc ie)+        | isDoc ie+        = do new_ie <- lookup_doc_ie ie+             return (Just (acc, (cL loc new_ie, [])))++        | otherwise+        = do (new_ie, avail) <- lookup_ie ie+             if isUnboundName (ieName new_ie)+                  then return Nothing    -- Avoid error cascade+                  else do++                    occs' <- check_occs ie occs [avail]++                    return (Just ( ExportAccum occs' mods+                                 , (cL loc new_ie, [avail])))++    -------------+    lookup_ie :: IE GhcPs -> RnM (IE GhcRn, AvailInfo)+    lookup_ie (IEVar _ (dL->L l rdr))+        = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr+             return (IEVar noExt (cL l (replaceWrappedName rdr name)), avail)++    lookup_ie (IEThingAbs _ (dL->L l rdr))+        = do (name, avail) <- lookupGreAvailRn $ ieWrappedName rdr+             return (IEThingAbs noExt (cL l (replaceWrappedName rdr name))+                    , avail)++    lookup_ie ie@(IEThingAll _ n')+        = do+            (n, avail, flds) <- lookup_ie_all ie n'+            let name = unLoc n+            return (IEThingAll noExt (replaceLWrappedName n' (unLoc n))+                   , AvailTC name (name:avail) flds)+++    lookup_ie ie@(IEThingWith _ l wc sub_rdrs _)+        = do+            (lname, subs, avails, flds)+              <- addExportErrCtxt ie $ lookup_ie_with l sub_rdrs+            (_, all_avail, all_flds) <-+              case wc of+                NoIEWildcard -> return (lname, [], [])+                IEWildcard _ -> lookup_ie_all ie l+            let name = unLoc lname+            return (IEThingWith noExt (replaceLWrappedName l name) wc subs+                                (flds ++ (map noLoc all_flds)),+                    AvailTC name (name : avails ++ all_avail)+                                 (map unLoc flds ++ all_flds))+++    lookup_ie _ = panic "lookup_ie"    -- Other cases covered earlier+++    lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName]+                   -> RnM (Located Name, [LIEWrappedName Name], [Name],+                           [Located FieldLabel])+    lookup_ie_with (dL->L l rdr) sub_rdrs+        = do name <- lookupGlobalOccRn $ ieWrappedName rdr+             (non_flds, flds) <- lookupChildrenExport name sub_rdrs+             if isUnboundName name+                then return (cL l name, [], [name], [])+                else return (cL l name, non_flds+                            , map (ieWrappedName . unLoc) non_flds+                            , flds)++    lookup_ie_all :: IE GhcPs -> LIEWrappedName RdrName+                  -> RnM (Located Name, [Name], [FieldLabel])+    lookup_ie_all ie (dL->L l rdr) =+          do name <- lookupGlobalOccRn $ ieWrappedName rdr+             let gres = findChildren kids_env name+                 (non_flds, flds) = classifyGREs gres+             addUsedKids (ieWrappedName rdr) gres+             warnDodgyExports <- woptM Opt_WarnDodgyExports+             when (null gres) $+                  if isTyConName name+                  then when warnDodgyExports $+                           addWarn (Reason Opt_WarnDodgyExports)+                                   (dodgyExportWarn name)+                  else -- This occurs when you export T(..), but+                       -- only import T abstractly, or T is a synonym.+                       addErr (exportItemErr ie)+             return (cL l name, non_flds, flds)++    -------------+    lookup_doc_ie :: IE GhcPs -> RnM (IE GhcRn)+    lookup_doc_ie (IEGroup _ lev doc) = do rn_doc <- rnHsDoc doc+                                           return (IEGroup noExt lev rn_doc)+    lookup_doc_ie (IEDoc _ doc)       = do rn_doc <- rnHsDoc doc+                                           return (IEDoc noExt rn_doc)+    lookup_doc_ie (IEDocNamed _ str)  = return (IEDocNamed noExt str)+    lookup_doc_ie _ = panic "lookup_doc_ie"    -- Other cases covered earlier++    -- In an export item M.T(A,B,C), we want to treat the uses of+    -- A,B,C as if they were M.A, M.B, M.C+    -- Happily pickGREs does just the right thing+    addUsedKids :: RdrName -> [GlobalRdrElt] -> RnM ()+    addUsedKids parent_rdr kid_gres = addUsedGREs (pickGREs parent_rdr kid_gres)++classifyGREs :: [GlobalRdrElt] -> ([Name], [FieldLabel])+classifyGREs = partitionEithers . map classifyGRE++classifyGRE :: GlobalRdrElt -> Either Name FieldLabel+classifyGRE gre = case gre_par gre of+  FldParent _ Nothing -> Right (FieldLabel (occNameFS (nameOccName n)) False n)+  FldParent _ (Just lbl) -> Right (FieldLabel lbl True n)+  _                      -> Left  n+  where+    n = gre_name gre++isDoc :: IE GhcPs -> Bool+isDoc (IEDoc {})      = True+isDoc (IEDocNamed {}) = True+isDoc (IEGroup {})    = True+isDoc _ = False++-- Renaming and typechecking of exports happens after everything else has+-- been typechecked.++{-+Note [Modules without a module header]+--------------------------------------------------++The Haskell 2010 report says in section 5.1:++>> An abbreviated form of module, consisting only of the module body, is+>> permitted. If this is used, the header is assumed to be+>> ‘module Main(main) where’.++For modules without a module header, this is implemented the+following way:++If the module has a main function:+   Then create a module header and export the main function.+   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 NO main function:+   Then export all top-level functions. This marks all top level+   functions as 'used'.+   In GHCi this has the effect, that we don't get any 'non-used' warnings.+   In GHC, however, the 'has-main-module' check in the module+   compiler/typecheck/TcRnDriver (functions checkMain / check-main) fires,+   and we get the error:+      The IO action ‘main’ is not defined in module ‘Main’+-}+++-- Renaming exports lists is a minefield. Five different things can appear in+-- children export lists ( T(A, B, C) ).+-- 1. Record selectors+-- 2. Type constructors+-- 3. Data constructors+-- 4. Pattern Synonyms+-- 5. Pattern Synonym Selectors+--+-- However, things get put into weird name spaces.+-- 1. Some type constructors are parsed as variables (-.->) for example.+-- 2. All data constructors are parsed as type constructors+-- 3. When there is ambiguity, we default type constructors to data+-- constructors and require the explicit `type` keyword for type+-- constructors.+--+-- This function first establishes the possible namespaces that an+-- identifier might be in (`choosePossibleNameSpaces`).+--+-- Then for each namespace in turn, tries to find the correct identifier+-- there returning the first positive result or the first terminating+-- error.+--++++lookupChildrenExport :: Name -> [LIEWrappedName RdrName]+                     -> RnM ([LIEWrappedName Name], [Located FieldLabel])+lookupChildrenExport spec_parent rdr_items =+  do+    xs <- mapAndReportM doOne rdr_items+    return $ partitionEithers xs+    where+        -- Pick out the possible namespaces in order of priority+        -- This is a consequence of how the parser parses all+        -- data constructors as type constructors.+        choosePossibleNamespaces :: NameSpace -> [NameSpace]+        choosePossibleNamespaces ns+          | ns == varName = [varName, tcName]+          | ns == tcName  = [dataName, tcName]+          | otherwise = [ns]+        -- Process an individual child+        doOne :: LIEWrappedName RdrName+              -> RnM (Either (LIEWrappedName Name) (Located FieldLabel))+        doOne n = do++          let bareName = (ieWrappedName . unLoc) n+              lkup v = lookupSubBndrOcc_helper False True+                        spec_parent (setRdrNameSpace bareName v)++          name <-  combineChildLookupResult $ map lkup $+                   choosePossibleNamespaces (rdrNameSpace bareName)+          traceRn "lookupChildrenExport" (ppr name)+          -- Default to data constructors for slightly better error+          -- messages+          let unboundName :: RdrName+              unboundName = if rdrNameSpace bareName == varName+                                then bareName+                                else setRdrNameSpace bareName dataName++          case name of+            NameNotFound -> do { ub <- reportUnboundName unboundName+                               ; let l = getLoc n+                               ; return (Left (cL l (IEName (cL l ub))))}+            FoundFL fls -> return $ Right (cL (getLoc n) fls)+            FoundName par name -> do { checkPatSynParent spec_parent par name+                                     ; return+                                       $ Left (replaceLWrappedName n name) }+            IncorrectParent p g td gs -> failWithDcErr p g td gs+++-- Note: [Typing Pattern Synonym Exports]+-- It proved quite a challenge to precisely specify which pattern synonyms+-- should be allowed to be bundled with which type constructors.+-- In the end it was decided to be quite liberal in what we allow. Below is+-- how Simon described the implementation.+--+-- "Personally I think we should Keep It Simple.  All this talk of+--  satisfiability makes me shiver.  I suggest this: allow T( P ) in all+--   situations except where `P`'s type is ''visibly incompatible'' with+--   `T`.+--+--    What does "visibly incompatible" mean?  `P` is visibly incompatible+--    with+--     `T` if+--       * `P`'s type is of form `... -> S t1 t2`+--       * `S` is a data/newtype constructor distinct from `T`+--+--  Nothing harmful happens if we allow `P` to be exported with+--  a type it can't possibly be useful for, but specifying a tighter+--  relationship is very awkward as you have discovered."+--+-- Note that this allows *any* pattern synonym to be bundled with any+-- datatype type constructor. For example, the following pattern `P` can be+-- bundled with any type.+--+-- ```+-- pattern P :: (A ~ f) => f+-- ```+--+-- So we provide basic type checking in order to help the user out, most+-- pattern synonyms are defined with definite type constructors, but don't+-- actually prevent a library author completely confusing their users if+-- they want to.+--+-- So, we check for exactly four things+-- 1. The name arises from a pattern synonym definition. (Either a pattern+--    synonym constructor or a pattern synonym selector)+-- 2. The pattern synonym is only bundled with a datatype or newtype.+-- 3. Check that the head of the result type constructor is an actual type+--    constructor and not a type variable. (See above example)+-- 4. Is so, check that this type constructor is the same as the parent+--    type constructor.+--+--+-- Note: [Types of TyCon]+--+-- This check appears to be overlly complicated, Richard asked why it+-- is not simply just `isAlgTyCon`. The answer for this is that+-- a classTyCon is also an `AlgTyCon` which we explicitly want to disallow.+-- (It is either a newtype or data depending on the number of methods)+--++-- | Given a resolved name in the children export list and a parent. Decide+-- whether we are allowed to export the child with the parent.+-- Invariant: gre_par == NoParent+-- See note [Typing Pattern Synonym Exports]+checkPatSynParent :: Name    -- ^ Alleged parent type constructor+                             -- User wrote T( P, Q )+                  -> Parent  -- The parent of P we discovered+                  -> Name    -- ^ Either a+                             --   a) Pattern Synonym Constructor+                             --   b) A pattern synonym selector+                  -> TcM ()  -- Fails if wrong parent+checkPatSynParent _ (ParentIs {}) _+  = return ()++checkPatSynParent _ (FldParent {}) _+  = return ()++checkPatSynParent parent NoParent mpat_syn+  | isUnboundName parent -- Avoid an error cascade+  = return ()++  | otherwise+  = do { parent_ty_con <- tcLookupTyCon parent+       ; mpat_syn_thing <- tcLookupGlobal mpat_syn++        -- 1. Check that the Id was actually from a thing associated with patsyns+       ; case mpat_syn_thing of+            AnId i | isId i+                   , RecSelId { sel_tycon = RecSelPatSyn p } <- idDetails i+                   -> handle_pat_syn (selErr i) parent_ty_con p++            AConLike (PatSynCon p) -> handle_pat_syn (psErr p) parent_ty_con p++            _ -> failWithDcErr parent mpat_syn (ppr mpat_syn) [] }+  where+    psErr  = exportErrCtxt "pattern synonym"+    selErr = exportErrCtxt "pattern synonym record selector"++    assocClassErr :: SDoc+    assocClassErr = text "Pattern synonyms can be bundled only with datatypes."++    handle_pat_syn :: SDoc+                   -> TyCon      -- ^ Parent TyCon+                   -> PatSyn     -- ^ Corresponding bundled PatSyn+                                 --   and pretty printed origin+                   -> TcM ()+    handle_pat_syn doc ty_con pat_syn++      -- 2. See note [Types of TyCon]+      | not $ isTyConWithSrcDataCons ty_con+      = addErrCtxt doc $ failWithTc assocClassErr++      -- 3. Is the head a type variable?+      | Nothing <- mtycon+      = return ()+      -- 4. Ok. Check they are actually the same type constructor.++      | Just p_ty_con <- mtycon, p_ty_con /= ty_con+      = addErrCtxt doc $ failWithTc typeMismatchError++      -- 5. We passed!+      | otherwise+      = return ()++      where+        expected_res_ty = mkTyConApp ty_con (mkTyVarTys (tyConTyVars ty_con))+        (_, _, _, _, _, res_ty) = patSynSig pat_syn+        mtycon = fst <$> tcSplitTyConApp_maybe res_ty+        typeMismatchError :: SDoc+        typeMismatchError =+          text "Pattern synonyms can only be bundled with matching type constructors"+              $$ text "Couldn't match expected type of"+              <+> quotes (ppr expected_res_ty)+              <+> text "with actual type of"+              <+> quotes (ppr res_ty)+++{-===========================================================================-}+check_occs :: IE GhcPs -> ExportOccMap -> [AvailInfo]+           -> RnM ExportOccMap+check_occs ie occs avails+  -- 'names' and 'fls' are the entities specified by 'ie'+  = foldlM check occs names_with_occs+  where+    -- Each Name specified by 'ie', paired with the OccName used to+    -- refer to it in the GlobalRdrEnv+    -- (see Note [Representing fields in AvailInfo] in Avail).+    --+    -- We check for export clashes using the selector Name, but need+    -- the field label OccName for presenting error messages.+    names_with_occs = availsNamesWithOccs avails++    check occs (name, occ)+      = case lookupOccEnv occs name_occ of+          Nothing -> return (extendOccEnv occs name_occ (name, ie))++          Just (name', ie')+            | name == name'   -- Duplicate export+            -- But we don't want to warn if the same thing is exported+            -- by two different module exports. See ticket #4478.+            -> do { warnIfFlag Opt_WarnDuplicateExports+                               (not (dupExport_ok name ie ie'))+                               (dupExportWarn occ ie ie')+                  ; return occs }++            | otherwise    -- Same occ name but different names: an error+            ->  do { global_env <- getGlobalRdrEnv ;+                     addErr (exportClashErr global_env occ name' name ie' ie) ;+                     return occs }+      where+        name_occ = nameOccName name+++dupExport_ok :: Name -> IE GhcPs -> IE GhcPs -> Bool+-- The Name is exported by both IEs. Is that ok?+-- "No"  iff the name is mentioned explicitly in both IEs+--        or one of the IEs mentions the name *alone*+-- "Yes" otherwise+--+-- Examples of "no":  module M( f, f )+--                    module M( fmap, Functor(..) )+--                    module M( module Data.List, head )+--+-- Example of "yes"+--    module M( module A, module B ) where+--        import A( f )+--        import B( f )+--+-- Example of "yes" (#2436)+--    module M( C(..), T(..) ) where+--         class C a where { data T a }+--         instance C Int where { data T Int = TInt }+--+-- Example of "yes" (#2436)+--    module Foo ( T ) where+--      data family T a+--    module Bar ( T(..), module Foo ) where+--        import Foo+--        data instance T Int = TInt++dupExport_ok n ie1 ie2+  = not (  single ie1 || single ie2+        || (explicit_in ie1 && explicit_in ie2) )+  where+    explicit_in (IEModuleContents {}) = False                   -- module M+    explicit_in (IEThingAll _ r)+      = nameOccName n == rdrNameOcc (ieWrappedName $ unLoc r)  -- T(..)+    explicit_in _              = True++    single IEVar {}      = True+    single IEThingAbs {} = True+    single _               = False+++dupModuleExport :: ModuleName -> SDoc+dupModuleExport mod+  = hsep [text "Duplicate",+          quotes (text "Module" <+> ppr mod),+          text "in export list"]++moduleNotImported :: ModuleName -> SDoc+moduleNotImported mod+  = hsep [text "The export item",+          quotes (text "module" <+> ppr mod),+          text "is not imported"]++nullModuleExport :: ModuleName -> SDoc+nullModuleExport mod+  = hsep [text "The export item",+          quotes (text "module" <+> ppr mod),+          text "exports nothing"]++missingModuleExportWarn :: ModuleName -> SDoc+missingModuleExportWarn mod+  = hsep [text "The export item",+          quotes (text "module" <+> ppr mod),+          text "is missing an export list"]+++dodgyExportWarn :: Name -> SDoc+dodgyExportWarn item+  = dodgyMsg (text "export") item (dodgyMsgInsert item :: IE GhcRn)++exportErrCtxt :: Outputable o => String -> o -> SDoc+exportErrCtxt herald exp =+  text "In the" <+> text (herald ++ ":") <+> ppr exp+++addExportErrCtxt :: (OutputableBndrId (GhcPass p))+                 => IE (GhcPass p) -> TcM a -> TcM a+addExportErrCtxt ie = addErrCtxt exportCtxt+  where+    exportCtxt = text "In the export:" <+> ppr ie++exportItemErr :: IE GhcPs -> SDoc+exportItemErr export_item+  = sep [ text "The export item" <+> quotes (ppr export_item),+          text "attempts to export constructors or class methods that are not visible here" ]+++dupExportWarn :: OccName -> IE GhcPs -> IE GhcPs -> SDoc+dupExportWarn occ_name ie1 ie2+  = hsep [quotes (ppr occ_name),+          text "is exported by", quotes (ppr ie1),+          text "and",            quotes (ppr ie2)]++dcErrMsg :: Name -> String -> SDoc -> [SDoc] -> SDoc+dcErrMsg ty_con what_is thing parents =+          text "The type constructor" <+> quotes (ppr ty_con)+                <+> text "is not the parent of the" <+> text what_is+                <+> quotes thing <> char '.'+                $$ text (capitalise what_is)+                <> text "s can only be exported with their parent type constructor."+                $$ (case parents of+                      [] -> empty+                      [_] -> text "Parent:"+                      _  -> text "Parents:") <+> fsep (punctuate comma parents)++failWithDcErr :: Name -> Name -> SDoc -> [Name] -> TcM a+failWithDcErr parent thing thing_doc parents = do+  ty_thing <- tcLookupGlobal thing+  failWithTc $ dcErrMsg parent (tyThingCategory' ty_thing)+                        thing_doc (map ppr parents)+  where+    tyThingCategory' :: TyThing -> String+    tyThingCategory' (AnId i)+      | isRecordSelector i = "record selector"+    tyThingCategory' i = tyThingCategory i+++exportClashErr :: GlobalRdrEnv -> OccName+               -> Name -> Name+               -> IE GhcPs -> IE GhcPs+               -> MsgDoc+exportClashErr global_env occ name1 name2 ie1 ie2+  = vcat [ text "Conflicting exports for" <+> quotes (ppr occ) <> colon+         , ppr_export ie1' name1'+         , ppr_export ie2' name2' ]+  where+    ppr_export ie name = nest 3 (hang (quotes (ppr ie) <+> text "exports" <+>+                                       quotes (ppr_name name))+                                    2 (pprNameProvenance (get_gre name)))++    -- DuplicateRecordFields means that nameOccName might be a mangled+    -- $sel-prefixed thing, in which case show the correct OccName alone+    ppr_name name+      | nameOccName name == occ = ppr name+      | otherwise               = ppr occ++    -- get_gre finds a GRE for the Name, so that we can show its provenance+    get_gre name+        = fromMaybe (pprPanic "exportClashErr" (ppr name))+                    (lookupGRE_Name_OccName global_env name occ)+    get_loc name = greSrcSpan (get_gre name)+    (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2+                                   then (name1, ie1, name2, ie2)+                                   else (name2, ie2, name1, ie1)
+ compiler/typecheck/TcRnMonad.hs view
@@ -0,0 +1,2051 @@+{-+(c) The University of Glasgow 2006+++Functions for working with the typechecker environment (setters, getters...).+-}++{-# LANGUAGE CPP, ExplicitForAll, FlexibleInstances, BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE ViewPatterns #-}+++module TcRnMonad(+  -- * Initalisation+  initTc, initTcWithGbl, initTcInteractive, initTcRnIf,++  -- * Simple accessors+  discardResult,+  getTopEnv, updTopEnv, getGblEnv, updGblEnv,+  setGblEnv, getLclEnv, updLclEnv, setLclEnv,+  getEnvs, setEnvs,+  xoptM, doptM, goptM, woptM,+  setXOptM, unsetXOptM, unsetGOptM, unsetWOptM,+  whenDOptM, whenGOptM, whenWOptM,+  whenXOptM, unlessXOptM,+  getGhcMode,+  withDoDynamicToo,+  getEpsVar,+  getEps,+  updateEps, updateEps_,+  getHpt, getEpsAndHpt,++  -- * Arrow scopes+  newArrowScope, escapeArrowScope,++  -- * Unique supply+  newUnique, newUniqueSupply, newName, newNameAt, cloneLocalName,+  newSysName, newSysLocalId, newSysLocalIds,++  -- * Accessing input/output+  newTcRef, readTcRef, writeTcRef, updTcRef,++  -- * Debugging+  traceTc, traceRn, traceOptTcRn, traceTcRn, traceTcRnForUser,+  traceTcRnWithStyle,+  getPrintUnqualified,+  printForUserTcRn,+  traceIf, traceHiDiffs, traceOptIf,+  debugTc,++  -- * Typechecker global environment+  getIsGHCi, getGHCiMonad, getInteractivePrintName,+  tcIsHsBootOrSig, tcIsHsig, tcSelfBootInfo, getGlobalRdrEnv,+  getRdrEnvs, getImports,+  getFixityEnv, extendFixityEnv, getRecFieldEnv,+  getDeclaredDefaultTys,+  addDependentFiles,++  -- * Error management+  getSrcSpanM, setSrcSpan, addLocM,+  wrapLocM, wrapLocFstM, wrapLocSndM,wrapLocM_,+  getErrsVar, setErrsVar,+  addErr,+  failWith, failAt,+  addErrAt, addErrs,+  checkErr,+  addMessages,+  discardWarnings,++  -- * Shared error message stuff: renamer and typechecker+  mkLongErrAt, mkErrDocAt, addLongErrAt, reportErrors, reportError,+  reportWarning, recoverM, mapAndRecoverM, mapAndReportM, foldAndRecoverM,+  attemptM, tryTc,+  askNoErrs, discardErrs, tryTcDiscardingErrs,+  checkNoErrs, whenNoErrs,+  ifErrsM, failIfErrsM,+  checkTH, failTH,++  -- * Context management for the type checker+  getErrCtxt, setErrCtxt, addErrCtxt, addErrCtxtM, addLandmarkErrCtxt,+  addLandmarkErrCtxtM, updCtxt, popErrCtxt, getCtLocM, setCtLocM,++  -- * Error message generation (type checker)+  addErrTc, addErrsTc,+  addErrTcM, mkErrTcM, mkErrTc,+  failWithTc, failWithTcM,+  checkTc, checkTcM,+  failIfTc, failIfTcM,+  warnIfFlag, warnIf, warnTc, warnTcM,+  addWarnTc, addWarnTcM, addWarn, addWarnAt, add_warn,+  mkErrInfo,++  -- * Type constraints+  newTcEvBinds, newNoTcEvBinds, cloneEvBindsVar,+  addTcEvBind, addTopEvBinds,+  getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,+  chooseUniqueOccTc,+  getConstraintVar, setConstraintVar,+  emitConstraints, emitStaticConstraints, emitSimple, emitSimples,+  emitImplication, emitImplications, emitInsoluble,+  discardConstraints, captureConstraints, tryCaptureConstraints,+  pushLevelAndCaptureConstraints,+  pushTcLevelM_, pushTcLevelM, pushTcLevelsM,+  getTcLevel, setTcLevel, isTouchableTcM,+  getLclTypeEnv, setLclTypeEnv,+  traceTcConstraints, emitWildCardHoleConstraints,++  -- * Template Haskell context+  recordThUse, recordThSpliceUse, recordTopLevelSpliceLoc,+  getTopLevelSpliceLocs, keepAlive, getStage, getStageAndBindLevel, setStage,+  addModFinalizersWithLclEnv,++  -- * Safe Haskell context+  recordUnsafeInfer, finalSafeMode, fixSafeInstances,++  -- * Stuff for the renamer's local env+  getLocalRdrEnv, setLocalRdrEnv,++  -- * Stuff for interface decls+  mkIfLclEnv,+  initIfaceTcRn,+  initIfaceCheck,+  initIfaceLcl,+  initIfaceLclWithSubst,+  initIfaceLoad,+  getIfModule,+  failIfM,+  forkM_maybe,+  forkM,+  setImplicitEnvM,++  withException,++  -- * Stuff for cost centres.+  ContainsCostCentreState(..), getCCIndexM,++  -- * Types etc.+  module TcRnTypes,+  module IOEnv+  ) where++#include "HsVersions.h"++import GhcPrelude++import TcRnTypes        -- Re-export all+import IOEnv            -- Re-export all+import TcEvidence++import HsSyn hiding (LIE)+import HscTypes+import Module+import RdrName+import Name+import Type++import TcType+import InstEnv+import FamInstEnv+import PrelNames++import Id+import VarSet+import VarEnv+import ErrUtils+import SrcLoc+import NameEnv+import NameSet+import Bag+import Outputable+import UniqSupply+import DynFlags+import FastString+import Panic+import Util+import Annotations+import BasicTypes( TopLevelFlag )+import Maybes+import CostCentreState++import qualified GHC.LanguageExtensions as LangExt++import Data.IORef+import Control.Monad+import Data.Set ( Set )+import qualified Data.Set as Set++import {-# SOURCE #-} TcEnv    ( tcInitTidyEnv )++import qualified Data.Map as Map++{-+************************************************************************+*                                                                      *+                        initTc+*                                                                      *+************************************************************************+-}++-- | Setup the initial typechecking environment+initTc :: HscEnv+       -> HscSource+       -> Bool          -- True <=> retain renamed syntax trees+       -> Module+       -> RealSrcSpan+       -> TcM r+       -> IO (Messages, Maybe r)+                -- Nothing => error thrown by the thing inside+                -- (error messages should have been printed already)++initTc hsc_env hsc_src keep_rn_syntax mod loc do_this+ = do { keep_var     <- newIORef emptyNameSet ;+        used_gre_var <- newIORef [] ;+        th_var       <- newIORef False ;+        th_splice_var<- newIORef False ;+        th_locs_var  <- newIORef Set.empty ;+        infer_var    <- newIORef (True, emptyBag) ;+        dfun_n_var   <- newIORef emptyOccSet ;+        type_env_var <- case hsc_type_env_var hsc_env of {+                           Just (_mod, te_var) -> return te_var ;+                           Nothing             -> newIORef emptyNameEnv } ;++        dependent_files_var <- newIORef [] ;+        static_wc_var       <- newIORef emptyWC ;+        cc_st_var           <- newIORef newCostCentreState ;+        th_topdecls_var      <- newIORef [] ;+        th_foreign_files_var <- newIORef [] ;+        th_topnames_var      <- newIORef emptyNameSet ;+        th_modfinalizers_var <- newIORef [] ;+        th_coreplugins_var <- newIORef [] ;+        th_state_var         <- newIORef Map.empty ;+        th_remote_state_var  <- newIORef Nothing ;+        let {+             dflags = hsc_dflags hsc_env ;++             maybe_rn_syntax :: forall a. a -> Maybe a ;+             maybe_rn_syntax empty_val+                | dopt Opt_D_dump_rn_ast dflags = Just empty_val++                | gopt Opt_WriteHie dflags       = Just empty_val++                  -- We want to serialize the documentation in the .hi-files,+                  -- and need to extract it from the renamed syntax first.+                  -- See 'ExtractDocs.extractDocs'.+                | gopt Opt_Haddock dflags       = Just empty_val++                | keep_rn_syntax                = Just empty_val+                | otherwise                     = Nothing ;++             gbl_env = TcGblEnv {+                tcg_th_topdecls      = th_topdecls_var,+                tcg_th_foreign_files = th_foreign_files_var,+                tcg_th_topnames      = th_topnames_var,+                tcg_th_modfinalizers = th_modfinalizers_var,+                tcg_th_coreplugins = th_coreplugins_var,+                tcg_th_state         = th_state_var,+                tcg_th_remote_state  = th_remote_state_var,++                tcg_mod            = mod,+                tcg_semantic_mod   =+                    canonicalizeModuleIfHome dflags mod,+                tcg_src            = hsc_src,+                tcg_rdr_env        = emptyGlobalRdrEnv,+                tcg_fix_env        = emptyNameEnv,+                tcg_field_env      = emptyNameEnv,+                tcg_default        = if moduleUnitId mod == primUnitId+                                     then Just []  -- See Note [Default types]+                                     else Nothing,+                tcg_type_env       = emptyNameEnv,+                tcg_type_env_var   = type_env_var,+                tcg_inst_env       = emptyInstEnv,+                tcg_fam_inst_env   = emptyFamInstEnv,+                tcg_ann_env        = emptyAnnEnv,+                tcg_th_used        = th_var,+                tcg_th_splice_used = th_splice_var,+                tcg_th_top_level_locs+                                   = th_locs_var,+                tcg_exports        = [],+                tcg_imports        = emptyImportAvails,+                tcg_used_gres     = used_gre_var,+                tcg_dus            = emptyDUs,++                tcg_rn_imports     = [],+                tcg_rn_exports     =+                    if hsc_src == HsigFile+                        -- Always retain renamed syntax, so that we can give+                        -- better errors.  (TODO: how?)+                        then Just []+                        else maybe_rn_syntax [],+                tcg_rn_decls       = maybe_rn_syntax emptyRnGroup,+                tcg_tr_module      = Nothing,+                tcg_binds          = emptyLHsBinds,+                tcg_imp_specs      = [],+                tcg_sigs           = emptyNameSet,+                tcg_ev_binds       = emptyBag,+                tcg_warns          = NoWarnings,+                tcg_anns           = [],+                tcg_tcs            = [],+                tcg_insts          = [],+                tcg_fam_insts      = [],+                tcg_rules          = [],+                tcg_fords          = [],+                tcg_patsyns        = [],+                tcg_merged         = [],+                tcg_dfun_n         = dfun_n_var,+                tcg_keep           = keep_var,+                tcg_doc_hdr        = Nothing,+                tcg_hpc            = False,+                tcg_main           = Nothing,+                tcg_self_boot      = NoSelfBoot,+                tcg_safeInfer      = infer_var,+                tcg_dependent_files = dependent_files_var,+                tcg_tc_plugins     = [],+                tcg_top_loc        = loc,+                tcg_static_wc      = static_wc_var,+                tcg_complete_matches = [],+                tcg_cc_st          = cc_st_var+             } ;+        } ;++        -- OK, here's the business end!+        initTcWithGbl hsc_env gbl_env loc do_this+    }++-- | Run a 'TcM' action in the context of an existing 'GblEnv'.+initTcWithGbl :: HscEnv+              -> TcGblEnv+              -> RealSrcSpan+              -> TcM r+              -> IO (Messages, Maybe r)+initTcWithGbl hsc_env gbl_env loc do_this+ = do { tvs_var      <- newIORef emptyVarSet+      ; lie_var      <- newIORef emptyWC+      ; errs_var     <- newIORef (emptyBag, emptyBag)+      ; let lcl_env = TcLclEnv {+                tcl_errs       = errs_var,+                tcl_loc        = loc,     -- Should be over-ridden very soon!+                tcl_ctxt       = [],+                tcl_rdr        = emptyLocalRdrEnv,+                tcl_th_ctxt    = topStage,+                tcl_th_bndrs   = emptyNameEnv,+                tcl_arrow_ctxt = NoArrowCtxt,+                tcl_env        = emptyNameEnv,+                tcl_bndrs      = [],+                tcl_tyvars     = tvs_var,+                tcl_lie        = lie_var,+                tcl_tclvl      = topTcLevel+                }++      ; maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $+                     do { r <- tryM do_this+                        ; case r of+                          Right res -> return (Just res)+                          Left _    -> return Nothing }++      -- Check for unsolved constraints+      -- If we succeed (maybe_res = Just r), there should be+      -- no unsolved constraints.  But if we exit via an+      -- exception (maybe_res = Nothing), we may have skipped+      -- solving, so don't panic then (#13466)+      ; lie <- readIORef (tcl_lie lcl_env)+      ; when (isJust maybe_res && not (isEmptyWC lie)) $+        pprPanic "initTc: unsolved constraints" (ppr lie)++        -- Collect any error messages+      ; msgs <- readIORef (tcl_errs lcl_env)++      ; let { final_res | errorsFound dflags msgs = Nothing+                        | otherwise               = maybe_res }++      ; return (msgs, final_res)+      }+  where dflags = hsc_dflags hsc_env++initTcInteractive :: HscEnv -> TcM a -> IO (Messages, Maybe a)+-- Initialise the type checker monad for use in GHCi+initTcInteractive hsc_env thing_inside+  = initTc hsc_env HsSrcFile False+           (icInteractiveModule (hsc_IC hsc_env))+           (realSrcLocSpan interactive_src_loc)+           thing_inside+  where+    interactive_src_loc = mkRealSrcLoc (fsLit "<interactive>") 1 1++{- Note [Default types]+~~~~~~~~~~~~~~~~~~~~~~~+The Integer type is simply not available in package ghc-prim (it is+declared in integer-gmp).  So we set the defaulting types to (Just+[]), meaning there are no default types, rather then Nothing, which+means "use the default default types of Integer, Double".++If you don't do this, attempted defaulting in package ghc-prim causes+an actual crash (attempting to look up the Integer type).+++************************************************************************+*                                                                      *+                Initialisation+*                                                                      *+************************************************************************+-}++initTcRnIf :: Char              -- Tag for unique supply+           -> HscEnv+           -> gbl -> lcl+           -> TcRnIf gbl lcl a+           -> IO a+initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside+   = do { us     <- mkSplitUniqSupply uniq_tag ;+        ; us_var <- newIORef us ;++        ; let { env = Env { env_top = hsc_env,+                            env_us  = us_var,+                            env_gbl = gbl_env,+                            env_lcl = lcl_env} }++        ; runIOEnv env thing_inside+        }++{-+************************************************************************+*                                                                      *+                Simple accessors+*                                                                      *+************************************************************************+-}++discardResult :: TcM a -> TcM ()+discardResult a = a >> return ()++getTopEnv :: TcRnIf gbl lcl HscEnv+getTopEnv = do { env <- getEnv; return (env_top env) }++updTopEnv :: (HscEnv -> HscEnv) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+updTopEnv upd = updEnv (\ env@(Env { env_top = top }) ->+                          env { env_top = upd top })++getGblEnv :: TcRnIf gbl lcl gbl+getGblEnv = do { Env{..} <- getEnv; return env_gbl }++updGblEnv :: (gbl -> gbl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+updGblEnv upd = updEnv (\ env@(Env { env_gbl = gbl }) ->+                          env { env_gbl = upd gbl })++setGblEnv :: gbl -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+setGblEnv gbl_env = updEnv (\ env -> env { env_gbl = gbl_env })++getLclEnv :: TcRnIf gbl lcl lcl+getLclEnv = do { Env{..} <- getEnv; return env_lcl }++updLclEnv :: (lcl -> lcl) -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+updLclEnv upd = updEnv (\ env@(Env { env_lcl = lcl }) ->+                          env { env_lcl = upd lcl })++setLclEnv :: lcl' -> TcRnIf gbl lcl' a -> TcRnIf gbl lcl a+setLclEnv lcl_env = updEnv (\ env -> env { env_lcl = lcl_env })++getEnvs :: TcRnIf gbl lcl (gbl, lcl)+getEnvs = do { env <- getEnv; return (env_gbl env, env_lcl env) }++setEnvs :: (gbl', lcl') -> TcRnIf gbl' lcl' a -> TcRnIf gbl lcl a+setEnvs (gbl_env, lcl_env) = updEnv (\ env -> env { env_gbl = gbl_env, env_lcl = lcl_env })++-- Command-line flags++xoptM :: LangExt.Extension -> TcRnIf gbl lcl Bool+xoptM flag = do { dflags <- getDynFlags; return (xopt flag dflags) }++doptM :: DumpFlag -> TcRnIf gbl lcl Bool+doptM flag = do { dflags <- getDynFlags; return (dopt flag dflags) }++goptM :: GeneralFlag -> TcRnIf gbl lcl Bool+goptM flag = do { dflags <- getDynFlags; return (gopt flag dflags) }++woptM :: WarningFlag -> TcRnIf gbl lcl Bool+woptM flag = do { dflags <- getDynFlags; return (wopt flag dflags) }++setXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+setXOptM flag =+  updTopEnv (\top -> top { hsc_dflags = xopt_set (hsc_dflags top) flag})++unsetXOptM :: LangExt.Extension -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+unsetXOptM flag =+  updTopEnv (\top -> top { hsc_dflags = xopt_unset (hsc_dflags top) flag})++unsetGOptM :: GeneralFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+unsetGOptM flag =+  updTopEnv (\top -> top { hsc_dflags = gopt_unset (hsc_dflags top) flag})++unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a+unsetWOptM flag =+  updTopEnv (\top -> top { hsc_dflags = wopt_unset (hsc_dflags top) flag})++-- | Do it flag is true+whenDOptM :: DumpFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()+whenDOptM flag thing_inside = do b <- doptM flag+                                 when b thing_inside++whenGOptM :: GeneralFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()+whenGOptM flag thing_inside = do b <- goptM flag+                                 when b thing_inside++whenWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()+whenWOptM flag thing_inside = do b <- woptM flag+                                 when b thing_inside++whenXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()+whenXOptM flag thing_inside = do b <- xoptM flag+                                 when b thing_inside++unlessXOptM :: LangExt.Extension -> TcRnIf gbl lcl () -> TcRnIf gbl lcl ()+unlessXOptM flag thing_inside = do b <- xoptM flag+                                   unless b thing_inside++getGhcMode :: TcRnIf gbl lcl GhcMode+getGhcMode = do { env <- getTopEnv; return (ghcMode (hsc_dflags env)) }++withDoDynamicToo :: TcRnIf gbl lcl a -> TcRnIf gbl lcl a+withDoDynamicToo =+  updTopEnv (\top@(HscEnv { hsc_dflags = dflags }) ->+              top { hsc_dflags = dynamicTooMkDynamicDynFlags dflags })++getEpsVar :: TcRnIf gbl lcl (TcRef ExternalPackageState)+getEpsVar = do { env <- getTopEnv; return (hsc_EPS env) }++getEps :: TcRnIf gbl lcl ExternalPackageState+getEps = do { env <- getTopEnv; readMutVar (hsc_EPS env) }++-- | Update the external package state.  Returns the second result of the+-- modifier function.+--+-- This is an atomic operation and forces evaluation of the modified EPS in+-- order to avoid space leaks.+updateEps :: (ExternalPackageState -> (ExternalPackageState, a))+          -> TcRnIf gbl lcl a+updateEps upd_fn = do+  traceIf (text "updating EPS")+  eps_var <- getEpsVar+  atomicUpdMutVar' eps_var upd_fn++-- | Update the external package state.+--+-- This is an atomic operation and forces evaluation of the modified EPS in+-- order to avoid space leaks.+updateEps_ :: (ExternalPackageState -> ExternalPackageState)+           -> TcRnIf gbl lcl ()+updateEps_ upd_fn = do+  traceIf (text "updating EPS_")+  eps_var <- getEpsVar+  atomicUpdMutVar' eps_var (\eps -> (upd_fn eps, ()))++getHpt :: TcRnIf gbl lcl HomePackageTable+getHpt = do { env <- getTopEnv; return (hsc_HPT env) }++getEpsAndHpt :: TcRnIf gbl lcl (ExternalPackageState, HomePackageTable)+getEpsAndHpt = do { env <- getTopEnv; eps <- readMutVar (hsc_EPS env)+                  ; return (eps, hsc_HPT env) }++-- | A convenient wrapper for taking a @MaybeErr MsgDoc a@ and throwing+-- an exception if it is an error.+withException :: TcRnIf gbl lcl (MaybeErr MsgDoc a) -> TcRnIf gbl lcl a+withException do_this = do+    r <- do_this+    dflags <- getDynFlags+    case r of+        Failed err -> liftIO $ throwGhcExceptionIO (ProgramError (showSDoc dflags err))+        Succeeded result -> return result++{-+************************************************************************+*                                                                      *+                Arrow scopes+*                                                                      *+************************************************************************+-}++newArrowScope :: TcM a -> TcM a+newArrowScope+  = updLclEnv $ \env -> env { tcl_arrow_ctxt = ArrowCtxt (tcl_rdr env) (tcl_lie env) }++-- Return to the stored environment (from the enclosing proc)+escapeArrowScope :: TcM a -> TcM a+escapeArrowScope+  = updLclEnv $ \ env ->+    case tcl_arrow_ctxt env of+      NoArrowCtxt       -> env+      ArrowCtxt rdr_env lie -> env { tcl_arrow_ctxt = NoArrowCtxt+                                   , tcl_lie = lie+                                   , tcl_rdr = rdr_env }++{-+************************************************************************+*                                                                      *+                Unique supply+*                                                                      *+************************************************************************+-}++newUnique :: TcRnIf gbl lcl Unique+newUnique+ = do { env <- getEnv ;+        let { u_var = env_us env } ;+        us <- readMutVar u_var ;+        case takeUniqFromSupply us of { (uniq, us') -> do {+        writeMutVar u_var us' ;+        return $! uniq }}}+   -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving+   -- a chain of unevaluated supplies behind.+   -- NOTE 2: we use the uniq in the supply from the MutVar directly, and+   -- throw away one half of the new split supply.  This is safe because this+   -- is the only place we use that unique.  Using the other half of the split+   -- supply is safer, but slower.++newUniqueSupply :: TcRnIf gbl lcl UniqSupply+newUniqueSupply+ = do { env <- getEnv ;+        let { u_var = env_us env } ;+        us <- readMutVar u_var ;+        case splitUniqSupply us of { (us1,us2) -> do {+        writeMutVar u_var us1 ;+        return us2 }}}++cloneLocalName :: Name -> TcM Name+-- Make a fresh Internal name with the same OccName and SrcSpan+cloneLocalName name = newNameAt (nameOccName name) (nameSrcSpan name)++newName :: OccName -> TcM Name+newName occ = do { loc  <- getSrcSpanM+                 ; newNameAt occ loc }++newNameAt :: OccName -> SrcSpan -> TcM Name+newNameAt occ span+  = do { uniq <- newUnique+       ; return (mkInternalName uniq occ span) }++newSysName :: OccName -> TcRnIf gbl lcl Name+newSysName occ+  = do { uniq <- newUnique+       ; return (mkSystemName uniq occ) }++newSysLocalId :: FastString -> TcType -> TcRnIf gbl lcl TcId+newSysLocalId fs ty+  = do  { u <- newUnique+        ; return (mkSysLocalOrCoVar fs u ty) }++newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId]+newSysLocalIds fs tys+  = do  { us <- newUniqueSupply+        ; return (zipWith (mkSysLocalOrCoVar fs) (uniqsFromSupply us) tys) }++instance MonadUnique (IOEnv (Env gbl lcl)) where+        getUniqueM = newUnique+        getUniqueSupplyM = newUniqueSupply++{-+************************************************************************+*                                                                      *+                Accessing input/output+*                                                                      *+************************************************************************+-}++newTcRef :: a -> TcRnIf gbl lcl (TcRef a)+newTcRef = newMutVar++readTcRef :: TcRef a -> TcRnIf gbl lcl a+readTcRef = readMutVar++writeTcRef :: TcRef a -> a -> TcRnIf gbl lcl ()+writeTcRef = writeMutVar++updTcRef :: TcRef a -> (a -> a) -> TcRnIf gbl lcl ()+-- Returns ()+updTcRef ref fn = liftIO $ do { old <- readIORef ref+                              ; writeIORef ref (fn old) }++{-+************************************************************************+*                                                                      *+                Debugging+*                                                                      *+************************************************************************+-}+++-- Typechecker trace+traceTc :: String -> SDoc -> TcRn ()+traceTc =+  labelledTraceOptTcRn Opt_D_dump_tc_trace++-- Renamer Trace+traceRn :: String -> SDoc -> TcRn ()+traceRn =+  labelledTraceOptTcRn Opt_D_dump_rn_trace++-- | Trace when a certain flag is enabled. This is like `traceOptTcRn`+-- but accepts a string as a label and formats the trace message uniformly.+labelledTraceOptTcRn :: DumpFlag -> String -> SDoc -> TcRn ()+labelledTraceOptTcRn flag herald doc = do+   traceOptTcRn flag (formatTraceMsg herald doc)++formatTraceMsg :: String -> SDoc -> SDoc+formatTraceMsg herald doc = hang (text herald) 2 doc++-- | Output a doc if the given 'DumpFlag' is set.+--+-- By default this logs to stdout+-- However, if the `-ddump-to-file` flag is set,+-- then this will dump output to a file+--+-- Just a wrapper for 'dumpSDoc'+traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()+traceOptTcRn flag doc+  = do { dflags <- getDynFlags+       ; when (dopt flag dflags)+              (traceTcRn flag doc)+       }++-- Certain tests (T3017, Roles3, T12763 etc.) expect part of the+-- output generated by `-ddump-types` to be in 'PprUser' style. However,+-- generally we want all other debugging output to use 'PprDump'+-- style. 'traceTcRn' and 'traceTcRnForUser' help us accomplish this.++-- | A wrapper around 'traceTcRnWithStyle' which uses 'PprDump' style.+traceTcRn :: DumpFlag -> SDoc -> TcRn ()+traceTcRn flag doc+  = do { dflags  <- getDynFlags+       ; printer <- getPrintUnqualified dflags+       ; let dump_style = mkDumpStyle dflags printer+       ; traceTcRnWithStyle dump_style dflags flag doc }++-- | A wrapper around 'traceTcRnWithStyle' which uses 'PprUser' style.+traceTcRnForUser :: DumpFlag -> SDoc -> TcRn ()+-- Used by 'TcRnDriver.tcDump'.+traceTcRnForUser flag doc+  = do { dflags  <- getDynFlags+       ; printer <- getPrintUnqualified dflags+       ; let user_style = mkUserStyle dflags printer AllTheWay+       ; traceTcRnWithStyle user_style dflags flag doc }++traceTcRnWithStyle :: PprStyle -> DynFlags -> DumpFlag -> SDoc -> TcRn ()+-- ^ Unconditionally dump some trace output+--+-- The DumpFlag is used only to set the output filename+-- for --dump-to-file, not to decide whether or not to output+-- That part is done by the caller+traceTcRnWithStyle sty dflags flag doc+  = do { real_doc <- prettyDoc dflags doc+       ; liftIO $ dumpSDocWithStyle sty dflags flag "" real_doc }+  where+    -- Add current location if -dppr-debug+    prettyDoc :: DynFlags -> SDoc -> TcRn SDoc+    prettyDoc dflags doc = if hasPprDebug dflags+       then do { loc  <- getSrcSpanM; return $ mkLocMessage SevOutput loc doc }+       else return doc -- The full location is usually way too much+++getPrintUnqualified :: DynFlags -> TcRn PrintUnqualified+getPrintUnqualified dflags+  = do { rdr_env <- getGlobalRdrEnv+       ; return $ mkPrintUnqualified dflags rdr_env }++-- | Like logInfoTcRn, but for user consumption+printForUserTcRn :: SDoc -> TcRn ()+printForUserTcRn doc+  = do { dflags <- getDynFlags+       ; printer <- getPrintUnqualified dflags+       ; liftIO (printOutputForUser dflags printer doc) }++{-+traceIf and traceHiDiffs work in the TcRnIf monad, where no RdrEnv is+available.  Alas, they behave inconsistently with the other stuff;+e.g. are unaffected by -dump-to-file.+-}++traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()+traceIf      = traceOptIf Opt_D_dump_if_trace+traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs+++traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()+traceOptIf flag doc+  = whenDOptM flag $    -- No RdrEnv available, so qualify everything+    do { dflags <- getDynFlags+       ; liftIO (putMsg dflags doc) }++{-+************************************************************************+*                                                                      *+                Typechecker global environment+*                                                                      *+************************************************************************+-}++getIsGHCi :: TcRn Bool+getIsGHCi = do { mod <- getModule+               ; return (isInteractiveModule mod) }++getGHCiMonad :: TcRn Name+getGHCiMonad = do { hsc <- getTopEnv; return (ic_monad $ hsc_IC hsc) }++getInteractivePrintName :: TcRn Name+getInteractivePrintName = do { hsc <- getTopEnv; return (ic_int_print $ hsc_IC hsc) }++tcIsHsBootOrSig :: TcRn Bool+tcIsHsBootOrSig = do { env <- getGblEnv; return (isHsBootOrSig (tcg_src env)) }++tcIsHsig :: TcRn Bool+tcIsHsig = do { env <- getGblEnv; return (isHsigFile (tcg_src env)) }++tcSelfBootInfo :: TcRn SelfBootInfo+tcSelfBootInfo = do { env <- getGblEnv; return (tcg_self_boot env) }++getGlobalRdrEnv :: TcRn GlobalRdrEnv+getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) }++getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv)+getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) }++getImports :: TcRn ImportAvails+getImports = do { env <- getGblEnv; return (tcg_imports env) }++getFixityEnv :: TcRn FixityEnv+getFixityEnv = do { env <- getGblEnv; return (tcg_fix_env env) }++extendFixityEnv :: [(Name,FixItem)] -> RnM a -> RnM a+extendFixityEnv new_bit+  = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) ->+                env {tcg_fix_env = extendNameEnvList old_fix_env new_bit})++getRecFieldEnv :: TcRn RecFieldEnv+getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) }++getDeclaredDefaultTys :: TcRn (Maybe [Type])+getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) }++addDependentFiles :: [FilePath] -> TcRn ()+addDependentFiles fs = do+  ref <- fmap tcg_dependent_files getGblEnv+  dep_files <- readTcRef ref+  writeTcRef ref (fs ++ dep_files)++{-+************************************************************************+*                                                                      *+                Error management+*                                                                      *+************************************************************************+-}++getSrcSpanM :: TcRn SrcSpan+        -- Avoid clash with Name.getSrcLoc+getSrcSpanM = do { env <- getLclEnv; return (RealSrcSpan (tcl_loc env)) }++setSrcSpan :: SrcSpan -> TcRn a -> TcRn a+setSrcSpan (RealSrcSpan real_loc) thing_inside+    = updLclEnv (\env -> env { tcl_loc = real_loc }) thing_inside+-- Don't overwrite useful info with useless:+setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside++addLocM :: HasSrcSpan a => (SrcSpanLess a -> TcM b) -> a -> TcM b+addLocM fn (dL->L loc a) = setSrcSpan loc $ fn a++wrapLocM :: (HasSrcSpan a, HasSrcSpan b) =>+            (SrcSpanLess a -> TcM (SrcSpanLess b)) -> a -> TcM b+-- wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b)+wrapLocM fn (dL->L loc a) = setSrcSpan loc $ do { b <- fn a+                                                ; return (cL loc b) }+wrapLocFstM :: (HasSrcSpan a, HasSrcSpan b) =>+               (SrcSpanLess a -> TcM (SrcSpanLess b,c)) -> a -> TcM (b, c)+wrapLocFstM fn (dL->L loc a) =+  setSrcSpan loc $ do+    (b,c) <- fn a+    return (cL loc b, c)++wrapLocSndM :: (HasSrcSpan a, HasSrcSpan c) =>+               (SrcSpanLess a -> TcM (b, SrcSpanLess c)) -> a -> TcM (b, c)+wrapLocSndM fn (dL->L loc a) =+  setSrcSpan loc $ do+    (b,c) <- fn a+    return (b, cL loc c)++wrapLocM_ :: HasSrcSpan a =>+             (SrcSpanLess a -> TcM ()) -> a -> TcM ()+wrapLocM_ fn (dL->L loc a) = setSrcSpan loc (fn a)++-- Reporting errors++getErrsVar :: TcRn (TcRef Messages)+getErrsVar = do { env <- getLclEnv; return (tcl_errs env) }++setErrsVar :: TcRef Messages -> TcRn a -> TcRn a+setErrsVar v = updLclEnv (\ env -> env { tcl_errs =  v })++addErr :: MsgDoc -> TcRn ()+addErr msg = do { loc <- getSrcSpanM; addErrAt loc msg }++failWith :: MsgDoc -> TcRn a+failWith msg = addErr msg >> failM++failAt :: SrcSpan -> MsgDoc -> TcRn a+failAt loc msg = addErrAt loc msg >> failM++addErrAt :: SrcSpan -> MsgDoc -> TcRn ()+-- addErrAt is mainly (exclusively?) used by the renamer, where+-- tidying is not an issue, but it's all lazy so the extra+-- work doesn't matter+addErrAt loc msg = do { ctxt <- getErrCtxt+                      ; tidy_env <- tcInitTidyEnv+                      ; err_info <- mkErrInfo tidy_env ctxt+                      ; addLongErrAt loc msg err_info }++addErrs :: [(SrcSpan,MsgDoc)] -> TcRn ()+addErrs msgs = mapM_ add msgs+             where+               add (loc,msg) = addErrAt loc msg++checkErr :: Bool -> MsgDoc -> TcRn ()+-- Add the error if the bool is False+checkErr ok msg = unless ok (addErr msg)++addMessages :: Messages -> TcRn ()+addMessages msgs1+  = do { errs_var <- getErrsVar ;+         msgs0 <- readTcRef errs_var ;+         writeTcRef errs_var (unionMessages msgs0 msgs1) }++discardWarnings :: TcRn a -> TcRn a+-- Ignore warnings inside the thing inside;+-- used to ignore-unused-variable warnings inside derived code+discardWarnings thing_inside+  = do  { errs_var <- getErrsVar+        ; (old_warns, _) <- readTcRef errs_var++        ; result <- thing_inside++        -- Revert warnings to old_warns+        ; (_new_warns, new_errs) <- readTcRef errs_var+        ; writeTcRef errs_var (old_warns, new_errs)++        ; return result }++{-+************************************************************************+*                                                                      *+        Shared error message stuff: renamer and typechecker+*                                                                      *+************************************************************************+-}++mkLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ErrMsg+mkLongErrAt loc msg extra+  = do { dflags <- getDynFlags ;+         printer <- getPrintUnqualified dflags ;+         return $ mkLongErrMsg dflags loc printer msg extra }++mkErrDocAt :: SrcSpan -> ErrDoc -> TcRn ErrMsg+mkErrDocAt loc errDoc+  = do { dflags <- getDynFlags ;+         printer <- getPrintUnqualified dflags ;+         return $ mkErrDoc dflags loc printer errDoc }++addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()+addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError++reportErrors :: [ErrMsg] -> TcM ()+reportErrors = mapM_ reportError++reportError :: ErrMsg -> TcRn ()+reportError err+  = do { traceTc "Adding error:" (pprLocErrMsg err) ;+         errs_var <- getErrsVar ;+         (warns, errs) <- readTcRef errs_var ;+         writeTcRef errs_var (warns, errs `snocBag` err) }++reportWarning :: WarnReason -> ErrMsg -> TcRn ()+reportWarning reason err+  = do { let warn = makeIntoWarning reason err+                    -- 'err' was built by mkLongErrMsg or something like that,+                    -- so it's of error severity.  For a warning we downgrade+                    -- its severity to SevWarning++       ; traceTc "Adding warning:" (pprLocErrMsg warn)+       ; errs_var <- getErrsVar+       ; (warns, errs) <- readTcRef errs_var+       ; writeTcRef errs_var (warns `snocBag` warn, errs) }+++-----------------------+checkNoErrs :: TcM r -> TcM r+-- (checkNoErrs m) succeeds iff m succeeds and generates no errors+-- If m fails then (checkNoErrsTc m) fails.+-- If m succeeds, it checks whether m generated any errors messages+--      (it might have recovered internally)+--      If so, it fails too.+-- Regardless, any errors generated by m are propagated to the enclosing context.+checkNoErrs main+  = do  { (res, no_errs) <- askNoErrs main+        ; unless no_errs failM+        ; return res }++-----------------------+whenNoErrs :: TcM () -> TcM ()+whenNoErrs thing = ifErrsM (return ()) thing++ifErrsM :: TcRn r -> TcRn r -> TcRn r+--      ifErrsM bale_out normal+-- does 'bale_out' if there are errors in errors collection+-- otherwise does 'normal'+ifErrsM bale_out normal+ = do { errs_var <- getErrsVar ;+        msgs <- readTcRef errs_var ;+        dflags <- getDynFlags ;+        if errorsFound dflags msgs then+           bale_out+        else+           normal }++failIfErrsM :: TcRn ()+-- Useful to avoid error cascades+failIfErrsM = ifErrsM failM (return ())++checkTH :: a -> String -> TcRn ()+checkTH _ _ = return () -- OK++failTH :: Outputable a => a -> String -> TcRn x+failTH e what  -- Raise an error in a stage-1 compiler+  = failWithTc (vcat [ hang (char 'A' <+> text what+                             <+> text "requires GHC with interpreter support:")+                          2 (ppr e)+                     , text "Perhaps you are using a stage-1 compiler?" ])+++{- *********************************************************************+*                                                                      *+        Context management for the type checker+*                                                                      *+************************************************************************+-}++getErrCtxt :: TcM [ErrCtxt]+getErrCtxt = do { env <- getLclEnv; return (tcl_ctxt env) }++setErrCtxt :: [ErrCtxt] -> TcM a -> TcM a+setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt })++-- | Add a fixed message to the error context. This message should not+-- do any tidying.+addErrCtxt :: MsgDoc -> TcM a -> TcM a+addErrCtxt msg = addErrCtxtM (\env -> return (env, msg))++-- | Add a message to the error context. This message may do tidying.+addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a+addErrCtxtM ctxt = updCtxt (\ ctxts -> (False, ctxt) : ctxts)++-- | Add a fixed landmark message to the error context. A landmark+-- message is always sure to be reported, even if there is a lot of+-- context. It also doesn't count toward the maximum number of contexts+-- reported.+addLandmarkErrCtxt :: MsgDoc -> TcM a -> TcM a+addLandmarkErrCtxt msg = addLandmarkErrCtxtM (\env -> return (env, msg))++-- | Variant of 'addLandmarkErrCtxt' that allows for monadic operations+-- and tidying.+addLandmarkErrCtxtM :: (TidyEnv -> TcM (TidyEnv, MsgDoc)) -> TcM a -> TcM a+addLandmarkErrCtxtM ctxt = updCtxt (\ctxts -> (True, ctxt) : ctxts)++-- Helper function for the above+updCtxt :: ([ErrCtxt] -> [ErrCtxt]) -> TcM a -> TcM a+updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) ->+                           env { tcl_ctxt = upd ctxt })++popErrCtxt :: TcM a -> TcM a+popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms })++getCtLocM :: CtOrigin -> Maybe TypeOrKind -> TcM CtLoc+getCtLocM origin t_or_k+  = do { env <- getLclEnv+       ; return (CtLoc { ctl_origin = origin+                       , ctl_env    = env+                       , ctl_t_or_k = t_or_k+                       , ctl_depth  = initialSubGoalDepth }) }++setCtLocM :: CtLoc -> TcM a -> TcM a+-- Set the SrcSpan and error context from the CtLoc+setCtLocM (CtLoc { ctl_env = lcl }) thing_inside+  = updLclEnv (\env -> env { tcl_loc   = tcl_loc lcl+                           , tcl_bndrs = tcl_bndrs lcl+                           , tcl_ctxt  = tcl_ctxt lcl })+              thing_inside+++{- *********************************************************************+*                                                                      *+             Error recovery and exceptions+*                                                                      *+********************************************************************* -}++tcTryM :: TcRn r -> TcRn (Maybe r)+-- The most basic function: catch the exception+--   Nothing => an exception happened+--   Just r  => no exception, result R+-- Errors and constraints are propagated in both cases+-- Never throws an exception+tcTryM thing_inside+  = do { either_res <- tryM thing_inside+       ; return (case either_res of+                    Left _  -> Nothing+                    Right r -> Just r) }+         -- In the Left case the exception is always the IOEnv+         -- built-in in exception; see IOEnv.failM++-----------------------+capture_constraints :: TcM r -> TcM (r, WantedConstraints)+-- capture_constraints simply captures and returns the+--                     constraints generated by thing_inside+-- Precondition: thing_inside must not throw an exception!+-- Reason for precondition: an exception would blow past the place+-- where we read the lie_var, and we'd lose the constraints altogether+capture_constraints thing_inside+  = do { lie_var <- newTcRef emptyWC+       ; res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) $+                thing_inside+       ; lie <- readTcRef lie_var+       ; return (res, lie) }++capture_messages :: TcM r -> TcM (r, Messages)+-- capture_messages simply captures and returns the+--                  errors arnd warnings generated by thing_inside+-- Precondition: thing_inside must not throw an exception!+-- Reason for precondition: an exception would blow past the place+-- where we read the msg_var, and we'd lose the constraints altogether+capture_messages thing_inside+  = do { msg_var <- newTcRef emptyMessages+       ; res     <- setErrsVar msg_var thing_inside+       ; msgs    <- readTcRef msg_var+       ; return (res, msgs) }++-----------------------+-- (askNoErrs m) runs m+-- If m fails,+--    then (askNoErrs m) fails, propagating only+--         insoluble constraints+--+-- If m succeeds with result r,+--    then (askNoErrs m) succeeds with result (r, b),+--         where b is True iff m generated no errors+--+-- Regardless of success or failure,+--   propagate any errors/warnings generated by m+askNoErrs :: TcRn a -> TcRn (a, Bool)+askNoErrs thing_inside+  = do { ((mb_res, lie), msgs) <- capture_messages    $+                                  capture_constraints $+                                  tcTryM thing_inside+       ; addMessages msgs++       ; case mb_res of+           Nothing  -> do { emitConstraints (insolublesOnly lie)+                          ; failM }++           Just res -> do { emitConstraints lie+                          ; dflags <- getDynFlags+                          ; let errs_found = errorsFound dflags msgs+                                          || insolubleWC lie+                          ; return (res, not errs_found) } }++-----------------------+tryCaptureConstraints :: TcM a -> TcM (Maybe a, WantedConstraints)+-- (tryCaptureConstraints_maybe m) runs m,+--   and returns the type constraints it generates+-- It never throws an exception; instead if thing_inside fails,+--   it returns Nothing and the /insoluble/ constraints+-- Error messages are propagated+tryCaptureConstraints thing_inside+  = do { (mb_res, lie) <- capture_constraints $+                          tcTryM thing_inside++       -- See Note [Constraints and errors]+       ; let lie_to_keep = case mb_res of+                             Nothing -> insolublesOnly lie+                             Just {} -> lie++       ; return (mb_res, lie_to_keep) }++captureConstraints :: TcM a -> TcM (a, WantedConstraints)+-- (captureConstraints m) runs m, and returns the type constraints it generates+-- If thing_inside fails (throwing an exception),+--   then (captureConstraints thing_inside) fails too+--   propagating the insoluble constraints only+-- Error messages are propagated in either case+captureConstraints thing_inside+  = do { (mb_res, lie) <- tryCaptureConstraints thing_inside++            -- See Note [Constraints and errors]+            -- If the thing_inside threw an exception, emit the insoluble+            -- constraints only (returned by tryCaptureConstraints)+            -- so that they are not lost+       ; case mb_res of+           Nothing  -> do { emitConstraints lie; failM }+           Just res -> return (res, lie) }++-----------------------+attemptM :: TcRn r -> TcRn (Maybe r)+-- (attemptM thing_inside) runs thing_inside+-- If thing_inside succeeds, returning r,+--   we return (Just r), and propagate all constraints and errors+-- If thing_inside fail, throwing an exception,+--   we return Nothing, propagating insoluble constraints,+--                      and all errors+-- attemptM never throws an exception+attemptM thing_inside+  = do { (mb_r, lie) <- tryCaptureConstraints thing_inside+       ; emitConstraints lie++       -- Debug trace+       ; when (isNothing mb_r) $+         traceTc "attemptM recovering with insoluble constraints" $+                 (ppr lie)++       ; return mb_r }++-----------------------+recoverM :: TcRn r      -- Recovery action; do this if the main one fails+         -> TcRn r      -- Main action: do this first;+                        --  if it generates errors, propagate them all+         -> TcRn r+-- (recoverM recover thing_inside) runs thing_inside+-- If thing_inside fails, propagate its errors and insoluble constraints+--                        and run 'recover'+-- If thing_inside succeeds, propagate all its errors and constraints+--+-- Can fail, if 'recover' fails+recoverM recover thing+  = do { mb_res <- attemptM thing ;+         case mb_res of+           Nothing  -> recover+           Just res -> return res }++-----------------------++-- | Drop elements of the input that fail, so the result+-- list can be shorter than the argument list+mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b]+mapAndRecoverM f xs+  = do { mb_rs <- mapM (attemptM . f) xs+       ; return [r | Just r <- mb_rs] }++-- | Apply the function to all elements on the input list+-- If all succeed, return the list of results+-- Othewise fail, propagating all errors+mapAndReportM :: (a -> TcRn b) -> [a] -> TcRn [b]+mapAndReportM f xs+  = do { mb_rs <- mapM (attemptM . f) xs+       ; when (any isNothing mb_rs) failM+       ; return [r | Just r <- mb_rs] }++-- | The accumulator is not updated if the action fails+foldAndRecoverM :: (b -> a -> TcRn b) -> b -> [a] -> TcRn b+foldAndRecoverM _ acc []     = return acc+foldAndRecoverM f acc (x:xs) =+                          do { mb_r <- attemptM (f acc x)+                             ; case mb_r of+                                Nothing   -> foldAndRecoverM f acc xs+                                Just acc' -> foldAndRecoverM f acc' xs  }++-----------------------+tryTc :: TcRn a -> TcRn (Maybe a, Messages)+-- (tryTc m) executes m, and returns+--      Just r,  if m succeeds (returning r)+--      Nothing, if m fails+-- It also returns all the errors and warnings accumulated by m+-- It always succeeds (never raises an exception)+tryTc thing_inside+ = capture_messages (attemptM thing_inside)++-----------------------+discardErrs :: TcRn a -> TcRn a+-- (discardErrs m) runs m,+--   discarding all error messages and warnings generated by m+-- If m fails, discardErrs fails, and vice versa+discardErrs m+ = do { errs_var <- newTcRef emptyMessages+      ; setErrsVar errs_var m }++-----------------------+tryTcDiscardingErrs :: TcM r -> TcM r -> TcM r+-- (tryTcDiscardingErrs recover thing_inside) tries 'thing_inside';+--      if 'main' succeeds with no error messages, it's the answer+--      otherwise discard everything from 'main', including errors,+--          and try 'recover' instead.+tryTcDiscardingErrs recover thing_inside+  = do { ((mb_res, lie), msgs) <- capture_messages    $+                                  capture_constraints $+                                  tcTryM thing_inside+        ; dflags <- getDynFlags+        ; case mb_res of+            Just res | not (errorsFound dflags msgs)+                     , not (insolubleWC lie)+              -> -- 'main' succeeed with no errors+                 do { addMessages msgs  -- msgs might still have warnings+                    ; emitConstraints lie+                    ; return res }++            _ -> -- 'main' failed, or produced an error message+                 recover     -- Discard all errors and warnings+                             -- and unsolved constraints entirely+        }++{-+************************************************************************+*                                                                      *+             Error message generation (type checker)+*                                                                      *+************************************************************************++    The addErrTc functions add an error message, but do not cause failure.+    The 'M' variants pass a TidyEnv that has already been used to+    tidy up the message; we then use it to tidy the context messages+-}++addErrTc :: MsgDoc -> TcM ()+addErrTc err_msg = do { env0 <- tcInitTidyEnv+                      ; addErrTcM (env0, err_msg) }++addErrsTc :: [MsgDoc] -> TcM ()+addErrsTc err_msgs = mapM_ addErrTc err_msgs++addErrTcM :: (TidyEnv, MsgDoc) -> TcM ()+addErrTcM (tidy_env, err_msg)+  = do { ctxt <- getErrCtxt ;+         loc  <- getSrcSpanM ;+         add_err_tcm tidy_env err_msg loc ctxt }++-- Return the error message, instead of reporting it straight away+mkErrTcM :: (TidyEnv, MsgDoc) -> TcM ErrMsg+mkErrTcM (tidy_env, err_msg)+  = do { ctxt <- getErrCtxt ;+         loc  <- getSrcSpanM ;+         err_info <- mkErrInfo tidy_env ctxt ;+         mkLongErrAt loc err_msg err_info }++mkErrTc :: MsgDoc -> TcM ErrMsg+mkErrTc msg = do { env0 <- tcInitTidyEnv+                 ; mkErrTcM (env0, msg) }++-- The failWith functions add an error message and cause failure++failWithTc :: MsgDoc -> TcM a               -- Add an error message and fail+failWithTc err_msg+  = addErrTc err_msg >> failM++failWithTcM :: (TidyEnv, MsgDoc) -> TcM a   -- Add an error message and fail+failWithTcM local_and_msg+  = addErrTcM local_and_msg >> failM++checkTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is true+checkTc True  _   = return ()+checkTc False err = failWithTc err++checkTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()+checkTcM True  _   = return ()+checkTcM False err = failWithTcM err++failIfTc :: Bool -> MsgDoc -> TcM ()         -- Check that the boolean is false+failIfTc False _   = return ()+failIfTc True  err = failWithTc err++failIfTcM :: Bool -> (TidyEnv, MsgDoc) -> TcM ()+   -- Check that the boolean is false+failIfTcM False _   = return ()+failIfTcM True  err = failWithTcM err+++--         Warnings have no 'M' variant, nor failure++-- | Display a warning if a condition is met,+--   and the warning is enabled+warnIfFlag :: WarningFlag -> Bool -> MsgDoc -> TcRn ()+warnIfFlag warn_flag is_bad msg+  = do { warn_on <- woptM warn_flag+       ; when (warn_on && is_bad) $+         addWarn (Reason warn_flag) msg }++-- | Display a warning if a condition is met.+warnIf :: Bool -> MsgDoc -> TcRn ()+warnIf is_bad msg+  = when is_bad (addWarn NoReason msg)++-- | Display a warning if a condition is met.+warnTc :: WarnReason -> Bool -> MsgDoc -> TcM ()+warnTc reason warn_if_true warn_msg+  | warn_if_true = addWarnTc reason warn_msg+  | otherwise    = return ()++-- | Display a warning if a condition is met.+warnTcM :: WarnReason -> Bool -> (TidyEnv, MsgDoc) -> TcM ()+warnTcM reason warn_if_true warn_msg+  | warn_if_true = addWarnTcM reason warn_msg+  | otherwise    = return ()++-- | Display a warning in the current context.+addWarnTc :: WarnReason -> MsgDoc -> TcM ()+addWarnTc reason msg+ = do { env0 <- tcInitTidyEnv ;+      addWarnTcM reason (env0, msg) }++-- | Display a warning in a given context.+addWarnTcM :: WarnReason -> (TidyEnv, MsgDoc) -> TcM ()+addWarnTcM reason (env0, msg)+ = do { ctxt <- getErrCtxt ;+        err_info <- mkErrInfo env0 ctxt ;+        add_warn reason msg err_info }++-- | Display a warning for the current source location.+addWarn :: WarnReason -> MsgDoc -> TcRn ()+addWarn reason msg = add_warn reason msg Outputable.empty++-- | Display a warning for a given source location.+addWarnAt :: WarnReason -> SrcSpan -> MsgDoc -> TcRn ()+addWarnAt reason loc msg = add_warn_at reason loc msg Outputable.empty++-- | Display a warning, with an optional flag, for the current source+-- location.+add_warn :: WarnReason -> MsgDoc -> MsgDoc -> TcRn ()+add_warn reason msg extra_info+  = do { loc <- getSrcSpanM+       ; add_warn_at reason loc msg extra_info }++-- | Display a warning, with an optional flag, for a given location.+add_warn_at :: WarnReason -> SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()+add_warn_at reason loc msg extra_info+  = do { dflags <- getDynFlags ;+         printer <- getPrintUnqualified dflags ;+         let { warn = mkLongWarnMsg dflags loc printer+                                    msg extra_info } ;+         reportWarning reason warn }+++{-+-----------------------------------+        Other helper functions+-}++add_err_tcm :: TidyEnv -> MsgDoc -> SrcSpan+            -> [ErrCtxt]+            -> TcM ()+add_err_tcm tidy_env err_msg loc ctxt+ = do { err_info <- mkErrInfo tidy_env ctxt ;+        addLongErrAt loc err_msg err_info }++mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc+-- Tidy the error info, trimming excessive contexts+mkErrInfo env ctxts+--  = do+--       dbg <- hasPprDebug <$> getDynFlags+--       if dbg                -- In -dppr-debug style the output+--          then return empty  -- just becomes too voluminous+--          else go dbg 0 env ctxts+ = go False 0 env ctxts+ where+   go :: Bool -> Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc+   go _ _ _   [] = return empty+   go dbg n env ((is_landmark, ctxt) : ctxts)+     | is_landmark || n < mAX_CONTEXTS -- Too verbose || dbg+     = do { (env', msg) <- ctxt env+          ; let n' = if is_landmark then n else n+1+          ; rest <- go dbg n' env' ctxts+          ; return (msg $$ rest) }+     | otherwise+     = go dbg n env ctxts++mAX_CONTEXTS :: Int     -- No more than this number of non-landmark contexts+mAX_CONTEXTS = 3++-- debugTc is useful for monadic debugging code++debugTc :: TcM () -> TcM ()+debugTc thing+ | debugIsOn = thing+ | otherwise = return ()++{-+************************************************************************+*                                                                      *+             Type constraints+*                                                                      *+************************************************************************+-}++addTopEvBinds :: Bag EvBind -> TcM a -> TcM a+addTopEvBinds new_ev_binds thing_inside+  =updGblEnv upd_env thing_inside+  where+    upd_env tcg_env = tcg_env { tcg_ev_binds = tcg_ev_binds tcg_env+                                               `unionBags` new_ev_binds }++newTcEvBinds :: TcM EvBindsVar+newTcEvBinds = do { binds_ref <- newTcRef emptyEvBindMap+                  ; tcvs_ref  <- newTcRef emptyVarSet+                  ; uniq <- newUnique+                  ; traceTc "newTcEvBinds" (text "unique =" <+> ppr uniq)+                  ; return (EvBindsVar { ebv_binds = binds_ref+                                       , ebv_tcvs = tcvs_ref+                                       , ebv_uniq = uniq }) }++-- | Creates an EvBindsVar incapable of holding any bindings. It still+-- tracks covar usages (see comments on ebv_tcvs in TcEvidence), thus+-- must be made monadically+newNoTcEvBinds :: TcM EvBindsVar+newNoTcEvBinds+  = do { tcvs_ref  <- newTcRef emptyVarSet+       ; uniq <- newUnique+       ; traceTc "newNoTcEvBinds" (text "unique =" <+> ppr uniq)+       ; return (CoEvBindsVar { ebv_tcvs = tcvs_ref+                              , ebv_uniq = uniq }) }++cloneEvBindsVar :: EvBindsVar -> TcM EvBindsVar+-- Clone the refs, so that any binding created when+-- solving don't pollute the original+cloneEvBindsVar ebv@(EvBindsVar {})+  = do { binds_ref <- newTcRef emptyEvBindMap+       ; tcvs_ref  <- newTcRef emptyVarSet+       ; return (ebv { ebv_binds = binds_ref+                     , ebv_tcvs = tcvs_ref }) }+cloneEvBindsVar ebv@(CoEvBindsVar {})+  = do { tcvs_ref  <- newTcRef emptyVarSet+       ; return (ebv { ebv_tcvs = tcvs_ref }) }++getTcEvTyCoVars :: EvBindsVar -> TcM TyCoVarSet+getTcEvTyCoVars ev_binds_var+  = readTcRef (ebv_tcvs ev_binds_var)++getTcEvBindsMap :: EvBindsVar -> TcM EvBindMap+getTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref })+  = readTcRef ev_ref+getTcEvBindsMap (CoEvBindsVar {})+  = return emptyEvBindMap++setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcM ()+setTcEvBindsMap (EvBindsVar { ebv_binds = ev_ref }) binds+  = writeTcRef ev_ref binds+setTcEvBindsMap v@(CoEvBindsVar {}) ev_binds+  | isEmptyEvBindMap ev_binds+  = return ()+  | otherwise+  = pprPanic "setTcEvBindsMap" (ppr v $$ ppr ev_binds)++addTcEvBind :: EvBindsVar -> EvBind -> TcM ()+-- Add a binding to the TcEvBinds by side effect+addTcEvBind (EvBindsVar { ebv_binds = ev_ref, ebv_uniq = u }) ev_bind+  = do { traceTc "addTcEvBind" $ ppr u $$+                                 ppr ev_bind+       ; bnds <- readTcRef ev_ref+       ; writeTcRef ev_ref (extendEvBinds bnds ev_bind) }+addTcEvBind (CoEvBindsVar { ebv_uniq = u }) ev_bind+  = pprPanic "addTcEvBind CoEvBindsVar" (ppr ev_bind $$ ppr u)++chooseUniqueOccTc :: (OccSet -> OccName) -> TcM OccName+chooseUniqueOccTc fn =+  do { env <- getGblEnv+     ; let dfun_n_var = tcg_dfun_n env+     ; set <- readTcRef dfun_n_var+     ; let occ = fn set+     ; writeTcRef dfun_n_var (extendOccSet set occ)+     ; return occ }++getConstraintVar :: TcM (TcRef WantedConstraints)+getConstraintVar = do { env <- getLclEnv; return (tcl_lie env) }++setConstraintVar :: TcRef WantedConstraints -> TcM a -> TcM a+setConstraintVar lie_var = updLclEnv (\ env -> env { tcl_lie = lie_var })++emitStaticConstraints :: WantedConstraints -> TcM ()+emitStaticConstraints static_lie+  = do { gbl_env <- getGblEnv+       ; updTcRef (tcg_static_wc gbl_env) (`andWC` static_lie) }++emitConstraints :: WantedConstraints -> TcM ()+emitConstraints ct+  | isEmptyWC ct+  = return ()+  | otherwise+  = do { lie_var <- getConstraintVar ;+         updTcRef lie_var (`andWC` ct) }++emitSimple :: Ct -> TcM ()+emitSimple ct+  = do { lie_var <- getConstraintVar ;+         updTcRef lie_var (`addSimples` unitBag ct) }++emitSimples :: Cts -> TcM ()+emitSimples cts+  = do { lie_var <- getConstraintVar ;+         updTcRef lie_var (`addSimples` cts) }++emitImplication :: Implication -> TcM ()+emitImplication ct+  = do { lie_var <- getConstraintVar ;+         updTcRef lie_var (`addImplics` unitBag ct) }++emitImplications :: Bag Implication -> TcM ()+emitImplications ct+  = unless (isEmptyBag ct) $+    do { lie_var <- getConstraintVar ;+         updTcRef lie_var (`addImplics` ct) }++emitInsoluble :: Ct -> TcM ()+emitInsoluble ct+  = do { traceTc "emitInsoluble" (ppr ct)+       ; lie_var <- getConstraintVar+       ; updTcRef lie_var (`addInsols` unitBag ct) }++emitInsolubles :: Cts -> TcM ()+emitInsolubles cts+  | isEmptyBag cts = return ()+  | otherwise      = do { traceTc "emitInsolubles" (ppr cts)+                        ; lie_var <- getConstraintVar+                        ; updTcRef lie_var (`addInsols` cts) }++-- | Throw out any constraints emitted by the thing_inside+discardConstraints :: TcM a -> TcM a+discardConstraints thing_inside = fst <$> captureConstraints thing_inside++-- | The name says it all. The returned TcLevel is the *inner* TcLevel.+pushLevelAndCaptureConstraints :: TcM a -> TcM (TcLevel, WantedConstraints, a)+pushLevelAndCaptureConstraints thing_inside+  = do { env <- getLclEnv+       ; let tclvl' = pushTcLevel (tcl_tclvl env)+       ; traceTc "pushLevelAndCaptureConstraints {" (ppr tclvl')+       ; (res, lie) <- setLclEnv (env { tcl_tclvl = tclvl' }) $+                       captureConstraints thing_inside+       ; traceTc "pushLevelAndCaptureConstraints }" (ppr tclvl')+       ; return (tclvl', lie, res) }++pushTcLevelM_ :: TcM a -> TcM a+pushTcLevelM_ x = updLclEnv (\ env -> env { tcl_tclvl = pushTcLevel (tcl_tclvl env) }) x++pushTcLevelM :: TcM a -> TcM (TcLevel, a)+-- See Note [TcLevel assignment] in TcType+pushTcLevelM thing_inside+  = do { env <- getLclEnv+       ; let tclvl' = pushTcLevel (tcl_tclvl env)+       ; res <- setLclEnv (env { tcl_tclvl = tclvl' })+                          thing_inside+       ; return (tclvl', res) }++-- Returns pushed TcLevel+pushTcLevelsM :: Int -> TcM a -> TcM (a, TcLevel)+pushTcLevelsM num_levels thing_inside+  = do { env <- getLclEnv+       ; let tclvl' = nTimes num_levels pushTcLevel (tcl_tclvl env)+       ; res <- setLclEnv (env { tcl_tclvl = tclvl' }) $+                thing_inside+       ; return (res, tclvl') }++getTcLevel :: TcM TcLevel+getTcLevel = do { env <- getLclEnv+                ; return (tcl_tclvl env) }++setTcLevel :: TcLevel -> TcM a -> TcM a+setTcLevel tclvl thing_inside+  = updLclEnv (\env -> env { tcl_tclvl = tclvl }) thing_inside++isTouchableTcM :: TcTyVar -> TcM Bool+isTouchableTcM tv+  = do { lvl <- getTcLevel+       ; return (isTouchableMetaTyVar lvl tv) }++getLclTypeEnv :: TcM TcTypeEnv+getLclTypeEnv = do { env <- getLclEnv; return (tcl_env env) }++setLclTypeEnv :: TcLclEnv -> TcM a -> TcM a+-- Set the local type envt, but do *not* disturb other fields,+-- notably the lie_var+setLclTypeEnv lcl_env thing_inside+  = updLclEnv upd thing_inside+  where+    upd env = env { tcl_env = tcl_env lcl_env,+                    tcl_tyvars = tcl_tyvars lcl_env }++traceTcConstraints :: String -> TcM ()+traceTcConstraints msg+  = do { lie_var <- getConstraintVar+       ; lie     <- readTcRef lie_var+       ; traceOptTcRn Opt_D_dump_tc_trace $+         hang (text (msg ++ ": LIE:")) 2 (ppr lie)+       }++emitWildCardHoleConstraints :: [(Name, TcTyVar)] -> TcM ()+emitWildCardHoleConstraints wcs+  = do { ct_loc <- getCtLocM HoleOrigin Nothing+       ; emitInsolubles $ listToBag $+         map (do_one ct_loc) wcs }+  where+    do_one :: CtLoc -> (Name, TcTyVar) -> Ct+    do_one ct_loc (name, tv)+       = CHoleCan { cc_ev = CtDerived { ctev_pred = mkTyVarTy tv+                                      , ctev_loc  = ct_loc' }+                  , cc_hole = TypeHole (occName name) }+       where+         real_span = case nameSrcSpan name of+                           RealSrcSpan span  -> span+                           UnhelpfulSpan str -> pprPanic "emitWildCardHoleConstraints"+                                                      (ppr name <+> quotes (ftext str))+               -- Wildcards are defined locally, and so have RealSrcSpans+         ct_loc' = setCtLocSpan ct_loc real_span++{- Note [Constraints and errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#12124):++  foo :: Maybe Int+  foo = return (case Left 3 of+                  Left -> 1  -- Hard error here!+                  _    -> 0)++The call to 'return' will generate a (Monad m) wanted constraint; but+then there'll be "hard error" (i.e. an exception in the TcM monad), from+the unsaturated Left constructor pattern.++We'll recover in tcPolyBinds, using recoverM.  But then the final+tcSimplifyTop will see that (Monad m) constraint, with 'm' utterly+un-filled-in, and will emit a misleading error message.++The underlying problem is that an exception interrupts the constraint+gathering process. Bottom line: if we have an exception, it's best+simply to discard any gathered constraints.  Hence in 'attemptM' we+capture the constraints in a fresh variable, and only emit them into+the surrounding context if we exit normally.  If an exception is+raised, simply discard the collected constraints... we have a hard+error to report.  So this capture-the-emit dance isn't as stupid as it+looks :-).++However suppose we throw an exception inside an invocation of+captureConstraints, and discard all the constraints. Some of those+constraints might be "variable out of scope" Hole constraints, and that+might have been the actual original cause of the exception!  For+example (#12529):+   f = p @ Int+Here 'p' is out of scope, so we get an insolube Hole constraint. But+the visible type application fails in the monad (thows an exception).+We must not discard the out-of-scope error.++So we /retain the insoluble constraints/ if there is an exception.+Hence:+  - insolublesOnly in tryCaptureConstraints+  - emitConstraints in the Left case of captureConstraints++However note that freshly-generated constraints like (Int ~ Bool), or+((a -> b) ~ Int) are all CNonCanonical, and hence won't be flagged as+insoluble.  The constraint solver does that.  So they'll be discarded.+That's probably ok; but see th/5358 as a not-so-good example:+   t1 :: Int+   t1 x = x   -- Manifestly wrong++   foo = $(...raises exception...)+We report the exception, but not the bug in t1.  Oh well.  Possible+solution: make TcUnify.uType spot manifestly-insoluble constraints.+++************************************************************************+*                                                                      *+             Template Haskell context+*                                                                      *+************************************************************************+-}++recordThUse :: TcM ()+recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True }++recordThSpliceUse :: TcM ()+recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True }++-- | When generating an out-of-scope error message for a variable matching a+-- binding in a later inter-splice group, the typechecker uses the splice+-- locations to provide details in the message about the scope of that binding.+recordTopLevelSpliceLoc :: SrcSpan -> TcM ()+recordTopLevelSpliceLoc (RealSrcSpan real_loc)+  = do { env <- getGblEnv+       ; let locs_var = tcg_th_top_level_locs env+       ; locs0 <- readTcRef locs_var+       ; writeTcRef locs_var (Set.insert real_loc locs0) }+recordTopLevelSpliceLoc (UnhelpfulSpan _) = return ()++getTopLevelSpliceLocs :: TcM (Set RealSrcSpan)+getTopLevelSpliceLocs+  = do { env <- getGblEnv+       ; readTcRef (tcg_th_top_level_locs env) }++keepAlive :: Name -> TcRn ()     -- Record the name in the keep-alive set+keepAlive name+  = do { env <- getGblEnv+       ; traceRn "keep alive" (ppr name)+       ; updTcRef (tcg_keep env) (`extendNameSet` name) }++getStage :: TcM ThStage+getStage = do { env <- getLclEnv; return (tcl_th_ctxt env) }++getStageAndBindLevel :: Name -> TcRn (Maybe (TopLevelFlag, ThLevel, ThStage))+getStageAndBindLevel name+  = do { env <- getLclEnv;+       ; case lookupNameEnv (tcl_th_bndrs env) name of+           Nothing                  -> return Nothing+           Just (top_lvl, bind_lvl) -> return (Just (top_lvl, bind_lvl, tcl_th_ctxt env)) }++setStage :: ThStage -> TcM a -> TcRn a+setStage s = updLclEnv (\ env -> env { tcl_th_ctxt = s })++-- | Adds the given modFinalizers to the global environment and set them to use+-- the current local environment.+addModFinalizersWithLclEnv :: ThModFinalizers -> TcM ()+addModFinalizersWithLclEnv mod_finalizers+  = do lcl_env <- getLclEnv+       th_modfinalizers_var <- fmap tcg_th_modfinalizers getGblEnv+       updTcRef th_modfinalizers_var $ \fins ->+         (lcl_env, mod_finalizers) : fins++{-+************************************************************************+*                                                                      *+             Safe Haskell context+*                                                                      *+************************************************************************+-}++-- | Mark that safe inference has failed+-- See Note [Safe Haskell Overlapping Instances Implementation]+-- although this is used for more than just that failure case.+recordUnsafeInfer :: WarningMessages -> TcM ()+recordUnsafeInfer warns =+    getGblEnv >>= \env -> writeTcRef (tcg_safeInfer env) (False, warns)++-- | Figure out the final correct safe haskell mode+finalSafeMode :: DynFlags -> TcGblEnv -> IO SafeHaskellMode+finalSafeMode dflags tcg_env = do+    safeInf <- fst <$> readIORef (tcg_safeInfer tcg_env)+    return $ case safeHaskell dflags of+        Sf_None | safeInferOn dflags && safeInf -> Sf_Safe+                | otherwise                     -> Sf_None+        s -> s++-- | Switch instances to safe instances if we're in Safe mode.+fixSafeInstances :: SafeHaskellMode -> [ClsInst] -> [ClsInst]+fixSafeInstances sfMode | sfMode /= Sf_Safe = id+fixSafeInstances _ = map fixSafe+  where fixSafe inst = let new_flag = (is_flag inst) { isSafeOverlap = True }+                       in inst { is_flag = new_flag }++{-+************************************************************************+*                                                                      *+             Stuff for the renamer's local env+*                                                                      *+************************************************************************+-}++getLocalRdrEnv :: RnM LocalRdrEnv+getLocalRdrEnv = do { env <- getLclEnv; return (tcl_rdr env) }++setLocalRdrEnv :: LocalRdrEnv -> RnM a -> RnM a+setLocalRdrEnv rdr_env thing_inside+  = updLclEnv (\env -> env {tcl_rdr = rdr_env}) thing_inside++{-+************************************************************************+*                                                                      *+             Stuff for interface decls+*                                                                      *+************************************************************************+-}++mkIfLclEnv :: Module -> SDoc -> Bool -> IfLclEnv+mkIfLclEnv mod loc boot+                   = IfLclEnv { if_mod     = mod,+                                if_loc     = loc,+                                if_boot    = boot,+                                if_nsubst  = Nothing,+                                if_implicits_env = Nothing,+                                if_tv_env  = emptyFsEnv,+                                if_id_env  = emptyFsEnv }++-- | Run an 'IfG' (top-level interface monad) computation inside an existing+-- 'TcRn' (typecheck-renaming monad) computation by initializing an 'IfGblEnv'+-- based on 'TcGblEnv'.+initIfaceTcRn :: IfG a -> TcRn a+initIfaceTcRn thing_inside+  = do  { tcg_env <- getGblEnv+        ; dflags <- getDynFlags+        ; let !mod = tcg_semantic_mod tcg_env+              -- When we are instantiating a signature, we DEFINITELY+              -- do not want to knot tie.+              is_instantiate = unitIdIsDefinite (thisPackage dflags) &&+                               not (null (thisUnitIdInsts dflags))+        ; let { if_env = IfGblEnv {+                            if_doc = text "initIfaceTcRn",+                            if_rec_types =+                                if is_instantiate+                                    then Nothing+                                    else Just (mod, get_type_env)+                         }+              ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }+        ; setEnvs (if_env, ()) thing_inside }++-- Used when sucking in a ModIface into a ModDetails to put in+-- the HPT.  Notably, unlike initIfaceCheck, this does NOT use+-- hsc_type_env_var (since we're not actually going to typecheck,+-- so this variable will never get updated!)+initIfaceLoad :: HscEnv -> IfG a -> IO a+initIfaceLoad hsc_env do_this+ = do let gbl_env = IfGblEnv {+                        if_doc = text "initIfaceLoad",+                        if_rec_types = Nothing+                    }+      initTcRnIf 'i' hsc_env gbl_env () do_this++initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a+-- Used when checking the up-to-date-ness of the old Iface+-- Initialise the environment with no useful info at all+initIfaceCheck doc hsc_env do_this+ = do let rec_types = case hsc_type_env_var hsc_env of+                         Just (mod,var) -> Just (mod, readTcRef var)+                         Nothing        -> Nothing+          gbl_env = IfGblEnv {+                        if_doc = text "initIfaceCheck" <+> doc,+                        if_rec_types = rec_types+                    }+      initTcRnIf 'i' hsc_env gbl_env () do_this++initIfaceLcl :: Module -> SDoc -> Bool -> IfL a -> IfM lcl a+initIfaceLcl mod loc_doc hi_boot_file thing_inside+  = setLclEnv (mkIfLclEnv mod loc_doc hi_boot_file) thing_inside++-- | Initialize interface typechecking, but with a 'NameShape'+-- to apply when typechecking top-level 'OccName's (see+-- 'lookupIfaceTop')+initIfaceLclWithSubst :: Module -> SDoc -> Bool -> NameShape -> IfL a -> IfM lcl a+initIfaceLclWithSubst mod loc_doc hi_boot_file nsubst thing_inside+  = setLclEnv ((mkIfLclEnv mod loc_doc hi_boot_file) { if_nsubst = Just nsubst }) thing_inside++getIfModule :: IfL Module+getIfModule = do { env <- getLclEnv; return (if_mod env) }++--------------------+failIfM :: MsgDoc -> IfL a+-- The Iface monad doesn't have a place to accumulate errors, so we+-- just fall over fast if one happens; it "shouldn't happen".+-- We use IfL here so that we can get context info out of the local env+failIfM msg+  = do  { env <- getLclEnv+        ; let full_msg = (if_loc env <> colon) $$ nest 2 msg+        ; dflags <- getDynFlags+        ; liftIO (putLogMsg dflags NoReason SevFatal+                   noSrcSpan (defaultErrStyle dflags) full_msg)+        ; failM }++--------------------+forkM_maybe :: SDoc -> IfL a -> IfL (Maybe a)+-- Run thing_inside in an interleaved thread.+-- It shares everything with the parent thread, so this is DANGEROUS.+--+-- It returns Nothing if the computation fails+--+-- It's used for lazily type-checking interface+-- signatures, which is pretty benign++forkM_maybe doc thing_inside+ -- NB: Don't share the mutable env_us with the interleaved thread since env_us+ --     does not get updated atomically (e.g. in newUnique and newUniqueSupply).+ = do { child_us <- newUniqueSupply+      ; child_env_us <- newMutVar child_us+        -- see Note [Masking exceptions in forkM_maybe]+      ; unsafeInterleaveM $ uninterruptibleMaskM_ $ updEnv (\env -> env { env_us = child_env_us }) $+        do { traceIf (text "Starting fork {" <+> doc)+           ; mb_res <- tryM $+                       updLclEnv (\env -> env { if_loc = if_loc env $$ doc }) $+                       thing_inside+           ; case mb_res of+                Right r  -> do  { traceIf (text "} ending fork" <+> doc)+                                ; return (Just r) }+                Left exn -> do {++                    -- Bleat about errors in the forked thread, if -ddump-if-trace is on+                    -- Otherwise we silently discard errors. Errors can legitimately+                    -- happen when compiling interface signatures (see tcInterfaceSigs)+                      whenDOptM Opt_D_dump_if_trace $ do+                          dflags <- getDynFlags+                          let msg = hang (text "forkM failed:" <+> doc)+                                       2 (text (show exn))+                          liftIO $ putLogMsg dflags+                                             NoReason+                                             SevFatal+                                             noSrcSpan+                                             (defaultErrStyle dflags)+                                             msg++                    ; traceIf (text "} ending fork (badly)" <+> doc)+                    ; return Nothing }+        }}++forkM :: SDoc -> IfL a -> IfL a+forkM doc thing_inside+ = do   { mb_res <- forkM_maybe doc thing_inside+        ; return (case mb_res of+                        Nothing -> pgmError "Cannot continue after interface file error"+                                   -- pprPanic "forkM" doc+                        Just r  -> r) }++setImplicitEnvM :: TypeEnv -> IfL a -> IfL a+setImplicitEnvM tenv m = updLclEnv (\lcl -> lcl+                                     { if_implicits_env = Just tenv }) m++{-+Note [Masking exceptions in forkM_maybe]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When using GHC-as-API it must be possible to interrupt snippets of code+executed using runStmt (#1381). Since commit 02c4ab04 this is almost possible+by throwing an asynchronous interrupt to the GHC thread. However, there is a+subtle problem: runStmt first typechecks the code before running it, and the+exception might interrupt the type checker rather than the code. Moreover, the+typechecker might be inside an unsafeInterleaveIO (through forkM_maybe), and+more importantly might be inside an exception handler inside that+unsafeInterleaveIO. If that is the case, the exception handler will rethrow the+asynchronous exception as a synchronous exception, and the exception will end+up as the value of the unsafeInterleaveIO thunk (see #8006 for a detailed+discussion).  We don't currently know a general solution to this problem, but+we can use uninterruptibleMask_ to avoid the situation.+-}++-- | Environments which track 'CostCentreState'+class ContainsCostCentreState e where+  extractCostCentreState :: e -> TcRef CostCentreState++instance ContainsCostCentreState TcGblEnv where+  extractCostCentreState = tcg_cc_st++instance ContainsCostCentreState DsGblEnv where+  extractCostCentreState = ds_cc_st++-- | Get the next cost centre index associated with a given name.+getCCIndexM :: (ContainsCostCentreState gbl)+            => FastString -> TcRnIf gbl lcl CostCentreIndex+getCCIndexM nm = do+  env <- getGblEnv+  let cc_st_ref = extractCostCentreState env+  cc_st <- readTcRef cc_st_ref+  let (idx, cc_st') = getCCIndex nm cc_st+  writeTcRef cc_st_ref cc_st'+  return idx
+ compiler/typecheck/TcRules.hs view
@@ -0,0 +1,463 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1993-1998+++TcRules: Typechecking transformation rules+-}++{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeFamilies #-}++module TcRules ( tcRules ) where++import GhcPrelude++import HsSyn+import TcRnTypes+import TcRnMonad+import TcSimplify+import TcMType+import TcType+import TcHsType+import TcExpr+import TcEnv+import TcUnify( buildImplicationFor )+import TcEvidence( mkTcCoVarCo )+import Type+import TyCon( isTypeFamilyTyCon )+import Id+import Var( EvVar )+import VarSet+import BasicTypes       ( RuleName )+import SrcLoc+import Outputable+import FastString+import Bag++{-+Note [Typechecking rules]+~~~~~~~~~~~~~~~~~~~~~~~~~+We *infer* the typ of the LHS, and use that type to *check* the type of+the RHS.  That means that higher-rank rules work reasonably well. Here's+an example (test simplCore/should_compile/rule2.hs) produced by Roman:++   foo :: (forall m. m a -> m b) -> m a -> m b+   foo f = ...++   bar :: (forall m. m a -> m a) -> m a -> m a+   bar f = ...++   {-# RULES "foo/bar" foo = bar #-}++He wanted the rule to typecheck.++Note [TcLevel in type checking rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Bringing type variables into scope naturally bumps the TcLevel. Thus, we type+check the term-level binders in a bumped level, and we must accordingly bump+the level whenever these binders are in scope.+-}++tcRules :: [LRuleDecls GhcRn] -> TcM [LRuleDecls GhcTcId]+tcRules decls = mapM (wrapLocM tcRuleDecls) decls++tcRuleDecls :: RuleDecls GhcRn -> TcM (RuleDecls GhcTcId)+tcRuleDecls (HsRules { rds_src = src+                     , rds_rules = decls })+   = do { tc_decls <- mapM (wrapLocM tcRule) decls+        ; return $ HsRules { rds_ext   = noExt+                           , rds_src   = src+                           , rds_rules = tc_decls } }+tcRuleDecls (XRuleDecls _) = panic "tcRuleDecls"++tcRule :: RuleDecl GhcRn -> TcM (RuleDecl GhcTcId)+tcRule (HsRule { rd_ext  = ext+               , rd_name = rname@(L _ (_,name))+               , rd_act  = act+               , rd_tyvs = ty_bndrs+               , rd_tmvs = tm_bndrs+               , rd_lhs  = lhs+               , rd_rhs  = rhs })+  = addErrCtxt (ruleCtxt name)  $+    do { traceTc "---- Rule ------" (pprFullRuleName rname)++        -- Note [Typechecking rules]+       ; (tc_lvl, stuff) <- pushTcLevelM $+                            generateRuleConstraints ty_bndrs tm_bndrs lhs rhs++       ; let (tv_bndrs, id_bndrs, lhs', lhs_wanted+                                , rhs', rhs_wanted, rule_ty) = stuff++       ; traceTc "tcRule 1" (vcat [ pprFullRuleName rname+                                  , ppr lhs_wanted+                                  , ppr rhs_wanted ])++       ; (lhs_evs, residual_lhs_wanted)+            <- simplifyRule name tc_lvl lhs_wanted rhs_wanted++       -- SimplfyRule Plan, step 4+       -- Now figure out what to quantify over+       -- c.f. TcSimplify.simplifyInfer+       -- We quantify over any tyvars free in *either* the rule+       --  *or* the bound variables.  The latter is important.  Consider+       --      ss (x,(y,z)) = (x,z)+       --      RULE:  forall v. fst (ss v) = fst v+       -- The type of the rhs of the rule is just a, but v::(a,(b,c))+       --+       -- We also need to get the completely-uconstrained tyvars of+       -- the LHS, lest they otherwise get defaulted to Any; but we do that+       -- during zonking (see TcHsSyn.zonkRule)++       ; let tpl_ids = lhs_evs ++ id_bndrs+       ; gbls  <- tcGetGlobalTyCoVars -- Even though top level, there might be top-level+                                      -- monomorphic bindings from the MR; test tc111+       ; forall_tkvs <- candidateQTyVarsOfTypes $+                        map (mkSpecForAllTys tv_bndrs) $  -- don't quantify over lexical tyvars+                        rule_ty : map idType tpl_ids+       ; qtkvs <- quantifyTyVars gbls forall_tkvs+       ; traceTc "tcRule" (vcat [ pprFullRuleName rname+                                , ppr forall_tkvs+                                , ppr qtkvs+                                , ppr tv_bndrs+                                , ppr rule_ty+                                , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ]+                  ])++       -- SimplfyRule Plan, step 5+       -- Simplify the LHS and RHS constraints:+       -- For the LHS constraints we must solve the remaining constraints+       -- (a) so that we report insoluble ones+       -- (b) so that we bind any soluble ones+       ; let all_qtkvs = qtkvs ++ tv_bndrs+             skol_info = RuleSkol name+       ; (lhs_implic, lhs_binds) <- buildImplicationFor tc_lvl skol_info all_qtkvs+                                         lhs_evs residual_lhs_wanted+       ; (rhs_implic, rhs_binds) <- buildImplicationFor tc_lvl skol_info all_qtkvs+                                         lhs_evs rhs_wanted++       ; emitImplications (lhs_implic `unionBags` rhs_implic)+       ; return $ HsRule { rd_ext = ext+                         , rd_name = rname+                         , rd_act = act+                         , rd_tyvs = ty_bndrs -- preserved for ppr-ing+                         , rd_tmvs = map (noLoc . RuleBndr noExt . noLoc) (all_qtkvs ++ tpl_ids)+                         , rd_lhs  = mkHsDictLet lhs_binds lhs'+                         , rd_rhs  = mkHsDictLet rhs_binds rhs' } }+tcRule (XRuleDecl _) = panic "tcRule"++generateRuleConstraints :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]+                        -> LHsExpr GhcRn -> LHsExpr GhcRn+                        -> TcM ( [TyVar]+                               , [TcId]+                               , LHsExpr GhcTc, WantedConstraints+                               , LHsExpr GhcTc, WantedConstraints+                               , TcType )+generateRuleConstraints ty_bndrs tm_bndrs lhs rhs+  = do { ((tv_bndrs, id_bndrs), bndr_wanted) <- captureConstraints $+                                                tcRuleBndrs ty_bndrs tm_bndrs+              -- bndr_wanted constraints can include wildcard hole+              -- constraints, which we should not forget about.+              -- It may mention the skolem type variables bound by+              -- the RULE.  c.f. #10072++       ; tcExtendTyVarEnv tv_bndrs $+         tcExtendIdEnv    id_bndrs $+    do { -- See Note [Solve order for RULES]+         ((lhs', rule_ty), lhs_wanted) <- captureConstraints (tcInferRho lhs)+       ; (rhs',            rhs_wanted) <- captureConstraints $+                                          tcMonoExpr rhs (mkCheckExpType rule_ty)+       ; let all_lhs_wanted = bndr_wanted `andWC` lhs_wanted+       ; return (tv_bndrs, id_bndrs, lhs', all_lhs_wanted, rhs', rhs_wanted, rule_ty) } }++-- See Note [TcLevel in type checking rules]+tcRuleBndrs :: Maybe [LHsTyVarBndr GhcRn] -> [LRuleBndr GhcRn]+            -> TcM ([TcTyVar], [Id])+tcRuleBndrs (Just bndrs) xs+  = do { (tys1,(tys2,tms)) <- bindExplicitTKBndrs_Skol bndrs $+                              tcRuleTmBndrs xs+       ; return (tys1 ++ tys2, tms) }++tcRuleBndrs Nothing xs+  = tcRuleTmBndrs xs++-- See Note [TcLevel in type checking rules]+tcRuleTmBndrs :: [LRuleBndr GhcRn] -> TcM ([TcTyVar],[Id])+tcRuleTmBndrs [] = return ([],[])+tcRuleTmBndrs (L _ (RuleBndr _ (L _ name)) : rule_bndrs)+  = do  { ty <- newOpenFlexiTyVarTy+        ; (tyvars, tmvars) <- tcRuleTmBndrs rule_bndrs+        ; return (tyvars, mkLocalId name ty : tmvars) }+tcRuleTmBndrs (L _ (RuleBndrSig _ (L _ name) rn_ty) : rule_bndrs)+--  e.g         x :: a->a+--  The tyvar 'a' is brought into scope first, just as if you'd written+--              a::*, x :: a->a+--  If there's an explicit forall, the renamer would have already reported an+--   error for each out-of-scope type variable used+  = do  { let ctxt = RuleSigCtxt name+        ; (_ , tvs, id_ty) <- tcHsPatSigType ctxt rn_ty+        ; let id  = mkLocalIdOrCoVar name id_ty+                    -- See Note [Pattern signature binders] in TcHsType++              -- The type variables scope over subsequent bindings; yuk+        ; (tyvars, tmvars) <- tcExtendNameTyVarEnv tvs $+                                   tcRuleTmBndrs rule_bndrs+        ; return (map snd tvs ++ tyvars, id : tmvars) }+tcRuleTmBndrs (L _ (XRuleBndr _) : _) = panic "tcRuleTmBndrs"++ruleCtxt :: FastString -> SDoc+ruleCtxt name = text "When checking the transformation rule" <+>+                doubleQuotes (ftext name)+++{-+*********************************************************************************+*                                                                                 *+              Constraint simplification for rules+*                                                                                 *+***********************************************************************************++Note [The SimplifyRule Plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Example.  Consider the following left-hand side of a rule+        f (x == y) (y > z) = ...+If we typecheck this expression we get constraints+        d1 :: Ord a, d2 :: Eq a+We do NOT want to "simplify" to the LHS+        forall x::a, y::a, z::a, d1::Ord a.+          f ((==) (eqFromOrd d1) x y) ((>) d1 y z) = ...+Instead we want+        forall x::a, y::a, z::a, d1::Ord a, d2::Eq a.+          f ((==) d2 x y) ((>) d1 y z) = ...++Here is another example:+        fromIntegral :: (Integral a, Num b) => a -> b+        {-# RULES "foo"  fromIntegral = id :: Int -> Int #-}+In the rule, a=b=Int, and Num Int is a superclass of Integral Int. But+we *dont* want to get+        forall dIntegralInt.+           fromIntegral Int Int dIntegralInt (scsel dIntegralInt) = id Int+because the scsel will mess up RULE matching.  Instead we want+        forall dIntegralInt, dNumInt.+          fromIntegral Int Int dIntegralInt dNumInt = id Int++Even if we have+        g (x == y) (y == z) = ..+where the two dictionaries are *identical*, we do NOT WANT+        forall x::a, y::a, z::a, d1::Eq a+          f ((==) d1 x y) ((>) d1 y z) = ...+because that will only match if the dict args are (visibly) equal.+Instead we want to quantify over the dictionaries separately.++In short, simplifyRuleLhs must *only* squash equalities, leaving+all dicts unchanged, with absolutely no sharing.++Also note that we can't solve the LHS constraints in isolation:+Example   foo :: Ord a => a -> a+          foo_spec :: Int -> Int+          {-# RULE "foo"  foo = foo_spec #-}+Here, it's the RHS that fixes the type variable++HOWEVER, under a nested implication things are different+Consider+  f :: (forall a. Eq a => a->a) -> Bool -> ...+  {-# RULES "foo" forall (v::forall b. Eq b => b->b).+       f b True = ...+    #-}+Here we *must* solve the wanted (Eq a) from the given (Eq a)+resulting from skolemising the argument type of g.  So we+revert to SimplCheck when going under an implication.+++--------- So the SimplifyRule Plan is this -----------------------++* Step 0: typecheck the LHS and RHS to get constraints from each++* Step 1: Simplify the LHS and RHS constraints all together in one bag+          We do this to discover all unification equalities++* Step 2: Zonk the ORIGINAL (unsimplified) LHS constraints, to take+          advantage of those unifications++* Setp 3: Partition the LHS constraints into the ones we will+          quantify over, and the others.+          See Note [RULE quantification over equalities]++* Step 4: Decide on the type variables to quantify over++* Step 5: Simplify the LHS and RHS constraints separately, using the+          quantified constraints as givens++Note [Solve order for RULES]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In step 1 above, we need to be a bit careful about solve order.+Consider+   f :: Int -> T Int+   type instance T Int = Bool++   RULE f 3 = True++From the RULE we get+   lhs-constraints:  T Int ~ alpha+   rhs-constraints:  Bool ~ alpha+where 'alpha' is the type that connects the two.  If we glom them+all together, and solve the RHS constraint first, we might solve+with alpha := Bool.  But then we'd end up with a RULE like++    RULE: f 3 |> (co :: T Int ~ Bool) = True++which is terrible.  We want++    RULE: f 3 = True |> (sym co :: Bool ~ T Int)++So we are careful to solve the LHS constraints first, and *then* the+RHS constraints.  Actually much of this is done by the on-the-fly+constraint solving, so the same order must be observed in+tcRule.+++Note [RULE quantification over equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Deciding which equalities to quantify over is tricky:+ * We do not want to quantify over insoluble equalities (Int ~ Bool)+    (a) because we prefer to report a LHS type error+    (b) because if such things end up in 'givens' we get a bogus+        "inaccessible code" error++ * But we do want to quantify over things like (a ~ F b), where+   F is a type function.++The difficulty is that it's hard to tell what is insoluble!+So we see whether the simplification step yielded any type errors,+and if so refrain from quantifying over *any* equalities.++Note [Quantifying over coercion holes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Equality constraints from the LHS will emit coercion hole Wanteds.+These don't have a name, so we can't quantify over them directly.+Instead, because we really do want to quantify here, invent a new+EvVar for the coercion, fill the hole with the invented EvVar, and+then quantify over the EvVar. Not too tricky -- just some+impedance matching, really.++Note [Simplify cloned constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At this stage, we're simplifying constraints only for insolubility+and for unification. Note that all the evidence is quickly discarded.+We use a clone of the real constraint. If we don't do this,+then RHS coercion-hole constraints get filled in, only to get filled+in *again* when solving the implications emitted from tcRule. That's+terrible, so we avoid the problem by cloning the constraints.++-}++simplifyRule :: RuleName+             -> TcLevel                 -- Level at which to solve the constraints+             -> WantedConstraints       -- Constraints from LHS+             -> WantedConstraints       -- Constraints from RHS+             -> TcM ( [EvVar]               -- Quantify over these LHS vars+                    , WantedConstraints)    -- Residual un-quantified LHS constraints+-- See Note [The SimplifyRule Plan]+-- NB: This consumes all simple constraints on the LHS, but not+-- any LHS implication constraints.+simplifyRule name tc_lvl lhs_wanted rhs_wanted+  = do {+       -- Note [The SimplifyRule Plan] step 1+       -- First solve the LHS and *then* solve the RHS+       -- Crucially, this performs unifications+       -- Why clone?  See Note [Simplify cloned constraints]+       ; lhs_clone <- cloneWC lhs_wanted+       ; rhs_clone <- cloneWC rhs_wanted+       ; setTcLevel tc_lvl $+         runTcSDeriveds    $+         do { _ <- solveWanteds lhs_clone+            ; _ <- solveWanteds rhs_clone+                  -- Why do them separately?+                  -- See Note [Solve order for RULES]+            ; return () }++       -- Note [The SimplifyRule Plan] step 2+       ; lhs_wanted <- zonkWC lhs_wanted+       ; let (quant_cts, residual_lhs_wanted) = getRuleQuantCts lhs_wanted++       -- Note [The SimplifyRule Plan] step 3+       ; quant_evs <- mapM mk_quant_ev (bagToList quant_cts)++       ; traceTc "simplifyRule" $+         vcat [ text "LHS of rule" <+> doubleQuotes (ftext name)+              , text "lhs_wanted" <+> ppr lhs_wanted+              , text "rhs_wanted" <+> ppr rhs_wanted+              , text "quant_cts" <+> ppr quant_cts+              , text "residual_lhs_wanted" <+> ppr residual_lhs_wanted+              ]++       ; return (quant_evs, residual_lhs_wanted) }++  where+    mk_quant_ev :: Ct -> TcM EvVar+    mk_quant_ev ct+      | CtWanted { ctev_dest = dest, ctev_pred = pred } <- ctEvidence ct+      = case dest of+          EvVarDest ev_id -> return ev_id+          HoleDest hole   -> -- See Note [Quantifying over coercion holes]+                             do { ev_id <- newEvVar pred+                                ; fillCoercionHole hole (mkTcCoVarCo ev_id)+                                ; return ev_id }+    mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct)+++getRuleQuantCts :: WantedConstraints -> (Cts, WantedConstraints)+-- Extract all the constraints we can quantify over,+--   also returning the depleted WantedConstraints+--+-- NB: we must look inside implications, because with+--     -fdefer-type-errors we generate implications rather eagerly;+--     see TcUnify.implicationNeeded. Not doing so caused #14732.+--+-- Unlike simplifyInfer, we don't leave the WantedConstraints unchanged,+--   and attempt to solve them from the quantified constraints.  That+--   nearly works, but fails for a constraint like (d :: Eq Int).+--   We /do/ want to quantify over it, but the short-cut solver+--   (see TcInteract Note [Shortcut solving]) ignores the quantified+--   and instead solves from the top level.+--+--   So we must partition the WantedConstraints ourselves+--   Not hard, but tiresome.++getRuleQuantCts wc+  = float_wc emptyVarSet wc+  where+    float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints)+    float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics })+      = ( simple_yes `andCts` implic_yes+        , WC { wc_simple = simple_no, wc_impl = implics_no })+     where+        (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples+        (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs)+                                                emptyBag implics++    float_implic :: TcTyCoVarSet -> Cts -> Implication -> (Cts, Implication)+    float_implic skol_tvs yes1 imp+      = (yes1 `andCts` yes2, imp { ic_wanted = no })+      where+        (yes2, no) = float_wc new_skol_tvs (ic_wanted imp)+        new_skol_tvs = skol_tvs `extendVarSetList` ic_skols imp++    rule_quant_ct :: TcTyCoVarSet -> Ct -> Bool+    rule_quant_ct skol_tvs ct+      | EqPred _ t1 t2 <- classifyPredType (ctPred ct)+      , not (ok_eq t1 t2)+       = False        -- Note [RULE quantification over equalities]+      | isHoleCt ct+      = False         -- Don't quantify over type holes, obviously+      | otherwise+      = tyCoVarsOfCt ct `disjointVarSet` skol_tvs++    ok_eq t1 t2+       | t1 `tcEqType` t2 = False+       | otherwise        = is_fun_app t1 || is_fun_app t2++    is_fun_app ty   -- ty is of form (F tys) where F is a type function+      = case tyConAppTyCon_maybe ty of+          Just tc -> isTypeFamilyTyCon tc+          Nothing -> False
+ compiler/typecheck/TcSMonad.hs view
@@ -0,0 +1,3522 @@+{-# LANGUAGE CPP, TypeFamilies #-}++-- Type definitions for the constraint solver+module TcSMonad (++    -- The work list+    WorkList(..), isEmptyWorkList, emptyWorkList,+    extendWorkListNonEq, extendWorkListCt,+    extendWorkListCts, extendWorkListEq, extendWorkListFunEq,+    appendWorkList, extendWorkListImplic,+    selectNextWorkItem,+    workListSize, workListWantedCount,+    getWorkList, updWorkListTcS,++    -- The TcS monad+    TcS, runTcS, runTcSDeriveds, runTcSWithEvBinds,+    failTcS, warnTcS, addErrTcS,+    runTcSEqualities,+    nestTcS, nestImplicTcS, setEvBindsTcS,+    checkConstraintsTcS, checkTvConstraintsTcS,++    runTcPluginTcS, addUsedGRE, addUsedGREs,+    matchGlobalInst, TcM.ClsInstResult(..),++    QCInst(..),++    -- Tracing etc+    panicTcS, traceTcS,+    traceFireTcS, bumpStepCountTcS, csTraceTcS,+    wrapErrTcS, wrapWarnTcS,++    -- Evidence creation and transformation+    MaybeNew(..), freshGoals, isFresh, getEvExpr,++    newTcEvBinds, newNoTcEvBinds,+    newWantedEq, emitNewWantedEq,+    newWanted, newWantedEvVar, newWantedNC, newWantedEvVarNC, newDerivedNC,+    newBoundEvVarId,+    unifyTyVar, unflattenFmv, reportUnifications,+    setEvBind, setWantedEq,+    setWantedEvTerm, setEvBindIfWanted,+    newEvVar, newGivenEvVar, newGivenEvVars,+    emitNewDeriveds, emitNewDerivedEq,+    checkReductionDepth,+    getSolvedDicts, setSolvedDicts,++    getInstEnvs, getFamInstEnvs,                -- Getting the environments+    getTopEnv, getGblEnv, getLclEnv,+    getTcEvBindsVar, getTcLevel,+    getTcEvTyCoVars, getTcEvBindsMap, setTcEvBindsMap,+    tcLookupClass, tcLookupId,++    -- Inerts+    InertSet(..), InertCans(..),+    updInertTcS, updInertCans, updInertDicts, updInertIrreds,+    getNoGivenEqs, setInertCans,+    getInertEqs, getInertCans, getInertGivens,+    getInertInsols,+    getTcSInerts, setTcSInerts,+    matchableGivens, prohibitedSuperClassSolve, mightMatchLater,+    getUnsolvedInerts,+    removeInertCts, getPendingGivenScs,+    addInertCan, insertFunEq, addInertForAll,+    emitWorkNC, emitWork,+    isImprovable,++    -- The Model+    kickOutAfterUnification,++    -- Inert Safe Haskell safe-overlap failures+    addInertSafehask, insertSafeOverlapFailureTcS, updInertSafehask,+    getSafeOverlapFailures,++    -- Inert CDictCans+    DictMap, emptyDictMap, lookupInertDict, findDictsByClass, addDict,+    addDictsByClass, delDict, foldDicts, filterDicts, findDict,++    -- Inert CTyEqCans+    EqualCtList, findTyEqs, foldTyEqs, isInInertEqs,+    lookupFlattenTyVar, lookupInertTyVar,++    -- Inert solved dictionaries+    addSolvedDict, lookupSolvedDict,++    -- Irreds+    foldIrreds,++    -- The flattening cache+    lookupFlatCache, extendFlatCache, newFlattenSkolem,            -- Flatten skolems+    dischargeFunEq, pprKicked,++    -- Inert CFunEqCans+    updInertFunEqs, findFunEq,+    findFunEqsByTyCon,++    instDFunType,                              -- Instantiation++    -- MetaTyVars+    newFlexiTcSTy, instFlexi, instFlexiX,+    cloneMetaTyVar, demoteUnfilledFmv,+    tcInstSkolTyVarsX,++    TcLevel,+    isFilledMetaTyVar_maybe, isFilledMetaTyVar,+    zonkTyCoVarsAndFV, zonkTcType, zonkTcTypes, zonkTcTyVar, zonkCo,+    zonkTyCoVarsAndFVList,+    zonkSimples, zonkWC,+    zonkTyCoVarKind,++    -- References+    newTcRef, readTcRef, writeTcRef, updTcRef,++    -- Misc+    getDefaultInfo, getDynFlags, getGlobalRdrEnvTcS,+    matchFam, matchFamTcM,+    checkWellStagedDFun,+    pprEq                                    -- Smaller utils, re-exported from TcM+                                             -- TODO (DV): these are only really used in the+                                             -- instance matcher in TcSimplify. I am wondering+                                             -- if the whole instance matcher simply belongs+                                             -- here+) where++#include "HsVersions.h"++import GhcPrelude++import HscTypes++import qualified Inst as TcM+import InstEnv+import FamInst+import FamInstEnv++import qualified TcRnMonad as TcM+import qualified TcMType as TcM+import qualified ClsInst as TcM( matchGlobalInst, ClsInstResult(..) )+import qualified TcEnv as TcM+       ( checkWellStaged, tcGetDefaultTys, tcLookupClass, tcLookupId, topIdLvl )+import ClsInst( InstanceWhat(..) )+import Kind+import TcType+import DynFlags+import Type+import Coercion+import Unify++import TcEvidence+import Class+import TyCon+import TcErrors   ( solverDepthErrorTcS )++import Name+import Module ( HasModule, getModule )+import RdrName ( GlobalRdrEnv, GlobalRdrElt )+import qualified RnEnv as TcM+import Var+import VarEnv+import VarSet+import Outputable+import Bag+import UniqSupply+import Util+import TcRnTypes++import Unique+import UniqFM+import UniqDFM+import Maybes++import CoreMap+import Control.Monad+import qualified Control.Monad.Fail as MonadFail+import MonadUtils+import Data.IORef+import Data.List ( partition, mapAccumL )++#if defined(DEBUG)+import Digraph+import UniqSet+#endif++{-+************************************************************************+*                                                                      *+*                            Worklists                                *+*  Canonical and non-canonical constraints that the simplifier has to  *+*  work on. Including their simplification depths.                     *+*                                                                      *+*                                                                      *+************************************************************************++Note [WorkList priorities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+A WorkList contains canonical and non-canonical items (of all flavors).+Notice that each Ct now has a simplification depth. We may+consider using this depth for prioritization as well in the future.++As a simple form of priority queue, our worklist separates out++* equalities (wl_eqs); see Note [Prioritise equalities]+* type-function equalities (wl_funeqs)+* all the rest (wl_rest)++Note [Prioritise equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very important to process equalities /first/:++* (Efficiency)  The general reason to do so is that if we process a+  class constraint first, we may end up putting it into the inert set+  and then kicking it out later.  That's extra work compared to just+  doing the equality first.++* (Avoiding fundep iteration) As #14723 showed, it's possible to+  get non-termination if we+      - Emit the Derived fundep equalities for a class constraint,+        generating some fresh unification variables.+      - That leads to some unification+      - Which kicks out the class constraint+      - Which isn't solved (because there are still some more Derived+        equalities in the work-list), but generates yet more fundeps+  Solution: prioritise derived equalities over class constraints++* (Class equalities) We need to prioritise equalities even if they+  are hidden inside a class constraint;+  see Note [Prioritise class equalities]++* (Kick-out) We want to apply this priority scheme to kicked-out+  constraints too (see the call to extendWorkListCt in kick_out_rewritable+  E.g. a CIrredCan can be a hetero-kinded (t1 ~ t2), which may become+  homo-kinded when kicked out, and hence we want to priotitise it.++* (Derived equalities) Originally we tried to postpone processing+  Derived equalities, in the hope that we might never need to deal+  with them at all; but in fact we must process Derived equalities+  eagerly, partly for the (Efficiency) reason, and more importantly+  for (Avoiding fundep iteration).++Note [Prioritise class equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We prioritise equalities in the solver (see selectWorkItem). But class+constraints like (a ~ b) and (a ~~ b) are actually equalities too;+see Note [The equality types story] in TysPrim.++Failing to prioritise these is inefficient (more kick-outs etc).+But, worse, it can prevent us spotting a "recursive knot" among+Wanted constraints.  See comment:10 of #12734 for a worked-out+example.++So we arrange to put these particular class constraints in the wl_eqs.++  NB: since we do not currently apply the substitution to the+  inert_solved_dicts, the knot-tying still seems a bit fragile.+  But this makes it better.+-}++-- See Note [WorkList priorities]+data WorkList+  = WL { wl_eqs     :: [Ct]  -- CTyEqCan, CDictCan, CIrredCan+                             -- Given, Wanted, and Derived+                       -- Contains both equality constraints and their+                       -- class-level variants (a~b) and (a~~b);+                       -- See Note [Prioritise equalities]+                       -- See Note [Prioritise class equalities]++       , wl_funeqs  :: [Ct]++       , wl_rest    :: [Ct]++       , wl_implics :: Bag Implication  -- See Note [Residual implications]+    }++appendWorkList :: WorkList -> WorkList -> WorkList+appendWorkList+    (WL { wl_eqs = eqs1, wl_funeqs = funeqs1, wl_rest = rest1+        , wl_implics = implics1 })+    (WL { wl_eqs = eqs2, wl_funeqs = funeqs2, wl_rest = rest2+        , wl_implics = implics2 })+   = WL { wl_eqs     = eqs1     ++ eqs2+        , wl_funeqs  = funeqs1  ++ funeqs2+        , wl_rest    = rest1    ++ rest2+        , wl_implics = implics1 `unionBags`   implics2 }++workListSize :: WorkList -> Int+workListSize (WL { wl_eqs = eqs, wl_funeqs = funeqs, wl_rest = rest })+  = length eqs + length funeqs + length rest++workListWantedCount :: WorkList -> Int+-- Count the things we need to solve+-- excluding the insolubles (c.f. inert_count)+workListWantedCount (WL { wl_eqs = eqs, wl_rest = rest })+  = count isWantedCt eqs + count is_wanted rest+  where+    is_wanted ct+     | CIrredCan { cc_ev = ev, cc_insol = insol } <- ct+     = not insol && isWanted ev+     | otherwise+     = isWantedCt ct++extendWorkListEq :: Ct -> WorkList -> WorkList+extendWorkListEq ct wl = wl { wl_eqs = ct : wl_eqs wl }++extendWorkListFunEq :: Ct -> WorkList -> WorkList+extendWorkListFunEq ct wl = wl { wl_funeqs = ct : wl_funeqs wl }++extendWorkListNonEq :: Ct -> WorkList -> WorkList+-- Extension by non equality+extendWorkListNonEq ct wl = wl { wl_rest = ct : wl_rest wl }++extendWorkListDeriveds :: [CtEvidence] -> WorkList -> WorkList+extendWorkListDeriveds evs wl+  = extendWorkListCts (map mkNonCanonical evs) wl++extendWorkListImplic :: Bag Implication -> WorkList -> WorkList+extendWorkListImplic implics wl = wl { wl_implics = implics `unionBags` wl_implics wl }++extendWorkListCt :: Ct -> WorkList -> WorkList+-- Agnostic+extendWorkListCt ct wl+ = case classifyPredType (ctPred ct) of+     EqPred NomEq ty1 _+       | Just tc <- tcTyConAppTyCon_maybe ty1+       , isTypeFamilyTyCon tc+       -> extendWorkListFunEq ct wl++     EqPred {}+       -> extendWorkListEq ct wl++     ClassPred cls _  -- See Note [Prioritise class equalities]+       |  isEqPredClass cls+       -> extendWorkListEq ct wl++     _ -> extendWorkListNonEq ct wl++extendWorkListCts :: [Ct] -> WorkList -> WorkList+-- Agnostic+extendWorkListCts cts wl = foldr extendWorkListCt wl cts++isEmptyWorkList :: WorkList -> Bool+isEmptyWorkList (WL { wl_eqs = eqs, wl_funeqs = funeqs+                    , wl_rest = rest, wl_implics = implics })+  = null eqs && null rest && null funeqs && isEmptyBag implics++emptyWorkList :: WorkList+emptyWorkList = WL { wl_eqs  = [], wl_rest = []+                   , wl_funeqs = [], wl_implics = emptyBag }++selectWorkItem :: WorkList -> Maybe (Ct, WorkList)+-- See Note [Prioritise equalities]+selectWorkItem wl@(WL { wl_eqs = eqs, wl_funeqs = feqs+                      , wl_rest = rest })+  | ct:cts <- eqs  = Just (ct, wl { wl_eqs    = cts })+  | ct:fes <- feqs = Just (ct, wl { wl_funeqs = fes })+  | ct:cts <- rest = Just (ct, wl { wl_rest   = cts })+  | otherwise      = Nothing++getWorkList :: TcS WorkList+getWorkList = do { wl_var <- getTcSWorkListRef+                 ; wrapTcS (TcM.readTcRef wl_var) }++selectNextWorkItem :: TcS (Maybe Ct)+-- Pick which work item to do next+-- See Note [Prioritise equalities]+selectNextWorkItem+  = do { wl_var <- getTcSWorkListRef+       ; wl <- readTcRef wl_var+       ; case selectWorkItem wl of {+           Nothing -> return Nothing ;+           Just (ct, new_wl) ->+    do { -- checkReductionDepth (ctLoc ct) (ctPred ct)+         -- This is done by TcInteract.chooseInstance+       ; writeTcRef wl_var new_wl+       ; return (Just ct) } } }++-- Pretty printing+instance Outputable WorkList where+  ppr (WL { wl_eqs = eqs, wl_funeqs = feqs+          , wl_rest = rest, wl_implics = implics })+   = text "WL" <+> (braces $+     vcat [ ppUnless (null eqs) $+            text "Eqs =" <+> vcat (map ppr eqs)+          , ppUnless (null feqs) $+            text "Funeqs =" <+> vcat (map ppr feqs)+          , ppUnless (null rest) $+            text "Non-eqs =" <+> vcat (map ppr rest)+          , ppUnless (isEmptyBag implics) $+            ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics)))+                       (text "(Implics omitted)")+          ])+++{- *********************************************************************+*                                                                      *+                InertSet: the inert set+*                                                                      *+*                                                                      *+********************************************************************* -}++data InertSet+  = IS { inert_cans :: InertCans+              -- Canonical Given, Wanted, Derived+              -- Sometimes called "the inert set"++       , inert_fsks :: [(TcTyVar, TcType)]+              -- A list of (fsk, ty) pairs; we add one element when we flatten+              -- a function application in a Given constraint, creating+              -- a new fsk in newFlattenSkolem.  When leaving a nested scope,+              -- unflattenGivens unifies fsk := ty+              --+              -- We could also get this info from inert_funeqs, filtered by+              -- level, but it seems simpler and more direct to capture the+              -- fsk as we generate them.++       , inert_flat_cache :: ExactFunEqMap (TcCoercion, TcType, CtFlavour)+              -- See Note [Type family equations]+              -- If    F tys :-> (co, rhs, flav),+              -- then  co :: F tys ~ rhs+              --       flav is [G] or [WD]+              --+              -- Just a hash-cons cache for use when flattening only+              -- These include entirely un-processed goals, so don't use+              -- them to solve a top-level goal, else you may end up solving+              -- (w:F ty ~ a) by setting w:=w!  We just use the flat-cache+              -- when allocating a new flatten-skolem.+              -- Not necessarily inert wrt top-level equations (or inert_cans)++              -- NB: An ExactFunEqMap -- this doesn't match via loose types!++       , inert_solved_dicts   :: DictMap CtEvidence+              -- All Wanteds, of form ev :: C t1 .. tn+              -- See Note [Solved dictionaries]+              -- and Note [Do not add superclasses of solved dictionaries]+       }++instance Outputable InertSet where+  ppr (IS { inert_cans = ics+          , inert_fsks = ifsks+          , inert_solved_dicts = solved_dicts })+      = vcat [ ppr ics+             , text "Inert fsks =" <+> ppr ifsks+             , ppUnless (null dicts) $+               text "Solved dicts =" <+> vcat (map ppr dicts) ]+         where+           dicts = bagToList (dictsToBag solved_dicts)++emptyInertCans :: InertCans+emptyInertCans+  = IC { inert_count    = 0+       , inert_eqs      = emptyDVarEnv+       , inert_dicts    = emptyDicts+       , inert_safehask = emptyDicts+       , inert_funeqs   = emptyFunEqs+       , inert_insts    = []+       , inert_irreds   = emptyCts }++emptyInert :: InertSet+emptyInert+  = IS { inert_cans         = emptyInertCans+       , inert_fsks         = []+       , inert_flat_cache   = emptyExactFunEqs+       , inert_solved_dicts = emptyDictMap }+++{- Note [Solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we apply a top-level instance declaration, we add the "solved"+dictionary to the inert_solved_dicts.  In general, we use it to avoid+creating a new EvVar when we have a new goal that we have solved in+the past.++But in particular, we can use it to create *recursive* dictionaries.+The simplest, degnerate case is+    instance C [a] => C [a] where ...+If we have+    [W] d1 :: C [x]+then we can apply the instance to get+    d1 = $dfCList d+    [W] d2 :: C [x]+Now 'd1' goes in inert_solved_dicts, and we can solve d2 directly from d1.+    d1 = $dfCList d+    d2 = d1++See Note [Example of recursive dictionaries]+Other notes about solved dictionaries++* See also Note [Do not add superclasses of solved dictionaries]++* The inert_solved_dicts field is not rewritten by equalities,+  so it may get out of date.++* THe inert_solved_dicts are all Wanteds, never givens++* We only cache dictionaries from top-level instances, not from+  local quantified constraints.  Reason: if we cached the latter+  we'd need to purge the cache when bringing new quantified+  constraints into scope, because quantified constraints "shadow"+  top-level instances.++Note [Do not add superclasses of solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Every member of inert_solved_dicts is the result of applying a dictionary+function, NOT of applying superclass selection to anything.+Consider++        class Ord a => C a where+        instance Ord [a] => C [a] where ...++Suppose we are trying to solve+  [G] d1 : Ord a+  [W] d2 : C [a]++Then we'll use the instance decl to give++  [G] d1 : Ord a     Solved: d2 : C [a] = $dfCList d3+  [W] d3 : Ord [a]++We must not add d4 : Ord [a] to the 'solved' set (by taking the+superclass of d2), otherwise we'll use it to solve d3, without ever+using d1, which would be a catastrophe.++Solution: when extending the solved dictionaries, do not add superclasses.+That's why each element of the inert_solved_dicts is the result of applying+a dictionary function.++Note [Example of recursive dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--- Example 1++    data D r = ZeroD | SuccD (r (D r));++    instance (Eq (r (D r))) => Eq (D r) where+        ZeroD     == ZeroD     = True+        (SuccD a) == (SuccD b) = a == b+        _         == _         = False;++    equalDC :: D [] -> D [] -> Bool;+    equalDC = (==);++We need to prove (Eq (D [])). Here's how we go:++   [W] d1 : Eq (D [])+By instance decl of Eq (D r):+   [W] d2 : Eq [D []]      where   d1 = dfEqD d2+By instance decl of Eq [a]:+   [W] d3 : Eq (D [])      where   d2 = dfEqList d3+                                   d1 = dfEqD d2+Now this wanted can interact with our "solved" d1 to get:+    d3 = d1++-- Example 2:+This code arises in the context of "Scrap Your Boilerplate with Class"++    class Sat a+    class Data ctx a+    instance  Sat (ctx Char)             => Data ctx Char       -- dfunData1+    instance (Sat (ctx [a]), Data ctx a) => Data ctx [a]        -- dfunData2++    class Data Maybe a => Foo a++    instance Foo t => Sat (Maybe t)                             -- dfunSat++    instance Data Maybe a => Foo a                              -- dfunFoo1+    instance Foo a        => Foo [a]                            -- dfunFoo2+    instance                 Foo [Char]                         -- dfunFoo3++Consider generating the superclasses of the instance declaration+         instance Foo a => Foo [a]++So our problem is this+    [G] d0 : Foo t+    [W] d1 : Data Maybe [t]   -- Desired superclass++We may add the given in the inert set, along with its superclasses+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  WorkList+    [W] d1 : Data Maybe [t]++Solve d1 using instance dfunData2; d1 := dfunData2 d2 d3+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+  WorkList:+    [W] d2 : Sat (Maybe [t])+    [W] d3 : Data Maybe t++Now, we may simplify d2 using dfunSat; d2 := dfunSat d4+  Inert:+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+  WorkList:+    [W] d3 : Data Maybe t+    [W] d4 : Foo [t]++Now, we can just solve d3 from d01; d3 := d01+  Inert+    [G] d0 : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+  WorkList+    [W] d4 : Foo [t]++Now, solve d4 using dfunFoo2;  d4 := dfunFoo2 d5+  Inert+    [G] d0  : Foo t+    [G] d01 : Data Maybe t   -- Superclass of d0+  Solved:+        d1 : Data Maybe [t]+        d2 : Sat (Maybe [t])+        d4 : Foo [t]+  WorkList:+    [W] d5 : Foo t++Now, d5 can be solved! d5 := d0++Result+   d1 := dfunData2 d2 d3+   d2 := dfunSat d4+   d3 := d01+   d4 := dfunFoo2 d5+   d5 := d0+-}++{- *********************************************************************+*                                                                      *+                InertCans: the canonical inerts+*                                                                      *+*                                                                      *+********************************************************************* -}++data InertCans   -- See Note [Detailed InertCans Invariants] for more+  = IC { inert_eqs :: InertEqs+              -- See Note [inert_eqs: the inert equalities]+              -- All CTyEqCans; index is the LHS tyvar+              -- Domain = skolems and untouchables; a touchable would be unified++       , inert_funeqs :: FunEqMap Ct+              -- All CFunEqCans; index is the whole family head type.+              -- All Nominal (that's an invarint of all CFunEqCans)+              -- LHS is fully rewritten (modulo eqCanRewrite constraints)+              --     wrt inert_eqs+              -- Can include all flavours, [G], [W], [WD], [D]+              -- See Note [Type family equations]++       , inert_dicts :: DictMap Ct+              -- Dictionaries only+              -- All fully rewritten (modulo flavour constraints)+              --     wrt inert_eqs++       , inert_insts :: [QCInst]++       , inert_safehask :: DictMap Ct+              -- Failed dictionary resolution due to Safe Haskell overlapping+              -- instances restriction. We keep this separate from inert_dicts+              -- as it doesn't cause compilation failure, just safe inference+              -- failure.+              --+              -- ^ See Note [Safe Haskell Overlapping Instances Implementation]+              -- in TcSimplify++       , inert_irreds :: Cts+              -- Irreducible predicates that cannot be made canonical,+              --     and which don't interact with others (e.g.  (c a))+              -- and insoluble predicates (e.g.  Int ~ Bool, or a ~ [a])++       , inert_count :: Int+              -- Number of Wanted goals in+              --     inert_eqs, inert_dicts, inert_safehask, inert_irreds+              -- Does not include insolubles+              -- When non-zero, keep trying to solve+       }++type InertEqs    = DTyVarEnv EqualCtList+type EqualCtList = [Ct]  -- See Note [EqualCtList invariants]++{- Note [Detailed InertCans Invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The InertCans represents a collection of constraints with the following properties:++  * All canonical++  * No two dictionaries with the same head+  * No two CIrreds with the same type++  * Family equations inert wrt top-level family axioms++  * Dictionaries have no matching top-level instance++  * Given family or dictionary constraints don't mention touchable+    unification variables++  * Non-CTyEqCan constraints are fully rewritten with respect+    to the CTyEqCan equalities (modulo canRewrite of course;+    eg a wanted cannot rewrite a given)++  * CTyEqCan equalities: see Note [Applying the inert substitution]+                         in TcFlatten++Note [EqualCtList invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    * All are equalities+    * All these equalities have the same LHS+    * The list is never empty+    * No element of the list can rewrite any other+    * Derived before Wanted++From the fourth invariant it follows that the list is+   - A single [G], or+   - Zero or one [D] or [WD], followd by any number of [W]++The Wanteds can't rewrite anything which is why we put them last++Note [Type family equations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Type-family equations, CFunEqCans, of form (ev : F tys ~ ty),+live in three places++  * The work-list, of course++  * The inert_funeqs are un-solved but fully processed, and in+    the InertCans. They can be [G], [W], [WD], or [D].++  * The inert_flat_cache.  This is used when flattening, to get maximal+    sharing. Everthing in the inert_flat_cache is [G] or [WD]++    It contains lots of things that are still in the work-list.+    E.g Suppose we have (w1: F (G a) ~ Int), and (w2: H (G a) ~ Int) in the+        work list.  Then we flatten w1, dumping (w3: G a ~ f1) in the work+        list.  Now if we flatten w2 before we get to w3, we still want to+        share that (G a).+    Because it contains work-list things, DO NOT use the flat cache to solve+    a top-level goal.  Eg in the above example we don't want to solve w3+    using w3 itself!++The CFunEqCan Ownership Invariant:++  * Each [G/W/WD] CFunEqCan has a distinct fsk or fmv+    It "owns" that fsk/fmv, in the sense that:+      - reducing a [W/WD] CFunEqCan fills in the fmv+      - unflattening a [W/WD] CFunEqCan fills in the fmv+      (in both cases unless an occurs-check would result)++  * In contrast a [D] CFunEqCan does not "own" its fmv:+      - reducing a [D] CFunEqCan does not fill in the fmv;+        it just generates an equality+      - unflattening ignores [D] CFunEqCans altogether+++Note [inert_eqs: the inert equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Definition [Can-rewrite relation]+A "can-rewrite" relation between flavours, written f1 >= f2, is a+binary relation with the following properties++  (R1) >= is transitive+  (R2) If f1 >= f, and f2 >= f,+       then either f1 >= f2 or f2 >= f1++Lemma.  If f1 >= f then f1 >= f1+Proof.  By property (R2), with f1=f2++Definition [Generalised substitution]+A "generalised substitution" S is a set of triples (a -f-> t), where+  a is a type variable+  t is a type+  f is a flavour+such that+  (WF1) if (a -f1-> t1) in S+           (a -f2-> t2) in S+        then neither (f1 >= f2) nor (f2 >= f1) hold+  (WF2) if (a -f-> t) is in S, then t /= a++Definition [Applying a generalised substitution]+If S is a generalised substitution+   S(f,a) = t,  if (a -fs-> t) in S, and fs >= f+          = a,  otherwise+Application extends naturally to types S(f,t), modulo roles.+See Note [Flavours with roles].++Theorem: S(f,a) is well defined as a function.+Proof: Suppose (a -f1-> t1) and (a -f2-> t2) are both in S,+               and  f1 >= f and f2 >= f+       Then by (R2) f1 >= f2 or f2 >= f1, which contradicts (WF1)++Notation: repeated application.+  S^0(f,t)     = t+  S^(n+1)(f,t) = S(f, S^n(t))++Definition: inert generalised substitution+A generalised substitution S is "inert" iff++  (IG1) there is an n such that+        for every f,t, S^n(f,t) = S^(n+1)(f,t)++By (IG1) we define S*(f,t) to be the result of exahaustively+applying S(f,_) to t.++----------------------------------------------------------------+Our main invariant:+   the inert CTyEqCans should be an inert generalised substitution+----------------------------------------------------------------++Note that inertness is not the same as idempotence.  To apply S to a+type, you may have to apply it recursive.  But inertness does+guarantee that this recursive use will terminate.++Note [Extending the inert equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Main Theorem [Stability under extension]+   Suppose we have a "work item"+       a -fw-> t+   and an inert generalised substitution S,+   THEN the extended substitution T = S+(a -fw-> t)+        is an inert generalised substitution+   PROVIDED+      (T1) S(fw,a) = a     -- LHS of work-item is a fixpoint of S(fw,_)+      (T2) S(fw,t) = t     -- RHS of work-item is a fixpoint of S(fw,_)+      (T3) a not in t      -- No occurs check in the work item++      AND, for every (b -fs-> s) in S:+           (K0) not (fw >= fs)+                Reason: suppose we kick out (a -fs-> s),+                        and add (a -fw-> t) to the inert set.+                        The latter can't rewrite the former,+                        so the kick-out achieved nothing++           OR { (K1) not (a = b)+                     Reason: if fw >= fs, WF1 says we can't have both+                             a -fw-> t  and  a -fs-> s++                AND (K2): guarantees inertness of the new substitution+                    {  (K2a) not (fs >= fs)+                    OR (K2b) fs >= fw+                    OR (K2d) a not in s }++                AND (K3) See Note [K3: completeness of solving]+                    { (K3a) If the role of fs is nominal: s /= a+                      (K3b) If the role of fs is representational:+                            s is not of form (a t1 .. tn) } }+++Conditions (T1-T3) are established by the canonicaliser+Conditions (K1-K3) are established by TcSMonad.kickOutRewritable++The idea is that+* (T1-2) are guaranteed by exhaustively rewriting the work-item+  with S(fw,_).++* T3 is guaranteed by a simple occurs-check on the work item.+  This is done during canonicalisation, in canEqTyVar;+  (invariant: a CTyEqCan never has an occurs check).++* (K1-3) are the "kick-out" criteria.  (As stated, they are really the+  "keep" criteria.) If the current inert S contains a triple that does+  not satisfy (K1-3), then we remove it from S by "kicking it out",+  and re-processing it.++* Note that kicking out is a Bad Thing, because it means we have to+  re-process a constraint.  The less we kick out, the better.+  TODO: Make sure that kicking out really *is* a Bad Thing. We've assumed+  this but haven't done the empirical study to check.++* Assume we have  G>=G, G>=W and that's all.  Then, when performing+  a unification we add a new given  a -G-> ty.  But doing so does NOT require+  us to kick out an inert wanted that mentions a, because of (K2a).  This+  is a common case, hence good not to kick out.++* Lemma (L2): if not (fw >= fw), then K0 holds and we kick out nothing+  Proof: using Definition [Can-rewrite relation], fw can't rewrite anything+         and so K0 holds.  Intuitively, since fw can't rewrite anything,+         adding it cannot cause any loops+  This is a common case, because Wanteds cannot rewrite Wanteds.+  It's used to avoid even looking for constraint to kick out.++* Lemma (L1): The conditions of the Main Theorem imply that there is no+              (a -fs-> t) in S, s.t.  (fs >= fw).+  Proof. Suppose the contrary (fs >= fw).  Then because of (T1),+  S(fw,a)=a.  But since fs>=fw, S(fw,a) = s, hence s=a.  But now we+  have (a -fs-> a) in S, which contradicts (WF2).++* The extended substitution satisfies (WF1) and (WF2)+  - (K1) plus (L1) guarantee that the extended substitution satisfies (WF1).+  - (T3) guarantees (WF2).++* (K2) is about inertness.  Intuitively, any infinite chain T^0(f,t),+  T^1(f,t), T^2(f,T).... must pass through the new work item infinitely+  often, since the substitution without the work item is inert; and must+  pass through at least one of the triples in S infinitely often.++  - (K2a): if not(fs>=fs) then there is no f that fs can rewrite (fs>=f),+    and hence this triple never plays a role in application S(f,a).+    It is always safe to extend S with such a triple.++    (NB: we could strengten K1) in this way too, but see K3.++  - (K2b): If this holds then, by (T2), b is not in t.  So applying the+    work item does not generate any new opportunities for applying S++  - (K2c): If this holds, we can't pass through this triple infinitely+    often, because if we did then fs>=f, fw>=f, hence by (R2)+      * either fw>=fs, contradicting K2c+      * or fs>=fw; so by the argument in K2b we can't have a loop++  - (K2d): if a not in s, we hae no further opportunity to apply the+    work item, similar to (K2b)++  NB: Dimitrios has a PDF that does this in more detail++Key lemma to make it watertight.+  Under the conditions of the Main Theorem,+  forall f st fw >= f, a is not in S^k(f,t), for any k++Also, consider roles more carefully. See Note [Flavours with roles]++Note [K3: completeness of solving]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(K3) is not necessary for the extended substitution+to be inert.  In fact K1 could be made stronger by saying+   ... then (not (fw >= fs) or not (fs >= fs))+But it's not enough for S to be inert; we also want completeness.+That is, we want to be able to solve all soluble wanted equalities.+Suppose we have++   work-item   b -G-> a+   inert-item  a -W-> b++Assuming (G >= W) but not (W >= W), this fulfills all the conditions,+so we could extend the inerts, thus:++   inert-items   b -G-> a+                 a -W-> b++But if we kicked-out the inert item, we'd get++   work-item     a -W-> b+   inert-item    b -G-> a++Then rewrite the work-item gives us (a -W-> a), which is soluble via Refl.+So we add one more clause to the kick-out criteria++Another way to understand (K3) is that we treat an inert item+        a -f-> b+in the same way as+        b -f-> a+So if we kick out one, we should kick out the other.  The orientation+is somewhat accidental.++When considering roles, we also need the second clause (K3b). Consider++  work-item    c -G/N-> a+  inert-item   a -W/R-> b c++The work-item doesn't get rewritten by the inert, because (>=) doesn't hold.+But we don't kick out the inert item because not (W/R >= W/R).  So we just+add the work item. But then, consider if we hit the following:++  work-item    b -G/N-> Id+  inert-items  a -W/R-> b c+               c -G/N-> a+where+  newtype Id x = Id x++For similar reasons, if we only had (K3a), we wouldn't kick the+representational inert out. And then, we'd miss solving the inert, which+now reduced to reflexivity.++The solution here is to kick out representational inerts whenever the+tyvar of a work item is "exposed", where exposed means being at the+head of the top-level application chain (a t1 .. tn).  See+TcType.isTyVarHead. This is encoded in (K3b).++Beware: if we make this test succeed too often, we kick out too much,+and the solver might loop.  Consider (#14363)+  work item:   [G] a ~R f b+  inert item:  [G] b ~R f a+In GHC 8.2 the completeness tests more aggressive, and kicked out+the inert item; but no rewriting happened and there was an infinite+loop.  All we need is to have the tyvar at the head.++Note [Flavours with roles]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The system described in Note [inert_eqs: the inert equalities]+discusses an abstract+set of flavours. In GHC, flavours have two components: the flavour proper,+taken from {Wanted, Derived, Given} and the equality relation (often called+role), taken from {NomEq, ReprEq}.+When substituting w.r.t. the inert set,+as described in Note [inert_eqs: the inert equalities],+we must be careful to respect all components of a flavour.+For example, if we have++  inert set: a -G/R-> Int+             b -G/R-> Bool++  type role T nominal representational++and we wish to compute S(W/R, T a b), the correct answer is T a Bool, NOT+T Int Bool. The reason is that T's first parameter has a nominal role, and+thus rewriting a to Int in T a b is wrong. Indeed, this non-congruence of+substitution means that the proof in Note [The inert equalities] may need+to be revisited, but we don't think that the end conclusion is wrong.+-}++instance Outputable InertCans where+  ppr (IC { inert_eqs = eqs+          , inert_funeqs = funeqs, inert_dicts = dicts+          , inert_safehask = safehask, inert_irreds = irreds+          , inert_insts = insts+          , inert_count = count })+    = braces $ vcat+      [ ppUnless (isEmptyDVarEnv eqs) $+        text "Equalities:"+          <+> pprCts (foldDVarEnv (\eqs rest -> listToBag eqs `andCts` rest) emptyCts eqs)+      , ppUnless (isEmptyTcAppMap funeqs) $+        text "Type-function equalities =" <+> pprCts (funEqsToBag funeqs)+      , ppUnless (isEmptyTcAppMap dicts) $+        text "Dictionaries =" <+> pprCts (dictsToBag dicts)+      , ppUnless (isEmptyTcAppMap safehask) $+        text "Safe Haskell unsafe overlap =" <+> pprCts (dictsToBag safehask)+      , ppUnless (isEmptyCts irreds) $+        text "Irreds =" <+> pprCts irreds+      , ppUnless (null insts) $+        text "Given instances =" <+> vcat (map ppr insts)+      , text "Unsolved goals =" <+> int count+      ]++{- *********************************************************************+*                                                                      *+             Shadow constraints and improvement+*                                                                      *+************************************************************************++Note [The improvement story and derived shadows]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because Wanteds cannot rewrite Wanteds (see Note [Wanteds do not+rewrite Wanteds] in TcRnTypes), we may miss some opportunities for+solving.  Here's a classic example (indexed-types/should_fail/T4093a)++    Ambiguity check for f: (Foo e ~ Maybe e) => Foo e++    We get [G] Foo e ~ Maybe e+           [W] Foo e ~ Foo ee      -- ee is a unification variable+           [W] Foo ee ~ Maybe ee++    Flatten: [G] Foo e ~ fsk+             [G] fsk ~ Maybe e   -- (A)++             [W] Foo ee ~ fmv+             [W] fmv ~ fsk       -- (B) From Foo e ~ Foo ee+             [W] fmv ~ Maybe ee++    --> rewrite (B) with (A)+             [W] Foo ee ~ fmv+             [W] fmv ~ Maybe e+             [W] fmv ~ Maybe ee++    But now we appear to be stuck, since we don't rewrite Wanteds with+    Wanteds.  This is silly because we can see that ee := e is the+    only solution.++The basic plan is+  * generate Derived constraints that shadow Wanted constraints+  * allow Derived to rewrite Derived+  * in order to cause some unifications to take place+  * that in turn solve the original Wanteds++The ONLY reason for all these Derived equalities is to tell us how to+unify a variable: that is, what Mark Jones calls "improvement".++The same idea is sometimes also called "saturation"; find all the+equalities that must hold in any solution.++Or, equivalently, you can think of the derived shadows as implementing+the "model": a non-idempotent but no-occurs-check substitution,+reflecting *all* *Nominal* equalities (a ~N ty) that are not+immediately soluble by unification.++More specifically, here's how it works (Oct 16):++* Wanted constraints are born as [WD]; this behaves like a+  [W] and a [D] paired together.++* When we are about to add a [WD] to the inert set, if it can+  be rewritten by a [D] a ~ ty, then we split it into [W] and [D],+  putting the latter into the work list (see maybeEmitShadow).++In the example above, we get to the point where we are stuck:+    [WD] Foo ee ~ fmv+    [WD] fmv ~ Maybe e+    [WD] fmv ~ Maybe ee++But now when [WD] fmv ~ Maybe ee is about to be added, we'll+split it into [W] and [D], since the inert [WD] fmv ~ Maybe e+can rewrite it.  Then:+    work item: [D] fmv ~ Maybe ee+    inert:     [W] fmv ~ Maybe ee+               [WD] fmv ~ Maybe e   -- (C)+               [WD] Foo ee ~ fmv++See Note [Splitting WD constraints].  Now the work item is rewritten+by (C) and we soon get ee := e.++Additional notes:++  * The derived shadow equalities live in inert_eqs, along with+    the Givens and Wanteds; see Note [EqualCtList invariants].++  * We make Derived shadows only for Wanteds, not Givens.  So we+    have only [G], not [GD] and [G] plus splitting.  See+    Note [Add derived shadows only for Wanteds]++  * We also get Derived equalities from functional dependencies+    and type-function injectivity; see calls to unifyDerived.++  * This splitting business applies to CFunEqCans too; and then+    we do apply type-function reductions to the [D] CFunEqCan.+    See Note [Reduction for Derived CFunEqCans]++  * It's worth having [WD] rather than just [W] and [D] because+    * efficiency: silly to process the same thing twice+    * inert_funeqs, inert_dicts is a finite map keyed by+      the type; it's inconvenient for it to map to TWO constraints++Note [Splitting WD constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We are about to add a [WD] constraint to the inert set; and we+know that the inert set has fully rewritten it.  Should we split+it into [W] and [D], and put the [D] in the work list for further+work?++* CDictCan (C tys) or CFunEqCan (F tys ~ fsk):+  Yes if the inert set could rewrite tys to make the class constraint,+  or type family, fire.  That is, yes if the inert_eqs intersects+  with the free vars of tys.  For this test we use+  (anyRewritableTyVar True) which ignores casts and coercions in tys,+  because rewriting the casts or coercions won't make the thing fire+  more often.++* CTyEqCan (a ~ ty): Yes if the inert set could rewrite 'a' or 'ty'.+  We need to check both 'a' and 'ty' against the inert set:+    - Inert set contains  [D] a ~ ty2+      Then we want to put [D] a ~ ty in the worklist, so we'll+      get [D] ty ~ ty2 with consequent good things++    - Inert set contains [D] b ~ a, where b is in ty.+      We can't just add [WD] a ~ ty[b] to the inert set, because+      that breaks the inert-set invariants.  If we tried to+      canonicalise another [D] constraint mentioning 'a', we'd+      get an infinite loop++  Moreover we must use (anyRewritableTyVar False) for the RHS,+  because even tyvars in the casts and coercions could give+  an infinite loop if we don't expose it++* CIrredCan: Yes if the inert set can rewrite the constraint.+  We used to think splitting irreds was unnecessary, but+  see Note [Splitting Irred WD constraints]++* Others: nothing is gained by splitting.++Note [Splitting Irred WD constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Splitting Irred constraints can make a difference. Here is the+scenario:++  a[sk] :: F v     -- F is a type family+  beta :: alpha++  work item: [WD] a ~ beta++This is heterogeneous, so we try flattening the kinds.++  co :: F v ~ fmv+  [WD] (a |> co) ~ beta++This is still hetero, so we emit a kind equality and make the work item an+inert Irred.++  work item: [D] fmv ~ alpha+  inert: [WD] (a |> co) ~ beta (CIrredCan)++Can't make progress on the work item. Add to inert set. This kicks out the+old inert, because a [D] can rewrite a [WD].++  work item: [WD] (a |> co) ~ beta+  inert: [D] fmv ~ alpha (CTyEqCan)++Can't make progress on this work item either (although GHC tries by+decomposing the cast and reflattening... but that doesn't make a difference),+which is still hetero. Emit a new kind equality and add to inert set. But,+critically, we split the Irred.++  work list:+   [D] fmv ~ alpha (CTyEqCan)+   [D] (a |> co) ~ beta (CIrred) -- this one was split off+  inert:+   [W] (a |> co) ~ beta+   [D] fmv ~ alpha++We quickly solve the first work item, as it's the same as an inert.++  work item: [D] (a |> co) ~ beta+  inert:+   [W] (a |> co) ~ beta+   [D] fmv ~ alpha++We decompose the cast, yielding++  [D] a ~ beta++We then flatten the kinds. The lhs kind is F v, which flattens to fmv which+then rewrites to alpha.++  co' :: F v ~ alpha+  [D] (a |> co') ~ beta++Now this equality is homo-kinded. So we swizzle it around to++  [D] beta ~ (a |> co')++and set beta := a |> co', and go home happy.++If we don't split the Irreds, we loop. This is all dangerously subtle.++This is triggered by test case typecheck/should_compile/SplitWD.++Note [Examples of how Derived shadows helps completeness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+#10009, a very nasty example:++    f :: (UnF (F b) ~ b) => F b -> ()++    g :: forall a. (UnF (F a) ~ a) => a -> ()+    g _ = f (undefined :: F a)++  For g we get [G] UnF (F a) ~ a+               [WD] UnF (F beta) ~ beta+               [WD] F a ~ F beta+  Flatten:+      [G] g1: F a ~ fsk1         fsk1 := F a+      [G] g2: UnF fsk1 ~ fsk2    fsk2 := UnF fsk1+      [G] g3: fsk2 ~ a++      [WD] w1: F beta ~ fmv1+      [WD] w2: UnF fmv1 ~ fmv2+      [WD] w3: fmv2 ~ beta+      [WD] w4: fmv1 ~ fsk1   -- From F a ~ F beta using flat-cache+                             -- and re-orient to put meta-var on left++Rewrite w2 with w4: [D] d1: UnF fsk1 ~ fmv2+React that with g2: [D] d2: fmv2 ~ fsk2+React that with w3: [D] beta ~ fsk2+            and g3: [D] beta ~ a -- Hooray beta := a+And that is enough to solve everything++Note [Add derived shadows only for Wanteds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We only add shadows for Wanted constraints. That is, we have+[WD] but not [GD]; and maybeEmitShaodw looks only at [WD]+constraints.++It does just possibly make sense ot add a derived shadow for a+Given. If we created a Derived shadow of a Given, it could be+rewritten by other Deriveds, and that could, conceivably, lead to a+useful unification.++But (a) I have been unable to come up with an example of this+        happening+    (b) see #12660 for how adding the derived shadows+        of a Given led to an infinite loop.+    (c) It's unlikely that rewriting derived Givens will lead+        to a unification because Givens don't mention touchable+        unification variables++For (b) there may be other ways to solve the loop, but simply+reraining from adding derived shadows of Givens is particularly+simple.  And it's more efficient too!++Still, here's one possible reason for adding derived shadows+for Givens.  Consider+           work-item [G] a ~ [b], inerts has [D] b ~ a.+If we added the derived shadow (into the work list)+         [D] a ~ [b]+When we process it, we'll rewrite to a ~ [a] and get an+occurs check.  Without it we'll miss the occurs check (reporting+inaccessible code); but that's probably OK.++Note [Keep CDictCan shadows as CDictCan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+  class C a => D a b+and [G] D a b, [G] C a in the inert set.  Now we insert+[D] b ~ c.  We want to kick out a derived shadow for [D] D a b,+so we can rewrite it with the new constraint, and perhaps get+instance reduction or other consequences.++BUT we do not want to kick out a *non-canonical* (D a b). If we+did, we would do this:+  - rewrite it to [D] D a c, with pend_sc = True+  - use expandSuperClasses to add C a+  - go round again, which solves C a from the givens+This loop goes on for ever and triggers the simpl_loop limit.++Solution: kick out the CDictCan which will have pend_sc = False,+because we've already added its superclasses.  So we won't re-add+them.  If we forget the pend_sc flag, our cunning scheme for avoiding+generating superclasses repeatedly will fail.++See #11379 for a case of this.++Note [Do not do improvement for WOnly]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do improvement between two constraints (e.g. for injectivity+or functional dependencies) only if both are "improvable". And+we improve a constraint wrt the top-level instances only if+it is improvable.++Improvable:     [G] [WD] [D}+Not improvable: [W]++Reasons:++* It's less work: fewer pairs to compare++* Every [W] has a shadow [D] so nothing is lost++* Consider [WD] C Int b,  where 'b' is a skolem, and+    class C a b | a -> b+    instance C Int Bool+  We'll do a fundep on it and emit [D] b ~ Bool+  That will kick out constraint [WD] C Int b+  Then we'll split it to [W] C Int b (keep in inert)+                     and [D] C Int b (in work list)+  When processing the latter we'll rewrite it to+        [D] C Int Bool+  At that point it would be /stupid/ to interact it+  with the inert [W] C Int b in the inert set; after all,+  it's the very constraint from which the [D] C Int Bool+  was split!  We can avoid this by not doing improvement+  on [W] constraints. This came up in #12860.+-}++maybeEmitShadow :: InertCans -> Ct -> TcS Ct+-- See Note [The improvement story and derived shadows]+maybeEmitShadow ics ct+  | let ev = ctEvidence ct+  , CtWanted { ctev_pred = pred, ctev_loc = loc+             , ctev_nosh = WDeriv } <- ev+  , shouldSplitWD (inert_eqs ics) ct+  = do { traceTcS "Emit derived shadow" (ppr ct)+       ; let derived_ev = CtDerived { ctev_pred = pred+                                    , ctev_loc  = loc }+             shadow_ct = ct { cc_ev = derived_ev }+               -- Te shadow constraint keeps the canonical shape.+               -- This just saves work, but is sometimes important;+               -- see Note [Keep CDictCan shadows as CDictCan]+       ; emitWork [shadow_ct]++       ; let ev' = ev { ctev_nosh = WOnly }+             ct' = ct { cc_ev = ev' }+                 -- Record that it now has a shadow+                 -- This is /the/ place we set the flag to WOnly+       ; return ct' }++  | otherwise+  = return ct++shouldSplitWD :: InertEqs -> Ct -> Bool+-- Precondition: 'ct' is [WD], and is inert+-- True <=> we should split ct ito [W] and [D] because+--          the inert_eqs can make progress on the [D]+-- See Note [Splitting WD constraints]++shouldSplitWD inert_eqs (CFunEqCan { cc_tyargs = tys })+  = should_split_match_args inert_eqs tys+    -- We don't need to split if the tv is the RHS fsk++shouldSplitWD inert_eqs (CDictCan { cc_tyargs = tys })+  = should_split_match_args inert_eqs tys+    -- NB True: ignore coercions+    -- See Note [Splitting WD constraints]++shouldSplitWD inert_eqs (CTyEqCan { cc_tyvar = tv, cc_rhs = ty+                                  , cc_eq_rel = eq_rel })+  =  tv `elemDVarEnv` inert_eqs+  || anyRewritableTyVar False eq_rel (canRewriteTv inert_eqs) ty+  -- NB False: do not ignore casts and coercions+  -- See Note [Splitting WD constraints]++shouldSplitWD inert_eqs (CIrredCan { cc_ev = ev })+  = anyRewritableTyVar False (ctEvEqRel ev) (canRewriteTv inert_eqs) (ctEvPred ev)++shouldSplitWD _ _ = False   -- No point in splitting otherwise++should_split_match_args :: InertEqs -> [TcType] -> Bool+-- True if the inert_eqs can rewrite anything in the argument+-- types, ignoring casts and coercions+should_split_match_args inert_eqs tys+  = any (anyRewritableTyVar True NomEq (canRewriteTv inert_eqs)) tys+    -- NB True: ignore casts coercions+    -- See Note [Splitting WD constraints]++canRewriteTv :: InertEqs -> EqRel -> TyVar -> Bool+canRewriteTv inert_eqs eq_rel tv+  | Just (ct : _) <- lookupDVarEnv inert_eqs tv+  , CTyEqCan { cc_eq_rel = eq_rel1 } <- ct+  = eq_rel1 `eqCanRewrite` eq_rel+  | otherwise+  = False++isImprovable :: CtEvidence -> Bool+-- See Note [Do not do improvement for WOnly]+isImprovable (CtWanted { ctev_nosh = WOnly }) = False+isImprovable _                                = True+++{- *********************************************************************+*                                                                      *+                   Inert equalities+*                                                                      *+********************************************************************* -}++addTyEq :: InertEqs -> TcTyVar -> Ct -> InertEqs+addTyEq old_eqs tv ct+  = extendDVarEnv_C add_eq old_eqs tv [ct]+  where+    add_eq old_eqs _+      | isWantedCt ct+      , (eq1 : eqs) <- old_eqs+      = eq1 : ct : eqs+      | otherwise+      = ct : old_eqs++foldTyEqs :: (Ct -> b -> b) -> InertEqs -> b -> b+foldTyEqs k eqs z+  = foldDVarEnv (\cts z -> foldr k z cts) z eqs++findTyEqs :: InertCans -> TyVar -> EqualCtList+findTyEqs icans tv = lookupDVarEnv (inert_eqs icans) tv `orElse` []++delTyEq :: InertEqs -> TcTyVar -> TcType -> InertEqs+delTyEq m tv t = modifyDVarEnv (filter (not . isThisOne)) m tv+  where isThisOne (CTyEqCan { cc_rhs = t1 }) = eqType t t1+        isThisOne _                          = False++lookupInertTyVar :: InertEqs -> TcTyVar -> Maybe TcType+lookupInertTyVar ieqs tv+  = case lookupDVarEnv ieqs tv of+      Just (CTyEqCan { cc_rhs = rhs, cc_eq_rel = NomEq } : _ ) -> Just rhs+      _                                                        -> Nothing++lookupFlattenTyVar :: InertEqs -> TcTyVar -> TcType+-- See Note [lookupFlattenTyVar]+lookupFlattenTyVar ieqs ftv+  = lookupInertTyVar ieqs ftv `orElse` mkTyVarTy ftv++{- Note [lookupFlattenTyVar]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have an injective function F and+  inert_funeqs:   F t1 ~ fsk1+                  F t2 ~ fsk2+  inert_eqs:      fsk1 ~ fsk2++We never rewrite the RHS (cc_fsk) of a CFunEqCan.  But we /do/ want to+get the [D] t1 ~ t2 from the injectiveness of F.  So we look up the+cc_fsk of CFunEqCans in the inert_eqs when trying to find derived+equalities arising from injectivity.+-}+++{- *********************************************************************+*                                                                      *+                   Inert instances: inert_insts+*                                                                      *+********************************************************************* -}++addInertForAll :: QCInst -> TcS ()+-- Add a local Given instance, typically arising from a type signature+addInertForAll new_qci+  = updInertCans $ \ics ->+    ics { inert_insts = add_qci (inert_insts ics) }+  where+    add_qci :: [QCInst] -> [QCInst]+    -- See Note [Do not add duplicate quantified instances]+    add_qci qcis | any same_qci qcis = qcis+                 | otherwise         = new_qci : qcis++    same_qci old_qci = tcEqType (ctEvPred (qci_ev old_qci))+                                (ctEvPred (qci_ev new_qci))++{- Note [Do not add duplicate quantified instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#15244):++  f :: (C g, D g) => ....+  class S g => C g where ...+  class S g => D g where ...+  class (forall a. Eq a => Eq (g a)) => S g where ...++Then in f's RHS there are two identical quantified constraints+available, one via the superclasses of C and one via the superclasses+of D.  The two are identical, and it seems wrong to reject the program+because of that. But without doing duplicate-elimination we will have+two matching QCInsts when we try to solve constraints arising from f's+RHS.++The simplest thing is simply to eliminate duplicattes, which we do here.+-}++{- *********************************************************************+*                                                                      *+                  Adding an inert+*                                                                      *+************************************************************************++Note [Adding an equality to the InertCans]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When adding an equality to the inerts:++* Split [WD] into [W] and [D] if the inerts can rewrite the latter;+  done by maybeEmitShadow.++* Kick out any constraints that can be rewritten by the thing+  we are adding.  Done by kickOutRewritable.++* Note that unifying a:=ty, is like adding [G] a~ty; just use+  kickOutRewritable with Nominal, Given.  See kickOutAfterUnification.++Note [Kicking out CFunEqCan for fundeps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+   New:    [D] fmv1 ~ fmv2+   Inert:  [W] F alpha ~ fmv1+           [W] F beta  ~ fmv2++where F is injective. The new (derived) equality certainly can't+rewrite the inerts. But we *must* kick out the first one, to get:++   New:   [W] F alpha ~ fmv1+   Inert: [W] F beta ~ fmv2+          [D] fmv1 ~ fmv2++and now improvement will discover [D] alpha ~ beta. This is important;+eg in #9587.++So in kickOutRewritable we look at all the tyvars of the+CFunEqCan, including the fsk.+-}++addInertCan :: Ct -> TcS ()  -- Constraints *other than* equalities+-- Precondition: item /is/ canonical+-- See Note [Adding an equality to the InertCans]+addInertCan ct+  = do { traceTcS "insertInertCan {" $+         text "Trying to insert new inert item:" <+> ppr ct++       ; ics <- getInertCans+       ; ct  <- maybeEmitShadow ics ct+       ; ics <- maybeKickOut ics ct+       ; setInertCans (add_item ics ct)++       ; traceTcS "addInertCan }" $ empty }++maybeKickOut :: InertCans -> Ct -> TcS InertCans+-- For a CTyEqCan, kick out any inert that can be rewritten by the CTyEqCan+maybeKickOut ics ct+  | CTyEqCan { cc_tyvar = tv, cc_ev = ev, cc_eq_rel = eq_rel } <- ct+  = do { (_, ics') <- kickOutRewritable (ctEvFlavour ev, eq_rel) tv ics+       ; return ics' }+  | otherwise+  = return ics++add_item :: InertCans -> Ct -> InertCans+add_item ics item@(CFunEqCan { cc_fun = tc, cc_tyargs = tys })+  = ics { inert_funeqs = insertFunEq (inert_funeqs ics) tc tys item }++add_item ics item@(CTyEqCan { cc_tyvar = tv, cc_ev = ev })+  = ics { inert_eqs   = addTyEq (inert_eqs ics) tv item+        , inert_count = bumpUnsolvedCount ev (inert_count ics) }++add_item ics@(IC { inert_irreds = irreds, inert_count = count })+         item@(CIrredCan { cc_ev = ev, cc_insol = insoluble })+  = ics { inert_irreds = irreds `Bag.snocBag` item+        , inert_count  = if insoluble+                         then count  -- inert_count does not include insolubles+                         else bumpUnsolvedCount ev count }++add_item ics item@(CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })+  = ics { inert_dicts = addDict (inert_dicts ics) cls tys item+        , inert_count = bumpUnsolvedCount ev (inert_count ics) }++add_item _ item+  = pprPanic "upd_inert set: can't happen! Inserting " $+    ppr item   -- Can't be CNonCanonical, CHoleCan,+               -- because they only land in inert_irreds++bumpUnsolvedCount :: CtEvidence -> Int -> Int+bumpUnsolvedCount ev n | isWanted ev = n+1+                       | otherwise   = n+++-----------------------------------------+kickOutRewritable  :: CtFlavourRole  -- Flavour/role of the equality that+                                      -- is being added to the inert set+                    -> TcTyVar        -- The new equality is tv ~ ty+                    -> InertCans+                    -> TcS (Int, InertCans)+kickOutRewritable new_fr new_tv ics+  = do { let (kicked_out, ics') = kick_out_rewritable new_fr new_tv ics+             n_kicked = workListSize kicked_out++       ; unless (n_kicked == 0) $+         do { updWorkListTcS (appendWorkList kicked_out)+            ; csTraceTcS $+              hang (text "Kick out, tv =" <+> ppr new_tv)+                 2 (vcat [ text "n-kicked =" <+> int n_kicked+                         , text "kicked_out =" <+> ppr kicked_out+                         , text "Residual inerts =" <+> ppr ics' ]) }++       ; return (n_kicked, ics') }++kick_out_rewritable :: CtFlavourRole  -- Flavour/role of the equality that+                                      -- is being added to the inert set+                    -> TcTyVar        -- The new equality is tv ~ ty+                    -> InertCans+                    -> (WorkList, InertCans)+-- See Note [kickOutRewritable]+kick_out_rewritable new_fr new_tv+                    ics@(IC { inert_eqs      = tv_eqs+                            , inert_dicts    = dictmap+                            , inert_safehask = safehask+                            , inert_funeqs   = funeqmap+                            , inert_irreds   = irreds+                            , inert_insts    = old_insts+                            , inert_count    = n })+  | not (new_fr `eqMayRewriteFR` new_fr)+  = (emptyWorkList, ics)+        -- If new_fr can't rewrite itself, it can't rewrite+        -- anything else, so no need to kick out anything.+        -- (This is a common case: wanteds can't rewrite wanteds)+        -- Lemma (L2) in Note [Extending the inert equalities]++  | otherwise+  = (kicked_out, inert_cans_in)+  where+    inert_cans_in = IC { inert_eqs      = tv_eqs_in+                       , inert_dicts    = dicts_in+                       , inert_safehask = safehask   -- ??+                       , inert_funeqs   = feqs_in+                       , inert_irreds   = irs_in+                       , inert_insts    = insts_in+                       , inert_count    = n - workListWantedCount kicked_out }++    kicked_out :: WorkList+    -- NB: use extendWorkList to ensure that kicked-out equalities get priority+    -- See Note [Prioritise equality constraints] (Kick-out).+    -- The irreds may include non-canonical (hetero-kinded) equality+    -- constraints, which perhaps may have become soluble after new_tv+    -- is substituted; ditto the dictionaries, which may include (a~b)+    -- or (a~~b) constraints.+    kicked_out = foldrBag extendWorkListCt+                          (emptyWorkList { wl_eqs    = tv_eqs_out+                                         , wl_funeqs = feqs_out })+                          ((dicts_out `andCts` irs_out)+                            `extendCtsList` insts_out)++    (tv_eqs_out, tv_eqs_in) = foldDVarEnv kick_out_eqs ([], emptyDVarEnv) tv_eqs+    (feqs_out,   feqs_in)   = partitionFunEqs  kick_out_ct funeqmap+           -- See Note [Kicking out CFunEqCan for fundeps]+    (dicts_out,  dicts_in)  = partitionDicts   kick_out_ct dictmap+    (irs_out,    irs_in)    = partitionBag     kick_out_ct irreds+      -- Kick out even insolubles: See Note [Rewrite insolubles]+      -- Of course we must kick out irreducibles like (c a), in case+      -- we can rewrite 'c' to something more useful++    -- Kick-out for inert instances+    -- See Note [Quantified constraints] in TcCanonical+    insts_out :: [Ct]+    insts_in  :: [QCInst]+    (insts_out, insts_in)+       | fr_may_rewrite (Given, NomEq)  -- All the insts are Givens+       = partitionWith kick_out_qci old_insts+       | otherwise+       = ([], old_insts)+    kick_out_qci qci+      | let ev = qci_ev qci+      , fr_can_rewrite_ty NomEq (ctEvPred (qci_ev qci))+      = Left (mkNonCanonical ev)+      | otherwise+      = Right qci++    (_, new_role) = new_fr++    fr_can_rewrite_ty :: EqRel -> Type -> Bool+    fr_can_rewrite_ty role ty = anyRewritableTyVar False role+                                                   fr_can_rewrite_tv ty+    fr_can_rewrite_tv :: EqRel -> TyVar -> Bool+    fr_can_rewrite_tv role tv = new_role `eqCanRewrite` role+                             && tv == new_tv++    fr_may_rewrite :: CtFlavourRole -> Bool+    fr_may_rewrite fs = new_fr `eqMayRewriteFR` fs+        -- Can the new item rewrite the inert item?++    kick_out_ct :: Ct -> Bool+    -- Kick it out if the new CTyEqCan can rewrite the inert one+    -- See Note [kickOutRewritable]+    kick_out_ct ct | let fs@(_,role) = ctFlavourRole ct+                   = fr_may_rewrite fs+                   && fr_can_rewrite_ty role (ctPred ct)+                  -- False: ignore casts and coercions+                  -- NB: this includes the fsk of a CFunEqCan.  It can't+                  --     actually be rewritten, but we need to kick it out+                  --     so we get to take advantage of injectivity+                  -- See Note [Kicking out CFunEqCan for fundeps]++    kick_out_eqs :: EqualCtList -> ([Ct], DTyVarEnv EqualCtList)+                 -> ([Ct], DTyVarEnv EqualCtList)+    kick_out_eqs eqs (acc_out, acc_in)+      = (eqs_out ++ acc_out, case eqs_in of+                               []      -> acc_in+                               (eq1:_) -> extendDVarEnv acc_in (cc_tyvar eq1) eqs_in)+      where+        (eqs_out, eqs_in) = partition kick_out_eq eqs++    -- Implements criteria K1-K3 in Note [Extending the inert equalities]+    kick_out_eq (CTyEqCan { cc_tyvar = tv, cc_rhs = rhs_ty+                          , cc_ev = ev, cc_eq_rel = eq_rel })+      | not (fr_may_rewrite fs)+      = False  -- Keep it in the inert set if the new thing can't rewrite it++      -- Below here (fr_may_rewrite fs) is True+      | tv == new_tv              = True        -- (K1)+      | kick_out_for_inertness    = True+      | kick_out_for_completeness = True+      | otherwise                 = False++      where+        fs = (ctEvFlavour ev, eq_rel)+        kick_out_for_inertness+          =        (fs `eqMayRewriteFR` fs)       -- (K2a)+            && not (fs `eqMayRewriteFR` new_fr)   -- (K2b)+            && fr_can_rewrite_ty eq_rel rhs_ty    -- (K2d)+            -- (K2c) is guaranteed by the first guard of keep_eq++        kick_out_for_completeness+          = case eq_rel of+              NomEq  -> rhs_ty `eqType` mkTyVarTy new_tv+              ReprEq -> isTyVarHead new_tv rhs_ty++    kick_out_eq ct = pprPanic "keep_eq" (ppr ct)++kickOutAfterUnification :: TcTyVar -> TcS Int+kickOutAfterUnification new_tv+  = do { ics <- getInertCans+       ; (n_kicked, ics2) <- kickOutRewritable (Given,NomEq)+                                                 new_tv ics+                     -- Given because the tv := xi is given; NomEq because+                     -- only nominal equalities are solved by unification++       ; setInertCans ics2+       ; return n_kicked }++{- Note [kickOutRewritable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [inert_eqs: the inert equalities].++When we add a new inert equality (a ~N ty) to the inert set,+we must kick out any inert items that could be rewritten by the+new equality, to maintain the inert-set invariants.++  - We want to kick out an existing inert constraint if+    a) the new constraint can rewrite the inert one+    b) 'a' is free in the inert constraint (so that it *will*)+       rewrite it if we kick it out.++    For (b) we use tyCoVarsOfCt, which returns the type variables /and+    the kind variables/ that are directly visible in the type. Hence+    we will have exposed all the rewriting we care about to make the+    most precise kinds visible for matching classes etc. No need to+    kick out constraints that mention type variables whose kinds+    contain this variable!++  - A Derived equality can kick out [D] constraints in inert_eqs,+    inert_dicts, inert_irreds etc.++  - We don't kick out constraints from inert_solved_dicts, and+    inert_solved_funeqs optimistically. But when we lookup we have to+    take the substitution into account+++Note [Rewrite insolubles]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have an insoluble alpha ~ [alpha], which is insoluble+because an occurs check.  And then we unify alpha := [Int].  Then we+really want to rewrite the insoluble to [Int] ~ [[Int]].  Now it can+be decomposed.  Otherwise we end up with a "Can't match [Int] ~+[[Int]]" which is true, but a bit confusing because the outer type+constructors match.++Similarly, if we have a CHoleCan, we'd like to rewrite it with any+Givens, to give as informative an error messasge as possible+(#12468, #11325).++Hence:+ * In the main simlifier loops in TcSimplify (solveWanteds,+   simpl_loop), we feed the insolubles in solveSimpleWanteds,+   so that they get rewritten (albeit not solved).++ * We kick insolubles out of the inert set, if they can be+   rewritten (see TcSMonad.kick_out_rewritable)++ * We rewrite those insolubles in TcCanonical.+   See Note [Make sure that insolubles are fully rewritten]+-}++++--------------+addInertSafehask :: InertCans -> Ct -> InertCans+addInertSafehask ics item@(CDictCan { cc_class = cls, cc_tyargs = tys })+  = ics { inert_safehask = addDict (inert_dicts ics) cls tys item }++addInertSafehask _ item+  = pprPanic "addInertSafehask: can't happen! Inserting " $ ppr item++insertSafeOverlapFailureTcS :: Ct -> TcS ()+-- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify+insertSafeOverlapFailureTcS item+  = updInertCans (\ics -> addInertSafehask ics item)++getSafeOverlapFailures :: TcS Cts+-- See Note [Safe Haskell Overlapping Instances Implementation] in TcSimplify+getSafeOverlapFailures+ = do { IC { inert_safehask = safehask } <- getInertCans+      ; return $ foldDicts consCts safehask emptyCts }++--------------+addSolvedDict :: CtEvidence -> Class -> [Type] -> TcS ()+-- Add a new item in the solved set of the monad+-- See Note [Solved dictionaries]+addSolvedDict item cls tys+  | isIPPred (ctEvPred item)    -- Never cache "solved" implicit parameters (not sure why!)+  = return ()+  | otherwise+  = do { traceTcS "updSolvedSetTcs:" $ ppr item+       ; updInertTcS $ \ ics ->+             ics { inert_solved_dicts = addDict (inert_solved_dicts ics) cls tys item } }++getSolvedDicts :: TcS (DictMap CtEvidence)+getSolvedDicts = do { ics <- getTcSInerts; return (inert_solved_dicts ics) }++setSolvedDicts :: DictMap CtEvidence -> TcS ()+setSolvedDicts solved_dicts+  = updInertTcS $ \ ics ->+    ics { inert_solved_dicts = solved_dicts }+++{- *********************************************************************+*                                                                      *+                  Other inert-set operations+*                                                                      *+********************************************************************* -}++updInertTcS :: (InertSet -> InertSet) -> TcS ()+-- Modify the inert set with the supplied function+updInertTcS upd_fn+  = do { is_var <- getTcSInertsRef+       ; wrapTcS (do { curr_inert <- TcM.readTcRef is_var+                     ; TcM.writeTcRef is_var (upd_fn curr_inert) }) }++getInertCans :: TcS InertCans+getInertCans = do { inerts <- getTcSInerts; return (inert_cans inerts) }++setInertCans :: InertCans -> TcS ()+setInertCans ics = updInertTcS $ \ inerts -> inerts { inert_cans = ics }++updRetInertCans :: (InertCans -> (a, InertCans)) -> TcS a+-- Modify the inert set with the supplied function+updRetInertCans upd_fn+  = do { is_var <- getTcSInertsRef+       ; wrapTcS (do { inerts <- TcM.readTcRef is_var+                     ; let (res, cans') = upd_fn (inert_cans inerts)+                     ; TcM.writeTcRef is_var (inerts { inert_cans = cans' })+                     ; return res }) }++updInertCans :: (InertCans -> InertCans) -> TcS ()+-- Modify the inert set with the supplied function+updInertCans upd_fn+  = updInertTcS $ \ inerts -> inerts { inert_cans = upd_fn (inert_cans inerts) }++updInertDicts :: (DictMap Ct -> DictMap Ct) -> TcS ()+-- Modify the inert set with the supplied function+updInertDicts upd_fn+  = updInertCans $ \ ics -> ics { inert_dicts = upd_fn (inert_dicts ics) }++updInertSafehask :: (DictMap Ct -> DictMap Ct) -> TcS ()+-- Modify the inert set with the supplied function+updInertSafehask upd_fn+  = updInertCans $ \ ics -> ics { inert_safehask = upd_fn (inert_safehask ics) }++updInertFunEqs :: (FunEqMap Ct -> FunEqMap Ct) -> TcS ()+-- Modify the inert set with the supplied function+updInertFunEqs upd_fn+  = updInertCans $ \ ics -> ics { inert_funeqs = upd_fn (inert_funeqs ics) }++updInertIrreds :: (Cts -> Cts) -> TcS ()+-- Modify the inert set with the supplied function+updInertIrreds upd_fn+  = updInertCans $ \ ics -> ics { inert_irreds = upd_fn (inert_irreds ics) }++getInertEqs :: TcS (DTyVarEnv EqualCtList)+getInertEqs = do { inert <- getInertCans; return (inert_eqs inert) }++getInertInsols :: TcS Cts+-- Returns insoluble equality constraints+-- specifically including Givens+getInertInsols = do { inert <- getInertCans+                    ; return (filterBag insolubleEqCt (inert_irreds inert)) }++getInertGivens :: TcS [Ct]+-- Returns the Given constraints in the inert set,+-- with type functions *not* unflattened+getInertGivens+  = do { inerts <- getInertCans+       ; let all_cts = foldDicts (:) (inert_dicts inerts)+                     $ foldFunEqs (:) (inert_funeqs inerts)+                     $ concat (dVarEnvElts (inert_eqs inerts))+       ; return (filter isGivenCt all_cts) }++getPendingGivenScs :: TcS [Ct]+-- Find all inert Given dictionaries, or quantified constraints,+--     whose cc_pend_sc flag is True+--     and that belong to the current level+-- Set their cc_pend_sc flag to False in the inert set, and return that Ct+getPendingGivenScs = do { lvl <- getTcLevel+                        ; updRetInertCans (get_sc_pending lvl) }++get_sc_pending :: TcLevel -> InertCans -> ([Ct], InertCans)+get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })+  = ASSERT2( all isGivenCt sc_pending, ppr sc_pending )+       -- When getPendingScDics is called,+       -- there are never any Wanteds in the inert set+    (sc_pending, ic { inert_dicts = dicts', inert_insts = insts' })+  where+    sc_pending = sc_pend_insts ++ sc_pend_dicts++    sc_pend_dicts = foldDicts get_pending dicts []+    dicts' = foldr add dicts sc_pend_dicts++    (sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts++    get_pending :: Ct -> [Ct] -> [Ct]  -- Get dicts with cc_pend_sc = True+                                       -- but flipping the flag+    get_pending dict dicts+        | Just dict' <- isPendingScDict dict+        , belongs_to_this_level (ctEvidence dict)+        = dict' : dicts+        | otherwise+        = dicts++    add :: Ct -> DictMap Ct -> DictMap Ct+    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts+        = addDict dicts cls tys ct+    add ct _ = pprPanic "getPendingScDicts" (ppr ct)++    get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)+    get_pending_inst cts qci@(QCI { qci_ev = ev })+       | Just qci' <- isPendingScInst qci+       , belongs_to_this_level ev+       = (CQuantCan qci' : cts, qci')+       | otherwise+       = (cts, qci)++    belongs_to_this_level ev = ctLocLevel (ctEvLoc ev) == this_lvl+    -- We only want Givens from this level; see (3a) in+    -- Note [The superclass story] in TcCanonical++getUnsolvedInerts :: TcS ( Bag Implication+                         , Cts     -- Tyvar eqs: a ~ ty+                         , Cts     -- Fun eqs:   F a ~ ty+                         , Cts )   -- All others+-- Return all the unsolved [Wanted] or [Derived] constraints+--+-- Post-condition: the returned simple constraints are all fully zonked+--                     (because they come from the inert set)+--                 the unsolved implics may not be+getUnsolvedInerts+ = do { IC { inert_eqs    = tv_eqs+           , inert_funeqs = fun_eqs+           , inert_irreds = irreds+           , inert_dicts  = idicts+           } <- getInertCans++      ; let unsolved_tv_eqs  = foldTyEqs add_if_unsolved tv_eqs emptyCts+            unsolved_fun_eqs = foldFunEqs add_if_wanted fun_eqs emptyCts+            unsolved_irreds  = Bag.filterBag is_unsolved irreds+            unsolved_dicts   = foldDicts add_if_unsolved idicts emptyCts+            unsolved_others  = unsolved_irreds `unionBags` unsolved_dicts++      ; implics <- getWorkListImplics++      ; traceTcS "getUnsolvedInerts" $+        vcat [ text " tv eqs =" <+> ppr unsolved_tv_eqs+             , text "fun eqs =" <+> ppr unsolved_fun_eqs+             , text "others =" <+> ppr unsolved_others+             , text "implics =" <+> ppr implics ]++      ; return ( implics, unsolved_tv_eqs, unsolved_fun_eqs, unsolved_others) }+  where+    add_if_unsolved :: Ct -> Cts -> Cts+    add_if_unsolved ct cts | is_unsolved ct = ct `consCts` cts+                           | otherwise      = cts++    is_unsolved ct = not (isGivenCt ct)   -- Wanted or Derived++    -- For CFunEqCans we ignore the Derived ones, and keep+    -- only the Wanteds for flattening.  The Derived ones+    -- share a unification variable with the corresponding+    -- Wanted, so we definitely don't want to participate+    -- in unflattening+    -- See Note [Type family equations]+    add_if_wanted ct cts | isWantedCt ct = ct `consCts` cts+                         | otherwise     = cts++isInInertEqs :: DTyVarEnv EqualCtList -> TcTyVar -> TcType -> Bool+-- True if (a ~N ty) is in the inert set, in either Given or Wanted+isInInertEqs eqs tv rhs+  = case lookupDVarEnv eqs tv of+      Nothing  -> False+      Just cts -> any (same_pred rhs) cts+  where+    same_pred rhs ct+      | CTyEqCan { cc_rhs = rhs2, cc_eq_rel = eq_rel } <- ct+      , NomEq <- eq_rel+      , rhs `eqType` rhs2 = True+      | otherwise         = False++getNoGivenEqs :: TcLevel          -- TcLevel of this implication+               -> [TcTyVar]       -- Skolems of this implication+               -> TcS ( Bool      -- True <=> definitely no residual given equalities+                      , Cts )     -- Insoluble equalities arising from givens+-- See Note [When does an implication have given equalities?]+getNoGivenEqs tclvl skol_tvs+  = do { inerts@(IC { inert_eqs = ieqs, inert_irreds = irreds })+              <- getInertCans+       ; let has_given_eqs = foldrBag ((||) . ct_given_here) False irreds+                          || anyDVarEnv eqs_given_here ieqs+             insols = filterBag insolubleEqCt irreds+                      -- Specifically includes ones that originated in some+                      -- outer context but were refined to an insoluble by+                      -- a local equality; so do /not/ add ct_given_here.++       ; traceTcS "getNoGivenEqs" $+         vcat [ if has_given_eqs then text "May have given equalities"+                                 else text "No given equalities"+              , text "Skols:" <+> ppr skol_tvs+              , text "Inerts:" <+> ppr inerts+              , text "Insols:" <+> ppr insols]+       ; return (not has_given_eqs, insols) }+  where+    eqs_given_here :: EqualCtList -> Bool+    eqs_given_here [ct@(CTyEqCan { cc_tyvar = tv })]+                              -- Givens are always a sigleton+      = not (skolem_bound_here tv) && ct_given_here ct+    eqs_given_here _ = False++    ct_given_here :: Ct -> Bool+    -- True for a Given bound by the current implication,+    -- i.e. the current level+    ct_given_here ct =  isGiven ev+                     && tclvl == ctLocLevel (ctEvLoc ev)+        where+          ev = ctEvidence ct++    skol_tv_set = mkVarSet skol_tvs+    skolem_bound_here tv -- See Note [Let-bound skolems]+      = case tcTyVarDetails tv of+          SkolemTv {} -> tv `elemVarSet` skol_tv_set+          _           -> False++-- | Returns Given constraints that might,+-- potentially, match the given pred. This is used when checking to see if a+-- Given might overlap with an instance. See Note [Instance and Given overlap]+-- in TcInteract.+matchableGivens :: CtLoc -> PredType -> InertSet -> Cts+matchableGivens loc_w pred_w (IS { inert_cans = inert_cans })+  = filterBag matchable_given all_relevant_givens+  where+    -- just look in class constraints and irreds. matchableGivens does get called+    -- for ~R constraints, but we don't need to look through equalities, because+    -- canonical equalities are used for rewriting. We'll only get caught by+    -- non-canonical -- that is, irreducible -- equalities.+    all_relevant_givens :: Cts+    all_relevant_givens+      | Just (clas, _) <- getClassPredTys_maybe pred_w+      = findDictsByClass (inert_dicts inert_cans) clas+        `unionBags` inert_irreds inert_cans+      | otherwise+      = inert_irreds inert_cans++    matchable_given :: Ct -> Bool+    matchable_given ct+      | CtGiven { ctev_loc = loc_g, ctev_pred = pred_g } <- ctEvidence ct+      = mightMatchLater pred_g loc_g pred_w loc_w++      | otherwise+      = False++mightMatchLater :: TcPredType -> CtLoc -> TcPredType -> CtLoc -> Bool+mightMatchLater given_pred given_loc wanted_pred wanted_loc+  =  not (prohibitedSuperClassSolve given_loc wanted_loc)+  && isJust (tcUnifyTys bind_meta_tv [given_pred] [wanted_pred])+  where+    bind_meta_tv :: TcTyVar -> BindFlag+    -- Any meta tyvar may be unified later, so we treat it as+    -- bindable when unifying with givens. That ensures that we+    -- conservatively assume that a meta tyvar might get unified with+    -- something that matches the 'given', until demonstrated+    -- otherwise.  More info in Note [Instance and Given overlap]+    -- in TcInteract+    bind_meta_tv tv | isMetaTyVar tv+                    , not (isFskTyVar tv) = BindMe+                    | otherwise           = Skolem++prohibitedSuperClassSolve :: CtLoc -> CtLoc -> Bool+-- See Note [Solving superclass constraints] in TcInstDcls+prohibitedSuperClassSolve from_loc solve_loc+  | GivenOrigin (InstSC given_size) <- ctLocOrigin from_loc+  , ScOrigin wanted_size <- ctLocOrigin solve_loc+  = given_size >= wanted_size+  | otherwise+  = False++{- Note [Unsolved Derived equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In getUnsolvedInerts, we return a derived equality from the inert_eqs+because it is a candidate for floating out of this implication.  We+only float equalities with a meta-tyvar on the left, so we only pull+those out here.++Note [When does an implication have given equalities?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider an implication+   beta => alpha ~ Int+where beta is a unification variable that has already been unified+to () in an outer scope.  Then we can float the (alpha ~ Int) out+just fine. So when deciding whether the givens contain an equality,+we should canonicalise first, rather than just looking at the original+givens (#8644).++So we simply look at the inert, canonical Givens and see if there are+any equalities among them, the calculation of has_given_eqs.  There+are some wrinkles:++ * We must know which ones are bound in *this* implication and which+   are bound further out.  We can find that out from the TcLevel+   of the Given, which is itself recorded in the tcl_tclvl field+   of the TcLclEnv stored in the Given (ev_given_here).++   What about interactions between inner and outer givens?+      - Outer given is rewritten by an inner given, then there must+        have been an inner given equality, hence the “given-eq” flag+        will be true anyway.++      - Inner given rewritten by outer, retains its level (ie. The inner one)++ * We must take account of *potential* equalities, like the one above:+      beta => ...blah...+   If we still don't know what beta is, we conservatively treat it as potentially+   becoming an equality. Hence including 'irreds' in the calculation or has_given_eqs.++ * When flattening givens, we generate Given equalities like+     <F [a]> : F [a] ~ f,+   with Refl evidence, and we *don't* want those to count as an equality+   in the givens!  After all, the entire flattening business is just an+   internal matter, and the evidence does not mention any of the 'givens'+   of this implication.  So we do not treat inert_funeqs as a 'given equality'.++ * See Note [Let-bound skolems] for another wrinkle++ * We do *not* need to worry about representational equalities, because+   these do not affect the ability to float constraints.++Note [Let-bound skolems]+~~~~~~~~~~~~~~~~~~~~~~~~+If   * the inert set contains a canonical Given CTyEqCan (a ~ ty)+and  * 'a' is a skolem bound in this very implication,++then:+a) The Given is pretty much a let-binding, like+      f :: (a ~ b->c) => a -> a+   Here the equality constraint is like saying+      let a = b->c in ...+   It is not adding any new, local equality  information,+   and hence can be ignored by has_given_eqs++b) 'a' will have been completely substituted out in the inert set,+   so we can safely discard it.  Notably, it doesn't need to be+   returned as part of 'fsks'++For an example, see #9211.++See also TcUnify Note [Deeper level on the left] for how we ensure+that the right variable is on the left of the equality when both are+tyvars.++You might wonder whether the skokem really needs to be bound "in the+very same implication" as the equuality constraint.+(c.f. #15009) Consider this:++  data S a where+    MkS :: (a ~ Int) => S a++  g :: forall a. S a -> a -> blah+  g x y = let h = \z. ( z :: Int+                      , case x of+                           MkS -> [y,z])+          in ...++From the type signature for `g`, we get `y::a` .  Then when when we+encounter the `\z`, we'll assign `z :: alpha[1]`, say.  Next, from the+body of the lambda we'll get++  [W] alpha[1] ~ Int                             -- From z::Int+  [W] forall[2]. (a ~ Int) => [W] alpha[1] ~ a   -- From [y,z]++Now, suppose we decide to float `alpha ~ a` out of the implication+and then unify `alpha := a`.  Now we are stuck!  But if treat+`alpha ~ Int` first, and unify `alpha := Int`, all is fine.+But we absolutely cannot float that equality or we will get stuck.+-}++removeInertCts :: [Ct] -> InertCans -> InertCans+-- ^ Remove inert constraints from the 'InertCans', for use when a+-- typechecker plugin wishes to discard a given.+removeInertCts cts icans = foldl' removeInertCt icans cts++removeInertCt :: InertCans -> Ct -> InertCans+removeInertCt is ct =+  case ct of++    CDictCan  { cc_class = cl, cc_tyargs = tys } ->+      is { inert_dicts = delDict (inert_dicts is) cl tys }++    CFunEqCan { cc_fun  = tf,  cc_tyargs = tys } ->+      is { inert_funeqs = delFunEq (inert_funeqs is) tf tys }++    CTyEqCan  { cc_tyvar = x,  cc_rhs    = ty } ->+      is { inert_eqs    = delTyEq (inert_eqs is) x ty }++    CQuantCan {}     -> panic "removeInertCt: CQuantCan"+    CIrredCan {}     -> panic "removeInertCt: CIrredEvCan"+    CNonCanonical {} -> panic "removeInertCt: CNonCanonical"+    CHoleCan {}      -> panic "removeInertCt: CHoleCan"+++lookupFlatCache :: TyCon -> [Type] -> TcS (Maybe (TcCoercion, TcType, CtFlavour))+lookupFlatCache fam_tc tys+  = do { IS { inert_flat_cache = flat_cache+            , inert_cans = IC { inert_funeqs = inert_funeqs } } <- getTcSInerts+       ; return (firstJusts [lookup_inerts inert_funeqs,+                             lookup_flats flat_cache]) }+  where+    lookup_inerts inert_funeqs+      | Just (CFunEqCan { cc_ev = ctev, cc_fsk = fsk, cc_tyargs = xis })+           <- findFunEq inert_funeqs fam_tc tys+      , tys `eqTypes` xis   -- The lookup might find a near-match; see+                            -- Note [Use loose types in inert set]+      = Just (ctEvCoercion ctev, mkTyVarTy fsk, ctEvFlavour ctev)+      | otherwise = Nothing++    lookup_flats flat_cache = findExactFunEq flat_cache fam_tc tys+++lookupInInerts :: CtLoc -> TcPredType -> TcS (Maybe CtEvidence)+-- Is this exact predicate type cached in the solved or canonicals of the InertSet?+lookupInInerts loc pty+  | ClassPred cls tys <- classifyPredType pty+  = do { inerts <- getTcSInerts+       ; return (lookupSolvedDict inerts loc cls tys `mplus`+                 lookupInertDict (inert_cans inerts) loc cls tys) }+  | otherwise -- NB: No caching for equalities, IPs, holes, or errors+  = return Nothing++-- | Look up a dictionary inert. NB: the returned 'CtEvidence' might not+-- match the input exactly. Note [Use loose types in inert set].+lookupInertDict :: InertCans -> CtLoc -> Class -> [Type] -> Maybe CtEvidence+lookupInertDict (IC { inert_dicts = dicts }) loc cls tys+  = case findDict dicts loc cls tys of+      Just ct -> Just (ctEvidence ct)+      _       -> Nothing++-- | Look up a solved inert. NB: the returned 'CtEvidence' might not+-- match the input exactly. See Note [Use loose types in inert set].+lookupSolvedDict :: InertSet -> CtLoc -> Class -> [Type] -> Maybe CtEvidence+-- Returns just if exactly this predicate type exists in the solved.+lookupSolvedDict (IS { inert_solved_dicts = solved }) loc cls tys+  = case findDict solved loc cls tys of+      Just ev -> Just ev+      _       -> Nothing++{- *********************************************************************+*                                                                      *+                   Irreds+*                                                                      *+********************************************************************* -}++foldIrreds :: (Ct -> b -> b) -> Cts -> b -> b+foldIrreds k irreds z = foldrBag k z irreds+++{- *********************************************************************+*                                                                      *+                   TcAppMap+*                                                                      *+************************************************************************++Note [Use loose types in inert set]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Say we know (Eq (a |> c1)) and we need (Eq (a |> c2)). One is clearly+solvable from the other. So, we do lookup in the inert set using+loose types, which omit the kind-check.++We must be careful when using the result of a lookup because it may+not match the requested info exactly!++-}++type TcAppMap a = UniqDFM (ListMap LooseTypeMap a)+    -- Indexed by tycon then the arg types, using "loose" matching, where+    -- we don't require kind equality. This allows, for example, (a |> co)+    -- to match (a).+    -- See Note [Use loose types in inert set]+    -- Used for types and classes; hence UniqDFM+    -- See Note [foldTM determinism] for why we use UniqDFM here++isEmptyTcAppMap :: TcAppMap a -> Bool+isEmptyTcAppMap m = isNullUDFM m++emptyTcAppMap :: TcAppMap a+emptyTcAppMap = emptyUDFM++findTcApp :: TcAppMap a -> Unique -> [Type] -> Maybe a+findTcApp m u tys = do { tys_map <- lookupUDFM m u+                       ; lookupTM tys tys_map }++delTcApp :: TcAppMap a -> Unique -> [Type] -> TcAppMap a+delTcApp m cls tys = adjustUDFM (deleteTM tys) m cls++insertTcApp :: TcAppMap a -> Unique -> [Type] -> a -> TcAppMap a+insertTcApp m cls tys ct = alterUDFM alter_tm m cls+  where+    alter_tm mb_tm = Just (insertTM tys ct (mb_tm `orElse` emptyTM))++-- mapTcApp :: (a->b) -> TcAppMap a -> TcAppMap b+-- mapTcApp f = mapUDFM (mapTM f)++filterTcAppMap :: (Ct -> Bool) -> TcAppMap Ct -> TcAppMap Ct+filterTcAppMap f m+  = mapUDFM do_tm m+  where+    do_tm tm = foldTM insert_mb tm emptyTM+    insert_mb ct tm+       | f ct      = insertTM tys ct tm+       | otherwise = tm+       where+         tys = case ct of+                CFunEqCan { cc_tyargs = tys } -> tys+                CDictCan  { cc_tyargs = tys } -> tys+                _ -> pprPanic "filterTcAppMap" (ppr ct)++tcAppMapToBag :: TcAppMap a -> Bag a+tcAppMapToBag m = foldTcAppMap consBag m emptyBag++foldTcAppMap :: (a -> b -> b) -> TcAppMap a -> b -> b+foldTcAppMap k m z = foldUDFM (foldTM k) z m+++{- *********************************************************************+*                                                                      *+                   DictMap+*                                                                      *+********************************************************************* -}+++{- Note [Tuples hiding implicit parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f,g :: (?x::Int, C a) => a -> a+   f v = let ?x = 4 in g v++The call to 'g' gives rise to a Wanted constraint (?x::Int, C a).+We must /not/ solve this from the Given (?x::Int, C a), because of+the intervening binding for (?x::Int).  #14218.++We deal with this by arranging that we always fail when looking up a+tuple constraint that hides an implicit parameter. Not that this applies+  * both to the inert_dicts (lookupInertDict)+  * and to the solved_dicts (looukpSolvedDict)+An alternative would be not to extend these sets with such tuple+constraints, but it seemed more direct to deal with the lookup.++Note [Solving CallStack constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose f :: HasCallStack => blah.  Then++* Each call to 'f' gives rise to+    [W] s1 :: IP "callStack" CallStack    -- CtOrigin = OccurrenceOf f+  with a CtOrigin that says "OccurrenceOf f".+  Remember that HasCallStack is just shorthand for+    IP "callStack CallStack+  See Note [Overview of implicit CallStacks] in TcEvidence++* We cannonicalise such constraints, in TcCanonical.canClassNC, by+  pushing the call-site info on the stack, and changing the CtOrigin+  to record that has been done.+   Bind:  s1 = pushCallStack <site-info> s2+   [W] s2 :: IP "callStack" CallStack   -- CtOrigin = IPOccOrigin++* Then, and only then, we can solve the constraint from an enclosing+  Given.++So we must be careful /not/ to solve 's1' from the Givens.  Again,+we ensure this by arranging that findDict always misses when looking+up souch constraints.+-}++type DictMap a = TcAppMap a++emptyDictMap :: DictMap a+emptyDictMap = emptyTcAppMap++findDict :: DictMap a -> CtLoc -> Class -> [Type] -> Maybe a+findDict m loc cls tys+  | isCTupleClass cls+  , any hasIPPred tys   -- See Note [Tuples hiding implicit parameters]+  = Nothing++  | Just {} <- isCallStackPred cls tys+  , OccurrenceOf {} <- ctLocOrigin loc+  = Nothing             -- See Note [Solving CallStack constraints]++  | otherwise+  = findTcApp m (getUnique cls) tys++findDictsByClass :: DictMap a -> Class -> Bag a+findDictsByClass m cls+  | Just tm <- lookupUDFM m cls = foldTM consBag tm emptyBag+  | otherwise                  = emptyBag++delDict :: DictMap a -> Class -> [Type] -> DictMap a+delDict m cls tys = delTcApp m (getUnique cls) tys++addDict :: DictMap a -> Class -> [Type] -> a -> DictMap a+addDict m cls tys item = insertTcApp m (getUnique cls) tys item++addDictsByClass :: DictMap Ct -> Class -> Bag Ct -> DictMap Ct+addDictsByClass m cls items+  = addToUDFM m cls (foldrBag add emptyTM items)+  where+    add ct@(CDictCan { cc_tyargs = tys }) tm = insertTM tys ct tm+    add ct _ = pprPanic "addDictsByClass" (ppr ct)++filterDicts :: (Ct -> Bool) -> DictMap Ct -> DictMap Ct+filterDicts f m = filterTcAppMap f m++partitionDicts :: (Ct -> Bool) -> DictMap Ct -> (Bag Ct, DictMap Ct)+partitionDicts f m = foldTcAppMap k m (emptyBag, emptyDicts)+  where+    k ct (yeses, noes) | f ct      = (ct `consBag` yeses, noes)+                       | otherwise = (yeses,              add ct noes)+    add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) m+      = addDict m cls tys ct+    add ct _ = pprPanic "partitionDicts" (ppr ct)++dictsToBag :: DictMap a -> Bag a+dictsToBag = tcAppMapToBag++foldDicts :: (a -> b -> b) -> DictMap a -> b -> b+foldDicts = foldTcAppMap++emptyDicts :: DictMap a+emptyDicts = emptyTcAppMap+++{- *********************************************************************+*                                                                      *+                   FunEqMap+*                                                                      *+********************************************************************* -}++type FunEqMap a = TcAppMap a  -- A map whose key is a (TyCon, [Type]) pair++emptyFunEqs :: TcAppMap a+emptyFunEqs = emptyTcAppMap++findFunEq :: FunEqMap a -> TyCon -> [Type] -> Maybe a+findFunEq m tc tys = findTcApp m (getUnique tc) tys++funEqsToBag :: FunEqMap a -> Bag a+funEqsToBag m = foldTcAppMap consBag m emptyBag++findFunEqsByTyCon :: FunEqMap a -> TyCon -> [a]+-- Get inert function equation constraints that have the given tycon+-- in their head.  Not that the constraints remain in the inert set.+-- We use this to check for derived interactions with built-in type-function+-- constructors.+findFunEqsByTyCon m tc+  | Just tm <- lookupUDFM m tc = foldTM (:) tm []+  | otherwise                 = []++foldFunEqs :: (a -> b -> b) -> FunEqMap a -> b -> b+foldFunEqs = foldTcAppMap++-- mapFunEqs :: (a -> b) -> FunEqMap a -> FunEqMap b+-- mapFunEqs = mapTcApp++-- filterFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> FunEqMap Ct+-- filterFunEqs = filterTcAppMap++insertFunEq :: FunEqMap a -> TyCon -> [Type] -> a -> FunEqMap a+insertFunEq m tc tys val = insertTcApp m (getUnique tc) tys val++partitionFunEqs :: (Ct -> Bool) -> FunEqMap Ct -> ([Ct], FunEqMap Ct)+-- Optimise for the case where the predicate is false+-- partitionFunEqs is called only from kick-out, and kick-out usually+-- kicks out very few equalities, so we want to optimise for that case+partitionFunEqs f m = (yeses, foldr del m yeses)+  where+    yeses = foldTcAppMap k m []+    k ct yeses | f ct      = ct : yeses+               | otherwise = yeses+    del (CFunEqCan { cc_fun = tc, cc_tyargs = tys }) m+        = delFunEq m tc tys+    del ct _ = pprPanic "partitionFunEqs" (ppr ct)++delFunEq :: FunEqMap a -> TyCon -> [Type] -> FunEqMap a+delFunEq m tc tys = delTcApp m (getUnique tc) tys++------------------------------+type ExactFunEqMap a = UniqFM (ListMap TypeMap a)++emptyExactFunEqs :: ExactFunEqMap a+emptyExactFunEqs = emptyUFM++findExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> Maybe a+findExactFunEq m tc tys = do { tys_map <- lookupUFM m (getUnique tc)+                             ; lookupTM tys tys_map }++insertExactFunEq :: ExactFunEqMap a -> TyCon -> [Type] -> a -> ExactFunEqMap a+insertExactFunEq m tc tys val = alterUFM alter_tm m (getUnique tc)+  where alter_tm mb_tm = Just (insertTM tys val (mb_tm `orElse` emptyTM))++{-+************************************************************************+*                                                                      *+*              The TcS solver monad                                    *+*                                                                      *+************************************************************************++Note [The TcS monad]+~~~~~~~~~~~~~~~~~~~~+The TcS monad is a weak form of the main Tc monad++All you can do is+    * fail+    * allocate new variables+    * fill in evidence variables++Filling in a dictionary evidence variable means to create a binding+for it, so TcS carries a mutable location where the binding can be+added.  This is initialised from the innermost implication constraint.+-}++data TcSEnv+  = TcSEnv {+      tcs_ev_binds    :: EvBindsVar,++      tcs_unified     :: IORef Int,+         -- The number of unification variables we have filled+         -- The important thing is whether it is non-zero++      tcs_count     :: IORef Int, -- Global step count++      tcs_inerts    :: IORef InertSet, -- Current inert set++      -- The main work-list and the flattening worklist+      -- See Note [Work list priorities] and+      tcs_worklist  :: IORef WorkList -- Current worklist+    }++---------------+newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a }++instance Functor TcS where+  fmap f m = TcS $ fmap f . unTcS m++instance Applicative TcS where+  pure x = TcS (\_ -> return x)+  (<*>) = ap++instance Monad TcS where+#if !MIN_VERSION_base(4,13,0)+  fail = MonadFail.fail+#endif+  m >>= k   = TcS (\ebs -> unTcS m ebs >>= \r -> unTcS (k r) ebs)++instance MonadFail.MonadFail TcS where+  fail err  = TcS (\_ -> fail err)++instance MonadUnique TcS where+   getUniqueSupplyM = wrapTcS getUniqueSupplyM++instance HasModule TcS where+   getModule = wrapTcS getModule++instance MonadThings TcS where+   lookupThing n = wrapTcS (lookupThing n)++-- Basic functionality+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+wrapTcS :: TcM a -> TcS a+-- Do not export wrapTcS, because it promotes an arbitrary TcM to TcS,+-- and TcS is supposed to have limited functionality+wrapTcS = TcS . const -- a TcM action will not use the TcEvBinds++wrapErrTcS :: TcM a -> TcS a+-- The thing wrapped should just fail+-- There's no static check; it's up to the user+-- Having a variant for each error message is too painful+wrapErrTcS = wrapTcS++wrapWarnTcS :: TcM a -> TcS a+-- The thing wrapped should just add a warning, or no-op+-- There's no static check; it's up to the user+wrapWarnTcS = wrapTcS++failTcS, panicTcS  :: SDoc -> TcS a+warnTcS   :: WarningFlag -> SDoc -> TcS ()+addErrTcS :: SDoc -> TcS ()+failTcS      = wrapTcS . TcM.failWith+warnTcS flag = wrapTcS . TcM.addWarn (Reason flag)+addErrTcS    = wrapTcS . TcM.addErr+panicTcS doc = pprPanic "TcCanonical" doc++traceTcS :: String -> SDoc -> TcS ()+traceTcS herald doc = wrapTcS (TcM.traceTc herald doc)++runTcPluginTcS :: TcPluginM a -> TcS a+runTcPluginTcS m = wrapTcS . runTcPluginM m =<< getTcEvBindsVar++instance HasDynFlags TcS where+    getDynFlags = wrapTcS getDynFlags++getGlobalRdrEnvTcS :: TcS GlobalRdrEnv+getGlobalRdrEnvTcS = wrapTcS TcM.getGlobalRdrEnv++bumpStepCountTcS :: TcS ()+bumpStepCountTcS = TcS $ \env -> do { let ref = tcs_count env+                                    ; n <- TcM.readTcRef ref+                                    ; TcM.writeTcRef ref (n+1) }++csTraceTcS :: SDoc -> TcS ()+csTraceTcS doc+  = wrapTcS $ csTraceTcM (return doc)++traceFireTcS :: CtEvidence -> SDoc -> TcS ()+-- Dump a rule-firing trace+traceFireTcS ev doc+  = TcS $ \env -> csTraceTcM $+    do { n <- TcM.readTcRef (tcs_count env)+       ; tclvl <- TcM.getTcLevel+       ; return (hang (text "Step" <+> int n+                       <> brackets (text "l:" <> ppr tclvl <> comma <>+                                    text "d:" <> ppr (ctLocDepth (ctEvLoc ev)))+                       <+> doc <> colon)+                     4 (ppr ev)) }++csTraceTcM :: TcM SDoc -> TcM ()+-- Constraint-solver tracing, -ddump-cs-trace+csTraceTcM mk_doc+  = do { dflags <- getDynFlags+       ; when (  dopt Opt_D_dump_cs_trace dflags+                  || dopt Opt_D_dump_tc_trace dflags )+              ( do { msg <- mk_doc+                   ; TcM.traceTcRn Opt_D_dump_cs_trace msg }) }++runTcS :: TcS a                -- What to run+       -> TcM (a, EvBindMap)+runTcS tcs+  = do { ev_binds_var <- TcM.newTcEvBinds+       ; res <- runTcSWithEvBinds ev_binds_var tcs+       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var+       ; return (res, ev_binds) }++-- | This variant of 'runTcS' will keep solving, even when only Deriveds+-- are left around. It also doesn't return any evidence, as callers won't+-- need it.+runTcSDeriveds :: TcS a -> TcM a+runTcSDeriveds tcs+  = do { ev_binds_var <- TcM.newTcEvBinds+       ; runTcSWithEvBinds ev_binds_var tcs }++-- | This can deal only with equality constraints.+runTcSEqualities :: TcS a -> TcM a+runTcSEqualities thing_inside+  = do { ev_binds_var <- TcM.newNoTcEvBinds+       ; runTcSWithEvBinds ev_binds_var thing_inside }++runTcSWithEvBinds :: EvBindsVar+                  -> TcS a+                  -> TcM a+runTcSWithEvBinds ev_binds_var tcs+  = do { unified_var <- TcM.newTcRef 0+       ; step_count <- TcM.newTcRef 0+       ; inert_var <- TcM.newTcRef emptyInert+       ; wl_var <- TcM.newTcRef emptyWorkList+       ; let env = TcSEnv { tcs_ev_binds      = ev_binds_var+                          , tcs_unified       = unified_var+                          , tcs_count         = step_count+                          , tcs_inerts        = inert_var+                          , tcs_worklist      = wl_var }++             -- Run the computation+       ; res <- unTcS tcs env++       ; count <- TcM.readTcRef step_count+       ; when (count > 0) $+         csTraceTcM $ return (text "Constraint solver steps =" <+> int count)++       ; unflattenGivens inert_var++#if defined(DEBUG)+       ; ev_binds <- TcM.getTcEvBindsMap ev_binds_var+       ; checkForCyclicBinds ev_binds+#endif++       ; return res }++----------------------------+#if defined(DEBUG)+checkForCyclicBinds :: EvBindMap -> TcM ()+checkForCyclicBinds ev_binds_map+  | null cycles+  = return ()+  | null coercion_cycles+  = TcM.traceTc "Cycle in evidence binds" $ ppr cycles+  | otherwise+  = pprPanic "Cycle in coercion bindings" $ ppr coercion_cycles+  where+    ev_binds = evBindMapBinds ev_binds_map++    cycles :: [[EvBind]]+    cycles = [c | CyclicSCC c <- stronglyConnCompFromEdgedVerticesUniq edges]++    coercion_cycles = [c | c <- cycles, any is_co_bind c]+    is_co_bind (EvBind { eb_lhs = b }) = isEqPrimPred (varType b)++    edges :: [ Node EvVar EvBind ]+    edges = [ DigraphNode bind bndr (nonDetEltsUniqSet (evVarsOfTerm rhs))+            | bind@(EvBind { eb_lhs = bndr, eb_rhs = rhs}) <- bagToList ev_binds ]+            -- It's OK to use nonDetEltsUFM here as+            -- stronglyConnCompFromEdgedVertices is still deterministic even+            -- if the edges are in nondeterministic order as explained in+            -- Note [Deterministic SCC] in Digraph.+#endif++----------------------------+setEvBindsTcS :: EvBindsVar -> TcS a -> TcS a+setEvBindsTcS ref (TcS thing_inside)+ = TcS $ \ env -> thing_inside (env { tcs_ev_binds = ref })++nestImplicTcS :: EvBindsVar+              -> TcLevel -> TcS a+              -> TcS a+nestImplicTcS ref inner_tclvl (TcS thing_inside)+  = TcS $ \ TcSEnv { tcs_unified       = unified_var+                   , tcs_inerts        = old_inert_var+                   , tcs_count         = count+                   } ->+    do { inerts <- TcM.readTcRef old_inert_var+       ; let nest_inert = emptyInert+                            { inert_cans = inert_cans inerts+                            , inert_solved_dicts = inert_solved_dicts inerts }+                              -- See Note [Do not inherit the flat cache]+       ; new_inert_var <- TcM.newTcRef nest_inert+       ; new_wl_var    <- TcM.newTcRef emptyWorkList+       ; let nest_env = TcSEnv { tcs_ev_binds      = ref+                               , tcs_unified       = unified_var+                               , tcs_count         = count+                               , tcs_inerts        = new_inert_var+                               , tcs_worklist      = new_wl_var }+       ; res <- TcM.setTcLevel inner_tclvl $+                thing_inside nest_env++       ; unflattenGivens new_inert_var++#if defined(DEBUG)+       -- Perform a check that the thing_inside did not cause cycles+       ; ev_binds <- TcM.getTcEvBindsMap ref+       ; checkForCyclicBinds ev_binds+#endif+       ; return res }++{- Note [Do not inherit the flat cache]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not want to inherit the flat cache when processing nested+implications.  Consider+   a ~ F b, forall c. b~Int => blah+If we have F b ~ fsk in the flat-cache, and we push that into the+nested implication, we might miss that F b can be rewritten to F Int,+and hence perhpas solve it.  Moreover, the fsk from outside is+flattened out after solving the outer level, but and we don't+do that flattening recursively.+-}++nestTcS ::  TcS a -> TcS a+-- Use the current untouchables, augmenting the current+-- evidence bindings, and solved dictionaries+-- But have no effect on the InertCans, or on the inert_flat_cache+-- (we want to inherit the latter from processing the Givens)+nestTcS (TcS thing_inside)+  = TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) ->+    do { inerts <- TcM.readTcRef inerts_var+       ; new_inert_var <- TcM.newTcRef inerts+       ; new_wl_var    <- TcM.newTcRef emptyWorkList+       ; let nest_env = env { tcs_inerts   = new_inert_var+                            , tcs_worklist = new_wl_var }++       ; res <- thing_inside nest_env++       ; new_inerts <- TcM.readTcRef new_inert_var++       -- we want to propogate the safe haskell failures+       ; let old_ic = inert_cans inerts+             new_ic = inert_cans new_inerts+             nxt_ic = old_ic { inert_safehask = inert_safehask new_ic }++       ; TcM.writeTcRef inerts_var  -- See Note [Propagate the solved dictionaries]+                        (inerts { inert_solved_dicts = inert_solved_dicts new_inerts+                                , inert_cans = nxt_ic })++       ; return res }++checkTvConstraintsTcS :: SkolemInfo+                      -> [TcTyVar]        -- Skolems+                      -> TcS (result, Cts)+                      -> TcS result+-- Just like TcUnify.checkTvConstraints, but+--   - In the TcS monnad+--   - The thing-inside should not put things in the work-list+--     Instead, it returns the Wanted constraints it needs+--   - No 'givens', and no TcEvBinds; this is type-level constraints only+checkTvConstraintsTcS skol_info skol_tvs (TcS thing_inside)+  = TcS $ \ tcs_env ->+    do { let wl_panic  = pprPanic "TcSMonad.buildImplication" $+                         ppr skol_info $$ ppr skol_tvs+                         -- This panic checks that the thing-inside+                         -- does not emit any work-list constraints+             new_tcs_env = tcs_env { tcs_worklist = wl_panic }++       ; (new_tclvl, (res, wanteds)) <- TcM.pushTcLevelM $+                                        thing_inside new_tcs_env++       ; unless (null wanteds) $+         do { ev_binds_var <- TcM.newNoTcEvBinds+            ; imp <- newImplication+            ; let wc = emptyWC { wc_simple = wanteds }+                  imp' = imp { ic_tclvl  = new_tclvl+                             , ic_skols  = skol_tvs+                             , ic_wanted = wc+                             , ic_binds  = ev_binds_var+                             , ic_info   = skol_info }++           -- Add the implication to the work-list+           ; TcM.updTcRef (tcs_worklist tcs_env)+                          (extendWorkListImplic (unitBag imp')) }++      ; return res }++checkConstraintsTcS :: SkolemInfo+                    -> [TcTyVar]        -- Skolems+                    -> [EvVar]          -- Givens+                    -> TcS (result, Cts)+                    -> TcS (result, TcEvBinds)+-- Just like checkConstraintsTcS, but+--   - In the TcS monnad+--   - The thing-inside should not put things in the work-list+--     Instead, it returns the Wanted constraints it needs+--   - I did not bother to put in the fast-path for+--     empty-skols/empty-givens, or for empty-wanteds, because+--     this function is used only for "quantified constraints" in+--     with both tests are pretty much guaranteed to fail+checkConstraintsTcS skol_info skol_tvs given (TcS thing_inside)+  = TcS $ \ tcs_env ->+    do { let wl_panic  = pprPanic "TcSMonad.buildImplication" $+                         ppr skol_info $$ ppr skol_tvs+                         -- This panic checks that the thing-inside+                         -- does not emit any work-list constraints+             new_tcs_env = tcs_env { tcs_worklist = wl_panic }++       ; (new_tclvl, (res, wanteds)) <- TcM.pushTcLevelM $+                                        thing_inside new_tcs_env++       ; ev_binds_var <- TcM.newTcEvBinds+       ; imp <- newImplication+       ; let wc = emptyWC { wc_simple = wanteds }+             imp' = imp { ic_tclvl  = new_tclvl+                        , ic_skols  = skol_tvs+                        , ic_given  = given+                        , ic_wanted = wc+                        , ic_binds  = ev_binds_var+                        , ic_info   = skol_info }++           -- Add the implication to the work-list+       ; TcM.updTcRef (tcs_worklist tcs_env)+                      (extendWorkListImplic (unitBag imp'))++       ; return (res, TcEvBinds ev_binds_var) }++{-+Note [Propagate the solved dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's really quite important that nestTcS does not discard the solved+dictionaries from the thing_inside.+Consider+   Eq [a]+   forall b. empty =>  Eq [a]+We solve the simple (Eq [a]), under nestTcS, and then turn our attention to+the implications.  It's definitely fine to use the solved dictionaries on+the inner implications, and it can make a signficant performance difference+if you do so.+-}++-- Getters and setters of TcEnv fields+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++-- Getter of inerts and worklist+getTcSInertsRef :: TcS (IORef InertSet)+getTcSInertsRef = TcS (return . tcs_inerts)++getTcSWorkListRef :: TcS (IORef WorkList)+getTcSWorkListRef = TcS (return . tcs_worklist)++getTcSInerts :: TcS InertSet+getTcSInerts = getTcSInertsRef >>= readTcRef++setTcSInerts :: InertSet -> TcS ()+setTcSInerts ics = do { r <- getTcSInertsRef; writeTcRef r ics }++getWorkListImplics :: TcS (Bag Implication)+getWorkListImplics+  = do { wl_var <- getTcSWorkListRef+       ; wl_curr <- readTcRef wl_var+       ; return (wl_implics wl_curr) }++updWorkListTcS :: (WorkList -> WorkList) -> TcS ()+updWorkListTcS f+  = do { wl_var <- getTcSWorkListRef+       ; updTcRef wl_var f }++emitWorkNC :: [CtEvidence] -> TcS ()+emitWorkNC evs+  | null evs+  = return ()+  | otherwise+  = emitWork (map mkNonCanonical evs)++emitWork :: [Ct] -> TcS ()+emitWork cts+  = do { traceTcS "Emitting fresh work" (vcat (map ppr cts))+       ; updWorkListTcS (extendWorkListCts cts) }++newTcRef :: a -> TcS (TcRef a)+newTcRef x = wrapTcS (TcM.newTcRef x)++readTcRef :: TcRef a -> TcS a+readTcRef ref = wrapTcS (TcM.readTcRef ref)++writeTcRef :: TcRef a -> a -> TcS ()+writeTcRef ref val = wrapTcS (TcM.writeTcRef ref val)++updTcRef :: TcRef a -> (a->a) -> TcS ()+updTcRef ref upd_fn = wrapTcS (TcM.updTcRef ref upd_fn)++getTcEvBindsVar :: TcS EvBindsVar+getTcEvBindsVar = TcS (return . tcs_ev_binds)++getTcLevel :: TcS TcLevel+getTcLevel = wrapTcS TcM.getTcLevel++getTcEvTyCoVars :: EvBindsVar -> TcS TyCoVarSet+getTcEvTyCoVars ev_binds_var+  = wrapTcS $ TcM.getTcEvTyCoVars ev_binds_var++getTcEvBindsMap :: EvBindsVar -> TcS EvBindMap+getTcEvBindsMap ev_binds_var+  = wrapTcS $ TcM.getTcEvBindsMap ev_binds_var++setTcEvBindsMap :: EvBindsVar -> EvBindMap -> TcS ()+setTcEvBindsMap ev_binds_var binds+  = wrapTcS $ TcM.setTcEvBindsMap ev_binds_var binds++unifyTyVar :: TcTyVar -> TcType -> TcS ()+-- Unify a meta-tyvar with a type+-- We keep track of how many unifications have happened in tcs_unified,+--+-- We should never unify the same variable twice!+unifyTyVar tv ty+  = ASSERT2( isMetaTyVar tv, ppr tv )+    TcS $ \ env ->+    do { TcM.traceTc "unifyTyVar" (ppr tv <+> text ":=" <+> ppr ty)+       ; TcM.writeMetaTyVar tv ty+       ; TcM.updTcRef (tcs_unified env) (+1) }++reportUnifications :: TcS a -> TcS (Int, a)+reportUnifications (TcS thing_inside)+  = TcS $ \ env ->+    do { inner_unified <- TcM.newTcRef 0+       ; res <- thing_inside (env { tcs_unified = inner_unified })+       ; n_unifs <- TcM.readTcRef inner_unified+       ; TcM.updTcRef (tcs_unified env) (+ n_unifs)+       ; return (n_unifs, res) }++getDefaultInfo ::  TcS ([Type], (Bool, Bool))+getDefaultInfo = wrapTcS TcM.tcGetDefaultTys++-- Just get some environments needed for instance looking up and matching+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++getInstEnvs :: TcS InstEnvs+getInstEnvs = wrapTcS $ TcM.tcGetInstEnvs++getFamInstEnvs :: TcS (FamInstEnv, FamInstEnv)+getFamInstEnvs = wrapTcS $ FamInst.tcGetFamInstEnvs++getTopEnv :: TcS HscEnv+getTopEnv = wrapTcS $ TcM.getTopEnv++getGblEnv :: TcS TcGblEnv+getGblEnv = wrapTcS $ TcM.getGblEnv++getLclEnv :: TcS TcLclEnv+getLclEnv = wrapTcS $ TcM.getLclEnv++tcLookupClass :: Name -> TcS Class+tcLookupClass c = wrapTcS $ TcM.tcLookupClass c++tcLookupId :: Name -> TcS Id+tcLookupId n = wrapTcS $ TcM.tcLookupId n++-- Setting names as used (used in the deriving of Coercible evidence)+-- Too hackish to expose it to TcS? In that case somehow extract the used+-- constructors from the result of solveInteract+addUsedGREs :: [GlobalRdrElt] -> TcS ()+addUsedGREs gres = wrapTcS  $ TcM.addUsedGREs gres++addUsedGRE :: Bool -> GlobalRdrElt -> TcS ()+addUsedGRE warn_if_deprec gre = wrapTcS $ TcM.addUsedGRE warn_if_deprec gre+++-- Various smaller utilities [TODO, maybe will be absorbed in the instance matcher]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++checkWellStagedDFun :: CtLoc -> InstanceWhat -> PredType -> TcS ()+-- Check that we do not try to use an instance before it is available.  E.g.+--    instance Eq T where ...+--    f x = $( ... (\(p::T) -> p == p)... )+-- Here we can't use the equality function from the instance in the splice++checkWellStagedDFun loc what pred+  | TopLevInstance { iw_dfun_id = dfun_id } <- what+  , let bind_lvl = TcM.topIdLvl dfun_id+  , bind_lvl > impLevel+  = wrapTcS $ TcM.setCtLocM loc $+    do { use_stage <- TcM.getStage+       ; TcM.checkWellStaged pp_thing bind_lvl (thLevel use_stage) }++  | otherwise+  = return ()    -- Fast path for common case+  where+    pp_thing = text "instance for" <+> quotes (ppr pred)++pprEq :: TcType -> TcType -> SDoc+pprEq ty1 ty2 = pprParendType ty1 <+> char '~' <+> pprParendType ty2++isFilledMetaTyVar_maybe :: TcTyVar -> TcS (Maybe Type)+isFilledMetaTyVar_maybe tv = wrapTcS (TcM.isFilledMetaTyVar_maybe tv)++isFilledMetaTyVar :: TcTyVar -> TcS Bool+isFilledMetaTyVar tv = wrapTcS (TcM.isFilledMetaTyVar tv)++zonkTyCoVarsAndFV :: TcTyCoVarSet -> TcS TcTyCoVarSet+zonkTyCoVarsAndFV tvs = wrapTcS (TcM.zonkTyCoVarsAndFV tvs)++zonkTyCoVarsAndFVList :: [TcTyCoVar] -> TcS [TcTyCoVar]+zonkTyCoVarsAndFVList tvs = wrapTcS (TcM.zonkTyCoVarsAndFVList tvs)++zonkCo :: Coercion -> TcS Coercion+zonkCo = wrapTcS . TcM.zonkCo++zonkTcType :: TcType -> TcS TcType+zonkTcType ty = wrapTcS (TcM.zonkTcType ty)++zonkTcTypes :: [TcType] -> TcS [TcType]+zonkTcTypes tys = wrapTcS (TcM.zonkTcTypes tys)++zonkTcTyVar :: TcTyVar -> TcS TcType+zonkTcTyVar tv = wrapTcS (TcM.zonkTcTyVar tv)++zonkSimples :: Cts -> TcS Cts+zonkSimples cts = wrapTcS (TcM.zonkSimples cts)++zonkWC :: WantedConstraints -> TcS WantedConstraints+zonkWC wc = wrapTcS (TcM.zonkWC wc)++zonkTyCoVarKind :: TcTyCoVar -> TcS TcTyCoVar+zonkTyCoVarKind tv = wrapTcS (TcM.zonkTyCoVarKind tv)++{- *********************************************************************+*                                                                      *+*                Flatten skolems                                       *+*                                                                      *+********************************************************************* -}++newFlattenSkolem :: CtFlavour -> CtLoc+                 -> TyCon -> [TcType]                    -- F xis+                 -> TcS (CtEvidence, Coercion, TcTyVar)  -- [G/WD] x:: F xis ~ fsk+newFlattenSkolem flav loc tc xis+  = do { stuff@(ev, co, fsk) <- new_skolem+       ; let fsk_ty = mkTyVarTy fsk+       ; extendFlatCache tc xis (co, fsk_ty, ctEvFlavour ev)+       ; return stuff }+  where+    fam_ty = mkTyConApp tc xis++    new_skolem+      | Given <- flav+      = do { fsk <- wrapTcS (TcM.newFskTyVar fam_ty)++           -- Extend the inert_fsks list, for use by unflattenGivens+           ; updInertTcS $ \is -> is { inert_fsks = (fsk, fam_ty) : inert_fsks is }++           -- Construct the Refl evidence+           ; let pred = mkPrimEqPred fam_ty (mkTyVarTy fsk)+                 co   = mkNomReflCo fam_ty+           ; ev  <- newGivenEvVar loc (pred, evCoercion co)+           ; return (ev, co, fsk) }++      | otherwise  -- Generate a [WD] for both Wanted and Derived+                   -- See Note [No Derived CFunEqCans]+      = do { fmv <- wrapTcS (TcM.newFmvTyVar fam_ty)+           ; (ev, hole_co) <- newWantedEq loc Nominal fam_ty (mkTyVarTy fmv)+           ; return (ev, hole_co, fmv) }++----------------------------+unflattenGivens :: IORef InertSet -> TcM ()+-- Unflatten all the fsks created by flattening types in Given+-- constraints. We must be sure to do this, else we end up with+-- flatten-skolems buried in any residual Wanteds+--+-- NB: this is the /only/ way that a fsk (MetaDetails = FlatSkolTv)+--     is filled in. Nothing else does so.+--+-- It's here (rather than in TcFlatten) because the Right Places+-- to call it are in runTcSWithEvBinds/nestImplicTcS, where it+-- is nicely paired with the creation an empty inert_fsks list.+unflattenGivens inert_var+ = do { inerts <- TcM.readTcRef inert_var+       ; TcM.traceTc "unflattenGivens" (ppr (inert_fsks inerts))+       ; mapM_ flatten_one (inert_fsks inerts) }+  where+    flatten_one (fsk, ty) = TcM.writeMetaTyVar fsk ty++----------------------------+extendFlatCache :: TyCon -> [Type] -> (TcCoercion, TcType, CtFlavour) -> TcS ()+extendFlatCache tc xi_args stuff@(_, ty, fl)+  | isGivenOrWDeriv fl  -- Maintain the invariant that inert_flat_cache+                        -- only has [G] and [WD] CFunEqCans+  = do { dflags <- getDynFlags+       ; when (gopt Opt_FlatCache dflags) $+    do { traceTcS "extendFlatCache" (vcat [ ppr tc <+> ppr xi_args+                                          , ppr fl, ppr ty ])+            -- 'co' can be bottom, in the case of derived items+       ; updInertTcS $ \ is@(IS { inert_flat_cache = fc }) ->+            is { inert_flat_cache = insertExactFunEq fc tc xi_args stuff } } }++  | otherwise+  = return ()++----------------------------+unflattenFmv :: TcTyVar -> TcType -> TcS ()+-- Fill a flatten-meta-var, simply by unifying it.+-- This does NOT count as a unification in tcs_unified.+unflattenFmv tv ty+  = ASSERT2( isMetaTyVar tv, ppr tv )+    TcS $ \ _ ->+    do { TcM.traceTc "unflattenFmv" (ppr tv <+> text ":=" <+> ppr ty)+       ; TcM.writeMetaTyVar tv ty }++----------------------------+demoteUnfilledFmv :: TcTyVar -> TcS ()+-- If a flatten-meta-var is still un-filled,+-- turn it into an ordinary meta-var+demoteUnfilledFmv fmv+  = wrapTcS $ do { is_filled <- TcM.isFilledMetaTyVar fmv+                 ; unless is_filled $+                   do { tv_ty <- TcM.newFlexiTyVarTy (tyVarKind fmv)+                      ; TcM.writeMetaTyVar fmv tv_ty } }++-----------------------------+dischargeFunEq :: CtEvidence -> TcTyVar -> TcCoercion -> TcType -> TcS ()+-- (dischargeFunEq tv co ty)+--     Preconditions+--       - ev :: F tys ~ tv   is a CFunEqCan+--       - tv is a FlatMetaTv of FlatSkolTv+--       - co :: F tys ~ xi+--       - fmv/fsk `notElem` xi+--       - fmv not filled (for Wanteds)+--+-- Then for [W] or [WD], we actually fill in the fmv:+--      set fmv := xi,+--      set ev  := co+--      kick out any inert things that are now rewritable+--+-- For [D], we instead emit an equality that must ultimately hold+--      [D] xi ~ fmv+--      Does not evaluate 'co' if 'ev' is Derived+--+-- For [G], emit this equality+--     [G] (sym ev; co) :: fsk ~ xi++-- See TcFlatten Note [The flattening story],+-- especially "Ownership of fsk/fmv"+dischargeFunEq (CtGiven { ctev_evar = old_evar, ctev_loc = loc }) fsk co xi+  = do { new_ev <- newGivenEvVar loc ( new_pred, evCoercion new_co  )+       ; emitWorkNC [new_ev] }+  where+    new_pred = mkPrimEqPred (mkTyVarTy fsk) xi+    new_co   = mkTcSymCo (mkTcCoVarCo old_evar) `mkTcTransCo` co++dischargeFunEq ev@(CtWanted { ctev_dest = dest }) fmv co xi+  = ASSERT2( not (fmv `elemVarSet` tyCoVarsOfType xi), ppr ev $$ ppr fmv $$ ppr xi )+    do { setWantedEvTerm dest (evCoercion co)+       ; unflattenFmv fmv xi+       ; n_kicked <- kickOutAfterUnification fmv+       ; traceTcS "dischargeFmv" (ppr fmv <+> equals <+> ppr xi $$ pprKicked n_kicked) }++dischargeFunEq (CtDerived { ctev_loc = loc }) fmv _co xi+  = emitNewDerivedEq loc Nominal xi (mkTyVarTy fmv)+              -- FunEqs are always at Nominal role++pprKicked :: Int -> SDoc+pprKicked 0 = empty+pprKicked n = parens (int n <+> text "kicked out")++{- *********************************************************************+*                                                                      *+*                Instantiation etc.+*                                                                      *+********************************************************************* -}++-- Instantiations+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++instDFunType :: DFunId -> [DFunInstType] -> TcS ([TcType], TcThetaType)+instDFunType dfun_id inst_tys+  = wrapTcS $ TcM.instDFunType dfun_id inst_tys++newFlexiTcSTy :: Kind -> TcS TcType+newFlexiTcSTy knd = wrapTcS (TcM.newFlexiTyVarTy knd)++cloneMetaTyVar :: TcTyVar -> TcS TcTyVar+cloneMetaTyVar tv = wrapTcS (TcM.cloneMetaTyVar tv)++instFlexi :: [TKVar] -> TcS TCvSubst+instFlexi = instFlexiX emptyTCvSubst++instFlexiX :: TCvSubst -> [TKVar] -> TcS TCvSubst+instFlexiX subst tvs+  = wrapTcS (foldlM instFlexiHelper subst tvs)++instFlexiHelper :: TCvSubst -> TKVar -> TcM TCvSubst+instFlexiHelper subst tv+  = do { uniq <- TcM.newUnique+       ; details <- TcM.newMetaDetails TauTv+       ; let name = setNameUnique (tyVarName tv) uniq+             kind = substTyUnchecked subst (tyVarKind tv)+             ty'  = mkTyVarTy (mkTcTyVar name kind details)+       ; TcM.traceTc "instFlexi" (ppr ty')+       ; return (extendTvSubst subst tv ty') }++matchGlobalInst :: DynFlags+                -> Bool      -- True <=> caller is the short-cut solver+                             -- See Note [Shortcut solving: overlap]+                -> Class -> [Type] -> TcS TcM.ClsInstResult+matchGlobalInst dflags short_cut cls tys+  = wrapTcS (TcM.matchGlobalInst dflags short_cut cls tys)++tcInstSkolTyVarsX :: TCvSubst -> [TyVar] -> TcS (TCvSubst, [TcTyVar])+tcInstSkolTyVarsX subst tvs = wrapTcS $ TcM.tcInstSkolTyVarsX subst tvs++-- Creating and setting evidence variables and CtFlavors+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++data MaybeNew = Fresh CtEvidence | Cached EvExpr++isFresh :: MaybeNew -> Bool+isFresh (Fresh {})  = True+isFresh (Cached {}) = False++freshGoals :: [MaybeNew] -> [CtEvidence]+freshGoals mns = [ ctev | Fresh ctev <- mns ]++getEvExpr :: MaybeNew -> EvExpr+getEvExpr (Fresh ctev) = ctEvExpr ctev+getEvExpr (Cached evt) = evt++setEvBind :: EvBind -> TcS ()+setEvBind ev_bind+  = do { evb <- getTcEvBindsVar+       ; wrapTcS $ TcM.addTcEvBind evb ev_bind }++-- | Mark variables as used filling a coercion hole+useVars :: CoVarSet -> TcS ()+useVars co_vars+  = do { ev_binds_var <- getTcEvBindsVar+       ; let ref = ebv_tcvs ev_binds_var+       ; wrapTcS $+         do { tcvs <- TcM.readTcRef ref+            ; let tcvs' = tcvs `unionVarSet` co_vars+            ; TcM.writeTcRef ref tcvs' } }++-- | Equalities only+setWantedEq :: TcEvDest -> Coercion -> TcS ()+setWantedEq (HoleDest hole) co+  = do { useVars (coVarsOfCo co)+       ; wrapTcS $ TcM.fillCoercionHole hole co }+setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq" (ppr ev)++-- | Good for both equalities and non-equalities+setWantedEvTerm :: TcEvDest -> EvTerm -> TcS ()+setWantedEvTerm (HoleDest hole) tm+  | Just co <- evTermCoercion_maybe tm+  = do { useVars (coVarsOfCo co)+       ; wrapTcS $ TcM.fillCoercionHole hole co }+  | otherwise+  = do { let co_var = coHoleCoVar hole+       ; setEvBind (mkWantedEvBind co_var tm)+       ; wrapTcS $ TcM.fillCoercionHole hole (mkTcCoVarCo co_var) }++setWantedEvTerm (EvVarDest ev_id) tm+  = setEvBind (mkWantedEvBind ev_id tm)++setEvBindIfWanted :: CtEvidence -> EvTerm -> TcS ()+setEvBindIfWanted ev tm+  = case ev of+      CtWanted { ctev_dest = dest } -> setWantedEvTerm dest tm+      _                             -> return ()++newTcEvBinds :: TcS EvBindsVar+newTcEvBinds = wrapTcS TcM.newTcEvBinds++newNoTcEvBinds :: TcS EvBindsVar+newNoTcEvBinds = wrapTcS TcM.newNoTcEvBinds++newEvVar :: TcPredType -> TcS EvVar+newEvVar pred = wrapTcS (TcM.newEvVar pred)++newGivenEvVar :: CtLoc -> (TcPredType, EvTerm) -> TcS CtEvidence+-- Make a new variable of the given PredType,+-- immediately bind it to the given term+-- and return its CtEvidence+-- See Note [Bind new Givens immediately] in TcRnTypes+newGivenEvVar loc (pred, rhs)+  = do { new_ev <- newBoundEvVarId pred rhs+       ; return (CtGiven { ctev_pred = pred, ctev_evar = new_ev, ctev_loc = loc }) }++-- | Make a new 'Id' of the given type, bound (in the monad's EvBinds) to the+-- given term+newBoundEvVarId :: TcPredType -> EvTerm -> TcS EvVar+newBoundEvVarId pred rhs+  = do { new_ev <- newEvVar pred+       ; setEvBind (mkGivenEvBind new_ev rhs)+       ; return new_ev }++newGivenEvVars :: CtLoc -> [(TcPredType, EvTerm)] -> TcS [CtEvidence]+newGivenEvVars loc pts = mapM (newGivenEvVar loc) pts++emitNewWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS Coercion+-- | Emit a new Wanted equality into the work-list+emitNewWantedEq loc role ty1 ty2+  = do { (ev, co) <- newWantedEq loc role ty1 ty2+       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev))+       ; return co }++-- | Make a new equality CtEvidence+newWantedEq :: CtLoc -> Role -> TcType -> TcType -> TcS (CtEvidence, Coercion)+newWantedEq loc role ty1 ty2+  = do { hole <- wrapTcS $ TcM.newCoercionHole pty+       ; traceTcS "Emitting new coercion hole" (ppr hole <+> dcolon <+> ppr pty)+       ; return ( CtWanted { ctev_pred = pty, ctev_dest = HoleDest hole+                           , ctev_nosh = WDeriv+                           , ctev_loc = loc}+                , mkHoleCo hole ) }+  where+    pty = mkPrimEqPredRole role ty1 ty2++-- no equalities here. Use newWantedEq instead+newWantedEvVarNC :: CtLoc -> TcPredType -> TcS CtEvidence+-- Don't look up in the solved/inerts; we know it's not there+newWantedEvVarNC loc pty+  = do { new_ev <- newEvVar pty+       ; traceTcS "Emitting new wanted" (ppr new_ev <+> dcolon <+> ppr pty $$+                                         pprCtLoc loc)+       ; return (CtWanted { ctev_pred = pty, ctev_dest = EvVarDest new_ev+                          , ctev_nosh = WDeriv+                          , ctev_loc = loc })}++newWantedEvVar :: CtLoc -> TcPredType -> TcS MaybeNew+-- For anything except ClassPred, this is the same as newWantedEvVarNC+newWantedEvVar loc pty+  = do { mb_ct <- lookupInInerts loc pty+       ; case mb_ct of+            Just ctev+              | not (isDerived ctev)+              -> do { traceTcS "newWantedEvVar/cache hit" $ ppr ctev+                    ; return $ Cached (ctEvExpr ctev) }+            _ -> do { ctev <- newWantedEvVarNC loc pty+                    ; return (Fresh ctev) } }++-- deals with both equalities and non equalities. Tries to look+-- up non-equalities in the cache+newWanted :: CtLoc -> PredType -> TcS MaybeNew+newWanted loc pty+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty+  = Fresh . fst <$> newWantedEq loc role ty1 ty2+  | otherwise+  = newWantedEvVar loc pty++-- deals with both equalities and non equalities. Doesn't do any cache lookups.+newWantedNC :: CtLoc -> PredType -> TcS CtEvidence+newWantedNC loc pty+  | Just (role, ty1, ty2) <- getEqPredTys_maybe pty+  = fst <$> newWantedEq loc role ty1 ty2+  | otherwise+  = newWantedEvVarNC loc pty++emitNewDeriveds :: CtLoc -> [TcPredType] -> TcS ()+emitNewDeriveds loc preds+  | null preds+  = return ()+  | otherwise+  = do { evs <- mapM (newDerivedNC loc) preds+       ; traceTcS "Emitting new deriveds" (ppr evs)+       ; updWorkListTcS (extendWorkListDeriveds evs) }++emitNewDerivedEq :: CtLoc -> Role -> TcType -> TcType -> TcS ()+-- Create new equality Derived and put it in the work list+-- There's no caching, no lookupInInerts+emitNewDerivedEq loc role ty1 ty2+  = do { ev <- newDerivedNC loc (mkPrimEqPredRole role ty1 ty2)+       ; traceTcS "Emitting new derived equality" (ppr ev $$ pprCtLoc loc)+       ; updWorkListTcS (extendWorkListEq (mkNonCanonical ev)) }+         -- Very important: put in the wl_eqs+         -- See Note [Prioritise equalities] (Avoiding fundep iteration)++newDerivedNC :: CtLoc -> TcPredType -> TcS CtEvidence+newDerivedNC loc pred+  = do { -- checkReductionDepth loc pred+       ; return (CtDerived { ctev_pred = pred, ctev_loc = loc }) }++-- --------- Check done in TcInteract.selectNewWorkItem???? ---------+-- | Checks if the depth of the given location is too much. Fails if+-- it's too big, with an appropriate error message.+checkReductionDepth :: CtLoc -> TcType   -- ^ type being reduced+                    -> TcS ()+checkReductionDepth loc ty+  = do { dflags <- getDynFlags+       ; when (subGoalDepthExceeded dflags (ctLocDepth loc)) $+         wrapErrTcS $+         solverDepthErrorTcS loc ty }++matchFam :: TyCon -> [Type] -> TcS (Maybe (Coercion, TcType))+matchFam tycon args = wrapTcS $ matchFamTcM tycon args++matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (Coercion, TcType))+-- Given (F tys) return (ty, co), where co :: F tys ~ ty+matchFamTcM tycon args+  = do { fam_envs <- FamInst.tcGetFamInstEnvs+       ; let match_fam_result+              = reduceTyFamApp_maybe fam_envs Nominal tycon args+       ; TcM.traceTc "matchFamTcM" $+         vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args)+              , ppr_res match_fam_result ]+       ; return match_fam_result }+  where+    ppr_res Nothing        = text "Match failed"+    ppr_res (Just (co,ty)) = hang (text "Match succeeded:")+                                2 (vcat [ text "Rewrites to:" <+> ppr ty+                                        , text "Coercion:" <+> ppr co ])++{-+Note [Residual implications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The wl_implics in the WorkList are the residual implication+constraints that are generated while solving or canonicalising the+current worklist.  Specifically, when canonicalising+   (forall a. t1 ~ forall a. t2)+from which we get the implication+   (forall a. t1 ~ t2)+See TcSMonad.deferTcSForAllEq+-}
+ compiler/typecheck/TcSigs.hs view
@@ -0,0 +1,847 @@+{-+(c) The University of Glasgow 2006-2012+(c) The GRASP Project, Glasgow University, 1992-2002++-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}++module TcSigs(+       TcSigInfo(..),+       TcIdSigInfo(..), TcIdSigInst,+       TcPatSynInfo(..),+       TcSigFun,++       isPartialSig, hasCompleteSig, tcIdSigName, tcSigInfoName,+       completeSigPolyId_maybe,++       tcTySigs, tcUserTypeSig, completeSigFromId,+       tcInstSig,++       TcPragEnv, emptyPragEnv, lookupPragEnv, extendPragEnv,+       mkPragEnv, tcSpecPrags, tcSpecWrapper, tcImpPrags, addInlinePrags+   ) where++#include "HsVersions.h"++import GhcPrelude++import HsSyn+import TcHsType+import TcRnTypes+import TcRnMonad+import TcType+import TcMType+import TcValidity ( checkValidType )+import TcUnify( tcSkolemise, unifyType )+import Inst( topInstantiate )+import TcEnv( tcLookupId )+import TcEvidence( HsWrapper, (<.>) )+import Type( mkTyVarBinders )++import DynFlags+import Var      ( TyVar, tyVarKind )+import Id       ( Id, idName, idType, idInlinePragma, setInlinePragma, mkLocalId )+import PrelNames( mkUnboundName )+import BasicTypes+import Bag( foldrBag )+import Module( getModule )+import Name+import NameEnv+import Outputable+import SrcLoc+import Util( singleton )+import Maybes( orElse )+import Data.Maybe( mapMaybe )+import Control.Monad( unless )+++{- -------------------------------------------------------------+          Note [Overview of type signatures]+----------------------------------------------------------------+Type signatures, including partial signatures, are jolly tricky,+especially on value bindings.  Here's an overview.++    f :: forall a. [a] -> [a]+    g :: forall b. _ -> b++    f = ...g...+    g = ...f...++* HsSyn: a signature in a binding starts off as a TypeSig, in+  type HsBinds.Sig++* When starting a mutually recursive group, like f/g above, we+  call tcTySig on each signature in the group.++* tcTySig: Sig -> TcIdSigInfo+  - For a /complete/ signature, like 'f' above, tcTySig kind-checks+    the HsType, producing a Type, and wraps it in a CompleteSig, and+    extend the type environment with this polymorphic 'f'.++  - For a /partial/signature, like 'g' above, tcTySig does nothing+    Instead it just wraps the pieces in a PartialSig, to be handled+    later.++* tcInstSig: TcIdSigInfo -> TcIdSigInst+  In tcMonoBinds, when looking at an individual binding, we use+  tcInstSig to instantiate the signature forall's in the signature,+  and attribute that instantiated (monomorphic) type to the+  binder.  You can see this in TcBinds.tcLhsId.++  The instantiation does the obvious thing for complete signatures,+  but for /partial/ signatures it starts from the HsSyn, so it+  has to kind-check it etc: tcHsPartialSigType.  It's convenient+  to do this at the same time as instantiation, because we can+  make the wildcards into unification variables right away, raather+  than somehow quantifying over them.  And the "TcLevel" of those+  unification variables is correct because we are in tcMonoBinds.+++Note [Scoped tyvars]+~~~~~~~~~~~~~~~~~~~~+The -XScopedTypeVariables flag brings lexically-scoped type variables+into scope for any explicitly forall-quantified type variables:+        f :: forall a. a -> a+        f x = e+Then 'a' is in scope inside 'e'.++However, we do *not* support this+  - For pattern bindings e.g+        f :: forall a. a->a+        (f,g) = e++Note [Binding scoped type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The type variables *brought into lexical scope* by a type signature+may be a subset of the *quantified type variables* of the signatures,+for two reasons:++* With kind polymorphism a signature like+    f :: forall f a. f a -> f a+  may actually give rise to+    f :: forall k. forall (f::k -> *) (a:k). f a -> f a+  So the sig_tvs will be [k,f,a], but only f,a are scoped.+  NB: the scoped ones are not necessarily the *inital* ones!++* Even aside from kind polymorphism, there may be more instantiated+  type variables than lexically-scoped ones.  For example:+        type T a = forall b. b -> (a,b)+        f :: forall c. T c+  Here, the signature for f will have one scoped type variable, c,+  but two instantiated type variables, c' and b'.++However, all of this only applies to the renamer.  The typechecker+just puts all of them into the type environment; any lexical-scope+errors were dealt with by the renamer.++-}+++{- *********************************************************************+*                                                                      *+             Utility functions for TcSigInfo+*                                                                      *+********************************************************************* -}++tcIdSigName :: TcIdSigInfo -> Name+tcIdSigName (CompleteSig { sig_bndr = id }) = idName id+tcIdSigName (PartialSig { psig_name = n })  = n++tcSigInfoName :: TcSigInfo -> Name+tcSigInfoName (TcIdSig     idsi) = tcIdSigName idsi+tcSigInfoName (TcPatSynSig tpsi) = patsig_name tpsi++completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId+completeSigPolyId_maybe sig+  | TcIdSig sig_info <- sig+  , CompleteSig { sig_bndr = id } <- sig_info = Just id+  | otherwise                                 = Nothing+++{- *********************************************************************+*                                                                      *+               Typechecking user signatures+*                                                                      *+********************************************************************* -}++tcTySigs :: [LSig GhcRn] -> TcM ([TcId], TcSigFun)+tcTySigs hs_sigs+  = checkNoErrs $+    do { -- Fail if any of the signatures is duff+         -- Hence mapAndReportM+         -- See Note [Fail eagerly on bad signatures]+         ty_sigs_s <- mapAndReportM tcTySig hs_sigs++       ; let ty_sigs = concat ty_sigs_s+             poly_ids = mapMaybe completeSigPolyId_maybe ty_sigs+                        -- The returned [TcId] are the ones for which we have+                        -- a complete type signature.+                        -- See Note [Complete and partial type signatures]+             env = mkNameEnv [(tcSigInfoName sig, sig) | sig <- ty_sigs]++       ; return (poly_ids, lookupNameEnv env) }++tcTySig :: LSig GhcRn -> TcM [TcSigInfo]+tcTySig (L _ (IdSig _ id))+  = do { let ctxt = FunSigCtxt (idName id) False+                    -- False: do not report redundant constraints+                    -- The user has no control over the signature!+             sig = completeSigFromId ctxt id+       ; return [TcIdSig sig] }++tcTySig (L loc (TypeSig _ names sig_ty))+  = setSrcSpan loc $+    do { sigs <- sequence [ tcUserTypeSig loc sig_ty (Just name)+                          | L _ name <- names ]+       ; return (map TcIdSig sigs) }++tcTySig (L loc (PatSynSig _ names sig_ty))+  = setSrcSpan loc $+    do { tpsigs <- sequence [ tcPatSynSig name sig_ty+                            | L _ name <- names ]+       ; return (map TcPatSynSig tpsigs) }++tcTySig _ = return []+++tcUserTypeSig :: SrcSpan -> LHsSigWcType GhcRn -> Maybe Name+              -> TcM TcIdSigInfo+-- A function or expression type signature+-- Returns a fully quantified type signature; even the wildcards+-- are quantified with ordinary skolems that should be instantiated+--+-- The SrcSpan is what to declare as the binding site of the+-- any skolems in the signature. For function signatures we+-- use the whole `f :: ty' signature; for expression signatures+-- just the type part.+--+-- Just n  => Function type signature       name :: type+-- Nothing => Expression type signature   <expr> :: type+tcUserTypeSig loc hs_sig_ty mb_name+  | isCompleteHsSig hs_sig_ty+  = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty+       ; traceTc "tcuser" (ppr sigma_ty)+       ; return $+         CompleteSig { sig_bndr  = mkLocalId name sigma_ty+                     , sig_ctxt  = ctxt_T+                     , sig_loc   = loc } }+                       -- Location of the <type> in   f :: <type>++  -- Partial sig with wildcards+  | otherwise+  = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty+                       , sig_ctxt = ctxt_F, sig_loc = loc })+  where+    name   = case mb_name of+               Just n  -> n+               Nothing -> mkUnboundName (mkVarOcc "<expression>")+    ctxt_F = case mb_name of+               Just n  -> FunSigCtxt n False+               Nothing -> ExprSigCtxt+    ctxt_T = case mb_name of+               Just n  -> FunSigCtxt n True+               Nothing -> ExprSigCtxt++++completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo+-- Used for instance methods and record selectors+completeSigFromId ctxt id+  = CompleteSig { sig_bndr = id+                , sig_ctxt = ctxt+                , sig_loc  = getSrcSpan id }++isCompleteHsSig :: LHsSigWcType GhcRn -> Bool+-- ^ If there are no wildcards, return a LHsSigType+isCompleteHsSig (HsWC { hswc_ext  = wcs+                      , hswc_body = HsIB { hsib_body = hs_ty } })+   = null wcs && no_anon_wc hs_ty+isCompleteHsSig (HsWC _ (XHsImplicitBndrs _)) = panic "isCompleteHsSig"+isCompleteHsSig (XHsWildCardBndrs _) = panic "isCompleteHsSig"++no_anon_wc :: LHsType GhcRn -> Bool+no_anon_wc lty = go lty+  where+    go (L _ ty) = case ty of+      HsWildCardTy _                 -> False+      HsAppTy _ ty1 ty2              -> go ty1 && go ty2+      HsAppKindTy _ ty ki            -> go ty && go ki+      HsFunTy _ ty1 ty2              -> go ty1 && go ty2+      HsListTy _ ty                  -> go ty+      HsTupleTy _ _ tys              -> gos tys+      HsSumTy _ tys                  -> gos tys+      HsOpTy _ ty1 _ ty2             -> go ty1 && go ty2+      HsParTy _ ty                   -> go ty+      HsIParamTy _ _ ty              -> go ty+      HsKindSig _ ty kind            -> go ty && go kind+      HsDocTy _ ty _                 -> go ty+      HsBangTy _ _ ty                -> go ty+      HsRecTy _ flds                 -> gos $ map (cd_fld_type . unLoc) flds+      HsExplicitListTy _ _ tys       -> gos tys+      HsExplicitTupleTy _ tys        -> gos tys+      HsForAllTy { hst_bndrs = bndrs+                 , hst_body = ty } -> no_anon_wc_bndrs bndrs+                                        && go ty+      HsQualTy { hst_ctxt = L _ ctxt+               , hst_body = ty }  -> gos ctxt && go ty+      HsSpliceTy _ (HsSpliced _ _ (HsSplicedTy ty)) -> go $ L noSrcSpan ty+      HsSpliceTy{} -> True+      HsTyLit{} -> True+      HsTyVar{} -> True+      HsStarTy{} -> True+      XHsType{} -> True      -- Core type, which does not have any wildcard++    gos = all go++no_anon_wc_bndrs :: [LHsTyVarBndr GhcRn] -> Bool+no_anon_wc_bndrs ltvs = all (go . unLoc) ltvs+  where+    go (UserTyVar _ _)      = True+    go (KindedTyVar _ _ ki) = no_anon_wc ki+    go (XTyVarBndr{})       = panic "no_anon_wc_bndrs"++{- Note [Fail eagerly on bad signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a type signature is wrong, fail immediately:++ * the type sigs may bind type variables, so proceeding without them+   can lead to a cascade of errors++ * the type signature might be ambiguous, in which case checking+   the code against the signature will give a very similar error+   to the ambiguity error.++ToDo: this means we fall over if any top-level type signature in the+module is wrong, because we typecheck all the signatures together+(see TcBinds.tcValBinds).  Moreover, because of top-level+captureTopConstraints, only insoluble constraints will be reported.+We typecheck all signatures at the same time because a signature+like   f,g :: blah   might have f and g from different SCCs.++So it's a bit awkward to get better error recovery, and no one+has complained!+-}++{- *********************************************************************+*                                                                      *+        Type checking a pattern synonym signature+*                                                                      *+************************************************************************++Note [Pattern synonym signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Pattern synonym signatures are surprisingly tricky (see #11224 for example).+In general they look like this:++   pattern P :: forall univ_tvs. req_theta+             => forall ex_tvs. prov_theta+             => arg1 -> .. -> argn -> res_ty++For parsing and renaming we treat the signature as an ordinary LHsSigType.++Once we get to type checking, we decompose it into its parts, in tcPatSynSig.++* Note that 'forall univ_tvs' and 'req_theta =>'+        and 'forall ex_tvs'   and 'prov_theta =>'+  are all optional.  We gather the pieces at the top of tcPatSynSig++* Initially the implicitly-bound tyvars (added by the renamer) include both+  universal and existential vars.++* After we kind-check the pieces and convert to Types, we do kind generalisation.++Note [solveEqualities in tcPatSynSig]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important that we solve /all/ the equalities in a pattern+synonym signature, because we are going to zonk the signature to+a Type (not a TcType), in TcPatSyn.tc_patsyn_finish, and that+fails if there are un-filled-in coercion variables mentioned+in the type (#15694).++The best thing is simply to use solveEqualities to solve all the+equalites, rather than leaving them in the ambient constraints+to be solved later.  Pattern synonyms are top-level, so there's+no problem with completely solving them.++(NB: this solveEqualities wraps newImplicitTKBndrs, which itself+does a solveLocalEqualities; so solveEqualities isn't going to+make any further progress; it'll just report any unsolved ones,+and fail, as it should.)+-}++tcPatSynSig :: Name -> LHsSigType GhcRn -> TcM TcPatSynInfo+-- See Note [Pattern synonym signatures]+-- See Note [Recipe for checking a signature] in TcHsType+tcPatSynSig name sig_ty+  | HsIB { hsib_ext = implicit_hs_tvs+         , hsib_body = hs_ty }  <- sig_ty+  , (univ_hs_tvs, hs_req,  hs_ty1)     <- splitLHsSigmaTyInvis hs_ty+  , (ex_hs_tvs,   hs_prov, hs_body_ty) <- splitLHsSigmaTyInvis hs_ty1+  = do {  traceTc "tcPatSynSig 1" (ppr sig_ty)+       ; (implicit_tvs, (univ_tvs, (ex_tvs, (req, prov, body_ty))))+           <- pushTcLevelM_   $+              solveEqualities $ -- See Note [solveEqualities in tcPatSynSig]+              bindImplicitTKBndrs_Skol implicit_hs_tvs $+              bindExplicitTKBndrs_Skol univ_hs_tvs     $+              bindExplicitTKBndrs_Skol ex_hs_tvs       $+              do { req     <- tcHsContext hs_req+                 ; prov    <- tcHsContext hs_prov+                 ; body_ty <- tcHsOpenType hs_body_ty+                     -- A (literal) pattern can be unlifted;+                     -- e.g. pattern Zero <- 0#   (#12094)+                 ; return (req, prov, body_ty) }++       ; let ungen_patsyn_ty = build_patsyn_type [] implicit_tvs univ_tvs+                                                 req ex_tvs prov body_ty++       -- Kind generalisation+       ; kvs <- kindGeneralize ungen_patsyn_ty+       ; traceTc "tcPatSynSig" (ppr ungen_patsyn_ty)++       -- These are /signatures/ so we zonk to squeeze out any kind+       -- unification variables.  Do this after kindGeneralize which may+       -- default kind variables to *.+       ; implicit_tvs <- zonkAndScopedSort implicit_tvs+       ; univ_tvs     <- mapM zonkTyCoVarKind univ_tvs+       ; ex_tvs       <- mapM zonkTyCoVarKind ex_tvs+       ; req          <- zonkTcTypes req+       ; prov         <- zonkTcTypes prov+       ; body_ty      <- zonkTcType  body_ty++       -- Skolems have TcLevels too, though they're used only for debugging.+       -- If you don't do this, the debugging checks fail in TcPatSyn.+       -- Test case: patsyn/should_compile/T13441+{-+       ; tclvl <- getTcLevel+       ; let env0                  = mkEmptyTCvSubst $ mkInScopeSet $ mkVarSet kvs+             (env1, implicit_tvs') = promoteSkolemsX tclvl env0 implicit_tvs+             (env2, univ_tvs')     = promoteSkolemsX tclvl env1 univ_tvs+             (env3, ex_tvs')       = promoteSkolemsX tclvl env2 ex_tvs+             req'                  = substTys env3 req+             prov'                 = substTys env3 prov+             body_ty'              = substTy  env3 body_ty+-}+      ; let implicit_tvs' = implicit_tvs+            univ_tvs'     = univ_tvs+            ex_tvs'       = ex_tvs+            req'          = req+            prov'         = prov+            body_ty'      = body_ty++       -- Now do validity checking+       ; checkValidType ctxt $+         build_patsyn_type kvs implicit_tvs' univ_tvs' req' ex_tvs' prov' body_ty'++       -- arguments become the types of binders. We thus cannot allow+       -- levity polymorphism here+       ; let (arg_tys, _) = tcSplitFunTys body_ty'+       ; mapM_ (checkForLevPoly empty) arg_tys++       ; traceTc "tcTySig }" $+         vcat [ text "implicit_tvs" <+> ppr_tvs implicit_tvs'+              , text "kvs" <+> ppr_tvs kvs+              , text "univ_tvs" <+> ppr_tvs univ_tvs'+              , text "req" <+> ppr req'+              , text "ex_tvs" <+> ppr_tvs ex_tvs'+              , text "prov" <+> ppr prov'+              , text "body_ty" <+> ppr body_ty' ]+       ; return (TPSI { patsig_name = name+                      , patsig_implicit_bndrs = mkTyVarBinders Inferred  kvs +++                                                mkTyVarBinders Specified implicit_tvs'+                      , patsig_univ_bndrs     = univ_tvs'+                      , patsig_req            = req'+                      , patsig_ex_bndrs       = ex_tvs'+                      , patsig_prov           = prov'+                      , patsig_body_ty        = body_ty' }) }+  where+    ctxt = PatSynCtxt name++    build_patsyn_type kvs imp univ req ex prov body+      = mkInvForAllTys kvs $+        mkSpecForAllTys (imp ++ univ) $+        mkPhiTy req $+        mkSpecForAllTys ex $+        mkPhiTy prov $+        body+tcPatSynSig _ (XHsImplicitBndrs _) = panic "tcPatSynSig"++ppr_tvs :: [TyVar] -> SDoc+ppr_tvs tvs = braces (vcat [ ppr tv <+> dcolon <+> ppr (tyVarKind tv)+                           | tv <- tvs])+++{- *********************************************************************+*                                                                      *+               Instantiating user signatures+*                                                                      *+********************************************************************* -}+++tcInstSig :: TcIdSigInfo -> TcM TcIdSigInst+-- Instantiate a type signature; only used with plan InferGen+tcInstSig sig@(CompleteSig { sig_bndr = poly_id, sig_loc = loc })+  = setSrcSpan loc $  -- Set the binding site of the tyvars+    do { (tv_prs, theta, tau) <- tcInstType newMetaTyVarTyVars poly_id+              -- See Note [Pattern bindings and complete signatures]++       ; return (TISI { sig_inst_sig   = sig+                      , sig_inst_skols = tv_prs+                      , sig_inst_wcs   = []+                      , sig_inst_wcx   = Nothing+                      , sig_inst_theta = theta+                      , sig_inst_tau   = tau }) }++tcInstSig hs_sig@(PartialSig { psig_hs_ty = hs_ty+                             , sig_ctxt = ctxt+                             , sig_loc = loc })+  = setSrcSpan loc $  -- Set the binding site of the tyvars+    do { traceTc "Staring partial sig {" (ppr hs_sig)+       ; (wcs, wcx, tv_names, tvs, theta, tau) <- tcHsPartialSigType ctxt hs_ty++        -- Clone the quantified tyvars+        -- Reason: we might have    f, g :: forall a. a -> _ -> a+        --         and we want it to behave exactly as if there were+        --         two separate signatures.  Cloning here seems like+        --         the easiest way to do so, and is very similar to+        --         the tcInstType in the CompleteSig case+        -- See #14643+       ; (subst, tvs') <- newMetaTyVarTyVars tvs+                         -- Why newMetaTyVarTyVars?  See TcBinds+                         -- Note [Quantified variables in partial type signatures]+       ; let tv_prs = tv_names `zip` tvs'+             inst_sig = TISI { sig_inst_sig   = hs_sig+                             , sig_inst_skols = tv_prs+                             , sig_inst_wcs   = wcs+                             , sig_inst_wcx   = wcx+                             , sig_inst_theta = substTysUnchecked subst theta+                             , sig_inst_tau   = substTyUnchecked  subst tau }+       ; traceTc "End partial sig }" (ppr inst_sig)+       ; return inst_sig }+++{- Note [Pattern bindings and complete signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+      data T a = MkT a a+      f :: forall a. a->a+      g :: forall b. b->b+      MkT f g = MkT (\x->x) (\y->y)+Here we'll infer a type from the pattern of 'T a', but if we feed in+the signature types for f and g, we'll end up unifying 'a' and 'b'++So we instantiate f and g's signature with TyVarTv skolems+(newMetaTyVarTyVars) that can unify with each other.  If too much+unification takes place, we'll find out when we do the final+impedance-matching check in TcBinds.mkExport++See Note [Signature skolems] in TcType++None of this applies to a function binding with a complete+signature, which doesn't use tcInstSig.  See TcBinds.tcPolyCheck.+-}++{- *********************************************************************+*                                                                      *+                   Pragmas and PragEnv+*                                                                      *+********************************************************************* -}++type TcPragEnv = NameEnv [LSig GhcRn]++emptyPragEnv :: TcPragEnv+emptyPragEnv = emptyNameEnv++lookupPragEnv :: TcPragEnv -> Name -> [LSig GhcRn]+lookupPragEnv prag_fn n = lookupNameEnv prag_fn n `orElse` []++extendPragEnv :: TcPragEnv -> (Name, LSig GhcRn) -> TcPragEnv+extendPragEnv prag_fn (n, sig) = extendNameEnv_Acc (:) singleton prag_fn n sig++---------------+mkPragEnv :: [LSig GhcRn] -> LHsBinds GhcRn -> TcPragEnv+mkPragEnv sigs binds+  = foldl' extendPragEnv emptyNameEnv prs+  where+    prs = mapMaybe get_sig sigs++    get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn)+    get_sig (L l (SpecSig x lnm@(L _ nm) ty inl))+      = Just (nm, L l $ SpecSig   x lnm ty (add_arity nm inl))+    get_sig (L l (InlineSig x lnm@(L _ nm) inl))+      = Just (nm, L l $ InlineSig x lnm    (add_arity nm inl))+    get_sig (L l (SCCFunSig x st lnm@(L _ nm) str))+      = Just (nm, L l $ SCCFunSig x st lnm str)+    get_sig _ = Nothing++    add_arity n inl_prag   -- Adjust inl_sat field to match visible arity of function+      | Inline <- inl_inline inl_prag+        -- add arity only for real INLINE pragmas, not INLINABLE+      = case lookupNameEnv ar_env n of+          Just ar -> inl_prag { inl_sat = Just ar }+          Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n )+                     -- There really should be a binding for every INLINE pragma+                     inl_prag+      | otherwise+      = inl_prag++    -- ar_env maps a local to the arity of its definition+    ar_env :: NameEnv Arity+    ar_env = foldrBag lhsBindArity emptyNameEnv binds++lhsBindArity :: LHsBind GhcRn -> NameEnv Arity -> NameEnv Arity+lhsBindArity (L _ (FunBind { fun_id = id, fun_matches = ms })) env+  = extendNameEnv env (unLoc id) (matchGroupArity ms)+lhsBindArity _ env = env        -- PatBind/VarBind+++-----------------+addInlinePrags :: TcId -> [LSig GhcRn] -> TcM TcId+addInlinePrags poly_id prags_for_me+  | inl@(L _ prag) : inls <- inl_prags+  = do { traceTc "addInlinePrag" (ppr poly_id $$ ppr prag)+       ; unless (null inls) (warn_multiple_inlines inl inls)+       ; return (poly_id `setInlinePragma` prag) }+  | otherwise+  = return poly_id+  where+    inl_prags = [L loc prag | L loc (InlineSig _ _ prag) <- prags_for_me]++    warn_multiple_inlines _ [] = return ()++    warn_multiple_inlines inl1@(L loc prag1) (inl2@(L _ prag2) : inls)+       | inlinePragmaActivation prag1 == inlinePragmaActivation prag2+       , noUserInlineSpec (inlinePragmaSpec prag1)+       =    -- Tiresome: inl1 is put there by virtue of being in a hs-boot loop+            -- and inl2 is a user NOINLINE pragma; we don't want to complain+         warn_multiple_inlines inl2 inls+       | otherwise+       = setSrcSpan loc $+         addWarnTc NoReason+                     (hang (text "Multiple INLINE pragmas for" <+> ppr poly_id)+                       2 (vcat (text "Ignoring all but the first"+                                : map pp_inl (inl1:inl2:inls))))++    pp_inl (L loc prag) = ppr prag <+> parens (ppr loc)+++{- *********************************************************************+*                                                                      *+                   SPECIALISE pragmas+*                                                                      *+************************************************************************++Note [Handling SPECIALISE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The basic idea is this:++   foo :: Num a => a -> b -> a+   {-# SPECIALISE foo :: Int -> b -> Int #-}++We check that+   (forall a b. Num a => a -> b -> a)+      is more polymorphic than+   forall b. Int -> b -> Int+(for which we could use tcSubType, but see below), generating a HsWrapper+to connect the two, something like+      wrap = /\b. <hole> Int b dNumInt+This wrapper is put in the TcSpecPrag, in the ABExport record of+the AbsBinds.+++        f :: (Eq a, Ix b) => a -> b -> Bool+        {-# SPECIALISE f :: (Ix p, Ix q) => Int -> (p,q) -> Bool #-}+        f = <poly_rhs>++From this the typechecker generates++    AbsBinds [ab] [d1,d2] [([ab], f, f_mono, prags)] binds++    SpecPrag (wrap_fn :: forall a b. (Eq a, Ix b) => XXX+                      -> forall p q. (Ix p, Ix q) => XXX[ Int/a, (p,q)/b ])++From these we generate:++    Rule:       forall p, q, (dp:Ix p), (dq:Ix q).+                    f Int (p,q) dInt ($dfInPair dp dq) = f_spec p q dp dq++    Spec bind:  f_spec = wrap_fn <poly_rhs>++Note that++  * The LHS of the rule may mention dictionary *expressions* (eg+    $dfIxPair dp dq), and that is essential because the dp, dq are+    needed on the RHS.++  * The RHS of f_spec, <poly_rhs> has a *copy* of 'binds', so that it+    can fully specialise it.++++From the TcSpecPrag, in DsBinds we generate a binding for f_spec and a RULE:++   f_spec :: Int -> b -> Int+   f_spec = wrap<f rhs>++   RULE: forall b (d:Num b). f b d = f_spec b++The RULE is generated by taking apart the HsWrapper, which is a little+delicate, but works.++Some wrinkles++1. We don't use full-on tcSubType, because that does co and contra+   variance and that in turn will generate too complex a LHS for the+   RULE.  So we use a single invocation of skolemise /+   topInstantiate in tcSpecWrapper.  (Actually I think that even+   the "deeply" stuff may be too much, because it introduces lambdas,+   though I think it can be made to work without too much trouble.)++2. We need to take care with type families (#5821).  Consider+      type instance F Int = Bool+      f :: Num a => a -> F a+      {-# SPECIALISE foo :: Int -> Bool #-}++  We *could* try to generate an f_spec with precisely the declared type:+      f_spec :: Int -> Bool+      f_spec = <f rhs> Int dNumInt |> co++      RULE: forall d. f Int d = f_spec |> sym co++  but the 'co' and 'sym co' are (a) playing no useful role, and (b) are+  hard to generate.  At all costs we must avoid this:+      RULE: forall d. f Int d |> co = f_spec+  because the LHS will never match (indeed it's rejected in+  decomposeRuleLhs).++  So we simply do this:+    - Generate a constraint to check that the specialised type (after+      skolemiseation) is equal to the instantiated function type.+    - But *discard* the evidence (coercion) for that constraint,+      so that we ultimately generate the simpler code+          f_spec :: Int -> F Int+          f_spec = <f rhs> Int dNumInt++          RULE: forall d. f Int d = f_spec+      You can see this discarding happening in++3. Note that the HsWrapper can transform *any* function with the right+   type prefix+       forall ab. (Eq a, Ix b) => XXX+   regardless of XXX.  It's sort of polymorphic in XXX.  This is+   useful: we use the same wrapper to transform each of the class ops, as+   well as the dict.  That's what goes on in TcInstDcls.mk_meth_spec_prags+-}++tcSpecPrags :: Id -> [LSig GhcRn]+            -> TcM [LTcSpecPrag]+-- Add INLINE and SPECIALSE pragmas+--    INLINE prags are added to the (polymorphic) Id directly+--    SPECIALISE prags are passed to the desugarer via TcSpecPrags+-- Pre-condition: the poly_id is zonked+-- Reason: required by tcSubExp+tcSpecPrags poly_id prag_sigs+  = do { traceTc "tcSpecPrags" (ppr poly_id <+> ppr spec_sigs)+       ; unless (null bad_sigs) warn_discarded_sigs+       ; pss <- mapAndRecoverM (wrapLocM (tcSpecPrag poly_id)) spec_sigs+       ; return $ concatMap (\(L l ps) -> map (L l) ps) pss }+  where+    spec_sigs = filter isSpecLSig prag_sigs+    bad_sigs  = filter is_bad_sig prag_sigs+    is_bad_sig s = not (isSpecLSig s || isInlineLSig s || isSCCFunSig s)++    warn_discarded_sigs+      = addWarnTc NoReason+                  (hang (text "Discarding unexpected pragmas for" <+> ppr poly_id)+                      2 (vcat (map (ppr . getLoc) bad_sigs)))++--------------+tcSpecPrag :: TcId -> Sig GhcRn -> TcM [TcSpecPrag]+tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl)+-- See Note [Handling SPECIALISE pragmas]+--+-- The Name fun_name in the SpecSig may not be the same as that of the poly_id+-- Example: SPECIALISE for a class method: the Name in the SpecSig is+--          for the selector Id, but the poly_id is something like $cop+-- However we want to use fun_name in the error message, since that is+-- what the user wrote (#8537)+  = addErrCtxt (spec_ctxt prag) $+    do  { warnIf (not (isOverloadedTy poly_ty || isInlinePragma inl))+                 (text "SPECIALISE pragma for non-overloaded function"+                  <+> quotes (ppr fun_name))+                  -- Note [SPECIALISE pragmas]+        ; spec_prags <- mapM tc_one hs_tys+        ; traceTc "tcSpecPrag" (ppr poly_id $$ nest 2 (vcat (map ppr spec_prags)))+        ; return spec_prags }+  where+    name      = idName poly_id+    poly_ty   = idType poly_id+    spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)++    tc_one hs_ty+      = do { spec_ty <- tcHsSigType   (FunSigCtxt name False) hs_ty+           ; wrap    <- tcSpecWrapper (FunSigCtxt name True)  poly_ty spec_ty+           ; return (SpecPrag poly_id wrap inl) }++tcSpecPrag _ prag = pprPanic "tcSpecPrag" (ppr prag)++--------------+tcSpecWrapper :: UserTypeCtxt -> TcType -> TcType -> TcM HsWrapper+-- A simpler variant of tcSubType, used for SPECIALISE pragmas+-- See Note [Handling SPECIALISE pragmas], wrinkle 1+tcSpecWrapper ctxt poly_ty spec_ty+  = do { (sk_wrap, inst_wrap)+               <- tcSkolemise ctxt spec_ty $ \ _ spec_tau ->+                  do { (inst_wrap, tau) <- topInstantiate orig poly_ty+                     ; _ <- unifyType Nothing spec_tau tau+                            -- Deliberately ignore the evidence+                            -- See Note [Handling SPECIALISE pragmas],+                            --   wrinkle (2)+                     ; return inst_wrap }+       ; return (sk_wrap <.> inst_wrap) }+  where+    orig = SpecPragOrigin ctxt++--------------+tcImpPrags :: [LSig GhcRn] -> TcM [LTcSpecPrag]+-- SPECIALISE pragmas for imported things+tcImpPrags prags+  = do { this_mod <- getModule+       ; dflags <- getDynFlags+       ; if (not_specialising dflags) then+            return []+         else do+            { pss <- mapAndRecoverM (wrapLocM tcImpSpec)+                     [L loc (name,prag)+                             | (L loc prag@(SpecSig _ (L _ name) _ _)) <- prags+                             , not (nameIsLocalOrFrom this_mod name) ]+            ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } }+  where+    -- Ignore SPECIALISE pragmas for imported things+    -- when we aren't specialising, or when we aren't generating+    -- code.  The latter happens when Haddocking the base library;+    -- we don't want complaints about lack of INLINABLE pragmas+    not_specialising dflags+      | not (gopt Opt_Specialise dflags) = True+      | otherwise = case hscTarget dflags of+                      HscNothing -> True+                      HscInterpreted -> True+                      _other         -> False++tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag]+tcImpSpec (name, prag)+ = do { id <- tcLookupId name+      ; unless (isAnyInlinePragma (idInlinePragma id))+               (addWarnTc NoReason (impSpecErr name))+      ; tcSpecPrag id prag }++impSpecErr :: Name -> SDoc+impSpecErr name+  = hang (text "You cannot SPECIALISE" <+> quotes (ppr name))+       2 (vcat [ text "because its definition has no INLINE/INLINABLE pragma"+               , parens $ sep+                   [ text "or its defining module" <+> quotes (ppr mod)+                   , text "was compiled without -O"]])+  where+    mod = nameModule name
+ compiler/typecheck/TcSimplify.hs view
@@ -0,0 +1,2678 @@+{-# LANGUAGE CPP #-}++module TcSimplify(+       simplifyInfer, InferMode(..),+       growThetaTyVars,+       simplifyAmbiguityCheck,+       simplifyDefault,+       simplifyTop, simplifyTopImplic,+       simplifyInteractive,+       solveEqualities, solveLocalEqualities, solveLocalEqualitiesX,+       simplifyWantedsTcM,+       tcCheckSatisfiability,+       tcNormalise,++       captureTopConstraints,++       simpl_top,++       promoteTyVar,+       promoteTyVarSet,++       -- For Rules we need these+       solveWanteds, solveWantedsAndDrop,+       approximateWC, runTcSDeriveds+  ) where++#include "HsVersions.h"++import GhcPrelude++import Bag+import Class         ( Class, classKey, classTyCon )+import DynFlags      ( WarningFlag ( Opt_WarnMonomorphism )+                     , WarnReason ( Reason )+                     , DynFlags( solverIterations ) )+import HsExpr        ( UnboundVar(..) )+import Id            ( idType, mkLocalId )+import Inst+import ListSetOps+import Name+import Outputable+import PrelInfo+import PrelNames+import RdrName       ( emptyGlobalRdrEnv )+import TcErrors+import TcEvidence+import TcInteract+import TcCanonical   ( makeSuperClasses, solveCallStack )+import TcMType   as TcM+import TcRnMonad as TcM+import TcSMonad  as TcS+import TcType+import TrieMap       () -- DV: for now+import Type+import TysWiredIn    ( liftedRepTy )+import Unify         ( tcMatchTyKi )+import Util+import Var+import VarSet+import UniqSet+import BasicTypes    ( IntWithInf, intGtLimit )+import ErrUtils      ( emptyMessages )+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.Foldable      ( toList )+import Data.List          ( partition )+import Data.List.NonEmpty ( NonEmpty(..) )+import Maybes             ( isJust )++{-+*********************************************************************************+*                                                                               *+*                           External interface                                  *+*                                                                               *+*********************************************************************************+-}++captureTopConstraints :: TcM a -> TcM (a, WantedConstraints)+-- (captureTopConstraints m) runs m, and returns the type constraints it+-- generates plus the constraints produced by static forms inside.+-- If it fails with an exception, it reports any insolubles+-- (out of scope variables) before doing so+--+-- captureTopConstraints is used exclusively by TcRnDriver at the top+-- level of a module.+--+-- Importantly, if captureTopConstraints propagates an exception, it+-- reports any insoluble constraints first, lest they be lost+-- altogether.  This is important, because solveLocalEqualities (maybe+-- other things too) throws an exception without adding any error+-- messages; it just puts the unsolved constraints back into the+-- monad. See TcRnMonad Note [Constraints and errors]+-- #16376 is an example of what goes wrong if you don't do this.+--+-- NB: the caller should bring any environments into scope before+-- calling this, so that the reportUnsolved has access to the most+-- complete GlobalRdrEnv+captureTopConstraints thing_inside+  = do { static_wc_var <- TcM.newTcRef emptyWC ;+       ; (mb_res, lie) <- TcM.updGblEnv (\env -> env { tcg_static_wc = static_wc_var } ) $+                          TcM.tryCaptureConstraints thing_inside+       ; stWC <- TcM.readTcRef static_wc_var++       -- See TcRnMonad Note [Constraints and errors]+       -- If the thing_inside threw an exception, but generated some insoluble+       -- constraints, report the latter before propagating the exception+       -- Otherwise they will be lost altogether+       ; case mb_res of+           Just res -> return (res, lie `andWC` stWC)+           Nothing  -> do { _ <- simplifyTop lie; failM } }+                -- This call to simplifyTop is the reason+                -- this function is here instead of TcRnMonad+                -- We call simplifyTop so that it does defaulting+                -- (esp of runtime-reps) before reporting errors++simplifyTopImplic :: Bag Implication -> TcM ()+simplifyTopImplic implics+  = do { empty_binds <- simplifyTop (mkImplicWC implics)++       -- Since all the inputs are implications the returned bindings will be empty+       ; MASSERT2( isEmptyBag empty_binds, ppr empty_binds )++       ; return () }++simplifyTop :: WantedConstraints -> TcM (Bag EvBind)+-- Simplify top-level constraints+-- Usually these will be implications,+-- but when there is nothing to quantify we don't wrap+-- in a degenerate implication, so we do that here instead+simplifyTop wanteds+  = do { traceTc "simplifyTop {" $ text "wanted = " <+> ppr wanteds+       ; ((final_wc, unsafe_ol), binds1) <- runTcS $+            do { final_wc <- simpl_top wanteds+               ; unsafe_ol <- getSafeOverlapFailures+               ; return (final_wc, unsafe_ol) }+       ; traceTc "End simplifyTop }" empty++       ; binds2 <- reportUnsolved final_wc++       ; traceTc "reportUnsolved (unsafe overlapping) {" empty+       ; unless (isEmptyCts unsafe_ol) $ do {+           -- grab current error messages and clear, warnAllUnsolved will+           -- update error messages which we'll grab and then restore saved+           -- messages.+           ; errs_var  <- getErrsVar+           ; saved_msg <- TcM.readTcRef errs_var+           ; TcM.writeTcRef errs_var emptyMessages++           ; warnAllUnsolved $ WC { wc_simple = unsafe_ol+                                  , wc_impl = emptyBag }++           ; whyUnsafe <- fst <$> TcM.readTcRef errs_var+           ; TcM.writeTcRef errs_var saved_msg+           ; recordUnsafeInfer whyUnsafe+           }+       ; traceTc "reportUnsolved (unsafe overlapping) }" empty++       ; return (evBindMapBinds binds1 `unionBags` binds2) }+++-- | Type-check a thing that emits only equality constraints, solving any+-- constraints we can and re-emitting constraints that we can't. The thing_inside+-- should generally bump the TcLevel to make sure that this run of the solver+-- doesn't affect anything lying around.+solveLocalEqualities :: String -> TcM a -> TcM a+solveLocalEqualities callsite thing_inside+  = do { (wanted, res) <- solveLocalEqualitiesX callsite thing_inside+       ; emitConstraints wanted++       -- See Note [Fail fast if there are insoluble kind equalities]+       ; if insolubleWC wanted+         then failM+         else return res }++{- Note [Fail fast if there are insoluble kind equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Rather like in simplifyInfer, fail fast if there is an insoluble+constraint.  Otherwise we'll just succeed in kind-checking a nonsense+type, with a cascade of follow-up errors.++For example polykinds/T12593, T15577, and many others.++Take care to ensure that you emit the insoluble constraints before+failing, because they are what will ulimately lead to the error+messsage!+-}++solveLocalEqualitiesX :: String -> TcM a -> TcM (WantedConstraints, a)+solveLocalEqualitiesX callsite thing_inside+  = do { traceTc "solveLocalEqualitiesX {" (vcat [ text "Called from" <+> text callsite ])++       ; (result, wanted) <- captureConstraints thing_inside++       ; traceTc "solveLocalEqualities: running solver" (ppr wanted)+       ; residual_wanted <- runTcSEqualities (solveWanteds wanted)++       ; traceTc "solveLocalEqualitiesX end }" $+         text "residual_wanted =" <+> ppr residual_wanted++       ; return (residual_wanted, result) }++-- | Type-check a thing that emits only equality constraints, then+-- solve those constraints. Fails outright if there is trouble.+-- Use this if you're not going to get another crack at solving+-- (because, e.g., you're checking a datatype declaration)+solveEqualities :: TcM a -> TcM a+solveEqualities thing_inside+  = checkNoErrs $  -- See Note [Fail fast on kind errors]+    do { lvl <- TcM.getTcLevel+       ; traceTc "solveEqualities {" (text "level =" <+> ppr lvl)++       ; (result, wanted) <- captureConstraints thing_inside++       ; traceTc "solveEqualities: running solver" $ text "wanted = " <+> ppr wanted+       ; final_wc <- runTcSEqualities $ simpl_top wanted+          -- NB: Use simpl_top here so that we potentially default RuntimeRep+          -- vars to LiftedRep. This is needed to avoid #14991.++       ; traceTc "End solveEqualities }" empty+       ; reportAllUnsolved final_wc+       ; return result }++-- | Simplify top-level constraints, but without reporting any unsolved+-- constraints nor unsafe overlapping.+simpl_top :: WantedConstraints -> TcS WantedConstraints+    -- See Note [Top-level Defaulting Plan]+simpl_top wanteds+  = do { wc_first_go <- nestTcS (solveWantedsAndDrop wanteds)+                            -- This is where the main work happens+       ; try_tyvar_defaulting wc_first_go }+  where+    try_tyvar_defaulting :: WantedConstraints -> TcS WantedConstraints+    try_tyvar_defaulting wc+      | isEmptyWC wc+      = return wc+      | otherwise+      = do { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc)+           ; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs+                   -- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked+                   -- filter isMetaTyVar: we might have runtime-skolems in GHCi,+                   -- and we definitely don't want to try to assign to those!+                   -- The isTyVar is needed to weed out coercion variables++           ; defaulted <- mapM defaultTyVarTcS meta_tvs   -- Has unification side effects+           ; if or defaulted+             then do { wc_residual <- nestTcS (solveWanteds wc)+                            -- See Note [Must simplify after defaulting]+                     ; try_class_defaulting wc_residual }+             else try_class_defaulting wc }     -- No defaulting took place++    try_class_defaulting :: WantedConstraints -> TcS WantedConstraints+    try_class_defaulting wc+      | isEmptyWC wc+      = return wc+      | otherwise  -- See Note [When to do type-class defaulting]+      = do { something_happened <- applyDefaultingRules wc+                                   -- See Note [Top-level Defaulting Plan]+           ; if something_happened+             then do { wc_residual <- nestTcS (solveWantedsAndDrop wc)+                     ; try_class_defaulting wc_residual }+                  -- See Note [Overview of implicit CallStacks] in TcEvidence+             else try_callstack_defaulting wc }++    try_callstack_defaulting :: WantedConstraints -> TcS WantedConstraints+    try_callstack_defaulting wc+      | isEmptyWC wc+      = return wc+      | otherwise+      = defaultCallStacks wc++-- | Default any remaining @CallStack@ constraints to empty @CallStack@s.+defaultCallStacks :: WantedConstraints -> TcS WantedConstraints+-- See Note [Overview of implicit CallStacks] in TcEvidence+defaultCallStacks wanteds+  = do simples <- handle_simples (wc_simple wanteds)+       mb_implics <- mapBagM handle_implic (wc_impl wanteds)+       return (wanteds { wc_simple = simples+                       , wc_impl = catBagMaybes mb_implics })++  where++  handle_simples simples+    = catBagMaybes <$> mapBagM defaultCallStack simples++  handle_implic :: Implication -> TcS (Maybe Implication)+  -- The Maybe is because solving the CallStack constraint+  -- may well allow us to discard the implication entirely+  handle_implic implic+    | isSolvedStatus (ic_status implic)+    = return (Just implic)+    | otherwise+    = do { wanteds <- setEvBindsTcS (ic_binds implic) $+                      -- defaultCallStack sets a binding, so+                      -- we must set the correct binding group+                      defaultCallStacks (ic_wanted implic)+         ; setImplicationStatus (implic { ic_wanted = wanteds }) }++  defaultCallStack ct+    | ClassPred cls tys <- classifyPredType (ctPred ct)+    , Just {} <- isCallStackPred cls tys+    = do { solveCallStack (ctEvidence ct) EvCsEmpty+         ; return Nothing }++  defaultCallStack ct+    = return (Just ct)+++{- Note [Fail fast on kind errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+solveEqualities is used to solve kind equalities when kind-checking+user-written types. If solving fails we should fail outright, rather+than just accumulate an error message, for two reasons:++  * A kind-bogus type signature may cause a cascade of knock-on+    errors if we let it pass++  * More seriously, we don't have a convenient term-level place to add+    deferred bindings for unsolved kind-equality constraints, so we+    don't build evidence bindings (by usine reportAllUnsolved). That+    means that we'll be left with with a type that has coercion holes+    in it, something like+           <type> |> co-hole+    where co-hole is not filled in.  Eeek!  That un-filled-in+    hole actually causes GHC to crash with "fvProv falls into a hole"+    See #11563, #11520, #11516, #11399++So it's important to use 'checkNoErrs' here!++Note [When to do type-class defaulting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In GHC 7.6 and 7.8.2, we did type-class defaulting only if insolubleWC+was false, on the grounds that defaulting can't help solve insoluble+constraints.  But if we *don't* do defaulting we may report a whole+lot of errors that would be solved by defaulting; these errors are+quite spurious because fixing the single insoluble error means that+defaulting happens again, which makes all the other errors go away.+This is jolly confusing: #9033.++So it seems better to always do type-class defaulting.++However, always doing defaulting does mean that we'll do it in+situations like this (#5934):+   run :: (forall s. GenST s) -> Int+   run = fromInteger 0+We don't unify the return type of fromInteger with the given function+type, because the latter involves foralls.  So we're left with+    (Num alpha, alpha ~ (forall s. GenST s) -> Int)+Now we do defaulting, get alpha := Integer, and report that we can't+match Integer with (forall s. GenST s) -> Int.  That's not totally+stupid, but perhaps a little strange.++Another potential alternative would be to suppress *all* non-insoluble+errors if there are *any* insoluble errors, anywhere, but that seems+too drastic.++Note [Must simplify after defaulting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We may have a deeply buried constraint+    (t:*) ~ (a:Open)+which we couldn't solve because of the kind incompatibility, and 'a' is free.+Then when we default 'a' we can solve the constraint.  And we want to do+that before starting in on type classes.  We MUST do it before reporting+errors, because it isn't an error!  #7967 was due to this.++Note [Top-level Defaulting Plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have considered two design choices for where/when to apply defaulting.+   (i) Do it in SimplCheck mode only /whenever/ you try to solve some+       simple constraints, maybe deep inside the context of implications.+       This used to be the case in GHC 7.4.1.+   (ii) Do it in a tight loop at simplifyTop, once all other constraints have+        finished. This is the current story.++Option (i) had many disadvantages:+   a) Firstly, it was deep inside the actual solver.+   b) Secondly, it was dependent on the context (Infer a type signature,+      or Check a type signature, or Interactive) since we did not want+      to always start defaulting when inferring (though there is an exception to+      this, see Note [Default while Inferring]).+   c) It plainly did not work. Consider typecheck/should_compile/DfltProb2.hs:+          f :: Int -> Bool+          f x = const True (\y -> let w :: a -> a+                                      w a = const a (y+1)+                                  in w y)+      We will get an implication constraint (for beta the type of y):+               [untch=beta] forall a. 0 => Num beta+      which we really cannot default /while solving/ the implication, since beta is+      untouchable.++Instead our new defaulting story is to pull defaulting out of the solver loop and+go with option (ii), implemented at SimplifyTop. Namely:+     - First, have a go at solving the residual constraint of the whole+       program+     - Try to approximate it with a simple constraint+     - Figure out derived defaulting equations for that simple constraint+     - Go round the loop again if you did manage to get some equations++Now, that has to do with class defaulting. However there exists type variable /kind/+defaulting. Again this is done at the top-level and the plan is:+     - At the top-level, once you had a go at solving the constraint, do+       figure out /all/ the touchable unification variables of the wanted constraints.+     - Apply defaulting to their kinds++More details in Note [DefaultTyVar].++Note [Safe Haskell Overlapping Instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Safe Haskell, we apply an extra restriction to overlapping instances. The+motive is to prevent untrusted code provided by a third-party, changing the+behavior of trusted code through type-classes. This is due to the global and+implicit nature of type-classes that can hide the source of the dictionary.++Another way to state this is: if a module M compiles without importing another+module N, changing M to import N shouldn't change the behavior of M.++Overlapping instances with type-classes can violate this principle. However,+overlapping instances aren't always unsafe. They are just unsafe when the most+selected dictionary comes from untrusted code (code compiled with -XSafe) and+overlaps instances provided by other modules.++In particular, in Safe Haskell at a call site with overlapping instances, we+apply the following rule to determine if it is a 'unsafe' overlap:++ 1) Most specific instance, I1, defined in an `-XSafe` compiled module.+ 2) I1 is an orphan instance or a MPTC.+ 3) At least one overlapped instance, Ix, is both:+    A) from a different module than I1+    B) Ix is not marked `OVERLAPPABLE`++This is a slightly involved heuristic, but captures the situation of an+imported module N changing the behavior of existing code. For example, if+condition (2) isn't violated, then the module author M must depend either on a+type-class or type defined in N.++Secondly, when should these heuristics be enforced? We enforced them when the+type-class method call site is in a module marked `-XSafe` or `-XTrustworthy`.+This allows `-XUnsafe` modules to operate without restriction, and for Safe+Haskell inferrence to infer modules with unsafe overlaps as unsafe.++One alternative design would be to also consider if an instance was imported as+a `safe` import or not and only apply the restriction to instances imported+safely. However, since instances are global and can be imported through more+than one path, this alternative doesn't work.++Note [Safe Haskell Overlapping Instances Implementation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++How is this implemented? It's complicated! So we'll step through it all:++ 1) `InstEnv.lookupInstEnv` -- Performs instance resolution, so this is where+    we check if a particular type-class method call is safe or unsafe. We do this+    through the return type, `ClsInstLookupResult`, where the last parameter is a+    list of instances that are unsafe to overlap. When the method call is safe,+    the list is null.++ 2) `TcInteract.matchClassInst` -- This module drives the instance resolution+    / dictionary generation. The return type is `ClsInstResult`, which either+    says no instance matched, or one found, and if it was a safe or unsafe+    overlap.++ 3) `TcInteract.doTopReactDict` -- Takes a dictionary / class constraint and+     tries to resolve it by calling (in part) `matchClassInst`. The resolving+     mechanism has a work list (of constraints) that it process one at a time. If+     the constraint can't be resolved, it's added to an inert set. When compiling+     an `-XSafe` or `-XTrustworthy` module, we follow this approach as we know+     compilation should fail. These are handled as normal constraint resolution+     failures from here-on (see step 6).++     Otherwise, we may be inferring safety (or using `-Wunsafe`), and+     compilation should succeed, but print warnings and/or mark the compiled module+     as `-XUnsafe`. In this case, we call `insertSafeOverlapFailureTcS` which adds+     the unsafe (but resolved!) constraint to the `inert_safehask` field of+     `InertCans`.++ 4) `TcSimplify.simplifyTop`:+       * Call simpl_top, the top-level function for driving the simplifier for+         constraint resolution.++       * Once finished, call `getSafeOverlapFailures` to retrieve the+         list of overlapping instances that were successfully resolved,+         but unsafe. Remember, this is only applicable for generating warnings+         (`-Wunsafe`) or inferring a module unsafe. `-XSafe` and `-XTrustworthy`+         cause compilation failure by not resolving the unsafe constraint at all.++       * For unresolved constraints (all types), call `TcErrors.reportUnsolved`,+         while for resolved but unsafe overlapping dictionary constraints, call+         `TcErrors.warnAllUnsolved`. Both functions convert constraints into a+         warning message for the user.++       * In the case of `warnAllUnsolved` for resolved, but unsafe+         dictionary constraints, we collect the generated warning+         message (pop it) and call `TcRnMonad.recordUnsafeInfer` to+         mark the module we are compiling as unsafe, passing the+         warning message along as the reason.++ 5) `TcErrors.*Unsolved` -- Generates error messages for constraints by+    actually calling `InstEnv.lookupInstEnv` again! Yes, confusing, but all we+    know is the constraint that is unresolved or unsafe. For dictionary, all we+    know is that we need a dictionary of type C, but not what instances are+    available and how they overlap. So we once again call `lookupInstEnv` to+    figure that out so we can generate a helpful error message.++ 6) `TcRnMonad.recordUnsafeInfer` -- Save the unsafe result and reason in an+      IORef called `tcg_safeInfer`.++ 7) `HscMain.tcRnModule'` -- Reads `tcg_safeInfer` after type-checking, calling+    `HscMain.markUnsafeInfer` (passing the reason along) when safe-inferrence+    failed.++Note [No defaulting in the ambiguity check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When simplifying constraints for the ambiguity check, we use+solveWantedsAndDrop, not simpl_top, so that we do no defaulting.+#11947 was an example:+   f :: Num a => Int -> Int+This is ambiguous of course, but we don't want to default the+(Num alpha) constraint to (Num Int)!  Doing so gives a defaulting+warning, but no error.+-}++------------------+simplifyAmbiguityCheck :: Type -> WantedConstraints -> TcM ()+simplifyAmbiguityCheck ty wanteds+  = do { traceTc "simplifyAmbiguityCheck {" (text "type = " <+> ppr ty $$ text "wanted = " <+> ppr wanteds)+       ; (final_wc, _) <- runTcS $ solveWantedsAndDrop wanteds+             -- NB: no defaulting!  See Note [No defaulting in the ambiguity check]++       ; traceTc "End simplifyAmbiguityCheck }" empty++       -- Normally report all errors; but with -XAllowAmbiguousTypes+       -- report only insoluble ones, since they represent genuinely+       -- inaccessible code+       ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes+       ; traceTc "reportUnsolved(ambig) {" empty+       ; unless (allow_ambiguous && not (insolubleWC final_wc))+                (discardResult (reportUnsolved final_wc))+       ; traceTc "reportUnsolved(ambig) }" empty++       ; return () }++------------------+simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind)+simplifyInteractive wanteds+  = traceTc "simplifyInteractive" empty >>+    simplifyTop wanteds++------------------+simplifyDefault :: ThetaType    -- Wanted; has no type variables in it+                -> TcM ()       -- Succeeds if the constraint is soluble+simplifyDefault theta+  = do { traceTc "simplifyDefault" empty+       ; wanteds  <- newWanteds DefaultOrigin theta+       ; unsolved <- runTcSDeriveds (solveWantedsAndDrop (mkSimpleWC wanteds))+       ; reportAllUnsolved unsolved+       ; return () }++------------------+tcCheckSatisfiability :: Bag EvVar -> TcM Bool+-- Return True if satisfiable, False if definitely contradictory+tcCheckSatisfiability given_ids+  = do { lcl_env <- TcM.getLclEnv+       ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env+       ; (res, _ev_binds) <- runTcS $+             do { traceTcS "checkSatisfiability {" (ppr given_ids)+                ; let given_cts = mkGivens given_loc (bagToList given_ids)+                     -- See Note [Superclasses and satisfiability]+                ; solveSimpleGivens given_cts+                ; insols <- getInertInsols+                ; insols <- try_harder insols+                ; traceTcS "checkSatisfiability }" (ppr insols)+                ; return (isEmptyBag insols) }+       ; return res }+ where+    try_harder :: Cts -> TcS Cts+    -- Maybe we have to search up the superclass chain to find+    -- an unsatisfiable constraint.  Example: pmcheck/T3927b.+    -- At the moment we try just once+    try_harder insols+      | not (isEmptyBag insols)   -- We've found that it's definitely unsatisfiable+      = return insols             -- Hurrah -- stop now.+      | otherwise+      = do { pending_given <- getPendingGivenScs+           ; new_given <- makeSuperClasses pending_given+           ; solveSimpleGivens new_given+           ; getInertInsols }++-- | Normalise a type as much as possible using the given constraints.+-- See @Note [tcNormalise]@.+tcNormalise :: Bag EvVar -> Type -> TcM Type+tcNormalise given_ids ty+  = do { lcl_env <- TcM.getLclEnv+       ; let given_loc = mkGivenLoc topTcLevel UnkSkol lcl_env+       ; wanted_ct <- mk_wanted_ct+       ; (res, _ev_binds) <- runTcS $+             do { traceTcS "tcNormalise {" (ppr given_ids)+                ; let given_cts = mkGivens given_loc (bagToList given_ids)+                ; solveSimpleGivens given_cts+                ; wcs <- solveSimpleWanteds (unitBag wanted_ct)+                  -- It's an invariant that this wc_simple will always be+                  -- a singleton Ct, since that's what we fed in as input.+                ; let ty' = case bagToList (wc_simple wcs) of+                              (ct:_) -> ctEvPred (ctEvidence ct)+                              cts    -> pprPanic "tcNormalise" (ppr cts)+                ; traceTcS "tcNormalise }" (ppr ty')+                ; pure ty' }+       ; return res }+  where+    mk_wanted_ct :: TcM Ct+    mk_wanted_ct = do+      let occ = mkVarOcc "$tcNorm"+      name <- newSysName occ+      let ev = mkLocalId name ty+          hole = ExprHole $ OutOfScope occ emptyGlobalRdrEnv+      newHoleCt hole ev ty++{- Note [Superclasses and satisfiability]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Expand superclasses before starting, because (Int ~ Bool), has+(Int ~~ Bool) as a superclass, which in turn has (Int ~N# Bool)+as a superclass, and it's the latter that is insoluble.  See+Note [The equality types story] in TysPrim.++If we fail to prove unsatisfiability we (arbitrarily) try just once to+find superclasses, using try_harder.  Reason: we might have a type+signature+   f :: F op (Implements push) => ..+where F is a type function.  This happened in #3972.++We could do more than once but we'd have to have /some/ limit: in the+the recursive case, we would go on forever in the common case where+the constraints /are/ satisfiable (#10592 comment:12!).++For stratightforard situations without type functions the try_harder+step does nothing.++Note [tcNormalise]+~~~~~~~~~~~~~~~~~~+tcNormalise is a rather atypical entrypoint to the constraint solver. Whereas+most invocations of the constraint solver are intended to simplify a set of+constraints or to decide if a particular set of constraints is satisfiable,+the purpose of tcNormalise is to take a type, plus some local constraints, and+normalise the type as much as possible with respect to those constraints.++Why is this useful? As one example, when coverage-checking an EmptyCase+expression, it's possible that the type of the scrutinee will only reduce+if some local equalities are solved for. See "Wrinkle: Local equalities"+in Note [Type normalisation for EmptyCase] in Check.++To accomplish its stated goal, tcNormalise first feeds the local constraints+into solveSimpleGivens, then stuffs the argument type in a CHoleCan, and feeds+that singleton Ct into solveSimpleWanteds, which reduces the type in the+CHoleCan as much as possible with respect to the local given constraints. When+solveSimpleWanteds is finished, we dig out the type from the CHoleCan and+return that.++***********************************************************************************+*                                                                                 *+*                            Inference+*                                                                                 *+***********************************************************************************++Note [Inferring the type of a let-bound variable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f x = rhs++To infer f's type we do the following:+ * Gather the constraints for the RHS with ambient level *one more than*+   the current one.  This is done by the call+        pushLevelAndCaptureConstraints (tcMonoBinds...)+   in TcBinds.tcPolyInfer++ * Call simplifyInfer to simplify the constraints and decide what to+   quantify over. We pass in the level used for the RHS constraints,+   here called rhs_tclvl.++This ensures that the implication constraint we generate, if any,+has a strictly-increased level compared to the ambient level outside+the let binding.++-}++-- | How should we choose which constraints to quantify over?+data InferMode = ApplyMR          -- ^ Apply the monomorphism restriction,+                                  -- never quantifying over any constraints+               | EagerDefaulting  -- ^ See Note [TcRnExprMode] in TcRnDriver,+                                  -- the :type +d case; this mode refuses+                                  -- to quantify over any defaultable constraint+               | NoRestrictions   -- ^ Quantify over any constraint that+                                  -- satisfies TcType.pickQuantifiablePreds++instance Outputable InferMode where+  ppr ApplyMR         = text "ApplyMR"+  ppr EagerDefaulting = text "EagerDefaulting"+  ppr NoRestrictions  = text "NoRestrictions"++simplifyInfer :: TcLevel               -- Used when generating the constraints+              -> InferMode+              -> [TcIdSigInst]         -- Any signatures (possibly partial)+              -> [(Name, TcTauType)]   -- Variables to be generalised,+                                       -- and their tau-types+              -> WantedConstraints+              -> TcM ([TcTyVar],    -- Quantify over these type variables+                      [EvVar],      -- ... and these constraints (fully zonked)+                      TcEvBinds,    -- ... binding these evidence variables+                      WantedConstraints, -- Redidual as-yet-unsolved constraints+                      Bool)         -- True <=> the residual constraints are insoluble++simplifyInfer rhs_tclvl infer_mode sigs name_taus wanteds+  | isEmptyWC wanteds+   = do { -- When quantifying, we want to preserve any order of variables as they+          -- appear in partial signatures. cf. decideQuantifiedTyVars+          let psig_tv_tys = [ mkTyVarTy tv | sig <- partial_sigs+                                          , (_,tv) <- sig_inst_skols sig ]+              psig_theta  = [ pred | sig <- partial_sigs+                                   , pred <- sig_inst_theta sig ]++       ; gbl_tvs <- tcGetGlobalTyCoVars+       ; dep_vars <- candidateQTyVarsOfTypes (psig_tv_tys ++ psig_theta ++ map snd name_taus)+       ; qtkvs <- quantifyTyVars gbl_tvs dep_vars+       ; traceTc "simplifyInfer: empty WC" (ppr name_taus $$ ppr qtkvs)+       ; return (qtkvs, [], emptyTcEvBinds, emptyWC, False) }++  | otherwise+  = do { traceTc "simplifyInfer {"  $ vcat+             [ text "sigs =" <+> ppr sigs+             , text "binds =" <+> ppr name_taus+             , text "rhs_tclvl =" <+> ppr rhs_tclvl+             , text "infer_mode =" <+> ppr infer_mode+             , text "(unzonked) wanted =" <+> ppr wanteds+             ]++       ; let psig_theta = concatMap sig_inst_theta partial_sigs++       -- First do full-blown solving+       -- NB: we must gather up all the bindings from doing+       -- this solving; hence (runTcSWithEvBinds ev_binds_var).+       -- And note that since there are nested implications,+       -- calling solveWanteds will side-effect their evidence+       -- bindings, so we can't just revert to the input+       -- constraint.++       ; tc_env          <- TcM.getEnv+       ; ev_binds_var    <- TcM.newTcEvBinds+       ; psig_theta_vars <- mapM TcM.newEvVar psig_theta+       ; wanted_transformed_incl_derivs+            <- setTcLevel rhs_tclvl $+               runTcSWithEvBinds ev_binds_var $+               do { let loc         = mkGivenLoc rhs_tclvl UnkSkol $+                                      env_lcl tc_env+                        psig_givens = mkGivens loc psig_theta_vars+                  ; _ <- solveSimpleGivens psig_givens+                         -- See Note [Add signature contexts as givens]+                  ; solveWanteds wanteds }++       -- Find quant_pred_candidates, the predicates that+       -- we'll consider quantifying over+       -- NB1: wanted_transformed does not include anything provable from+       --      the psig_theta; it's just the extra bit+       -- NB2: We do not do any defaulting when inferring a type, this can lead+       --      to less polymorphic types, see Note [Default while Inferring]+       ; wanted_transformed_incl_derivs <- TcM.zonkWC wanted_transformed_incl_derivs+       ; let definite_error = insolubleWC wanted_transformed_incl_derivs+                              -- See Note [Quantification with errors]+                              -- NB: must include derived errors in this test,+                              --     hence "incl_derivs"+             wanted_transformed = dropDerivedWC wanted_transformed_incl_derivs+             quant_pred_candidates+               | definite_error = []+               | otherwise      = ctsPreds (approximateWC False wanted_transformed)++       -- Decide what type variables and constraints to quantify+       -- NB: quant_pred_candidates is already fully zonked+       -- NB: bound_theta are constraints we want to quantify over,+       --     including the psig_theta, which we always quantify over+       -- NB: bound_theta are fully zonked+       ; (qtvs, bound_theta, co_vars) <- decideQuantification infer_mode rhs_tclvl+                                                     name_taus partial_sigs+                                                     quant_pred_candidates+       ; bound_theta_vars <- mapM TcM.newEvVar bound_theta++       -- We must produce bindings for the psig_theta_vars, because we may have+       -- used them in evidence bindings constructed by solveWanteds earlier+       -- Easiest way to do this is to emit them as new Wanteds (#14643)+       ; ct_loc <- getCtLocM AnnOrigin Nothing+       ; let psig_wanted = [ CtWanted { ctev_pred = idType psig_theta_var+                                      , ctev_dest = EvVarDest psig_theta_var+                                      , ctev_nosh = WDeriv+                                      , ctev_loc  = ct_loc }+                           | psig_theta_var <- psig_theta_vars ]++       -- Now construct the residual constraint+       ; residual_wanted <- mkResidualConstraints rhs_tclvl tc_env ev_binds_var+                                 name_taus co_vars qtvs bound_theta_vars+                                 (wanted_transformed `andWC` mkSimpleWC psig_wanted)++         -- All done!+       ; traceTc "} simplifyInfer/produced residual implication for quantification" $+         vcat [ text "quant_pred_candidates =" <+> ppr quant_pred_candidates+              , text "psig_theta =" <+> ppr psig_theta+              , text "bound_theta =" <+> ppr bound_theta+              , text "qtvs ="       <+> ppr qtvs+              , text "definite_error =" <+> ppr definite_error ]++       ; return ( qtvs, bound_theta_vars, TcEvBinds ev_binds_var+                , residual_wanted, definite_error ) }+         -- NB: bound_theta_vars must be fully zonked+  where+    partial_sigs = filter isPartialSig sigs++--------------------+mkResidualConstraints :: TcLevel -> Env TcGblEnv TcLclEnv -> EvBindsVar+                      -> [(Name, TcTauType)]+                      -> VarSet -> [TcTyVar] -> [EvVar]+                      -> WantedConstraints -> TcM WantedConstraints+-- Emit the remaining constraints from the RHS.+-- See Note [Emitting the residual implication in simplifyInfer]+mkResidualConstraints rhs_tclvl tc_env ev_binds_var+                        name_taus co_vars qtvs full_theta_vars wanteds+  | isEmptyWC wanteds+  = return wanteds++  | otherwise+  = do { wanted_simple <- TcM.zonkSimples (wc_simple wanteds)+       ; let (outer_simple, inner_simple) = partitionBag is_mono wanted_simple+             is_mono ct = isWantedCt ct && ctEvId ct `elemVarSet` co_vars++        ; _ <- promoteTyVarSet (tyCoVarsOfCts outer_simple)++        ; let inner_wanted = wanteds { wc_simple = inner_simple }+        ; return (WC { wc_simple = outer_simple+                     , wc_impl   = mk_implic inner_wanted })}+  where+    mk_implic inner_wanted+      | isEmptyWC inner_wanted+      = emptyBag+      | otherwise+      = unitBag (implicationPrototype { ic_tclvl  = rhs_tclvl+                                      , ic_skols  = qtvs+                                      , ic_telescope = Nothing+                                      , ic_given  = full_theta_vars+                                      , ic_wanted = inner_wanted+                                      , ic_binds  = ev_binds_var+                                      , ic_no_eqs = False+                                      , ic_info   = skol_info+                                      , ic_env    = tc_env })++    full_theta = map idType full_theta_vars+    skol_info  = InferSkol [ (name, mkSigmaTy [] full_theta ty)+                           | (name, ty) <- name_taus ]+                 -- Don't add the quantified variables here, because+                 -- they are also bound in ic_skols and we want them+                 -- to be tidied uniformly++--------------------+ctsPreds :: Cts -> [PredType]+ctsPreds cts = [ ctEvPred ev | ct <- bagToList cts+                             , let ev = ctEvidence ct ]++{- Note [Emitting the residual implication in simplifyInfer]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f = e+where f's type is inferred to be something like (a, Proxy k (Int |> co))+and we have an as-yet-unsolved, or perhaps insoluble, constraint+   [W] co :: Type ~ k+We can't form types like (forall co. blah), so we can't generalise over+the coercion variable, and hence we can't generalise over things free in+its kind, in the case 'k'.  But we can still generalise over 'a'.  So+we'll generalise to+   f :: forall a. (a, Proxy k (Int |> co))+Now we do NOT want to form the residual implication constraint+   forall a. [W] co :: Type ~ k+because then co's eventual binding (which will be a value binding if we+use -fdefer-type-errors) won't scope over the entire binding for 'f' (whose+type mentions 'co').  Instead, just as we don't generalise over 'co', we+should not bury its constraint inside the implication.  Instead, we must+put it outside.++That is the reason for the partitionBag in emitResidualConstraints,+which takes the CoVars free in the inferred type, and pulls their+constraints out.  (NB: this set of CoVars should be closed-over-kinds.)++All rather subtle; see #14584.++Note [Add signature contexts as givens]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#11016):+  f2 :: (?x :: Int) => _+  f2 = ?x+or this+  f3 :: a ~ Bool => (a, _)+  f3 = (True, False)+or theis+  f4 :: (Ord a, _) => a -> Bool+  f4 x = x==x++We'll use plan InferGen because there are holes in the type.  But:+ * For f2 we want to have the (?x :: Int) constraint floating around+   so that the functional dependencies kick in.  Otherwise the+   occurrence of ?x on the RHS produces constraint (?x :: alpha), and+   we won't unify alpha:=Int.+ * For f3 we want the (a ~ Bool) available to solve the wanted (a ~ Bool)+   in the RHS+ * For f4 we want to use the (Ord a) in the signature to solve the Eq a+   constraint.++Solution: in simplifyInfer, just before simplifying the constraints+gathered from the RHS, add Given constraints for the context of any+type signatures.++************************************************************************+*                                                                      *+                Quantification+*                                                                      *+************************************************************************++Note [Deciding quantification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the monomorphism restriction does not apply, then we quantify as follows:++* Step 1. Take the global tyvars, and "grow" them using the equality+  constraints+     E.g.  if x:alpha is in the environment, and alpha ~ [beta] (which can+          happen because alpha is untouchable here) then do not quantify over+          beta, because alpha fixes beta, and beta is effectively free in+          the environment too++  We also account for the monomorphism restriction; if it applies,+  add the free vars of all the constraints.++  Result is mono_tvs; we will not quantify over these.++* Step 2. Default any non-mono tyvars (i.e ones that are definitely+  not going to become further constrained), and re-simplify the+  candidate constraints.++  Motivation for re-simplification (#7857): imagine we have a+  constraint (C (a->b)), where 'a :: TYPE l1' and 'b :: TYPE l2' are+  not free in the envt, and instance forall (a::*) (b::*). (C a) => C+  (a -> b) The instance doesn't match while l1,l2 are polymorphic, but+  it will match when we default them to LiftedRep.++  This is all very tiresome.++* Step 3: decide which variables to quantify over, as follows:++  - Take the free vars of the tau-type (zonked_tau_tvs) and "grow"+    them using all the constraints.  These are tau_tvs_plus++  - Use quantifyTyVars to quantify over (tau_tvs_plus - mono_tvs), being+    careful to close over kinds, and to skolemise the quantified tyvars.+    (This actually unifies each quantifies meta-tyvar with a fresh skolem.)++  Result is qtvs.++* Step 4: Filter the constraints using pickQuantifiablePreds and the+  qtvs. We have to zonk the constraints first, so they "see" the+  freshly created skolems.++-}++decideQuantification+  :: InferMode+  -> TcLevel+  -> [(Name, TcTauType)]   -- Variables to be generalised+  -> [TcIdSigInst]         -- Partial type signatures (if any)+  -> [PredType]            -- Candidate theta; already zonked+  -> TcM ( [TcTyVar]       -- Quantify over these (skolems)+         , [PredType]      -- and this context (fully zonked)+         , VarSet)+-- See Note [Deciding quantification]+decideQuantification infer_mode rhs_tclvl name_taus psigs candidates+  = do { -- Step 1: find the mono_tvs+       ; (mono_tvs, candidates, co_vars) <- decideMonoTyVars infer_mode+                                              name_taus psigs candidates++       -- Step 2: default any non-mono tyvars, and re-simplify+       -- This step may do some unification, but result candidates is zonked+       ; candidates <- defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates++       -- Step 3: decide which kind/type variables to quantify over+       ; qtvs <- decideQuantifiedTyVars mono_tvs name_taus psigs candidates++       -- Step 4: choose which of the remaining candidate+       --         predicates to actually quantify over+       -- NB: decideQuantifiedTyVars turned some meta tyvars+       -- into quantified skolems, so we have to zonk again+       ; candidates <- TcM.zonkTcTypes candidates+       ; psig_theta <- TcM.zonkTcTypes (concatMap sig_inst_theta psigs)+       ; let quantifiable_candidates+               = pickQuantifiablePreds (mkVarSet qtvs) candidates+             -- NB: do /not/ run pickQuantifiablePreds over psig_theta,+             -- because we always want to quantify over psig_theta, and not+             -- drop any of them; e.g. CallStack constraints.  c.f #14658++             theta = mkMinimalBySCs id $  -- See Note [Minimize by Superclasses]+                     (psig_theta ++ quantifiable_candidates)++       ; traceTc "decideQuantification"+           (vcat [ text "infer_mode:" <+> ppr infer_mode+                 , text "candidates:" <+> ppr candidates+                 , text "psig_theta:" <+> ppr psig_theta+                 , text "mono_tvs:"   <+> ppr mono_tvs+                 , text "co_vars:"    <+> ppr co_vars+                 , text "qtvs:"       <+> ppr qtvs+                 , text "theta:"      <+> ppr theta ])+       ; return (qtvs, theta, co_vars) }++------------------+decideMonoTyVars :: InferMode+                 -> [(Name,TcType)]+                 -> [TcIdSigInst]+                 -> [PredType]+                 -> TcM (TcTyCoVarSet, [PredType], CoVarSet)+-- Decide which tyvars and covars cannot be generalised:+--   (a) Free in the environment+--   (b) Mentioned in a constraint we can't generalise+--   (c) Connected by an equality to (a) or (b)+-- Also return CoVars that appear free in the final quatified types+--   we can't quantify over these, and we must make sure they are in scope+decideMonoTyVars infer_mode name_taus psigs candidates+  = do { (no_quant, maybe_quant) <- pick infer_mode candidates++       -- If possible, we quantify over partial-sig qtvs, so they are+       -- not mono. Need to zonk them because they are meta-tyvar TyVarTvs+       ; psig_qtvs <- mapM zonkTcTyVarToTyVar $+                      concatMap (map snd . sig_inst_skols) psigs++       ; psig_theta <- mapM TcM.zonkTcType $+                       concatMap sig_inst_theta psigs++       ; taus <- mapM (TcM.zonkTcType . snd) name_taus++       ; mono_tvs0 <- tcGetGlobalTyCoVars+       ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta++             co_vars = coVarsOfTypes (psig_tys ++ taus)+             co_var_tvs = closeOverKinds co_vars+               -- The co_var_tvs are tvs mentioned in the types of covars or+               -- coercion holes. We can't quantify over these covars, so we+               -- must include the variable in their types in the mono_tvs.+               -- E.g.  If we can't quantify over co :: k~Type, then we can't+               --       quantify over k either!  Hence closeOverKinds++             mono_tvs1 = mono_tvs0 `unionVarSet` co_var_tvs++             eq_constraints = filter isEqPrimPred candidates+             mono_tvs2      = growThetaTyVars eq_constraints mono_tvs1++             constrained_tvs = (growThetaTyVars eq_constraints+                                               (tyCoVarsOfTypes no_quant)+                                `minusVarSet` mono_tvs2)+                               `delVarSetList` psig_qtvs+             -- constrained_tvs: the tyvars that we are not going to+             -- quantify solely because of the moonomorphism restriction+             --+             -- (`minusVarSet` mono_tvs1`): a type variable is only+             --   "constrained" (so that the MR bites) if it is not+             --   free in the environment (#13785)+             --+             -- (`delVarSetList` psig_qtvs): if the user has explicitly+             --   asked for quantification, then that request "wins"+             --   over the MR.  Note: do /not/ delete psig_qtvs from+             --   mono_tvs1, because mono_tvs1 cannot under any circumstances+             --   be quantified (#14479); see+             --   Note [Quantification and partial signatures], Wrinkle 3, 4++             mono_tvs = mono_tvs2 `unionVarSet` constrained_tvs++           -- Warn about the monomorphism restriction+       ; warn_mono <- woptM Opt_WarnMonomorphism+       ; when (case infer_mode of { ApplyMR -> warn_mono; _ -> False}) $+         warnTc (Reason Opt_WarnMonomorphism)+                (constrained_tvs `intersectsVarSet` tyCoVarsOfTypes taus)+                mr_msg++       ; traceTc "decideMonoTyVars" $ vcat+           [ text "mono_tvs0 =" <+> ppr mono_tvs0+           , text "mono_tvs1 =" <+> ppr mono_tvs1+           , text "no_quant =" <+> ppr no_quant+           , text "maybe_quant =" <+> ppr maybe_quant+           , text "eq_constraints =" <+> ppr eq_constraints+           , text "mono_tvs =" <+> ppr mono_tvs+           , text "co_vars =" <+> ppr co_vars ]++       ; return (mono_tvs, maybe_quant, co_vars) }+  where+    pick :: InferMode -> [PredType] -> TcM ([PredType], [PredType])+    -- Split the candidates into ones we definitely+    -- won't quantify, and ones that we might+    pick NoRestrictions  cand = return ([], cand)+    pick ApplyMR         cand = return (cand, [])+    pick EagerDefaulting cand = do { os <- xoptM LangExt.OverloadedStrings+                                   ; return (partition (is_int_ct os) cand) }++    -- For EagerDefaulting, do not quantify over+    -- over any interactive class constraint+    is_int_ct ovl_strings pred+      | Just (cls, _) <- getClassPredTys_maybe pred+      = isInteractiveClass ovl_strings cls+      | otherwise+      = False++    pp_bndrs = pprWithCommas (quotes . ppr . fst) name_taus+    mr_msg =+         hang (sep [ text "The Monomorphism Restriction applies to the binding"+                     <> plural name_taus+                   , text "for" <+> pp_bndrs ])+            2 (hsep [ text "Consider giving"+                    , text (if isSingleton name_taus then "it" else "them")+                    , text "a type signature"])++-------------------+defaultTyVarsAndSimplify :: TcLevel+                         -> TyCoVarSet+                         -> [PredType]          -- Assumed zonked+                         -> TcM [PredType]      -- Guaranteed zonked+-- Default any tyvar free in the constraints,+-- and re-simplify in case the defaulting allows further simplification+defaultTyVarsAndSimplify rhs_tclvl mono_tvs candidates+  = do {  -- Promote any tyvars that we cannot generalise+          -- See Note [Promote momomorphic tyvars]+       ; traceTc "decideMonoTyVars: promotion:" (ppr mono_tvs)+       ; (prom, _) <- promoteTyVarSet mono_tvs++       -- Default any kind/levity vars+       ; DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs}+                <- candidateQTyVarsOfTypes candidates+                -- any covars should already be handled by+                -- the logic in decideMonoTyVars, which looks at+                -- the constraints generated++       ; poly_kinds  <- xoptM LangExt.PolyKinds+       ; default_kvs <- mapM (default_one poly_kinds True)+                             (dVarSetElems cand_kvs)+       ; default_tvs <- mapM (default_one poly_kinds False)+                             (dVarSetElems (cand_tvs `minusDVarSet` cand_kvs))+       ; let some_default = or default_kvs || or default_tvs++       ; case () of+           _ | some_default -> simplify_cand candidates+             | prom         -> mapM TcM.zonkTcType candidates+             | otherwise    -> return candidates+       }+  where+    default_one poly_kinds is_kind_var tv+      | not (isMetaTyVar tv)+      = return False+      | tv `elemVarSet` mono_tvs+      = return False+      | otherwise+      = defaultTyVar (not poly_kinds && is_kind_var) tv++    simplify_cand candidates+      = do { clone_wanteds <- newWanteds DefaultOrigin candidates+           ; WC { wc_simple = simples } <- setTcLevel rhs_tclvl $+                                           simplifyWantedsTcM clone_wanteds+              -- Discard evidence; simples is fully zonked++           ; let new_candidates = ctsPreds simples+           ; traceTc "Simplified after defaulting" $+                      vcat [ text "Before:" <+> ppr candidates+                           , text "After:"  <+> ppr new_candidates ]+           ; return new_candidates }++------------------+decideQuantifiedTyVars+   :: TyCoVarSet        -- Monomorphic tyvars+   -> [(Name,TcType)]   -- Annotated theta and (name,tau) pairs+   -> [TcIdSigInst]     -- Partial signatures+   -> [PredType]        -- Candidates, zonked+   -> TcM [TyVar]+-- Fix what tyvars we are going to quantify over, and quantify them+decideQuantifiedTyVars mono_tvs name_taus psigs candidates+  = do {     -- Why psig_tys? We try to quantify over everything free in here+             -- See Note [Quantification and partial signatures]+             --     Wrinkles 2 and 3+       ; psig_tv_tys <- mapM TcM.zonkTcTyVar [ tv | sig <- psigs+                                                  , (_,tv) <- sig_inst_skols sig ]+       ; psig_theta <- mapM TcM.zonkTcType [ pred | sig <- psigs+                                                  , pred <- sig_inst_theta sig ]+       ; tau_tys  <- mapM (TcM.zonkTcType . snd) name_taus+       ; mono_tvs <- TcM.zonkTyCoVarsAndFV mono_tvs++       ; let -- Try to quantify over variables free in these types+             psig_tys = psig_tv_tys ++ psig_theta+             seed_tys = psig_tys ++ tau_tys++             -- Now "grow" those seeds to find ones reachable via 'candidates'+             grown_tcvs = growThetaTyVars candidates (tyCoVarsOfTypes seed_tys)++       -- Now we have to classify them into kind variables and type variables+       -- (sigh) just for the benefit of -XNoPolyKinds; see quantifyTyVars+       --+       -- Keep the psig_tys first, so that candidateQTyVarsOfTypes produces+       -- them in that order, so that the final qtvs quantifies in the same+       -- order as the partial signatures do (#13524)+       ; dv@DV {dv_kvs = cand_kvs, dv_tvs = cand_tvs} <- candidateQTyVarsOfTypes $+                                                         psig_tys ++ candidates ++ tau_tys+       ; let pick     = (`dVarSetIntersectVarSet` grown_tcvs)+             dvs_plus = dv { dv_kvs = pick cand_kvs, dv_tvs = pick cand_tvs }++       ; traceTc "decideQuantifiedTyVars" (vcat+           [ text "candidates =" <+> ppr candidates+           , text "tau_tys =" <+> ppr tau_tys+           , text "seed_tys =" <+> ppr seed_tys+           , text "seed_tcvs =" <+> ppr (tyCoVarsOfTypes seed_tys)+           , text "grown_tcvs =" <+> ppr grown_tcvs+           , text "dvs =" <+> ppr dvs_plus])++       ; quantifyTyVars mono_tvs dvs_plus }++------------------+growThetaTyVars :: ThetaType -> TyCoVarSet -> TyCoVarSet+-- See Note [Growing the tau-tvs using constraints]+growThetaTyVars theta tcvs+  | null theta = tcvs+  | otherwise  = transCloVarSet mk_next seed_tcvs+  where+    seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips+    (ips, non_ips) = partition isIPPred theta+                         -- See Note [Inheriting implicit parameters] in TcType++    mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones+    mk_next so_far = foldr (grow_one so_far) emptyVarSet non_ips+    grow_one so_far pred tcvs+       | pred_tcvs `intersectsVarSet` so_far = tcvs `unionVarSet` pred_tcvs+       | otherwise                           = tcvs+       where+         pred_tcvs = tyCoVarsOfType pred+++{- Note [Promote momomorphic tyvars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Promote any type variables that are free in the environment.  Eg+   f :: forall qtvs. bound_theta => zonked_tau+The free vars of f's type become free in the envt, and hence will show+up whenever 'f' is called.  They may currently at rhs_tclvl, but they+had better be unifiable at the outer_tclvl!  Example: envt mentions+alpha[1]+           tau_ty = beta[2] -> beta[2]+           constraints = alpha ~ [beta]+we don't quantify over beta (since it is fixed by envt)+so we must promote it!  The inferred type is just+  f :: beta -> beta++NB: promoteTyVar ignores coercion variables++Note [Quantification and partial signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When choosing type variables to quantify, the basic plan is to+quantify over all type variables that are+ * free in the tau_tvs, and+ * not forced to be monomorphic (mono_tvs),+   for example by being free in the environment.++However, in the case of a partial type signature, be doing inference+*in the presence of a type signature*. For example:+   f :: _ -> a+   f x = ...+or+   g :: (Eq _a) => _b -> _b+In both cases we use plan InferGen, and hence call simplifyInfer.  But+those 'a' variables are skolems (actually TyVarTvs), and we should be+sure to quantify over them.  This leads to several wrinkles:++* Wrinkle 1.  In the case of a type error+     f :: _ -> Maybe a+     f x = True && x+  The inferred type of 'f' is f :: Bool -> Bool, but there's a+  left-over error of form (HoleCan (Maybe a ~ Bool)).  The error-reporting+  machine expects to find a binding site for the skolem 'a', so we+  add it to the quantified tyvars.++* Wrinkle 2.  Consider the partial type signature+     f :: (Eq _) => Int -> Int+     f x = x+  In normal cases that makes sense; e.g.+     g :: Eq _a => _a -> _a+     g x = x+  where the signature makes the type less general than it could+  be. But for 'f' we must therefore quantify over the user-annotated+  constraints, to get+     f :: forall a. Eq a => Int -> Int+  (thereby correctly triggering an ambiguity error later).  If we don't+  we'll end up with a strange open type+     f :: Eq alpha => Int -> Int+  which isn't ambiguous but is still very wrong.++  Bottom line: Try to quantify over any variable free in psig_theta,+  just like the tau-part of the type.++* Wrinkle 3 (#13482). Also consider+    f :: forall a. _ => Int -> Int+    f x = if (undefined :: a) == undefined then x else 0+  Here we get an (Eq a) constraint, but it's not mentioned in the+  psig_theta nor the type of 'f'.  But we still want to quantify+  over 'a' even if the monomorphism restriction is on.++* Wrinkle 4 (#14479)+    foo :: Num a => a -> a+    foo xxx = g xxx+      where+        g :: forall b. Num b => _ -> b+        g y = xxx + y++  In the signature for 'g', we cannot quantify over 'b' because it turns out to+  get unified with 'a', which is free in g's environment.  So we carefully+  refrain from bogusly quantifying, in TcSimplify.decideMonoTyVars.  We+  report the error later, in TcBinds.chooseInferredQuantifiers.++Note [Growing the tau-tvs using constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(growThetaTyVars insts tvs) is the result of extending the set+    of tyvars, tvs, using all conceivable links from pred++E.g. tvs = {a}, preds = {H [a] b, K (b,Int) c, Eq e}+Then growThetaTyVars preds tvs = {a,b,c}++Notice that+   growThetaTyVars is conservative       if v might be fixed by vs+                                         => v `elem` grow(vs,C)++Note [Quantification with errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we find that the RHS of the definition has some absolutely-insoluble+constraints (including especially "variable not in scope"), we++* Abandon all attempts to find a context to quantify over,+  and instead make the function fully-polymorphic in whatever+  type we have found++* Return a flag from simplifyInfer, indicating that we found an+  insoluble constraint.  This flag is used to suppress the ambiguity+  check for the inferred type, which may well be bogus, and which+  tends to obscure the real error.  This fix feels a bit clunky,+  but I failed to come up with anything better.++Reasons:+    - Avoid downstream errors+    - Do not perform an ambiguity test on a bogus type, which might well+      fail spuriously, thereby obfuscating the original insoluble error.+      #14000 is an example++I tried an alternative approach: simply failM, after emitting the+residual implication constraint; the exception will be caught in+TcBinds.tcPolyBinds, which gives all the binders in the group the type+(forall a. a).  But that didn't work with -fdefer-type-errors, because+the recovery from failM emits no code at all, so there is no function+to run!   But -fdefer-type-errors aspires to produce a runnable program.++NB that we must include *derived* errors in the check for insolubles.+Example:+    (a::*) ~ Int#+We get an insoluble derived error *~#, and we don't want to discard+it before doing the isInsolubleWC test!  (#8262)++Note [Default while Inferring]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Our current plan is that defaulting only happens at simplifyTop and+not simplifyInfer.  This may lead to some insoluble deferred constraints.+Example:++instance D g => C g Int b++constraint inferred = (forall b. 0 => C gamma alpha b) /\ Num alpha+type inferred       = gamma -> gamma++Now, if we try to default (alpha := Int) we will be able to refine the implication to+  (forall b. 0 => C gamma Int b)+which can then be simplified further to+  (forall b. 0 => D gamma)+Finally, we /can/ approximate this implication with (D gamma) and infer the quantified+type:  forall g. D g => g -> g++Instead what will currently happen is that we will get a quantified type+(forall g. g -> g) and an implication:+       forall g. 0 => (forall b. 0 => C g alpha b) /\ Num alpha++Which, even if the simplifyTop defaults (alpha := Int) we will still be left with an+unsolvable implication:+       forall g. 0 => (forall b. 0 => D g)++The concrete example would be:+       h :: C g a s => g -> a -> ST s a+       f (x::gamma) = (\_ -> x) (runST (h x (undefined::alpha)) + 1)++But it is quite tedious to do defaulting and resolve the implication constraints, and+we have not observed code breaking because of the lack of defaulting in inference, so+we don't do it for now.++++Note [Minimize by Superclasses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we quantify over a constraint, in simplifyInfer we need to+quantify over a constraint that is minimal in some sense: For+instance, if the final wanted constraint is (Eq alpha, Ord alpha),+we'd like to quantify over Ord alpha, because we can just get Eq alpha+from superclass selection from Ord alpha. This minimization is what+mkMinimalBySCs does. Then, simplifyInfer uses the minimal constraint+to check the original wanted.+++Note [Avoid unnecessary constraint simplification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    -------- NB NB NB (Jun 12) -------------+    This note not longer applies; see the notes with #4361.+    But I'm leaving it in here so we remember the issue.)+    ----------------------------------------+When inferring the type of a let-binding, with simplifyInfer,+try to avoid unnecessarily simplifying class constraints.+Doing so aids sharing, but it also helps with delicate+situations like++   instance C t => C [t] where ..++   f :: C [t] => ....+   f x = let g y = ...(constraint C [t])...+         in ...+When inferring a type for 'g', we don't want to apply the+instance decl, because then we can't satisfy (C t).  So we+just notice that g isn't quantified over 't' and partition+the constraints before simplifying.++This only half-works, but then let-generalisation only half-works.++*********************************************************************************+*                                                                                 *+*                                 Main Simplifier                                 *+*                                                                                 *+***********************************************************************************++-}++simplifyWantedsTcM :: [CtEvidence] -> TcM WantedConstraints+-- Solve the specified Wanted constraints+-- Discard the evidence binds+-- Discards all Derived stuff in result+-- Postcondition: fully zonked and unflattened constraints+simplifyWantedsTcM wanted+  = do { traceTc "simplifyWantedsTcM {" (ppr wanted)+       ; (result, _) <- runTcS (solveWantedsAndDrop (mkSimpleWC wanted))+       ; result <- TcM.zonkWC result+       ; traceTc "simplifyWantedsTcM }" (ppr result)+       ; return result }++solveWantedsAndDrop :: WantedConstraints -> TcS WantedConstraints+-- Since solveWanteds returns the residual WantedConstraints,+-- it should always be called within a runTcS or something similar,+-- Result is not zonked+solveWantedsAndDrop wanted+  = do { wc <- solveWanteds wanted+       ; return (dropDerivedWC wc) }++solveWanteds :: WantedConstraints -> TcS WantedConstraints+-- so that the inert set doesn't mindlessly propagate.+-- NB: wc_simples may be wanted /or/ derived now+solveWanteds wc@(WC { wc_simple = simples, wc_impl = implics })+  = do { cur_lvl <- TcS.getTcLevel+       ; traceTcS "solveWanteds {" $+         vcat [ text "Level =" <+> ppr cur_lvl+              , ppr wc ]++       ; wc1 <- solveSimpleWanteds simples+                -- Any insoluble constraints are in 'simples' and so get rewritten+                -- See Note [Rewrite insolubles] in TcSMonad++       ; (floated_eqs, implics2) <- solveNestedImplications $+                                    implics `unionBags` wc_impl wc1++       ; dflags   <- getDynFlags+       ; final_wc <- simpl_loop 0 (solverIterations dflags) floated_eqs+                                (wc1 { wc_impl = implics2 })++       ; ev_binds_var <- getTcEvBindsVar+       ; bb <- TcS.getTcEvBindsMap ev_binds_var+       ; traceTcS "solveWanteds }" $+                 vcat [ text "final wc =" <+> ppr final_wc+                      , text "current evbinds  =" <+> ppr (evBindMapBinds bb) ]++       ; return final_wc }++simpl_loop :: Int -> IntWithInf -> Cts+           -> WantedConstraints -> TcS WantedConstraints+simpl_loop n limit floated_eqs wc@(WC { wc_simple = simples })+  | n `intGtLimit` limit+  = do { -- Add an error (not a warning) if we blow the limit,+         -- Typically if we blow the limit we are going to report some other error+         -- (an unsolved constraint), and we don't want that error to suppress+         -- the iteration limit warning!+         addErrTcS (hang (text "solveWanteds: too many iterations"+                   <+> parens (text "limit =" <+> ppr limit))+                2 (vcat [ text "Unsolved:" <+> ppr wc+                        , ppUnless (isEmptyBag floated_eqs) $+                          text "Floated equalities:" <+> ppr floated_eqs+                        , text "Set limit with -fconstraint-solver-iterations=n; n=0 for no limit"+                  ]))+       ; return wc }++  | not (isEmptyBag floated_eqs)+  = simplify_again n limit True (wc { wc_simple = floated_eqs `unionBags` simples })+            -- Put floated_eqs first so they get solved first+            -- NB: the floated_eqs may include /derived/ equalities+            -- arising from fundeps inside an implication++  | superClassesMightHelp wc+  = -- We still have unsolved goals, and apparently no way to solve them,+    -- so try expanding superclasses at this level, both Given and Wanted+    do { pending_given <- getPendingGivenScs+       ; let (pending_wanted, simples1) = getPendingWantedScs simples+       ; if null pending_given && null pending_wanted+           then return wc  -- After all, superclasses did not help+           else+    do { new_given  <- makeSuperClasses pending_given+       ; new_wanted <- makeSuperClasses pending_wanted+       ; solveSimpleGivens new_given -- Add the new Givens to the inert set+       ; simplify_again n limit (null pending_given)+         wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } }++  | otherwise+  = return wc++simplify_again :: Int -> IntWithInf -> Bool+               -> WantedConstraints -> TcS WantedConstraints+-- We have definitely decided to have another go at solving+-- the wanted constraints (we have tried at least once already+simplify_again n limit no_new_given_scs+               wc@(WC { wc_simple = simples, wc_impl = implics })+  = do { csTraceTcS $+         text "simpl_loop iteration=" <> int n+         <+> (parens $ hsep [ text "no new given superclasses =" <+> ppr no_new_given_scs <> comma+                            , int (lengthBag simples) <+> text "simples to solve" ])+       ; traceTcS "simpl_loop: wc =" (ppr wc)++       ; (unifs1, wc1) <- reportUnifications $+                          solveSimpleWanteds $+                          simples++       -- See Note [Cutting off simpl_loop]+       -- We have already tried to solve the nested implications once+       -- Try again only if we have unified some meta-variables+       -- (which is a bit like adding more givens), or we have some+       -- new Given superclasses+       ; let new_implics = wc_impl wc1+       ; if unifs1 == 0       &&+            no_new_given_scs  &&+            isEmptyBag new_implics++           then -- Do not even try to solve the implications+                simpl_loop (n+1) limit emptyBag (wc1 { wc_impl = implics })++           else -- Try to solve the implications+                do { (floated_eqs2, implics2) <- solveNestedImplications $+                                                 implics `unionBags` new_implics+                   ; simpl_loop (n+1) limit floated_eqs2 (wc1 { wc_impl = implics2 })+    } }++solveNestedImplications :: Bag Implication+                        -> TcS (Cts, Bag Implication)+-- Precondition: the TcS inerts may contain unsolved simples which have+-- to be converted to givens before we go inside a nested implication.+solveNestedImplications implics+  | isEmptyBag implics+  = return (emptyBag, emptyBag)+  | otherwise+  = do { traceTcS "solveNestedImplications starting {" empty+       ; (floated_eqs_s, unsolved_implics) <- mapAndUnzipBagM solveImplication implics+       ; let floated_eqs = concatBag floated_eqs_s++       -- ... and we are back in the original TcS inerts+       -- Notice that the original includes the _insoluble_simples so it was safe to ignore+       -- them in the beginning of this function.+       ; traceTcS "solveNestedImplications end }" $+                  vcat [ text "all floated_eqs ="  <+> ppr floated_eqs+                       , text "unsolved_implics =" <+> ppr unsolved_implics ]++       ; return (floated_eqs, catBagMaybes unsolved_implics) }++solveImplication :: Implication    -- Wanted+                 -> TcS (Cts,      -- All wanted or derived floated equalities: var = type+                         Maybe Implication) -- Simplified implication (empty or singleton)+-- Precondition: The TcS monad contains an empty worklist and given-only inerts+-- which after trying to solve this implication we must restore to their original value+solveImplication imp@(Implic { ic_tclvl  = tclvl+                             , ic_binds  = ev_binds_var+                             , ic_skols  = skols+                             , ic_given  = given_ids+                             , ic_wanted = wanteds+                             , ic_info   = info+                             , ic_status = status })+  | isSolvedStatus status+  = return (emptyCts, Just imp)  -- Do nothing++  | otherwise  -- Even for IC_Insoluble it is worth doing more work+               -- The insoluble stuff might be in one sub-implication+               -- and other unsolved goals in another; and we want to+               -- solve the latter as much as possible+  = do { inerts <- getTcSInerts+       ; traceTcS "solveImplication {" (ppr imp $$ text "Inerts" <+> ppr inerts)++       -- commented out; see `where` clause below+       -- ; when debugIsOn check_tc_level++         -- Solve the nested constraints+       ; (no_given_eqs, given_insols, residual_wanted)+            <- nestImplicTcS ev_binds_var tclvl $+               do { let loc    = mkGivenLoc tclvl info (implicLclEnv imp)+                        givens = mkGivens loc given_ids+                  ; solveSimpleGivens givens++                  ; residual_wanted <- solveWanteds wanteds+                        -- solveWanteds, *not* solveWantedsAndDrop, because+                        -- we want to retain derived equalities so we can float+                        -- them out in floatEqualities++                  ; (no_eqs, given_insols) <- getNoGivenEqs tclvl skols+                        -- Call getNoGivenEqs /after/ solveWanteds, because+                        -- solveWanteds can augment the givens, via expandSuperClasses,+                        -- to reveal given superclass equalities++                  ; return (no_eqs, given_insols, residual_wanted) }++       ; (floated_eqs, residual_wanted)+             <- floatEqualities skols given_ids ev_binds_var+                                no_given_eqs residual_wanted++       ; traceTcS "solveImplication 2"+           (ppr given_insols $$ ppr residual_wanted)+       ; let final_wanted = residual_wanted `addInsols` given_insols+             -- Don't lose track of the insoluble givens,+             -- which signal unreachable code; put them in ic_wanted++       ; res_implic <- setImplicationStatus (imp { ic_no_eqs = no_given_eqs+                                                 , ic_wanted = final_wanted })++       ; evbinds <- TcS.getTcEvBindsMap ev_binds_var+       ; tcvs    <- TcS.getTcEvTyCoVars ev_binds_var+       ; traceTcS "solveImplication end }" $ vcat+             [ text "no_given_eqs =" <+> ppr no_given_eqs+             , text "floated_eqs =" <+> ppr floated_eqs+             , text "res_implic =" <+> ppr res_implic+             , text "implication evbinds =" <+> ppr (evBindMapBinds evbinds)+             , text "implication tvcs =" <+> ppr tcvs ]++       ; return (floated_eqs, res_implic) }++  where+    -- TcLevels must be strictly increasing (see (ImplicInv) in+    -- Note [TcLevel and untouchable type variables] in TcType),+    -- and in fact I thinkthey should always increase one level at a time.++    -- Though sensible, this check causes lots of testsuite failures. It is+    -- remaining commented out for now.+    {-+    check_tc_level = do { cur_lvl <- TcS.getTcLevel+                        ; MASSERT2( tclvl == pushTcLevel cur_lvl , text "Cur lvl =" <+> ppr cur_lvl $$ text "Imp lvl =" <+> ppr tclvl ) }+    -}++----------------------+setImplicationStatus :: Implication -> TcS (Maybe Implication)+-- Finalise the implication returned from solveImplication:+--    * Set the ic_status field+--    * Trim the ic_wanted field to remove Derived constraints+-- Precondition: the ic_status field is not already IC_Solved+-- Return Nothing if we can discard the implication altogether+setImplicationStatus implic@(Implic { ic_status     = status+                                    , ic_info       = info+                                    , ic_wanted     = wc+                                    , ic_given      = givens })+ | ASSERT2( not (isSolvedStatus status ), ppr info )+   -- Precondition: we only set the status if it is not already solved+   not (isSolvedWC pruned_wc)+ = do { traceTcS "setImplicationStatus(not-all-solved) {" (ppr implic)++      ; implic <- neededEvVars implic++      ; let new_status | insolubleWC pruned_wc = IC_Insoluble+                       | otherwise             = IC_Unsolved+            new_implic = implic { ic_status = new_status+                                , ic_wanted = pruned_wc }++      ; traceTcS "setImplicationStatus(not-all-solved) }" (ppr new_implic)++      ; return $ Just new_implic }++ | otherwise  -- Everything is solved+              -- Set status to IC_Solved,+              -- and compute the dead givens and outer needs+              -- See Note [Tracking redundant constraints]+ = do { traceTcS "setImplicationStatus(all-solved) {" (ppr implic)++      ; implic@(Implic { ic_need_inner = need_inner+                       , ic_need_outer = need_outer }) <- neededEvVars implic++      ; bad_telescope <- checkBadTelescope implic++      ; let dead_givens | warnRedundantGivens info+                        = filterOut (`elemVarSet` need_inner) givens+                        | otherwise = []   -- None to report++            discard_entire_implication  -- Can we discard the entire implication?+              =  null dead_givens           -- No warning from this implication+              && not bad_telescope+              && isEmptyWC pruned_wc        -- No live children+              && isEmptyVarSet need_outer   -- No needed vars to pass up to parent++            final_status+              | bad_telescope = IC_BadTelescope+              | otherwise     = IC_Solved { ics_dead = dead_givens }+            final_implic = implic { ic_status = final_status+                                  , ic_wanted = pruned_wc }++      ; traceTcS "setImplicationStatus(all-solved) }" $+        vcat [ text "discard:" <+> ppr discard_entire_implication+             , text "new_implic:" <+> ppr final_implic ]++      ; return $ if discard_entire_implication+                 then Nothing+                 else Just final_implic }+ where+   WC { wc_simple = simples, wc_impl = implics } = wc++   pruned_simples = dropDerivedSimples simples+   pruned_implics = filterBag keep_me implics+   pruned_wc = WC { wc_simple = pruned_simples+                  , wc_impl   = pruned_implics }++   keep_me :: Implication -> Bool+   keep_me ic+     | IC_Solved { ics_dead = dead_givens } <- ic_status ic+                          -- Fully solved+     , null dead_givens   -- No redundant givens to report+     , isEmptyBag (wc_impl (ic_wanted ic))+           -- And no children that might have things to report+     = False       -- Tnen we don't need to keep it+     | otherwise+     = True        -- Otherwise, keep it++checkBadTelescope :: Implication -> TcS Bool+-- True <=> the skolems form a bad telescope+-- See Note [Keeping scoped variables in order: Explicit] in TcHsType+checkBadTelescope (Implic { ic_telescope  = m_telescope+                          , ic_skols      = skols })+  | isJust m_telescope+  = do{ skols <- mapM TcS.zonkTyCoVarKind skols+      ; return (go emptyVarSet (reverse skols))}++  | otherwise+  = return False++  where+    go :: TyVarSet   -- skolems that appear *later* than the current ones+       -> [TcTyVar]  -- ordered skolems, in reverse order+       -> Bool       -- True <=> there is an out-of-order skolem+    go _ [] = False+    go later_skols (one_skol : earlier_skols)+      | tyCoVarsOfType (tyVarKind one_skol) `intersectsVarSet` later_skols+      = True+      | otherwise+      = go (later_skols `extendVarSet` one_skol) earlier_skols++warnRedundantGivens :: SkolemInfo -> Bool+warnRedundantGivens (SigSkol ctxt _ _)+  = case ctxt of+       FunSigCtxt _ warn_redundant -> warn_redundant+       ExprSigCtxt                 -> True+       _                           -> False++  -- To think about: do we want to report redundant givens for+  -- pattern synonyms, PatSynSigSkol? c.f #9953, comment:21.+warnRedundantGivens (InstSkol {}) = True+warnRedundantGivens _             = False++neededEvVars :: Implication -> TcS Implication+-- Find all the evidence variables that are "needed",+-- and delete dead evidence bindings+--   See Note [Tracking redundant constraints]+--   See Note [Delete dead Given evidence bindings]+--+--   - Start from initial_seeds (from nested implications)+--+--   - Add free vars of RHS of all Wanted evidence bindings+--     and coercion variables accumulated in tcvs (all Wanted)+--+--   - Generate 'needed', the needed set of EvVars, by doing transitive+--     closure through Given bindings+--     e.g.   Needed {a,b}+--            Given  a = sc_sel a2+--            Then a2 is needed too+--+--   - Prune out all Given bindings that are not needed+--+--   - From the 'needed' set, delete ev_bndrs, the binders of the+--     evidence bindings, to give the final needed variables+--+neededEvVars implic@(Implic { ic_given = givens+                            , ic_binds = ev_binds_var+                            , ic_wanted = WC { wc_impl = implics }+                            , ic_need_inner = old_needs })+ = do { ev_binds <- TcS.getTcEvBindsMap ev_binds_var+      ; tcvs     <- TcS.getTcEvTyCoVars ev_binds_var++      ; let seeds1        = foldrBag add_implic_seeds old_needs implics+            seeds2        = foldEvBindMap add_wanted seeds1 ev_binds+            seeds3        = seeds2 `unionVarSet` tcvs+            need_inner    = findNeededEvVars ev_binds seeds3+            live_ev_binds = filterEvBindMap (needed_ev_bind need_inner) ev_binds+            need_outer    = foldEvBindMap del_ev_bndr need_inner live_ev_binds+                            `delVarSetList` givens++      ; TcS.setTcEvBindsMap ev_binds_var live_ev_binds+           -- See Note [Delete dead Given evidence bindings]++      ; traceTcS "neededEvVars" $+        vcat [ text "old_needs:" <+> ppr old_needs+             , text "seeds3:" <+> ppr seeds3+             , text "tcvs:" <+> ppr tcvs+             , text "ev_binds:" <+> ppr ev_binds+             , text "live_ev_binds:" <+> ppr live_ev_binds ]++      ; return (implic { ic_need_inner = need_inner+                       , ic_need_outer = need_outer }) }+ where+   add_implic_seeds (Implic { ic_need_outer = needs }) acc+      = needs `unionVarSet` acc++   needed_ev_bind needed (EvBind { eb_lhs = ev_var+                                 , eb_is_given = is_given })+     | is_given  = ev_var `elemVarSet` needed+     | otherwise = True   -- Keep all wanted bindings++   del_ev_bndr :: EvBind -> VarSet -> VarSet+   del_ev_bndr (EvBind { eb_lhs = v }) needs = delVarSet needs v++   add_wanted :: EvBind -> VarSet -> VarSet+   add_wanted (EvBind { eb_is_given = is_given, eb_rhs = rhs }) needs+     | is_given  = needs  -- Add the rhs vars of the Wanted bindings only+     | otherwise = evVarsOfTerm rhs `unionVarSet` needs+++{- Note [Delete dead Given evidence bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As a result of superclass expansion, we speculatively+generate evidence bindings for Givens. E.g.+   f :: (a ~ b) => a -> b -> Bool+   f x y = ...+We'll have+   [G] d1 :: (a~b)+and we'll specuatively generate the evidence binding+   [G] d2 :: (a ~# b) = sc_sel d++Now d2 is available for solving.  But it may not be needed!  Usually+such dead superclass selections will eventually be dropped as dead+code, but:++ * It won't always be dropped (#13032).  In the case of an+   unlifted-equality superclass like d2 above, we generate+       case heq_sc d1 of d2 -> ...+   and we can't (in general) drop that case exrpession in case+   d1 is bottom.  So it's technically unsound to have added it+   in the first place.++ * Simply generating all those extra superclasses can generate lots of+   code that has to be zonked, only to be discarded later.  Better not+   to generate it in the first place.++   Moreover, if we simplify this implication more than once+   (e.g. because we can't solve it completely on the first iteration+   of simpl_looop), we'll generate all the same bindings AGAIN!++Easy solution: take advantage of the work we are doing to track dead+(unused) Givens, and use it to prune the Given bindings too.  This is+all done by neededEvVars.++This led to a remarkable 25% overall compiler allocation decrease in+test T12227.++But we don't get to discard all redundant equality superclasses, alas;+see #15205.++Note [Tracking redundant constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With Opt_WarnRedundantConstraints, GHC can report which+constraints of a type signature (or instance declaration) are+redundant, and can be omitted.  Here is an overview of how it+works:++----- What is a redundant constraint?++* The things that can be redundant are precisely the Given+  constraints of an implication.++* A constraint can be redundant in two different ways:+  a) It is implied by other givens.  E.g.+       f :: (Eq a, Ord a)     => blah   -- Eq a unnecessary+       g :: (Eq a, a~b, Eq b) => blah   -- Either Eq a or Eq b unnecessary+  b) It is not needed by the Wanted constraints covered by the+     implication E.g.+       f :: Eq a => a -> Bool+       f x = True  -- Equality not used++*  To find (a), when we have two Given constraints,+   we must be careful to drop the one that is a naked variable (if poss).+   So if we have+       f :: (Eq a, Ord a) => blah+   then we may find [G] sc_sel (d1::Ord a) :: Eq a+                    [G] d2 :: Eq a+   We want to discard d2 in favour of the superclass selection from+   the Ord dictionary.  This is done by TcInteract.solveOneFromTheOther+   See Note [Replacement vs keeping].++* To find (b) we need to know which evidence bindings are 'wanted';+  hence the eb_is_given field on an EvBind.++----- How tracking works++* The ic_need fields of an Implic records in-scope (given) evidence+  variables bound by the context, that were needed to solve this+  implication (so far).  See the declaration of Implication.++* When the constraint solver finishes solving all the wanteds in+  an implication, it sets its status to IC_Solved++  - The ics_dead field, of IC_Solved, records the subset of this+    implication's ic_given that are redundant (not needed).++* We compute which evidence variables are needed by an implication+  in setImplicationStatus.  A variable is needed if+    a) it is free in the RHS of a Wanted EvBind,+    b) it is free in the RHS of an EvBind whose LHS is needed,+    c) it is in the ics_need of a nested implication.++* We need to be careful not to discard an implication+  prematurely, even one that is fully solved, because we might+  thereby forget which variables it needs, and hence wrongly+  report a constraint as redundant.  But we can discard it once+  its free vars have been incorporated into its parent; or if it+  simply has no free vars. This careful discarding is also+  handled in setImplicationStatus.++----- Reporting redundant constraints++* TcErrors does the actual warning, in warnRedundantConstraints.++* We don't report redundant givens for *every* implication; only+  for those which reply True to TcSimplify.warnRedundantGivens:++   - For example, in a class declaration, the default method *can*+     use the class constraint, but it certainly doesn't *have* to,+     and we don't want to report an error there.++   - More subtly, in a function definition+       f :: (Ord a, Ord a, Ix a) => a -> a+       f x = rhs+     we do an ambiguity check on the type (which would find that one+     of the Ord a constraints was redundant), and then we check that+     the definition has that type (which might find that both are+     redundant).  We don't want to report the same error twice, so we+     disable it for the ambiguity check.  Hence using two different+     FunSigCtxts, one with the warn-redundant field set True, and the+     other set False in+        - TcBinds.tcSpecPrag+        - TcBinds.tcTySig++  This decision is taken in setImplicationStatus, rather than TcErrors+  so that we can discard implication constraints that we don't need.+  So ics_dead consists only of the *reportable* redundant givens.++----- Shortcomings++Consider (see #9939)+    f2 :: (Eq a, Ord a) => a -> a -> Bool+    -- Ord a redundant, but Eq a is reported+    f2 x y = (x == y)++We report (Eq a) as redundant, whereas actually (Ord a) is.  But it's+really not easy to detect that!+++Note [Cutting off simpl_loop]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is very important not to iterate in simpl_loop unless there is a chance+of progress.  #8474 is a classic example:++  * There's a deeply-nested chain of implication constraints.+       ?x:alpha => ?y1:beta1 => ... ?yn:betan => [W] ?x:Int++  * From the innermost one we get a [D] alpha ~ Int,+    but alpha is untouchable until we get out to the outermost one++  * We float [D] alpha~Int out (it is in floated_eqs), but since alpha+    is untouchable, the solveInteract in simpl_loop makes no progress++  * So there is no point in attempting to re-solve+       ?yn:betan => [W] ?x:Int+    via solveNestedImplications, because we'll just get the+    same [D] again++  * If we *do* re-solve, we'll get an ininite loop. It is cut off by+    the fixed bound of 10, but solving the next takes 10*10*...*10 (ie+    exponentially many) iterations!++Conclusion: we should call solveNestedImplications only if we did+some unification in solveSimpleWanteds; because that's the only way+we'll get more Givens (a unification is like adding a Given) to+allow the implication to make progress.+-}++promoteTyVar :: TcTyVar -> TcM (Bool, TcTyVar)+-- When we float a constraint out of an implication we must restore+-- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in TcType+-- Return True <=> we did some promotion+-- Also returns either the original tyvar (no promotion) or the new one+-- See Note [Promoting unification variables]+promoteTyVar tv+  = do { tclvl <- TcM.getTcLevel+       ; if (isFloatedTouchableMetaTyVar tclvl tv)+         then do { cloned_tv <- TcM.cloneMetaTyVar tv+                 ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl+                 ; TcM.writeMetaTyVar tv (mkTyVarTy rhs_tv)+                 ; return (True, rhs_tv) }+         else return (False, tv) }++-- Returns whether or not *any* tyvar is defaulted+promoteTyVarSet :: TcTyVarSet -> TcM (Bool, TcTyVarSet)+promoteTyVarSet tvs+  = do { (bools, tyvars) <- mapAndUnzipM promoteTyVar (nonDetEltsUniqSet tvs)+           -- non-determinism is OK because order of promotion doesn't matter++       ; return (or bools, mkVarSet tyvars) }++promoteTyVarTcS :: TcTyVar  -> TcS ()+-- When we float a constraint out of an implication we must restore+-- invariant (WantedInv) in Note [TcLevel and untouchable type variables] in TcType+-- See Note [Promoting unification variables]+-- We don't just call promoteTyVar because we want to use unifyTyVar,+-- not writeMetaTyVar+promoteTyVarTcS tv+  = do { tclvl <- TcS.getTcLevel+       ; when (isFloatedTouchableMetaTyVar tclvl tv) $+         do { cloned_tv <- TcS.cloneMetaTyVar tv+            ; let rhs_tv = setMetaTyVarTcLevel cloned_tv tclvl+            ; unifyTyVar tv (mkTyVarTy rhs_tv) } }++-- | Like 'defaultTyVar', but in the TcS monad.+defaultTyVarTcS :: TcTyVar -> TcS Bool+defaultTyVarTcS the_tv+  | isRuntimeRepVar the_tv+  , not (isTyVarTyVar the_tv)+    -- TyVarTvs should only be unified with a tyvar+    -- never with a type; c.f. TcMType.defaultTyVar+    -- and Note [Inferring kinds for type declarations] in TcTyClsDecls+  = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv)+       ; unifyTyVar the_tv liftedRepTy+       ; return True }+  | otherwise+  = return False  -- the common case++approximateWC :: Bool -> WantedConstraints -> Cts+-- Postcondition: Wanted or Derived Cts+-- See Note [ApproximateWC]+approximateWC float_past_equalities wc+  = float_wc emptyVarSet wc+  where+    float_wc :: TcTyCoVarSet -> WantedConstraints -> Cts+    float_wc trapping_tvs (WC { wc_simple = simples, wc_impl = implics })+      = filterBag (is_floatable trapping_tvs) simples `unionBags`+        do_bag (float_implic trapping_tvs) implics+      where++    float_implic :: TcTyCoVarSet -> Implication -> Cts+    float_implic trapping_tvs imp+      | float_past_equalities || ic_no_eqs imp+      = float_wc new_trapping_tvs (ic_wanted imp)+      | otherwise   -- Take care with equalities+      = emptyCts    -- See (1) under Note [ApproximateWC]+      where+        new_trapping_tvs = trapping_tvs `extendVarSetList` ic_skols imp++    do_bag :: (a -> Bag c) -> Bag a -> Bag c+    do_bag f = foldrBag (unionBags.f) emptyBag++    is_floatable skol_tvs ct+       | isGivenCt ct     = False+       | isHoleCt ct      = False+       | insolubleEqCt ct = False+       | otherwise        = tyCoVarsOfCt ct `disjointVarSet` skol_tvs++{- Note [ApproximateWC]+~~~~~~~~~~~~~~~~~~~~~~~+approximateWC takes a constraint, typically arising from the RHS of a+let-binding whose type we are *inferring*, and extracts from it some+*simple* constraints that we might plausibly abstract over.  Of course+the top-level simple constraints are plausible, but we also float constraints+out from inside, if they are not captured by skolems.++The same function is used when doing type-class defaulting (see the call+to applyDefaultingRules) to extract constraints that that might be defaulted.++There is one caveat:++1.  When infering most-general types (in simplifyInfer), we do *not*+    float anything out if the implication binds equality constraints,+    because that defeats the OutsideIn story.  Consider+       data T a where+         TInt :: T Int+         MkT :: T a++       f TInt = 3::Int++    We get the implication (a ~ Int => res ~ Int), where so far we've decided+      f :: T a -> res+    We don't want to float (res~Int) out because then we'll infer+      f :: T a -> Int+    which is only on of the possible types. (GHC 7.6 accidentally *did*+    float out of such implications, which meant it would happily infer+    non-principal types.)++   HOWEVER (#12797) in findDefaultableGroups we are not worried about+   the most-general type; and we /do/ want to float out of equalities.+   Hence the boolean flag to approximateWC.++------ Historical note -----------+There used to be a second caveat, driven by #8155++   2. We do not float out an inner constraint that shares a type variable+      (transitively) with one that is trapped by a skolem.  Eg+          forall a.  F a ~ beta, Integral beta+      We don't want to float out (Integral beta).  Doing so would be bad+      when defaulting, because then we'll default beta:=Integer, and that+      makes the error message much worse; we'd get+          Can't solve  F a ~ Integer+      rather than+          Can't solve  Integral (F a)++      Moreover, floating out these "contaminated" constraints doesn't help+      when generalising either. If we generalise over (Integral b), we still+      can't solve the retained implication (forall a. F a ~ b).  Indeed,+      arguably that too would be a harder error to understand.++But this transitive closure stuff gives rise to a complex rule for+when defaulting actually happens, and one that was never documented.+Moreover (#12923), the more complex rule is sometimes NOT what+you want.  So I simply removed the extra code to implement the+contamination stuff.  There was zero effect on the testsuite (not even+#8155).+------ End of historical note -----------+++Note [DefaultTyVar]+~~~~~~~~~~~~~~~~~~~+defaultTyVar is used on any un-instantiated meta type variables to+default any RuntimeRep variables to LiftedRep.  This is important+to ensure that instance declarations match.  For example consider++     instance Show (a->b)+     foo x = show (\_ -> True)++Then we'll get a constraint (Show (p ->q)) where p has kind (TYPE r),+and that won't match the tcTypeKind (*) in the instance decl.  See tests+tc217 and tc175.++We look only at touchable type variables. No further constraints+are going to affect these type variables, so it's time to do it by+hand.  However we aren't ready to default them fully to () or+whatever, because the type-class defaulting rules have yet to run.++An alternate implementation would be to emit a derived constraint setting+the RuntimeRep variable to LiftedRep, but this seems unnecessarily indirect.++Note [Promote _and_ default when inferring]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we are inferring a type, we simplify the constraint, and then use+approximateWC to produce a list of candidate constraints.  Then we MUST++  a) Promote any meta-tyvars that have been floated out by+     approximateWC, to restore invariant (WantedInv) described in+     Note [TcLevel and untouchable type variables] in TcType.++  b) Default the kind of any meta-tyvars that are not mentioned in+     in the environment.++To see (b), suppose the constraint is (C ((a :: OpenKind) -> Int)), and we+have an instance (C ((x:*) -> Int)).  The instance doesn't match -- but it+should!  If we don't solve the constraint, we'll stupidly quantify over+(C (a->Int)) and, worse, in doing so skolemiseQuantifiedTyVar will quantify over+(b:*) instead of (a:OpenKind), which can lead to disaster; see #7332.+#7641 is a simpler example.++Note [Promoting unification variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we float an equality out of an implication we must "promote" free+unification variables of the equality, in order to maintain Invariant+(WantedInv) from Note [TcLevel and untouchable type variables] in+TcType.  for the leftover implication.++This is absolutely necessary. Consider the following example. We start+with two implications and a class with a functional dependency.++    class C x y | x -> y+    instance C [a] [a]++    (I1)      [untch=beta]forall b. 0 => F Int ~ [beta]+    (I2)      [untch=beta]forall c. 0 => F Int ~ [[alpha]] /\ C beta [c]++We float (F Int ~ [beta]) out of I1, and we float (F Int ~ [[alpha]]) out of I2.+They may react to yield that (beta := [alpha]) which can then be pushed inwards+the leftover of I2 to get (C [alpha] [a]) which, using the FunDep, will mean that+(alpha := a). In the end we will have the skolem 'b' escaping in the untouchable+beta! Concrete example is in indexed_types/should_fail/ExtraTcsUntch.hs:++    class C x y | x -> y where+     op :: x -> y -> ()++    instance C [a] [a]++    type family F a :: *++    h :: F Int -> ()+    h = undefined++    data TEx where+      TEx :: a -> TEx++    f (x::beta) =+        let g1 :: forall b. b -> ()+            g1 _ = h [x]+            g2 z = case z of TEx y -> (h [[undefined]], op x [y])+        in (g1 '3', g2 undefined)++++*********************************************************************************+*                                                                               *+*                          Floating equalities                                  *+*                                                                               *+*********************************************************************************++Note [Float Equalities out of Implications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For ordinary pattern matches (including existentials) we float+equalities out of implications, for instance:+     data T where+       MkT :: Eq a => a -> T+     f x y = case x of MkT _ -> (y::Int)+We get the implication constraint (x::T) (y::alpha):+     forall a. [untouchable=alpha] Eq a => alpha ~ Int+We want to float out the equality into a scope where alpha is no+longer untouchable, to solve the implication!++But we cannot float equalities out of implications whose givens may+yield or contain equalities:++      data T a where+        T1 :: T Int+        T2 :: T Bool+        T3 :: T a++      h :: T a -> a -> Int++      f x y = case x of+                T1 -> y::Int+                T2 -> y::Bool+                T3 -> h x y++We generate constraint, for (x::T alpha) and (y :: beta):+   [untouchables = beta] (alpha ~ Int => beta ~ Int)   -- From 1st branch+   [untouchables = beta] (alpha ~ Bool => beta ~ Bool) -- From 2nd branch+   (alpha ~ beta)                                      -- From 3rd branch++If we float the equality (beta ~ Int) outside of the first implication and+the equality (beta ~ Bool) out of the second we get an insoluble constraint.+But if we just leave them inside the implications, we unify alpha := beta and+solve everything.++Principle:+    We do not want to float equalities out which may+    need the given *evidence* to become soluble.++Consequence: classes with functional dependencies don't matter (since there is+no evidence for a fundep equality), but equality superclasses do matter (since+they carry evidence).+-}++floatEqualities :: [TcTyVar] -> [EvId] -> EvBindsVar -> Bool+                -> WantedConstraints+                -> TcS (Cts, WantedConstraints)+-- Main idea: see Note [Float Equalities out of Implications]+--+-- Precondition: the wc_simple of the incoming WantedConstraints are+--               fully zonked, so that we can see their free variables+--+-- Postcondition: The returned floated constraints (Cts) are only+--                Wanted or Derived+--+-- Also performs some unifications (via promoteTyVar), adding to+-- monadically-carried ty_binds. These will be used when processing+-- floated_eqs later+--+-- Subtleties: Note [Float equalities from under a skolem binding]+--             Note [Skolem escape]+--             Note [What prevents a constraint from floating]+floatEqualities skols given_ids ev_binds_var no_given_eqs+                wanteds@(WC { wc_simple = simples })+  | not no_given_eqs  -- There are some given equalities, so don't float+  = return (emptyBag, wanteds)   -- Note [Float Equalities out of Implications]++  | otherwise+  = do { -- First zonk: the inert set (from whence they came) is fully+         -- zonked, but unflattening may have filled in unification+         -- variables, and we /must/ see them.  Otherwise we may float+         -- constraints that mention the skolems!+         simples <- TcS.zonkSimples simples+       ; binds   <- TcS.getTcEvBindsMap ev_binds_var++       -- Now we can pick the ones to float+       -- The constraints are un-flattened and de-canonicalised+       ; let (candidate_eqs, no_float_cts) = partitionBag is_float_eq_candidate simples++             seed_skols = mkVarSet skols     `unionVarSet`+                          mkVarSet given_ids `unionVarSet`+                          foldrBag add_non_flt_ct emptyVarSet no_float_cts `unionVarSet`+                          foldEvBindMap add_one_bind emptyVarSet binds+             -- seed_skols: See Note [What prevents a constraint from floating] (1,2,3)+             -- Include the EvIds of any non-floating constraints++             extended_skols = transCloVarSet (add_captured_ev_ids candidate_eqs) seed_skols+                 -- extended_skols contains the EvIds of all the trapped constraints+                 -- See Note [What prevents a constraint from floating] (3)++             (flt_eqs, no_flt_eqs) = partitionBag (is_floatable extended_skols)+                                                  candidate_eqs++             remaining_simples = no_float_cts `andCts` no_flt_eqs++       -- Promote any unification variables mentioned in the floated equalities+       -- See Note [Promoting unification variables]+       ; mapM_ promoteTyVarTcS (tyCoVarsOfCtsList flt_eqs)++       ; traceTcS "floatEqualities" (vcat [ text "Skols =" <+> ppr skols+                                          , text "Extended skols =" <+> ppr extended_skols+                                          , text "Simples =" <+> ppr simples+                                          , text "Candidate eqs =" <+> ppr candidate_eqs+                                          , text "Floated eqs =" <+> ppr flt_eqs])+       ; return ( flt_eqs, wanteds { wc_simple = remaining_simples } ) }++  where+    add_one_bind :: EvBind -> VarSet -> VarSet+    add_one_bind bind acc = extendVarSet acc (evBindVar bind)++    add_non_flt_ct :: Ct -> VarSet -> VarSet+    add_non_flt_ct ct acc | isDerivedCt ct = acc+                          | otherwise      = extendVarSet acc (ctEvId ct)++    is_floatable :: VarSet -> Ct -> Bool+    is_floatable skols ct+      | isDerivedCt ct = not (tyCoVarsOfCt ct `intersectsVarSet` skols)+      | otherwise      = not (ctEvId ct `elemVarSet` skols)++    add_captured_ev_ids :: Cts -> VarSet -> VarSet+    add_captured_ev_ids cts skols = foldrBag extra_skol emptyVarSet cts+       where+         extra_skol ct acc+           | isDerivedCt ct                           = acc+           | tyCoVarsOfCt ct `intersectsVarSet` skols = extendVarSet acc (ctEvId ct)+           | otherwise                                = acc++    -- Identify which equalities are candidates for floating+    -- Float out alpha ~ ty, or ty ~ alpha which might be unified outside+    -- See Note [Which equalities to float]+    is_float_eq_candidate ct+      | pred <- ctPred ct+      , EqPred NomEq ty1 ty2 <- classifyPredType pred+      , tcTypeKind ty1 `tcEqType` tcTypeKind ty2+      = case (tcGetTyVar_maybe ty1, tcGetTyVar_maybe ty2) of+          (Just tv1, _) -> float_tv_eq_candidate tv1 ty2+          (_, Just tv2) -> float_tv_eq_candidate tv2 ty1+          _             -> False+      | otherwise = False++    float_tv_eq_candidate tv1 ty2  -- See Note [Which equalities to float]+      =  isMetaTyVar tv1+      && (not (isTyVarTyVar tv1) || isTyVarTy ty2)+++{- Note [Float equalities from under a skolem binding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Which of the simple equalities can we float out?  Obviously, only+ones that don't mention the skolem-bound variables.  But that is+over-eager. Consider+   [2] forall a. F a beta[1] ~ gamma[2], G beta[1] gamma[2] ~ Int+The second constraint doesn't mention 'a'.  But if we float it,+we'll promote gamma[2] to gamma'[1].  Now suppose that we learn that+beta := Bool, and F a Bool = a, and G Bool _ = Int.  Then we'll+we left with the constraint+   [2] forall a. a ~ gamma'[1]+which is insoluble because gamma became untouchable.++Solution: float only constraints that stand a jolly good chance of+being soluble simply by being floated, namely ones of form+      a ~ ty+where 'a' is a currently-untouchable unification variable, but may+become touchable by being floated (perhaps by more than one level).++We had a very complicated rule previously, but this is nice and+simple.  (To see the notes, look at this Note in a version of+TcSimplify prior to Oct 2014).++Note [Which equalities to float]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Which equalities should we float?  We want to float ones where there+is a decent chance that floating outwards will allow unification to+happen.  In particular, float out equalities that are:++* Of form (alpha ~# ty) or (ty ~# alpha), where+   * alpha is a meta-tyvar.+   * And 'alpha' is not a TyVarTv with 'ty' being a non-tyvar.  In that+     case, floating out won't help either, and it may affect grouping+     of error messages.++* Homogeneous (both sides have the same kind). Why only homogeneous?+  Because heterogeneous equalities have derived kind equalities.+  See Note [Equalities with incompatible kinds] in TcCanonical.+  If we float out a hetero equality, then it will spit out the same+  derived kind equality again, which might create duplicate error+  messages.++  Instead, we do float out the kind equality (if it's worth floating+  out, as above). If/when we solve it, we'll be able to rewrite the+  original hetero equality to be homogeneous, and then perhaps make+  progress / float it out. The duplicate error message was spotted in+  typecheck/should_fail/T7368.++* Nominal.  No point in floating (alpha ~R# ty), because we do not+  unify representational equalities even if alpha is touchable.+  See Note [Do not unify representational equalities] in TcInteract.++Note [Skolem escape]+~~~~~~~~~~~~~~~~~~~~+You might worry about skolem escape with all this floating.+For example, consider+    [2] forall a. (a ~ F beta[2] delta,+                   Maybe beta[2] ~ gamma[1])++The (Maybe beta ~ gamma) doesn't mention 'a', so we float it, and+solve with gamma := beta. But what if later delta:=Int, and+  F b Int = b.+Then we'd get a ~ beta[2], and solve to get beta:=a, and now the+skolem has escaped!++But it's ok: when we float (Maybe beta[2] ~ gamma[1]), we promote beta[2]+to beta[1], and that means the (a ~ beta[1]) will be stuck, as it should be.++Note [What prevents a constraint from floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What /prevents/ a constraint from floating?  If it mentions one of the+"bound variables of the implication".  What are they?++The "bound variables of the implication" are++  1. The skolem type variables `ic_skols`++  2. The "given" evidence variables `ic_given`.  Example:+         forall a. (co :: t1 ~# t2) =>  [W] co2 : (a ~# b |> co)+     Here 'co' is bound++  3. The binders of all evidence bindings in `ic_binds`. Example+         forall a. (d :: t1 ~ t2)+            EvBinds { (co :: t1 ~# t2) = superclass-sel d }+            => [W] co2 : (a ~# b |> co)+     Here `co` is gotten by superclass selection from `d`, and the+     wanted constraint co2 must not float.++  4. And the evidence variable of any equality constraint (incl+     Wanted ones) whose type mentions a bound variable.  Example:+        forall k. [W] co1 :: t1 ~# t2 |> co2+                  [W] co2 :: k ~# *+     Here, since `k` is bound, so is `co2` and hence so is `co1`.++Here (1,2,3) are handled by the "seed_skols" calculation, and+(4) is done by the transCloVarSet call.++The possible dependence on givens, and evidence bindings, is more+subtle than we'd realised at first.  See #14584.+++*********************************************************************************+*                                                                               *+*                          Defaulting and disambiguation                        *+*                                                                               *+*********************************************************************************+-}++applyDefaultingRules :: WantedConstraints -> TcS Bool+-- True <=> I did some defaulting, by unifying a meta-tyvar+-- Input WantedConstraints are not necessarily zonked++applyDefaultingRules wanteds+  | isEmptyWC wanteds+  = return False+  | otherwise+  = do { info@(default_tys, _) <- getDefaultInfo+       ; wanteds               <- TcS.zonkWC wanteds++       ; let groups = findDefaultableGroups info wanteds++       ; traceTcS "applyDefaultingRules {" $+                  vcat [ text "wanteds =" <+> ppr wanteds+                       , text "groups  =" <+> ppr groups+                       , text "info    =" <+> ppr info ]++       ; something_happeneds <- mapM (disambigGroup default_tys) groups++       ; traceTcS "applyDefaultingRules }" (ppr something_happeneds)++       ; return (or something_happeneds) }++findDefaultableGroups+    :: ( [Type]+       , (Bool,Bool) )     -- (Overloaded strings, extended default rules)+    -> WantedConstraints   -- Unsolved (wanted or derived)+    -> [(TyVar, [Ct])]+findDefaultableGroups (default_tys, (ovl_strings, extended_defaults)) wanteds+  | null default_tys+  = []+  | otherwise+  = [ (tv, map fstOf3 group)+    | group'@((_,_,tv) :| _) <- unary_groups+    , let group = toList group'+    , defaultable_tyvar tv+    , defaultable_classes (map sndOf3 group) ]+  where+    simples                = approximateWC True wanteds+    (unaries, non_unaries) = partitionWith find_unary (bagToList simples)+    unary_groups           = equivClasses cmp_tv unaries++    unary_groups :: [NonEmpty (Ct, Class, TcTyVar)] -- (C tv) constraints+    unaries      :: [(Ct, Class, TcTyVar)]          -- (C tv) constraints+    non_unaries  :: [Ct]                            -- and *other* constraints++        -- Finds unary type-class constraints+        -- But take account of polykinded classes like Typeable,+        -- which may look like (Typeable * (a:*))   (#8931)+    find_unary :: Ct -> Either (Ct, Class, TyVar) Ct+    find_unary cc+        | Just (cls,tys)   <- getClassPredTys_maybe (ctPred cc)+        , [ty] <- filterOutInvisibleTypes (classTyCon cls) tys+              -- Ignore invisible arguments for this purpose+        , Just tv <- tcGetTyVar_maybe ty+        , isMetaTyVar tv  -- We might have runtime-skolems in GHCi, and+                          -- we definitely don't want to try to assign to those!+        = Left (cc, cls, tv)+    find_unary cc = Right cc  -- Non unary or non dictionary++    bad_tvs :: TcTyCoVarSet  -- TyVars mentioned by non-unaries+    bad_tvs = mapUnionVarSet tyCoVarsOfCt non_unaries++    cmp_tv (_,_,tv1) (_,_,tv2) = tv1 `compare` tv2++    defaultable_tyvar :: TcTyVar -> Bool+    defaultable_tyvar tv+        = let b1 = isTyConableTyVar tv  -- Note [Avoiding spurious errors]+              b2 = not (tv `elemVarSet` bad_tvs)+          in b1 && (b2 || extended_defaults) -- Note [Multi-parameter defaults]++    defaultable_classes :: [Class] -> Bool+    defaultable_classes clss+        | extended_defaults = any (isInteractiveClass ovl_strings) clss+        | otherwise         = all is_std_class clss && (any (isNumClass ovl_strings) clss)++    -- is_std_class adds IsString to the standard numeric classes,+    -- when -foverloaded-strings is enabled+    is_std_class cls = isStandardClass cls ||+                       (ovl_strings && (cls `hasKey` isStringClassKey))++------------------------------+disambigGroup :: [Type]            -- The default types+              -> (TcTyVar, [Ct])   -- All classes of the form (C a)+                                   --  sharing same type variable+              -> TcS Bool   -- True <=> something happened, reflected in ty_binds++disambigGroup [] _+  = return False+disambigGroup (default_ty:default_tys) group@(the_tv, wanteds)+  = do { traceTcS "disambigGroup {" (vcat [ ppr default_ty, ppr the_tv, ppr wanteds ])+       ; fake_ev_binds_var <- TcS.newTcEvBinds+       ; tclvl             <- TcS.getTcLevel+       ; success <- nestImplicTcS fake_ev_binds_var (pushTcLevel tclvl) try_group++       ; if success then+             -- Success: record the type variable binding, and return+             do { unifyTyVar the_tv default_ty+                ; wrapWarnTcS $ warnDefaulting wanteds default_ty+                ; traceTcS "disambigGroup succeeded }" (ppr default_ty)+                ; return True }+         else+             -- Failure: try with the next type+             do { traceTcS "disambigGroup failed, will try other default types }"+                           (ppr default_ty)+                ; disambigGroup default_tys group } }+  where+    try_group+      | Just subst <- mb_subst+      = do { lcl_env <- TcS.getLclEnv+           ; tc_lvl <- TcS.getTcLevel+           ; let loc = mkGivenLoc tc_lvl UnkSkol lcl_env+           ; wanted_evs <- mapM (newWantedEvVarNC loc . substTy subst . ctPred)+                                wanteds+           ; fmap isEmptyWC $+             solveSimpleWanteds $ listToBag $+             map mkNonCanonical wanted_evs }++      | otherwise+      = return False++    the_ty   = mkTyVarTy the_tv+    mb_subst = tcMatchTyKi the_ty default_ty+      -- Make sure the kinds match too; hence this call to tcMatchTyKi+      -- E.g. suppose the only constraint was (Typeable k (a::k))+      -- With the addition of polykinded defaulting we also want to reject+      -- ill-kinded defaulting attempts like (Eq []) or (Foldable Int) here.++-- In interactive mode, or with -XExtendedDefaultRules,+-- we default Show a to Show () to avoid graututious errors on "show []"+isInteractiveClass :: Bool   -- -XOverloadedStrings?+                   -> Class -> Bool+isInteractiveClass ovl_strings cls+    = isNumClass ovl_strings cls || (classKey cls `elem` interactiveClassKeys)++    -- isNumClass adds IsString to the standard numeric classes,+    -- when -foverloaded-strings is enabled+isNumClass :: Bool   -- -XOverloadedStrings?+           -> Class -> Bool+isNumClass ovl_strings cls+  = isNumericClass cls || (ovl_strings && (cls `hasKey` isStringClassKey))+++{-+Note [Avoiding spurious errors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When doing the unification for defaulting, we check for skolem+type variables, and simply don't default them.  For example:+   f = (*)      -- Monomorphic+   g :: Num a => a -> a+   g x = f x x+Here, we get a complaint when checking the type signature for g,+that g isn't polymorphic enough; but then we get another one when+dealing with the (Num a) context arising from f's definition;+we try to unify a with Int (to default it), but find that it's+already been unified with the rigid variable from g's type sig.++Note [Multi-parameter defaults]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With -XExtendedDefaultRules, we default only based on single-variable+constraints, but do not exclude from defaulting any type variables which also+appear in multi-variable constraints. This means that the following will+default properly:++   default (Integer, Double)++   class A b (c :: Symbol) where+      a :: b -> Proxy c++   instance A Integer c where a _ = Proxy++   main = print (a 5 :: Proxy "5")++Note that if we change the above instance ("instance A Integer") to+"instance A Double", we get an error:++   No instance for (A Integer "5")++This is because the first defaulted type (Integer) has successfully satisfied+its single-parameter constraints (in this case Num).+-}
+ compiler/typecheck/TcSplice.hs view
@@ -0,0 +1,2100 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++TcSplice: Template Haskell splices+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module TcSplice(+     tcSpliceExpr, tcTypedBracket, tcUntypedBracket,+--     runQuasiQuoteExpr, runQuasiQuotePat,+--     runQuasiQuoteDecl, runQuasiQuoteType,+     runAnnotation,++     runMetaE, runMetaP, runMetaT, runMetaD, runQuasi,+     tcTopSpliceExpr, lookupThName_maybe,+     defaultRunMeta, runMeta', runRemoteModFinalizers,+     finishTH, runTopSplice+      ) where++#include "HsVersions.h"++import GhcPrelude++import HsSyn+import Annotations+import Finder+import Name+import TcRnMonad+import TcType++import Outputable+import TcExpr+import SrcLoc+import THNames+import TcUnify+import TcEnv+import Coercion( etaExpandCoAxBranch )+import FileCleanup ( newTempName, TempFileLifetime(..) )++import Control.Monad++import GHCi.Message+import GHCi.RemoteTypes+import GHCi+import HscMain+        -- These imports are the reason that TcSplice+        -- is very high up the module hierarchy+import RnSplice( traceSplice, SpliceInfo(..))+import RdrName+import HscTypes+import Convert+import RnExpr+import RnEnv+import RnUtils ( HsDocContext(..) )+import RnFixity ( lookupFixityRn_help )+import RnTypes+import TcHsSyn+import TcSimplify+import Type+import NameSet+import TcMType+import TcHsType+import TcIface+import TyCoRep+import FamInst+import FamInstEnv+import InstEnv+import Inst+import NameEnv+import PrelNames+import TysWiredIn+import OccName+import Hooks+import Var+import Module+import LoadIface+import Class+import TyCon+import CoAxiom+import PatSyn+import ConLike+import DataCon+import TcEvidence( TcEvBinds(..) )+import Id+import IdInfo+import DsExpr+import DsMonad+import GHC.Serialized+import ErrUtils+import Util+import Unique+import VarSet+import Data.List        ( find )+import Data.Maybe+import FastString+import BasicTypes hiding( SuccessFlag(..) )+import Maybes( MaybeErr(..) )+import DynFlags+import Panic+import Lexeme+import qualified EnumSet+import Plugins+import Bag++import qualified Language.Haskell.TH as TH+-- THSyntax gives access to internal functions and data types+import qualified Language.Haskell.TH.Syntax as TH++-- Because GHC.Desugar might not be in the base library of the bootstrapping compiler+import GHC.Desugar      ( AnnotationWrapper(..) )++import Control.Exception+import Data.Binary+import Data.Binary.Get+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import Data.Dynamic  ( fromDynamic, toDyn )+import qualified Data.Map as Map+import Data.Typeable ( typeOf, Typeable, TypeRep, typeRep )+import Data.Data (Data)+import Data.Proxy    ( Proxy (..) )+import GHC.Exts         ( unsafeCoerce# )++{-+************************************************************************+*                                                                      *+\subsection{Main interface + stubs for the non-GHCI case+*                                                                      *+************************************************************************+-}++tcTypedBracket   :: HsExpr GhcRn -> HsBracket GhcRn -> ExpRhoType -> TcM (HsExpr GhcTcId)+tcUntypedBracket :: HsExpr GhcRn -> HsBracket GhcRn -> [PendingRnSplice] -> ExpRhoType+                 -> TcM (HsExpr GhcTcId)+tcSpliceExpr     :: HsSplice GhcRn  -> ExpRhoType -> TcM (HsExpr GhcTcId)+        -- None of these functions add constraints to the LIE++-- runQuasiQuoteExpr :: HsQuasiQuote RdrName -> RnM (LHsExpr RdrName)+-- runQuasiQuotePat  :: HsQuasiQuote RdrName -> RnM (LPat RdrName)+-- runQuasiQuoteType :: HsQuasiQuote RdrName -> RnM (LHsType RdrName)+-- runQuasiQuoteDecl :: HsQuasiQuote RdrName -> RnM [LHsDecl RdrName]++runAnnotation     :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation+{-+************************************************************************+*                                                                      *+\subsection{Quoting an expression}+*                                                                      *+************************************************************************+-}++-- See Note [How brackets and nested splices are handled]+-- tcTypedBracket :: HsBracket Name -> TcRhoType -> TcM (HsExpr TcId)+tcTypedBracket rn_expr brack@(TExpBr _ expr) res_ty+  = addErrCtxt (quotationCtxtDoc brack) $+    do { cur_stage <- getStage+       ; ps_ref <- newMutVar []+       ; lie_var <- getConstraintVar   -- Any constraints arising from nested splices+                                       -- should get thrown into the constraint set+                                       -- from outside the bracket++       -- Typecheck expr to make sure it is valid,+       -- Throw away the typechecked expression but return its type.+       -- We'll typecheck it again when we splice it in somewhere+       ; (_tc_expr, expr_ty) <- setStage (Brack cur_stage (TcPending ps_ref lie_var)) $+                                tcInferRhoNC expr+                                -- NC for no context; tcBracket does that+       ; let rep = getRuntimeRep expr_ty++       ; meta_ty <- tcTExpTy expr_ty+       ; ps' <- readMutVar ps_ref+       ; texpco <- tcLookupId unsafeTExpCoerceName+       ; tcWrapResultO (Shouldn'tHappenOrigin "TExpBr")+                       rn_expr+                       (unLoc (mkHsApp (nlHsTyApp texpco [rep, expr_ty])+                                      (noLoc (HsTcBracketOut noExt brack ps'))))+                       meta_ty res_ty }+tcTypedBracket _ other_brack _+  = pprPanic "tcTypedBracket" (ppr other_brack)++-- tcUntypedBracket :: HsBracket Name -> [PendingRnSplice] -> ExpRhoType -> TcM (HsExpr TcId)+tcUntypedBracket rn_expr brack ps res_ty+  = do { traceTc "tc_bracket untyped" (ppr brack $$ ppr ps)+       ; ps' <- mapM tcPendingSplice ps+       ; meta_ty <- tcBrackTy brack+       ; traceTc "tc_bracket done untyped" (ppr meta_ty)+       ; tcWrapResultO (Shouldn'tHappenOrigin "untyped bracket")+                       rn_expr (HsTcBracketOut noExt brack ps') meta_ty res_ty }++---------------+tcBrackTy :: HsBracket GhcRn -> TcM TcType+tcBrackTy (VarBr {})  = tcMetaTy nameTyConName+                                           -- Result type is Var (not Q-monadic)+tcBrackTy (ExpBr {})  = tcMetaTy expQTyConName  -- Result type is ExpQ (= Q Exp)+tcBrackTy (TypBr {})  = tcMetaTy typeQTyConName -- Result type is Type (= Q Typ)+tcBrackTy (DecBrG {}) = tcMetaTy decsQTyConName -- Result type is Q [Dec]+tcBrackTy (PatBr {})  = tcMetaTy patQTyConName  -- Result type is PatQ (= Q Pat)+tcBrackTy (DecBrL {})   = panic "tcBrackTy: Unexpected DecBrL"+tcBrackTy (TExpBr {})   = panic "tcUntypedBracket: Unexpected TExpBr"+tcBrackTy (XBracket {}) = panic "tcUntypedBracket: Unexpected XBracket"++---------------+tcPendingSplice :: PendingRnSplice -> TcM PendingTcSplice+tcPendingSplice (PendingRnSplice flavour splice_name expr)+  = do { res_ty <- tcMetaTy meta_ty_name+       ; expr' <- tcMonoExpr expr (mkCheckExpType res_ty)+       ; return (PendingTcSplice splice_name expr') }+  where+     meta_ty_name = case flavour of+                       UntypedExpSplice  -> expQTyConName+                       UntypedPatSplice  -> patQTyConName+                       UntypedTypeSplice -> typeQTyConName+                       UntypedDeclSplice -> decsQTyConName++---------------+-- Takes a tau and returns the type Q (TExp tau)+tcTExpTy :: TcType -> TcM TcType+tcTExpTy exp_ty+  = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)+       ; q    <- tcLookupTyCon qTyConName+       ; texp <- tcLookupTyCon tExpTyConName+       ; let rep = getRuntimeRep exp_ty+       ; return (mkTyConApp q [mkTyConApp texp [rep, exp_ty]]) }+  where+    err_msg ty+      = vcat [ text "Illegal polytype:" <+> ppr ty+             , text "The type of a Typed Template Haskell expression must" <+>+               text "not have any quantification." ]++quotationCtxtDoc :: HsBracket GhcRn -> SDoc+quotationCtxtDoc br_body+  = hang (text "In the Template Haskell quotation")+         2 (ppr br_body)+++  -- The whole of the rest of the file is the else-branch (ie stage2 only)++{-+Note [How top-level splices are handled]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Top-level splices (those not inside a [| .. |] quotation bracket) are handled+very straightforwardly:++  1. tcTopSpliceExpr: typecheck the body e of the splice $(e)++  2. runMetaT: desugar, compile, run it, and convert result back to+     HsSyn RdrName (of the appropriate flavour, eg HsType RdrName,+     HsExpr RdrName etc)++  3. treat the result as if that's what you saw in the first place+     e.g for HsType, rename and kind-check+         for HsExpr, rename and type-check++     (The last step is different for decls, because they can *only* be+      top-level: we return the result of step 2.)++Note [How brackets and nested splices are handled]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Nested splices (those inside a [| .. |] quotation bracket),+are treated quite differently.++Remember, there are two forms of bracket+         typed   [|| e ||]+   and untyped   [|  e  |]++The life cycle of a typed bracket:+   * Starts as HsBracket++   * When renaming:+        * Set the ThStage to (Brack s RnPendingTyped)+        * Rename the body+        * Result is still a HsBracket++   * When typechecking:+        * Set the ThStage to (Brack s (TcPending ps_var lie_var))+        * Typecheck the body, and throw away the elaborated result+        * Nested splices (which must be typed) are typechecked, and+          the results accumulated in ps_var; their constraints+          accumulate in lie_var+        * Result is a HsTcBracketOut rn_brack pending_splices+          where rn_brack is the incoming renamed bracket++The life cycle of a un-typed bracket:+   * Starts as HsBracket++   * When renaming:+        * Set the ThStage to (Brack s (RnPendingUntyped ps_var))+        * Rename the body+        * Nested splices (which must be untyped) are renamed, and the+          results accumulated in ps_var+        * Result is still (HsRnBracketOut rn_body pending_splices)++   * When typechecking a HsRnBracketOut+        * Typecheck the pending_splices individually+        * Ignore the body of the bracket; just check that the context+          expects a bracket of that type (e.g. a [p| pat |] bracket should+          be in a context needing a (Q Pat)+        * Result is a HsTcBracketOut rn_brack pending_splices+          where rn_brack is the incoming renamed bracket+++In both cases, desugaring happens like this:+  * HsTcBracketOut is desugared by DsMeta.dsBracket.  It++      a) Extends the ds_meta environment with the PendingSplices+         attached to the bracket++      b) Converts the quoted (HsExpr Name) to a CoreExpr that, when+         run, will produce a suitable TH expression/type/decl.  This+         is why we leave the *renamed* expression attached to the bracket:+         the quoted expression should not be decorated with all the goop+         added by the type checker++  * Each splice carries a unique Name, called a "splice point", thus+    ${n}(e).  The name is initialised to an (Unqual "splice") when the+    splice is created; the renamer gives it a unique.++  * When DsMeta (used to desugar the body of the bracket) comes across+    a splice, it looks up the splice's Name, n, in the ds_meta envt,+    to find an (HsExpr Id) that should be substituted for the splice;+    it just desugars it to get a CoreExpr (DsMeta.repSplice).++Example:+    Source:       f = [| Just $(g 3) |]+      The [| |] part is a HsBracket++    Typechecked:  f = [| Just ${s7}(g 3) |]{s7 = g Int 3}+      The [| |] part is a HsBracketOut, containing *renamed*+        (not typechecked) expression+      The "s7" is the "splice point"; the (g Int 3) part+        is a typechecked expression++    Desugared:    f = do { s7 <- g Int 3+                         ; return (ConE "Data.Maybe.Just" s7) }+++Note [Template Haskell state diagram]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here are the ThStages, s, their corresponding level numbers+(the result of (thLevel s)), and their state transitions.+The top level of the program is stage Comp:++     Start here+         |+         V+      -----------     $      ------------   $+      |  Comp   | ---------> |  Splice  | -----|+      |   1     |            |    0     | <----|+      -----------            ------------+        ^     |                ^      |+      $ |     | [||]         $ |      | [||]+        |     v                |      v+   --------------          ----------------+   | Brack Comp |          | Brack Splice |+   |     2      |          |      1       |+   --------------          ----------------++* Normal top-level declarations start in state Comp+       (which has level 1).+  Annotations start in state Splice, since they are+       treated very like a splice (only without a '$')++* Code compiled in state Splice (and only such code)+  will be *run at compile time*, with the result replacing+  the splice++* The original paper used level -1 instead of 0, etc.++* The original paper did not allow a splice within a+  splice, but there is no reason not to. This is the+  $ transition in the top right.++Note [Template Haskell levels]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Imported things are impLevel (= 0)++* However things at level 0 are not *necessarily* imported.+      eg  $( \b -> ... )   here b is bound at level 0++* In GHCi, variables bound by a previous command are treated+  as impLevel, because we have bytecode for them.++* Variables are bound at the "current level"++* The current level starts off at outerLevel (= 1)++* The level is decremented by splicing $(..)+               incremented by brackets [| |]+               incremented by name-quoting 'f++When a variable is used, we compare+        bind:  binding level, and+        use:   current level at usage site++  Generally+        bind > use      Always error (bound later than used)+                        [| \x -> $(f x) |]++        bind = use      Always OK (bound same stage as used)+                        [| \x -> $(f [| x |]) |]++        bind < use      Inside brackets, it depends+                        Inside splice, OK+                        Inside neither, OK++  For (bind < use) inside brackets, there are three cases:+    - Imported things   OK      f = [| map |]+    - Top-level things  OK      g = [| f |]+    - Non-top-level     Only if there is a liftable instance+                                h = \(x:Int) -> [| x |]++  To track top-level-ness we use the ThBindEnv in TcLclEnv++  For example:+           f = ...+           g1 = $(map ...)         is OK+           g2 = $(f ...)           is not OK; because we havn't compiled f yet++-}++{-+************************************************************************+*                                                                      *+\subsection{Splicing an expression}+*                                                                      *+************************************************************************+-}++tcSpliceExpr splice@(HsTypedSplice _ _ name expr) res_ty+  = addErrCtxt (spliceCtxtDoc splice) $+    setSrcSpan (getLoc expr)    $ do+    { stage <- getStage+    ; case stage of+          Splice {}            -> tcTopSplice expr res_ty+          Brack pop_stage pend -> tcNestedSplice pop_stage pend name expr res_ty+          RunSplice _          ->+            -- See Note [RunSplice ThLevel] in "TcRnTypes".+            pprPanic ("tcSpliceExpr: attempted to typecheck a splice when " +++                      "running another splice") (ppr splice)+          Comp                 -> tcTopSplice expr res_ty+    }+tcSpliceExpr splice _+  = pprPanic "tcSpliceExpr" (ppr splice)++{- Note [Collecting modFinalizers in typed splices]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++'qAddModFinalizer' of the @Quasi TcM@ instance adds finalizers in the local+environment (see Note [Delaying modFinalizers in untyped splices] in+"RnSplice"). Thus after executing the splice, we move the finalizers to the+finalizer list in the global environment and set them to use the current local+environment (with 'addModFinalizersWithLclEnv').++-}++tcNestedSplice :: ThStage -> PendingStuff -> Name+                -> LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)+    -- See Note [How brackets and nested splices are handled]+    -- A splice inside brackets+tcNestedSplice pop_stage (TcPending ps_var lie_var) splice_name expr res_ty+  = do { res_ty <- expTypeToType res_ty+       ; let rep = getRuntimeRep res_ty+       ; meta_exp_ty <- tcTExpTy res_ty+       ; expr' <- setStage pop_stage $+                  setConstraintVar lie_var $+                  tcMonoExpr expr (mkCheckExpType meta_exp_ty)+       ; untypeq <- tcLookupId unTypeQName+       ; let expr'' = mkHsApp (nlHsTyApp untypeq [rep, res_ty]) expr'+       ; ps <- readMutVar ps_var+       ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps)++       -- The returned expression is ignored; it's in the pending splices+       ; return (panic "tcSpliceExpr") }++tcNestedSplice _ _ splice_name _ _+  = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name)++tcTopSplice :: LHsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)+tcTopSplice expr res_ty+  = do { -- Typecheck the expression,+         -- making sure it has type Q (T res_ty)+         res_ty <- expTypeToType res_ty+       ; meta_exp_ty <- tcTExpTy res_ty+       ; q_expr <- tcTopSpliceExpr Typed $+                          tcMonoExpr expr (mkCheckExpType meta_exp_ty)+       ; lcl_env <- getLclEnv+       ; let delayed_splice+              = DelayedSplice lcl_env expr res_ty q_expr+       ; return (HsSpliceE noExt (HsSplicedT delayed_splice))++       }+++-- This is called in the zonker+-- See Note [Running typed splices in the zonker]+runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)+runTopSplice (DelayedSplice lcl_env orig_expr res_ty q_expr)+  = setLclEnv lcl_env $ do {+         zonked_ty <- zonkTcType res_ty+       ; zonked_q_expr <- zonkTopLExpr q_expr+        -- See Note [Collecting modFinalizers in typed splices].+       ; modfinalizers_ref <- newTcRef []+         -- Run the expression+       ; expr2 <- setStage (RunSplice modfinalizers_ref) $+                    runMetaE zonked_q_expr+       ; mod_finalizers <- readTcRef modfinalizers_ref+       ; addModFinalizersWithLclEnv $ ThModFinalizers mod_finalizers+       -- We use orig_expr here and not q_expr when tracing as a call to+       -- unsafeTExpCoerce is added to the original expression by the+       -- typechecker when typed quotes are type checked.+       ; traceSplice (SpliceInfo { spliceDescription = "expression"+                                 , spliceIsDecl      = False+                                 , spliceSource      = Just orig_expr+                                 , spliceGenerated   = ppr expr2 })+        -- Rename and typecheck the spliced-in expression,+        -- making sure it has type res_ty+        -- These steps should never fail; this is a *typed* splice+       ; (res, wcs) <-+            captureConstraints $+              addErrCtxt (spliceResultDoc zonked_q_expr) $ do+                { (exp3, _fvs) <- rnLExpr expr2+                ; tcMonoExpr exp3 (mkCheckExpType zonked_ty)}+       ; ev <- simplifyTop wcs+       ; return $ unLoc (mkHsDictLet (EvBinds ev) res)+       }+++{-+************************************************************************+*                                                                      *+\subsection{Error messages}+*                                                                      *+************************************************************************+-}++spliceCtxtDoc :: HsSplice GhcRn -> SDoc+spliceCtxtDoc splice+  = hang (text "In the Template Haskell splice")+         2 (pprSplice splice)++spliceResultDoc :: LHsExpr GhcTc -> SDoc+spliceResultDoc expr+  = sep [ text "In the result of the splice:"+        , nest 2 (char '$' <> ppr expr)+        , text "To see what the splice expanded to, use -ddump-splices"]++-------------------+tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTc) -> TcM (LHsExpr GhcTc)+-- Note [How top-level splices are handled]+-- Type check an expression that is the body of a top-level splice+--   (the caller will compile and run it)+-- Note that set the level to Splice, regardless of the original level,+-- before typechecking the expression.  For example:+--      f x = $( ...$(g 3) ... )+-- The recursive call to tcPolyExpr will simply expand the+-- inner escape before dealing with the outer one++tcTopSpliceExpr isTypedSplice tc_action+  = checkNoErrs $  -- checkNoErrs: must not try to run the thing+                   -- if the type checker fails!+    unsetGOptM Opt_DeferTypeErrors $+                   -- Don't defer type errors.  Not only are we+                   -- going to run this code, but we do an unsafe+                   -- coerce, so we get a seg-fault if, say we+                   -- splice a type into a place where an expression+                   -- is expected (#7276)+    setStage (Splice isTypedSplice) $+    do {    -- Typecheck the expression+         (expr', wanted) <- captureConstraints tc_action+       ; const_binds     <- simplifyTop wanted++          -- Zonk it and tie the knot of dictionary bindings+       ; return $ mkHsDictLet (EvBinds const_binds) expr' }++{-+************************************************************************+*                                                                      *+        Annotations+*                                                                      *+************************************************************************+-}++runAnnotation target expr = do+    -- Find the classes we want instances for in order to call toAnnotationWrapper+    loc <- getSrcSpanM+    data_class <- tcLookupClass dataClassName+    to_annotation_wrapper_id <- tcLookupId toAnnotationWrapperName++    -- Check the instances we require live in another module (we want to execute it..)+    -- and check identifiers live in other modules using TH stage checks. tcSimplifyStagedExpr+    -- also resolves the LIE constraints to detect e.g. instance ambiguity+    zonked_wrapped_expr' <- zonkTopLExpr =<< tcTopSpliceExpr Untyped (+           do { (expr', expr_ty) <- tcInferRhoNC expr+                -- We manually wrap the typechecked expression in a call to toAnnotationWrapper+                -- By instantiating the call >here< it gets registered in the+                -- LIE consulted by tcTopSpliceExpr+                -- and hence ensures the appropriate dictionary is bound by const_binds+              ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]]+              ; let specialised_to_annotation_wrapper_expr+                      = L loc (mkHsWrap wrapper+                                 (HsVar noExt (L loc to_annotation_wrapper_id)))+              ; return (L loc (HsApp noExt+                                specialised_to_annotation_wrapper_expr expr'))+                                })++    -- Run the appropriately wrapped expression to get the value of+    -- the annotation and its dictionaries. The return value is of+    -- type AnnotationWrapper by construction, so this conversion is+    -- safe+    serialized <- runMetaAW zonked_wrapped_expr'+    return Annotation {+               ann_target = target,+               ann_value = serialized+           }++convertAnnotationWrapper :: ForeignHValue -> TcM (Either MsgDoc Serialized)+convertAnnotationWrapper fhv = do+  dflags <- getDynFlags+  if gopt Opt_ExternalInterpreter dflags+    then do+      Right <$> runTH THAnnWrapper fhv+    else do+      annotation_wrapper <- liftIO $ wormhole dflags fhv+      return $ Right $+        case unsafeCoerce# annotation_wrapper of+           AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->+               -- Got the value and dictionaries: build the serialized value and+               -- call it a day. We ensure that we seq the entire serialized value+               -- in order that any errors in the user-written code for the+               -- annotation are exposed at this point.  This is also why we are+               -- doing all this stuff inside the context of runMeta: it has the+               -- facilities to deal with user error in a meta-level expression+               seqSerialized serialized `seq` serialized++-- | Force the contents of the Serialized value so weknow it doesn't contain any bottoms+seqSerialized :: Serialized -> ()+seqSerialized (Serialized the_type bytes) = the_type `seq` bytes `seqList` ()+++{-+************************************************************************+*                                                                      *+\subsection{Running an expression}+*                                                                      *+************************************************************************+-}++runQuasi :: TH.Q a -> TcM a+runQuasi act = TH.runQ act++runRemoteModFinalizers :: ThModFinalizers -> TcM ()+runRemoteModFinalizers (ThModFinalizers finRefs) = do+  dflags <- getDynFlags+  let withForeignRefs [] f = f []+      withForeignRefs (x : xs) f = withForeignRef x $ \r ->+        withForeignRefs xs $ \rs -> f (r : rs)+  if gopt Opt_ExternalInterpreter dflags then do+    hsc_env <- env_top <$> getEnv+    withIServ hsc_env $ \i -> do+      tcg <- getGblEnv+      th_state <- readTcRef (tcg_th_remote_state tcg)+      case th_state of+        Nothing -> return () -- TH was not started, nothing to do+        Just fhv -> do+          liftIO $ withForeignRef fhv $ \st ->+            withForeignRefs finRefs $ \qrefs ->+              writeIServ i (putMessage (RunModFinalizers st qrefs))+          () <- runRemoteTH i []+          readQResult i+  else do+    qs <- liftIO (withForeignRefs finRefs $ mapM localRef)+    runQuasi $ sequence_ qs++runQResult+  :: (a -> String)+  -> (SrcSpan -> a -> b)+  -> (ForeignHValue -> TcM a)+  -> SrcSpan+  -> ForeignHValue {- TH.Q a -}+  -> TcM b+runQResult show_th f runQ expr_span hval+  = do { th_result <- runQ hval+       ; traceTc "Got TH result:" (text (show_th th_result))+       ; return (f expr_span th_result) }+++-----------------+runMeta :: (MetaHook TcM -> LHsExpr GhcTc -> TcM hs_syn)+        -> LHsExpr GhcTc+        -> TcM hs_syn+runMeta unwrap e+  = do { h <- getHooked runMetaHook defaultRunMeta+       ; unwrap h e }++defaultRunMeta :: MetaHook TcM+defaultRunMeta (MetaE r)+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsExpr runTHExp)+defaultRunMeta (MetaP r)+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToPat runTHPat)+defaultRunMeta (MetaT r)+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsType runTHType)+defaultRunMeta (MetaD r)+  = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec)+defaultRunMeta (MetaAW r)+  = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper)+    -- We turn off showing the code in meta-level exceptions because doing so exposes+    -- the toAnnotationWrapper function that we slap around the user's code++----------------+runMetaAW :: LHsExpr GhcTc         -- Of type AnnotationWrapper+          -> TcM Serialized+runMetaAW = runMeta metaRequestAW++runMetaE :: LHsExpr GhcTc          -- Of type (Q Exp)+         -> TcM (LHsExpr GhcPs)+runMetaE = runMeta metaRequestE++runMetaP :: LHsExpr GhcTc          -- Of type (Q Pat)+         -> TcM (LPat GhcPs)+runMetaP = runMeta metaRequestP++runMetaT :: LHsExpr GhcTc          -- Of type (Q Type)+         -> TcM (LHsType GhcPs)+runMetaT = runMeta metaRequestT++runMetaD :: LHsExpr GhcTc          -- Of type Q [Dec]+         -> TcM [LHsDecl GhcPs]+runMetaD = runMeta metaRequestD++---------------+runMeta' :: Bool                 -- Whether code should be printed in the exception message+         -> (hs_syn -> SDoc)                                    -- how to print the code+         -> (SrcSpan -> ForeignHValue -> TcM (Either MsgDoc hs_syn))        -- How to run x+         -> LHsExpr GhcTc        -- Of type x; typically x = Q TH.Exp, or+                                 --    something like that+         -> TcM hs_syn           -- Of type t+runMeta' show_code ppr_hs run_and_convert expr+  = do  { traceTc "About to run" (ppr expr)+        ; recordThSpliceUse -- seems to be the best place to do this,+                            -- we catch all kinds of splices and annotations.++        -- Check that we've had no errors of any sort so far.+        -- For example, if we found an error in an earlier defn f, but+        -- recovered giving it type f :: forall a.a, it'd be very dodgy+        -- to carry ont.  Mind you, the staging restrictions mean we won't+        -- actually run f, but it still seems wrong. And, more concretely,+        -- see #5358 for an example that fell over when trying to+        -- reify a function with a "?" kind in it.  (These don't occur+        -- in type-correct programs.+        ; failIfErrsM++        -- run plugins+        ; hsc_env <- getTopEnv+        ; expr' <- withPlugins (hsc_dflags hsc_env) spliceRunAction expr++        -- Desugar+        ; ds_expr <- initDsTc (dsLExpr expr')+        -- Compile and link it; might fail if linking fails+        ; src_span <- getSrcSpanM+        ; traceTc "About to run (desugared)" (ppr ds_expr)+        ; either_hval <- tryM $ liftIO $+                         HscMain.hscCompileCoreExpr hsc_env src_span ds_expr+        ; case either_hval of {+            Left exn   -> fail_with_exn "compile and link" exn ;+            Right hval -> do++        {       -- Coerce it to Q t, and run it++                -- Running might fail if it throws an exception of any kind (hence tryAllM)+                -- including, say, a pattern-match exception in the code we are running+                --+                -- We also do the TH -> HS syntax conversion inside the same+                -- exception-cacthing thing so that if there are any lurking+                -- exceptions in the data structure returned by hval, we'll+                -- encounter them inside the try+                --+                -- See Note [Exceptions in TH]+          let expr_span = getLoc expr+        ; either_tval <- tryAllM $+                         setSrcSpan expr_span $ -- Set the span so that qLocation can+                                                -- see where this splice is+             do { mb_result <- run_and_convert expr_span hval+                ; case mb_result of+                    Left err     -> failWithTc err+                    Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)+                                       ; return $! result } }++        ; case either_tval of+            Right v -> return v+            Left se -> case fromException se of+                         Just IOEnvFailure -> failM -- Error already in Tc monad+                         _ -> fail_with_exn "run" se -- Exception+        }}}+  where+    -- see Note [Concealed TH exceptions]+    fail_with_exn :: Exception e => String -> e -> TcM a+    fail_with_exn phase exn = do+        exn_msg <- liftIO $ Panic.safeShowException exn+        let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",+                        nest 2 (text exn_msg),+                        if show_code then text "Code:" <+> ppr expr else empty]+        failWithTc msg++{-+Note [Running typed splices in the zonker]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++See #15471 for the full discussion.++For many years typed splices were run immediately after they were type checked+however, this is too early as it means to zonk some type variables before+they can be unified with type variables in the surrounding context.++For example,++```+module A where++test_foo :: forall a . Q (TExp (a -> a))+test_foo = [|| id ||]++module B where++import A++qux = $$(test_foo)+```++We would expect `qux` to have inferred type `forall a . a -> a` but if+we run the splices too early the unified variables are zonked to `Any`. The+inferred type is the unusable `Any -> Any`.++To run the splice, we must compile `test_foo` all the way to byte code.+But at the moment when the type checker is looking at the splice, test_foo+has type `Q (TExp (alpha -> alpha))` and we+certainly can't compile code involving unification variables!++We could default `alpha` to `Any` but then we infer `qux :: Any -> Any`+which definitely is not what we want.  Moreover, if we had+  qux = [$$(test_foo), (\x -> x +1::Int)]+then `alpha` would have to be `Int`.++Conclusion: we must defer taking decisions about `alpha` until the+typechecker is done; and *then* we can run the splice.  It's fine to do it+later, because we know it'll produce type-correct code.++Deferring running the splice until later, in the zonker, means that the+unification variables propagate upwards from the splice into the surrounding+context and are unified correctly.++This is implemented by storing the arguments we need for running the splice+in a `DelayedSplice`. In the zonker, the arguments are passed to+`TcSplice.runTopSplice` and the expression inserted into the AST as normal.++++Note [Exceptions in TH]+~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have something like this+        $( f 4 )+where+        f :: Int -> Q [Dec]+        f n | n>3       = fail "Too many declarations"+            | otherwise = ...++The 'fail' is a user-generated failure, and should be displayed as a+perfectly ordinary compiler error message, not a panic or anything+like that.  Here's how it's processed:++  * 'fail' is the monad fail.  The monad instance for Q in TH.Syntax+    effectively transforms (fail s) to+        qReport True s >> fail+    where 'qReport' comes from the Quasi class and fail from its monad+    superclass.++  * The TcM monad is an instance of Quasi (see TcSplice), and it implements+    (qReport True s) by using addErr to add an error message to the bag of errors.+    The 'fail' in TcM raises an IOEnvFailure exception++ * 'qReport' forces the message to ensure any exception hidden in unevaluated+   thunk doesn't get into the bag of errors. Otherwise the following splice+   will triger panic (#8987):+        $(fail undefined)+   See also Note [Concealed TH exceptions]++  * So, when running a splice, we catch all exceptions; then for+        - an IOEnvFailure exception, we assume the error is already+                in the error-bag (above)+        - other errors, we add an error to the bag+    and then fail++Note [Concealed TH exceptions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When displaying the error message contained in an exception originated from TH+code, we need to make sure that the error message itself does not contain an+exception.  For example, when executing the following splice:++    $( error ("foo " ++ error "bar") )++the message for the outer exception is a thunk which will throw the inner+exception when evaluated.++For this reason, we display the message of a TH exception using the+'safeShowException' function, which recursively catches any exception thrown+when showing an error message.+++To call runQ in the Tc monad, we need to make TcM an instance of Quasi:+-}++instance TH.Quasi TcM where+  qNewName s = do { u <- newUnique+                  ; let i = toInteger (getKey u)+                  ; return (TH.mkNameU s i) }++  -- 'msg' is forced to ensure exceptions don't escape,+  -- see Note [Exceptions in TH]+  qReport True msg  = seqList msg $ addErr  (text msg)+  qReport False msg = seqList msg $ addWarn NoReason (text msg)++  qLocation = do { m <- getModule+                 ; l <- getSrcSpanM+                 ; r <- case l of+                        UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"+                                                    (ppr l)+                        RealSrcSpan s -> return s+                 ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)+                                  , TH.loc_module   = moduleNameString (moduleName m)+                                  , TH.loc_package  = unitIdString (moduleUnitId m)+                                  , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)+                                  , TH.loc_end = (srcSpanEndLine   r, srcSpanEndCol   r) }) }++  qLookupName       = lookupName+  qReify            = reify+  qReifyFixity nm   = lookupThName nm >>= reifyFixity+  qReifyInstances   = reifyInstances+  qReifyRoles       = reifyRoles+  qReifyAnnotations = reifyAnnotations+  qReifyModule      = reifyModule+  qReifyConStrictness nm = do { nm' <- lookupThName nm+                              ; dc  <- tcLookupDataCon nm'+                              ; let bangs = dataConImplBangs dc+                              ; return (map reifyDecidedStrictness bangs) }++        -- For qRecover, discard error messages if+        -- the recovery action is chosen.  Otherwise+        -- we'll only fail higher up.+  qRecover recover main = tryTcDiscardingErrs recover main++  qAddDependentFile fp = do+    ref <- fmap tcg_dependent_files getGblEnv+    dep_files <- readTcRef ref+    writeTcRef ref (fp:dep_files)++  qAddTempFile suffix = do+    dflags <- getDynFlags+    liftIO $ newTempName dflags TFL_GhcSession suffix++  qAddTopDecls thds = do+      l <- getSrcSpanM+      let either_hval = convertToHsDecls l thds+      ds <- case either_hval of+              Left exn -> failWithTc $+                hang (text "Error in a declaration passed to addTopDecls:")+                   2 exn+              Right ds -> return ds+      mapM_ (checkTopDecl . unLoc) ds+      th_topdecls_var <- fmap tcg_th_topdecls getGblEnv+      updTcRef th_topdecls_var (\topds -> ds ++ topds)+    where+      checkTopDecl :: HsDecl GhcPs -> TcM ()+      checkTopDecl (ValD _ binds)+        = mapM_ bindName (collectHsBindBinders binds)+      checkTopDecl (SigD _ _)+        = return ()+      checkTopDecl (AnnD _ _)+        = return ()+      checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name }))+        = bindName name+      checkTopDecl _+        = addErr $ text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl"++      bindName :: RdrName -> TcM ()+      bindName (Exact n)+        = do { th_topnames_var <- fmap tcg_th_topnames getGblEnv+             ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)+             }++      bindName name =+          addErr $+          hang (text "The binder" <+> quotes (ppr name) <+> ptext (sLit "is not a NameU."))+             2 (text "Probable cause: you used mkName instead of newName to generate a binding.")++  qAddForeignFilePath lang fp = do+    var <- fmap tcg_th_foreign_files getGblEnv+    updTcRef var ((lang, fp) :)++  qAddModFinalizer fin = do+      r <- liftIO $ mkRemoteRef fin+      fref <- liftIO $ mkForeignRef r (freeRemoteRef r)+      addModFinalizerRef fref++  qAddCorePlugin plugin = do+      hsc_env <- env_top <$> getEnv+      r <- liftIO $ findHomeModule hsc_env (mkModuleName plugin)+      let err = hang+            (text "addCorePlugin: invalid plugin module "+               <+> text (show plugin)+            )+            2+            (text "Plugins in the current package can't be specified.")+      case r of+        Found {} -> addErr err+        FoundMultiple {} -> addErr err+        _ -> return ()+      th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv+      updTcRef th_coreplugins_var (plugin:)++  qGetQ :: forall a. Typeable a => TcM (Maybe a)+  qGetQ = do+      th_state_var <- fmap tcg_th_state getGblEnv+      th_state <- readTcRef th_state_var+      -- See #10596 for why we use a scoped type variable here.+      return (Map.lookup (typeRep (Proxy :: Proxy a)) th_state >>= fromDynamic)++  qPutQ x = do+      th_state_var <- fmap tcg_th_state getGblEnv+      updTcRef th_state_var (\m -> Map.insert (typeOf x) (toDyn x) m)++  qIsExtEnabled = xoptM++  qExtsEnabled =+    EnumSet.toList . extensionFlags . hsc_dflags <$> getTopEnv++-- | Adds a mod finalizer reference to the local environment.+addModFinalizerRef :: ForeignRef (TH.Q ()) -> TcM ()+addModFinalizerRef finRef = do+    th_stage <- getStage+    case th_stage of+      RunSplice th_modfinalizers_var -> updTcRef th_modfinalizers_var (finRef :)+      -- This case happens only if a splice is executed and the caller does+      -- not set the 'ThStage' to 'RunSplice' to collect finalizers.+      -- See Note [Delaying modFinalizers in untyped splices] in RnSplice.+      _ ->+        pprPanic "addModFinalizer was called when no finalizers were collected"+                 (ppr th_stage)++-- | Releases the external interpreter state.+finishTH :: TcM ()+finishTH = do+  dflags <- getDynFlags+  when (gopt Opt_ExternalInterpreter dflags) $ do+    tcg <- getGblEnv+    writeTcRef (tcg_th_remote_state tcg) Nothing++runTHExp :: ForeignHValue -> TcM TH.Exp+runTHExp = runTH THExp++runTHPat :: ForeignHValue -> TcM TH.Pat+runTHPat = runTH THPat++runTHType :: ForeignHValue -> TcM TH.Type+runTHType = runTH THType++runTHDec :: ForeignHValue -> TcM [TH.Dec]+runTHDec = runTH THDec++runTH :: Binary a => THResultType -> ForeignHValue -> TcM a+runTH ty fhv = do+  hsc_env <- env_top <$> getEnv+  dflags <- getDynFlags+  if not (gopt Opt_ExternalInterpreter dflags)+    then do+       -- Run it in the local TcM+      hv <- liftIO $ wormhole dflags fhv+      r <- runQuasi (unsafeCoerce# hv :: TH.Q a)+      return r+    else+      -- Run it on the server.  For an overview of how TH works with+      -- Remote GHCi, see Note [Remote Template Haskell] in+      -- libraries/ghci/GHCi/TH.hs.+      withIServ hsc_env $ \i -> do+        rstate <- getTHState i+        loc <- TH.qLocation+        liftIO $+          withForeignRef rstate $ \state_hv ->+          withForeignRef fhv $ \q_hv ->+            writeIServ i (putMessage (RunTH state_hv q_hv ty (Just loc)))+        runRemoteTH i []+        bs <- readQResult i+        return $! runGet get (LB.fromStrict bs)+++-- | communicate with a remotely-running TH computation until it finishes.+-- See Note [Remote Template Haskell] in libraries/ghci/GHCi/TH.hs.+runRemoteTH+  :: IServ+  -> [Messages]   --  saved from nested calls to qRecover+  -> TcM ()+runRemoteTH iserv recovers = do+  THMsg msg <- liftIO $ readIServ iserv getTHMessage+  case msg of+    RunTHDone -> return ()+    StartRecover -> do -- Note [TH recover with -fexternal-interpreter]+      v <- getErrsVar+      msgs <- readTcRef v+      writeTcRef v emptyMessages+      runRemoteTH iserv (msgs : recovers)+    EndRecover caught_error -> do+      let (prev_msgs@(prev_warns,prev_errs), rest) = case recovers of+             [] -> panic "EndRecover"+             a : b -> (a,b)+      v <- getErrsVar+      (warn_msgs,_) <- readTcRef v+      -- keep the warnings only if there were no errors+      writeTcRef v $ if caught_error+        then prev_msgs+        else (prev_warns `unionBags` warn_msgs, prev_errs)+      runRemoteTH iserv rest+    _other -> do+      r <- handleTHMessage msg+      liftIO $ writeIServ iserv (put r)+      runRemoteTH iserv recovers++-- | Read a value of type QResult from the iserv+readQResult :: Binary a => IServ -> TcM a+readQResult i = do+  qr <- liftIO $ readIServ i get+  case qr of+    QDone a -> return a+    QException str -> liftIO $ throwIO (ErrorCall str)+    QFail str -> fail str++{- Note [TH recover with -fexternal-interpreter]++Recover is slightly tricky to implement.++The meaning of "recover a b" is+ - Do a+   - If it finished with no errors, then keep the warnings it generated+   - If it failed, discard any messages it generated, and do b++Note that "failed" here can mean either+  (1) threw an exception (failTc)+  (2) generated an error message (addErrTcM)++The messages are managed by GHC in the TcM monad, whereas the+exception-handling is done in the ghc-iserv process, so we have to+coordinate between the two.++On the server:+  - emit a StartRecover message+  - run "a; FailIfErrs" inside a try+  - emit an (EndRecover x) message, where x = True if "a; FailIfErrs" failed+  - if "a; FailIfErrs" failed, run "b"++Back in GHC, when we receive:++  FailIfErrrs+    failTc if there are any error messages (= failIfErrsM)+  StartRecover+    save the current messages and start with an empty set.+  EndRecover caught_error+    Restore the previous messages,+    and merge in the new messages if caught_error is false.+-}++-- | Retrieve (or create, if it hasn't been created already), the+-- remote TH state.  The TH state is a remote reference to an IORef+-- QState living on the server, and we have to pass this to each RunTH+-- call we make.+--+-- The TH state is stored in tcg_th_remote_state in the TcGblEnv.+--+getTHState :: IServ -> TcM (ForeignRef (IORef QState))+getTHState i = do+  tcg <- getGblEnv+  th_state <- readTcRef (tcg_th_remote_state tcg)+  case th_state of+    Just rhv -> return rhv+    Nothing -> do+      hsc_env <- env_top <$> getEnv+      fhv <- liftIO $ mkFinalizedHValue hsc_env =<< iservCall i StartTH+      writeTcRef (tcg_th_remote_state tcg) (Just fhv)+      return fhv++wrapTHResult :: TcM a -> TcM (THResult a)+wrapTHResult tcm = do+  e <- tryM tcm   -- only catch 'fail', treat everything else as catastrophic+  case e of+    Left e -> return (THException (show e))+    Right a -> return (THComplete a)++handleTHMessage :: THMessage a -> TcM a+handleTHMessage msg = case msg of+  NewName a -> wrapTHResult $ TH.qNewName a+  Report b str -> wrapTHResult $ TH.qReport b str+  LookupName b str -> wrapTHResult $ TH.qLookupName b str+  Reify n -> wrapTHResult $ TH.qReify n+  ReifyFixity n -> wrapTHResult $ TH.qReifyFixity n+  ReifyInstances n ts -> wrapTHResult $ TH.qReifyInstances n ts+  ReifyRoles n -> wrapTHResult $ TH.qReifyRoles n+  ReifyAnnotations lookup tyrep ->+    wrapTHResult $ (map B.pack <$> getAnnotationsByTypeRep lookup tyrep)+  ReifyModule m -> wrapTHResult $ TH.qReifyModule m+  ReifyConStrictness nm -> wrapTHResult $ TH.qReifyConStrictness nm+  AddDependentFile f -> wrapTHResult $ TH.qAddDependentFile f+  AddTempFile s -> wrapTHResult $ TH.qAddTempFile s+  AddModFinalizer r -> do+    hsc_env <- env_top <$> getEnv+    wrapTHResult $ liftIO (mkFinalizedHValue hsc_env r) >>= addModFinalizerRef+  AddCorePlugin str -> wrapTHResult $ TH.qAddCorePlugin str+  AddTopDecls decs -> wrapTHResult $ TH.qAddTopDecls decs+  AddForeignFilePath lang str -> wrapTHResult $ TH.qAddForeignFilePath lang str+  IsExtEnabled ext -> wrapTHResult $ TH.qIsExtEnabled ext+  ExtsEnabled -> wrapTHResult $ TH.qExtsEnabled+  FailIfErrs -> wrapTHResult failIfErrsM+  _ -> panic ("handleTHMessage: unexpected message " ++ show msg)++getAnnotationsByTypeRep :: TH.AnnLookup -> TypeRep -> TcM [[Word8]]+getAnnotationsByTypeRep th_name tyrep+  = do { name <- lookupThAnnLookup th_name+       ; topEnv <- getTopEnv+       ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing+       ; tcg <- getGblEnv+       ; let selectedEpsHptAnns = findAnnsByTypeRep epsHptAnns name tyrep+       ; let selectedTcgAnns = findAnnsByTypeRep (tcg_ann_env tcg) name tyrep+       ; return (selectedEpsHptAnns ++ selectedTcgAnns) }++{-+************************************************************************+*                                                                      *+            Instance Testing+*                                                                      *+************************************************************************+-}++reifyInstances :: TH.Name -> [TH.Type] -> TcM [TH.Dec]+reifyInstances th_nm th_tys+   = addErrCtxt (text "In the argument of reifyInstances:"+                 <+> ppr_th th_nm <+> sep (map ppr_th th_tys)) $+     do { loc <- getSrcSpanM+        ; rdr_ty <- cvt loc (mkThAppTs (TH.ConT th_nm) th_tys)+          -- #9262 says to bring vars into scope, like in HsForAllTy case+          -- of rnHsTyKi+        ; let tv_rdrs = extractHsTyRdrTyVars rdr_ty+          -- Rename  to HsType Name+        ; ((tv_names, rn_ty), _fvs)+            <- checkNoErrs $ -- If there are out-of-scope Names here, then we+                             -- must error before proceeding to typecheck the+                             -- renamed type, as that will result in GHC+                             -- internal errors (#13837).+               bindLRdrNames tv_rdrs $ \ tv_names ->+               do { (rn_ty, fvs) <- rnLHsType doc rdr_ty+                  ; return ((tv_names, rn_ty), fvs) }+        ; (_tvs, ty)+            <- pushTcLevelM_   $+               solveEqualities $ -- Avoid error cascade if there are unsolved+               bindImplicitTKBndrs_Skol tv_names $+               fst <$> tcLHsType rn_ty+        ; ty <- zonkTcTypeToType ty+                -- Substitute out the meta type variables+                -- In particular, the type might have kind+                -- variables inside it (#7477)++        ; traceTc "reifyInstances" (ppr ty $$ ppr (tcTypeKind ty))+        ; case splitTyConApp_maybe ty of   -- This expands any type synonyms+            Just (tc, tys)                 -- See #7910+               | Just cls <- tyConClass_maybe tc+               -> do { inst_envs <- tcGetInstEnvs+                     ; let (matches, unifies, _) = lookupInstEnv False inst_envs cls tys+                     ; traceTc "reifyInstances1" (ppr matches)+                     ; reifyClassInstances cls (map fst matches ++ unifies) }+               | isOpenFamilyTyCon tc+               -> do { inst_envs <- tcGetFamInstEnvs+                     ; let matches = lookupFamInstEnv inst_envs tc tys+                     ; traceTc "reifyInstances2" (ppr matches)+                     ; reifyFamilyInstances tc (map fim_instance matches) }+            _  -> bale_out (hang (text "reifyInstances:" <+> quotes (ppr ty))+                               2 (text "is not a class constraint or type family application")) }+  where+    doc = ClassInstanceCtx+    bale_out msg = failWithTc msg++    cvt :: SrcSpan -> TH.Type -> TcM (LHsType GhcPs)+    cvt loc th_ty = case convertToHsType loc th_ty of+                      Left msg -> failWithTc msg+                      Right ty -> return ty++{-+************************************************************************+*                                                                      *+                        Reification+*                                                                      *+************************************************************************+-}++lookupName :: Bool      -- True  <=> type namespace+                        -- False <=> value namespace+           -> String -> TcM (Maybe TH.Name)+lookupName is_type_name s+  = do { lcl_env <- getLocalRdrEnv+       ; case lookupLocalRdrEnv lcl_env rdr_name of+           Just n  -> return (Just (reifyName n))+           Nothing -> do { mb_nm <- lookupGlobalOccRn_maybe rdr_name+                         ; return (fmap reifyName mb_nm) } }+  where+    th_name = TH.mkName s       -- Parses M.x into a base of 'x' and a module of 'M'++    occ_fs :: FastString+    occ_fs = mkFastString (TH.nameBase th_name)++    occ :: OccName+    occ | is_type_name+        = if isLexVarSym occ_fs || isLexCon occ_fs+                             then mkTcOccFS    occ_fs+                             else mkTyVarOccFS occ_fs+        | otherwise+        = if isLexCon occ_fs then mkDataOccFS occ_fs+                             else mkVarOccFS  occ_fs++    rdr_name = case TH.nameModule th_name of+                 Nothing  -> mkRdrUnqual occ+                 Just mod -> mkRdrQual (mkModuleName mod) occ++getThing :: TH.Name -> TcM TcTyThing+getThing th_name+  = do  { name <- lookupThName th_name+        ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name)+        ; tcLookupTh name }+        -- ToDo: this tcLookup could fail, which would give a+        --       rather unhelpful error message+  where+    ppr_ns (TH.Name _ (TH.NameG TH.DataName  _pkg _mod)) = text "data"+    ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"+    ppr_ns (TH.Name _ (TH.NameG TH.VarName   _pkg _mod)) = text "var"+    ppr_ns _ = panic "reify/ppr_ns"++reify :: TH.Name -> TcM TH.Info+reify th_name+  = do  { traceTc "reify 1" (text (TH.showName th_name))+        ; thing <- getThing th_name+        ; traceTc "reify 2" (ppr thing)+        ; reifyThing thing }++lookupThName :: TH.Name -> TcM Name+lookupThName th_name = do+    mb_name <- lookupThName_maybe th_name+    case mb_name of+        Nothing   -> failWithTc (notInScope th_name)+        Just name -> return name++lookupThName_maybe :: TH.Name -> TcM (Maybe Name)+lookupThName_maybe th_name+  =  do { names <- mapMaybeM lookup (thRdrNameGuesses th_name)+          -- Pick the first that works+          -- E.g. reify (mkName "A") will pick the class A in preference to the data constructor A+        ; return (listToMaybe names) }+  where+    lookup rdr_name+        = do {  -- Repeat much of lookupOccRn, because we want+                -- to report errors in a TH-relevant way+             ; rdr_env <- getLocalRdrEnv+             ; case lookupLocalRdrEnv rdr_env rdr_name of+                 Just name -> return (Just name)+                 Nothing   -> lookupGlobalOccRn_maybe rdr_name }++tcLookupTh :: Name -> TcM TcTyThing+-- This is a specialised version of TcEnv.tcLookup; specialised mainly in that+-- it gives a reify-related error message on failure, whereas in the normal+-- tcLookup, failure is a bug.+tcLookupTh name+  = do  { (gbl_env, lcl_env) <- getEnvs+        ; case lookupNameEnv (tcl_env lcl_env) name of {+                Just thing -> return thing;+                Nothing    ->++          case lookupNameEnv (tcg_type_env gbl_env) name of {+                Just thing -> return (AGlobal thing);+                Nothing    ->++          -- EZY: I don't think this choice matters, no TH in signatures!+          if nameIsLocalOrFrom (tcg_semantic_mod gbl_env) name+          then  -- It's defined in this module+                failWithTc (notInEnv name)++          else+     do { mb_thing <- tcLookupImported_maybe name+        ; case mb_thing of+            Succeeded thing -> return (AGlobal thing)+            Failed msg      -> failWithTc msg+    }}}}++notInScope :: TH.Name -> SDoc+notInScope th_name = quotes (text (TH.pprint th_name)) <+>+                     text "is not in scope at a reify"+        -- Ugh! Rather an indirect way to display the name++notInEnv :: Name -> SDoc+notInEnv name = quotes (ppr name) <+>+                     text "is not in the type environment at a reify"++------------------------------+reifyRoles :: TH.Name -> TcM [TH.Role]+reifyRoles th_name+  = do { thing <- getThing th_name+       ; case thing of+           AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))+           _ -> failWithTc (text "No roles associated with" <+> (ppr thing))+       }+  where+    reify_role Nominal          = TH.NominalR+    reify_role Representational = TH.RepresentationalR+    reify_role Phantom          = TH.PhantomR++------------------------------+reifyThing :: TcTyThing -> TcM TH.Info+-- The only reason this is monadic is for error reporting,+-- which in turn is mainly for the case when TH can't express+-- some random GHC extension++reifyThing (AGlobal (AnId id))+  = do  { ty <- reifyType (idType id)+        ; let v = reifyName id+        ; case idDetails id of+            ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls))+            RecSelId{sel_tycon=RecSelData tc}+                          -> return (TH.VarI (reifySelector id tc) ty Nothing)+            _             -> return (TH.VarI     v ty Nothing)+    }++reifyThing (AGlobal (ATyCon tc))   = reifyTyCon tc+reifyThing (AGlobal (AConLike (RealDataCon dc)))+  = do  { let name = dataConName dc+        ; ty <- reifyType (idType (dataConWrapId dc))+        ; return (TH.DataConI (reifyName name) ty+                              (reifyName (dataConOrigTyCon dc)))+        }++reifyThing (AGlobal (AConLike (PatSynCon ps)))+  = do { let name = reifyName ps+       ; ty <- reifyPatSynType (patSynSig ps)+       ; return (TH.PatSynI name ty) }++reifyThing (ATcId {tct_id = id})+  = do  { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even+                                        -- though it may be incomplete+        ; ty2 <- reifyType ty1+        ; return (TH.VarI (reifyName id) ty2 Nothing) }++reifyThing (ATyVar tv tv1)+  = do { ty1 <- zonkTcTyVar tv1+       ; ty2 <- reifyType ty1+       ; return (TH.TyVarI (reifyName tv) ty2) }++reifyThing thing = pprPanic "reifyThing" (pprTcTyThingCategory thing)++-------------------------------------------+reifyAxBranch :: TyCon -> CoAxBranch -> TcM TH.TySynEqn+reifyAxBranch fam_tc (CoAxBranch { cab_tvs = tvs+                                 , cab_lhs = lhs+                                 , cab_rhs = rhs })+            -- remove kind patterns (#8884)+  = do { tvs' <- reifyTyVarsToMaybe tvs+       ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs+       ; lhs' <- reifyTypes lhs_types_only+       ; annot_th_lhs <- zipWith3M annotThType (mkIsPolyTvs fam_tvs)+                                   lhs_types_only lhs'+       ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam_tc) annot_th_lhs+       ; rhs'  <- reifyType rhs+       ; return (TH.TySynEqn tvs' lhs_type rhs') }+  where+    fam_tvs = tyConVisibleTyVars fam_tc++reifyTyCon :: TyCon -> TcM TH.Info+reifyTyCon tc+  | Just cls <- tyConClass_maybe tc+  = reifyClass cls++  | isFunTyCon tc+  = return (TH.PrimTyConI (reifyName tc) 2                False)++  | isPrimTyCon tc+  = return (TH.PrimTyConI (reifyName tc) (length (tyConVisibleTyVars tc))+                          (isUnliftedTyCon tc))++  | isTypeFamilyTyCon tc+  = do { let tvs      = tyConTyVars tc+             res_kind = tyConResKind tc+             resVar   = famTcResVar tc++       ; kind' <- reifyKind res_kind+       ; let (resultSig, injectivity) =+                 case resVar of+                   Nothing   -> (TH.KindSig kind', Nothing)+                   Just name ->+                     let thName   = reifyName name+                         injAnnot = tyConInjectivityInfo tc+                         sig = TH.TyVarSig (TH.KindedTV thName kind')+                         inj = case injAnnot of+                                 NotInjective -> Nothing+                                 Injective ms ->+                                     Just (TH.InjectivityAnn thName injRHS)+                                   where+                                     injRHS = map (reifyName . tyVarName)+                                                  (filterByList ms tvs)+                     in (sig, inj)+       ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)+       ; let tfHead =+               TH.TypeFamilyHead (reifyName tc) tvs' resultSig injectivity+       ; if isOpenTypeFamilyTyCon tc+         then do { fam_envs <- tcGetFamInstEnvs+                 ; instances <- reifyFamilyInstances tc+                                  (familyInstances fam_envs tc)+                 ; return (TH.FamilyI (TH.OpenTypeFamilyD tfHead) instances) }+         else do { eqns <-+                     case isClosedSynFamilyTyConWithAxiom_maybe tc of+                       Just ax -> mapM (reifyAxBranch tc) $+                                  fromBranches $ coAxiomBranches ax+                       Nothing -> return []+                 ; return (TH.FamilyI (TH.ClosedTypeFamilyD tfHead eqns)+                      []) } }++  | isDataFamilyTyCon tc+  = do { let res_kind = tyConResKind tc++       ; kind' <- fmap Just (reifyKind res_kind)++       ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)+       ; fam_envs <- tcGetFamInstEnvs+       ; instances <- reifyFamilyInstances tc (familyInstances fam_envs tc)+       ; return (TH.FamilyI+                       (TH.DataFamilyD (reifyName tc) tvs' kind') instances) }++  | Just (_, rhs) <- synTyConDefn_maybe tc  -- Vanilla type synonym+  = do { rhs' <- reifyType rhs+       ; tvs' <- reifyTyVars (tyConVisibleTyVars tc)+       ; return (TH.TyConI+                   (TH.TySynD (reifyName tc) tvs' rhs'))+       }++  | otherwise+  = do  { cxt <- reifyCxt (tyConStupidTheta tc)+        ; let tvs      = tyConTyVars tc+              dataCons = tyConDataCons tc+              isGadt   = isGadtSyntaxTyCon tc+        ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys tvs)) dataCons+        ; r_tvs <- reifyTyVars (tyConVisibleTyVars tc)+        ; let name = reifyName tc+              deriv = []        -- Don't know about deriving+              decl | isNewTyCon tc =+                       TH.NewtypeD cxt name r_tvs Nothing (head cons) deriv+                   | otherwise     =+                       TH.DataD    cxt name r_tvs Nothing       cons  deriv+        ; return (TH.TyConI decl) }++reifyDataCon :: Bool -> [Type] -> DataCon -> TcM TH.Con+reifyDataCon isGadtDataCon tys dc+  = do { let -- used for H98 data constructors+             (ex_tvs, theta, arg_tys)+                 = dataConInstSig dc tys+             -- used for GADTs data constructors+             g_user_tvs' = dataConUserTyVars dc+             (g_univ_tvs, _, g_eq_spec, g_theta', g_arg_tys', g_res_ty')+                 = dataConFullSig dc+             (srcUnpks, srcStricts)+                 = mapAndUnzip reifySourceBang (dataConSrcBangs dc)+             dcdBangs  = zipWith TH.Bang srcUnpks srcStricts+             fields    = dataConFieldLabels dc+             name      = reifyName dc+             -- Universal tvs present in eq_spec need to be filtered out, as+             -- they will not appear anywhere in the type.+             eq_spec_tvs = mkVarSet (map eqSpecTyVar g_eq_spec)++       ; (univ_subst, _)+              -- See Note [Freshen reified GADT constructors' universal tyvars]+           <- freshenTyVarBndrs $+              filterOut (`elemVarSet` eq_spec_tvs) g_univ_tvs+       ; let (tvb_subst, g_user_tvs) = substTyVarBndrs univ_subst g_user_tvs'+             g_theta   = substTys tvb_subst g_theta'+             g_arg_tys = substTys tvb_subst g_arg_tys'+             g_res_ty  = substTy  tvb_subst g_res_ty'++       ; r_arg_tys <- reifyTypes (if isGadtDataCon then g_arg_tys else arg_tys)++       ; main_con <-+           if | not (null fields) && not isGadtDataCon ->+                  return $ TH.RecC name (zip3 (map reifyFieldLabel fields)+                                         dcdBangs r_arg_tys)+              | not (null fields) -> do+                  { res_ty <- reifyType g_res_ty+                  ; return $ TH.RecGadtC [name]+                                     (zip3 (map (reifyName . flSelector) fields)+                                      dcdBangs r_arg_tys) res_ty }+                -- We need to check not isGadtDataCon here because GADT+                -- constructors can be declared infix.+                -- See Note [Infix GADT constructors] in TcTyClsDecls.+              | dataConIsInfix dc && not isGadtDataCon ->+                  ASSERT( arg_tys `lengthIs` 2 ) do+                  { let [r_a1, r_a2] = r_arg_tys+                        [s1,   s2]   = dcdBangs+                  ; return $ TH.InfixC (s1,r_a1) name (s2,r_a2) }+              | isGadtDataCon -> do+                  { res_ty <- reifyType g_res_ty+                  ; return $ TH.GadtC [name] (dcdBangs `zip` r_arg_tys) res_ty }+              | otherwise ->+                  return $ TH.NormalC name (dcdBangs `zip` r_arg_tys)++       ; let (ex_tvs', theta') | isGadtDataCon = (g_user_tvs, g_theta)+                               | otherwise     = ASSERT( all isTyVar ex_tvs )+                                                 -- no covars for haskell syntax+                                                 (ex_tvs, theta)+             ret_con | null ex_tvs' && null theta' = return main_con+                     | otherwise                   = do+                         { cxt <- reifyCxt theta'+                         ; ex_tvs'' <- reifyTyVars ex_tvs'+                         ; return (TH.ForallC ex_tvs'' cxt main_con) }+       ; ASSERT( arg_tys `equalLength` dcdBangs )+         ret_con }++{-+Note [Freshen reified GADT constructors' universal tyvars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose one were to reify this GADT:++  data a :~: b where+    Refl :: forall a b. (a ~ b) => a :~: b++We ought to be careful here about the uniques we give to the occurrences of `a`+and `b` in this definition. That is because in the original DataCon, all uses+of `a` and `b` have the same unique, since `a` and `b` are both universally+quantified type variables--that is, they are used in both the (:~:) tycon as+well as in the constructor type signature. But when we turn the DataCon+definition into the reified one, the `a` and `b` in the constructor type+signature becomes differently scoped than the `a` and `b` in `data a :~: b`.++While it wouldn't technically be *wrong* per se to re-use the same uniques for+`a` and `b` across these two different scopes, it's somewhat annoying for end+users of Template Haskell, since they wouldn't be able to rely on the+assumption that all TH names have globally distinct uniques (#13885). For this+reason, we freshen the universally quantified tyvars that go into the reified+GADT constructor type signature to give them distinct uniques from their+counterparts in the tycon.+-}++------------------------------+reifyClass :: Class -> TcM TH.Info+reifyClass cls+  = do  { cxt <- reifyCxt theta+        ; inst_envs <- tcGetInstEnvs+        ; insts <- reifyClassInstances cls (InstEnv.classInstances inst_envs cls)+        ; assocTys <- concatMapM reifyAT ats+        ; ops <- concatMapM reify_op op_stuff+        ; tvs' <- reifyTyVars (tyConVisibleTyVars (classTyCon cls))+        ; let dec = TH.ClassD cxt (reifyName cls) tvs' fds' (assocTys ++ ops)+        ; return (TH.ClassI dec insts) }+  where+    (_, fds, theta, _, ats, op_stuff) = classExtraBigSig cls+    fds' = map reifyFunDep fds+    reify_op (op, def_meth)+      = do { let (_, _, ty) = tcSplitMethodTy (idType op)+               -- Use tcSplitMethodTy to get rid of the extraneous class+               -- variables and predicates at the beginning of op's type+               -- (see #15551).+           ; ty' <- reifyType ty+           ; let nm' = reifyName op+           ; case def_meth of+                Just (_, GenericDM gdm_ty) ->+                  do { gdm_ty' <- reifyType gdm_ty+                     ; return [TH.SigD nm' ty', TH.DefaultSigD nm' gdm_ty'] }+                _ -> return [TH.SigD nm' ty'] }++    reifyAT :: ClassATItem -> TcM [TH.Dec]+    reifyAT (ATI tycon def) = do+      tycon' <- reifyTyCon tycon+      case tycon' of+        TH.FamilyI dec _ -> do+          let (tyName, tyArgs) = tfNames dec+          (dec :) <$> maybe (return [])+                            (fmap (:[]) . reifyDefImpl tyName tyArgs . fst)+                            def+        _ -> pprPanic "reifyAT" (text (show tycon'))++    reifyDefImpl :: TH.Name -> [TH.Name] -> Type -> TcM TH.Dec+    reifyDefImpl n args ty =+      TH.TySynInstD . TH.TySynEqn Nothing (mkThAppTs (TH.ConT n) (map TH.VarT args))+                                  <$> reifyType ty++    tfNames :: TH.Dec -> (TH.Name, [TH.Name])+    tfNames (TH.OpenTypeFamilyD (TH.TypeFamilyHead n args _ _))+      = (n, map bndrName args)+    tfNames d = pprPanic "tfNames" (text (show d))++    bndrName :: TH.TyVarBndr -> TH.Name+    bndrName (TH.PlainTV n)    = n+    bndrName (TH.KindedTV n _) = n++------------------------------+-- | Annotate (with TH.SigT) a type if the first parameter is True+-- and if the type contains a free variable.+-- This is used to annotate type patterns for poly-kinded tyvars in+-- reifying class and type instances. See #8953 and th/T8953.+annotThType :: Bool   -- True <=> annotate+            -> TyCoRep.Type -> TH.Type -> TcM TH.Type+  -- tiny optimization: if the type is annotated, don't annotate again.+annotThType _    _  th_ty@(TH.SigT {}) = return th_ty+annotThType True ty th_ty+  | not $ isEmptyVarSet $ filterVarSet isTyVar $ tyCoVarsOfType ty+  = do { let ki = tcTypeKind ty+       ; th_ki <- reifyKind ki+       ; return (TH.SigT th_ty th_ki) }+annotThType _    _ th_ty = return th_ty++-- | For every type variable in the input,+-- report whether or not the tv is poly-kinded. This is used to eventually+-- feed into 'annotThType'.+mkIsPolyTvs :: [TyVar] -> [Bool]+mkIsPolyTvs = map is_poly_tv+  where+    is_poly_tv tv = not $+                    isEmptyVarSet $+                    filterVarSet isTyVar $+                    tyCoVarsOfType $+                    tyVarKind tv++------------------------------+reifyClassInstances :: Class -> [ClsInst] -> TcM [TH.Dec]+reifyClassInstances cls insts+  = mapM (reifyClassInstance (mkIsPolyTvs tvs)) insts+  where+    tvs = tyConVisibleTyVars (classTyCon cls)++reifyClassInstance :: [Bool]  -- True <=> the corresponding tv is poly-kinded+                              -- includes only *visible* tvs+                   -> ClsInst -> TcM TH.Dec+reifyClassInstance is_poly_tvs i+  = do { cxt <- reifyCxt theta+       ; let vis_types = filterOutInvisibleTypes cls_tc types+       ; thtypes <- reifyTypes vis_types+       ; annot_thtypes <- zipWith3M annotThType is_poly_tvs vis_types thtypes+       ; let head_ty = mkThAppTs (TH.ConT (reifyName cls)) annot_thtypes+       ; return $ (TH.InstanceD over cxt head_ty []) }+  where+     (_tvs, theta, cls, types) = tcSplitDFunTy (idType dfun)+     cls_tc   = classTyCon cls+     dfun     = instanceDFunId i+     over     = case overlapMode (is_flag i) of+                  NoOverlap _     -> Nothing+                  Overlappable _  -> Just TH.Overlappable+                  Overlapping _   -> Just TH.Overlapping+                  Overlaps _      -> Just TH.Overlaps+                  Incoherent _    -> Just TH.Incoherent++------------------------------+reifyFamilyInstances :: TyCon -> [FamInst] -> TcM [TH.Dec]+reifyFamilyInstances fam_tc fam_insts+  = mapM (reifyFamilyInstance (mkIsPolyTvs fam_tvs)) fam_insts+  where+    fam_tvs = tyConVisibleTyVars fam_tc++reifyFamilyInstance :: [Bool] -- True <=> the corresponding tv is poly-kinded+                              -- includes only *visible* tvs+                    -> FamInst -> TcM TH.Dec+reifyFamilyInstance is_poly_tvs (FamInst { fi_flavor = flavor+                                         , fi_axiom = ax+                                         , fi_fam = fam })+  | let fam_tc = coAxiomTyCon ax+        branch = coAxiomSingleBranch ax+  , CoAxBranch { cab_tvs = tvs, cab_lhs = lhs, cab_rhs = rhs } <- branch+  = case flavor of+      SynFamilyInst ->+               -- remove kind patterns (#8884)+        do { th_tvs <- reifyTyVarsToMaybe tvs+           ; let lhs_types_only = filterOutInvisibleTypes fam_tc lhs+           ; th_lhs <- reifyTypes lhs_types_only+           ; annot_th_lhs <- zipWith3M annotThType is_poly_tvs lhs_types_only+                                                   th_lhs+           ; let lhs_type = mkThAppTs (TH.ConT $ reifyName fam) annot_th_lhs+           ; th_rhs <- reifyType rhs+           ; return (TH.TySynInstD (TH.TySynEqn th_tvs lhs_type th_rhs)) }++      DataFamilyInst rep_tc ->+        do { let -- eta-expand lhs types, because sometimes data/newtype+                 -- instances are eta-reduced; See #9692+                 -- See Note [Eta reduction for data families] in FamInstEnv+                 (ee_tvs, ee_lhs, _) = etaExpandCoAxBranch branch+                 fam'     = reifyName fam+                 dataCons = tyConDataCons rep_tc+                 isGadt   = isGadtSyntaxTyCon rep_tc+           ; th_tvs <- reifyTyVarsToMaybe ee_tvs+           ; cons <- mapM (reifyDataCon isGadt (mkTyVarTys ee_tvs)) dataCons+           ; let types_only = filterOutInvisibleTypes fam_tc ee_lhs+           ; th_tys <- reifyTypes types_only+           ; annot_th_tys <- zipWith3M annotThType is_poly_tvs types_only th_tys+           ; let lhs_type = mkThAppTs (TH.ConT fam') annot_th_tys+           ; return $+               if isNewTyCon rep_tc+               then TH.NewtypeInstD [] th_tvs lhs_type Nothing (head cons) []+               else TH.DataInstD    [] th_tvs lhs_type Nothing       cons  []+           }++------------------------------+reifyType :: TyCoRep.Type -> TcM TH.Type+-- Monadic only because of failure+reifyType ty                | tcIsLiftedTypeKind ty = return TH.StarT+  -- Make sure to use tcIsLiftedTypeKind here, since we don't want to confuse it+  -- with Constraint (#14869).+reifyType ty@(ForAllTy (Bndr _ argf) _)+                            = reify_for_all argf ty+reifyType (LitTy t)         = do { r <- reifyTyLit t; return (TH.LitT r) }+reifyType (TyVarTy tv)      = return (TH.VarT (reifyName tv))+reifyType (TyConApp tc tys) = reify_tc_app tc tys   -- Do not expand type synonyms here+reifyType ty@(AppTy {})     = do+  let (ty_head, ty_args) = splitAppTys ty+  ty_head' <- reifyType ty_head+  ty_args' <- reifyTypes (filter_out_invisible_args ty_head ty_args)+  pure $ mkThAppTs ty_head' ty_args'+  where+    -- Make sure to filter out any invisible arguments. For instance, if you+    -- reify the following:+    --+    --   newtype T (f :: forall a. a -> Type) = MkT (f Bool)+    --+    -- Then you should receive back `f Bool`, not `f Type Bool`, since the+    -- `Type` argument is invisible (#15792).+    filter_out_invisible_args :: Type -> [Type] -> [Type]+    filter_out_invisible_args ty_head ty_args =+      filterByList (map isVisibleArgFlag $ appTyArgFlags ty_head ty_args)+                   ty_args+reifyType ty@(FunTy { ft_af = af, ft_arg = t1, ft_res = t2 })+  | InvisArg <- af = reify_for_all Inferred ty  -- Types like ((?x::Int) => Char -> Char)+  | otherwise      = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }+reifyType (CastTy t _)      = reifyType t -- Casts are ignored in TH+reifyType ty@(CoercionTy {})= noTH (sLit "coercions in types") (ppr ty)++reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type+-- Arg of reify_for_all is always ForAllTy or a predicate FunTy+reify_for_all argf ty = do+  tvs' <- reifyTyVars tvs+  case argToForallVisFlag argf of+    ForallVis   -> do phi' <- reifyType phi+                      pure $ TH.ForallVisT tvs' phi'+    ForallInvis -> do let (cxt, tau) = tcSplitPhiTy phi+                      cxt' <- reifyCxt cxt+                      tau' <- reifyType tau+                      pure $ TH.ForallT tvs' cxt' tau'+  where+    (tvs, phi) = tcSplitForAllTysSameVis argf ty++reifyTyLit :: TyCoRep.TyLit -> TcM TH.TyLit+reifyTyLit (NumTyLit n) = return (TH.NumTyLit n)+reifyTyLit (StrTyLit s) = return (TH.StrTyLit (unpackFS s))++reifyTypes :: [Type] -> TcM [TH.Type]+reifyTypes = mapM reifyType++reifyPatSynType+  :: ([TyVar], ThetaType, [TyVar], ThetaType, [Type], Type) -> TcM TH.Type+-- reifies a pattern synonym's type and returns its *complete* type+-- signature; see NOTE [Pattern synonym signatures and Template+-- Haskell]+reifyPatSynType (univTyVars, req, exTyVars, prov, argTys, resTy)+  = do { univTyVars' <- reifyTyVars univTyVars+       ; req'        <- reifyCxt req+       ; exTyVars'   <- reifyTyVars exTyVars+       ; prov'       <- reifyCxt prov+       ; tau'        <- reifyType (mkVisFunTys argTys resTy)+       ; return $ TH.ForallT univTyVars' req'+                $ TH.ForallT exTyVars' prov' tau' }++reifyKind :: Kind -> TcM TH.Kind+reifyKind = reifyType++reifyCxt :: [PredType] -> TcM [TH.Pred]+reifyCxt   = mapM reifyType++reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep+reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)++reifyTyVars :: [TyVar] -> TcM [TH.TyVarBndr]+reifyTyVars tvs = mapM reify_tv tvs+  where+    -- even if the kind is *, we need to include a kind annotation,+    -- in case a poly-kind would be inferred without the annotation.+    -- See #8953 or test th/T8953+    reify_tv tv = TH.KindedTV name <$> reifyKind kind+      where+        kind = tyVarKind tv+        name = reifyName tv++reifyTyVarsToMaybe :: [TyVar] -> TcM (Maybe [TH.TyVarBndr])+reifyTyVarsToMaybe []  = pure Nothing+reifyTyVarsToMaybe tys = Just <$> reifyTyVars tys++reify_tc_app :: TyCon -> [Type.Type] -> TcM TH.Type+reify_tc_app tc tys+  = do { tys' <- reifyTypes (filterOutInvisibleTypes tc tys)+       ; maybe_sig_t (mkThAppTs r_tc tys') }+  where+    arity       = tyConArity tc++    r_tc | isUnboxedSumTyCon tc           = TH.UnboxedSumT (arity `div` 2)+         | isUnboxedTupleTyCon tc         = TH.UnboxedTupleT (arity `div` 2)+         | isPromotedTupleTyCon tc        = TH.PromotedTupleT (arity `div` 2)+             -- See Note [Unboxed tuple RuntimeRep vars] in TyCon+         | isTupleTyCon tc                = if isPromotedDataCon tc+                                            then TH.PromotedTupleT arity+                                            else TH.TupleT arity+         | tc `hasKey` constraintKindTyConKey+                                          = TH.ConstraintT+         | tc `hasKey` funTyConKey        = TH.ArrowT+         | tc `hasKey` listTyConKey       = TH.ListT+         | tc `hasKey` nilDataConKey      = TH.PromotedNilT+         | tc `hasKey` consDataConKey     = TH.PromotedConsT+         | tc `hasKey` heqTyConKey        = TH.EqualityT+         | tc `hasKey` eqPrimTyConKey     = TH.EqualityT+         | tc `hasKey` eqReprPrimTyConKey = TH.ConT (reifyName coercibleTyCon)+         | isPromotedDataCon tc           = TH.PromotedT (reifyName tc)+         | otherwise                      = TH.ConT (reifyName tc)++    -- See Note [When does a tycon application need an explicit kind+    -- signature?] in TyCoRep+    maybe_sig_t th_type+      | tyConAppNeedsKindSig+          False -- We don't reify types using visible kind applications, so+                -- don't count specified binders as contributing towards+                -- injective positions in the kind of the tycon.+          tc (length tys)+      = do { let full_kind = tcTypeKind (mkTyConApp tc tys)+           ; th_full_kind <- reifyKind full_kind+           ; return (TH.SigT th_type th_full_kind) }+      | otherwise+      = return th_type++------------------------------+reifyName :: NamedThing n => n -> TH.Name+reifyName thing+  | isExternalName name+              = mk_varg pkg_str mod_str occ_str+  | otherwise = TH.mkNameU occ_str (toInteger $ getKey (getUnique name))+        -- Many of the things we reify have local bindings, and+        -- NameL's aren't supposed to appear in binding positions, so+        -- we use NameU.  When/if we start to reify nested things, that+        -- have free variables, we may need to generate NameL's for them.+  where+    name    = getName thing+    mod     = ASSERT( isExternalName name ) nameModule name+    pkg_str = unitIdString (moduleUnitId mod)+    mod_str = moduleNameString (moduleName mod)+    occ_str = occNameString occ+    occ     = nameOccName name+    mk_varg | OccName.isDataOcc occ = TH.mkNameG_d+            | OccName.isVarOcc  occ = TH.mkNameG_v+            | OccName.isTcOcc   occ = TH.mkNameG_tc+            | otherwise             = pprPanic "reifyName" (ppr name)++-- See Note [Reifying field labels]+reifyFieldLabel :: FieldLabel -> TH.Name+reifyFieldLabel fl+  | flIsOverloaded fl+              = TH.Name (TH.mkOccName occ_str) (TH.NameQ (TH.mkModName mod_str))+  | otherwise = TH.mkNameG_v pkg_str mod_str occ_str+  where+    name    = flSelector fl+    mod     = ASSERT( isExternalName name ) nameModule name+    pkg_str = unitIdString (moduleUnitId mod)+    mod_str = moduleNameString (moduleName mod)+    occ_str = unpackFS (flLabel fl)++reifySelector :: Id -> TyCon -> TH.Name+reifySelector id tc+  = case find ((idName id ==) . flSelector) (tyConFieldLabels tc) of+      Just fl -> reifyFieldLabel fl+      Nothing -> pprPanic "reifySelector: missing field" (ppr id $$ ppr tc)++------------------------------+reifyFixity :: Name -> TcM (Maybe TH.Fixity)+reifyFixity name+  = do { (found, fix) <- lookupFixityRn_help name+       ; return (if found then Just (conv_fix fix) else Nothing) }+    where+      conv_fix (BasicTypes.Fixity _ i d) = TH.Fixity i (conv_dir d)+      conv_dir BasicTypes.InfixR = TH.InfixR+      conv_dir BasicTypes.InfixL = TH.InfixL+      conv_dir BasicTypes.InfixN = TH.InfixN++reifyUnpackedness :: DataCon.SrcUnpackedness -> TH.SourceUnpackedness+reifyUnpackedness NoSrcUnpack = TH.NoSourceUnpackedness+reifyUnpackedness SrcNoUnpack = TH.SourceNoUnpack+reifyUnpackedness SrcUnpack   = TH.SourceUnpack++reifyStrictness :: DataCon.SrcStrictness -> TH.SourceStrictness+reifyStrictness NoSrcStrict = TH.NoSourceStrictness+reifyStrictness SrcStrict   = TH.SourceStrict+reifyStrictness SrcLazy     = TH.SourceLazy++reifySourceBang :: DataCon.HsSrcBang+                -> (TH.SourceUnpackedness, TH.SourceStrictness)+reifySourceBang (HsSrcBang _ u s) = (reifyUnpackedness u, reifyStrictness s)++reifyDecidedStrictness :: DataCon.HsImplBang -> TH.DecidedStrictness+reifyDecidedStrictness HsLazy     = TH.DecidedLazy+reifyDecidedStrictness HsStrict   = TH.DecidedStrict+reifyDecidedStrictness HsUnpack{} = TH.DecidedUnpack++------------------------------+lookupThAnnLookup :: TH.AnnLookup -> TcM CoreAnnTarget+lookupThAnnLookup (TH.AnnLookupName th_nm) = fmap NamedTarget (lookupThName th_nm)+lookupThAnnLookup (TH.AnnLookupModule (TH.Module pn mn))+  = return $ ModuleTarget $+    mkModule (stringToUnitId $ TH.pkgString pn) (mkModuleName $ TH.modString mn)++reifyAnnotations :: Data a => TH.AnnLookup -> TcM [a]+reifyAnnotations th_name+  = do { name <- lookupThAnnLookup th_name+       ; topEnv <- getTopEnv+       ; epsHptAnns <- liftIO $ prepareAnnotations topEnv Nothing+       ; tcg <- getGblEnv+       ; let selectedEpsHptAnns = findAnns deserializeWithData epsHptAnns name+       ; let selectedTcgAnns = findAnns deserializeWithData (tcg_ann_env tcg) name+       ; return (selectedEpsHptAnns ++ selectedTcgAnns) }++------------------------------+modToTHMod :: Module -> TH.Module+modToTHMod m = TH.Module (TH.PkgName $ unitIdString  $ moduleUnitId m)+                         (TH.ModName $ moduleNameString $ moduleName m)++reifyModule :: TH.Module -> TcM TH.ModuleInfo+reifyModule (TH.Module (TH.PkgName pkgString) (TH.ModName mString)) = do+  this_mod <- getModule+  let reifMod = mkModule (stringToUnitId pkgString) (mkModuleName mString)+  if (reifMod == this_mod) then reifyThisModule else reifyFromIface reifMod+    where+      reifyThisModule = do+        usages <- fmap (map modToTHMod . moduleEnvKeys . imp_mods) getImports+        return $ TH.ModuleInfo usages++      reifyFromIface reifMod = do+        iface <- loadInterfaceForModule (text "reifying module from TH for" <+> ppr reifMod) reifMod+        let usages = [modToTHMod m | usage <- mi_usages iface,+                                     Just m <- [usageToModule (moduleUnitId reifMod) usage] ]+        return $ TH.ModuleInfo usages++      usageToModule :: UnitId -> Usage -> Maybe Module+      usageToModule _ (UsageFile {}) = Nothing+      usageToModule this_pkg (UsageHomeModule { usg_mod_name = mn }) = Just $ mkModule this_pkg mn+      usageToModule _ (UsagePackageModule { usg_mod = m }) = Just m+      usageToModule _ (UsageMergedRequirement { usg_mod = m }) = Just m++------------------------------+mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type+mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys++noTH :: PtrString -> SDoc -> TcM a+noTH s d = failWithTc (hsep [text "Can't represent" <+> ptext s <+>+                                text "in Template Haskell:",+                             nest 2 d])++ppr_th :: TH.Ppr a => a -> SDoc+ppr_th x = text (TH.pprint x)++{-+Note [Reifying field labels]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When reifying a datatype declared with DuplicateRecordFields enabled, we want+the reified names of the fields to be labels rather than selector functions.+That is, we want (reify ''T) and (reify 'foo) to produce++    data T = MkT { foo :: Int }+    foo :: T -> Int++rather than++    data T = MkT { $sel:foo:MkT :: Int }+    $sel:foo:MkT :: T -> Int++because otherwise TH code that uses the field names as strings will silently do+the wrong thing.  Thus we use the field label (e.g. foo) as the OccName, rather+than the selector (e.g. $sel:foo:MkT).  Since the Orig name M.foo isn't in the+environment, NameG can't be used to represent such fields.  Instead,+reifyFieldLabel uses NameQ.++However, this means that extracting the field name from the output of reify, and+trying to reify it again, may fail with an ambiguity error if there are multiple+such fields defined in the module (see the test case+overloadedrecflds/should_fail/T11103.hs).  The "proper" fix requires changes to+the TH AST to make it able to represent duplicate record fields.+-}
+ compiler/typecheck/TcSplice.hs-boot view
@@ -0,0 +1,46 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}++module TcSplice where++import GhcPrelude+import Name+import HsExpr   ( PendingRnSplice, DelayedSplice )+import TcRnTypes( TcM , SpliceType )+import TcType   ( ExpRhoType )+import Annotations ( Annotation, CoreAnnTarget )+import HsExtension ( GhcTcId, GhcRn, GhcPs, GhcTc )++import HsSyn      ( HsSplice, HsBracket, HsExpr, LHsExpr, LHsType, LPat,+                    LHsDecl, ThModFinalizers )+import qualified Language.Haskell.TH as TH++tcSpliceExpr :: HsSplice GhcRn+             -> ExpRhoType+             -> TcM (HsExpr GhcTcId)++tcUntypedBracket :: HsExpr GhcRn+                 -> HsBracket GhcRn+                 -> [PendingRnSplice]+                 -> ExpRhoType+                 -> TcM (HsExpr GhcTcId)+tcTypedBracket :: HsExpr GhcRn+               -> HsBracket GhcRn+               -> ExpRhoType+               -> TcM (HsExpr GhcTcId)++runTopSplice :: DelayedSplice -> TcM (HsExpr GhcTc)++runAnnotation     :: CoreAnnTarget -> LHsExpr GhcRn -> TcM Annotation++tcTopSpliceExpr :: SpliceType -> TcM (LHsExpr GhcTcId) -> TcM (LHsExpr GhcTcId)++runMetaE :: LHsExpr GhcTcId -> TcM (LHsExpr GhcPs)+runMetaP :: LHsExpr GhcTcId -> TcM (LPat GhcPs)+runMetaT :: LHsExpr GhcTcId -> TcM (LHsType GhcPs)+runMetaD :: LHsExpr GhcTcId -> TcM [LHsDecl GhcPs]++lookupThName_maybe :: TH.Name -> TcM (Maybe Name)+runQuasi :: TH.Q a -> TcM a+runRemoteModFinalizers :: ThModFinalizers -> TcM ()+finishTH :: TcM ()
+ compiler/typecheck/TcTyClsDecls.hs view
@@ -0,0 +1,4014 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1996-1998+++TcTyClsDecls: Typecheck type and class declarations+-}++{-# LANGUAGE CPP, TupleSections, MultiWayIf #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module TcTyClsDecls (+        tcTyAndClassDecls,++        -- Functions used by TcInstDcls to check+        -- data/type family instance declarations+        kcConDecl, tcConDecls, dataDeclChecks, checkValidTyCon,+        tcFamTyPats, tcTyFamInstEqn,+        tcAddTyFamInstCtxt, tcMkDataFamInstCtxt, tcAddDataFamInstCtxt,+        unravelFamInstPats, addConsistencyConstraints,+        wrongKindOfFamily+    ) where++#include "HsVersions.h"++import GhcPrelude++import HsSyn+import HscTypes+import BuildTyCl+import TcRnMonad+import TcEnv+import TcValidity+import TcHsSyn+import TcTyDecls+import TcClassDcl+import {-# SOURCE #-} TcInstDcls( tcInstDecls1 )+import TcDeriv (DerivInfo)+import TcHsType+import ClsInst( AssocInstInfo(..) )+import TcMType+import TysWiredIn ( unitTy, makeRecoveryTyCon )+import TcType+import RnEnv( lookupConstructorFields )+import FamInst+import FamInstEnv+import Coercion+import Type+import TyCoRep   -- for checkValidRoles+import Class+import CoAxiom+import TyCon+import DataCon+import Id+import Var+import VarEnv+import VarSet+import Module+import Name+import NameSet+import NameEnv+import Outputable+import Maybes+import Unify+import Util+import SrcLoc+import ListSetOps+import DynFlags+import Unique+import ConLike( ConLike(..) )+import BasicTypes+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.Foldable+import Data.Function ( on )+import Data.List+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.Set as Set+++{-+************************************************************************+*                                                                      *+\subsection{Type checking for type and class declarations}+*                                                                      *+************************************************************************++Note [Grouping of type and class declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+tcTyAndClassDecls is called on a list of `TyClGroup`s. Each group is a strongly+connected component of mutually dependent types and classes. We kind check and+type check each group separately to enhance kind polymorphism. Take the+following example:++  type Id a = a+  data X = X (Id Int)++If we were to kind check the two declarations together, we would give Id the+kind * -> *, since we apply it to an Int in the definition of X. But we can do+better than that, since Id really is kind polymorphic, and should get kind+forall (k::*). k -> k. Since it does not depend on anything else, it can be+kind-checked by itself, hence getting the most general kind. We then kind check+X, which works fine because we then know the polymorphic kind of Id, and simply+instantiate k to *.++Note [Check role annotations in a second pass]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Role inference potentially depends on the types of all of the datacons declared+in a mutually recursive group. The validity of a role annotation, in turn,+depends on the result of role inference. Because the types of datacons might+be ill-formed (see #7175 and Note [Checking GADT return types]) we must check+*all* the tycons in a group for validity before checking *any* of the roles.+Thus, we take two passes over the resulting tycons, first checking for general+validity and then checking for valid role annotations.+-}++tcTyAndClassDecls :: [TyClGroup GhcRn]      -- Mutually-recursive groups in+                                            -- dependency order+                  -> TcM ( TcGblEnv         -- Input env extended by types and+                                            -- classes+                                            -- and their implicit Ids,DataCons+                         , [InstInfo GhcRn] -- Source-code instance decls info+                         , [DerivInfo]      -- data family deriving info+                         )+-- Fails if there are any errors+tcTyAndClassDecls tyclds_s+  -- The code recovers internally, but if anything gave rise to+  -- an error we'd better stop now, to avoid a cascade+  -- Type check each group in dependency order folding the global env+  = checkNoErrs $ fold_env [] [] tyclds_s+  where+    fold_env :: [InstInfo GhcRn]+             -> [DerivInfo]+             -> [TyClGroup GhcRn]+             -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])+    fold_env inst_info deriv_info []+      = do { gbl_env <- getGblEnv+           ; return (gbl_env, inst_info, deriv_info) }+    fold_env inst_info deriv_info (tyclds:tyclds_s)+      = do { (tcg_env, inst_info', deriv_info') <- tcTyClGroup tyclds+           ; setGblEnv tcg_env $+               -- remaining groups are typechecked in the extended global env.+             fold_env (inst_info' ++ inst_info)+                      (deriv_info' ++ deriv_info)+                      tyclds_s }++tcTyClGroup :: TyClGroup GhcRn+            -> TcM (TcGblEnv, [InstInfo GhcRn], [DerivInfo])+-- Typecheck one strongly-connected component of type, class, and instance decls+-- See Note [TyClGroups and dependency analysis] in HsDecls+tcTyClGroup (TyClGroup { group_tyclds = tyclds+                       , group_roles  = roles+                       , group_instds = instds })+  = do { let role_annots = mkRoleAnnotEnv roles++           -- Step 1: Typecheck the type/class declarations+       ; traceTc "---- tcTyClGroup ---- {" empty+       ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))+       ; tyclss <- tcTyClDecls tyclds role_annots++           -- Step 1.5: Make sure we don't have any type synonym cycles+       ; traceTc "Starting synonym cycle check" (ppr tyclss)+       ; this_uid <- fmap thisPackage getDynFlags+       ; checkSynCycles this_uid tyclss tyclds+       ; traceTc "Done synonym cycle check" (ppr tyclss)++           -- Step 2: Perform the validity check on those types/classes+           -- We can do this now because we are done with the recursive knot+           -- Do it before Step 3 (adding implicit things) because the latter+           -- expects well-formed TyCons+       ; traceTc "Starting validity check" (ppr tyclss)+       ; tyclss <- concatMapM checkValidTyCl tyclss+       ; traceTc "Done validity check" (ppr tyclss)+       ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss+           -- See Note [Check role annotations in a second pass]++       ; traceTc "---- end tcTyClGroup ---- }" empty++           -- Step 3: Add the implicit things;+           -- we want them in the environment because+           -- they may be mentioned in interface files+       ; gbl_env <- addTyConsToGblEnv tyclss++           -- Step 4: check instance declarations+       ; setGblEnv gbl_env $+         tcInstDecls1 instds }++tcTyClGroup (XTyClGroup _) = panic "tcTyClGroup"++tcTyClDecls :: [LTyClDecl GhcRn] -> RoleAnnotEnv -> TcM [TyCon]+tcTyClDecls tyclds role_annots+  = tcExtendKindEnv promotion_err_env $   --- See Note [Type environment evolution]+    do {    -- Step 1: kind-check this group and returns the final+            -- (possibly-polymorphic) kind of each TyCon and Class+            -- See Note [Kind checking for type and class decls]+         tc_tycons <- kcTyClGroup tyclds+       ; traceTc "tcTyAndCl generalized kinds" (vcat (map ppr_tc_tycon tc_tycons))++            -- Step 2: type-check all groups together, returning+            -- the final TyCons and Classes+            --+            -- NB: We have to be careful here to NOT eagerly unfold+            -- type synonyms, as we have not tested for type synonym+            -- loops yet and could fall into a black hole.+       ; fixM $ \ ~rec_tyclss -> do+           { tcg_env <- getGblEnv+           ; let roles = inferRoles (tcg_src tcg_env) role_annots rec_tyclss++                 -- Populate environment with knot-tied ATyCon for TyCons+                 -- NB: if the decls mention any ill-staged data cons+                 -- (see Note [Recursion and promoting data constructors])+                 -- we will have failed already in kcTyClGroup, so no worries here+           ; tcExtendRecEnv (zipRecTyClss tc_tycons rec_tyclss) $++                 -- Also extend the local type envt with bindings giving+                 -- a TcTyCon for each each knot-tied TyCon or Class+                 -- See Note [Type checking recursive type and class declarations]+                 -- and Note [Type environment evolution]+             tcExtendKindEnvWithTyCons tc_tycons $++                 -- Kind and type check declarations for this group+               mapM (tcTyClDecl roles) tyclds+           } }+  where+    promotion_err_env = mkPromotionErrorEnv tyclds+    ppr_tc_tycon tc = parens (sep [ ppr (tyConName tc) <> comma+                                  , ppr (tyConBinders tc) <> comma+                                  , ppr (tyConResKind tc)+                                  , ppr (isTcTyCon tc) ])++zipRecTyClss :: [TcTyCon]+             -> [TyCon]           -- Knot-tied+             -> [(Name,TyThing)]+-- Build a name-TyThing mapping for the TyCons bound by decls+-- being careful not to look at the knot-tied [TyThing]+-- The TyThings in the result list must have a visible ATyCon,+-- because typechecking types (in, say, tcTyClDecl) looks at+-- this outer constructor+zipRecTyClss tc_tycons rec_tycons+  = [ (name, ATyCon (get name)) | tc_tycon <- tc_tycons, let name = getName tc_tycon ]+  where+    rec_tc_env :: NameEnv TyCon+    rec_tc_env = foldr add_tc emptyNameEnv rec_tycons++    add_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon+    add_tc tc env = foldr add_one_tc env (tc : tyConATs tc)++    add_one_tc :: TyCon -> NameEnv TyCon -> NameEnv TyCon+    add_one_tc tc env = extendNameEnv env (tyConName tc) tc++    get name = case lookupNameEnv rec_tc_env name of+                 Just tc -> tc+                 other   -> pprPanic "zipRecTyClss" (ppr name <+> ppr other)++{-+************************************************************************+*                                                                      *+                Kind checking+*                                                                      *+************************************************************************++Note [Kind checking for type and class decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Kind checking is done thus:++   1. Make up a kind variable for each parameter of the declarations,+      and extend the kind environment (which is in the TcLclEnv)++   2. Kind check the declarations++We need to kind check all types in the mutually recursive group+before we know the kind of the type variables.  For example:++  class C a where+     op :: D b => a -> b -> b++  class D c where+     bop :: (Monad c) => ...++Here, the kind of the locally-polymorphic type variable "b"+depends on *all the uses of class D*.  For example, the use of+Monad c in bop's type signature means that D must have kind Type->Type.++Note: we don't treat type synonyms specially (we used to, in the past);+in particular, even if we have a type synonym cycle, we still kind check+it normally, and test for cycles later (checkSynCycles).  The reason+we can get away with this is because we have more systematic TYPE r+inference, which means that we can do unification between kinds that+aren't lifted (this historically was not true.)++The downside of not directly reading off the kinds of the RHS of+type synonyms in topological order is that we don't transparently+support making synonyms of types with higher-rank kinds.  But+you can always specify a CUSK directly to make this work out.+See tc269 for an example.++Note [Skip decls with CUSKs in kcLTyClDecl]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++    data T (a :: *) = MkT (S a)   -- Has CUSK+    data S a = MkS (T Int) (S a)  -- No CUSK++Via getInitialKinds we get+  T :: * -> *+  S :: kappa -> *++Then we call kcTyClDecl on each decl in the group, to constrain the+kind unification variables.  BUT we /skip/ the RHS of any decl with+a CUSK.  Here we skip the RHS of T, so we eventually get+  S :: forall k. k -> *++This gets us more polymorphism than we would otherwise get, similar+(but implemented strangely differently from) the treatment of type+signatures in value declarations.++However, we only want to do so when we have PolyKinds.+When we have NoPolyKinds, we don't skip those decls, because we have defaulting+(#16609). Skipping won't bring us more polymorphism when we have defaulting.+Consider++  data T1 a = MkT1 T2        -- No CUSK+  data T2 = MkT2 (T1 Maybe)  -- Has CUSK++If we skip the rhs of T2 during kind-checking, the kind of a remains unsolved.+With PolyKinds, we do generalization to get T1 :: forall a. a -> *. And the+program type-checks.+But with NoPolyKinds, we do defaulting to get T1 :: * -> *. Defaulting happens+in quantifyTyVars, which is called from generaliseTcTyCon. Then type-checking+(T1 Maybe) will throw a type error.++Summary: with PolyKinds, we must skip; with NoPolyKinds, we must /not/ skip.++Open type families+~~~~~~~~~~~~~~~~~~+This treatment of type synonyms only applies to Haskell 98-style synonyms.+General type functions can be recursive, and hence, appear in `alg_decls'.++The kind of an open type family is solely determinded by its kind signature;+hence, only kind signatures participate in the construction of the initial+kind environment (as constructed by `getInitialKind'). In fact, we ignore+instances of families altogether in the following. However, we need to include+the kinds of *associated* families into the construction of the initial kind+environment. (This is handled by `allDecls').++See also Note [Kind checking recursive type and class declarations]++Note [How TcTyCons work]+~~~~~~~~~~~~~~~~~~~~~~~~+TcTyCons are used for two distinct purposes++1.  When recovering from a type error in a type declaration,+    we want to put the erroneous TyCon in the environment in a+    way that won't lead to more errors.  We use a TcTyCon for this;+    see makeRecoveryTyCon.++2.  When checking a type/class declaration (in module TcTyClsDecls), we come+    upon knowledge of the eventual tycon in bits and pieces.++      S1) First, we use getInitialKinds to look over the user-provided+          kind signature of a tycon (including, for example, the number+          of parameters written to the tycon) to get an initial shape of+          the tycon's kind.  We record that shape in a TcTyCon.++          For CUSK tycons, the TcTyCon has the final, generalised kind.+          For non-CUSK tycons, the TcTyCon has as its tyConBinders only+          the explicit arguments given -- no kind variables, etc.++      S2) Then, using these initial kinds, we kind-check the body of the+          tycon (class methods, data constructors, etc.), filling in the+          metavariables in the tycon's initial kind.++      S3) We then generalize to get the (non-CUSK) tycon's final, fixed+          kind. Finally, once this has happened for all tycons in a+          mutually recursive group, we can desugar the lot.++    For convenience, we store partially-known tycons in TcTyCons, which+    might store meta-variables. These TcTyCons are stored in the local+    environment in TcTyClsDecls, until the real full TyCons can be created+    during desugaring. A desugared program should never have a TcTyCon.++3.  In a TcTyCon, everything is zonked after the kind-checking pass (S2).++4.  tyConScopedTyVars.  A challenging piece in all of this is that we+    end up taking three separate passes over every declaration:+      - one in getInitialKind (this pass look only at the head, not the body)+      - one in kcTyClDecls (to kind-check the body)+      - a final one in tcTyClDecls (to desugar)++    In the latter two passes, we need to connect the user-written type+    variables in an LHsQTyVars with the variables in the tycon's+    inferred kind. Because the tycon might not have a CUSK, this+    matching up is, in general, quite hard to do.  (Look through the+    git history between Dec 2015 and Apr 2016 for+    TcHsType.splitTelescopeTvs!)++    Instead of trying, we just store the list of type variables to+    bring into scope, in the tyConScopedTyVars field of the TcTyCon.+    These tyvars are brought into scope in TcHsType.bindTyClTyVars.++    In a TcTyCon, why is tyConScopedTyVars :: [(Name,TcTyVar)] rather+    than just [TcTyVar]?  Consider these mutually-recursive decls+       data T (a :: k1) b = MkT (S a b)+       data S (c :: k2) d = MkS (T c d)+    We start with k1 bound to kappa1, and k2 to kappa2; so initially+    in the (Name,TcTyVar) pairs the Name is that of the TcTyVar. But+    then kappa1 and kappa2 get unified; so after the zonking in+    'generalise' in 'kcTyClGroup' the Name and TcTyVar may differ.++See also Note [Type checking recursive type and class declarations].++Note [Type environment evolution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As we typecheck a group of declarations the type environment evolves.+Consider for example:+  data B (a :: Type) = MkB (Proxy 'MkB)++We do the following steps:++  1. Start of tcTyClDecls: use mkPromotionErrorEnv to initialise the+     type env with promotion errors+            B   :-> TyConPE+            MkB :-> DataConPE++  2. kcTyCLGroup+      - Do getInitialKinds, which will signal a promotion+        error if B is used in any of the kinds needed to initialise+        B's kind (e.g. (a :: Type)) here++      - Extend the type env with these initial kinds (monomorphic for+        decls that lack a CUSK)+            B :-> TcTyCon <initial kind>+        (thereby overriding the B :-> TyConPE binding)+        and do kcLTyClDecl on each decl to get equality constraints on+        all those inital kinds++      - Generalise the inital kind, making a poly-kinded TcTyCon++  3. Back in tcTyDecls, extend the envt with bindings of the poly-kinded+     TcTyCons, again overriding the promotion-error bindings.++     But note that the data constructor promotion errors are still in place+     so that (in our example) a use of MkB will sitll be signalled as+     an error.++  4. Typecheck the decls.++  5. In tcTyClGroup, extend the envt with bindings for TyCon and DataCons+++Note [Missed opportunity to retain higher-rank kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In 'kcTyClGroup', there is a missed opportunity to make kind+inference work in a few more cases.  The idea is analogous+to Note [Single function non-recursive binding special-case]:++     * If we have an SCC with a single decl, which is non-recursive,+       instead of creating a unification variable representing the+       kind of the decl and unifying it with the rhs, we can just+       read the type directly of the rhs.++     * Furthermore, we can update our SCC analysis to ignore+       dependencies on declarations which have CUSKs: we don't+       have to kind-check these all at once, since we can use+       the CUSK to initialize the kind environment.++Unfortunately this requires reworking a bit of the code in+'kcLTyClDecl' so I've decided to punt unless someone shouts about it.++Note [Don't process associated types in kcLHsQTyVars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Previously, we processed associated types in the thing_inside in kcLHsQTyVars,+but this was wrong -- we want to do ATs sepearately.+The consequence for not doing it this way is #15142:++  class ListTuple (tuple :: Type) (as :: [(k, Type)]) where+    type ListToTuple as :: Type++We assign k a kind kappa[1]. When checking the tuple (k, Type), we try to unify+kappa ~ Type, but this gets deferred because we bumped the TcLevel as we bring+`tuple` into scope. Thus, when we check ListToTuple, kappa[1] still hasn't+unified with Type. And then, when we generalize the kind of ListToTuple (which+indeed has a CUSK, according to the rules), we skolemize the free metavariable+kappa. Note that we wouldn't skolemize kappa when generalizing the kind of ListTuple,+because the solveEqualities in kcLHsQTyVars is at TcLevel 1 and so kappa[1]+will unify with Type.++Bottom line: as associated types should have no effect on a CUSK enclosing class,+we move processing them to a separate action, run after the outer kind has+been generalized.++-}++kcTyClGroup :: [LTyClDecl GhcRn] -> TcM [TcTyCon]++-- Kind check this group, kind generalize, and return the resulting local env+-- This binds the TyCons and Classes of the group, but not the DataCons+-- See Note [Kind checking for type and class decls]+-- and Note [Inferring kinds for type declarations]+kcTyClGroup decls+  = do  { mod <- getModule+        ; traceTc "---- kcTyClGroup ---- {"+                  (text "module" <+> ppr mod $$ vcat (map ppr decls))++          -- Kind checking;+          --    1. Bind kind variables for decls+          --    2. Kind-check decls+          --    3. Generalise the inferred kinds+          -- See Note [Kind checking for type and class decls]++        ; cusks_enabled <- xoptM LangExt.CUSKs+        ; let (cusk_decls, no_cusk_decls)+                 = partition (hsDeclHasCusk cusks_enabled . unLoc) decls++        ; poly_cusk_tcs <- getInitialKinds True cusk_decls++        ; mono_tcs+            <- tcExtendKindEnvWithTyCons poly_cusk_tcs $+               pushTcLevelM_   $  -- We are going to kind-generalise, so+                                  -- unification variables in here must+                                  -- be one level in+               solveEqualities $+               do {  -- Step 1: Bind kind variables for all decls+                    mono_tcs <- getInitialKinds False no_cusk_decls++                  ; traceTc "kcTyClGroup: initial kinds" $+                    ppr_tc_kinds mono_tcs++                    -- Step 2: Set extended envt, kind-check the decls+                    -- NB: the environment extension overrides the tycon+                    --     promotion-errors bindings+                    --     See Note [Type environment evolution]+                  ; poly_kinds  <- xoptM LangExt.PolyKinds+                  ; tcExtendKindEnvWithTyCons mono_tcs $+                    mapM_ kcLTyClDecl (if poly_kinds then no_cusk_decls else decls)+                    -- See Note [Skip decls with CUSKs in kcLTyClDecl]++                  ; return mono_tcs }++        -- Step 3: generalisation+        -- Finally, go through each tycon and give it its final kind,+        -- with all the required, specified, and inferred variables+        -- in order.+        ; poly_no_cusk_tcs <- mapAndReportM generaliseTcTyCon mono_tcs++        ; let poly_tcs = poly_cusk_tcs ++ poly_no_cusk_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++             (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" dnotes the Name k1, and kk1, aa, etc are MetaTyVarss,+             -- specifically TyVarTvs++       -- 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]++       -- 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++       -- 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)+       ; 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 emptyVarSet 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+                 , 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++       ; 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++       -- Step 5: Make the TyConBinders.+             to_user tv     = lookupTyVarOcc ze tv `orElse` tv+             dep_fv_set     = mapVarSet to_user (candidateKindVars dvs1)+             inferred_tcbs  = mkNamedTyConBinders Inferred inferred+             specified_tcbs = mkNamedTyConBinders Specified specified+             required_tcbs  = map (mkRequiredTyConBinder dep_fv_set) req_tvs++       -- Step 6: 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)+                            True {- it's generalised now -}+                            (tyConFlavour tc)++       ; traceTc "generaliseTcTyCon done" $+         vcat [ text "tycon =" <+> ppr tc+              , text "tc_res_kind =" <+> ppr tc_res_kind+              , text "dep_fv_set =" <+> ppr dep_fv_set+              , text "final_spec_req_tvs =" <+> pprTyVars final_spec_req_tvs+              , text "inferred =" <+> pprTyVars inferred+              , text "specified =" <+> pprTyVars specified+              , text "required_tcbs =" <+> ppr required_tcbs+              , text "final_tcbs =" <+> ppr final_tcbs ]++       -- Step 8: 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++  * Required: an argument must be provided at every call site++  * Specified: the argument can be inferred at call sites, but+    may be instantiated with visible type/kind application++  * Inferred: the must be inferred at call sites; it+    is unavailable for use with visible type/kind application.++Why have Inferred at all? Because we just can't make user-facing+promises about the ordering of some variables. These might swizzle+around even between minor released. By forbidding visible type+application, we ensure users aren't caught unawares.++Go read Note [VarBndrs, TyCoVarBinders, TyConBinders, and visibility] in TyCoRep.++The question for this Note is this:+   given a TyClDecl, how are its quantified type variables classified?+Much of the debate is memorialized in #15743.++Here is our design choice. When inferring the ordering of variables+for a TyCl declaration (that is, for those variables that he user+has not specified the order with an explicit `forall`), we use the+following order:++ 1. Inferred variables+ 2. Specified variables; in the left-to-right order in which+    the user wrote them, modified by scopedSort (see below)+    to put them in depdendency order.+ 3. Required variables before a top-level ::+ 4. All variables after a top-level ::++If this ordering does not make a valid telescope, we reject the definition.++Example:+  data SameKind :: k -> k -> *+  data Bad a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)++For Bad:+  - a, c, d, x are Required; they are explicitly listed by the user+    as the positional arguments of Bad+  - b is Specified; it appears explicitly in a kind signature+  - k, the kind of a, is Inferred; it is not mentioned explicitly at all++Putting variables in the order Inferred, Specified, Required+gives us this telescope:+  Inferred:  k+  Specified: b : Proxy a+  Required : (a : k) (c : Proxy b) (d : Proxy a) (x : SameKind b d)++But this order is ill-scoped, because b's kind mentions a, which occurs+after b in the telescope. So we reject Bad.++Associated types+~~~~~~~~~~~~~~~~+For associated types everything above is determined by the+associated-type declaration alone, ignoring the class header.+Here is an example (#15592)+  class C (a :: k) b where+    type F (x :: b a)++In the kind of C, 'k' is Specified.  But what about F?+In the kind of F,++ * Should k be Inferred or Specified?  It's Specified for C,+   but not mentioned in F's declaration.++ * In which order should the Specified variables a and b occur?+   It's clearly 'a' then 'b' in C's declaration, but the L-R ordering+   in F's declaration is 'b' then 'a'.++In both cases we make the choice by looking at F's declaration alone,+so it gets the kind+   F :: forall {k}. forall b a. b a -> Type++How it works+~~~~~~~~~~~~+These design choices are implemented by two completely different code+paths for++  * Declarations with a complete user-specified kind signature (CUSK)+    Handed by the CUSK case of kcLHsQTyVars.++  * Declarations without a CUSK are handled by kcTyClDecl; see+    Note [Inferring kinds for type declarations].++Note that neither code path worries about point (4) above, as this+is nicely handled by not mangling the res_kind. (Mangling res_kinds is done+*after* all this stuff, in tcDataDefn's call to etaExpandAlgTyCon.)++We can tell Inferred apart from Specified by looking at the scoped+tyvars; Specified are always included there.++Design alternatives+~~~~~~~~~~~~~~~~~~~+* For associated types we considered putting the class variables+  before the local variables, in a nod to the treatment for class+  methods. But it got too compilicated; see #15592, comment:21ff.++* We rigidly require the ordering above, even though we could be much more+  permissive. Relevant musings are at+  https://gitlab.haskell.org/ghc/ghc/issues/15743#note_161623+  The bottom line conclusion is that, if the user wants a different ordering,+  then can specify it themselves, and it is better to be predictable and dumb+  than clever and capricious.++  I (Richard) conjecture we could be fully permissive, allowing all classes+  of variables to intermix. We would have to augment ScopedSort to refuse to+  reorder Required variables (or check that it wouldn't have). But this would+  allow more programs. See #15743 for examples. Interestingly, Idris seems+  to allow this intermixing. The intermixing would be fully specified, in that+  we can be sure that inference wouldn't change between versions. However,+  would users be able to predict it? That I cannot answer.++Test cases (and tickets) relevant to these design decisions+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  T15591*+  T15592*+  T15743*++Note [Inferring kinds for type declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This note deals with /inference/ for type declarations+that do not have a CUSK.  Consider+  data T (a :: k1) k2 (x :: k2) = MkT (S a k2 x)+  data S (b :: k3) k4 (y :: k4) = MkS (T b k4 y)++We do kind inference as follows:++* Step 1: getInitialKinds, and in particular kcLHsQTyVars_NonCusk.+  Make a unification variable for each of the Required and Specified+  type varialbes in the header.++  Record the connection between the Names the user wrote and the+  fresh unification variables in the tcTyConScopedTyVars field+  of the TcTyCon we are making+      [ (a,  aa)+      , (k1, kk1)+      , (k2, kk2)+      , (x,  xx) ]+  (I'm using the convention that double letter like 'aa' or 'kk'+  mean a unification variable.)++  These unification variables+    - Are TyVarTvs: that is, unification variables that can+      unify only with other type variables.+      See Note [Signature skolems] in TcType++    - Have complete fresh Names; see TcMType+      Note [Unification variables need fresh Names]++  Assign initial monomorophic kinds to S, T+          T :: kk1 -> * -> kk2 -> *+          S :: kk3 -> * -> kk4 -> *++* Step 2: kcTyClDecl. Extend the environment with a TcTyCon for S and+  T, with these monomophic kinds.  Now kind-check the declarations,+  and solve the resulting equalities.  The goal here is to discover+  constraints on all these unification variables.++  Here we find that kk1 := kk3, and kk2 := kk4.++  This is why we can't use skolems for kk1 etc; they have to+  unify with each other.++* Step 3: generaliseTcTyCon. Generalise each TyCon in turn.+  We find the free variables of the kind, skolemise them,+  sort them out into Inferred/Required/Specified (see the above+  Note [Required, Specified, and Inferred for types]),+  and perform some validity checks.++  This makes the utterly-final TyConBinders for the TyCon.++  All this is very similar at the level of terms: see TcBinds+  Note [Quantified variables in partial type signatures]++  But there some tricky corners: Note [Tricky scoping in generaliseTcTyCon]++* Step 4.  Extend the type environment with a TcTyCon for S and T, now+  with their utterly-final polymorphic kinds (needed for recursive+  occurrences of S, T).  Now typecheck the declarations, and build the+  final AlgTyCOn for S and T resp.++The first three steps are in kcTyClGroup; the fourth is in+tcTyClDecls.++There are some wrinkles++* Do not default TyVarTvs.  We always want to kind-generalise over+  TyVarTvs, and /not/ default them to Type. By definition a TyVarTv is+  not allowed to unify with a type; it must stand for a type+  variable. Hence the check in TcSimplify.defaultTyVarTcS, and+  TcMType.defaultTyVar.  Here's another example (#14555):+     data Exp :: [TYPE rep] -> TYPE rep -> Type where+        Lam :: Exp (a:xs) b -> Exp xs (a -> b)+  We want to kind-generalise over the 'rep' variable.+  #14563 is another example.++* Duplicate type variables. Consider #11203+    data SameKind :: k -> k -> *+    data Q (a :: k1) (b :: k2) c = MkQ (SameKind a b)+  Here we will unify k1 with k2, but this time doing so is an error,+  because k1 and k2 are bound in the same declaration.++  We spot this during validity checking (findDupTyVarTvs),+  in generaliseTcTyCon.++* Required arguments.  Even the Required arguments should be made+  into TyVarTvs, not skolems.  Consider+    data T k (a :: k)+  Here, k is a Required, dependent variable. For uniformity, it is helpful+  to have k be a TyVarTv, in parallel with other dependent variables.++* Duplicate skolemisation is expected.  When generalising in Step 3,+  we may find that one of the variables we want to quantify has+  already been skolemised.  For example, suppose we have already+  generalise S. When we come to T we'll find that kk1 (now the same as+  kk3) has already been skolemised.++  That's fine -- but it means that+    a) when collecting quantification candidates, in+       candidateQTyVarsOfKind, we must collect skolems+    b) quantifyTyVars should be a no-op on such a skolem++Note [Tricky scoping in generaliseTcTyCon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider #16342+  class C (a::ka) x where+    cop :: D a x => x -> Proxy a -> Proxy a+    cop _ x = x :: Proxy (a::ka)++  class D (b::kb) y where+    dop :: C b y => y -> Proxy b -> Proxy b+    dop _ x = x :: Proxy (b::kb)++C and D are mutually recursive, by the time we get to+generaliseTcTyCon we'll have unified kka := kkb.++But when typechecking the default declarations for 'cop' and 'dop' in+tcDlassDecl2 we need {a, ka} and {b, kb} respectively to be in scope.+But at that point all we have is the utterly-final Class itself.++Conclusion: the classTyVars of a class must have the same Name as+that originally assigned by the user.  In our example, C must have+classTyVars {a, ka, x} while D has classTyVars {a, kb, y}.  Despite+the fact that kka and kkb got unified!++We achieve this sleight of hand in generaliseTcTyCon, using+the specialised function zonkRecTyVarBndrs.  We make the call+   zonkRecTyVarBndrs [ka,a,x] [kkb,aa,xxx]+where the [ka,a,x] are the Names originally assigned by the user, and+[kkb,aa,xx] are the corresponding (post-zonking, skolemised) TcTyVars.+zonkRecTyVarBndrs builds a recursive ZonkEnv that binds+   kkb :-> (ka :: <zonked kind of kkb>)+   aa  :-> (a  :: <konked kind of aa>)+   etc+That is, it maps each skolemised TcTyVars to the utterly-final+TyVar to put in the class, with its correct user-specified name.+When generalising D we'll do the same thing, but the ZonkEnv will map+   kkb :-> (kb :: <zonked kind of kkb>)+   bb  :-> (b  :: <konked kind of bb>)+   etc+Note that 'kkb' again appears in the domain of the mapping, but this+time mapped to 'kb'.  That's how C and D end up with differently-named+final TyVars despite the fact that we unified kka:=kkb++zonkRecTyVarBndrs we need to do knot-tying because of the need to+apply this same substitution to the kind of each.  -}++--------------+tcExtendKindEnvWithTyCons :: [TcTyCon] -> TcM a -> TcM a+tcExtendKindEnvWithTyCons tcs+  = tcExtendKindEnvList [ (tyConName tc, ATcTyCon tc) | tc <- tcs ]++--------------+mkPromotionErrorEnv :: [LTyClDecl GhcRn] -> TcTypeEnv+-- Maps each tycon/datacon to a suitable promotion error+--    tc :-> APromotionErr TyConPE+--    dc :-> APromotionErr RecDataConPE+--    See Note [Recursion and promoting data constructors]++mkPromotionErrorEnv decls+  = foldr (plusNameEnv . mk_prom_err_env . unLoc)+          emptyNameEnv decls++mk_prom_err_env :: TyClDecl GhcRn -> TcTypeEnv+mk_prom_err_env (ClassDecl { tcdLName = L _ nm, tcdATs = ats })+  = unitNameEnv nm (APromotionErr ClassPE)+    `plusNameEnv`+    mkNameEnv [ (name, APromotionErr TyConPE)+              | (dL->L _ (FamilyDecl { fdLName = (dL->L _ name) })) <- ats ]++mk_prom_err_env (DataDecl { tcdLName = (dL->L _ name)+                          , tcdDataDefn = HsDataDefn { dd_cons = cons } })+  = unitNameEnv name (APromotionErr TyConPE)+    `plusNameEnv`+    mkNameEnv [ (con, APromotionErr RecDataConPE)+              | (dL->L _ con') <- cons+              , (dL->L _ con)  <- getConNames con' ]++mk_prom_err_env decl+  = unitNameEnv (tcdName decl) (APromotionErr TyConPE)+    -- Works for family declarations too++--------------+getInitialKinds :: Bool -> [LTyClDecl GhcRn] -> TcM [TcTyCon]+-- Returns a TcTyCon for each TyCon bound by the decls,+-- each with its initial kind++getInitialKinds cusk decls+  = do { traceTc "getInitialKinds {" empty+       ; tcs <- concatMapM (addLocM (getInitialKind cusk)) decls+       ; traceTc "getInitialKinds done }" empty+       ; return tcs }++getInitialKind :: Bool -> TyClDecl GhcRn -> TcM [TcTyCon]+-- Allocate a fresh kind variable for each TyCon and Class+-- For each tycon, return a TcTyCon with kind k+-- where k is the kind of tc, derived from the LHS+--         of the definition (and probably including+--         kind unification variables)+--      Example: data T a b = ...+--      return (T, kv1 -> kv2 -> kv3)+--+-- This pass deals with (ie incorporates into the kind it produces)+--   * The kind signatures on type-variable binders+--   * The result kinds signature on a TyClDecl+--+-- No family instances are passed to getInitialKinds++getInitialKind cusk+    (ClassDecl { tcdLName = dL->L _ name+               , tcdTyVars = ktvs+               , tcdATs = ats })+  = do { tycon <- kcLHsQTyVars name ClassFlavour cusk ktvs $+                  return constraintKind+       ; let parent_tv_prs = tcTyConScopedTyVars tycon+            -- See Note [Don't process associated types in kcLHsQTyVars]+       ; inner_tcs <- tcExtendNameTyVarEnv parent_tv_prs $+                      getFamDeclInitialKinds cusk (Just tycon) ats+       ; return (tycon : inner_tcs) }++getInitialKind cusk+    (DataDecl { tcdLName = dL->L _ name+              , tcdTyVars = ktvs+              , tcdDataDefn = HsDataDefn { dd_kindSig = m_sig+                                         , dd_ND = new_or_data } })+  = do  { let flav = newOrDataToFlavour new_or_data+        ; tc <- kcLHsQTyVars name flav cusk ktvs $+                case m_sig of+                   Just ksig -> tcLHsKindSig (DataKindCtxt name) ksig+                   Nothing   -> return liftedTypeKind+        ; return [tc] }++getInitialKind cusk (FamDecl { tcdFam = decl })+  = do { tc <- getFamDeclInitialKind cusk Nothing decl+       ; return [tc] }++getInitialKind cusk (SynDecl { tcdLName = dL->L _ name+                             , tcdTyVars = ktvs+                             , tcdRhs = rhs })+  = do  { cusks_enabled <- xoptM LangExt.CUSKs+        ; tycon <- kcLHsQTyVars name TypeSynonymFlavour cusk ktvs $+                   case kind_annotation cusks_enabled rhs of+                     Just ksig -> tcLHsKindSig (TySynKindCtxt name) ksig+                     Nothing -> newMetaKindVar+        ; return [tycon] }+  where+    -- Keep this synchronized with 'hsDeclHasCusk'.+    kind_annotation+      :: Bool           --  cusks_enabled?+      -> LHsType GhcRn  --  rhs+      -> Maybe (LHsKind GhcRn)+    kind_annotation False = const Nothing+    kind_annotation True = go+      where+        go (dL->L _ ty) = case ty of+          HsParTy _ lty     -> go lty+          HsKindSig _ _ k   -> Just k+          _                 -> Nothing++getInitialKind _ (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "getInitialKind"+getInitialKind _ (XTyClDecl _) = panic "getInitialKind"++---------------------------------+getFamDeclInitialKinds+  :: Bool        -- ^ True <=> cusk+  -> Maybe TyCon -- ^ Just cls <=> this is an associated family of class cls+  -> [LFamilyDecl GhcRn]+  -> TcM [TcTyCon]+getFamDeclInitialKinds cusk mb_parent_tycon decls+  = mapM (addLocM (getFamDeclInitialKind cusk mb_parent_tycon)) decls++getFamDeclInitialKind+  :: Bool        -- ^ True <=> cusk+  -> Maybe TyCon -- ^ Just cls <=> this is an associated family of class cls+  -> FamilyDecl GhcRn+  -> TcM TcTyCon+getFamDeclInitialKind parent_cusk mb_parent_tycon+    decl@(FamilyDecl { fdLName     = (dL->L _ name)+                     , fdTyVars    = ktvs+                     , fdResultSig = (dL->L _ resultSig)+                     , fdInfo      = info })+  = do { cusks_enabled <- xoptM LangExt.CUSKs+       ; kcLHsQTyVars name flav (fam_cusk cusks_enabled) ktvs $+         case resultSig of+           KindSig _ ki                              -> tcLHsKindSig ctxt ki+           TyVarSig _ (dL->L _ (KindedTyVar _ _ ki)) -> tcLHsKindSig ctxt ki+           _ -- open type families have * return kind by default+             | tcFlavourIsOpen flav              -> return liftedTypeKind+                    -- closed type families have their return kind inferred+                    -- by default+             | otherwise                         -> newMetaKindVar+       }+  where+    assoc_with_no_cusk = isJust mb_parent_tycon && not parent_cusk+    fam_cusk cusks_enabled = famDeclHasCusk cusks_enabled assoc_with_no_cusk decl+    flav = case info of+      DataFamily         -> DataFamilyFlavour mb_parent_tycon+      OpenTypeFamily     -> OpenTypeFamilyFlavour mb_parent_tycon+      ClosedTypeFamily _ -> ASSERT( isNothing mb_parent_tycon )+                            ClosedTypeFamilyFlavour+    ctxt  = TyFamResKindCtxt name+getFamDeclInitialKind _ _ (XFamilyDecl _) = panic "getFamDeclInitialKind"++------------------------------------------------------------------------+kcLTyClDecl :: LTyClDecl GhcRn -> TcM ()+  -- See Note [Kind checking for type and class decls]+kcLTyClDecl (dL->L loc decl)+  = setSrcSpan loc $+    tcAddDeclCtxt decl $+    do { traceTc "kcTyClDecl {" (ppr tc_name)+       ; kcTyClDecl decl+       ; traceTc "kcTyClDecl done }" (ppr tc_name) }+  where+    tc_name = tyClDeclLName decl++kcTyClDecl :: TyClDecl GhcRn -> TcM ()+-- This function is used solely for its side effect on kind variables+-- NB kind signatures on the type variables and+--    result kind signature have already been dealt with+--    by getInitialKind, so we can ignore them here.++kcTyClDecl (DataDecl { tcdLName    = (dL->L _ name)+                     , tcdDataDefn = defn })+  | HsDataDefn { dd_cons = cons@((dL->L _ (ConDeclGADT {})) : _)+               , dd_ctxt = (dL->L _ []) } <- defn+  = mapM_ (wrapLocM_ kcConDecl) cons+    -- hs_tvs and dd_kindSig already dealt with in getInitialKind+    -- This must be a GADT-style decl,+    --        (see invariants of DataDefn declaration)+    -- so (a) we don't need to bring the hs_tvs into scope, because the+    --        ConDecls bind all their own variables+    --    (b) dd_ctxt is not allowed for GADT-style decls, so we can ignore it++  | HsDataDefn { dd_ctxt = ctxt, dd_cons = cons } <- defn+  = bindTyClTyVars name $ \ _ _ ->+    do  { _ <- tcHsContext ctxt+        ; mapM_ (wrapLocM_ kcConDecl) cons }++kcTyClDecl (SynDecl { tcdLName = dL->L _ name, tcdRhs = rhs })+  = bindTyClTyVars name $ \ _ res_kind ->+    discardResult $ tcCheckLHsType rhs res_kind+        -- NB: check against the result kind that we allocated+        -- in getInitialKinds.++kcTyClDecl (ClassDecl { tcdLName = (dL->L _ name)+                      , tcdCtxt = ctxt, tcdSigs = sigs })+  = bindTyClTyVars name $ \ _ _ ->+    do  { _ <- tcHsContext ctxt+        ; mapM_ (wrapLocM_ kc_sig) sigs }+  where+    kc_sig (ClassOpSig _ _ nms op_ty) = kcHsSigType nms op_ty+    kc_sig _                          = return ()++kcTyClDecl (FamDecl _ (FamilyDecl { fdLName  = (dL->L _ fam_tc_name)+                                  , fdInfo   = fd_info }))+-- closed type families look at their equations, but other families don't+-- do anything here+  = case fd_info of+      ClosedTypeFamily (Just eqns) ->+        do { fam_tc <- kcLookupTcTyCon fam_tc_name+           ; mapM_ (kcTyFamInstEqn fam_tc) eqns }+      _ -> return ()+kcTyClDecl (FamDecl _ (XFamilyDecl _))              = panic "kcTyClDecl"+kcTyClDecl (DataDecl _ _ _ _ (XHsDataDefn _)) = panic "kcTyClDecl"+kcTyClDecl (XTyClDecl _)                            = panic "kcTyClDecl"++-------------------+kcConDecl :: ConDecl GhcRn -> TcM ()+kcConDecl (ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs+                      , con_mb_cxt = ex_ctxt, con_args = args })+  = addErrCtxt (dataConCtxtName [name]) $+    discardResult                   $+    bindExplicitTKBndrs_Tv ex_tvs $+    do { _ <- tcHsMbContext ex_ctxt+       ; traceTc "kcConDecl {" (ppr name $$ ppr args)+       ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args)+       ; traceTc "kcConDecl }" (ppr name)+       }+              -- We don't need to check the telescope here, because that's+              -- done in tcConDecl++kcConDecl (ConDeclGADT { con_names = names+                       , con_qvars = qtvs, con_mb_cxt = cxt+                       , con_args = args, con_res_ty = res_ty })+  | HsQTvs { hsq_ext = implicit_tkv_nms+           , hsq_explicit = explicit_tkv_nms } <- qtvs+  = -- Even though the data constructor's type is closed, we+    -- must still kind-check the type, because that may influence+    -- the inferred kind of the /type/ constructor.  Example:+    --    data T f a where+    --      MkT :: f a -> T f a+    -- If we don't look at MkT we won't get the correct kind+    -- for the type constructor T+    addErrCtxt (dataConCtxtName names) $+    discardResult $+    bindImplicitTKBndrs_Tv implicit_tkv_nms $+    bindExplicitTKBndrs_Tv explicit_tkv_nms $+        -- Why "_Tv"?  See Note [Kind-checking for GADTs]+    do { _ <- tcHsMbContext cxt+       ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys args)+       ; _ <- tcHsOpenType res_ty+       ; return () }+kcConDecl (XConDecl _) = panic "kcConDecl"+kcConDecl (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _) = panic "kcConDecl"++{-+Note [Recursion and promoting data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't want to allow promotion in a strongly connected component+when kind checking.++Consider:+  data T f = K (f (K Any))++When kind checking the `data T' declaration the local env contains the+mappings:+  T -> ATcTyCon <some initial kind>+  K -> APromotionErr++APromotionErr is only used for DataCons, and only used during type checking+in tcTyClGroup.++Note [Kind-checking for GADTs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  data Proxy a where+    MkProxy1 :: forall k (b :: k). Proxy b+    MkProxy2 :: forall j (c :: j). Proxy c++It seems reasonable that this should be accepted. But something very strange+is going on here: when we're kind-checking this declaration, we need to unify+the kind of `a` with k and j -- even though k and j's scopes are local to the type of+MkProxy{1,2}. The best approach we've come up with is to use TyVarTvs during+the kind-checking pass. First off, note that it's OK if the kind-checking pass+is too permissive: we'll snag the problems in the type-checking pass later.+(This extra permissiveness might happen with something like++  data SameKind :: k -> k -> Type+  data Bad a where+    MkBad :: forall k1 k2 (a :: k1) (b :: k2). Bad (SameKind a b)++which would be accepted if k1 and k2 were TyVarTvs. This is correctly rejected+in the second pass, though. Test case: polykinds/TyVarTvKinds3)+Recall that the kind-checking pass exists solely to collect constraints+on the kinds and to power unification.++To achieve the use of TyVarTvs, we must be careful to use specialized functions+that produce TyVarTvs, not ordinary skolems. This is why we need+kcExplicitTKBndrs and kcImplicitTKBndrs in TcHsType, separate from their+tc... variants.++The drawback of this approach is sometimes it will accept a definition that+a (hypothetical) declarative specification would likely reject. As a general+rule, we don't want to allow polymorphic recursion without a CUSK. Indeed,+the whole point of CUSKs is to allow polymorphic recursion. Yet, the TyVarTvs+approach allows a limited form of polymorphic recursion *without* a CUSK.++To wit:+  data T a = forall k (b :: k). MkT (T b) Int+  (test case: dependent/should_compile/T14066a)++Note that this is polymorphically recursive, with the recursive occurrence+of T used at a kind other than a's kind. The approach outlined here accepts+this definition, because this kind is still a kind variable (and so the+TyVarTvs unify). Stepping back, I (Richard) have a hard time envisioning a+way to describe exactly what declarations will be accepted and which will+be rejected (without a CUSK). However, the accepted definitions are indeed+well-kinded and any rejected definitions would be accepted with a CUSK,+and so this wrinkle need not cause anyone to lose sleep.++************************************************************************+*                                                                      *+\subsection{Type checking}+*                                                                      *+************************************************************************++Note [Type checking recursive type and class declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At this point we have completed *kind-checking* of a mutually+recursive group of type/class decls (done in kcTyClGroup). However,+we discarded the kind-checked types (eg RHSs of data type decls);+note that kcTyClDecl returns ().  There are two reasons:++  * It's convenient, because we don't have to rebuild a+    kinded HsDecl (a fairly elaborate type)++  * It's necessary, because after kind-generalisation, the+    TyCons/Classes may now be kind-polymorphic, and hence need+    to be given kind arguments.++Example:+       data T f a = MkT (f a) (T f a)+During kind-checking, we give T the kind T :: k1 -> k2 -> *+and figure out constraints on k1, k2 etc. Then we generalise+to get   T :: forall k. (k->*) -> k -> *+So now the (T f a) in the RHS must be elaborated to (T k f a).++However, during tcTyClDecl of T (above) we will be in a recursive+"knot". So we aren't allowed to look at the TyCon T itself; we are only+allowed to put it (lazily) in the returned structures.  But when+kind-checking the RHS of T's decl, we *do* need to know T's kind (so+that we can correctly elaboarate (T k f a).  How can we get T's kind+without looking at T?  Delicate answer: during tcTyClDecl, we extend++  *Global* env with T -> ATyCon (the (not yet built) final TyCon for T)+  *Local*  env with T -> ATcTyCon (TcTyCon with the polymorphic kind of T)++Then:++  * During TcHsType.tcTyVar we look in the *local* env, to get the+    fully-known, not knot-tied TcTyCon for T.++  * Then, in TcHsSyn.zonkTcTypeToType (and zonkTcTyCon in particular)+    we look in the *global* env to get the TyCon.++This fancy footwork (with two bindings for T) is only necessary for the+TyCons or Classes of this recursive group.  Earlier, finished groups,+live in the global env only.++See also Note [Kind checking recursive type and class declarations]++Note [Kind checking recursive type and class declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before we can type-check the decls, we must kind check them. This+is done by establishing an "initial kind", which is a rather uninformed+guess at a tycon's kind (by counting arguments, mainly) and then+using this initial kind for recursive occurrences.++The initial kind is stored in exactly the same way during+kind-checking as it is during type-checking (Note [Type checking+recursive type and class declarations]): in the *local* environment,+with ATcTyCon. But we still must store *something* in the *global*+environment. Even though we discard the result of kind-checking, we+sometimes need to produce error messages. These error messages will+want to refer to the tycons being checked, except that they don't+exist yet, and it would be Terribly Annoying to get the error messages+to refer back to HsSyn. So we create a TcTyCon and put it in the+global env. This tycon can print out its name and knows its kind, but+any other action taken on it will panic. Note that TcTyCons are *not*+knot-tied, unlike the rather valid but knot-tied ones that occur+during type-checking.++Note [Declarations for wired-in things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For wired-in things we simply ignore the declaration+and take the wired-in information.  That avoids complications.+e.g. the need to make the data constructor worker name for+     a constraint tuple match the wired-in one+-}++tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM TyCon+tcTyClDecl roles_info (dL->L loc decl)+  | Just thing <- wiredInNameTyThing_maybe (tcdName decl)+  = case thing of -- See Note [Declarations for wired-in things]+      ATyCon tc -> return tc+      _ -> pprPanic "tcTyClDecl" (ppr thing)++  | otherwise+  = setSrcSpan loc $ tcAddDeclCtxt decl $+    do { traceTc "---- tcTyClDecl ---- {" (ppr decl)+       ; tc <- tcTyClDecl1 Nothing roles_info decl+       ; traceTc "---- tcTyClDecl end ---- }" (ppr tc)+       ; return tc }++  -- "type family" declarations+tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM TyCon+tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd })+  = tcFamDecl1 parent fd++  -- "type" synonym declaration+tcTyClDecl1 _parent roles_info+            (SynDecl { tcdLName = (dL->L _ tc_name)+                     , tcdRhs   = rhs })+  = ASSERT( isNothing _parent )+    bindTyClTyVars tc_name $ \ binders res_kind ->+    tcTySynRhs roles_info tc_name binders res_kind rhs++  -- "data/newtype" declaration+tcTyClDecl1 _parent roles_info+            (DataDecl { tcdLName = (dL->L _ tc_name)+                      , tcdDataDefn = defn })+  = ASSERT( isNothing _parent )+    bindTyClTyVars tc_name $ \ tycon_binders res_kind ->+    tcDataDefn roles_info tc_name tycon_binders res_kind defn++tcTyClDecl1 _parent roles_info+            (ClassDecl { tcdLName = (dL->L _ class_name)+                       , tcdCtxt = hs_ctxt+                       , tcdMeths = meths+                       , tcdFDs = fundeps+                       , tcdSigs = sigs+                       , tcdATs = ats+                       , tcdATDefs = at_defs })+  = ASSERT( isNothing _parent )+    do { clas <- tcClassDecl1 roles_info class_name hs_ctxt+                              meths fundeps sigs ats at_defs+       ; return (classTyCon clas) }++tcTyClDecl1 _ _ (XTyClDecl _) = panic "tcTyClDecl1"+++{- *********************************************************************+*                                                                      *+          Class declarations+*                                                                      *+********************************************************************* -}++tcClassDecl1 :: RolesInfo -> Name -> LHsContext GhcRn+             -> LHsBinds GhcRn -> [LHsFunDep GhcRn] -> [LSig GhcRn]+             -> [LFamilyDecl GhcRn] -> [LTyFamDefltDecl GhcRn]+             -> TcM Class+tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs+  = fixM $ \ clas ->+    -- We need the knot because 'clas' is passed into tcClassATs+    bindTyClTyVars class_name $ \ binders res_kind ->+    do { MASSERT2( tcIsConstraintKind res_kind+                 , ppr class_name $$ ppr res_kind )+       ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders)+       ; let tycon_name = class_name        -- We use the same name+             roles = roles_info tycon_name  -- for TyCon and Class++       ; (ctxt, fds, sig_stuff, at_stuff)+            <- pushTcLevelM_   $+               solveEqualities $+               do { ctxt <- tcHsContext hs_ctxt+                  ; fds  <- mapM (addLocM tc_fundep) fundeps+                  ; sig_stuff <- tcClassSigs class_name sigs meths+                  ; at_stuff  <- tcClassATs class_name clas ats at_defs+                  ; return (ctxt, fds, sig_stuff, at_stuff) }++       -- The solveEqualities will report errors for any+       -- unsolved equalities, so these zonks should not encounter+       -- any unfilled coercion variables unless there is such an error+       -- The zonk also squeeze out the TcTyCons, and converts+       -- Skolems to tyvars.+       ; ze        <- emptyZonkEnv+       ; ctxt      <- zonkTcTypesToTypesX ze ctxt+       ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff+         -- ToDo: do we need to zonk at_stuff?++       -- TODO: Allow us to distinguish between abstract class,+       -- and concrete class with no methods (maybe by+       -- specifying a trailing where or not++       ; mindef <- tcClassMinimalDef class_name sigs sig_stuff+       ; is_boot <- tcIsHsBootOrSig+       ; let body | is_boot, null ctxt, null at_stuff, null sig_stuff+                  = Nothing+                  | otherwise+                  = Just (ctxt, at_stuff, sig_stuff, mindef)++       ; clas <- buildClass class_name binders roles fds body+       ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$+                                ppr fds)+       ; return clas }+  where+    tc_fundep (tvs1, tvs2) = do { tvs1' <- mapM (tcLookupTyVar . unLoc) tvs1 ;+                                ; tvs2' <- mapM (tcLookupTyVar . unLoc) tvs2 ;+                                ; return (tvs1', tvs2') }+++{- Note [Associated type defaults]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The following is an example of associated type defaults:+             class C a where+               data D a++               type F a b :: *+               type F a b = [a]        -- Default++Note that we can get default definitions only for type families, not data+families.+-}++tcClassATs :: Name                    -- The class name (not knot-tied)+           -> Class                   -- The class parent of this associated type+           -> [LFamilyDecl GhcRn]     -- Associated types.+           -> [LTyFamDefltDecl GhcRn] -- Associated type defaults.+           -> TcM [ClassATItem]+tcClassATs class_name cls ats at_defs+  = do {  -- Complain about associated type defaults for non associated-types+         sequence_ [ failWithTc (badATErr class_name n)+                   | n <- map at_def_tycon at_defs+                   , not (n `elemNameSet` at_names) ]+       ; mapM tc_at ats }+  where+    at_def_tycon :: LTyFamDefltDecl GhcRn -> Name+    at_def_tycon (dL->L _ eqn) = tyFamInstDeclName eqn++    at_fam_name :: LFamilyDecl GhcRn -> Name+    at_fam_name (dL->L _ decl) = unLoc (fdLName decl)++    at_names = mkNameSet (map at_fam_name ats)++    at_defs_map :: NameEnv [LTyFamDefltDecl GhcRn]+    -- Maps an AT in 'ats' to a list of all its default defs in 'at_defs'+    at_defs_map = foldr (\at_def nenv -> extendNameEnv_C (++) nenv+                                          (at_def_tycon at_def) [at_def])+                        emptyNameEnv at_defs++    tc_at at = do { fam_tc <- addLocM (tcFamDecl1 (Just cls)) at+                  ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at)+                                  `orElse` []+                  ; atd <- tcDefaultAssocDecl fam_tc at_defs+                  ; return (ATI fam_tc atd) }++-------------------------+tcDefaultAssocDecl ::+     TyCon                                -- ^ Family TyCon (not knot-tied)+  -> [LTyFamDefltDecl GhcRn]              -- ^ Defaults+  -> TcM (Maybe (KnotTied Type, SrcSpan)) -- ^ Type checked RHS+tcDefaultAssocDecl _ []+  = return Nothing  -- No default declaration++tcDefaultAssocDecl _ (d1:_:_)+  = failWithTc (text "More than one default declaration for"+                <+> ppr (tyFamInstDeclName (unLoc d1)))++tcDefaultAssocDecl fam_tc+  [dL->L loc (TyFamInstDecl { tfid_eqn =+         HsIB { hsib_ext  = imp_vars+              , hsib_body = FamEqn { feqn_tycon = L _ tc_name+                                   , feqn_bndrs = mb_expl_bndrs+                                   , feqn_pats  = hs_pats+                                   , feqn_rhs   = hs_rhs_ty }}})]+  = -- See Note [Type-checking default assoc decls]+    setSrcSpan loc $+    tcAddFamInstCtxt (text "default type instance") tc_name $+    do { traceTc "tcDefaultAssocDecl 1" (ppr tc_name)+       ; let fam_tc_name = tyConName fam_tc+             vis_arity = length (tyConVisibleTyVars fam_tc)+             vis_pats  = numVisibleArgs hs_pats++       -- Kind of family check+       ; ASSERT( fam_tc_name == tc_name )+         checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)++       -- Arity check+       ; checkTc (vis_pats == vis_arity)+                 (wrongNumberOfParmsErr vis_arity)++       -- Typecheck RHS+       --+       -- You might think we should pass in some AssocInstInfo, as we're looking+       -- at an associated type. But this would be wrong, because an associated+       -- type default LHS can mention *different* type variables than the+       -- enclosing class. So it's treated more as a freestanding beast.+       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated+                                                    imp_vars (mb_expl_bndrs `orElse` [])+                                                    hs_pats hs_rhs_ty++       ; let fam_tvs  = tyConTyVars fam_tc+             ppr_eqn  = ppr_default_eqn pats rhs_ty+             pats_vis = tyConArgFlags fam_tc pats+       ; traceTc "tcDefaultAssocDecl 2" (vcat+           [ text "fam_tvs" <+> ppr fam_tvs+           , text "qtvs"    <+> ppr qtvs+           , text "pats"    <+> ppr pats+           , text "rhs_ty"  <+> ppr rhs_ty+           ])+       ; pat_tvs <- zipWithM (extract_tv ppr_eqn) pats pats_vis+       ; check_all_distinct_tvs ppr_eqn $ zip pat_tvs pats_vis+       ; let subst = zipTvSubst pat_tvs (mkTyVarTys fam_tvs)+       ; pure $ Just (substTyUnchecked subst rhs_ty, loc)+           -- We also perform other checks for well-formedness and validity+           -- later, in checkValidClass+     }+  where+    -- Checks that a pattern on the LHS of a default is a type+    -- variable. If so, return the underlying type variable, and if+    -- not, throw an error.+    -- See Note [Type-checking default assoc decls]+    extract_tv :: SDoc    -- The pretty-printed default equation+                          -- (only used for error message purposes)+               -> Type    -- The particular type pattern from which to extract+                          -- its underlying type variable+               -> ArgFlag -- The visibility of the type pattern+                          -- (only used for error message purposes)+               -> TcM TyVar+    extract_tv ppr_eqn pat pat_vis =+      case getTyVar_maybe pat of+        Just tv -> pure tv+        Nothing -> failWithTc $+          pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $+          hang (text "Illegal argument" <+> quotes (ppr pat) <+> text "in:")+             2 (vcat [ppr_eqn, suggestion])+++    -- Checks that no type variables in an associated default declaration are+    -- duplicated. If that is the case, throw an error.+    -- See Note [Type-checking default assoc decls]+    check_all_distinct_tvs ::+         SDoc               -- The pretty-printed default equation (only used+                            -- for error message purposes)+      -> [(TyVar, ArgFlag)] -- The type variable arguments in the associated+                            -- default declaration, along with their respective+                            -- visibilities (the latter are only used for error+                            -- message purposes)+      -> TcM ()+    check_all_distinct_tvs ppr_eqn pat_tvs_vis =+      let dups = findDupsEq ((==) `on` fst) pat_tvs_vis in+      traverse_+        (\d -> let (pat_tv, pat_vis) = NE.head d in failWithTc $+               pprWithExplicitKindsWhen (isInvisibleArgFlag pat_vis) $+               hang (text "Illegal duplicate variable"+                       <+> quotes (ppr pat_tv) <+> text "in:")+                  2 (vcat [ppr_eqn, suggestion]))+        dups++    ppr_default_eqn :: [Type] -> Type -> SDoc+    ppr_default_eqn pats rhs_ty =+      quotes (text "type" <+> ppr (mkTyConApp fam_tc pats)+                <+> equals <+> ppr rhs_ty)++    suggestion :: SDoc+    suggestion = text "The arguments to" <+> quotes (ppr fam_tc)+             <+> text "must all be distinct type variables"+tcDefaultAssocDecl _ [_]+  = panic "tcDefaultAssocDecl: Impossible Match" -- due to #15884+++{- Note [Type-checking default assoc decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this default declaration for an associated type++   class C a where+      type F (a :: k) b :: Type+      type F (x :: j) y = Proxy x -> y++Note that the class variable 'a' doesn't scope over the default assoc+decl (rather oddly I think), and (less oddly) neither does the second+argument 'b' of the associated type 'F', or the kind variable 'k'.+Instead, the default decl is treated more like a top-level type+instance.++However we store the default rhs (Proxy x -> y) in F's TyCon, using+F's own type variables, so we need to convert it to (Proxy a -> b).+We do this by creating a substitution [j |-> k, x |-> a, b |-> y] and+applying this substitution to the RHS.++In order to create this substitution, we must first ensure that all of+the arguments in the default instance consist of distinct type variables.+One might think that this is a simple task that could be implemented earlier+in the compiler, perhaps in the parser or the renamer. However, there are some+tricky corner cases that really do require the full power of typechecking to+weed out, as the examples below should illustrate.++First, we must check that all arguments are type variables. As a motivating+example, consider this erroneous program (inspired by #11361):++   class C a where+      type F (a :: k) b :: Type+      type F x        b = x++If you squint, you'll notice that the kind of `x` is actually Type. However,+we cannot substitute from [Type |-> k], so we reject this default.++Next, we must check that all arguments are distinct. Here is another offending+example, this time taken from #13971:++   class C2 (a :: j) where+      type F2 (a :: j) (b :: k)+      type F2 (x :: z) y = SameKind x y+   data SameKind :: k -> k -> Type++All of the arguments in the default equation for `F2` are type variables, so+that passes the first check. However, if we were to build this substitution,+then both `j` and `k` map to `z`! In terms of visible kind application, it's as+if we had written `type F2 @z @z x y = SameKind @z x y`, which makes it clear+that we have duplicated a use of `z` on the LHS. Therefore, `F2`'s default is+also rejected.++Since the LHS of an associated type family default is always just variables,+it won't contain any tycons. Accordingly, the patterns used in the substitution+won't actually be knot-tied, even though we're in the knot. This is too+delicate for my taste, but it works.+-}++{- *********************************************************************+*                                                                      *+          Type family declarations+*                                                                      *+********************************************************************* -}++tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon+tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info+                              , fdLName = tc_lname@(dL->L _ tc_name)+                              , fdResultSig = (dL->L _ sig)+                              , fdInjectivityAnn = inj })+  | DataFamily <- fam_info+  = bindTyClTyVars tc_name $ \ binders res_kind -> do+  { traceTc "data family:" (ppr tc_name)+  ; checkFamFlag tc_name++  -- Check that the result kind is OK+  -- We allow things like+  --   data family T (a :: Type) :: forall k. k -> Type+  -- We treat T as having arity 1, but result kind forall k. k -> Type+  -- But we want to check that the result kind finishes in+  --   Type or a kind-variable+  -- For the latter, consider+  --   data family D a :: forall k. Type -> k+  ; let (_, final_res_kind) = splitPiTys res_kind+  ; checkTc (tcIsLiftedTypeKind final_res_kind+             || isJust (tcGetCastedTyVar_maybe final_res_kind))+            (badKindSig False res_kind)++  ; tc_rep_name <- newTyConRepName tc_name+  ; let tycon = mkFamilyTyCon tc_name binders+                              res_kind+                              (resultVariableName sig)+                              (DataFamilyTyCon tc_rep_name)+                              parent NotInjective+  ; return tycon }++  | OpenTypeFamily <- fam_info+  = bindTyClTyVars tc_name $ \ binders res_kind -> do+  { traceTc "open type family:" (ppr tc_name)+  ; checkFamFlag tc_name+  ; inj' <- tcInjectivity binders inj+  ; let tycon = mkFamilyTyCon tc_name binders res_kind+                               (resultVariableName sig) OpenSynFamilyTyCon+                               parent inj'+  ; return tycon }++  | ClosedTypeFamily mb_eqns <- fam_info+  = -- Closed type families are a little tricky, because they contain the definition+    -- of both the type family and the equations for a CoAxiom.+    do { traceTc "Closed type family:" (ppr tc_name)+         -- the variables in the header scope only over the injectivity+         -- declaration but this is not involved here+       ; (inj', binders, res_kind)+            <- bindTyClTyVars tc_name $ \ binders res_kind ->+               do { inj' <- tcInjectivity binders inj+                  ; return (inj', binders, res_kind) }++       ; checkFamFlag tc_name -- make sure we have -XTypeFamilies++         -- If Nothing, this is an abstract family in a hs-boot file;+         -- but eqns might be empty in the Just case as well+       ; case mb_eqns of+           Nothing   ->+               return $ mkFamilyTyCon tc_name binders res_kind+                                      (resultVariableName sig)+                                      AbstractClosedSynFamilyTyCon parent+                                      inj'+           Just eqns -> do {++         -- Process the equations, creating CoAxBranches+       ; let tc_fam_tc = mkTcTyCon tc_name binders res_kind+                                   [] False {- this doesn't matter here -}+                                   ClosedTypeFamilyFlavour++       ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns+         -- Do not attempt to drop equations dominated by earlier+         -- ones here; in the case of mutual recursion with a data+         -- type, we get a knot-tying failure.  Instead we check+         -- for this afterwards, in TcValidity.checkValidCoAxiom+         -- Example: tc265++         -- Create a CoAxiom, with the correct src location.+       ; co_ax_name <- newFamInstAxiomName tc_lname []++       ; let mb_co_ax+              | null eqns = Nothing   -- mkBranchedCoAxiom fails on empty list+              | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches)++             fam_tc = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig)+                      (ClosedSynFamilyTyCon mb_co_ax) parent inj'++         -- We check for instance validity later, when doing validity+         -- checking for the tycon. Exception: checking equations+         -- overlap done by dropDominatedAxioms+       ; return fam_tc } }++  | otherwise = panic "tcFamInst1"  -- Silence pattern-exhaustiveness checker+tcFamDecl1 _ (XFamilyDecl _) = panic "tcFamDecl1"++-- | Maybe return a list of Bools that say whether a type family was declared+-- injective in the corresponding type arguments. Length of the list is equal to+-- the number of arguments (including implicit kind/coercion arguments).+-- True on position+-- N means that a function is injective in its Nth argument. False means it is+-- not.+tcInjectivity :: [TyConBinder] -> Maybe (LInjectivityAnn GhcRn)+              -> TcM Injectivity+tcInjectivity _ Nothing+  = return NotInjective++  -- User provided an injectivity annotation, so for each tyvar argument we+  -- check whether a type family was declared injective in that argument. We+  -- return a list of Bools, where True means that corresponding type variable+  -- was mentioned in lInjNames (type family is injective in that argument) and+  -- False means that it was not mentioned in lInjNames (type family is not+  -- injective in that type variable). We also extend injectivity information to+  -- kind variables, so if a user declares:+  --+  --   type family F (a :: k1) (b :: k2) = (r :: k3) | r -> a+  --+  -- then we mark both `a` and `k1` as injective.+  -- NB: the return kind is considered to be *input* argument to a type family.+  -- Since injectivity allows to infer input arguments from the result in theory+  -- we should always mark the result kind variable (`k3` in this example) as+  -- injective.  The reason is that result type has always an assigned kind and+  -- therefore we can always infer the result kind if we know the result type.+  -- But this does not seem to be useful in any way so we don't do it.  (Another+  -- reason is that the implementation would not be straightforward.)+tcInjectivity tcbs (Just (dL->L loc (InjectivityAnn _ lInjNames)))+  = setSrcSpan loc $+    do { let tvs = binderVars tcbs+       ; dflags <- getDynFlags+       ; checkTc (xopt LangExt.TypeFamilyDependencies dflags)+                 (text "Illegal injectivity annotation" $$+                  text "Use TypeFamilyDependencies to allow this")+       ; inj_tvs <- mapM (tcLookupTyVar . unLoc) lInjNames+       ; inj_tvs <- mapM zonkTcTyVarToTyVar inj_tvs -- zonk the kinds+       ; let inj_ktvs = filterVarSet isTyVar $  -- no injective coercion vars+                        closeOverKinds (mkVarSet inj_tvs)+       ; let inj_bools = map (`elemVarSet` inj_ktvs) tvs+       ; traceTc "tcInjectivity" (vcat [ ppr tvs, ppr lInjNames, ppr inj_tvs+                                       , ppr inj_ktvs, ppr inj_bools ])+       ; return $ Injective inj_bools }++tcTySynRhs :: RolesInfo+           -> Name+           -> [TyConBinder] -> Kind+           -> LHsType GhcRn -> TcM TyCon+tcTySynRhs roles_info tc_name binders res_kind hs_ty+  = do { env <- getLclEnv+       ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))+       ; rhs_ty <- pushTcLevelM_   $+                   solveEqualities $+                   tcCheckLHsType hs_ty res_kind+       ; rhs_ty <- zonkTcTypeToType rhs_ty+       ; let roles = roles_info tc_name+             tycon = buildSynTyCon tc_name binders res_kind roles rhs_ty+       ; return tycon }++tcDataDefn :: RolesInfo -> Name+           -> [TyConBinder] -> Kind+           -> HsDataDefn GhcRn -> TcM TyCon+  -- NB: not used for newtype/data instances (whether associated or not)+tcDataDefn roles_info+           tc_name tycon_binders res_kind+           (HsDataDefn { dd_ND = new_or_data, dd_cType = cType+                       , dd_ctxt = ctxt+                       , dd_kindSig = mb_ksig  -- Already in tc's kind+                                               -- via getInitialKinds+                       , dd_cons = cons })+ =  do { gadt_syntax <- dataDeclChecks tc_name new_or_data ctxt cons++       ; 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) $+         checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind)++       ; stupid_tc_theta <- pushTcLevelM_ $ solveEqualities $ tcHsContext ctxt+       ; stupid_theta    <- zonkTcTypesToTypes stupid_tc_theta+       ; kind_signatures <- xoptM LangExt.KindSignatures++             -- Check that we don't use kind signatures without Glasgow extensions+       ; when (isJust mb_ksig) $+         checkTc (kind_signatures) (badSigTyDecl tc_name)++       ; tycon <- fixM $ \ tycon -> do+             { let final_bndrs = tycon_binders `chkAppend` extra_bndrs+                   res_ty      = mkTyConApp tycon (mkTyVarTys (binderVars final_bndrs))+                   roles       = roles_info tc_name++             ; data_cons <- tcConDecls tycon final_bndrs res_ty cons+             ; tc_rhs    <- mk_tc_rhs hsc_src tycon data_cons+             ; tc_rep_nm <- newTyConRepName tc_name+             ; return (mkAlgTyCon tc_name+                                  final_bndrs+                                  final_res_kind+                                  roles+                                  (fmap unLoc cType)+                                  stupid_theta tc_rhs+                                  (VanillaAlgTyCon tc_rep_nm)+                                  gadt_syntax) }+       ; traceTc "tcDataDefn" (ppr tc_name $$ ppr tycon_binders $$ ppr extra_bndrs)+       ; return tycon }+  where+    -- Abstract data types in hsig files can have arbitrary kinds,+    -- because they may be implemented by type synonyms+    -- (which themselves can have arbitrary kinds, not just *)+    mk_permissive_kind HsigFile [] = True+    mk_permissive_kind _ _ = False++    -- In hs-boot, a 'data' declaration with no constructors+    -- indicates a nominally distinct abstract data type.+    mk_tc_rhs HsBootFile _ []+      = return AbstractTyCon++    mk_tc_rhs HsigFile _ [] -- ditto+      = return AbstractTyCon++    mk_tc_rhs _ tycon data_cons+      = case new_or_data of+          DataType -> return (mkDataTyConRhs data_cons)+          NewType  -> ASSERT( not (null data_cons) )+                      mkNewTyConRhs tc_name tycon (head data_cons)+tcDataDefn _ _ _ _ (XHsDataDefn _) = panic "tcDataDefn"+++-------------------------+kcTyFamInstEqn :: TcTyCon -> LTyFamInstEqn GhcRn -> TcM ()+-- Used for the equations of a closed type family only+-- Not used for data/type instances+kcTyFamInstEqn tc_fam_tc+    (dL->L loc (HsIB { hsib_ext = imp_vars+                     , hsib_body = FamEqn { feqn_tycon = dL->L _ eqn_tc_name+                                          , feqn_bndrs = mb_expl_bndrs+                                          , feqn_pats  = hs_pats+                                          , feqn_rhs   = hs_rhs_ty }}))+  = setSrcSpan loc $+    do { traceTc "kcTyFamInstEqn" (vcat+           [ text "tc_name ="    <+> ppr eqn_tc_name+           , text "fam_tc ="     <+> ppr tc_fam_tc <+> dcolon <+> ppr (tyConKind tc_fam_tc)+           , text "hsib_vars ="  <+> ppr imp_vars+           , text "feqn_bndrs =" <+> ppr mb_expl_bndrs+           , text "feqn_pats ="  <+> ppr hs_pats ])+          -- this check reports an arity error instead of a kind error; easier for user+       ; let vis_pats = numVisibleArgs hs_pats+       ; checkTc (vis_pats == vis_arity) $+                  wrongNumberOfParmsErr vis_arity+       ; discardResult $+         bindImplicitTKBndrs_Q_Tv imp_vars $+         bindExplicitTKBndrs_Q_Tv AnyKind (mb_expl_bndrs `orElse` []) $+         do { (_fam_app, res_kind) <- tcFamTyPats tc_fam_tc hs_pats+            ; tcCheckLHsType hs_rhs_ty res_kind }+             -- Why "_Tv" here?  Consider (#14066+             --  type family Bar x y where+             --      Bar (x :: a) (y :: b) = Int+             --      Bar (x :: c) (y :: d) = Bool+             -- During kind-checkig, a,b,c,d should be TyVarTvs and unify appropriately+    }+  where+    vis_arity = length (tyConVisibleTyVars tc_fam_tc)++kcTyFamInstEqn _ (dL->L _ (XHsImplicitBndrs _)) = panic "kcTyFamInstEqn"+kcTyFamInstEqn _ (dL->L _ (HsIB _ (XFamEqn _))) = panic "kcTyFamInstEqn"+kcTyFamInstEqn _ _ = panic "kcTyFamInstEqn: Impossible Match" -- due to #15884+++--------------------------+tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn+               -> TcM (KnotTied CoAxBranch)+-- Needs to be here, not in TcInstDcls, because closed families+-- (typechecked here) have TyFamInstEqns++tcTyFamInstEqn fam_tc mb_clsinfo+    (dL->L loc (HsIB { hsib_ext = imp_vars+                 , hsib_body = FamEqn { feqn_tycon  = L _ eqn_tc_name+                                      , feqn_bndrs  = mb_expl_bndrs+                                      , feqn_pats   = hs_pats+                                      , feqn_rhs    = hs_rhs_ty }}))+  = ASSERT( getName fam_tc == eqn_tc_name )+    setSrcSpan loc $+    do {+       -- First, check the arity of visible arguments+       -- If we wait until validity checking, we'll get kind errors+       -- below when an arity error will be much easier to understand.+       ; let vis_arity = length (tyConVisibleTyVars fam_tc)+             vis_pats  = numVisibleArgs hs_pats+       ; checkTc (vis_pats == vis_arity) $+         wrongNumberOfParmsErr vis_arity++       ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo+                                      imp_vars (mb_expl_bndrs `orElse` [])+                                      hs_pats hs_rhs_ty++       -- Don't print results they may be knot-tied+       -- (tcFamInstEqnGuts zonks to Type)+       ; return (mkCoAxBranch qtvs [] [] pats rhs_ty+                              (map (const Nominal) qtvs)+                              loc) }++tcTyFamInstEqn _ _ _ = panic "tcTyFamInstEqn"++{-+Kind check type patterns and kind annotate the embedded type variables.+     type instance F [a] = rhs++ * Here we check that a type instance matches its kind signature, but we do+   not check whether there is a pattern for each type index; the latter+   check is only required for type synonym instances.++Note [Instantiating a family tycon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's possible that kind-checking the result of a family tycon applied to+its patterns will instantiate the tycon further. For example, we might+have++  type family F :: k where+    F = Int+    F = Maybe++After checking (F :: forall k. k) (with no visible patterns), we still need+to instantiate the k. With data family instances, this problem can be even+more intricate, due to Note [Arity of data families] in FamInstEnv. See+indexed-types/should_compile/T12369 for an example.++So, the kind-checker must return the new skolems and args (that is, Type+or (Type -> Type) for the equations above) and the instantiated kind.++Note [Generalising in tcFamTyPatsGuts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have something like+  type instance forall (a::k) b. F t1 t2 = rhs++Then  imp_vars = [k], exp_bndrs = [a::k, b]++We want to quantify over+  * k, a, and b  (all user-specified)+  * and any inferred free kind vars from+      - the kinds of k, a, b+      - the types t1, t2++However, unlike a type signature like+  f :: forall (a::k). blah++we do /not/ care about the Inferred/Specified designation+or order for the final quantified tyvars.  Type-family+instances are not invoked directly in Haskell source code,+so visible type application etc plays no role.++So, the simple thing is+   - gather candiates from [k, a, b] and pats+   - quantify over them++Hence the sligtly mysterious call:+    candidateQTyVarsOfTypes (pats ++ mkTyVarTys scoped_tvs)++Simple, neat, but a little non-obvious!+-}++--------------------------+tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo+                   -> [Name] -> [LHsTyVarBndr GhcRn]  -- Implicit and explicicit binder+                   -> HsTyPats GhcRn                  -- Patterns+                   -> LHsType GhcRn                   -- RHS+                   -> TcM ([TyVar], [TcType], TcType)      -- (tyvars, pats, rhs)+-- Used only for type families, not data families+tcTyFamInstEqnGuts fam_tc mb_clsinfo imp_vars exp_bndrs hs_pats hs_rhs_ty+  = do { traceTc "tcTyFamInstEqnGuts {" (vcat [ ppr fam_tc <+> ppr hs_pats ])++       -- By now, for type families (but not data families) we should+       -- have checked that the number of patterns matches tyConArity++       -- This code is closely related to the code+       -- in TcHsType.kcLHsQTyVars_Cusk+       ; (imp_tvs, (exp_tvs, (lhs_ty, rhs_ty)))+               <- pushTcLevelM_                                $+                  solveEqualities                              $+                  bindImplicitTKBndrs_Q_Skol imp_vars          $+                  bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $+                  do { (lhs_ty, rhs_kind) <- tcFamTyPats fam_tc hs_pats+                       -- Ensure that the instance is consistent with its+                       -- parent class (#16008)+                     ; addConsistencyConstraints mb_clsinfo lhs_ty+                     ; rhs_ty <- tcCheckLHsType hs_rhs_ty rhs_kind+                     ; return (lhs_ty, rhs_ty) }++       -- See Note [Generalising in tcFamTyPatsGuts]+       -- This code (and the stuff immediately above) is very similar+       -- to that in tcDataFamHeader.  Maybe we should abstract the+       -- common code; but for the moment I concluded that it's+       -- clearer to duplicate it.  Still, if you fix a bug here,+       -- check there too!+       ; let scoped_tvs = imp_tvs ++ exp_tvs+       ; dvs  <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)+       ; qtvs <- quantifyTyVars emptyVarSet dvs++       ; (ze, qtvs) <- zonkTyBndrs qtvs+       ; lhs_ty     <- zonkTcTypeToTypeX ze lhs_ty+       ; rhs_ty     <- zonkTcTypeToTypeX ze rhs_ty++       ; let pats = unravelFamInstPats lhs_ty+             -- Note that we do this after solveEqualities+             -- so that any strange coercions inside lhs_ty+             -- have been solved before we attempt to unravel it+       ; traceTc "tcTyFamInstEqnGuts }" (ppr fam_tc <+> pprTyVars qtvs)+       ; return (qtvs, pats, rhs_ty) }++-----------------+tcFamTyPats :: TyCon+            -> HsTyPats GhcRn                -- Patterns+            -> TcM (TcType, TcKind)          -- (lhs_type, lhs_kind)+-- Used for both type and data families+tcFamTyPats fam_tc hs_pats+  = do { traceTc "tcFamTyPats {" $+         vcat [ ppr fam_tc, text "arity:" <+> ppr fam_arity ]++       ; let fun_ty = mkTyConApp fam_tc []++       ; (fam_app, res_kind) <- unsetWOptM Opt_WarnPartialTypeSignatures $+                                setXOptM LangExt.PartialTypeSignatures $+                                -- See Note [Wildcards in family instances] in+                                -- RnSource.hs+                                tcInferApps typeLevelMode lhs_fun fun_ty hs_pats++       ; traceTc "End tcFamTyPats }" $+         vcat [ ppr fam_tc, text "res_kind:" <+> ppr res_kind ]++       ; return (fam_app, res_kind) }+  where+    fam_name  = tyConName fam_tc+    fam_arity = tyConArity fam_tc+    lhs_fun   = noLoc (HsTyVar noExt NotPromoted (noLoc fam_name))++unravelFamInstPats :: TcType -> [TcType]+-- Decompose fam_app to get the argument patterns+--+-- We expect fam_app to look like (F t1 .. tn)+-- tcInferApps is capable of returning ((F ty1 |> co) ty2),+-- but that can't happen here because we already checked the+-- arity of F matches the number of pattern+unravelFamInstPats fam_app+  = case splitTyConApp_maybe fam_app of+      Just (_, pats) -> pats+      Nothing        -> WARN( True, bad_lhs fam_app ) []+        -- The Nothing case cannot happen for type families, because+        -- we don't call unravelFamInstPats until we've solved the+        -- equalities.  For data families I wasn't quite as convinced+        -- so I've let it as a warning rather than a panic.+  where+    bad_lhs fam_app+      = hang (text "Ill-typed LHS of family instance")+           2 (debugPprType fam_app)++addConsistencyConstraints :: AssocInstInfo -> TcType -> TcM ()+-- In the corresponding positions of the class and type-family,+-- ensure the the family argument is the same as the class argument+--   E.g    class C a b c d where+--             F c x y a :: Type+-- Here the first  arg of F should be the same as the third of C+--  and the fourth arg of F should be the same as the first of C+--+-- We emit /Derived/ constraints (a bit like fundeps) to encourage+-- unification to happen, but without actually reporting errors.+-- If, despite the efforts, corresponding positions do not match,+-- checkConsistentFamInst will complain+addConsistencyConstraints mb_clsinfo fam_app+  | InClsInst { ai_inst_env = inst_env } <- mb_clsinfo+  , Just (fam_tc, pats) <- tcSplitTyConApp_maybe fam_app+  = do { let eqs = [ (cls_ty, pat)+                   | (fam_tc_tv, pat) <- tyConTyVars fam_tc `zip` pats+                   , Just cls_ty <- [lookupVarEnv inst_env fam_tc_tv] ]+       ; traceTc "addConsistencyConstraints" (ppr eqs)+       ; emitDerivedEqs AssocFamPatOrigin eqs }+    -- Improve inference+    -- Any mis-match is reports by checkConsistentFamInst+  | otherwise+  = return ()++{- Note [Constraints in patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: This isn't the whole story. See comment in tcFamTyPats.++At first glance, it seems there is a complicated story to tell in tcFamTyPats+around constraint solving. After all, type family patterns can now do+GADT pattern-matching, which is jolly complicated. But, there's a key fact+which makes this all simple: everything is at top level! There cannot+be untouchable type variables. There can't be weird interaction between+case branches. There can't be global skolems.++This means that the semantics of type-level GADT matching is a little+different than term level. If we have++  data G a where+    MkGBool :: G Bool++And then++  type family F (a :: G k) :: k+  type instance F MkGBool = True++we get++  axF : F Bool (MkGBool <Bool>) ~ True++Simple! No casting on the RHS, because we can affect the kind parameter+to F.++If we ever introduce local type families, this all gets a lot more+complicated, and will end up looking awfully like term-level GADT+pattern-matching.+++** The new story **++Here is really what we want:++The matcher really can't deal with covars in arbitrary spots in coercions.+But it can deal with covars that are arguments to GADT data constructors.+So we somehow want to allow covars only in precisely those spots, then use+them as givens when checking the RHS. TODO (RAE): Implement plan.+++Note [Quantifying over family patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to quantify over two different lots of kind variables:++First, the ones that come from the kinds of the tyvar args of+tcTyVarBndrsKindGen, as usual+  data family Dist a++  -- Proxy :: forall k. k -> *+  data instance Dist (Proxy a) = DP+  -- Generates  data DistProxy = DP+  --            ax8 k (a::k) :: Dist * (Proxy k a) ~ DistProxy k a+  -- The 'k' comes from the tcTyVarBndrsKindGen (a::k)++Second, the ones that come from the kind argument of the type family+which we pick up using the (tyCoVarsOfTypes typats) in the result of+the thing_inside of tcHsTyvarBndrsGen.+  -- Any :: forall k. k+  data instance Dist Any = DA+  -- Generates  data DistAny k = DA+  --            ax7 k :: Dist k (Any k) ~ DistAny k+  -- The 'k' comes from kindGeneralizeKinds (Any k)++Note [Quantified kind variables of a family pattern]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider   type family KindFam (p :: k1) (q :: k1)+           data T :: Maybe k1 -> k2 -> *+           type instance KindFam (a :: Maybe k) b = T a b -> Int+The HsBSig for the family patterns will be ([k], [a])++Then in the family instance we want to+  * Bring into scope [ "k" -> k:*, "a" -> a:k ]+  * Kind-check the RHS+  * Quantify the type instance over k and k', as well as a,b, thus+       type instance [k, k', a:Maybe k, b:k']+                     KindFam (Maybe k) k' a b = T k k' a b -> Int++Notice that in the third step we quantify over all the visibly-mentioned+type variables (a,b), but also over the implicitly mentioned kind variables+(k, k').  In this case one is bound explicitly but often there will be+none. The role of the kind signature (a :: Maybe k) is to add a constraint+that 'a' must have that kind, and to bring 'k' into scope.++++************************************************************************+*                                                                      *+               Data types+*                                                                      *+************************************************************************+-}++dataDeclChecks :: Name -> NewOrData+               -> LHsContext GhcRn -> [LConDecl GhcRn]+               -> TcM Bool+dataDeclChecks tc_name new_or_data (L _ stupid_theta) cons+  = do {   -- Check that we don't use GADT syntax in H98 world+         gadtSyntax_ok <- xoptM LangExt.GADTSyntax+       ; let gadt_syntax = consUseGadtSyntax cons+       ; checkTc (gadtSyntax_ok || not gadt_syntax) (badGadtDecl tc_name)++           -- Check that the stupid theta is empty for a GADT-style declaration+       ; checkTc (null stupid_theta || not gadt_syntax) (badStupidTheta tc_name)++         -- Check that a newtype has exactly one constructor+         -- Do this before checking for empty data decls, so that+         -- we don't suggest -XEmptyDataDecls for newtypes+       ; checkTc (new_or_data == DataType || isSingleton cons)+                (newtypeConError tc_name (length cons))++         -- Check that there's at least one condecl,+         -- or else we're reading an hs-boot file, or -XEmptyDataDecls+       ; empty_data_decls <- xoptM LangExt.EmptyDataDecls+       ; is_boot <- tcIsHsBootOrSig  -- Are we compiling an hs-boot file?+       ; checkTc (not (null cons) || empty_data_decls || is_boot)+                 (emptyConDeclsErr tc_name)+       ; return gadt_syntax }+++-----------------------------------+consUseGadtSyntax :: [LConDecl a] -> Bool+consUseGadtSyntax ((dL->L _ (ConDeclGADT {})) : _) = True+consUseGadtSyntax _                                = False+                 -- All constructors have same shape++-----------------------------------+tcConDecls :: KnotTied TyCon -> [KnotTied TyConBinder] -> KnotTied Type+           -> [LConDecl GhcRn] -> TcM [DataCon]+  -- Why both the tycon tyvars and binders? Because the tyvars+  -- have all the names and the binders have the visibilities.+tcConDecls rep_tycon tmpl_bndrs res_tmpl+  = concatMapM $ addLocM $+    tcConDecl rep_tycon (mkTyConTagMap rep_tycon) tmpl_bndrs res_tmpl+    -- It's important that we pay for tag allocation here, once per TyCon,+    -- See Note [Constructor tag allocation], fixes #14657++tcConDecl :: KnotTied TyCon          -- Representation tycon. Knot-tied!+          -> NameEnv ConTag+          -> [KnotTied TyConBinder] -> KnotTied Type+                 -- Return type template (with its template tyvars)+                 --    (tvs, T tys), where T is the family TyCon+          -> ConDecl GhcRn+          -> TcM [DataCon]++tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl+          (ConDeclH98 { con_name = name+                      , con_ex_tvs = explicit_tkv_nms+                      , con_mb_cxt = hs_ctxt+                      , con_args = hs_args })+  = addErrCtxt (dataConCtxtName [name]) $+    do { -- NB: the tyvars from the declaration header are in scope++         -- Get hold of the existential type variables+         -- e.g. data T a = forall k (b::k) f. MkT a (f b)+         -- Here tmpl_bndrs = {a}+         --      hs_qvars = HsQTvs { hsq_implicit = {k}+         --                        , hsq_explicit = {f,b} }++       ; traceTc "tcConDecl 1" (vcat [ ppr name, ppr explicit_tkv_nms ])++       ; (exp_tvs, (ctxt, arg_tys, field_lbls, stricts))+           <- pushTcLevelM_                             $+              solveEqualities                           $+              bindExplicitTKBndrs_Skol explicit_tkv_nms $+              do { ctxt <- tcHsMbContext hs_ctxt+                 ; btys <- tcConArgs hs_args+                 ; field_lbls <- lookupConstructorFields (unLoc name)+                 ; let (arg_tys, stricts) = unzip btys+                 ; return (ctxt, arg_tys, field_lbls, stricts)+                 }++         -- exp_tvs have explicit, user-written binding sites+         -- the kvs below are those kind variables entirely unmentioned by the user+         --   and discovered only by generalization++       ; kvs <- kindGeneralize (mkSpecForAllTys (binderVars tmpl_bndrs) $+                                mkSpecForAllTys exp_tvs $+                                mkPhiTy ctxt $+                                mkVisFunTys arg_tys $+                                unitTy)+                 -- That type is a lie, of course. (It shouldn't end in ()!)+                 -- And we could construct a proper result type from the info+                 -- at hand. But the result would mention only the tmpl_tvs,+                 -- and so it just creates more work to do it right. Really,+                 -- we're only doing this to find the right kind variables to+                 -- quantify over, and this type is fine for that purpose.++             -- Zonk to Types+       ; (ze, qkvs)      <- zonkTyBndrs kvs+       ; (ze, user_qtvs) <- zonkTyBndrsX ze exp_tvs+       ; arg_tys         <- zonkTcTypesToTypesX ze arg_tys+       ; ctxt            <- zonkTcTypesToTypesX ze ctxt++       ; fam_envs <- tcGetFamInstEnvs++       -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here+       ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls)+       ; let+           univ_tvbs = tyConTyVarBinders tmpl_bndrs+           univ_tvs  = binderVars univ_tvbs+           ex_tvbs   = mkTyVarBinders Inferred qkvs +++                       mkTyVarBinders Specified user_qtvs+           ex_tvs    = qkvs ++ user_qtvs+           -- For H98 datatypes, the user-written tyvar binders are precisely+           -- the universals followed by the existentials.+           -- See Note [DataCon user type variable binders] in DataCon.+           user_tvbs = univ_tvbs ++ ex_tvbs+           buildOneDataCon (dL->L _ name) = do+             { is_infix <- tcConIsInfixH98 name hs_args+             ; rep_nm   <- newTyConRepName name++             ; buildDataCon fam_envs name is_infix rep_nm+                            stricts Nothing field_lbls+                            univ_tvs ex_tvs user_tvbs+                            [{- no eq_preds -}] ctxt arg_tys+                            res_tmpl rep_tycon tag_map+                  -- NB:  we put data_tc, the type constructor gotten from the+                  --      constructor type signature into the data constructor;+                  --      that way checkValidDataCon can complain if it's wrong.+             }+       ; traceTc "tcConDecl 2" (ppr name)+       ; mapM buildOneDataCon [name]+       }++tcConDecl rep_tycon tag_map tmpl_bndrs res_tmpl+          (ConDeclGADT { con_names = names+                       , con_qvars = qtvs+                       , con_mb_cxt = cxt, con_args = hs_args+                       , con_res_ty = hs_res_ty })+  | HsQTvs { hsq_ext = implicit_tkv_nms+           , hsq_explicit = explicit_tkv_nms } <- qtvs+  = addErrCtxt (dataConCtxtName names) $+    do { traceTc "tcConDecl 1 gadt" (ppr names)+       ; let ((dL->L _ name) : _) = names++       ; (imp_tvs, (exp_tvs, (ctxt, arg_tys, res_ty, field_lbls, stricts)))+           <- pushTcLevelM_    $  -- We are going to generalise+              solveEqualities  $  -- We won't get another crack, and we don't+                                  -- want an error cascade+              bindImplicitTKBndrs_Skol implicit_tkv_nms $+              bindExplicitTKBndrs_Skol explicit_tkv_nms $+              do { ctxt <- tcHsMbContext cxt+                 ; btys <- tcConArgs hs_args+                 ; res_ty <- tcHsLiftedType hs_res_ty+                 ; field_lbls <- lookupConstructorFields name+                 ; let (arg_tys, stricts) = unzip btys+                 ; return (ctxt, arg_tys, res_ty, field_lbls, stricts)+                 }+       ; imp_tvs <- zonkAndScopedSort imp_tvs+       ; let user_tvs = imp_tvs ++ exp_tvs++       ; tkvs <- kindGeneralize (mkSpecForAllTys user_tvs $+                                 mkPhiTy ctxt $+                                 mkVisFunTys arg_tys $+                                 res_ty)++             -- Zonk to Types+       ; (ze, tkvs)     <- zonkTyBndrs tkvs+       ; (ze, user_tvs) <- zonkTyBndrsX ze user_tvs+       ; arg_tys <- zonkTcTypesToTypesX ze arg_tys+       ; ctxt    <- zonkTcTypesToTypesX ze ctxt+       ; res_ty  <- zonkTcTypeToTypeX   ze res_ty++       ; let (univ_tvs, ex_tvs, tkvs', user_tvs', eq_preds, arg_subst)+               = rejigConRes tmpl_bndrs res_tmpl tkvs user_tvs res_ty+             -- NB: this is a /lazy/ binding, so we pass six thunks to+             --     buildDataCon without yet forcing the guards in rejigConRes+             -- See Note [Checking GADT return types]++             -- Compute the user-written tyvar binders. These have the same+             -- tyvars as univ_tvs/ex_tvs, but perhaps in a different order.+             -- See Note [DataCon user type variable binders] in DataCon.+             tkv_bndrs      = mkTyVarBinders Inferred  tkvs'+             user_tv_bndrs  = mkTyVarBinders Specified user_tvs'+             all_user_bndrs = tkv_bndrs ++ user_tv_bndrs++             ctxt'      = substTys arg_subst ctxt+             arg_tys'   = substTys arg_subst arg_tys+             res_ty'    = substTy  arg_subst res_ty+++       ; fam_envs <- tcGetFamInstEnvs++       -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here+       ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls)+       ; let+           buildOneDataCon (dL->L _ name) = do+             { is_infix <- tcConIsInfixGADT name hs_args+             ; rep_nm   <- newTyConRepName name++             ; buildDataCon fam_envs name is_infix+                            rep_nm+                            stricts Nothing field_lbls+                            univ_tvs ex_tvs all_user_bndrs eq_preds+                            ctxt' arg_tys' res_ty' rep_tycon tag_map+                  -- NB:  we put data_tc, the type constructor gotten from the+                  --      constructor type signature into the data constructor;+                  --      that way checkValidDataCon can complain if it's wrong.+             }+       ; traceTc "tcConDecl 2" (ppr names)+       ; mapM buildOneDataCon names+       }+tcConDecl _ _ _ _ (ConDeclGADT _ _ _ (XLHsQTyVars _) _ _ _ _)+  = panic "tcConDecl"+tcConDecl _ _ _ _ (XConDecl _) = panic "tcConDecl"++tcConIsInfixH98 :: Name+             -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])+             -> TcM Bool+tcConIsInfixH98 _   details+  = case details of+           InfixCon {}  -> return True+           _            -> return False++tcConIsInfixGADT :: Name+             -> HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn])+             -> TcM Bool+tcConIsInfixGADT con details+  = case details of+           InfixCon {}  -> return True+           RecCon {}    -> return False+           PrefixCon arg_tys           -- See Note [Infix GADT constructors]+               | isSymOcc (getOccName con)+               , [_ty1,_ty2] <- arg_tys+                  -> do { fix_env <- getFixityEnv+                        ; return (con `elemNameEnv` fix_env) }+               | otherwise -> return False++tcConArgs :: HsConDeclDetails GhcRn+          -> TcM [(TcType, HsSrcBang)]+tcConArgs (PrefixCon btys)+  = mapM tcConArg btys+tcConArgs (InfixCon bty1 bty2)+  = do { bty1' <- tcConArg bty1+       ; bty2' <- tcConArg bty2+       ; return [bty1', bty2'] }+tcConArgs (RecCon fields)+  = mapM tcConArg btys+  where+    -- We need a one-to-one mapping from field_names to btys+    combined = map (\(dL->L _ f) -> (cd_fld_names f,cd_fld_type f))+                   (unLoc fields)+    explode (ns,ty) = zip ns (repeat ty)+    exploded = concatMap explode combined+    (_,btys) = unzip exploded+++tcConArg :: LHsType GhcRn -> TcM (TcType, HsSrcBang)+tcConArg bty+  = do  { traceTc "tcConArg 1" (ppr bty)+        ; arg_ty <- tcHsOpenType (getBangType bty)+             -- Newtypes can't have unboxed types, but we check+             -- that in checkValidDataCon; this tcConArg stuff+             -- doesn't happen for GADT-style declarations+        ; traceTc "tcConArg 2" (ppr bty)+        ; return (arg_ty, getBangStrictness bty) }++{-+Note [Infix GADT constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We do not currently have syntax to declare an infix constructor in GADT syntax,+but it makes a (small) difference to the Show instance.  So as a slightly+ad-hoc solution, we regard a GADT data constructor as infix if+  a) it is an operator symbol+  b) it has two arguments+  c) there is a fixity declaration for it+For example:+   infix 6 (:--:)+   data T a where+     (:--:) :: t1 -> t2 -> T Int+++Note [Checking GADT return types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is a delicacy around checking the return types of a datacon. The+central problem is dealing with a declaration like++  data T a where+    MkT :: T a -> Q a++Note that the return type of MkT is totally bogus. When creating the T+tycon, we also need to create the MkT datacon, which must have a "rejigged"+return type. That is, the MkT datacon's type must be transformed to have+a uniform return type with explicit coercions for GADT-like type parameters.+This rejigging is what rejigConRes does. The problem is, though, that checking+that the return type is appropriate is much easier when done over *Type*,+not *HsType*, and doing a call to tcMatchTy will loop because T isn't fully+defined yet.++So, we want to make rejigConRes lazy and then check the validity of+the return type in checkValidDataCon.  To do this we /always/ return a+6-tuple from rejigConRes (so that we can compute the return type from it, which+checkValidDataCon needs), but the first three fields may be bogus if+the return type isn't valid (the last equation for rejigConRes).++This is better than an earlier solution which reduced the number of+errors reported in one pass.  See #7175, and #10836.+-}++-- Example+--   data instance T (b,c) where+--      TI :: forall e. e -> T (e,e)+--+-- The representation tycon looks like this:+--   data :R7T b c where+--      TI :: forall b1 c1. (b1 ~ c1) => b1 -> :R7T b1 c1+-- In this case orig_res_ty = T (e,e)++rejigConRes :: [KnotTied TyConBinder] -> KnotTied Type    -- Template for result type; e.g.+                                  -- data instance T [a] b c ...+                                  --      gives template ([a,b,c], T [a] b c)+                                  -- Type must be of kind *!+            -> [TyVar]            -- The constructor's inferred type variables+            -> [TyVar]            -- The constructor's user-written, specified+                                  -- type variables+            -> KnotTied Type      -- res_ty type must be of kind *+            -> ([TyVar],          -- Universal+                [TyVar],          -- Existential (distinct OccNames from univs)+                [TyVar],          -- The constructor's rejigged, user-written,+                                  -- inferred type variables+                [TyVar],          -- The constructor's rejigged, user-written,+                                  -- specified type variables+                [EqSpec],      -- Equality predicates+                TCvSubst)      -- Substitution to apply to argument types+        -- We don't check that the TyCon given in the ResTy is+        -- the same as the parent tycon, because checkValidDataCon will do it+-- NB: All arguments may potentially be knot-tied+rejigConRes tmpl_bndrs res_tmpl dc_inferred_tvs dc_specified_tvs res_ty+        -- E.g.  data T [a] b c where+        --         MkT :: forall x y z. T [(x,y)] z z+        -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs+        --     (NB: unlike the H98 case, the dc_tvs are not all existential)+        -- Then we generate+        --      Univ tyvars     Eq-spec+        --          a              a~(x,y)+        --          b              b~z+        --          z+        -- Existentials are the leftover type vars: [x,y]+        -- The user-written type variables are what is listed in the forall:+        --   [x, y, z] (all specified). We must rejig these as well.+        --   See Note [DataCon user type variable binders] in DataCon.+        -- So we return ( [a,b,z], [x,y]+        --              , [], [x,y,z]+        --              , [a~(x,y),b~z], <arg-subst> )+  | Just subst <- ASSERT( isLiftedTypeKind (tcTypeKind res_ty) )+                  ASSERT( isLiftedTypeKind (tcTypeKind res_tmpl) )+                  tcMatchTy res_tmpl res_ty+  = let (univ_tvs, raw_eqs, kind_subst) = mkGADTVars tmpl_tvs dc_tvs subst+        raw_ex_tvs = dc_tvs `minusList` univ_tvs+        (arg_subst, substed_ex_tvs) = substTyVarBndrs kind_subst raw_ex_tvs++        -- After rejigging the existential tyvars, the resulting substitution+        -- gives us exactly what we need to rejig the user-written tyvars,+        -- since the dcUserTyVarBinders invariant guarantees that the+        -- substitution has *all* the tyvars in its domain.+        -- See Note [DataCon user type variable binders] in DataCon.+        subst_user_tvs = map (getTyVar "rejigConRes" . substTyVar arg_subst)+        substed_inferred_tvs  = subst_user_tvs dc_inferred_tvs+        substed_specified_tvs = subst_user_tvs dc_specified_tvs++        substed_eqs = map (substEqSpec arg_subst) raw_eqs+    in+    (univ_tvs, substed_ex_tvs, substed_inferred_tvs, substed_specified_tvs,+     substed_eqs, arg_subst)++  | otherwise+        -- If the return type of the data constructor doesn't match the parent+        -- type constructor, or the arity is wrong, the tcMatchTy will fail+        --    e.g   data T a b where+        --            T1 :: Maybe a   -- Wrong tycon+        --            T2 :: T [a]     -- Wrong arity+        -- We are detect that later, in checkValidDataCon, but meanwhile+        -- we must do *something*, not just crash.  So we do something simple+        -- albeit bogus, relying on checkValidDataCon to check the+        --  bad-result-type error before seeing that the other fields look odd+        -- See Note [Checking GADT return types]+  = (tmpl_tvs, dc_tvs `minusList` tmpl_tvs, dc_inferred_tvs, dc_specified_tvs,+     [], emptyTCvSubst)+  where+    dc_tvs   = dc_inferred_tvs ++ dc_specified_tvs+    tmpl_tvs = binderVars tmpl_bndrs++{- Note [mkGADTVars]+~~~~~~~~~~~~~~~~~~~~+Running example:++data T (k1 :: *) (k2 :: *) (a :: k2) (b :: k2) where+  MkT :: forall (x1 : *) (y :: x1) (z :: *).+         T x1 * (Proxy (y :: x1), z) z++We need the rejigged type to be++  MkT :: forall (x1 :: *) (k2 :: *) (a :: k2) (b :: k2).+         forall (y :: x1) (z :: *).+         (k2 ~ *, a ~ (Proxy x1 y, z), b ~ z)+      => T x1 k2 a b++You might naively expect that z should become a universal tyvar,+not an existential. (After all, x1 becomes a universal tyvar.)+But z has kind * while b has kind k2, so the return type+   T x1 k2 a z+is ill-kinded.  Another way to say it is this: the universal+tyvars must have exactly the same kinds as the tyConTyVars.++So we need an existential tyvar and a heterogeneous equality+constraint. (The b ~ z is a bit redundant with the k2 ~ * that+comes before in that b ~ z implies k2 ~ *. I'm sure we could do+some analysis that could eliminate k2 ~ *. But we don't do this+yet.)++The data con signature has already been fully kind-checked.+The return type++  T x1 * (Proxy (y :: x1), z) z+becomes+  qtkvs    = [x1 :: *, y :: x1, z :: *]+  res_tmpl = T x1 * (Proxy x1 y, z) z++We start off by matching (T k1 k2 a b) with (T x1 * (Proxy x1 y, z) z). We+know this match will succeed because of the validity check (actually done+later, but laziness saves us -- see Note [Checking GADT return types]).+Thus, we get++  subst := { k1 |-> x1, k2 |-> *, a |-> (Proxy x1 y, z), b |-> z }++Now, we need to figure out what the GADT equalities should be. In this case,+we *don't* want (k1 ~ x1) to be a GADT equality: it should just be a+renaming. The others should be GADT equalities. We also need to make+sure that the universally-quantified variables of the datacon match up+with the tyvars of the tycon, as required for Core context well-formedness.+(This last bit is why we have to rejig at all!)++`choose` walks down the tycon tyvars, figuring out what to do with each one.+It carries two substitutions:+  - t_sub's domain is *template* or *tycon* tyvars, mapping them to variables+    mentioned in the datacon signature.+  - r_sub's domain is *result* tyvars, names written by the programmer in+    the datacon signature. The final rejigged type will use these names, but+    the subst is still needed because sometimes the printed name of these variables+    is different. (See choose_tv_name, below.)++Before explaining the details of `choose`, let's just look at its operation+on our example:++  choose [] [] {} {} [k1, k2, a, b]+  -->          -- first branch of `case` statement+  choose+    univs:    [x1 :: *]+    eq_spec:  []+    t_sub:    {k1 |-> x1}+    r_sub:    {x1 |-> x1}+    t_tvs:    [k2, a, b]+  -->          -- second branch of `case` statement+  choose+    univs:    [k2 :: *, x1 :: *]+    eq_spec:  [k2 ~ *]+    t_sub:    {k1 |-> x1, k2 |-> k2}+    r_sub:    {x1 |-> x1}+    t_tvs:    [a, b]+  -->          -- second branch of `case` statement+  choose+    univs:    [a :: k2, k2 :: *, x1 :: *]+    eq_spec:  [ a ~ (Proxy x1 y, z)+              , k2 ~ * ]+    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a}+    r_sub:    {x1 |-> x1}+    t_tvs:    [b]+  -->          -- second branch of `case` statement+  choose+    univs:    [b :: k2, a :: k2, k2 :: *, x1 :: *]+    eq_spec:  [ b ~ z+              , a ~ (Proxy x1 y, z)+              , k2 ~ * ]+    t_sub:    {k1 |-> x1, k2 |-> k2, a |-> a, b |-> z}+    r_sub:    {x1 |-> x1}+    t_tvs:    []+  -->          -- end of recursion+  ( [x1 :: *, k2 :: *, a :: k2, b :: k2]+  , [k2 ~ *, a ~ (Proxy x1 y, z), b ~ z]+  , {x1 |-> x1} )++`choose` looks up each tycon tyvar in the matching (it *must* be matched!).++* If it finds a bare result tyvar (the first branch of the `case`+  statement), it checks to make sure that the result tyvar isn't yet+  in the list of univ_tvs.  If it is in that list, then we have a+  repeated variable in the return type, and we in fact need a GADT+  equality.++* It then checks to make sure that the kind of the result tyvar+  matches the kind of the template tyvar. This check is what forces+  `z` to be existential, as it should be, explained above.++* Assuming no repeated variables or kind-changing, we wish to use the+  variable name given in the datacon signature (that is, `x1` not+  `k1`), not the tycon signature (which may have been made up by+  GHC). So, we add a mapping from the tycon tyvar to the result tyvar+  to t_sub.++* If we discover that a mapping in `subst` gives us a non-tyvar (the+  second branch of the `case` statement), then we have a GADT equality+  to create.  We create a fresh equality, but we don't extend any+  substitutions. The template variable substitution is meant for use+  in universal tyvar kinds, and these shouldn't be affected by any+  GADT equalities.++This whole algorithm is quite delicate, indeed. I (Richard E.) see two ways+of simplifying it:++1) The first branch of the `case` statement is really an optimization, used+in order to get fewer GADT equalities. It might be possible to make a GADT+equality for *every* univ. tyvar, even if the equality is trivial, and then+either deal with the bigger type or somehow reduce it later.++2) This algorithm strives to use the names for type variables as specified+by the user in the datacon signature. If we always used the tycon tyvar+names, for example, this would be simplified. This change would almost+certainly degrade error messages a bit, though.+-}++-- ^ From information about a source datacon definition, extract out+-- what the universal variables and the GADT equalities should be.+-- See Note [mkGADTVars].+mkGADTVars :: [TyVar]    -- ^ The tycon vars+           -> [TyVar]    -- ^ The datacon vars+           -> TCvSubst   -- ^ The matching between the template result type+                         -- and the actual result type+           -> ( [TyVar]+              , [EqSpec]+              , TCvSubst ) -- ^ The univ. variables, the GADT equalities,+                           -- and a subst to apply to the GADT equalities+                           -- and existentials.+mkGADTVars tmpl_tvs dc_tvs subst+  = choose [] [] empty_subst empty_subst tmpl_tvs+  where+    in_scope = mkInScopeSet (mkVarSet tmpl_tvs `unionVarSet` mkVarSet dc_tvs)+               `unionInScope` getTCvInScope subst+    empty_subst = mkEmptyTCvSubst in_scope++    choose :: [TyVar]           -- accumulator of univ tvs, reversed+           -> [EqSpec]          -- accumulator of GADT equalities, reversed+           -> TCvSubst          -- template substitution+           -> TCvSubst          -- res. substitution+           -> [TyVar]           -- template tvs (the univ tvs passed in)+           -> ( [TyVar]         -- the univ_tvs+              , [EqSpec]        -- GADT equalities+              , TCvSubst )       -- a substitution to fix kinds in ex_tvs++    choose univs eqs _t_sub r_sub []+      = (reverse univs, reverse eqs, r_sub)+    choose univs eqs t_sub r_sub (t_tv:t_tvs)+      | Just r_ty <- lookupTyVar subst t_tv+      = case getTyVar_maybe r_ty of+          Just r_tv+            |  not (r_tv `elem` univs)+            ,  tyVarKind r_tv `eqType` (substTy t_sub (tyVarKind t_tv))+            -> -- simple, well-kinded variable substitution.+               choose (r_tv:univs) eqs+                      (extendTvSubst t_sub t_tv r_ty')+                      (extendTvSubst r_sub r_tv r_ty')+                      t_tvs+            where+              r_tv1  = setTyVarName r_tv (choose_tv_name r_tv t_tv)+              r_ty'  = mkTyVarTy r_tv1++               -- Not a simple substitution: make an equality predicate+          _ -> choose (t_tv':univs) (mkEqSpec t_tv' r_ty : eqs)+                      (extendTvSubst t_sub t_tv (mkTyVarTy t_tv'))+                         -- We've updated the kind of t_tv,+                         -- so add it to t_sub (#14162)+                      r_sub t_tvs+            where+              t_tv' = updateTyVarKind (substTy t_sub) t_tv++      | otherwise+      = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst)++      -- choose an appropriate name for a univ tyvar.+      -- This *must* preserve the Unique of the result tv, so that we+      -- can detect repeated variables. It prefers user-specified names+      -- over system names. A result variable with a system name can+      -- happen with GHC-generated implicit kind variables.+    choose_tv_name :: TyVar -> TyVar -> Name+    choose_tv_name r_tv t_tv+      | isSystemName r_tv_name+      = setNameUnique t_tv_name (getUnique r_tv_name)++      | otherwise+      = r_tv_name++      where+        r_tv_name = getName r_tv+        t_tv_name = getName t_tv++{-+Note [Substitution in template variables kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++data G (a :: Maybe k) where+  MkG :: G Nothing++With explicit kind variables++data G k (a :: Maybe k) where+  MkG :: G k1 (Nothing k1)++Note how k1 is distinct from k. So, when we match the template+`G k a` against `G k1 (Nothing k1)`, we get a subst+[ k |-> k1, a |-> Nothing k1 ]. Even though this subst has two+mappings, we surely don't want to add (k, k1) to the list of+GADT equalities -- that would be overly complex and would create+more untouchable variables than we need. So, when figuring out+which tyvars are GADT-like and which aren't (the fundamental+job of `choose`), we want to treat `k` as *not* GADT-like.+Instead, we wish to substitute in `a`'s kind, to get (a :: Maybe k1)+instead of (a :: Maybe k). This is the reason for dealing+with a substitution in here.++However, we do not *always* want to substitute. Consider++data H (a :: k) where+  MkH :: H Int++With explicit kind variables:++data H k (a :: k) where+  MkH :: H * Int++Here, we have a kind-indexed GADT. The subst in question is+[ k |-> *, a |-> Int ]. Now, we *don't* want to substitute in `a`'s+kind, because that would give a constructor with the type++MkH :: forall (k :: *) (a :: *). (k ~ *) -> (a ~ Int) -> H k a++The problem here is that a's kind is wrong -- it needs to be k, not *!+So, if the matching for a variable is anything but another bare variable,+we drop the mapping from the substitution before proceeding. This+was not an issue before kind-indexed GADTs because this case could+never happen.++************************************************************************+*                                                                      *+                Validity checking+*                                                                      *+************************************************************************++Validity checking is done once the mutually-recursive knot has been+tied, so we can look at things freely.+-}++checkValidTyCl :: TyCon -> TcM [TyCon]+-- The returned list is either a singleton (if valid)+-- or a list of "fake tycons" (if not); the fake tycons+-- include any implicits, like promoted data constructors+-- See Note [Recover from validity error]+checkValidTyCl tc+  = setSrcSpan (getSrcSpan tc) $+    addTyConCtxt tc            $+    recoverM recovery_code     $+    do { traceTc "Starting validity for tycon" (ppr tc)+       ; checkValidTyCon tc+       ; traceTc "Done validity for tycon" (ppr tc)+       ; return [tc] }+  where+    recovery_code -- See Note [Recover from validity error]+      = do { traceTc "Aborted validity for tycon" (ppr tc)+           ; return (concatMap mk_fake_tc $+                     ATyCon tc : implicitTyConThings tc) }++    mk_fake_tc (ATyCon tc)+      | isClassTyCon tc = [tc]   -- Ugh! Note [Recover from validity error]+      | otherwise       = [makeRecoveryTyCon tc]+    mk_fake_tc (AConLike (RealDataCon dc))+                        = [makeRecoveryTyCon (promoteDataCon dc)]+    mk_fake_tc _        = []++{- Note [Recover from validity error]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We recover from a validity error in a type or class, which allows us+to report multiple validity errors. In the failure case we return a+TyCon of the right kind, but with no interesting behaviour+(makeRecoveryTyCon). Why?  Suppose we have+   type T a = Fun+where Fun is a type family of arity 1.  The RHS is invalid, but we+want to go on checking validity of subsequent type declarations.+So we replace T with an abstract TyCon which will do no harm.+See indexed-types/should_fail/BadSock and #10896++Some notes:++* We must make fakes for promoted DataCons too. Consider (#15215)+      data T a = MkT ...+      data S a = ...T...MkT....+  If there is an error in the definition of 'T' we add a "fake type+  constructor" to the type environment, so that we can continue to+  typecheck 'S'.  But we /were not/ adding a fake anything for 'MkT'+  and so there was an internal error when we met 'MkT' in the body of+  'S'.++* Painfully, we *don't* want to do this for classes.+  Consider tcfail041:+     class (?x::Int) => C a where ...+     instance C Int+  The class is invalid because of the superclass constraint.  But+  we still want it to look like a /class/, else the instance bleats+  that the instance is mal-formed because it hasn't got a class in+  the head.++  This is really bogus; now we have in scope a Class that is invalid+  in some way, with unknown downstream consequences.  A better+  alterantive might be to make a fake class TyCon.  A job for another day.+-}++-------------------------+-- For data types declared with record syntax, we require+-- that each constructor that has a field 'f'+--      (a) has the same result type+--      (b) has the same type for 'f'+-- module alpha conversion of the quantified type variables+-- of the constructor.+--+-- Note that we allow existentials to match because the+-- fields can never meet. E.g+--      data T where+--        T1 { f1 :: b, f2 :: a, f3 ::Int } :: T+--        T2 { f1 :: c, f2 :: c, f3 ::Int } :: T+-- Here we do not complain about f1,f2 because they are existential++checkValidTyCon :: TyCon -> TcM ()+checkValidTyCon tc+  | isPrimTyCon tc   -- Happens when Haddock'ing GHC.Prim+  = return ()++  | otherwise+  = do { traceTc "checkValidTyCon" (ppr tc $$ ppr (tyConClass_maybe tc))+       ; if | Just cl <- tyConClass_maybe tc+              -> checkValidClass cl++            | Just syn_rhs <- synTyConRhs_maybe tc+              -> do { checkValidType syn_ctxt syn_rhs+                    ; checkTySynRhs syn_ctxt syn_rhs }++            | Just fam_flav <- famTyConFlav_maybe tc+              -> case fam_flav of+               { ClosedSynFamilyTyCon (Just ax)+                   -> tcAddClosedTypeFamilyDeclCtxt tc $+                      checkValidCoAxiom ax+               ; ClosedSynFamilyTyCon Nothing   -> return ()+               ; AbstractClosedSynFamilyTyCon ->+                 do { hsBoot <- tcIsHsBootOrSig+                    ; checkTc hsBoot $+                      text "You may define an abstract closed type family" $$+                      text "only in a .hs-boot file" }+               ; DataFamilyTyCon {}           -> return ()+               ; OpenSynFamilyTyCon           -> return ()+               ; BuiltInSynFamTyCon _         -> return () }++             | otherwise -> do+               { -- Check the context on the data decl+                 traceTc "cvtc1" (ppr tc)+               ; checkValidTheta (DataTyCtxt name) (tyConStupidTheta tc)++               ; traceTc "cvtc2" (ppr tc)++               ; dflags          <- getDynFlags+               ; existential_ok  <- xoptM LangExt.ExistentialQuantification+               ; gadt_ok         <- xoptM LangExt.GADTs+               ; let ex_ok = existential_ok || gadt_ok+                     -- Data cons can have existential context+               ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons+               ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc)++                -- Check that fields with the same name share a type+               ; mapM_ check_fields groups }}+  where+    syn_ctxt  = TySynCtxt name+    name      = tyConName tc+    data_cons = tyConDataCons tc++    groups = equivClasses cmp_fld (concatMap get_fields data_cons)+    cmp_fld (f1,_) (f2,_) = flLabel f1 `compare` flLabel f2+    get_fields con = dataConFieldLabels con `zip` repeat con+        -- dataConFieldLabels may return the empty list, which is fine++    -- See Note [GADT record selectors] in TcTyDecls+    -- We must check (a) that the named field has the same+    --                   type in each constructor+    --               (b) that those constructors have the same result type+    --+    -- However, the constructors may have differently named type variable+    -- and (worse) we don't know how the correspond to each other.  E.g.+    --     C1 :: forall a b. { f :: a, g :: b } -> T a b+    --     C2 :: forall d c. { f :: c, g :: c } -> T c d+    --+    -- So what we do is to ust Unify.tcMatchTys to compare the first candidate's+    -- result type against other candidates' types BOTH WAYS ROUND.+    -- If they magically agrees, take the substitution and+    -- apply them to the latter ones, and see if they match perfectly.+    check_fields ((label, con1) :| other_fields)+        -- These fields all have the same name, but are from+        -- different constructors in the data type+        = recoverM (return ()) $ mapM_ checkOne other_fields+                -- Check that all the fields in the group have the same type+                -- NB: this check assumes that all the constructors of a given+                -- data type use the same type variables+        where+        (_, _, _, res1) = dataConSig con1+        fty1 = dataConFieldType con1 lbl+        lbl = flLabel label++        checkOne (_, con2)    -- Do it both ways to ensure they are structurally identical+            = do { checkFieldCompat lbl con1 con2 res1 res2 fty1 fty2+                 ; checkFieldCompat lbl con2 con1 res2 res1 fty2 fty1 }+            where+                (_, _, _, res2) = dataConSig con2+                fty2 = dataConFieldType con2 lbl++checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM ()+-- Checks the partial record field selector, and warns.+-- See Note [Checking partial record field]+checkPartialRecordField all_cons fld+  = setSrcSpan loc $+      warnIfFlag Opt_WarnPartialFields+        (not is_exhaustive && not (startsWithUnderscore occ_name))+        (sep [text "Use of partial record field selector" <> colon,+              nest 2 $ quotes (ppr occ_name)])+  where+    sel_name = flSelector fld+    loc    = getSrcSpan sel_name+    occ_name = getOccName sel_name++    (cons_with_field, cons_without_field) = partition has_field all_cons+    has_field con = fld `elem` (dataConFieldLabels con)+    is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field++    con1 = ASSERT( not (null cons_with_field) ) head cons_with_field+    (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1+    eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)+    inst_tys = substTyVars eq_subst univ_tvs++checkFieldCompat :: FieldLabelString -> DataCon -> DataCon+                 -> Type -> Type -> Type -> Type -> TcM ()+checkFieldCompat fld con1 con2 res1 res2 fty1 fty2+  = do  { checkTc (isJust mb_subst1) (resultTypeMisMatch fld con1 con2)+        ; checkTc (isJust mb_subst2) (fieldTypeMisMatch fld con1 con2) }+  where+    mb_subst1 = tcMatchTy res1 res2+    mb_subst2 = tcMatchTyX (expectJust "checkFieldCompat" mb_subst1) fty1 fty2++-------------------------------+checkValidDataCon :: DynFlags -> Bool -> TyCon -> DataCon -> TcM ()+checkValidDataCon dflags existential_ok tc con+  = setSrcSpan (getSrcSpan con)  $+    addErrCtxt (dataConCtxt con) $+    do  { -- Check that the return type of the data constructor+          -- matches the type constructor; eg reject this:+          --   data T a where { MkT :: Bogus a }+          -- It's important to do this first:+          --  see Note [Checking GADT return types]+          --  and c.f. Note [Check role annotations in a second pass]+          let tc_tvs      = tyConTyVars tc+              res_ty_tmpl = mkFamilyTyConApp tc (mkTyVarTys tc_tvs)+              orig_res_ty = dataConOrigResTy con+        ; traceTc "checkValidDataCon" (vcat+              [ ppr con, ppr tc, ppr tc_tvs+              , ppr res_ty_tmpl <+> dcolon <+> ppr (tcTypeKind res_ty_tmpl)+              , ppr orig_res_ty <+> dcolon <+> ppr (tcTypeKind orig_res_ty)])+++        ; checkTc (isJust (tcMatchTy res_ty_tmpl orig_res_ty))+                  (badDataConTyCon con res_ty_tmpl)+            -- Note that checkTc aborts if it finds an error. This is+            -- critical to avoid panicking when we call dataConUserType+            -- on an un-rejiggable datacon!++        ; traceTc "checkValidDataCon 2" (ppr (dataConUserType con))++          -- Check that the result type is a *monotype*+          --  e.g. reject this:   MkT :: T (forall a. a->a)+          -- Reason: it's really the argument of an equality constraint+        ; checkValidMonoType orig_res_ty++          -- Check all argument types for validity+        ; checkValidType ctxt (dataConUserType con)+        ; mapM_ (checkForLevPoly empty)+                (dataConOrigArgTys con)++          -- Extra checks for newtype data constructors+        ; when (isNewTyCon tc) (checkNewDataCon con)++          -- Check that existentials are allowed if they are used+        ; checkTc (existential_ok || isVanillaDataCon con)+                  (badExistential con)++          -- Check that UNPACK pragmas and bangs work out+          -- E.g.  reject   data T = MkT {-# UNPACK #-} Int     -- No "!"+          --                data T = MkT {-# UNPACK #-} !a      -- Can't unpack+        ; zipWith3M_ check_bang (dataConSrcBangs con) (dataConImplBangs con) [1..]++          -- Check the dcUserTyVarBinders invariant+          -- See Note [DataCon user type variable binders] in DataCon+          -- checked here because we sometimes build invalid DataCons before+          -- erroring above here+        ; when debugIsOn $+          do { let (univs, exs, eq_spec, _, _, _) = dataConFullSig con+                   user_tvs                       = dataConUserTyVars con+                   user_tvbs_invariant+                     =    Set.fromList (filterEqSpec eq_spec univs ++ exs)+                       == Set.fromList user_tvs+             ; WARN( not user_tvbs_invariant+                       , vcat ([ ppr con+                               , ppr univs+                               , ppr exs+                               , ppr eq_spec+                               , ppr user_tvs ])) return () }++        ; traceTc "Done validity of data con" $+          vcat [ ppr con+               , text "Datacon user type:" <+> ppr (dataConUserType con)+               , text "Datacon rep type:" <+> ppr (dataConRepType con)+               , text "Rep typcon binders:" <+> ppr (tyConBinders (dataConTyCon con))+               , case tyConFamInst_maybe (dataConTyCon con) of+                   Nothing -> text "not family"+                   Just (f, _) -> ppr (tyConBinders f) ]+    }+  where+    ctxt = ConArgCtxt (dataConName con)++    check_bang :: HsSrcBang -> HsImplBang -> Int -> TcM ()+    check_bang (HsSrcBang _ _ SrcLazy) _ n+      | not (xopt LangExt.StrictData dflags)+      = addErrTc+          (bad_bang n (text "Lazy annotation (~) without StrictData"))+    check_bang (HsSrcBang _ want_unpack strict_mark) rep_bang n+      | isSrcUnpacked want_unpack, not is_strict+      = addWarnTc NoReason (bad_bang n (text "UNPACK pragma lacks '!'"))+      | isSrcUnpacked want_unpack+      , case rep_bang of { HsUnpack {} -> False; _ -> True }+      -- If not optimising, we don't unpack (rep_bang is never+      -- HsUnpack), so don't complain!  This happens, e.g., in Haddock.+      -- See dataConSrcToImplBang.+      , not (gopt Opt_OmitInterfacePragmas dflags)+      -- When typechecking an indefinite package in Backpack, we+      -- may attempt to UNPACK an abstract type.  The test here will+      -- conclude that this is unusable, but it might become usable+      -- when we actually fill in the abstract type.  As such, don't+      -- warn in this case (it gives users the wrong idea about whether+      -- or not UNPACK on abstract types is supported; it is!)+      , unitIdIsDefinite (thisPackage dflags)+      = addWarnTc NoReason (bad_bang n (text "Ignoring unusable UNPACK pragma"))+      where+        is_strict = case strict_mark of+                      NoSrcStrict -> xopt LangExt.StrictData dflags+                      bang        -> isSrcStrict bang++    check_bang _ _ _+      = return ()++    bad_bang n herald+      = hang herald 2 (text "on the" <+> speakNth n+                       <+> text "argument of" <+> quotes (ppr con))+-------------------------------+checkNewDataCon :: DataCon -> TcM ()+-- Further checks for the data constructor of a newtype+checkNewDataCon con+  = do  { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))+              -- One argument++        ; checkTc (not (isUnliftedType arg_ty1)) $+          text "A newtype cannot have an unlifted argument type"++        ; check_con (null eq_spec) $+          text "A newtype constructor must have a return type of form T a1 ... an"+                -- Return type is (T a b c)++        ; check_con (null theta) $+          text "A newtype constructor cannot have a context in its type"++        ; check_con (null ex_tvs) $+          text "A newtype constructor cannot have existential type variables"+                -- No existentials++        ; checkTc (all ok_bang (dataConSrcBangs con))+                  (newtypeStrictError con)+                -- No strictness annotations+    }+  where+    (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)+      = dataConFullSig con+    check_con what msg+       = checkTc what (msg $$ ppr con <+> dcolon <+> ppr (dataConUserType con))++    (arg_ty1 : _) = arg_tys++    ok_bang (HsSrcBang _ _ SrcStrict) = False+    ok_bang (HsSrcBang _ _ SrcLazy)   = False+    ok_bang _                         = True++-------------------------------+checkValidClass :: Class -> TcM ()+checkValidClass cls+  = do  { constrained_class_methods <- xoptM LangExt.ConstrainedClassMethods+        ; multi_param_type_classes  <- xoptM LangExt.MultiParamTypeClasses+        ; nullary_type_classes      <- xoptM LangExt.NullaryTypeClasses+        ; fundep_classes            <- xoptM LangExt.FunctionalDependencies+        ; undecidable_super_classes <- xoptM LangExt.UndecidableSuperClasses++        -- Check that the class is unary, unless multiparameter type classes+        -- are enabled; also recognize deprecated nullary type classes+        -- extension (subsumed by multiparameter type classes, #8993)+        ; checkTc (multi_param_type_classes || cls_arity == 1 ||+                    (nullary_type_classes && cls_arity == 0))+                  (classArityErr cls_arity cls)+        ; checkTc (fundep_classes || null fundeps) (classFunDepsErr cls)++        -- Check the super-classes+        ; checkValidTheta (ClassSCCtxt (className cls)) theta++          -- Now check for cyclic superclasses+          -- If there are superclass cycles, checkClassCycleErrs bails.+        ; unless undecidable_super_classes $+          case checkClassCycles cls of+             Just err -> setSrcSpan (getSrcSpan cls) $+                         addErrTc err+             Nothing  -> return ()++        -- Check the class operations.+        -- But only if there have been no earlier errors+        -- See Note [Abort when superclass cycle is detected]+        ; whenNoErrs $+          mapM_ (check_op constrained_class_methods) op_stuff++        -- Check the associated type defaults are well-formed and instantiated+        ; mapM_ check_at at_stuff  }+  where+    (tyvars, fundeps, theta, _, at_stuff, op_stuff) = classExtraBigSig cls+    cls_arity = length (tyConVisibleTyVars (classTyCon cls))+       -- Ignore invisible variables+    cls_tv_set = mkVarSet tyvars++    check_op constrained_class_methods (sel_id, dm)+      = setSrcSpan (getSrcSpan sel_id) $+        addErrCtxt (classOpCtxt sel_id op_ty) $ do+        { traceTc "class op type" (ppr op_ty)+        ; checkValidType ctxt op_ty+                -- This implements the ambiguity check, among other things+                -- Example: tc223+                --   class Error e => Game b mv e | b -> mv e where+                --      newBoard :: MonadState b m => m ()+                -- Here, MonadState has a fundep m->b, so newBoard is fine++           -- a method cannot be levity polymorphic, as we have to store the+           -- method in a dictionary+           -- example of what this prevents:+           --   class BoundedX (a :: TYPE r) where minBound :: a+           -- See Note [Levity polymorphism checking] in DsMonad+        ; checkForLevPoly empty tau1++        ; unless constrained_class_methods $+          mapM_ check_constraint (tail (cls_pred:op_theta))++        ; check_dm ctxt sel_id cls_pred tau2 dm+        }+        where+          ctxt    = FunSigCtxt op_name True -- Report redundant class constraints+          op_name = idName sel_id+          op_ty   = idType sel_id+          (_,cls_pred,tau1) = tcSplitMethodTy op_ty+          -- See Note [Splitting nested sigma types in class type signatures]+          (_,op_theta,tau2) = tcSplitNestedSigmaTys tau1++          check_constraint :: TcPredType -> TcM ()+          check_constraint pred -- See Note [Class method constraints]+            = when (not (isEmptyVarSet pred_tvs) &&+                    pred_tvs `subVarSet` cls_tv_set)+                   (addErrTc (badMethPred sel_id pred))+            where+              pred_tvs = tyCoVarsOfType pred++    check_at (ATI fam_tc m_dflt_rhs)+      = do { checkTc (cls_arity == 0 || any (`elemVarSet` cls_tv_set) fam_tvs)+                     (noClassTyVarErr cls fam_tc)+                        -- Check that the associated type mentions at least+                        -- one of the class type variables+                        -- The check is disabled for nullary type classes,+                        -- since there is no possible ambiguity (#10020)++             -- Check that any default declarations for associated types are valid+           ; whenIsJust m_dflt_rhs $ \ (rhs, loc) ->+             setSrcSpan loc $+             tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $+             checkValidTyFamEqn fam_tc fam_tvs (mkTyVarTys fam_tvs) rhs }+        where+          fam_tvs = tyConTyVars fam_tc++    check_dm :: UserTypeCtxt -> Id -> PredType -> Type -> DefMethInfo -> TcM ()+    -- Check validity of the /top-level/ generic-default type+    -- E.g for   class C a where+    --             default op :: forall b. (a~b) => blah+    -- we do not want to do an ambiguity check on a type with+    -- a free TyVar 'a' (#11608).  See TcType+    -- Note [TyVars and TcTyVars during type checking] in TcType+    -- Hence the mkDefaultMethodType to close the type.+    check_dm ctxt sel_id vanilla_cls_pred vanilla_tau+             (Just (dm_name, dm_spec@(GenericDM dm_ty)))+      = setSrcSpan (getSrcSpan dm_name) $ do+            -- We have carefully set the SrcSpan on the generic+            -- default-method Name to be that of the generic+            -- default type signature++          -- First, we check that that the method's default type signature+          -- aligns with the non-default type signature.+          -- See Note [Default method type signatures must align]+          let cls_pred = mkClassPred cls $ mkTyVarTys $ classTyVars cls+              -- Note that the second field of this tuple contains the context+              -- of the default type signature, making it apparent that we+              -- ignore method contexts completely when validity-checking+              -- default type signatures. See the end of+              -- Note [Default method type signatures must align]+              -- to learn why this is OK.+              --+              -- See also+              -- Note [Splitting nested sigma types in class type signatures]+              -- for an explanation of why we don't use tcSplitSigmaTy here.+              (_, _, dm_tau) = tcSplitNestedSigmaTys dm_ty++              -- Given this class definition:+              --+              --  class C a b where+              --    op         :: forall p q. (Ord a, D p q)+              --               => a -> b -> p -> (a, b)+              --    default op :: forall r s. E r+              --               => a -> b -> s -> (a, b)+              --+              -- We want to match up two types of the form:+              --+              --   Vanilla type sig: C aa bb => aa -> bb -> p -> (aa, bb)+              --   Default type sig: C a  b  => a  -> b  -> s -> (a,  b)+              --+              -- Notice that the two type signatures can be quantified over+              -- different class type variables! Therefore, it's important that+              -- we include the class predicate parts to match up a with aa and+              -- b with bb.+              vanilla_phi_ty = mkPhiTy [vanilla_cls_pred] vanilla_tau+              dm_phi_ty      = mkPhiTy [cls_pred] dm_tau++          traceTc "check_dm" $ vcat+              [ text "vanilla_phi_ty" <+> ppr vanilla_phi_ty+              , text "dm_phi_ty"      <+> ppr dm_phi_ty ]++          -- Actually checking that the types align is done with a call to+          -- tcMatchTys. We need to get a match in both directions to rule+          -- out degenerate cases like these:+          --+          --  class Foo a where+          --    foo1         :: a -> b+          --    default foo1 :: a -> Int+          --+          --    foo2         :: a -> Int+          --    default foo2 :: a -> b+          unless (isJust $ tcMatchTys [dm_phi_ty, vanilla_phi_ty]+                                      [vanilla_phi_ty, dm_phi_ty]) $ addErrTc $+               hang (text "The default type signature for"+                     <+> ppr sel_id <> colon)+                 2 (ppr dm_ty)+            $$ (text "does not match its corresponding"+                <+> text "non-default type signature")++          -- Now do an ambiguity check on the default type signature.+          checkValidType ctxt (mkDefaultMethodType cls sel_id dm_spec)+    check_dm _ _ _ _ _ = return ()++checkFamFlag :: Name -> TcM ()+-- Check that we don't use families without -XTypeFamilies+-- The parser won't even parse them, but I suppose a GHC API+-- client might have a go!+checkFamFlag tc_name+  = do { idx_tys <- xoptM LangExt.TypeFamilies+       ; checkTc idx_tys err_msg }+  where+    err_msg = hang (text "Illegal family declaration for" <+> quotes (ppr tc_name))+                 2 (text "Enable TypeFamilies to allow indexed type families")++{- Note [Class method constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Haskell 2010 is supposed to reject+  class C a where+    op :: Eq a => a -> a+where the method type constrains only the class variable(s).  (The extension+-XConstrainedClassMethods switches off this check.)  But regardless+we should not reject+  class C a where+    op :: (?x::Int) => a -> a+as pointed out in #11793. So the test here rejects the program if+  * -XConstrainedClassMethods is off+  * the tyvars of the constraint are non-empty+  * all the tyvars are class tyvars, none are locally quantified++Note [Abort when superclass cycle is detected]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must avoid doing the ambiguity check for the methods (in+checkValidClass.check_op) when there are already errors accumulated.+This is because one of the errors may be a superclass cycle, and+superclass cycles cause canonicalization to loop. Here is a+representative example:++  class D a => C a where+    meth :: D a => ()+  class C a => D a++This fixes #9415, #9739++Note [Default method type signatures must align]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC enforces the invariant that a class method's default type signature+must "align" with that of the method's non-default type signature, as per+GHC #12918. For instance, if you have:++  class Foo a where+    bar :: forall b. Context => a -> b++Then a default type signature for bar must be alpha equivalent to+(forall b. a -> b). That is, the types must be the same modulo differences in+contexts. So the following would be acceptable default type signatures:++    default bar :: forall b. Context1 => a -> b+    default bar :: forall x. Context2 => a -> x++But the following are NOT acceptable default type signatures:++    default bar :: forall b. b -> a+    default bar :: forall x. x+    default bar :: a -> Int++Note that a is bound by the class declaration for Foo itself, so it is+not allowed to differ in the default type signature.++The default type signature (default bar :: a -> Int) deserves special mention,+since (a -> Int) is a straightforward instantiation of (forall b. a -> b). To+write this, you need to declare the default type signature like so:++    default bar :: forall b. (b ~ Int). a -> b++As noted in #12918, there are several reasons to do this:++1. It would make no sense to have a type that was flat-out incompatible with+   the non-default type signature. For instance, if you had:++     class Foo a where+       bar :: a -> Int+       default bar :: a -> Bool++   Then that would always fail in an instance declaration. So this check+   nips such cases in the bud before they have the chance to produce+   confusing error messages.++2. Internally, GHC uses TypeApplications to instantiate the default method in+   an instance. See Note [Default methods in instances] in TcInstDcls.+   Thus, GHC needs to know exactly what the universally quantified type+   variables are, and when instantiated that way, the default method's type+   must match the expected type.++3. Aesthetically, by only allowing the default type signature to differ in its+   context, we are making it more explicit the ways in which the default type+   signature is less polymorphic than the non-default type signature.++You might be wondering: why are the contexts allowed to be different, but not+the rest of the type signature? That's because default implementations often+rely on assumptions that the more general, non-default type signatures do not.+For instance, in the Enum class declaration:++    class Enum a where+      enum :: [a]+      default enum :: (Generic a, GEnum (Rep a)) => [a]+      enum = map to genum++    class GEnum f where+      genum :: [f a]++The default implementation for enum only works for types that are instances of+Generic, and for which their generic Rep type is an instance of GEnum. But+clearly enum doesn't _have_ to use this implementation, so naturally, the+context for enum is allowed to be different to accomodate this. As a result,+when we validity-check default type signatures, we ignore contexts completely.++Note that when checking whether two type signatures match, we must take care to+split as many foralls as it takes to retrieve the tau types we which to check.+See Note [Splitting nested sigma types in class type signatures].++Note [Splitting nested sigma types in class type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this type synonym and class definition:++  type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t++  class Each s t a b where+    each         ::                                      Traversal s t a b+    default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b++It might seem obvious that the tau types in both type signatures for `each`+are the same, but actually getting GHC to conclude this is surprisingly tricky.+That is because in general, the form of a class method's non-default type+signature is:++  forall a. C a => forall d. D d => E a b++And the general form of a default type signature is:++  forall f. F f => E a f -- The variable `a` comes from the class++So it you want to get the tau types in each type signature, you might find it+reasonable to call tcSplitSigmaTy twice on the non-default type signature, and+call it once on the default type signature. For most classes and methods, this+will work, but Each is a bit of an exceptional case. The way `each` is written,+it doesn't quantify any additional type variables besides those of the Each+class itself, so the non-default type signature for `each` is actually this:++  forall s t a b. Each s t a b => Traversal s t a b++Notice that there _appears_ to only be one forall. But there's actually another+forall lurking in the Traversal type synonym, so if you call tcSplitSigmaTy+twice, you'll also go under the forall in Traversal! That is, you'll end up+with:++  (a -> f b) -> s -> f t++A problem arises because you only call tcSplitSigmaTy once on the default type+signature for `each`, which gives you++  Traversal s t a b++Or, equivalently:++  forall f. Applicative f => (a -> f b) -> s -> f t++This is _not_ the same thing as (a -> f b) -> s -> f t! So now tcMatchTy will+say that the tau types for `each` are not equal.++A solution to this problem is to use tcSplitNestedSigmaTys instead of+tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it+sees until it can't go any further, so if you called it on the default type+signature for `each`, it would return (a -> f b) -> s -> f t like we desired.++Note [Checking partial record field]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This check checks the partial record field selector, and warns (#7169).++For example:++  data T a = A { m1 :: a, m2 :: a } | B { m1 :: a }++The function 'm2' is partial record field, and will fail when it is applied to+'B'. The warning identifies such partial fields. The check is performed at the+declaration of T, not at the call-sites of m2.++The warning can be suppressed by prefixing the field-name with an underscore.+For example:++  data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a }++************************************************************************+*                                                                      *+                Checking role validity+*                                                                      *+************************************************************************+-}++checkValidRoleAnnots :: RoleAnnotEnv -> TyCon -> TcM ()+checkValidRoleAnnots role_annots tc+  | isTypeSynonymTyCon tc = check_no_roles+  | isFamilyTyCon tc      = check_no_roles+  | isAlgTyCon tc         = check_roles+  | otherwise             = return ()+  where+    -- Role annotations are given only on *explicit* variables,+    -- but a tycon stores roles for all variables.+    -- So, we drop the implicit roles (which are all Nominal, anyway).+    name                   = tyConName tc+    roles                  = tyConRoles tc+    (vis_roles, vis_vars)  = unzip $ mapMaybe pick_vis $+                             zip roles (tyConBinders tc)+    role_annot_decl_maybe  = lookupRoleAnnot role_annots name++    pick_vis :: (Role, TyConBinder) -> Maybe (Role, TyVar)+    pick_vis (role, tvb)+      | isVisibleTyConBinder tvb = Just (role, binderVar tvb)+      | otherwise                = Nothing++    check_roles+      = whenIsJust role_annot_decl_maybe $+          \decl@(dL->L loc (RoleAnnotDecl _ _ the_role_annots)) ->+          addRoleAnnotCtxt name $+          setSrcSpan loc $ do+          { role_annots_ok <- xoptM LangExt.RoleAnnotations+          ; checkTc role_annots_ok $ needXRoleAnnotations tc+          ; checkTc (vis_vars `equalLength` the_role_annots)+                    (wrongNumberOfRoles vis_vars decl)+          ; _ <- zipWith3M checkRoleAnnot vis_vars the_role_annots vis_roles+          -- Representational or phantom roles for class parameters+          -- quickly lead to incoherence. So, we require+          -- IncoherentInstances to have them. See #8773, #14292+          ; incoherent_roles_ok <- xoptM LangExt.IncoherentInstances+          ; checkTc (  incoherent_roles_ok+                    || (not $ isClassTyCon tc)+                    || (all (== Nominal) vis_roles))+                    incoherentRoles++          ; lint <- goptM Opt_DoCoreLinting+          ; when lint $ checkValidRoles tc }++    check_no_roles+      = whenIsJust role_annot_decl_maybe illegalRoleAnnotDecl++checkRoleAnnot :: TyVar -> Located (Maybe Role) -> Role -> TcM ()+checkRoleAnnot _  (dL->L _ Nothing)   _  = return ()+checkRoleAnnot tv (dL->L _ (Just r1)) r2+  = when (r1 /= r2) $+    addErrTc $ badRoleAnnot (tyVarName tv) r1 r2+checkRoleAnnot _ _ _ = panic "checkRoleAnnot: Impossible Match" -- due to #15884++-- This is a double-check on the role inference algorithm. It is only run when+-- -dcore-lint is enabled. See Note [Role inference] in TcTyDecls+checkValidRoles :: TyCon -> TcM ()+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism] in CoreLint+checkValidRoles tc+  | isAlgTyCon tc+    -- tyConDataCons returns an empty list for data families+  = mapM_ check_dc_roles (tyConDataCons tc)+  | Just rhs <- synTyConRhs_maybe tc+  = check_ty_roles (zipVarEnv (tyConTyVars tc) (tyConRoles tc)) Representational rhs+  | otherwise+  = return ()+  where+    check_dc_roles datacon+      = do { traceTc "check_dc_roles" (ppr datacon <+> ppr (tyConRoles tc))+           ; mapM_ (check_ty_roles role_env Representational) $+                    eqSpecPreds eq_spec ++ theta ++ arg_tys }+                    -- See Note [Role-checking data constructor arguments] in TcTyDecls+      where+        (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)+          = dataConFullSig datacon+        univ_roles = zipVarEnv univ_tvs (tyConRoles tc)+              -- zipVarEnv uses zipEqual, but we don't want that for ex_tvs+        ex_roles   = mkVarEnv (map (, Nominal) ex_tvs)+        role_env   = univ_roles `plusVarEnv` ex_roles++    check_ty_roles env role ty+      | Just ty' <- coreView ty -- #14101+      = check_ty_roles env role ty'++    check_ty_roles env role (TyVarTy tv)+      = case lookupVarEnv env tv of+          Just role' -> unless (role' `ltRole` role || role' == role) $+                        report_error $ text "type variable" <+> quotes (ppr tv) <+>+                                       text "cannot have role" <+> ppr role <+>+                                       text "because it was assigned role" <+> ppr role'+          Nothing    -> report_error $ text "type variable" <+> quotes (ppr tv) <+>+                                       text "missing in environment"++    check_ty_roles env Representational (TyConApp tc tys)+      = let roles' = tyConRoles tc in+        zipWithM_ (maybe_check_ty_roles env) roles' tys++    check_ty_roles env Nominal (TyConApp _ tys)+      = mapM_ (check_ty_roles env Nominal) tys++    check_ty_roles _   Phantom ty@(TyConApp {})+      = pprPanic "check_ty_roles" (ppr ty)++    check_ty_roles env role (AppTy ty1 ty2)+      =  check_ty_roles env role    ty1+      >> check_ty_roles env Nominal ty2++    check_ty_roles env role (FunTy _ ty1 ty2)+      =  check_ty_roles env role ty1+      >> check_ty_roles env role ty2++    check_ty_roles env role (ForAllTy (Bndr tv _) ty)+      =  check_ty_roles env Nominal (tyVarKind tv)+      >> check_ty_roles (extendVarEnv env tv Nominal) role ty++    check_ty_roles _   _    (LitTy {}) = return ()++    check_ty_roles env role (CastTy t _)+      = check_ty_roles env role t++    check_ty_roles _   role (CoercionTy co)+      = unless (role == Phantom) $+        report_error $ text "coercion" <+> ppr co <+> text "has bad role" <+> ppr role++    maybe_check_ty_roles env role ty+      = when (role == Nominal || role == Representational) $+        check_ty_roles env role ty++    report_error doc+      = addErrTc $ vcat [text "Internal error in role inference:",+                         doc,+                         text "Please report this as a GHC bug:  https://www.haskell.org/ghc/reportabug"]++{-+************************************************************************+*                                                                      *+                Error messages+*                                                                      *+************************************************************************+-}++tcAddTyFamInstCtxt :: TyFamInstDecl GhcRn -> TcM a -> TcM a+tcAddTyFamInstCtxt decl+  = tcAddFamInstCtxt (text "type instance") (tyFamInstDeclName decl)++tcMkDataFamInstCtxt :: DataFamInstDecl GhcRn -> SDoc+tcMkDataFamInstCtxt decl@(DataFamInstDecl { dfid_eqn =+                            HsIB { hsib_body = eqn }})+  = tcMkFamInstCtxt (pprDataFamInstFlavour decl <+> text "instance")+                    (unLoc (feqn_tycon eqn))+tcMkDataFamInstCtxt (DataFamInstDecl (XHsImplicitBndrs _))+  = panic "tcMkDataFamInstCtxt"++tcAddDataFamInstCtxt :: DataFamInstDecl GhcRn -> TcM a -> TcM a+tcAddDataFamInstCtxt decl+  = addErrCtxt (tcMkDataFamInstCtxt decl)++tcMkFamInstCtxt :: SDoc -> Name -> SDoc+tcMkFamInstCtxt flavour tycon+  = hsep [ text "In the" <+> flavour <+> text "declaration for"+         , quotes (ppr tycon) ]++tcAddFamInstCtxt :: SDoc -> Name -> TcM a -> TcM a+tcAddFamInstCtxt flavour tycon thing_inside+  = addErrCtxt (tcMkFamInstCtxt flavour tycon) thing_inside++tcAddClosedTypeFamilyDeclCtxt :: TyCon -> TcM a -> TcM a+tcAddClosedTypeFamilyDeclCtxt tc+  = addErrCtxt ctxt+  where+    ctxt = text "In the equations for closed type family" <+>+           quotes (ppr tc)++resultTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc+resultTypeMisMatch field_name con1 con2+  = vcat [sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,+                text "have a common field" <+> quotes (ppr field_name) <> comma],+          nest 2 $ text "but have different result types"]++fieldTypeMisMatch :: FieldLabelString -> DataCon -> DataCon -> SDoc+fieldTypeMisMatch field_name con1 con2+  = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2,+         text "give different types for field", quotes (ppr field_name)]++dataConCtxtName :: [Located Name] -> SDoc+dataConCtxtName [con]+   = text "In the definition of data constructor" <+> quotes (ppr con)+dataConCtxtName con+   = text "In the definition of data constructors" <+> interpp'SP con++dataConCtxt :: Outputable a => a -> SDoc+dataConCtxt con = text "In the definition of data constructor" <+> quotes (ppr con)++classOpCtxt :: Var -> Type -> SDoc+classOpCtxt sel_id tau = sep [text "When checking the class method:",+                              nest 2 (pprPrefixOcc sel_id <+> dcolon <+> ppr tau)]++classArityErr :: Int -> Class -> SDoc+classArityErr n cls+    | n == 0 = mkErr "No" "no-parameter"+    | otherwise = mkErr "Too many" "multi-parameter"+  where+    mkErr howMany allowWhat =+        vcat [text (howMany ++ " parameters for class") <+> quotes (ppr cls),+              parens (text ("Enable MultiParamTypeClasses to allow "+                                    ++ allowWhat ++ " classes"))]++classFunDepsErr :: Class -> SDoc+classFunDepsErr cls+  = vcat [text "Fundeps in class" <+> quotes (ppr cls),+          parens (text "Enable FunctionalDependencies to allow fundeps")]++badMethPred :: Id -> TcPredType -> SDoc+badMethPred sel_id pred+  = vcat [ hang (text "Constraint" <+> quotes (ppr pred)+                 <+> text "in the type of" <+> quotes (ppr sel_id))+              2 (text "constrains only the class type variables")+         , text "Enable ConstrainedClassMethods to allow it" ]++noClassTyVarErr :: Class -> TyCon -> SDoc+noClassTyVarErr clas fam_tc+  = sep [ text "The associated type" <+> quotes (ppr fam_tc)+        , text "mentions none of the type or kind variables of the class" <+>+                quotes (ppr clas <+> hsep (map ppr (classTyVars clas)))]++badDataConTyCon :: DataCon -> Type -> SDoc+badDataConTyCon data_con res_ty_tmpl+  | ASSERT( all isTyVar tvs )+    tcIsForAllTy actual_res_ty+  = nested_foralls_contexts_suggestion+  | isJust (tcSplitPredFunTy_maybe actual_res_ty)+  = nested_foralls_contexts_suggestion+  | otherwise+  = hang (text "Data constructor" <+> quotes (ppr data_con) <+>+                text "returns type" <+> quotes (ppr actual_res_ty))+       2 (text "instead of an instance of its parent type" <+> quotes (ppr res_ty_tmpl))+  where+    actual_res_ty = dataConOrigResTy data_con++    -- This suggestion is useful for suggesting how to correct code like what+    -- was reported in #12087:+    --+    --   data F a where+    --     MkF :: Ord a => Eq a => a -> F a+    --+    -- Although nested foralls or contexts are allowed in function type+    -- signatures, it is much more difficult to engineer GADT constructor type+    -- signatures to allow something similar, so we error in the latter case.+    -- Nevertheless, we can at least suggest how a user might reshuffle their+    -- exotic GADT constructor type signature so that GHC will accept.+    nested_foralls_contexts_suggestion =+      text "GADT constructor type signature cannot contain nested"+      <+> quotes forAllLit <> text "s or contexts"+      $+$ hang (text "Suggestion: instead use this type signature:")+             2 (ppr (dataConName data_con) <+> dcolon <+> ppr suggested_ty)++    -- To construct a type that GHC would accept (suggested_ty), we:+    --+    -- 1) Find the existentially quantified type variables and the class+    --    predicates from the datacon. (NB: We don't need the universally+    --    quantified type variables, since rejigConRes won't substitute them in+    --    the result type if it fails, as in this scenario.)+    -- 2) Split apart the return type (which is headed by a forall or a+    --    context) using tcSplitNestedSigmaTys, collecting the type variables+    --    and class predicates we find, as well as the rho type lurking+    --    underneath the nested foralls and contexts.+    -- 3) Smash together the type variables and class predicates from 1) and+    --    2), and prepend them to the rho type from 2).+    (tvs, theta, rho) = tcSplitNestedSigmaTys (dataConUserType data_con)+    suggested_ty = mkSpecSigmaTy tvs theta rho++badGadtDecl :: Name -> SDoc+badGadtDecl tc_name+  = vcat [ text "Illegal generalised algebraic data declaration for" <+> quotes (ppr tc_name)+         , nest 2 (parens $ text "Enable the GADTs extension to allow this") ]++badExistential :: DataCon -> SDoc+badExistential con+  = hang (text "Data constructor" <+> quotes (ppr con) <+>+                text "has existential type variables, a context, or a specialised result type")+       2 (vcat [ ppr con <+> dcolon <+> ppr (dataConUserType con)+               , parens $ text "Enable ExistentialQuantification or GADTs to allow this" ])++badStupidTheta :: Name -> SDoc+badStupidTheta tc_name+  = text "A data type declared in GADT style cannot have a context:" <+> quotes (ppr tc_name)++newtypeConError :: Name -> Int -> SDoc+newtypeConError tycon n+  = sep [text "A newtype must have exactly one constructor,",+         nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ]++newtypeStrictError :: DataCon -> SDoc+newtypeStrictError con+  = sep [text "A newtype constructor cannot have a strictness annotation,",+         nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"]++newtypeFieldErr :: DataCon -> Int -> SDoc+newtypeFieldErr con_name n_flds+  = sep [text "The constructor of a newtype must have exactly one field",+         nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds]++badSigTyDecl :: Name -> SDoc+badSigTyDecl tc_name+  = vcat [ text "Illegal kind signature" <+>+           quotes (ppr tc_name)+         , nest 2 (parens $ text "Use KindSignatures to allow kind signatures") ]++emptyConDeclsErr :: Name -> SDoc+emptyConDeclsErr tycon+  = sep [quotes (ppr tycon) <+> text "has no constructors",+         nest 2 $ text "(EmptyDataDecls permits this)"]++wrongKindOfFamily :: TyCon -> SDoc+wrongKindOfFamily family+  = text "Wrong category of family instance; declaration was for a"+    <+> kindOfFamily+  where+    kindOfFamily | isTypeFamilyTyCon family = text "type family"+                 | isDataFamilyTyCon family = text "data family"+                 | otherwise = pprPanic "wrongKindOfFamily" (ppr family)++-- | Produce an error for oversaturated type family equations with too many+-- required arguments.+-- See Note [Oversaturated type family equations] in TcValidity.+wrongNumberOfParmsErr :: Arity -> SDoc+wrongNumberOfParmsErr max_args+  = text "Number of parameters must match family declaration; expected"+    <+> ppr max_args++badRoleAnnot :: Name -> Role -> Role -> SDoc+badRoleAnnot var annot inferred+  = hang (text "Role mismatch on variable" <+> ppr var <> colon)+       2 (sep [ text "Annotation says", ppr annot+              , text "but role", ppr inferred+              , text "is required" ])++wrongNumberOfRoles :: [a] -> LRoleAnnotDecl GhcRn -> SDoc+wrongNumberOfRoles tyvars d@(dL->L _ (RoleAnnotDecl _ _ annots))+  = hang (text "Wrong number of roles listed in role annotation;" $$+          text "Expected" <+> (ppr $ length tyvars) <> comma <+>+          text "got" <+> (ppr $ length annots) <> colon)+       2 (ppr d)+wrongNumberOfRoles _ (dL->L _ (XRoleAnnotDecl _)) = panic "wrongNumberOfRoles"+wrongNumberOfRoles _ _ = panic "wrongNumberOfRoles: Impossible Match"+                         -- due to #15884+++illegalRoleAnnotDecl :: LRoleAnnotDecl GhcRn -> TcM ()+illegalRoleAnnotDecl (dL->L loc (RoleAnnotDecl _ tycon _))+  = setErrCtxt [] $+    setSrcSpan loc $+    addErrTc (text "Illegal role annotation for" <+> ppr tycon <> char ';' $$+              text "they are allowed only for datatypes and classes.")+illegalRoleAnnotDecl (dL->L _ (XRoleAnnotDecl _)) = panic "illegalRoleAnnotDecl"+illegalRoleAnnotDecl _ = panic "illegalRoleAnnotDecl: Impossible Match"+                         -- due to #15884++needXRoleAnnotations :: TyCon -> SDoc+needXRoleAnnotations tc+  = text "Illegal role annotation for" <+> ppr tc <> char ';' $$+    text "did you intend to use RoleAnnotations?"++incoherentRoles :: SDoc+incoherentRoles = (text "Roles other than" <+> quotes (text "nominal") <+>+                   text "for class parameters can lead to incoherence.") $$+                  (text "Use IncoherentInstances to allow this; bad role found")++addTyConCtxt :: TyCon -> TcM a -> TcM a+addTyConCtxt tc = addTyConFlavCtxt name flav+  where+    name = getName tc+    flav = tyConFlavour tc++addRoleAnnotCtxt :: Name -> TcM a -> TcM a+addRoleAnnotCtxt name+  = addErrCtxt $+    text "while checking a role annotation for" <+> quotes (ppr name)
+ compiler/typecheck/TcTyDecls.hs view
@@ -0,0 +1,1033 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1999+++Analysis functions over data types.  Specifically, detecting recursive types.++This stuff is only used for source-code decls; it's recorded in interface+files for imported data types.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}++module TcTyDecls(+        RolesInfo,+        inferRoles,+        checkSynCycles,+        checkClassCycles,++        -- * Implicits+        addTyConsToGblEnv, mkDefaultMethodType,++        -- * Record selectors+        tcRecSelBinds, mkRecSelBinds, mkOneRecordSelector+    ) where++#include "HsVersions.h"++import GhcPrelude++import TcRnMonad+import TcEnv+import TcBinds( tcValBinds, addTypecheckedBinds )+import TyCoRep( Type(..), Coercion(..), MCoercion(..), UnivCoProvenance(..) )+import TcType+import TysWiredIn( unitTy )+import MkCore( rEC_SEL_ERROR_ID )+import HsSyn+import Class+import Type+import HscTypes+import TyCon+import ConLike+import DataCon+import Name+import NameEnv+import NameSet hiding (unitFV)+import RdrName ( mkVarUnqual )+import Id+import IdInfo+import VarEnv+import VarSet+import Coercion ( ltRole )+import BasicTypes+import SrcLoc+import Unique ( mkBuiltinUnique )+import Outputable+import Util+import Maybes+import Bag+import FastString+import FV+import Module++import Control.Monad++{-+************************************************************************+*                                                                      *+        Cycles in type synonym declarations+*                                                                      *+************************************************************************+-}++synonymTyConsOfType :: Type -> [TyCon]+-- Does not look through type synonyms at all+-- Return a list of synonym tycons+-- Keep this synchronized with 'expandTypeSynonyms'+synonymTyConsOfType ty+  = nameEnvElts (go ty)+  where+     go :: Type -> NameEnv TyCon  -- The NameEnv does duplicate elim+     go (TyConApp tc tys) = go_tc tc `plusNameEnv` go_s tys+     go (LitTy _)         = emptyNameEnv+     go (TyVarTy _)       = emptyNameEnv+     go (AppTy a b)       = go a `plusNameEnv` go b+     go (FunTy _ a b)     = go a `plusNameEnv` go b+     go (ForAllTy _ ty)   = go ty+     go (CastTy ty co)    = go ty `plusNameEnv` go_co co+     go (CoercionTy co)   = go_co co++     -- Note [TyCon cycles through coercions?!]+     -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+     -- Although, in principle, it's possible for a type synonym loop+     -- could go through a coercion (since a coercion can refer to+     -- a TyCon or Type), it doesn't seem possible to actually construct+     -- a Haskell program which tickles this case.  Here is an example+     -- program which causes a coercion:+     --+     --   type family Star where+     --       Star = Type+     --+     --   data T :: Star -> Type+     --   data S :: forall (a :: Type). T a -> Type+     --+     -- Here, the application 'T a' must first coerce a :: Type to a :: Star,+     -- witnessed by the type family.  But if we now try to make Type refer+     -- to a type synonym which in turn refers to Star, we'll run into+     -- trouble: we're trying to define and use the type constructor+     -- in the same recursive group.  Possibly this restriction will be+     -- lifted in the future but for now, this code is "just for completeness+     -- sake".+     go_mco MRefl    = emptyNameEnv+     go_mco (MCo co) = go_co co++     go_co (Refl ty)              = go ty+     go_co (GRefl _ ty mco)       = go ty `plusNameEnv` go_mco mco+     go_co (TyConAppCo _ tc cs)   = go_tc tc `plusNameEnv` go_co_s cs+     go_co (AppCo co co')         = go_co co `plusNameEnv` go_co co'+     go_co (ForAllCo _ co co')    = go_co co `plusNameEnv` go_co co'+     go_co (FunCo _ co co')       = go_co co `plusNameEnv` go_co co'+     go_co (CoVarCo _)            = emptyNameEnv+     go_co (HoleCo {})            = emptyNameEnv+     go_co (AxiomInstCo _ _ cs)   = go_co_s cs+     go_co (UnivCo p _ ty ty')    = go_prov p `plusNameEnv` go ty `plusNameEnv` go ty'+     go_co (SymCo co)             = go_co co+     go_co (TransCo co co')       = go_co co `plusNameEnv` go_co co'+     go_co (NthCo _ _ co)         = go_co co+     go_co (LRCo _ co)            = go_co co+     go_co (InstCo co co')        = go_co co `plusNameEnv` go_co co'+     go_co (KindCo co)            = go_co co+     go_co (SubCo co)             = go_co co+     go_co (AxiomRuleCo _ cs)     = go_co_s cs++     go_prov UnsafeCoerceProv     = emptyNameEnv+     go_prov (PhantomProv co)     = go_co co+     go_prov (ProofIrrelProv co)  = go_co co+     go_prov (PluginProv _)       = emptyNameEnv++     go_tc tc | isTypeSynonymTyCon tc = unitNameEnv (tyConName tc) tc+              | otherwise             = emptyNameEnv+     go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys+     go_co_s cos = foldr (plusNameEnv . go_co) emptyNameEnv cos++-- | A monad for type synonym cycle checking, which keeps+-- track of the TyCons which are known to be acyclic, or+-- a failure message reporting that a cycle was found.+newtype SynCycleM a = SynCycleM {+    runSynCycleM :: SynCycleState -> Either (SrcSpan, SDoc) (a, SynCycleState) }++type SynCycleState = NameSet++instance Functor SynCycleM where+    fmap = liftM++instance Applicative SynCycleM where+    pure x = SynCycleM $ \state -> Right (x, state)+    (<*>) = ap++instance Monad SynCycleM where+    m >>= f = SynCycleM $ \state ->+        case runSynCycleM m state of+            Right (x, state') ->+                runSynCycleM (f x) state'+            Left err -> Left err++failSynCycleM :: SrcSpan -> SDoc -> SynCycleM ()+failSynCycleM loc err = SynCycleM $ \_ -> Left (loc, err)++-- | Test if a 'Name' is acyclic, short-circuiting if we've+-- seen it already.+checkNameIsAcyclic :: Name -> SynCycleM () -> SynCycleM ()+checkNameIsAcyclic n m = SynCycleM $ \s ->+    if n `elemNameSet` s+        then Right ((), s) -- short circuit+        else case runSynCycleM m s of+                Right ((), s') -> Right ((), extendNameSet s' n)+                Left err -> Left err++-- | Checks if any of the passed in 'TyCon's have cycles.+-- Takes the 'UnitId' of the home package (as we can avoid+-- checking those TyCons: cycles never go through foreign packages) and+-- the corresponding @LTyClDecl Name@ for each 'TyCon', so we+-- can give better error messages.+checkSynCycles :: UnitId -> [TyCon] -> [LTyClDecl GhcRn] -> TcM ()+checkSynCycles this_uid tcs tyclds = do+    case runSynCycleM (mapM_ (go emptyNameSet []) tcs) emptyNameSet of+        Left (loc, err) -> setSrcSpan loc $ failWithTc err+        Right _  -> return ()+  where+    -- Try our best to print the LTyClDecl for locally defined things+    lcl_decls = mkNameEnv (zip (map tyConName tcs) tyclds)++    -- Short circuit if we've already seen this Name and concluded+    -- it was acyclic.+    go :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()+    go so_far seen_tcs tc =+        checkNameIsAcyclic (tyConName tc) $ go' so_far seen_tcs tc++    -- Expand type synonyms, complaining if you find the same+    -- type synonym a second time.+    go' :: NameSet -> [TyCon] -> TyCon -> SynCycleM ()+    go' so_far seen_tcs tc+        | n `elemNameSet` so_far+            = failSynCycleM (getSrcSpan (head seen_tcs)) $+                  sep [ text "Cycle in type synonym declarations:"+                      , nest 2 (vcat (map ppr_decl seen_tcs)) ]+        -- Optimization: we don't allow cycles through external packages,+        -- so once we find a non-local name we are guaranteed to not+        -- have a cycle.+        --+        -- This won't hold once we get recursive packages with Backpack,+        -- but for now it's fine.+        | not (isHoleModule mod ||+               moduleUnitId mod == this_uid ||+               isInteractiveModule mod)+            = return ()+        | Just ty <- synTyConRhs_maybe tc =+            go_ty (extendNameSet so_far (tyConName tc)) (tc:seen_tcs) ty+        | otherwise = return ()+      where+        n = tyConName tc+        mod = nameModule n+        ppr_decl tc =+          case lookupNameEnv lcl_decls n of+            Just (dL->L loc decl) -> ppr loc <> colon <+> ppr decl+            Nothing -> ppr (getSrcSpan n) <> colon <+> ppr n+                       <+> text "from external module"+         where+          n = tyConName tc++    go_ty :: NameSet -> [TyCon] -> Type -> SynCycleM ()+    go_ty so_far seen_tcs ty =+        mapM_ (go so_far seen_tcs) (synonymTyConsOfType ty)++{- Note [Superclass cycle check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The superclass cycle check for C decides if we can statically+guarantee that expanding C's superclass cycles transitively is+guaranteed to terminate.  This is a Haskell98 requirement,+but one that we lift with -XUndecidableSuperClasses.++The worry is that a superclass cycle could make the type checker loop.+More precisely, with a constraint (Given or Wanted)+    C ty1 .. tyn+one approach is to instantiate all of C's superclasses, transitively.+We can only do so if that set is finite.++This potential loop occurs only through superclasses.  This, for+example, is fine+  class C a where+    op :: C b => a -> b -> b+even though C's full definition uses C.++Making the check static also makes it conservative.  Eg+  type family F a+  class F a => C a+Here an instance of (F a) might mention C:+  type instance F [a] = C a+and now we'd have a loop.++The static check works like this, starting with C+  * Look at C's superclass predicates+  * If any is a type-function application,+    or is headed by a type variable, fail+  * If any has C at the head, fail+  * If any has a type class D at the head,+    make the same test with D++A tricky point is: what if there is a type variable at the head?+Consider this:+   class f (C f) => C f+   class c       => Id c+and now expand superclasses for constraint (C Id):+     C Id+ --> Id (C Id)+ --> C Id+ --> ....+Each step expands superclasses one layer, and clearly does not terminate.+-}++checkClassCycles :: Class -> Maybe SDoc+-- Nothing  <=> ok+-- Just err <=> possible cycle error+checkClassCycles cls+  = do { (definite_cycle, err) <- go (unitNameSet (getName cls))+                                     cls (mkTyVarTys (classTyVars cls))+       ; let herald | definite_cycle = text "Superclass cycle for"+                    | otherwise      = text "Potential superclass cycle for"+       ; return (vcat [ herald <+> quotes (ppr cls)+                      , nest 2 err, hint]) }+  where+    hint = text "Use UndecidableSuperClasses to accept this"++    -- Expand superclasses starting with (C a b), complaining+    -- if you find the same class a second time, or a type function+    -- or predicate headed by a type variable+    --+    -- NB: this code duplicates TcType.transSuperClasses, but+    --     with more error message generation clobber+    -- Make sure the two stay in sync.+    go :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)+    go so_far cls tys = firstJusts $+                        map (go_pred so_far) $+                        immSuperClasses cls tys++    go_pred :: NameSet -> PredType -> Maybe (Bool, SDoc)+       -- Nothing <=> ok+       -- Just (True, err)  <=> definite cycle+       -- Just (False, err) <=> possible cycle+    go_pred so_far pred  -- NB: tcSplitTyConApp looks through synonyms+       | Just (tc, tys) <- tcSplitTyConApp_maybe pred+       = go_tc so_far pred tc tys+       | hasTyVarHead pred+       = Just (False, hang (text "one of whose superclass constraints is headed by a type variable:")+                         2 (quotes (ppr pred)))+       | otherwise+       = Nothing++    go_tc :: NameSet -> PredType -> TyCon -> [Type] -> Maybe (Bool, SDoc)+    go_tc so_far pred tc tys+      | isFamilyTyCon tc+      = Just (False, hang (text "one of whose superclass constraints is headed by a type family:")+                        2 (quotes (ppr pred)))+      | Just cls <- tyConClass_maybe tc+      = go_cls so_far cls tys+      | otherwise   -- Equality predicate, for example+      = Nothing++    go_cls :: NameSet -> Class -> [Type] -> Maybe (Bool, SDoc)+    go_cls so_far cls tys+       | cls_nm `elemNameSet` so_far+       = Just (True, text "one of whose superclasses is" <+> quotes (ppr cls))+       | isCTupleClass cls+       = go so_far cls tys+       | otherwise+       = do { (b,err) <- go  (so_far `extendNameSet` cls_nm) cls tys+          ; return (b, text "one of whose superclasses is" <+> quotes (ppr cls)+                       $$ err) }+       where+         cls_nm = getName cls++{-+************************************************************************+*                                                                      *+        Role inference+*                                                                      *+************************************************************************++Note [Role inference]+~~~~~~~~~~~~~~~~~~~~~+The role inference algorithm datatype definitions to infer the roles on the+parameters. Although these roles are stored in the tycons, we can perform this+algorithm on the built tycons, as long as we don't peek at an as-yet-unknown+roles field! Ah, the magic of laziness.++First, we choose appropriate initial roles. For families and classes, roles+(including initial roles) are N. For datatypes, we start with the role in the+role annotation (if any), or otherwise use Phantom. This is done in+initialRoleEnv1.++The function irGroup then propagates role information until it reaches a+fixpoint, preferring N over (R or P) and R over P. To aid in this, we have a+monad RoleM, which is a combination reader and state monad. In its state are+the current RoleEnv, which gets updated by role propagation, and an update+bit, which we use to know whether or not we've reached the fixpoint. The+environment of RoleM contains the tycon whose parameters we are inferring, and+a VarEnv from parameters to their positions, so we can update the RoleEnv.+Between tycons, this reader information is missing; it is added by+addRoleInferenceInfo.++There are two kinds of tycons to consider: algebraic ones (excluding classes)+and type synonyms. (Remember, families don't participate -- all their parameters+are N.) An algebraic tycon processes each of its datacons, in turn. Note that+a datacon's universally quantified parameters might be different from the parent+tycon's parameters, so we use the datacon's univ parameters in the mapping from+vars to positions. Note also that we don't want to infer roles for existentials+(they're all at N, too), so we put them in the set of local variables. As an+optimisation, we skip any tycons whose roles are already all Nominal, as there+nowhere else for them to go. For synonyms, we just analyse their right-hand sides.++irType walks through a type, looking for uses of a variable of interest and+propagating role information. Because anything used under a phantom position+is at phantom and anything used under a nominal position is at nominal, the+irType function can assume that anything it sees is at representational. (The+other possibilities are pruned when they're encountered.)++The rest of the code is just plumbing.++How do we know that this algorithm is correct? It should meet the following+specification:++Let Z be a role context -- a mapping from variables to roles. The following+rules define the property (Z |- t : r), where t is a type and r is a role:++Z(a) = r'        r' <= r+------------------------- RCVar+Z |- a : r++---------- RCConst+Z |- T : r               -- T is a type constructor++Z |- t1 : r+Z |- t2 : N+-------------- RCApp+Z |- t1 t2 : r++forall i<=n. (r_i is R or N) implies Z |- t_i : r_i+roles(T) = r_1 .. r_n+---------------------------------------------------- RCDApp+Z |- T t_1 .. t_n : R++Z, a:N |- t : r+---------------------- RCAll+Z |- forall a:k.t : r+++We also have the following rules:++For all datacon_i in type T, where a_1 .. a_n are universally quantified+and b_1 .. b_m are existentially quantified, and the arguments are t_1 .. t_p,+then if forall j<=p, a_1 : r_1 .. a_n : r_n, b_1 : N .. b_m : N |- t_j : R,+then roles(T) = r_1 .. r_n++roles(->) = R, R+roles(~#) = N, N++With -dcore-lint on, the output of this algorithm is checked in checkValidRoles,+called from checkValidTycon.++Note [Role-checking data constructor arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  data T a where+    MkT :: Eq b => F a -> (a->a) -> T (G a)++Then we want to check the roles at which 'a' is used+in MkT's type.  We want to work on the user-written type,+so we need to take into account+  * the arguments:   (F a) and (a->a)+  * the context:     C a b+  * the result type: (G a)   -- this is in the eq_spec+++Note [Coercions in role inference]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Is (t |> co1) representationally equal to (t |> co2)? Of course they are! Changing+the kind of a type is totally irrelevant to the representation of that type. So,+we want to totally ignore coercions when doing role inference. This includes omitting+any type variables that appear in nominal positions but only within coercions.+-}++type RolesInfo = Name -> [Role]++type RoleEnv = NameEnv [Role]        -- from tycon names to roles++-- This, and any of the functions it calls, must *not* look at the roles+-- field of a tycon we are inferring roles about!+-- See Note [Role inference]+inferRoles :: HscSource -> RoleAnnotEnv -> [TyCon] -> Name -> [Role]+inferRoles hsc_src annots tycons+  = let role_env  = initialRoleEnv hsc_src annots tycons+        role_env' = irGroup role_env tycons in+    \name -> case lookupNameEnv role_env' name of+      Just roles -> roles+      Nothing    -> pprPanic "inferRoles" (ppr name)++initialRoleEnv :: HscSource -> RoleAnnotEnv -> [TyCon] -> RoleEnv+initialRoleEnv hsc_src annots = extendNameEnvList emptyNameEnv .+                                map (initialRoleEnv1 hsc_src annots)++initialRoleEnv1 :: HscSource -> RoleAnnotEnv -> TyCon -> (Name, [Role])+initialRoleEnv1 hsc_src annots_env tc+  | isFamilyTyCon tc      = (name, map (const Nominal) bndrs)+  | isAlgTyCon tc         = (name, default_roles)+  | isTypeSynonymTyCon tc = (name, default_roles)+  | otherwise             = pprPanic "initialRoleEnv1" (ppr tc)+  where name         = tyConName tc+        bndrs        = tyConBinders tc+        argflags     = map tyConBinderArgFlag bndrs+        num_exps     = count isVisibleArgFlag argflags++          -- if the number of annotations in the role annotation decl+          -- is wrong, just ignore it. We check this in the validity check.+        role_annots+          = case lookupRoleAnnot annots_env name of+              Just (dL->L _ (RoleAnnotDecl _ _ annots))+                | annots `lengthIs` num_exps -> map unLoc annots+              _                              -> replicate num_exps Nothing+        default_roles = build_default_roles argflags role_annots++        build_default_roles (argf : argfs) (m_annot : ras)+          | isVisibleArgFlag argf+          = (m_annot `orElse` default_role) : build_default_roles argfs ras+        build_default_roles (_argf : argfs) ras+          = Nominal : build_default_roles argfs ras+        build_default_roles [] [] = []+        build_default_roles _ _ = pprPanic "initialRoleEnv1 (2)"+                                           (vcat [ppr tc, ppr role_annots])++        default_role+          | isClassTyCon tc               = Nominal+          -- Note [Default roles for abstract TyCons in hs-boot/hsig]+          | HsBootFile <- hsc_src+          , isAbstractTyCon tc            = Representational+          | HsigFile   <- hsc_src+          , isAbstractTyCon tc            = Nominal+          | otherwise                     = Phantom++-- Note [Default roles for abstract TyCons in hs-boot/hsig]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- What should the default role for an abstract TyCon be?+--+-- Originally, we inferred phantom role for abstract TyCons+-- in hs-boot files, because the type variables were never used.+--+-- This was silly, because the role of the abstract TyCon+-- was required to match the implementation, and the roles of+-- data types are almost never phantom.  Thus, in ticket #9204,+-- the default was changed so be representational (the most common case).  If+-- the implementing data type was actually nominal, you'd get an easy+-- to understand error, and add the role annotation yourself.+--+-- Then Backpack was added, and with it we added role *subtyping*+-- the matching judgment: if an abstract TyCon has a nominal+-- parameter, it's OK to implement it with a representational+-- parameter.  But now, the representational default is not a good+-- one, because you should *only* request representational if+-- you're planning to do coercions. To be maximally flexible+-- with what data types you will accept, you want the default+-- for hsig files is nominal.  We don't allow role subtyping+-- with hs-boot files (it's good practice to give an exactly+-- accurate role here, because any types that use the abstract+-- type will propagate the role information.)++irGroup :: RoleEnv -> [TyCon] -> RoleEnv+irGroup env tcs+  = let (env', update) = runRoleM env $ mapM_ irTyCon tcs in+    if update+    then irGroup env' tcs+    else env'++irTyCon :: TyCon -> RoleM ()+irTyCon tc+  | isAlgTyCon tc+  = do { old_roles <- lookupRoles tc+       ; unless (all (== Nominal) old_roles) $  -- also catches data families,+                                                -- which don't want or need role inference+         irTcTyVars tc $+         do { mapM_ (irType emptyVarSet) (tyConStupidTheta tc)  -- See #8958+            ; whenIsJust (tyConClass_maybe tc) irClass+            ; mapM_ irDataCon (visibleDataCons $ algTyConRhs tc) }}++  | Just ty <- synTyConRhs_maybe tc+  = irTcTyVars tc $+    irType emptyVarSet ty++  | otherwise+  = return ()++-- any type variable used in an associated type must be Nominal+irClass :: Class -> RoleM ()+irClass cls+  = mapM_ ir_at (classATs cls)+  where+    cls_tvs    = classTyVars cls+    cls_tv_set = mkVarSet cls_tvs++    ir_at at_tc+      = mapM_ (updateRole Nominal) nvars+      where nvars = filter (`elemVarSet` cls_tv_set) $ tyConTyVars at_tc++-- See Note [Role inference]+irDataCon :: DataCon -> RoleM ()+irDataCon datacon+  = setRoleInferenceVars univ_tvs $+    irExTyVars ex_tvs $ \ ex_var_set ->+    mapM_ (irType ex_var_set)+          (map tyVarKind ex_tvs ++ eqSpecPreds eq_spec ++ theta ++ arg_tys)+      -- See Note [Role-checking data constructor arguments]+  where+    (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)+      = dataConFullSig datacon++irType :: VarSet -> Type -> RoleM ()+irType = go+  where+    go lcls ty                 | Just ty' <- coreView ty -- #14101+                               = go lcls ty'+    go lcls (TyVarTy tv)       = unless (tv `elemVarSet` lcls) $+                                 updateRole Representational tv+    go lcls (AppTy t1 t2)      = go lcls t1 >> markNominal lcls t2+    go lcls (TyConApp tc tys)  = do { roles <- lookupRolesX tc+                                    ; zipWithM_ (go_app lcls) roles tys }+    go lcls (ForAllTy tvb ty)  = do { let tv = binderVar tvb+                                          lcls' = extendVarSet lcls tv+                                    ; markNominal lcls (tyVarKind tv)+                                    ; go lcls' ty }+    go lcls (FunTy _ arg res)  = go lcls arg >> go lcls res+    go _    (LitTy {})         = return ()+      -- See Note [Coercions in role inference]+    go lcls (CastTy ty _)      = go lcls ty+    go _    (CoercionTy _)     = return ()++    go_app _ Phantom _ = return ()                 -- nothing to do here+    go_app lcls Nominal ty = markNominal lcls ty  -- all vars below here are N+    go_app lcls Representational ty = go lcls ty++irTcTyVars :: TyCon -> RoleM a -> RoleM a+irTcTyVars tc thing+  = setRoleInferenceTc (tyConName tc) $ go (tyConTyVars tc)+  where+    go []       = thing+    go (tv:tvs) = do { markNominal emptyVarSet (tyVarKind tv)+                     ; addRoleInferenceVar tv $ go tvs }++irExTyVars :: [TyVar] -> (TyVarSet -> RoleM a) -> RoleM a+irExTyVars orig_tvs thing = go emptyVarSet orig_tvs+  where+    go lcls []       = thing lcls+    go lcls (tv:tvs) = do { markNominal lcls (tyVarKind tv)+                          ; go (extendVarSet lcls tv) tvs }++markNominal :: TyVarSet   -- local variables+            -> Type -> RoleM ()+markNominal lcls ty = let nvars = fvVarList (FV.delFVs lcls $ get_ty_vars ty) in+                      mapM_ (updateRole Nominal) nvars+  where+     -- get_ty_vars gets all the tyvars (no covars!) from a type *without*+     -- recurring into coercions. Recall: coercions are totally ignored during+     -- role inference. See [Coercions in role inference]+    get_ty_vars :: Type -> FV+    get_ty_vars (TyVarTy tv)      = unitFV tv+    get_ty_vars (AppTy t1 t2)     = get_ty_vars t1 `unionFV` get_ty_vars t2+    get_ty_vars (FunTy _ t1 t2)   = get_ty_vars t1 `unionFV` get_ty_vars t2+    get_ty_vars (TyConApp _ tys)  = mapUnionFV get_ty_vars tys+    get_ty_vars (ForAllTy tvb ty) = tyCoFVsBndr tvb (get_ty_vars ty)+    get_ty_vars (LitTy {})        = emptyFV+    get_ty_vars (CastTy ty _)     = get_ty_vars ty+    get_ty_vars (CoercionTy _)    = emptyFV++-- like lookupRoles, but with Nominal tags at the end for oversaturated TyConApps+lookupRolesX :: TyCon -> RoleM [Role]+lookupRolesX tc+  = do { roles <- lookupRoles tc+       ; return $ roles ++ repeat Nominal }++-- gets the roles either from the environment or the tycon+lookupRoles :: TyCon -> RoleM [Role]+lookupRoles tc+  = do { env <- getRoleEnv+       ; case lookupNameEnv env (tyConName tc) of+           Just roles -> return roles+           Nothing    -> return $ tyConRoles tc }++-- tries to update a role; won't ever update a role "downwards"+updateRole :: Role -> TyVar -> RoleM ()+updateRole role tv+  = do { var_ns <- getVarNs+       ; name <- getTyConName+       ; case lookupVarEnv var_ns tv of+           Nothing -> pprPanic "updateRole" (ppr name $$ ppr tv $$ ppr var_ns)+           Just n  -> updateRoleEnv name n role }++-- the state in the RoleM monad+data RoleInferenceState = RIS { role_env  :: RoleEnv+                              , update    :: Bool }++-- the environment in the RoleM monad+type VarPositions = VarEnv Int++-- See [Role inference]+newtype RoleM a = RM { unRM :: Maybe Name -- of the tycon+                            -> VarPositions+                            -> Int          -- size of VarPositions+                            -> RoleInferenceState+                            -> (a, RoleInferenceState) }++instance Functor RoleM where+    fmap = liftM++instance Applicative RoleM where+    pure x = RM $ \_ _ _ state -> (x, state)+    (<*>) = ap++instance Monad RoleM where+  a >>= f  = RM $ \m_info vps nvps state ->+                  let (a', state') = unRM a m_info vps nvps state in+                  unRM (f a') m_info vps nvps state'++runRoleM :: RoleEnv -> RoleM () -> (RoleEnv, Bool)+runRoleM env thing = (env', update)+  where RIS { role_env = env', update = update }+          = snd $ unRM thing Nothing emptyVarEnv 0 state+        state = RIS { role_env  = env+                    , update    = False }++setRoleInferenceTc :: Name -> RoleM a -> RoleM a+setRoleInferenceTc name thing = RM $ \m_name vps nvps state ->+                                ASSERT( isNothing m_name )+                                ASSERT( isEmptyVarEnv vps )+                                ASSERT( nvps == 0 )+                                unRM thing (Just name) vps nvps state++addRoleInferenceVar :: TyVar -> RoleM a -> RoleM a+addRoleInferenceVar tv thing+  = RM $ \m_name vps nvps state ->+    ASSERT( isJust m_name )+    unRM thing m_name (extendVarEnv vps tv nvps) (nvps+1) state++setRoleInferenceVars :: [TyVar] -> RoleM a -> RoleM a+setRoleInferenceVars tvs thing+  = RM $ \m_name _vps _nvps state ->+    ASSERT( isJust m_name )+    unRM thing m_name (mkVarEnv (zip tvs [0..])) (panic "setRoleInferenceVars")+         state++getRoleEnv :: RoleM RoleEnv+getRoleEnv = RM $ \_ _ _ state@(RIS { role_env = env }) -> (env, state)++getVarNs :: RoleM VarPositions+getVarNs = RM $ \_ vps _ state -> (vps, state)++getTyConName :: RoleM Name+getTyConName = RM $ \m_name _ _ state ->+                    case m_name of+                      Nothing   -> panic "getTyConName"+                      Just name -> (name, state)++updateRoleEnv :: Name -> Int -> Role -> RoleM ()+updateRoleEnv name n role+  = RM $ \_ _ _ state@(RIS { role_env = role_env }) -> ((),+         case lookupNameEnv role_env name of+           Nothing -> pprPanic "updateRoleEnv" (ppr name)+           Just roles -> let (before, old_role : after) = splitAt n roles in+                         if role `ltRole` old_role+                         then let roles' = before ++ role : after+                                  role_env' = extendNameEnv role_env name roles' in+                              RIS { role_env = role_env', update = True }+                         else state )+++{- *********************************************************************+*                                                                      *+                Building implicits+*                                                                      *+********************************************************************* -}++addTyConsToGblEnv :: [TyCon] -> TcM TcGblEnv+-- Given a [TyCon], add to the TcGblEnv+--   * extend the TypeEnv with the tycons+--   * extend the TypeEnv with their implicitTyThings+--   * extend the TypeEnv with any default method Ids+--   * add bindings for record selectors+addTyConsToGblEnv tyclss+  = tcExtendTyConEnv tyclss                    $+    tcExtendGlobalEnvImplicit implicit_things  $+    tcExtendGlobalValEnv def_meth_ids          $+    do { traceTc "tcAddTyCons" $ vcat+            [ text "tycons" <+> ppr tyclss+            , text "implicits" <+> ppr implicit_things ]+       ; gbl_env <- tcRecSelBinds (mkRecSelBinds tyclss)+       ; return gbl_env }+ where+   implicit_things = concatMap implicitTyConThings tyclss+   def_meth_ids    = mkDefaultMethodIds tyclss++mkDefaultMethodIds :: [TyCon] -> [Id]+-- We want to put the default-method Ids (both vanilla and generic)+-- into the type environment so that they are found when we typecheck+-- the filled-in default methods of each instance declaration+-- See Note [Default method Ids and Template Haskell]+mkDefaultMethodIds tycons+  = [ mkExportedVanillaId dm_name (mkDefaultMethodType cls sel_id dm_spec)+    | tc <- tycons+    , Just cls <- [tyConClass_maybe tc]+    , (sel_id, Just (dm_name, dm_spec)) <- classOpItems cls ]++mkDefaultMethodType :: Class -> Id -> DefMethSpec Type -> Type+-- Returns the top-level type of the default method+mkDefaultMethodType _ sel_id VanillaDM        = idType sel_id+mkDefaultMethodType cls _   (GenericDM dm_ty) = mkSigmaTy tv_bndrs [pred] dm_ty+   where+     pred      = mkClassPred cls (mkTyVarTys (binderVars cls_bndrs))+     cls_bndrs = tyConBinders (classTyCon cls)+     tv_bndrs  = tyConTyVarBinders cls_bndrs+     -- NB: the Class doesn't have TyConBinders; we reach into its+     --     TyCon to get those.  We /do/ need the TyConBinders because+     --     we need the correct visibility: these default methods are+     --     used in code generated by the fill-in for missing+     --     methods in instances (TcInstDcls.mkDefMethBind), and+     --     then typechecked.  So we need the right visibilty info+     --     (#13998)++{-+************************************************************************+*                                                                      *+                Building record selectors+*                                                                      *+************************************************************************+-}++{-+Note [Default method Ids and Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#4169):+   class Numeric a where+     fromIntegerNum :: a+     fromIntegerNum = ...++   ast :: Q [Dec]+   ast = [d| instance Numeric Int |]++When we typecheck 'ast' we have done the first pass over the class decl+(in tcTyClDecls), but we have not yet typechecked the default-method+declarations (because they can mention value declarations).  So we+must bring the default method Ids into scope first (so they can be seen+when typechecking the [d| .. |] quote, and typecheck them later.+-}++{-+************************************************************************+*                                                                      *+                Building record selectors+*                                                                      *+************************************************************************+-}++tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv+tcRecSelBinds sel_bind_prs+  = tcExtendGlobalValEnv [sel_id | (dL->L _ (IdSig _ sel_id)) <- sigs] $+    do { (rec_sel_binds, tcg_env) <- discardWarnings $+                                     tcValBinds TopLevel binds sigs getGblEnv+       ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) }+  where+    sigs = [ cL loc (IdSig noExt sel_id)   | (sel_id, _) <- sel_bind_prs+                                          , let loc = getSrcSpan sel_id ]+    binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs]++mkRecSelBinds :: [TyCon] -> [(Id, LHsBind GhcRn)]+-- NB We produce *un-typechecked* bindings, rather like 'deriving'+--    This makes life easier, because the later type checking will add+--    all necessary type abstractions and applications+mkRecSelBinds tycons+  = map mkRecSelBind [ (tc,fld) | tc <- tycons+                                , fld <- tyConFieldLabels tc ]++mkRecSelBind :: (TyCon, FieldLabel) -> (Id, LHsBind GhcRn)+mkRecSelBind (tycon, fl)+  = mkOneRecordSelector all_cons (RecSelData tycon) fl+  where+    all_cons = map RealDataCon (tyConDataCons tycon)++mkOneRecordSelector :: [ConLike] -> RecSelParent -> FieldLabel+                    -> (Id, LHsBind GhcRn)+mkOneRecordSelector all_cons idDetails fl+  = (sel_id, cL loc sel_bind)+  where+    loc      = getSrcSpan sel_name+    lbl      = flLabel fl+    sel_name = flSelector fl++    sel_id = mkExportedLocalId rec_details sel_name sel_ty+    rec_details = RecSelId { sel_tycon = idDetails, sel_naughty = is_naughty }++    -- Find a representative constructor, con1+    cons_w_field = conLikesWithFields all_cons [lbl]+    con1 = ASSERT( not (null cons_w_field) ) head cons_w_field++    -- Selector type; Note [Polymorphic selectors]+    field_ty   = conLikeFieldType con1 lbl+    data_tvs   = tyCoVarsOfTypesWellScoped inst_tys+    data_tv_set= mkVarSet data_tvs+    is_naughty = not (tyCoVarsOfType field_ty `subVarSet` data_tv_set)+    (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty+    sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]+           | otherwise  = mkSpecForAllTys data_tvs          $+                          mkPhiTy (conLikeStupidTheta con1) $   -- Urgh!+                          mkVisFunTy data_ty                $+                          mkSpecForAllTys field_tvs         $+                          mkPhiTy field_theta               $+                          -- req_theta is empty for normal DataCon+                          mkPhiTy req_theta                 $+                          field_tau++    -- Make the binding: sel (C2 { fld = x }) = x+    --                   sel (C7 { fld = x }) = x+    --    where cons_w_field = [C2,C7]+    sel_bind = mkTopFunBind Generated sel_lname alts+      where+        alts | is_naughty = [mkSimpleMatch (mkPrefixFunRhs sel_lname)+                                           [] unit_rhs]+             | otherwise =  map mk_match cons_w_field ++ deflt+    mk_match con = mkSimpleMatch (mkPrefixFunRhs sel_lname)+                                 [cL loc (mk_sel_pat con)]+                                 (cL loc (HsVar noExt (cL loc field_var)))+    mk_sel_pat con = ConPatIn (cL loc (getName con)) (RecCon rec_fields)+    rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing }+    rec_field  = noLoc (HsRecField+                        { hsRecFieldLbl+                           = cL loc (FieldOcc sel_name+                                     (cL loc $ mkVarUnqual lbl))+                        , hsRecFieldArg+                           = cL loc (VarPat noExt (cL loc field_var))+                        , hsRecPun = False })+    sel_lname = cL loc sel_name+    field_var = mkInternalName (mkBuiltinUnique 1) (getOccName sel_name) loc++    -- Add catch-all default case unless the case is exhaustive+    -- We do this explicitly so that we get a nice error message that+    -- mentions this particular record selector+    deflt | all dealt_with all_cons = []+          | otherwise = [mkSimpleMatch CaseAlt+                            [cL loc (WildPat noExt)]+                            (mkHsApp (cL loc (HsVar noExt+                                         (cL loc (getName rEC_SEL_ERROR_ID))))+                                     (cL loc (HsLit noExt msg_lit)))]++        -- Do not add a default case unless there are unmatched+        -- constructors.  We must take account of GADTs, else we+        -- get overlap warning messages from the pattern-match checker+        -- NB: we need to pass type args for the *representation* TyCon+        --     to dataConCannotMatch, hence the calculation of inst_tys+        --     This matters in data families+        --              data instance T Int a where+        --                 A :: { fld :: Int } -> T Int Bool+        --                 B :: { fld :: Int } -> T Int Char+    dealt_with :: ConLike -> Bool+    dealt_with (PatSynCon _) = False -- We can't predict overlap+    dealt_with con@(RealDataCon dc) =+      con `elem` cons_w_field || dataConCannotMatch inst_tys dc++    (univ_tvs, _, eq_spec, _, req_theta, _, data_ty) = conLikeFullSig con1++    eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)+    inst_tys = substTyVars eq_subst univ_tvs++    unit_rhs = mkLHsTupleExpr []+    msg_lit = HsStringPrim NoSourceText (bytesFS lbl)++{-+Note [Polymorphic selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We take care to build the type of a polymorphic selector in the right+order, so that visible type application works.++  data Ord a => T a = MkT { field :: forall b. (Num a, Show b) => (a, b) }++We want++  field :: forall a. Ord a => T a -> forall b. (Num a, Show b) => (a, b)++Note [Naughty record selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A "naughty" field is one for which we can't define a record+selector, because an existential type variable would escape.  For example:+        data T = forall a. MkT { x,y::a }+We obviously can't define+        x (MkT v _) = v+Nevertheless we *do* put a RecSelId into the type environment+so that if the user tries to use 'x' as a selector we can bleat+helpfully, rather than saying unhelpfully that 'x' is not in scope.+Hence the sel_naughty flag, to identify record selectors that don't really exist.++In general, a field is "naughty" if its type mentions a type variable that+isn't in the result type of the constructor.  Note that this *allows*+GADT record selectors (Note [GADT record selectors]) whose types may look+like     sel :: T [a] -> a++For naughty selectors we make a dummy binding+   sel = ()+so that the later type-check will add them to the environment, and they'll be+exported.  The function is never called, because the typechecker spots the+sel_naughty field.++Note [GADT record selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For GADTs, we require that all constructors with a common field 'f' have the same+result type (modulo alpha conversion).  [Checked in TcTyClsDecls.checkValidTyCon]+E.g.+        data T where+          T1 { f :: Maybe a } :: T [a]+          T2 { f :: Maybe a, y :: b  } :: T [a]+          T3 :: T Int++and now the selector takes that result type as its argument:+   f :: forall a. T [a] -> Maybe a++Details: the "real" types of T1,T2 are:+   T1 :: forall r a.   (r~[a]) => a -> T r+   T2 :: forall r a b. (r~[a]) => a -> b -> T r++So the selector loooks like this:+   f :: forall a. T [a] -> Maybe a+   f (a:*) (t:T [a])+     = case t of+         T1 c   (g:[a]~[c]) (v:Maybe c)       -> v `cast` Maybe (right (sym g))+         T2 c d (g:[a]~[c]) (v:Maybe c) (w:d) -> v `cast` Maybe (right (sym g))+         T3 -> error "T3 does not have field f"++Note the forall'd tyvars of the selector are just the free tyvars+of the result type; there may be other tyvars in the constructor's+type (e.g. 'b' in T2).++Note the need for casts in the result!++Note [Selector running example]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's OK to combine GADTs and type families.  Here's a running example:++        data instance T [a] where+          T1 { fld :: b } :: T [Maybe b]++The representation type looks like this+        data :R7T a where+          T1 { fld :: b } :: :R7T (Maybe b)++and there's coercion from the family type to the representation type+        :CoR7T a :: T [a] ~ :R7T a++The selector we want for fld looks like this:++        fld :: forall b. T [Maybe b] -> b+        fld = /\b. \(d::T [Maybe b]).+              case d `cast` :CoR7T (Maybe b) of+                T1 (x::b) -> x++The scrutinee of the case has type :R7T (Maybe b), which can be+gotten by appying the eq_spec to the univ_tvs of the data con.++-}
+ compiler/typecheck/TcTypeNats.hs view
@@ -0,0 +1,992 @@+{-# LANGUAGE LambdaCase #-}++module TcTypeNats+  ( typeNatTyCons+  , typeNatCoAxiomRules+  , BuiltInSynFamily(..)++    -- If you define a new built-in type family, make sure to export its TyCon+    -- from here as well.+    -- See Note [Adding built-in type families]+  , typeNatAddTyCon+  , typeNatMulTyCon+  , typeNatExpTyCon+  , typeNatLeqTyCon+  , typeNatSubTyCon+  , typeNatDivTyCon+  , typeNatModTyCon+  , typeNatLogTyCon+  , typeNatCmpTyCon+  , typeSymbolCmpTyCon+  , typeSymbolAppendTyCon+  ) where++import GhcPrelude++import Type+import Pair+import TcType     ( TcType, tcEqType )+import TyCon      ( TyCon, FamTyConFlav(..), mkFamilyTyCon+                  , Injectivity(..) )+import Coercion   ( Role(..) )+import TcRnTypes  ( Xi )+import CoAxiom    ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn )+import Name       ( Name, BuiltInSyntax(..) )+import TysWiredIn+import TysPrim    ( mkTemplateAnonTyConBinders )+import PrelNames  ( gHC_TYPELITS+                  , gHC_TYPENATS+                  , typeNatAddTyFamNameKey+                  , typeNatMulTyFamNameKey+                  , typeNatExpTyFamNameKey+                  , typeNatLeqTyFamNameKey+                  , typeNatSubTyFamNameKey+                  , typeNatDivTyFamNameKey+                  , typeNatModTyFamNameKey+                  , typeNatLogTyFamNameKey+                  , typeNatCmpTyFamNameKey+                  , typeSymbolCmpTyFamNameKey+                  , typeSymbolAppendFamNameKey+                  )+import FastString ( FastString+                  , fsLit, nilFS, nullFS, unpackFS, mkFastString, appendFS+                  )+import qualified Data.Map as Map+import Data.Maybe ( isJust )+import Control.Monad ( guard )+import Data.List  ( isPrefixOf, isSuffixOf )++{-+Note [Type-level literals]+~~~~~~~~~~~~~~~~~~~~~~~~~~+There are currently two forms of type-level literals: natural numbers, and+symbols (even though this module is named TcTypeNats, it covers both).++Type-level literals are supported by CoAxiomRules (conditional axioms), which+power the built-in type families (see Note [Adding built-in type families]).+Currently, all built-in type families are for the express purpose of supporting+type-level literals.++See also the Wiki page:++    https://gitlab.haskell.org/ghc/ghc/wikis/type-nats++Note [Adding built-in type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are a few steps to adding a built-in type family:++* Adding a unique for the type family TyCon++  These go in PrelNames. It will likely be of the form+  @myTyFamNameKey = mkPreludeTyConUnique xyz@, where @xyz@ is a number that+  has not been chosen before in PrelNames. There are several examples already+  in PrelNames—see, for instance, typeNatAddTyFamNameKey.++* Adding the type family TyCon itself++  This goes in TcTypeNats. There are plenty of examples of how to define+  these—see, for instance, typeNatAddTyCon.++  Once your TyCon has been defined, be sure to:++  - Export it from TcTypeNats. (Not doing so caused #14632.)+  - Include it in the typeNatTyCons list, defined in TcTypeNats.++* Exposing associated type family axioms++  When defining the type family TyCon, you will need to define an axiom for+  the type family in general (see, for instance, axAddDef), and perhaps other+  auxiliary axioms for special cases of the type family (see, for instance,+  axAdd0L and axAdd0R).++  After you have defined all of these axioms, be sure to include them in the+  typeNatCoAxiomRules list, defined in TcTypeNats.+  (Not doing so caused #14934.)++* Define the type family somewhere++  Finally, you will need to define the type family somewhere, likely in @base@.+  Currently, all of the built-in type families are defined in GHC.TypeLits or+  GHC.TypeNats, so those are likely candidates.++  Since the behavior of your built-in type family is specified in TcTypeNats,+  you should give an open type family definition with no instances, like so:++    type family MyTypeFam (m :: Nat) (n :: Nat) :: Nat++  Changing the argument and result kinds as appropriate.++* Update the relevant test cases++  The GHC test suite will likely need to be updated after you add your built-in+  type family. For instance:++  - The T9181 test prints the :browse contents of GHC.TypeLits, so if you added+    a test there, the expected output of T9181 will need to change.+  - The TcTypeNatSimple and TcTypeSymbolSimple tests have compile-time unit+    tests, as well as TcTypeNatSimpleRun and TcTypeSymbolSimpleRun, which have+    runtime unit tests. Consider adding further unit tests to those if your+    built-in type family deals with Nats or Symbols, respectively.+-}++{-------------------------------------------------------------------------------+Built-in type constructors for functions on type-level nats+-}++-- The list of built-in type family TyCons that GHC uses.+-- If you define a built-in type family, make sure to add it to this list.+-- See Note [Adding built-in type families]+typeNatTyCons :: [TyCon]+typeNatTyCons =+  [ typeNatAddTyCon+  , typeNatMulTyCon+  , typeNatExpTyCon+  , typeNatLeqTyCon+  , typeNatSubTyCon+  , typeNatDivTyCon+  , typeNatModTyCon+  , typeNatLogTyCon+  , typeNatCmpTyCon+  , typeSymbolCmpTyCon+  , typeSymbolAppendTyCon+  ]++typeNatAddTyCon :: TyCon+typeNatAddTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam      = matchFamAdd+    , sfInteractTop   = interactTopAdd+    , sfInteractInert = interactInertAdd+    }+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "+")+            typeNatAddTyFamNameKey typeNatAddTyCon++typeNatSubTyCon :: TyCon+typeNatSubTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam      = matchFamSub+    , sfInteractTop   = interactTopSub+    , sfInteractInert = interactInertSub+    }+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "-")+            typeNatSubTyFamNameKey typeNatSubTyCon++typeNatMulTyCon :: TyCon+typeNatMulTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam      = matchFamMul+    , sfInteractTop   = interactTopMul+    , sfInteractInert = interactInertMul+    }+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "*")+            typeNatMulTyFamNameKey typeNatMulTyCon++typeNatDivTyCon :: TyCon+typeNatDivTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam      = matchFamDiv+    , sfInteractTop   = interactTopDiv+    , sfInteractInert = interactInertDiv+    }+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Div")+            typeNatDivTyFamNameKey typeNatDivTyCon++typeNatModTyCon :: TyCon+typeNatModTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam      = matchFamMod+    , sfInteractTop   = interactTopMod+    , sfInteractInert = interactInertMod+    }+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Mod")+            typeNatModTyFamNameKey typeNatModTyCon++++++typeNatExpTyCon :: TyCon+typeNatExpTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam      = matchFamExp+    , sfInteractTop   = interactTopExp+    , sfInteractInert = interactInertExp+    }+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "^")+                typeNatExpTyFamNameKey typeNatExpTyCon++typeNatLogTyCon :: TyCon+typeNatLogTyCon = mkTypeNatFunTyCon1 name+  BuiltInSynFamily+    { sfMatchFam      = matchFamLog+    , sfInteractTop   = interactTopLog+    , sfInteractInert = interactInertLog+    }+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Log2")+            typeNatLogTyFamNameKey typeNatLogTyCon++++typeNatLeqTyCon :: TyCon+typeNatLeqTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])+    boolTy+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    NotInjective++  where+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "<=?")+                typeNatLeqTyFamNameKey typeNatLeqTyCon+  ops = BuiltInSynFamily+    { sfMatchFam      = matchFamLeq+    , sfInteractTop   = interactTopLeq+    , sfInteractInert = interactInertLeq+    }++typeNatCmpTyCon :: TyCon+typeNatCmpTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])+    orderingKind+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    NotInjective++  where+  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "CmpNat")+                typeNatCmpTyFamNameKey typeNatCmpTyCon+  ops = BuiltInSynFamily+    { sfMatchFam      = matchFamCmpNat+    , sfInteractTop   = interactTopCmpNat+    , sfInteractInert = \_ _ _ _ -> []+    }++typeSymbolCmpTyCon :: TyCon+typeSymbolCmpTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ])+    orderingKind+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    NotInjective++  where+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CmpSymbol")+                typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon+  ops = BuiltInSynFamily+    { sfMatchFam      = matchFamCmpSymbol+    , sfInteractTop   = interactTopCmpSymbol+    , sfInteractInert = \_ _ _ _ -> []+    }++typeSymbolAppendTyCon :: TyCon+typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam      = matchFamAppendSymbol+    , sfInteractTop   = interactTopAppendSymbol+    , sfInteractInert = interactInertAppendSymbol+    }+  where+  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "AppendSymbol")+                typeSymbolAppendFamNameKey typeSymbolAppendTyCon++++-- Make a unary built-in constructor of kind: Nat -> Nat+mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon+mkTypeNatFunTyCon1 op tcb =+  mkFamilyTyCon op+    (mkTemplateAnonTyConBinders [ typeNatKind ])+    typeNatKind+    Nothing+    (BuiltInSynFamTyCon tcb)+    Nothing+    NotInjective+++-- Make a binary built-in constructor of kind: Nat -> Nat -> Nat+mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon+mkTypeNatFunTyCon2 op tcb =+  mkFamilyTyCon op+    (mkTemplateAnonTyConBinders [ typeNatKind, typeNatKind ])+    typeNatKind+    Nothing+    (BuiltInSynFamTyCon tcb)+    Nothing+    NotInjective++-- Make a binary built-in constructor of kind: Symbol -> Symbol -> Symbol+mkTypeSymbolFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon+mkTypeSymbolFunTyCon2 op tcb =+  mkFamilyTyCon op+    (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ])+    typeSymbolKind+    Nothing+    (BuiltInSynFamTyCon tcb)+    Nothing+    NotInjective+++{-------------------------------------------------------------------------------+Built-in rules axioms+-------------------------------------------------------------------------------}++-- If you add additional rules, please remember to add them to+-- `typeNatCoAxiomRules` also.+-- See Note [Adding built-in type families]+axAddDef+  , axMulDef+  , axExpDef+  , axLeqDef+  , axCmpNatDef+  , axCmpSymbolDef+  , axAppendSymbolDef+  , axAdd0L+  , axAdd0R+  , axMul0L+  , axMul0R+  , axMul1L+  , axMul1R+  , axExp1L+  , axExp0R+  , axExp1R+  , axLeqRefl+  , axCmpNatRefl+  , axCmpSymbolRefl+  , axLeq0L+  , axSubDef+  , axSub0R+  , axAppendSymbol0R+  , axAppendSymbol0L+  , axDivDef+  , axDiv1+  , axModDef+  , axMod1+  , axLogDef+  :: CoAxiomRule++axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon $+              \x y -> Just $ num (x + y)++axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon $+              \x y -> Just $ num (x * y)++axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon $+              \x y -> Just $ num (x ^ y)++axLeqDef = mkBinAxiom "LeqDef" typeNatLeqTyCon $+              \x y -> Just $ bool (x <= y)++axCmpNatDef   = mkBinAxiom "CmpNatDef" typeNatCmpTyCon+              $ \x y -> Just $ ordering (compare x y)++axCmpSymbolDef =+  CoAxiomRule+    { coaxrName      = fsLit "CmpSymbolDef"+    , coaxrAsmpRoles = [Nominal, Nominal]+    , coaxrRole      = Nominal+    , coaxrProves    = \cs ->+        do [Pair s1 s2, Pair t1 t2] <- return cs+           s2' <- isStrLitTy s2+           t2' <- isStrLitTy t2+           return (mkTyConApp typeSymbolCmpTyCon [s1,t1] ===+                   ordering (compare s2' t2')) }++axAppendSymbolDef = CoAxiomRule+    { coaxrName      = fsLit "AppendSymbolDef"+    , coaxrAsmpRoles = [Nominal, Nominal]+    , coaxrRole      = Nominal+    , coaxrProves    = \cs ->+        do [Pair s1 s2, Pair t1 t2] <- return cs+           s2' <- isStrLitTy s2+           t2' <- isStrLitTy t2+           let z = mkStrLitTy (appendFS s2' t2')+           return (mkTyConApp typeSymbolAppendTyCon [s1, t1] === z)+    }++axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon $+              \x y -> fmap num (minus x y)++axDivDef = mkBinAxiom "DivDef" typeNatDivTyCon $+              \x y -> do guard (y /= 0)+                         return (num (div x y))++axModDef = mkBinAxiom "ModDef" typeNatModTyCon $+              \x y -> do guard (y /= 0)+                         return (num (mod x y))++axLogDef = mkUnAxiom "LogDef" typeNatLogTyCon $+              \x -> do (a,_) <- genLog x 2+                       return (num a)++axAdd0L     = mkAxiom1 "Add0L"    $ \(Pair s t) -> (num 0 .+. s) === t+axAdd0R     = mkAxiom1 "Add0R"    $ \(Pair s t) -> (s .+. num 0) === t+axSub0R     = mkAxiom1 "Sub0R"    $ \(Pair s t) -> (s .-. num 0) === t+axMul0L     = mkAxiom1 "Mul0L"    $ \(Pair s _) -> (num 0 .*. s) === num 0+axMul0R     = mkAxiom1 "Mul0R"    $ \(Pair s _) -> (s .*. num 0) === num 0+axMul1L     = mkAxiom1 "Mul1L"    $ \(Pair s t) -> (num 1 .*. s) === t+axMul1R     = mkAxiom1 "Mul1R"    $ \(Pair s t) -> (s .*. num 1) === t+axDiv1      = mkAxiom1 "Div1"     $ \(Pair s t) -> (tDiv s (num 1) === t)+axMod1      = mkAxiom1 "Mod1"     $ \(Pair s _) -> (tMod s (num 1) === num 0)+                                    -- XXX: Shouldn't we check that _ is 0?+axExp1L     = mkAxiom1 "Exp1L"    $ \(Pair s _) -> (num 1 .^. s) === num 1+axExp0R     = mkAxiom1 "Exp0R"    $ \(Pair s _) -> (s .^. num 0) === num 1+axExp1R     = mkAxiom1 "Exp1R"    $ \(Pair s t) -> (s .^. num 1) === t+axLeqRefl   = mkAxiom1 "LeqRefl"  $ \(Pair s _) -> (s <== s) === bool True+axCmpNatRefl    = mkAxiom1 "CmpNatRefl"+                $ \(Pair s _) -> (cmpNat s s) === ordering EQ+axCmpSymbolRefl = mkAxiom1 "CmpSymbolRefl"+                $ \(Pair s _) -> (cmpSymbol s s) === ordering EQ+axLeq0L     = mkAxiom1 "Leq0L"    $ \(Pair s _) -> (num 0 <== s) === bool True+axAppendSymbol0R  = mkAxiom1 "Concat0R"+            $ \(Pair s t) -> (mkStrLitTy nilFS `appendSymbol` s) === t+axAppendSymbol0L  = mkAxiom1 "Concat0L"+            $ \(Pair s t) -> (s `appendSymbol` mkStrLitTy nilFS) === t++-- The list of built-in type family axioms that GHC uses.+-- If you define new axioms, make sure to include them in this list.+-- See Note [Adding built-in type families]+typeNatCoAxiomRules :: Map.Map FastString CoAxiomRule+typeNatCoAxiomRules = Map.fromList $ map (\x -> (coaxrName x, x))+  [ axAddDef+  , axMulDef+  , axExpDef+  , axLeqDef+  , axCmpNatDef+  , axCmpSymbolDef+  , axAppendSymbolDef+  , axAdd0L+  , axAdd0R+  , axMul0L+  , axMul0R+  , axMul1L+  , axMul1R+  , axExp1L+  , axExp0R+  , axExp1R+  , axLeqRefl+  , axCmpNatRefl+  , axCmpSymbolRefl+  , axLeq0L+  , axSubDef+  , axSub0R+  , axAppendSymbol0R+  , axAppendSymbol0L+  , axDivDef+  , axDiv1+  , axModDef+  , axMod1+  , axLogDef+  ]++++{-------------------------------------------------------------------------------+Various utilities for making axioms and types+-------------------------------------------------------------------------------}++(.+.) :: Type -> Type -> Type+s .+. t = mkTyConApp typeNatAddTyCon [s,t]++(.-.) :: Type -> Type -> Type+s .-. t = mkTyConApp typeNatSubTyCon [s,t]++(.*.) :: Type -> Type -> Type+s .*. t = mkTyConApp typeNatMulTyCon [s,t]++tDiv :: Type -> Type -> Type+tDiv s t = mkTyConApp typeNatDivTyCon [s,t]++tMod :: Type -> Type -> Type+tMod s t = mkTyConApp typeNatModTyCon [s,t]++(.^.) :: Type -> Type -> Type+s .^. t = mkTyConApp typeNatExpTyCon [s,t]++(<==) :: Type -> Type -> Type+s <== t = mkTyConApp typeNatLeqTyCon [s,t]++cmpNat :: Type -> Type -> Type+cmpNat s t = mkTyConApp typeNatCmpTyCon [s,t]++cmpSymbol :: Type -> Type -> Type+cmpSymbol s t = mkTyConApp typeSymbolCmpTyCon [s,t]++appendSymbol :: Type -> Type -> Type+appendSymbol s t = mkTyConApp typeSymbolAppendTyCon [s, t]++(===) :: Type -> Type -> Pair Type+x === y = Pair x y++num :: Integer -> Type+num = mkNumLitTy++bool :: Bool -> Type+bool b = if b then mkTyConApp promotedTrueDataCon []+              else mkTyConApp promotedFalseDataCon []++isBoolLitTy :: Type -> Maybe Bool+isBoolLitTy tc =+  do (tc,[]) <- splitTyConApp_maybe tc+     case () of+       _ | tc == promotedFalseDataCon -> return False+         | tc == promotedTrueDataCon  -> return True+         | otherwise                   -> Nothing++orderingKind :: Kind+orderingKind = mkTyConApp orderingTyCon []++ordering :: Ordering -> Type+ordering o =+  case o of+    LT -> mkTyConApp promotedLTDataCon []+    EQ -> mkTyConApp promotedEQDataCon []+    GT -> mkTyConApp promotedGTDataCon []++isOrderingLitTy :: Type -> Maybe Ordering+isOrderingLitTy tc =+  do (tc1,[]) <- splitTyConApp_maybe tc+     case () of+       _ | tc1 == promotedLTDataCon -> return LT+         | tc1 == promotedEQDataCon -> return EQ+         | tc1 == promotedGTDataCon -> return GT+         | otherwise                -> Nothing++known :: (Integer -> Bool) -> TcType -> Bool+known p x = case isNumLitTy x of+              Just a  -> p a+              Nothing -> False+++mkUnAxiom :: String -> TyCon -> (Integer -> Maybe Type) -> CoAxiomRule+mkUnAxiom str tc f =+  CoAxiomRule+    { coaxrName      = fsLit str+    , coaxrAsmpRoles = [Nominal]+    , coaxrRole      = Nominal+    , coaxrProves    = \cs ->+        do [Pair s1 s2] <- return cs+           s2' <- isNumLitTy s2+           z   <- f s2'+           return (mkTyConApp tc [s1] === z)+    }++++-- For the definitional axioms+mkBinAxiom :: String -> TyCon ->+              (Integer -> Integer -> Maybe Type) -> CoAxiomRule+mkBinAxiom str tc f =+  CoAxiomRule+    { coaxrName      = fsLit str+    , coaxrAsmpRoles = [Nominal, Nominal]+    , coaxrRole      = Nominal+    , coaxrProves    = \cs ->+        do [Pair s1 s2, Pair t1 t2] <- return cs+           s2' <- isNumLitTy s2+           t2' <- isNumLitTy t2+           z   <- f s2' t2'+           return (mkTyConApp tc [s1,t1] === z)+    }++++mkAxiom1 :: String -> (TypeEqn -> TypeEqn) -> CoAxiomRule+mkAxiom1 str f =+  CoAxiomRule+    { coaxrName      = fsLit str+    , coaxrAsmpRoles = [Nominal]+    , coaxrRole      = Nominal+    , coaxrProves    = \case [eqn] -> Just (f eqn)+                             _     -> Nothing+    }+++{-------------------------------------------------------------------------------+Evaluation+-------------------------------------------------------------------------------}++matchFamAdd :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamAdd [s,t]+  | Just 0 <- mbX = Just (axAdd0L, [t], t)+  | Just 0 <- mbY = Just (axAdd0R, [s], s)+  | Just x <- mbX, Just y <- mbY =+    Just (axAddDef, [s,t], num (x + y))+  where mbX = isNumLitTy s+        mbY = isNumLitTy t+matchFamAdd _ = Nothing++matchFamSub :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamSub [s,t]+  | Just 0 <- mbY = Just (axSub0R, [s], s)+  | Just x <- mbX, Just y <- mbY, Just z <- minus x y =+    Just (axSubDef, [s,t], num z)+  where mbX = isNumLitTy s+        mbY = isNumLitTy t+matchFamSub _ = Nothing++matchFamMul :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamMul [s,t]+  | Just 0 <- mbX = Just (axMul0L, [t], num 0)+  | Just 0 <- mbY = Just (axMul0R, [s], num 0)+  | Just 1 <- mbX = Just (axMul1L, [t], t)+  | Just 1 <- mbY = Just (axMul1R, [s], s)+  | Just x <- mbX, Just y <- mbY =+    Just (axMulDef, [s,t], num (x * y))+  where mbX = isNumLitTy s+        mbY = isNumLitTy t+matchFamMul _ = Nothing++matchFamDiv :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamDiv [s,t]+  | Just 1 <- mbY = Just (axDiv1, [s], s)+  | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axDivDef, [s,t], num (div x y))+  where mbX = isNumLitTy s+        mbY = isNumLitTy t+matchFamDiv _ = Nothing++matchFamMod :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamMod [s,t]+  | Just 1 <- mbY = Just (axMod1, [s], num 0)+  | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axModDef, [s,t], num (mod x y))+  where mbX = isNumLitTy s+        mbY = isNumLitTy t+matchFamMod _ = Nothing++++matchFamExp :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamExp [s,t]+  | Just 0 <- mbY = Just (axExp0R, [s], num 1)+  | Just 1 <- mbX = Just (axExp1L, [t], num 1)+  | Just 1 <- mbY = Just (axExp1R, [s], s)+  | Just x <- mbX, Just y <- mbY =+    Just (axExpDef, [s,t], num (x ^ y))+  where mbX = isNumLitTy s+        mbY = isNumLitTy t+matchFamExp _ = Nothing++matchFamLog :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamLog [s]+  | Just x <- mbX, Just (n,_) <- genLog x 2 = Just (axLogDef, [s], num n)+  where mbX = isNumLitTy s+matchFamLog _ = Nothing+++matchFamLeq :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamLeq [s,t]+  | Just 0 <- mbX = Just (axLeq0L, [t], bool True)+  | Just x <- mbX, Just y <- mbY =+    Just (axLeqDef, [s,t], bool (x <= y))+  | tcEqType s t  = Just (axLeqRefl, [s], bool True)+  where mbX = isNumLitTy s+        mbY = isNumLitTy t+matchFamLeq _ = Nothing++matchFamCmpNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamCmpNat [s,t]+  | Just x <- mbX, Just y <- mbY =+    Just (axCmpNatDef, [s,t], ordering (compare x y))+  | tcEqType s t = Just (axCmpNatRefl, [s], ordering EQ)+  where mbX = isNumLitTy s+        mbY = isNumLitTy t+matchFamCmpNat _ = Nothing++matchFamCmpSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamCmpSymbol [s,t]+  | Just x <- mbX, Just y <- mbY =+    Just (axCmpSymbolDef, [s,t], ordering (compare x y))+  | tcEqType s t = Just (axCmpSymbolRefl, [s], ordering EQ)+  where mbX = isStrLitTy s+        mbY = isStrLitTy t+matchFamCmpSymbol _ = Nothing++matchFamAppendSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)+matchFamAppendSymbol [s,t]+  | Just x <- mbX, nullFS x = Just (axAppendSymbol0R, [t], t)+  | Just y <- mbY, nullFS y = Just (axAppendSymbol0L, [s], s)+  | Just x <- mbX, Just y <- mbY =+    Just (axAppendSymbolDef, [s,t], mkStrLitTy (appendFS x y))+  where+  mbX = isStrLitTy s+  mbY = isStrLitTy t+matchFamAppendSymbol _ = Nothing++{-------------------------------------------------------------------------------+Interact with axioms+-------------------------------------------------------------------------------}++interactTopAdd :: [Xi] -> Xi -> [Pair Type]+interactTopAdd [s,t] r+  | Just 0 <- mbZ = [ s === num 0, t === num 0 ]                          -- (s + t ~ 0) => (s ~ 0, t ~ 0)+  | Just x <- mbX, Just z <- mbZ, Just y <- minus z x = [t === num y]     -- (5 + t ~ 8) => (t ~ 3)+  | Just y <- mbY, Just z <- mbZ, Just x <- minus z y = [s === num x]     -- (s + 5 ~ 8) => (s ~ 3)+  where+  mbX = isNumLitTy s+  mbY = isNumLitTy t+  mbZ = isNumLitTy r+interactTopAdd _ _ = []++{-+Note [Weakened interaction rule for subtraction]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++A simpler interaction here might be:++  `s - t ~ r` --> `t + r ~ s`++This would enable us to reuse all the code for addition.+Unfortunately, this works a little too well at the moment.+Consider the following example:++    0 - 5 ~ r --> 5 + r ~ 0 --> (5 = 0, r = 0)++This (correctly) spots that the constraint cannot be solved.++However, this may be a problem if the constraint did not+need to be solved in the first place!  Consider the following example:++f :: Proxy (If (5 <=? 0) (0 - 5) (5 - 0)) -> Proxy 5+f = id++Currently, GHC is strict while evaluating functions, so this does not+work, because even though the `If` should evaluate to `5 - 0`, we+also evaluate the "then" branch which generates the constraint `0 - 5 ~ r`,+which fails.++So, for the time being, we only add an improvement when the RHS is a constant,+which happens to work OK for the moment, although clearly we need to do+something more general.+-}+interactTopSub :: [Xi] -> Xi -> [Pair Type]+interactTopSub [s,t] r+  | Just z <- mbZ = [ s === (num z .+. t) ]         -- (s - t ~ 5) => (5 + t ~ s)+  where+  mbZ = isNumLitTy r+interactTopSub _ _ = []++++++interactTopMul :: [Xi] -> Xi -> [Pair Type]+interactTopMul [s,t] r+  | Just 1 <- mbZ = [ s === num 1, t === num 1 ]                        -- (s * t ~ 1)  => (s ~ 1, t ~ 1)+  | Just x <- mbX, Just z <- mbZ, Just y <- divide z x = [t === num y]  -- (3 * t ~ 15) => (t ~ 5)+  | Just y <- mbY, Just z <- mbZ, Just x <- divide z y = [s === num x]  -- (s * 3 ~ 15) => (s ~ 5)+  where+  mbX = isNumLitTy s+  mbY = isNumLitTy t+  mbZ = isNumLitTy r+interactTopMul _ _ = []++interactTopDiv :: [Xi] -> Xi -> [Pair Type]+interactTopDiv _ _ = []   -- I can't think of anything...++interactTopMod :: [Xi] -> Xi -> [Pair Type]+interactTopMod _ _ = []   -- I can't think of anything...++interactTopExp :: [Xi] -> Xi -> [Pair Type]+interactTopExp [s,t] r+  | Just 0 <- mbZ = [ s === num 0 ]                                       -- (s ^ t ~ 0) => (s ~ 0)+  | Just x <- mbX, Just z <- mbZ, Just y <- logExact  z x = [t === num y] -- (2 ^ t ~ 8) => (t ~ 3)+  | Just y <- mbY, Just z <- mbZ, Just x <- rootExact z y = [s === num x] -- (s ^ 2 ~ 9) => (s ~ 3)+  where+  mbX = isNumLitTy s+  mbY = isNumLitTy t+  mbZ = isNumLitTy r+interactTopExp _ _ = []++interactTopLog :: [Xi] -> Xi -> [Pair Type]+interactTopLog _ _ = []   -- I can't think of anything...++++interactTopLeq :: [Xi] -> Xi -> [Pair Type]+interactTopLeq [s,t] r+  | Just 0 <- mbY, Just True <- mbZ = [ s === num 0 ]                     -- (s <= 0) => (s ~ 0)+  where+  mbY = isNumLitTy t+  mbZ = isBoolLitTy r+interactTopLeq _ _ = []++interactTopCmpNat :: [Xi] -> Xi -> [Pair Type]+interactTopCmpNat [s,t] r+  | Just EQ <- isOrderingLitTy r = [ s === t ]+interactTopCmpNat _ _ = []++interactTopCmpSymbol :: [Xi] -> Xi -> [Pair Type]+interactTopCmpSymbol [s,t] r+  | Just EQ <- isOrderingLitTy r = [ s === t ]+interactTopCmpSymbol _ _ = []++interactTopAppendSymbol :: [Xi] -> Xi -> [Pair Type]+interactTopAppendSymbol [s,t] r+  -- (AppendSymbol a b ~ "") => (a ~ "", b ~ "")+  | Just z <- mbZ, nullFS z =+    [s === mkStrLitTy nilFS, t === mkStrLitTy nilFS ]++  -- (AppendSymbol "foo" b ~ "foobar") => (b ~ "bar")+  | Just x <- fmap unpackFS mbX, Just z <- fmap unpackFS mbZ, x `isPrefixOf` z =+    [ t === mkStrLitTy (mkFastString $ drop (length x) z) ]++  -- (AppendSymbol f "bar" ~ "foobar") => (f ~ "foo")+  | Just y <- fmap unpackFS mbY, Just z <- fmap unpackFS mbZ, y `isSuffixOf` z =+    [ t === mkStrLitTy (mkFastString $ take (length z - length y) z) ]++  where+  mbX = isStrLitTy s+  mbY = isStrLitTy t+  mbZ = isStrLitTy r++interactTopAppendSymbol _ _ = []++{-------------------------------------------------------------------------------+Interaction with inerts+-------------------------------------------------------------------------------}++interactInertAdd :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]+interactInertAdd [x1,y1] z1 [x2,y2] z2+  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]+  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]+  where sameZ = tcEqType z1 z2+interactInertAdd _ _ _ _ = []++interactInertSub :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]+interactInertSub [x1,y1] z1 [x2,y2] z2+  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]+  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]+  where sameZ = tcEqType z1 z2+interactInertSub _ _ _ _ = []++interactInertMul :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]+interactInertMul [x1,y1] z1 [x2,y2] z2+  | sameZ && known (/= 0) x1 && tcEqType x1 x2 = [ y1 === y2 ]+  | sameZ && known (/= 0) y1 && tcEqType y1 y2 = [ x1 === x2 ]+  where sameZ   = tcEqType z1 z2++interactInertMul _ _ _ _ = []++interactInertDiv :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]+interactInertDiv _ _ _ _ = []++interactInertMod :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]+interactInertMod _ _ _ _ = []++interactInertExp :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]+interactInertExp [x1,y1] z1 [x2,y2] z2+  | sameZ && known (> 1) x1 && tcEqType x1 x2 = [ y1 === y2 ]+  | sameZ && known (> 0) y1 && tcEqType y1 y2 = [ x1 === x2 ]+  where sameZ = tcEqType z1 z2++interactInertExp _ _ _ _ = []++interactInertLog :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]+interactInertLog _ _ _ _ = []+++interactInertLeq :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]+interactInertLeq [x1,y1] z1 [x2,y2] z2+  | bothTrue && tcEqType x1 y2 && tcEqType y1 x2 = [ x1 === y1 ]+  | bothTrue && tcEqType y1 x2                 = [ (x1 <== y2) === bool True ]+  | bothTrue && tcEqType y2 x1                 = [ (x2 <== y1) === bool True ]+  where bothTrue = isJust $ do True <- isBoolLitTy z1+                               True <- isBoolLitTy z2+                               return ()++interactInertLeq _ _ _ _ = []+++interactInertAppendSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]+interactInertAppendSymbol [x1,y1] z1 [x2,y2] z2+  | sameZ && tcEqType x1 x2         = [ y1 === y2 ]+  | sameZ && tcEqType y1 y2         = [ x1 === x2 ]+  where sameZ = tcEqType z1 z2+interactInertAppendSymbol _ _ _ _ = []++++{- -----------------------------------------------------------------------------+These inverse functions are used for simplifying propositions using+concrete natural numbers.+----------------------------------------------------------------------------- -}++-- | Subtract two natural numbers.+minus :: Integer -> Integer -> Maybe Integer+minus x y = if x >= y then Just (x - y) else Nothing++-- | Compute the exact logarithm of a natural number.+-- The logarithm base is the second argument.+logExact :: Integer -> Integer -> Maybe Integer+logExact x y = do (z,True) <- genLog x y+                  return z+++-- | Divide two natural numbers.+divide :: Integer -> Integer -> Maybe Integer+divide _ 0  = Nothing+divide x y  = case divMod x y of+                (a,0) -> Just a+                _     -> Nothing++-- | Compute the exact root of a natural number.+-- The second argument specifies which root we are computing.+rootExact :: Integer -> Integer -> Maybe Integer+rootExact x y = do (z,True) <- genRoot x y+                   return z++++{- | Compute the n-th root of a natural number, rounded down to+the closest natural number.  The boolean indicates if the result+is exact (i.e., True means no rounding was done, False means rounded down).+The second argument specifies which root we are computing. -}+genRoot :: Integer -> Integer -> Maybe (Integer, Bool)+genRoot _  0    = Nothing+genRoot x0 1    = Just (x0, True)+genRoot x0 root = Just (search 0 (x0+1))+  where+  search from to = let x = from + div (to - from) 2+                       a = x ^ root+                   in case compare a x0 of+                        EQ              -> (x, True)+                        LT | x /= from  -> search x to+                           | otherwise  -> (from, False)+                        GT | x /= to    -> search from x+                           | otherwise  -> (from, False)++{- | Compute the logarithm of a number in the given base, rounded down to the+closest integer.  The boolean indicates if we the result is exact+(i.e., True means no rounding happened, False means we rounded down).+The logarithm base is the second argument. -}+genLog :: Integer -> Integer -> Maybe (Integer, Bool)+genLog x 0    = if x == 1 then Just (0, True) else Nothing+genLog _ 1    = Nothing+genLog 0 _    = Nothing+genLog x base = Just (exactLoop 0 x)+  where+  exactLoop s i+    | i == 1     = (s,True)+    | i < base   = (s,False)+    | otherwise  =+        let s1 = s + 1+        in s1 `seq` case divMod i base of+                      (j,r)+                        | r == 0    -> exactLoop s1 j+                        | otherwise -> (underLoop s1 j, False)++  underLoop s i+    | i < base  = s+    | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base)
+ compiler/typecheck/TcTypeable.hs view
@@ -0,0 +1,717 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1999+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module TcTypeable(mkTypeableBinds) where++#include "HsVersions.h"++import GhcPrelude++import BasicTypes ( Boxity(..), neverInlinePragma, SourceText(..) )+import TcBinds( addTypecheckedBinds )+import IfaceEnv( newGlobalBinder )+import TyCoRep( Type(..), TyLit(..) )+import TcEnv+import TcEvidence ( mkWpTyApps )+import TcRnMonad+import HscTypes ( lookupId )+import PrelNames+import TysPrim ( primTyCons )+import TysWiredIn ( tupleTyCon, sumTyCon, runtimeRepTyCon+                  , vecCountTyCon, vecElemTyCon+                  , nilDataCon, consDataCon )+import Name+import Id+import Type+import TyCon+import DataCon+import Module+import HsSyn+import DynFlags+import Bag+import Var ( VarBndr(..) )+import CoreMap+import Constants+import Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints)+import Outputable+import FastString ( FastString, mkFastString, fsLit )++import Control.Monad.Trans.State+import Control.Monad.Trans.Class (lift)+import Data.Maybe ( isJust )+import Data.Word( Word64 )++{- Note [Grand plan for Typeable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The overall plan is this:++1. Generate a binding for each module p:M+   (done in TcTypeable by mkModIdBindings)+       M.$trModule :: GHC.Types.Module+       M.$trModule = Module "p" "M"+   ("tr" is short for "type representation"; see GHC.Types)++   We might want to add the filename too.+   This can be used for the lightweight stack-tracing stuff too++   Record the Name M.$trModule in the tcg_tr_module field of TcGblEnv++2. Generate a binding for every data type declaration T in module M,+       M.$tcT :: GHC.Types.TyCon+       M.$tcT = TyCon ...fingerprint info...+                      $trModule+                      "T"+                      0#+                      kind_rep++   Here 0# is the number of arguments expected by the tycon to fully determine+   its kind. kind_rep is a value of type GHC.Types.KindRep, which gives a+   recipe for computing the kind of an instantiation of the tycon (see+   Note [Representing TyCon kinds: KindRep] later in this file for details).++   We define (in TyCon)++        type TyConRepName = Name++   to use for these M.$tcT "tycon rep names". Note that these must be+   treated as "never exported" names by Backpack (see+   Note [Handling never-exported TyThings under Backpack]). Consequently+   they get slightly special treatment in RnModIface.rnIfaceDecl.++3. Record the TyConRepName in T's TyCon, including for promoted+   data and type constructors, and kinds like * and #.++   The TyConRepName is not an "implicit Id".  It's more like a record+   selector: the TyCon knows its name but you have to go to the+   interface file to find its type, value, etc++4. Solve Typeable constraints.  This is done by a custom Typeable solver,+   currently in TcInteract, that use M.$tcT so solve (Typeable T).++There are many wrinkles:++* The timing of when we produce this bindings is rather important: they must be+  defined after the rest of the module has been typechecked since we need to be+  able to lookup Module and TyCon in the type environment and we may be+  currently compiling GHC.Types (where they are defined).++* GHC.Prim doesn't have any associated object code, so we need to put the+  representations for types defined in this module elsewhere. We chose this+  place to be GHC.Types. TcTypeable.mkPrimTypeableBinds is responsible for+  injecting the bindings for the GHC.Prim representions when compiling+  GHC.Types.++* TyCon.tyConRepModOcc is responsible for determining where to find+  the representation binding for a given type. This is where we handle+  the special case for GHC.Prim.++* To save space and reduce dependencies, we need use quite low-level+  representations for TyCon and Module.  See GHC.Types+  Note [Runtime representation of modules and tycons]++* The KindReps can unfortunately get quite large. Moreover, the simplifier will+  float out various pieces of them, resulting in numerous top-level bindings.+  Consequently we mark the KindRep bindings as noinline, ensuring that the+  float-outs don't make it into the interface file. This is important since+  there is generally little benefit to inlining KindReps and they would+  otherwise strongly affect compiler performance.++* In general there are lots of things of kind *, * -> *, and * -> * -> *. To+  reduce the number of bindings we need to produce, we generate their KindReps+  once in GHC.Types. These are referred to as "built-in" KindReps below.++* Even though KindReps aren't inlined, this scheme still has more of an effect on+  compilation time than I'd like. This is especially true in the case of+  families of type constructors (e.g. tuples and unboxed sums). The problem is+  particularly bad in the case of sums, since each arity-N tycon brings with it+  N promoted datacons, each with a KindRep whose size also scales with N.+  Consequently we currently simply don't allow sums to be Typeable.++  In general we might consider moving some or all of this generation logic back+  to the solver since the performance hit we take in doing this at+  type-definition time is non-trivial and Typeable isn't very widely used. This+  is discussed in #13261.++-}++-- | Generate the Typeable bindings for a module. This is the only+-- entry-point of this module and is invoked by the typechecker driver in+-- 'tcRnSrcDecls'.+--+-- See Note [Grand plan for Typeable] in TcTypeable.+mkTypeableBinds :: TcM TcGblEnv+mkTypeableBinds+  = do { -- Create a binding for $trModule.+         -- Do this before processing any data type declarations,+         -- which need tcg_tr_module to be initialised+       ; tcg_env <- mkModIdBindings+         -- Now we can generate the TyCon representations...+         -- First we handle the primitive TyCons if we are compiling GHC.Types+       ; (tcg_env, prim_todos) <- setGblEnv tcg_env mkPrimTypeableTodos++         -- Then we produce bindings for the user-defined types in this module.+       ; setGblEnv tcg_env $+    do { mod <- getModule+       ; let tycons = filter needs_typeable_binds (tcg_tcs tcg_env)+             mod_id = case tcg_tr_module tcg_env of  -- Should be set by now+                        Just mod_id -> mod_id+                        Nothing     -> pprPanic "tcMkTypeableBinds" (ppr tycons)+       ; traceTc "mkTypeableBinds" (ppr tycons)+       ; this_mod_todos <- todoForTyCons mod mod_id tycons+       ; mkTypeRepTodoBinds (this_mod_todos : prim_todos)+       } }+  where+    needs_typeable_binds tc+      | tc `elem` [runtimeRepTyCon, vecCountTyCon, vecElemTyCon]+      = False+      | otherwise =+          isAlgTyCon tc+       || isDataFamilyTyCon tc+       || isClassTyCon tc+++{- *********************************************************************+*                                                                      *+            Building top-level binding for $trModule+*                                                                      *+********************************************************************* -}++mkModIdBindings :: TcM TcGblEnv+mkModIdBindings+  = do { mod <- getModule+       ; loc <- getSrcSpanM+       ; mod_nm        <- newGlobalBinder mod (mkVarOcc "$trModule") loc+       ; trModuleTyCon <- tcLookupTyCon trModuleTyConName+       ; let mod_id = mkExportedVanillaId mod_nm (mkTyConApp trModuleTyCon [])+       ; mod_bind      <- mkVarBind mod_id <$> mkModIdRHS mod++       ; tcg_env <- tcExtendGlobalValEnv [mod_id] getGblEnv+       ; return (tcg_env { tcg_tr_module = Just mod_id }+                 `addTypecheckedBinds` [unitBag mod_bind]) }++mkModIdRHS :: Module -> TcM (LHsExpr GhcTc)+mkModIdRHS mod+  = do { trModuleDataCon <- tcLookupDataCon trModuleDataConName+       ; trNameLit <- mkTrNameLit+       ; return $ nlHsDataCon trModuleDataCon+                  `nlHsApp` trNameLit (unitIdFS (moduleUnitId mod))+                  `nlHsApp` trNameLit (moduleNameFS (moduleName mod))+       }++{- *********************************************************************+*                                                                      *+                Building type-representation bindings+*                                                                      *+********************************************************************* -}++-- | Information we need about a 'TyCon' to generate its representation. We+-- carry the 'Id' in order to share it between the generation of the @TyCon@ and+-- @KindRep@ bindings.+data TypeableTyCon+    = TypeableTyCon+      { tycon        :: !TyCon+      , tycon_rep_id :: !Id+      }++-- | A group of 'TyCon's in need of type-rep bindings.+data TypeRepTodo+    = TypeRepTodo+      { mod_rep_expr    :: LHsExpr GhcTc    -- ^ Module's typerep binding+      , pkg_fingerprint :: !Fingerprint     -- ^ Package name fingerprint+      , mod_fingerprint :: !Fingerprint     -- ^ Module name fingerprint+      , todo_tycons     :: [TypeableTyCon]+        -- ^ The 'TyCon's in need of bindings kinds+      }+    | ExportedKindRepsTodo [(Kind, Id)]+      -- ^ Build exported 'KindRep' bindings for the given set of kinds.++todoForTyCons :: Module -> Id -> [TyCon] -> TcM TypeRepTodo+todoForTyCons mod mod_id tycons = do+    trTyConTy <- mkTyConTy <$> tcLookupTyCon trTyConTyConName+    let mk_rep_id :: TyConRepName -> Id+        mk_rep_id rep_name = mkExportedVanillaId rep_name trTyConTy++    let typeable_tycons :: [TypeableTyCon]+        typeable_tycons =+            [ TypeableTyCon { tycon = tc''+                            , tycon_rep_id = mk_rep_id rep_name+                            }+            | tc     <- tycons+            , tc'    <- tc : tyConATs tc+              -- We need type representations for any associated types+            , let promoted = map promoteDataCon (tyConDataCons tc')+            , tc''   <- tc' : promoted+              -- Don't make bindings for data-family instance tycons.+              -- Do, however, make them for their promoted datacon (see #13915).+            , not $ isFamInstTyCon tc''+            , Just rep_name <- pure $ tyConRepName_maybe tc''+            , typeIsTypeable $ dropForAlls $ tyConKind tc''+            ]+    return TypeRepTodo { mod_rep_expr    = nlHsVar mod_id+                       , pkg_fingerprint = pkg_fpr+                       , mod_fingerprint = mod_fpr+                       , todo_tycons     = typeable_tycons+                       }+  where+    mod_fpr = fingerprintString $ moduleNameString $ moduleName mod+    pkg_fpr = fingerprintString $ unitIdString $ moduleUnitId mod++todoForExportedKindReps :: [(Kind, Name)] -> TcM TypeRepTodo+todoForExportedKindReps kinds = do+    trKindRepTy <- mkTyConTy <$> tcLookupTyCon kindRepTyConName+    let mkId (k, name) = (k, mkExportedVanillaId name trKindRepTy)+    return $ ExportedKindRepsTodo $ map mkId kinds++-- | Generate TyCon bindings for a set of type constructors+mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv+mkTypeRepTodoBinds [] = getGblEnv+mkTypeRepTodoBinds todos+  = do { stuff <- collect_stuff++         -- First extend the type environment with all of the bindings+         -- which we are going to produce since we may need to refer to them+         -- while generating kind representations (namely, when we want to+         -- represent a TyConApp in a kind, we must be able to look up the+         -- TyCon associated with the applied type constructor).+       ; let produced_bndrs :: [Id]+             produced_bndrs = [ tycon_rep_id+                              | todo@(TypeRepTodo{}) <- todos+                              , TypeableTyCon {..} <- todo_tycons todo+                              ] +++                              [ rep_id+                              | ExportedKindRepsTodo kinds <- todos+                              , (_, rep_id) <- kinds+                              ]+       ; gbl_env <- tcExtendGlobalValEnv produced_bndrs getGblEnv++       ; let mk_binds :: TypeRepTodo -> KindRepM [LHsBinds GhcTc]+             mk_binds todo@(TypeRepTodo {}) =+                 mapM (mkTyConRepBinds stuff todo) (todo_tycons todo)+             mk_binds (ExportedKindRepsTodo kinds) =+                 mkExportedKindReps stuff kinds >> return []++       ; (gbl_env, binds) <- setGblEnv gbl_env+                             $ runKindRepM (mapM mk_binds todos)+       ; return $ gbl_env `addTypecheckedBinds` concat binds }++-- | Generate bindings for the type representation of a wired-in 'TyCon's+-- defined by the virtual "GHC.Prim" module. This is where we inject the+-- representation bindings for these primitive types into "GHC.Types"+--+-- See Note [Grand plan for Typeable] in this module.+mkPrimTypeableTodos :: TcM (TcGblEnv, [TypeRepTodo])+mkPrimTypeableTodos+  = do { mod <- getModule+       ; if mod == gHC_TYPES+           then do { -- Build Module binding for GHC.Prim+                     trModuleTyCon <- tcLookupTyCon trModuleTyConName+                   ; let ghc_prim_module_id =+                             mkExportedVanillaId trGhcPrimModuleName+                                                 (mkTyConTy trModuleTyCon)++                   ; ghc_prim_module_bind <- mkVarBind ghc_prim_module_id+                                             <$> mkModIdRHS gHC_PRIM++                     -- Extend our environment with above+                   ; gbl_env <- tcExtendGlobalValEnv [ghc_prim_module_id]+                                                     getGblEnv+                   ; let gbl_env' = gbl_env `addTypecheckedBinds`+                                    [unitBag ghc_prim_module_bind]++                     -- Build TypeRepTodos for built-in KindReps+                   ; todo1 <- todoForExportedKindReps builtInKindReps+                     -- Build TypeRepTodos for types in GHC.Prim+                   ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id+                                            ghcPrimTypeableTyCons+                   ; return ( gbl_env' , [todo1, todo2])+                   }+           else do gbl_env <- getGblEnv+                   return (gbl_env, [])+       }++-- | This is the list of primitive 'TyCon's for which we must generate bindings+-- in "GHC.Types". This should include all types defined in "GHC.Prim".+--+-- The majority of the types we need here are contained in 'primTyCons'.+-- However, not all of them: in particular unboxed tuples are absent since we+-- don't want to include them in the original name cache. See+-- Note [Built-in syntax and the OrigNameCache] in IfaceEnv for more.+ghcPrimTypeableTyCons :: [TyCon]+ghcPrimTypeableTyCons = concat+    [ [ runtimeRepTyCon, vecCountTyCon, vecElemTyCon, funTyCon ]+    , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE]+    , map sumTyCon [2..mAX_SUM_SIZE]+    , primTyCons+    ]++data TypeableStuff+    = Stuff { dflags         :: DynFlags+            , trTyConDataCon :: DataCon         -- ^ of @TyCon@+            , trNameLit      :: FastString -> LHsExpr GhcTc+                                                -- ^ To construct @TrName@s+              -- The various TyCon and DataCons of KindRep+            , kindRepTyCon           :: TyCon+            , kindRepTyConAppDataCon :: DataCon+            , kindRepVarDataCon      :: DataCon+            , kindRepAppDataCon      :: DataCon+            , kindRepFunDataCon      :: DataCon+            , kindRepTYPEDataCon     :: DataCon+            , kindRepTypeLitSDataCon :: DataCon+            , typeLitSymbolDataCon   :: DataCon+            , typeLitNatDataCon      :: DataCon+            }++-- | Collect various tidbits which we'll need to generate TyCon representations.+collect_stuff :: TcM TypeableStuff+collect_stuff = do+    dflags <- getDynFlags+    trTyConDataCon         <- tcLookupDataCon trTyConDataConName+    kindRepTyCon           <- tcLookupTyCon   kindRepTyConName+    kindRepTyConAppDataCon <- tcLookupDataCon kindRepTyConAppDataConName+    kindRepVarDataCon      <- tcLookupDataCon kindRepVarDataConName+    kindRepAppDataCon      <- tcLookupDataCon kindRepAppDataConName+    kindRepFunDataCon      <- tcLookupDataCon kindRepFunDataConName+    kindRepTYPEDataCon     <- tcLookupDataCon kindRepTYPEDataConName+    kindRepTypeLitSDataCon <- tcLookupDataCon kindRepTypeLitSDataConName+    typeLitSymbolDataCon   <- tcLookupDataCon typeLitSymbolDataConName+    typeLitNatDataCon      <- tcLookupDataCon typeLitNatDataConName+    trNameLit              <- mkTrNameLit+    return Stuff {..}++-- | Lookup the necessary pieces to construct the @trNameLit@. We do this so we+-- can save the work of repeating lookups when constructing many TyCon+-- representations.+mkTrNameLit :: TcM (FastString -> LHsExpr GhcTc)+mkTrNameLit = do+    trNameSDataCon <- tcLookupDataCon trNameSDataConName+    let trNameLit :: FastString -> LHsExpr GhcTc+        trNameLit fs = nlHsPar $ nlHsDataCon trNameSDataCon+                       `nlHsApp` nlHsLit (mkHsStringPrimLit fs)+    return trNameLit++-- | Make Typeable bindings for the given 'TyCon'.+mkTyConRepBinds :: TypeableStuff -> TypeRepTodo+                -> TypeableTyCon -> KindRepM (LHsBinds GhcTc)+mkTyConRepBinds stuff todo (TypeableTyCon {..})+  = do -- Make a KindRep+       let (bndrs, kind) = splitForAllVarBndrs (tyConKind tycon)+       liftTc $ traceTc "mkTyConKindRepBinds"+                        (ppr tycon $$ ppr (tyConKind tycon) $$ ppr kind)+       let ctx = mkDeBruijnContext (map binderVar bndrs)+       kind_rep <- getKindRep stuff ctx kind++       -- Make the TyCon binding+       let tycon_rep_rhs = mkTyConRepTyConRHS stuff todo tycon kind_rep+           tycon_rep_bind = mkVarBind tycon_rep_id tycon_rep_rhs+       return $ unitBag tycon_rep_bind++-- | Here is where we define the set of Typeable types. These exclude type+-- families and polytypes.+tyConIsTypeable :: TyCon -> Bool+tyConIsTypeable tc =+       isJust (tyConRepName_maybe tc)+    && typeIsTypeable (dropForAlls $ tyConKind tc)+      -- Ensure that the kind of the TyCon, with its initial foralls removed,+      -- is representable (e.g. has no higher-rank polymorphism or type+      -- synonyms).++-- | Is a particular 'Type' representable by @Typeable@? Here we look for+-- polytypes and types containing casts (which may be, for instance, a type+-- family).+typeIsTypeable :: Type -> Bool+-- We handle types of the form (TYPE rep) specifically to avoid+-- looping on (tyConIsTypeable RuntimeRep)+typeIsTypeable ty+  | Just ty' <- coreView ty         = typeIsTypeable ty'+typeIsTypeable ty+  | isJust (kindRep_maybe ty)       = True+typeIsTypeable (TyVarTy _)          = True+typeIsTypeable (AppTy a b)          = typeIsTypeable a && typeIsTypeable b+typeIsTypeable (FunTy _ a b)        = typeIsTypeable a && typeIsTypeable b+typeIsTypeable (TyConApp tc args)   = tyConIsTypeable tc+                                   && all typeIsTypeable args+typeIsTypeable (ForAllTy{})         = False+typeIsTypeable (LitTy _)            = True+typeIsTypeable (CastTy{})           = False+typeIsTypeable (CoercionTy{})       = False++-- | Maps kinds to 'KindRep' bindings. This binding may either be defined in+-- some other module (in which case the @Maybe (LHsExpr Id@ will be 'Nothing')+-- or a binding which we generated in the current module (in which case it will+-- be 'Just' the RHS of the binding).+type KindRepEnv = TypeMap (Id, Maybe (LHsExpr GhcTc))++-- | A monad within which we will generate 'KindRep's. Here we keep an+-- environment containing 'KindRep's which we've already generated so we can+-- re-use them opportunistically.+newtype KindRepM a = KindRepM { unKindRepM :: StateT KindRepEnv TcRn a }+                   deriving (Functor, Applicative, Monad)++liftTc :: TcRn a -> KindRepM a+liftTc = KindRepM . lift++-- | We generate @KindRep@s for a few common kinds in @GHC.Types@ so that they+-- can be reused across modules.+builtInKindReps :: [(Kind, Name)]+builtInKindReps =+    [ (star, starKindRepName)+    , (mkVisFunTy star star, starArrStarKindRepName)+    , (mkVisFunTys [star, star] star, starArrStarArrStarKindRepName)+    ]+  where+    star = liftedTypeKind++initialKindRepEnv :: TcRn KindRepEnv+initialKindRepEnv = foldlM add_kind_rep emptyTypeMap builtInKindReps+  where+    add_kind_rep acc (k,n) = do+        id <- tcLookupId n+        return $! extendTypeMap acc k (id, Nothing)++-- | Performed while compiling "GHC.Types" to generate the built-in 'KindRep's.+mkExportedKindReps :: TypeableStuff+                   -> [(Kind, Id)]  -- ^ the kinds to generate bindings for+                   -> KindRepM ()+mkExportedKindReps stuff = mapM_ kindrep_binding+  where+    empty_scope = mkDeBruijnContext []++    kindrep_binding :: (Kind, Id) -> KindRepM ()+    kindrep_binding (kind, rep_bndr) = do+        -- We build the binding manually here instead of using mkKindRepRhs+        -- since the latter would find the built-in 'KindRep's in the+        -- 'KindRepEnv' (by virtue of being in 'initialKindRepEnv').+        rhs <- mkKindRepRhs stuff empty_scope kind+        addKindRepBind empty_scope kind rep_bndr rhs++addKindRepBind :: CmEnv -> Kind -> Id -> LHsExpr GhcTc -> KindRepM ()+addKindRepBind in_scope k bndr rhs =+    KindRepM $ modify' $+    \env -> extendTypeMapWithScope env in_scope k (bndr, Just rhs)++-- | Run a 'KindRepM' and add the produced 'KindRep's to the typechecking+-- environment.+runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a)+runKindRepM (KindRepM action) = do+    kindRepEnv <- initialKindRepEnv+    (res, reps_env) <- runStateT action kindRepEnv+    let rep_binds = foldTypeMap to_bind_pair [] reps_env+        to_bind_pair (bndr, Just rhs) rest = (bndr, rhs) : rest+        to_bind_pair (_, Nothing) rest = rest+    tcg_env <- tcExtendGlobalValEnv (map fst rep_binds) getGblEnv+    let binds = map (uncurry mkVarBind) rep_binds+        tcg_env' = tcg_env `addTypecheckedBinds` [listToBag binds]+    return (tcg_env', res)++-- | Produce or find a 'KindRep' for the given kind.+getKindRep :: TypeableStuff -> CmEnv  -- ^ in-scope kind variables+           -> Kind   -- ^ the kind we want a 'KindRep' for+           -> KindRepM (LHsExpr GhcTc)+getKindRep stuff@(Stuff {..}) in_scope = go+  where+    go :: Kind -> KindRepM (LHsExpr GhcTc)+    go = KindRepM . StateT . go'++    go' :: Kind -> KindRepEnv -> TcRn (LHsExpr GhcTc, KindRepEnv)+    go' k env+        -- Look through type synonyms+      | Just k' <- tcView k = go' k' env++        -- We've already generated the needed KindRep+      | Just (id, _) <- lookupTypeMapWithScope env in_scope k+      = return (nlHsVar id, env)++        -- We need to construct a new KindRep binding+      | otherwise+      = do -- Place a NOINLINE pragma on KindReps since they tend to be quite+           -- large and bloat interface files.+           rep_bndr <- (`setInlinePragma` neverInlinePragma)+                   <$> newSysLocalId (fsLit "$krep") (mkTyConTy kindRepTyCon)++           -- do we need to tie a knot here?+           flip runStateT env $ unKindRepM $ do+               rhs <- mkKindRepRhs stuff in_scope k+               addKindRepBind in_scope k rep_bndr rhs+               return $ nlHsVar rep_bndr++-- | Construct the right-hand-side of the 'KindRep' for the given 'Kind' and+-- in-scope kind variable set.+mkKindRepRhs :: TypeableStuff+             -> CmEnv       -- ^ in-scope kind variables+             -> Kind        -- ^ the kind we want a 'KindRep' for+             -> KindRepM (LHsExpr GhcTc) -- ^ RHS expression+mkKindRepRhs stuff@(Stuff {..}) in_scope = new_kind_rep+  where+    new_kind_rep k+        -- We handle (TYPE LiftedRep) etc separately to make it+        -- clear to consumers (e.g. serializers) that there is+        -- a loop here (as TYPE :: RuntimeRep -> TYPE 'LiftedRep)+      | not (tcIsConstraintKind k)+              -- Typeable respects the Constraint/Type distinction+              -- so do not follow the special case here+      , Just arg <- kindRep_maybe k+      , Just (tc, []) <- splitTyConApp_maybe arg+      , Just dc <- isPromotedDataCon_maybe tc+      = return $ nlHsDataCon kindRepTYPEDataCon `nlHsApp` nlHsDataCon dc++    new_kind_rep (TyVarTy v)+      | Just idx <- lookupCME in_scope v+      = return $ nlHsDataCon kindRepVarDataCon+                 `nlHsApp` nlHsIntLit (fromIntegral idx)+      | otherwise+      = pprPanic "mkTyConKindRepBinds.go(tyvar)" (ppr v)++    new_kind_rep (AppTy t1 t2)+      = do rep1 <- getKindRep stuff in_scope t1+           rep2 <- getKindRep stuff in_scope t2+           return $ nlHsDataCon kindRepAppDataCon+                    `nlHsApp` rep1 `nlHsApp` rep2++    new_kind_rep k@(TyConApp tc tys)+      | Just rep_name <- tyConRepName_maybe tc+      = do rep_id <- liftTc $ lookupId rep_name+           tys' <- mapM (getKindRep stuff in_scope) tys+           return $ nlHsDataCon kindRepTyConAppDataCon+                    `nlHsApp` nlHsVar rep_id+                    `nlHsApp` mkList (mkTyConTy kindRepTyCon) tys'+      | otherwise+      = pprPanic "mkTyConKindRepBinds(TyConApp)" (ppr tc $$ ppr k)++    new_kind_rep (ForAllTy (Bndr var _) ty)+      = pprPanic "mkTyConKindRepBinds(ForAllTy)" (ppr var $$ ppr ty)++    new_kind_rep (FunTy _ t1 t2)+      = do rep1 <- getKindRep stuff in_scope t1+           rep2 <- getKindRep stuff in_scope t2+           return $ nlHsDataCon kindRepFunDataCon+                    `nlHsApp` rep1 `nlHsApp` rep2++    new_kind_rep (LitTy (NumTyLit n))+      = return $ nlHsDataCon kindRepTypeLitSDataCon+                 `nlHsApp` nlHsDataCon typeLitNatDataCon+                 `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show n)++    new_kind_rep (LitTy (StrTyLit s))+      = return $ nlHsDataCon kindRepTypeLitSDataCon+                 `nlHsApp` nlHsDataCon typeLitSymbolDataCon+                 `nlHsApp` nlHsLit (mkHsStringPrimLit $ mkFastString $ show s)++    new_kind_rep (CastTy ty co)+      = pprPanic "mkTyConKindRepBinds.go(cast)" (ppr ty $$ ppr co)++    new_kind_rep (CoercionTy co)+      = pprPanic "mkTyConKindRepBinds.go(coercion)" (ppr co)++-- | Produce the right-hand-side of a @TyCon@ representation.+mkTyConRepTyConRHS :: TypeableStuff -> TypeRepTodo+                   -> TyCon      -- ^ the 'TyCon' we are producing a binding for+                   -> LHsExpr GhcTc -- ^ its 'KindRep'+                   -> LHsExpr GhcTc+mkTyConRepTyConRHS (Stuff {..}) todo tycon kind_rep+  =           nlHsDataCon trTyConDataCon+    `nlHsApp` nlHsLit (word64 dflags high)+    `nlHsApp` nlHsLit (word64 dflags low)+    `nlHsApp` mod_rep_expr todo+    `nlHsApp` trNameLit (mkFastString tycon_str)+    `nlHsApp` nlHsLit (int n_kind_vars)+    `nlHsApp` kind_rep+  where+    n_kind_vars = length $ filter isNamedTyConBinder (tyConBinders tycon)+    tycon_str = add_tick (occNameString (getOccName tycon))+    add_tick s | isPromotedDataCon tycon = '\'' : s+               | otherwise               = s++    -- This must match the computation done in+    -- Data.Typeable.Internal.mkTyConFingerprint.+    Fingerprint high low = fingerprintFingerprints [ pkg_fingerprint todo+                                                   , mod_fingerprint todo+                                                   , fingerprintString tycon_str+                                                   ]++    int :: Int -> HsLit GhcTc+    int n = HsIntPrim (SourceText $ show n) (toInteger n)++word64 :: DynFlags -> Word64 -> HsLit GhcTc+word64 dflags n+  | wORD_SIZE dflags == 4 = HsWord64Prim NoSourceText (toInteger n)+  | otherwise             = HsWordPrim   NoSourceText (toInteger n)++{-+Note [Representing TyCon kinds: KindRep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+One of the operations supported by Typeable is typeRepKind,++    typeRepKind :: TypeRep (a :: k) -> TypeRep k++Implementing this is a bit tricky for poly-kinded types like++    data Proxy (a :: k) :: Type+    -- Proxy :: forall k. k -> Type++The TypeRep encoding of `Proxy Type Int` looks like this:++    $tcProxy :: GHC.Types.TyCon+    $trInt   :: TypeRep Int+    TrType   :: TypeRep Type++    $trProxyType :: TypeRep (Proxy Type :: Type -> Type)+    $trProxyType = TrTyCon $tcProxy+                           [TrType]  -- kind variable instantiation+                           (tyConKind $tcProxy [TrType]) -- The TypeRep of+                                                         -- Type -> Type++    $trProxy :: TypeRep (Proxy Type Int)+    $trProxy = TrApp $trProxyType $trInt TrType++    $tkProxy :: GHC.Types.KindRep+    $tkProxy = KindRepFun (KindRepVar 0)+                          (KindRepTyConApp (KindRepTYPE LiftedRep) [])++Note how $trProxyType cannot use 'TrApp', because TypeRep cannot represent+polymorphic types.  So instead++ * $trProxyType uses 'TrTyCon' to apply Proxy to (the representations)+   of all its kind arguments. We can't represent a tycon that is+   applied to only some of its kind arguments.++ * In $tcProxy, the GHC.Types.TyCon structure for Proxy, we store a+   GHC.Types.KindRep, which represents the polymorphic kind of Proxy+       Proxy :: forall k. k->Type++ * A KindRep is just a recipe that we can instantiate with the+   argument kinds, using Data.Typeable.Internal.tyConKind and+   store in the relevant 'TypeRep' constructor.++   Data.Typeable.Internal.typeRepKind looks up the stored kinds.++ * In a KindRep, the kind variables are represented by 0-indexed+   de Bruijn numbers:++    type KindBndr = Int   -- de Bruijn index++    data KindRep = KindRepTyConApp TyCon [KindRep]+                 | KindRepVar !KindBndr+                 | KindRepApp KindRep KindRep+                 | KindRepFun KindRep KindRep+                 ...+-}++mkList :: Type -> [LHsExpr GhcTc] -> LHsExpr GhcTc+mkList ty = foldr consApp (nilExpr ty)+  where+    cons = consExpr ty+    consApp :: LHsExpr GhcTc -> LHsExpr GhcTc -> LHsExpr GhcTc+    consApp x xs = cons `nlHsApp` x `nlHsApp` xs++    nilExpr :: Type -> LHsExpr GhcTc+    nilExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon nilDataCon)++    consExpr :: Type -> LHsExpr GhcTc+    consExpr ty = mkLHsWrap (mkWpTyApps [ty]) (nlHsDataCon consDataCon)
+ compiler/typecheck/TcUnify.hs view
@@ -0,0 +1,2254 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Type subsumption and unification+-}++{-# LANGUAGE CPP, MultiWayIf, TupleSections, ScopedTypeVariables #-}++module TcUnify (+  -- Full-blown subsumption+  tcWrapResult, tcWrapResultO, tcSkolemise, tcSkolemiseET,+  tcSubTypeHR, tcSubTypeO, tcSubType_NC, tcSubTypeDS,+  tcSubTypeDS_NC_O, tcSubTypeET,+  checkConstraints, checkTvConstraints,+  buildImplicationFor, emitResidualTvConstraint,++  -- Various unifications+  unifyType, unifyKind,+  uType, promoteTcType,+  swapOverTyVars, canSolveByUnification,++  --------------------------------+  -- Holes+  tcInferInst, tcInferNoInst,+  matchExpectedListTy,+  matchExpectedTyConApp,+  matchExpectedAppTy,+  matchExpectedFunTys,+  matchActualFunTys, matchActualFunTysPart,+  matchExpectedFunKind,++  metaTyVarUpdateOK, occCheckForErrors, MetaTyVarUpdateResult(..)++  ) where++#include "HsVersions.h"++import GhcPrelude++import HsSyn+import TyCoRep+import TcMType+import TcRnMonad+import TcType+import Type+import Coercion+import TcEvidence+import Name( isSystemName )+import Inst+import TyCon+import TysWiredIn+import TysPrim( tYPE )+import Var+import VarSet+import VarEnv+import ErrUtils+import DynFlags+import BasicTypes+import Bag+import Util+import qualified GHC.LanguageExtensions as LangExt+import Outputable++import Control.Monad+import Control.Arrow ( second )++{-+************************************************************************+*                                                                      *+             matchExpected functions+*                                                                      *+************************************************************************++Note [Herald for matchExpectedFunTys]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The 'herald' always looks like:+   "The equation(s) for 'f' have"+   "The abstraction (\x.e) takes"+   "The section (+ x) expects"+   "The function 'f' is applied to"++This is used to construct a message of form++   The abstraction `\Just 1 -> ...' takes two arguments+   but its type `Maybe a -> a' has only one++   The equation(s) for `f' have two arguments+   but its type `Maybe a -> a' has only one++   The section `(f 3)' requires 'f' to take two arguments+   but its type `Int -> Int' has only one++   The function 'f' is applied to two arguments+   but its type `Int -> Int' has only one++When visible type applications (e.g., `f @Int 1 2`, as in #13902) enter the+picture, we have a choice in deciding whether to count the type applications as+proper arguments:++   The function 'f' is applied to one visible type argument+     and two value arguments+   but its type `forall a. a -> a` has only one visible type argument+     and one value argument++Or whether to include the type applications as part of the herald itself:++   The expression 'f @Int' is applied to two arguments+   but its type `Int -> Int` has only one++The latter is easier to implement and is arguably easier to understand, so we+choose to implement that option.++Note [matchExpectedFunTys]+~~~~~~~~~~~~~~~~~~~~~~~~~~+matchExpectedFunTys checks that a sigma has the form+of an n-ary function.  It passes the decomposed type to the+thing_inside, and returns a wrapper to coerce between the two types++It's used wherever a language construct must have a functional type,+namely:+        A lambda expression+        A function definition+     An operator section++This function must be written CPS'd because it needs to fill in the+ExpTypes produced for arguments before it can fill in the ExpType+passed in.++-}++-- Use this one when you have an "expected" type.+matchExpectedFunTys :: forall a.+                       SDoc   -- See Note [Herald for matchExpectedFunTys]+                    -> Arity+                    -> ExpRhoType  -- deeply skolemised+                    -> ([ExpSigmaType] -> ExpRhoType -> TcM a)+                          -- must fill in these ExpTypes here+                    -> TcM (a, HsWrapper)+-- If    matchExpectedFunTys n ty = (_, wrap)+-- then  wrap : (t1 -> ... -> tn -> ty_r) ~> ty,+--   where [t1, ..., tn], ty_r are passed to the thing_inside+matchExpectedFunTys herald arity orig_ty thing_inside+  = case orig_ty of+      Check ty -> go [] arity ty+      _        -> defer [] arity orig_ty+  where+    go acc_arg_tys 0 ty+      = do { result <- thing_inside (reverse acc_arg_tys) (mkCheckExpType ty)+           ; return (result, idHsWrapper) }++    go acc_arg_tys n ty+      | Just ty' <- tcView ty = go acc_arg_tys n ty'++    go acc_arg_tys n (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty })+      = ASSERT( af == VisArg )+        do { (result, wrap_res) <- go (mkCheckExpType arg_ty : acc_arg_tys)+                                      (n-1) res_ty+           ; return ( result+                    , mkWpFun idHsWrapper wrap_res arg_ty res_ty doc ) }+      where+        doc = text "When inferring the argument type of a function with type" <+>+              quotes (ppr orig_ty)++    go acc_arg_tys n ty@(TyVarTy tv)+      | isMetaTyVar tv+      = do { cts <- readMetaTyVar tv+           ; case cts of+               Indirect ty' -> go acc_arg_tys n ty'+               Flexi        -> defer acc_arg_tys n (mkCheckExpType ty) }++       -- In all other cases we bale out into ordinary unification+       -- However unlike the meta-tyvar case, we are sure that the+       -- number of arguments doesn't match arity of the original+       -- type, so we can add a bit more context to the error message+       -- (cf #7869).+       --+       -- It is not always an error, because specialized type may have+       -- different arity, for example:+       --+       -- > f1 = f2 'a'+       -- > f2 :: Monad m => m Bool+       -- > f2 = undefined+       --+       -- But in that case we add specialized type into error context+       -- anyway, because it may be useful. See also #9605.+    go acc_arg_tys n ty = addErrCtxtM mk_ctxt $+                          defer acc_arg_tys n (mkCheckExpType ty)++    ------------+    defer :: [ExpSigmaType] -> Arity -> ExpRhoType -> TcM (a, HsWrapper)+    defer acc_arg_tys n fun_ty+      = do { more_arg_tys <- replicateM n newInferExpTypeNoInst+           ; res_ty       <- newInferExpTypeInst+           ; result       <- thing_inside (reverse acc_arg_tys ++ more_arg_tys) res_ty+           ; more_arg_tys <- mapM readExpType more_arg_tys+           ; res_ty       <- readExpType res_ty+           ; let unif_fun_ty = mkVisFunTys more_arg_tys res_ty+           ; wrap <- tcSubTypeDS AppOrigin GenSigCtxt unif_fun_ty fun_ty+                         -- Not a good origin at all :-(+           ; return (result, wrap) }++    ------------+    mk_ctxt :: TidyEnv -> TcM (TidyEnv, MsgDoc)+    mk_ctxt env = do { (env', ty) <- zonkTidyTcType env orig_tc_ty+                     ; let (args, _) = tcSplitFunTys ty+                           n_actual = length args+                           (env'', orig_ty') = tidyOpenType env' orig_tc_ty+                     ; return ( env''+                              , mk_fun_tys_msg orig_ty' ty n_actual arity herald) }+      where+        orig_tc_ty = checkingExpType "matchExpectedFunTys" orig_ty+            -- this is safe b/c we're called from "go"++-- Like 'matchExpectedFunTys', but used when you have an "actual" type,+-- for example in function application+matchActualFunTys :: SDoc   -- See Note [Herald for matchExpectedFunTys]+                  -> CtOrigin+                  -> Maybe (HsExpr GhcRn)   -- the thing with type TcSigmaType+                  -> Arity+                  -> TcSigmaType+                  -> TcM (HsWrapper, [TcSigmaType], TcSigmaType)+-- If    matchActualFunTys n ty = (wrap, [t1,..,tn], ty_r)+-- then  wrap : ty ~> (t1 -> ... -> tn -> ty_r)+matchActualFunTys herald ct_orig mb_thing arity ty+  = matchActualFunTysPart herald ct_orig mb_thing arity ty [] arity++-- | Variant of 'matchActualFunTys' that works when supplied only part+-- (that is, to the right of some arrows) of the full function type+matchActualFunTysPart :: SDoc -- See Note [Herald for matchExpectedFunTys]+                      -> CtOrigin+                      -> Maybe (HsExpr GhcRn)  -- the thing with type TcSigmaType+                      -> Arity+                      -> TcSigmaType+                      -> [TcSigmaType] -- reversed args. See (*) below.+                      -> Arity   -- overall arity of the function, for errs+                      -> TcM (HsWrapper, [TcSigmaType], TcSigmaType)+matchActualFunTysPart herald ct_orig mb_thing arity orig_ty+                      orig_old_args full_arity+  = go arity orig_old_args orig_ty+-- Does not allocate unnecessary meta variables: if the input already is+-- a function, we just take it apart.  Not only is this efficient,+-- it's important for higher rank: the argument might be of form+--              (forall a. ty) -> other+-- If allocated (fresh-meta-var1 -> fresh-meta-var2) and unified, we'd+-- hide the forall inside a meta-variable++-- (*) Sometimes it's necessary to call matchActualFunTys with only part+-- (that is, to the right of some arrows) of the type of the function in+-- question. (See TcExpr.tcArgs.) This argument is the reversed list of+-- arguments already seen (that is, not part of the TcSigmaType passed+-- in elsewhere).++  where+    -- This function has a bizarre mechanic: it accumulates arguments on+    -- the way down and also builds an argument list on the way up. Why:+    -- 1. The returns args list and the accumulated args list might be different.+    --    The accumulated args include all the arg types for the function,+    --    including those from before this function was called. The returned+    --    list should include only those arguments produced by this call of+    --    matchActualFunTys+    --+    -- 2. The HsWrapper can be built only on the way up. It seems (more)+    --    bizarre to build the HsWrapper but not the arg_tys.+    --+    -- Refactoring is welcome.+    go :: Arity+       -> [TcSigmaType] -- accumulator of arguments (reversed)+       -> TcSigmaType   -- the remainder of the type as we're processing+       -> TcM (HsWrapper, [TcSigmaType], TcSigmaType)+    go 0 _ ty = return (idHsWrapper, [], ty)++    go n acc_args ty+      | not (null tvs && null theta)+      = do { (wrap1, rho) <- topInstantiate ct_orig ty+           ; (wrap2, arg_tys, res_ty) <- go n acc_args rho+           ; return (wrap2 <.> wrap1, arg_tys, res_ty) }+      where+        (tvs, theta, _) = tcSplitSigmaTy ty++    go n acc_args ty+      | Just ty' <- tcView ty = go n acc_args ty'++    go n acc_args (FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty })+      = ASSERT( af == VisArg )+        do { (wrap_res, tys, ty_r) <- go (n-1) (arg_ty : acc_args) res_ty+           ; return ( mkWpFun idHsWrapper wrap_res arg_ty ty_r doc+                    , arg_ty : tys, ty_r ) }+      where+        doc = text "When inferring the argument type of a function with type" <+>+              quotes (ppr orig_ty)++    go n acc_args ty@(TyVarTy tv)+      | isMetaTyVar tv+      = do { cts <- readMetaTyVar tv+           ; case cts of+               Indirect ty' -> go n acc_args ty'+               Flexi        -> defer n ty }++       -- In all other cases we bale out into ordinary unification+       -- However unlike the meta-tyvar case, we are sure that the+       -- number of arguments doesn't match arity of the original+       -- type, so we can add a bit more context to the error message+       -- (cf #7869).+       --+       -- It is not always an error, because specialized type may have+       -- different arity, for example:+       --+       -- > f1 = f2 'a'+       -- > f2 :: Monad m => m Bool+       -- > f2 = undefined+       --+       -- But in that case we add specialized type into error context+       -- anyway, because it may be useful. See also #9605.+    go n acc_args ty = addErrCtxtM (mk_ctxt (reverse acc_args) ty) $+                       defer n ty++    ------------+    defer n fun_ty+      = do { arg_tys <- replicateM n newOpenFlexiTyVarTy+           ; res_ty  <- newOpenFlexiTyVarTy+           ; let unif_fun_ty = mkVisFunTys arg_tys res_ty+           ; co <- unifyType mb_thing fun_ty unif_fun_ty+           ; return (mkWpCastN co, arg_tys, res_ty) }++    ------------+    mk_ctxt :: [TcSigmaType] -> TcSigmaType -> TidyEnv -> TcM (TidyEnv, MsgDoc)+    mk_ctxt arg_tys res_ty env+      = do { let ty = mkVisFunTys arg_tys res_ty+           ; (env1, zonked) <- zonkTidyTcType env ty+                   -- zonking might change # of args+           ; let (zonked_args, _) = tcSplitFunTys zonked+                 n_actual         = length zonked_args+                 (env2, unzonked) = tidyOpenType env1 ty+           ; return ( env2+                    , mk_fun_tys_msg unzonked zonked n_actual full_arity herald) }++mk_fun_tys_msg :: TcType  -- the full type passed in (unzonked)+               -> TcType  -- the full type passed in (zonked)+               -> Arity   -- the # of args found+               -> Arity   -- the # of args wanted+               -> SDoc    -- overall herald+               -> SDoc+mk_fun_tys_msg full_ty ty n_args full_arity herald+  = herald <+> speakNOf full_arity (text "argument") <> comma $$+    if n_args == full_arity+      then text "its type is" <+> quotes (pprType full_ty) <>+           comma $$+           text "it is specialized to" <+> quotes (pprType ty)+      else sep [text "but its type" <+> quotes (pprType ty),+                if n_args == 0 then text "has none"+                else text "has only" <+> speakN n_args]++----------------------+matchExpectedListTy :: TcRhoType -> TcM (TcCoercionN, TcRhoType)+-- Special case for lists+matchExpectedListTy exp_ty+ = do { (co, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty+      ; return (co, elt_ty) }++---------------------+matchExpectedTyConApp :: TyCon                -- T :: forall kv1 ... kvm. k1 -> ... -> kn -> *+                      -> TcRhoType            -- orig_ty+                      -> TcM (TcCoercionN,    -- T k1 k2 k3 a b c ~N orig_ty+                              [TcSigmaType])  -- Element types, k1 k2 k3 a b c++-- It's used for wired-in tycons, so we call checkWiredInTyCon+-- Precondition: never called with FunTyCon+-- Precondition: input type :: *+-- Postcondition: (T k1 k2 k3 a b c) is well-kinded++matchExpectedTyConApp tc orig_ty+  = ASSERT(tc /= funTyCon) go orig_ty+  where+    go ty+       | Just ty' <- tcView ty+       = go ty'++    go ty@(TyConApp tycon args)+       | tc == tycon  -- Common case+       = return (mkTcNomReflCo ty, args)++    go (TyVarTy tv)+       | isMetaTyVar tv+       = do { cts <- readMetaTyVar tv+            ; case cts of+                Indirect ty -> go ty+                Flexi       -> defer }++    go _ = defer++    -- If the common case does not occur, instantiate a template+    -- T k1 .. kn t1 .. tm, and unify with the original type+    -- Doing it this way ensures that the types we return are+    -- kind-compatible with T.  For example, suppose we have+    --       matchExpectedTyConApp T (f Maybe)+    -- where data T a = MkT a+    -- Then we don't want to instantiate T's data constructors with+    --    (a::*) ~ Maybe+    -- because that'll make types that are utterly ill-kinded.+    -- This happened in #7368+    defer+      = do { (_, arg_tvs) <- newMetaTyVars (tyConTyVars tc)+           ; traceTc "matchExpectedTyConApp" (ppr tc $$ ppr (tyConTyVars tc) $$ ppr arg_tvs)+           ; let args = mkTyVarTys arg_tvs+                 tc_template = mkTyConApp tc args+           ; co <- unifyType Nothing tc_template orig_ty+           ; return (co, args) }++----------------------+matchExpectedAppTy :: TcRhoType                         -- orig_ty+                   -> TcM (TcCoercion,                   -- m a ~N orig_ty+                           (TcSigmaType, TcSigmaType))  -- Returns m, a+-- If the incoming type is a mutable type variable of kind k, then+-- matchExpectedAppTy returns a new type variable (m: * -> k); note the *.++matchExpectedAppTy orig_ty+  = go orig_ty+  where+    go ty+      | Just ty' <- tcView ty = go ty'++      | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty+      = return (mkTcNomReflCo orig_ty, (fun_ty, arg_ty))++    go (TyVarTy tv)+      | isMetaTyVar tv+      = do { cts <- readMetaTyVar tv+           ; case cts of+               Indirect ty -> go ty+               Flexi       -> defer }++    go _ = defer++    -- Defer splitting by generating an equality constraint+    defer+      = do { ty1 <- newFlexiTyVarTy kind1+           ; ty2 <- newFlexiTyVarTy kind2+           ; co <- unifyType Nothing (mkAppTy ty1 ty2) orig_ty+           ; return (co, (ty1, ty2)) }++    orig_kind = tcTypeKind orig_ty+    kind1 = mkVisFunTy liftedTypeKind orig_kind+    kind2 = liftedTypeKind    -- m :: * -> k+                              -- arg type :: *++{-+************************************************************************+*                                                                      *+                Subsumption checking+*                                                                      *+************************************************************************++Note [Subsumption checking: tcSubType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All the tcSubType calls have the form+                tcSubType actual_ty expected_ty+which checks+                actual_ty <= expected_ty++That is, that a value of type actual_ty is acceptable in+a place expecting a value of type expected_ty.  I.e. that++    actual ty   is more polymorphic than   expected_ty++It returns a coercion function+        co_fn :: actual_ty ~ expected_ty+which takes an HsExpr of type actual_ty into one of type+expected_ty.++These functions do not actually check for subsumption. They check if+expected_ty is an appropriate annotation to use for something of type+actual_ty. This difference matters when thinking about visible type+application. For example,++   forall a. a -> forall b. b -> b+      DOES NOT SUBSUME+   forall a b. a -> b -> b++because the type arguments appear in a different order. (Neither does+it work the other way around.) BUT, these types are appropriate annotations+for one another. Because the user directs annotations, it's OK if some+arguments shuffle around -- after all, it's what the user wants.+Bottom line: none of this changes with visible type application.++There are a number of wrinkles (below).++Notice that Wrinkle 1 and 2 both require eta-expansion, which technically+may increase termination.  We just put up with this, in exchange for getting+more predictable type inference.++Wrinkle 1: Note [Deep skolemisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want   (forall a. Int -> a -> a)  <=  (Int -> forall a. a->a)+(see section 4.6 of "Practical type inference for higher rank types")+So we must deeply-skolemise the RHS before we instantiate the LHS.++That is why tc_sub_type starts with a call to tcSkolemise (which does the+deep skolemisation), and then calls the DS variant (which assumes+that expected_ty is deeply skolemised)++Wrinkle 2: Note [Co/contra-variance of subsumption checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider  g :: (Int -> Int) -> Int+  f1 :: (forall a. a -> a) -> Int+  f1 = g++  f2 :: (forall a. a -> a) -> Int+  f2 x = g x+f2 will typecheck, and it would be odd/fragile if f1 did not.+But f1 will only typecheck if we have that+    (Int->Int) -> Int  <=  (forall a. a->a) -> Int+And that is only true if we do the full co/contravariant thing+in the subsumption check.  That happens in the FunTy case of+tcSubTypeDS_NC_O, and is the sole reason for the WpFun form of+HsWrapper.++Another powerful reason for doing this co/contra stuff is visible+in #9569, involving instantiation of constraint variables,+and again involving eta-expansion.++Wrinkle 3: Note [Higher rank types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider tc150:+  f y = \ (x::forall a. a->a). blah+The following happens:+* We will infer the type of the RHS, ie with a res_ty = alpha.+* Then the lambda will split  alpha := beta -> gamma.+* And then we'll check tcSubType IsSwapped beta (forall a. a->a)++So it's important that we unify beta := forall a. a->a, rather than+skolemising the type.+-}+++-- | Call this variant when you are in a higher-rank situation and+-- you know the right-hand type is deeply skolemised.+tcSubTypeHR :: CtOrigin               -- ^ of the actual type+            -> Maybe (HsExpr GhcRn)   -- ^ If present, it has type ty_actual+            -> TcSigmaType -> ExpRhoType -> TcM HsWrapper+tcSubTypeHR orig = tcSubTypeDS_NC_O orig GenSigCtxt++------------------------+tcSubTypeET :: CtOrigin -> UserTypeCtxt+            -> ExpSigmaType -> TcSigmaType -> TcM HsWrapper+-- If wrap = tc_sub_type_et t1 t2+--    => wrap :: t1 ~> t2+tcSubTypeET orig ctxt (Check ty_actual) ty_expected+  = tc_sub_tc_type eq_orig orig ctxt ty_actual ty_expected+  where+    eq_orig = TypeEqOrigin { uo_actual   = ty_expected+                           , uo_expected = ty_actual+                           , uo_thing    = Nothing+                           , uo_visible  = True }++tcSubTypeET _ _ (Infer inf_res) ty_expected+  = ASSERT2( not (ir_inst inf_res), ppr inf_res $$ ppr ty_expected )+      -- An (Infer inf_res) ExpSigmaType passed into tcSubTypeET never+      -- has the ir_inst field set.  Reason: in patterns (which is what+      -- tcSubTypeET is used for) do not aggressively instantiate+    do { co <- fill_infer_result ty_expected inf_res+               -- Since ir_inst is false, we can skip fillInferResult+               -- and go straight to fill_infer_result++       ; return (mkWpCastN (mkTcSymCo co)) }++------------------------+tcSubTypeO :: CtOrigin      -- ^ of the actual type+           -> UserTypeCtxt  -- ^ of the expected type+           -> TcSigmaType+           -> ExpRhoType+           -> TcM HsWrapper+tcSubTypeO orig ctxt ty_actual ty_expected+  = addSubTypeCtxt ty_actual ty_expected $+    do { traceTc "tcSubTypeDS_O" (vcat [ pprCtOrigin orig+                                       , pprUserTypeCtxt ctxt+                                       , ppr ty_actual+                                       , ppr ty_expected ])+       ; tcSubTypeDS_NC_O orig ctxt Nothing ty_actual ty_expected }++addSubTypeCtxt :: TcType -> ExpType -> TcM a -> TcM a+addSubTypeCtxt ty_actual ty_expected thing_inside+ | isRhoTy ty_actual        -- If there is no polymorphism involved, the+ , isRhoExpTy ty_expected   -- TypeEqOrigin stuff (added by the _NC functions)+ = thing_inside             -- gives enough context by itself+ | otherwise+ = addErrCtxtM mk_msg thing_inside+  where+    mk_msg tidy_env+      = do { (tidy_env, ty_actual)   <- zonkTidyTcType tidy_env ty_actual+                   -- might not be filled if we're debugging. ugh.+           ; mb_ty_expected          <- readExpType_maybe ty_expected+           ; (tidy_env, ty_expected) <- case mb_ty_expected of+                                          Just ty -> second mkCheckExpType <$>+                                                     zonkTidyTcType tidy_env ty+                                          Nothing -> return (tidy_env, ty_expected)+           ; ty_expected             <- readExpType ty_expected+           ; (tidy_env, ty_expected) <- zonkTidyTcType tidy_env ty_expected+           ; let msg = vcat [ hang (text "When checking that:")+                                 4 (ppr ty_actual)+                            , nest 2 (hang (text "is more polymorphic than:")+                                         2 (ppr ty_expected)) ]+           ; return (tidy_env, msg) }++---------------+-- The "_NC" variants do not add a typechecker-error context;+-- the caller is assumed to do that++tcSubType_NC :: UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper+-- Checks that actual <= expected+-- Returns HsWrapper :: actual ~ expected+tcSubType_NC ctxt ty_actual ty_expected+  = do { traceTc "tcSubType_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected])+       ; tc_sub_tc_type origin origin ctxt ty_actual ty_expected }+  where+    origin = TypeEqOrigin { uo_actual   = ty_actual+                          , uo_expected = ty_expected+                          , uo_thing    = Nothing+                          , uo_visible  = True }++tcSubTypeDS :: CtOrigin -> UserTypeCtxt -> TcSigmaType -> ExpRhoType -> TcM HsWrapper+-- Just like tcSubType, but with the additional precondition that+-- ty_expected is deeply skolemised (hence "DS")+tcSubTypeDS orig ctxt ty_actual ty_expected+  = addSubTypeCtxt ty_actual ty_expected $+    do { traceTc "tcSubTypeDS_NC" (vcat [pprUserTypeCtxt ctxt, ppr ty_actual, ppr ty_expected])+       ; tcSubTypeDS_NC_O orig ctxt Nothing ty_actual ty_expected }++tcSubTypeDS_NC_O :: CtOrigin   -- origin used for instantiation only+                 -> UserTypeCtxt+                 -> Maybe (HsExpr GhcRn)+                 -> TcSigmaType -> ExpRhoType -> TcM HsWrapper+-- Just like tcSubType, but with the additional precondition that+-- ty_expected is deeply skolemised+tcSubTypeDS_NC_O inst_orig ctxt m_thing ty_actual ty_expected+  = case ty_expected of+      Infer inf_res -> fillInferResult inst_orig ty_actual inf_res+      Check ty      -> tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty+         where+           eq_orig = TypeEqOrigin { uo_actual = ty_actual, uo_expected = ty+                                  , uo_thing  = ppr <$> m_thing+                                  , uo_visible = True }++---------------+tc_sub_tc_type :: CtOrigin   -- used when calling uType+               -> CtOrigin   -- used when instantiating+               -> UserTypeCtxt -> TcSigmaType -> TcSigmaType -> TcM HsWrapper+-- If wrap = tc_sub_type t1 t2+--    => wrap :: t1 ~> t2+tc_sub_tc_type eq_orig inst_orig ctxt ty_actual ty_expected+  | definitely_poly ty_expected      -- See Note [Don't skolemise unnecessarily]+  , not (possibly_poly ty_actual)+  = do { traceTc "tc_sub_tc_type (drop to equality)" $+         vcat [ text "ty_actual   =" <+> ppr ty_actual+              , text "ty_expected =" <+> ppr ty_expected ]+       ; mkWpCastN <$>+         uType TypeLevel eq_orig ty_actual ty_expected }++  | otherwise   -- This is the general case+  = do { traceTc "tc_sub_tc_type (general case)" $+         vcat [ text "ty_actual   =" <+> ppr ty_actual+              , text "ty_expected =" <+> ppr ty_expected ]+       ; (sk_wrap, inner_wrap) <- tcSkolemise ctxt ty_expected $+                                                   \ _ sk_rho ->+                                  tc_sub_type_ds eq_orig inst_orig ctxt+                                                 ty_actual sk_rho+       ; return (sk_wrap <.> inner_wrap) }+  where+    possibly_poly ty+      | isForAllTy ty                        = True+      | Just (_, res) <- splitFunTy_maybe ty = possibly_poly res+      | otherwise                            = False+      -- NB *not* tcSplitFunTy, because here we want+      -- to decompose type-class arguments too++    definitely_poly ty+      | (tvs, theta, tau) <- tcSplitSigmaTy ty+      , (tv:_) <- tvs+      , null theta+      , isInsolubleOccursCheck NomEq tv tau+      = True+      | otherwise+      = False++{- Note [Don't skolemise unnecessarily]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are trying to solve+    (Char->Char) <= (forall a. a->a)+We could skolemise the 'forall a', and then complain+that (Char ~ a) is insoluble; but that's a pretty obscure+error.  It's better to say that+    (Char->Char) ~ (forall a. a->a)+fails.++So roughly:+ * if the ty_expected has an outermost forall+      (i.e. skolemisation is the next thing we'd do)+ * and the ty_actual has no top-level polymorphism (but looking deeply)+then we can revert to simple equality.  But we need to be careful.+These examples are all fine:++ * (Char -> forall a. a->a) <= (forall a. Char -> a -> a)+      Polymorphism is buried in ty_actual++ * (Char->Char) <= (forall a. Char -> Char)+      ty_expected isn't really polymorphic++ * (Char->Char) <= (forall a. (a~Char) => a -> a)+      ty_expected isn't really polymorphic++ * (Char->Char) <= (forall a. F [a] Char -> Char)+                   where type instance F [x] t = t+     ty_expected isn't really polymorphic++If we prematurely go to equality we'll reject a program we should+accept (e.g. #13752).  So the test (which is only to improve+error message) is very conservative:+ * ty_actual is /definitely/ monomorphic+ * ty_expected is /definitely/ polymorphic+-}++---------------+tc_sub_type_ds :: CtOrigin    -- used when calling uType+               -> CtOrigin    -- used when instantiating+               -> UserTypeCtxt -> TcSigmaType -> TcRhoType -> TcM HsWrapper+-- If wrap = tc_sub_type_ds t1 t2+--    => wrap :: t1 ~> t2+-- Here is where the work actually happens!+-- Precondition: ty_expected is deeply skolemised+tc_sub_type_ds eq_orig inst_orig ctxt ty_actual ty_expected+  = do { traceTc "tc_sub_type_ds" $+         vcat [ text "ty_actual   =" <+> ppr ty_actual+              , text "ty_expected =" <+> ppr ty_expected ]+       ; go ty_actual ty_expected }+  where+    go ty_a ty_e | Just ty_a' <- tcView ty_a = go ty_a' ty_e+                 | Just ty_e' <- tcView ty_e = go ty_a  ty_e'++    go (TyVarTy tv_a) ty_e+      = do { lookup_res <- lookupTcTyVar tv_a+           ; case lookup_res of+               Filled ty_a' ->+                 do { traceTc "tcSubTypeDS_NC_O following filled act meta-tyvar:"+                        (ppr tv_a <+> text "-->" <+> ppr ty_a')+                    ; tc_sub_type_ds eq_orig inst_orig ctxt ty_a' ty_e }+               Unfilled _   -> unify }++    -- Historical note (Sept 16): there was a case here for+    --    go ty_a (TyVarTy alpha)+    -- which, in the impredicative case unified  alpha := ty_a+    -- where th_a is a polytype.  Not only is this probably bogus (we+    -- simply do not have decent story for impredicative types), but it+    -- caused #12616 because (also bizarrely) 'deriving' code had+    -- -XImpredicativeTypes on.  I deleted the entire case.++    go (FunTy { ft_af = VisArg, ft_arg = act_arg, ft_res = act_res })+       (FunTy { ft_af = VisArg, ft_arg = exp_arg, ft_res = exp_res })+      = -- See Note [Co/contra-variance of subsumption checking]+        do { res_wrap <- tc_sub_type_ds eq_orig inst_orig  ctxt       act_res exp_res+           ; arg_wrap <- tc_sub_tc_type eq_orig given_orig GenSigCtxt exp_arg act_arg+                         -- GenSigCtxt: See Note [Setting the argument context]+           ; return (mkWpFun arg_wrap res_wrap exp_arg exp_res doc) }+               -- arg_wrap :: exp_arg ~> act_arg+               -- res_wrap :: act-res ~> exp_res+      where+        given_orig = GivenOrigin (SigSkol GenSigCtxt exp_arg [])+        doc = text "When checking that" <+> quotes (ppr ty_actual) <+>+              text "is more polymorphic than" <+> quotes (ppr ty_expected)++    go ty_a ty_e+      | let (tvs, theta, _) = tcSplitSigmaTy ty_a+      , not (null tvs && null theta)+      = do { (in_wrap, in_rho) <- topInstantiate inst_orig ty_a+           ; body_wrap <- tc_sub_type_ds+                            (eq_orig { uo_actual = in_rho+                                     , uo_expected = ty_expected })+                            inst_orig ctxt in_rho ty_e+           ; return (body_wrap <.> in_wrap) }++      | otherwise   -- Revert to unification+      = inst_and_unify+         -- It's still possible that ty_actual has nested foralls. Instantiate+         -- these, as there's no way unification will succeed with them in.+         -- See typecheck/should_compile/T11305 for an example of when this+         -- is important. The problem is that we're checking something like+         --  a -> forall b. b -> b     <=   alpha beta gamma+         -- where we end up with alpha := (->)++    inst_and_unify = do { (wrap, rho_a) <- deeplyInstantiate inst_orig ty_actual++                           -- If we haven't recurred through an arrow, then+                           -- the eq_orig will list ty_actual. In this case,+                           -- we want to update the origin to reflect the+                           -- instantiation. If we *have* recurred through+                           -- an arrow, it's better not to update.+                        ; let eq_orig' = case eq_orig of+                                TypeEqOrigin { uo_actual   = orig_ty_actual }+                                  |  orig_ty_actual `tcEqType` ty_actual+                                  ,  not (isIdHsWrapper wrap)+                                  -> eq_orig { uo_actual = rho_a }+                                _ -> eq_orig++                        ; cow <- uType TypeLevel eq_orig' rho_a ty_expected+                        ; return (mkWpCastN cow <.> wrap) }+++     -- use versions without synonyms expanded+    unify = mkWpCastN <$> uType TypeLevel eq_orig ty_actual ty_expected++{- Note [Settting the argument context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider we are doing the ambiguity check for the (bogus)+  f :: (forall a b. C b => a -> a) -> Int++We'll call+   tcSubType ((forall a b. C b => a->a) -> Int )+             ((forall a b. C b => a->a) -> Int )++with a UserTypeCtxt of (FunSigCtxt "f").  Then we'll do the co/contra thing+on the argument type of the (->) -- and at that point we want to switch+to a UserTypeCtxt of GenSigCtxt.  Why?++* Error messages.  If we stick with FunSigCtxt we get errors like+     * Could not deduce: C b+       from the context: C b0+        bound by the type signature for:+            f :: forall a b. C b => a->a+  But of course f does not have that type signature!+  Example tests: T10508, T7220a, Simple14++* Implications. We may decide to build an implication for the whole+  ambiguity check, but we don't need one for each level within it,+  and TcUnify.alwaysBuildImplication checks the UserTypeCtxt.+  See Note [When to build an implication]+-}++-----------------+-- needs both un-type-checked (for origins) and type-checked (for wrapping)+-- expressions+tcWrapResult :: HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType+             -> TcM (HsExpr GhcTcId)+tcWrapResult rn_expr = tcWrapResultO (exprCtOrigin rn_expr) rn_expr++-- | Sometimes we don't have a @HsExpr Name@ to hand, and this is more+-- convenient.+tcWrapResultO :: CtOrigin -> HsExpr GhcRn -> HsExpr GhcTcId -> TcSigmaType -> ExpRhoType+               -> TcM (HsExpr GhcTcId)+tcWrapResultO orig rn_expr expr actual_ty res_ty+  = do { traceTc "tcWrapResult" (vcat [ text "Actual:  " <+> ppr actual_ty+                                      , text "Expected:" <+> ppr res_ty ])+       ; cow <- tcSubTypeDS_NC_O orig GenSigCtxt+                                 (Just rn_expr) actual_ty res_ty+       ; return (mkHsWrap cow expr) }+++{- **********************************************************************+%*                                                                      *+            ExpType functions: tcInfer, fillInferResult+%*                                                                      *+%********************************************************************* -}++-- | Infer a type using a fresh ExpType+-- See also Note [ExpType] in TcMType+-- Does not attempt to instantiate the inferred type+tcInferNoInst :: (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)+tcInferNoInst = tcInfer False++tcInferInst :: (ExpRhoType -> TcM a) -> TcM (a, TcRhoType)+tcInferInst = tcInfer True++tcInfer :: Bool -> (ExpSigmaType -> TcM a) -> TcM (a, TcSigmaType)+tcInfer instantiate tc_check+  = do { res_ty <- newInferExpType instantiate+       ; result <- tc_check res_ty+       ; res_ty <- readExpType res_ty+       ; return (result, res_ty) }++fillInferResult :: CtOrigin -> TcType -> InferResult -> TcM HsWrapper+-- If wrap = fillInferResult t1 t2+--    => wrap :: t1 ~> t2+-- See Note [Deep instantiation of InferResult]+fillInferResult orig ty inf_res@(IR { ir_inst = instantiate_me })+  | instantiate_me+  = do { (wrap, rho) <- deeplyInstantiate orig ty+       ; co <- fill_infer_result rho inf_res+       ; return (mkWpCastN co <.> wrap) }++  | otherwise+  = do { co <- fill_infer_result ty inf_res+       ; return (mkWpCastN co) }++fill_infer_result :: TcType -> InferResult -> TcM TcCoercionN+-- If wrap = fill_infer_result t1 t2+--    => wrap :: t1 ~> t2+fill_infer_result orig_ty (IR { ir_uniq = u, ir_lvl = res_lvl+                            , ir_ref = ref })+  = do { (ty_co, ty_to_fill_with) <- promoteTcType res_lvl orig_ty++       ; traceTc "Filling ExpType" $+         ppr u <+> text ":=" <+> ppr ty_to_fill_with++       ; when debugIsOn (check_hole ty_to_fill_with)++       ; writeTcRef ref (Just ty_to_fill_with)++       ; return ty_co }+  where+    check_hole ty   -- Debug check only+      = do { let ty_lvl = tcTypeLevel ty+           ; MASSERT2( not (ty_lvl `strictlyDeeperThan` res_lvl),+                       ppr u $$ ppr res_lvl $$ ppr ty_lvl $$+                       ppr ty <+> dcolon <+> ppr (tcTypeKind ty) $$ ppr orig_ty )+           ; cts <- readTcRef ref+           ; case cts of+               Just already_there -> pprPanic "writeExpType"+                                       (vcat [ ppr u+                                             , ppr ty+                                             , ppr already_there ])+               Nothing -> return () }++{- Note [Deep instantiation of InferResult]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In some cases we want to deeply instantiate before filling in+an InferResult, and in some cases not.  That's why InferReult+has the ir_inst flag.++* ir_inst = True: deeply instantiate++  Consider+    f x = (*)+  We want to instantiate the type of (*) before returning, else we+  will infer the type+    f :: forall {a}. a -> forall b. Num b => b -> b -> b+  This is surely confusing for users.++  And worse, the monomorphism restriction won't work properly. The MR is+  dealt with in simplifyInfer, and simplifyInfer has no way of+  instantiating. This could perhaps be worked around, but it may be+  hard to know even when instantiation should happen.++  Another reason.  Consider+       f :: (?x :: Int) => a -> a+       g y = let ?x = 3::Int in f+  Here want to instantiate f's type so that the ?x::Int constraint+  gets discharged by the enclosing implicit-parameter binding.++* ir_inst = False: do not instantiate++  Consider this (which uses visible type application):++    (let { f :: forall a. a -> a; f x = x } in f) @Int++  We'll call TcExpr.tcInferFun to infer the type of the (let .. in f)+  And we don't want to instantite the type of 'f' when we reach it,+  else the outer visible type application won't work+-}++{- *********************************************************************+*                                                                      *+              Promoting types+*                                                                      *+********************************************************************* -}++promoteTcType :: TcLevel -> TcType -> TcM (TcCoercion, TcType)+-- See Note [Promoting a type]+-- promoteTcType level ty = (co, ty')+--   * Returns ty'  whose max level is just 'level'+--             and  whose kind is ~# to the kind of 'ty'+--             and  whose kind has form TYPE rr+--   * and co :: ty ~ ty'+--   * and emits constraints to justify the coercion+promoteTcType dest_lvl ty+  = do { cur_lvl <- getTcLevel+       ; if (cur_lvl `sameDepthAs` dest_lvl)+         then dont_promote_it+         else promote_it }+  where+    promote_it :: TcM (TcCoercion, TcType)+    promote_it  -- Emit a constraint  (alpha :: TYPE rr) ~ ty+                -- where alpha and rr are fresh and from level dest_lvl+      = do { rr      <- newMetaTyVarTyAtLevel dest_lvl runtimeRepTy+           ; prom_ty <- newMetaTyVarTyAtLevel dest_lvl (tYPE rr)+           ; let eq_orig = TypeEqOrigin { uo_actual   = ty+                                        , uo_expected = prom_ty+                                        , uo_thing    = Nothing+                                        , uo_visible  = False }++           ; co <- emitWantedEq eq_orig TypeLevel Nominal ty prom_ty+           ; return (co, prom_ty) }++    dont_promote_it :: TcM (TcCoercion, TcType)+    dont_promote_it  -- Check that ty :: TYPE rr, for some (fresh) rr+      = do { res_kind <- newOpenTypeKind+           ; let ty_kind = tcTypeKind ty+                 kind_orig = TypeEqOrigin { uo_actual   = ty_kind+                                          , uo_expected = res_kind+                                          , uo_thing    = Nothing+                                          , uo_visible  = False }+           ; ki_co <- uType KindLevel kind_orig (tcTypeKind ty) res_kind+           ; let co = mkTcGReflRightCo Nominal ty ki_co+           ; return (co, ty `mkCastTy` ki_co) }++{- Note [Promoting a type]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#12427)++  data T where+    MkT :: (Int -> Int) -> a -> T++  h y = case y of MkT v w -> v++We'll infer the RHS type with an expected type ExpType of+  (IR { ir_lvl = l, ir_ref = ref, ... )+where 'l' is the TcLevel of the RHS of 'h'.  Then the MkT pattern+match will increase the level, so we'll end up in tcSubType, trying to+unify the type of v,+  v :: Int -> Int+with the expected type.  But this attempt takes place at level (l+1),+rightly so, since v's type could have mentioned existential variables,+(like w's does) and we want to catch that.++So we+  - create a new meta-var alpha[l+1]+  - fill in the InferRes ref cell 'ref' with alpha+  - emit an equality constraint, thus+        [W] alpha[l+1] ~ (Int -> Int)++That constraint will float outwards, as it should, unless v's+type mentions a skolem-captured variable.++This approach fails if v has a higher rank type; see+Note [Promotion and higher rank types]+++Note [Promotion and higher rank types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If v had a higher-rank type, say v :: (forall a. a->a) -> Int,+then we'd emit an equality+        [W] alpha[l+1] ~ ((forall a. a->a) -> Int)+which will sadly fail because we can't unify a unification variable+with a polytype.  But there is nothing really wrong with the program+here.++We could just about solve this by "promote the type" of v, to expose+its polymorphic "shape" while still leaving constraints that will+prevent existential escape.  But we must be careful!  Exposing+the "shape" of the type is precisely what we must NOT do under+a GADT pattern match!  So in this case we might promote the type+to+        (forall a. a->a) -> alpha[l+1]+and emit the constraint+        [W] alpha[l+1] ~ Int+Now the promoted type can fill the ref cell, while the emitted+equality can float or not, according to the usual rules.++But that's not quite right!  We are exposing the arrow! We could+deal with that too:+        (forall a. mu[l+1] a a) -> alpha[l+1]+with constraints+        [W] alpha[l+1] ~ Int+        [W] mu[l+1] ~ (->)+Here we abstract over the '->' inside the forall, in case that+is subject to an equality constraint from a GADT match.++Note that we kept the outer (->) because that's part of+the polymorphic "shape".  And because of impredicativity,+GADT matches can't give equalities that affect polymorphic+shape.++This reasoning just seems too complicated, so I decided not+to do it.  These higher-rank notes are just here to record+the thinking.+-}++{- *********************************************************************+*                                                                      *+                    Generalisation+*                                                                      *+********************************************************************* -}++-- | Take an "expected type" and strip off quantifiers to expose the+-- type underneath, binding the new skolems for the @thing_inside@.+-- The returned 'HsWrapper' has type @specific_ty -> expected_ty@.+tcSkolemise :: UserTypeCtxt -> TcSigmaType+            -> ([TcTyVar] -> TcType -> TcM result)+         -- ^ These are only ever used for scoped type variables.+            -> TcM (HsWrapper, result)+        -- ^ The expression has type: spec_ty -> expected_ty++tcSkolemise ctxt expected_ty thing_inside+   -- We expect expected_ty to be a forall-type+   -- If not, the call is a no-op+  = do  { traceTc "tcSkolemise" Outputable.empty+        ; (wrap, tv_prs, given, rho') <- deeplySkolemise expected_ty++        ; lvl <- getTcLevel+        ; when debugIsOn $+              traceTc "tcSkolemise" $ vcat [+                ppr lvl,+                text "expected_ty" <+> ppr expected_ty,+                text "inst tyvars" <+> ppr tv_prs,+                text "given"       <+> ppr given,+                text "inst type"   <+> ppr rho' ]++        -- Generally we must check that the "forall_tvs" havn't been constrained+        -- The interesting bit here is that we must include the free variables+        -- of the expected_ty.  Here's an example:+        --       runST (newVar True)+        -- Here, if we don't make a check, we'll get a type (ST s (MutVar s Bool))+        -- for (newVar True), with s fresh.  Then we unify with the runST's arg type+        -- forall s'. ST s' a. That unifies s' with s, and a with MutVar s Bool.+        -- So now s' isn't unconstrained because it's linked to a.+        --+        -- However [Oct 10] now that the untouchables are a range of+        -- TcTyVars, all this is handled automatically with no need for+        -- extra faffing around++        ; let tvs' = map snd tv_prs+              skol_info = SigSkol ctxt expected_ty tv_prs++        ; (ev_binds, result) <- checkConstraints skol_info tvs' given $+                                thing_inside tvs' rho'++        ; return (wrap <.> mkWpLet ev_binds, result) }+          -- The ev_binds returned by checkConstraints is very+          -- often empty, in which case mkWpLet is a no-op++-- | Variant of 'tcSkolemise' that takes an ExpType+tcSkolemiseET :: UserTypeCtxt -> ExpSigmaType+              -> (ExpRhoType -> TcM result)+              -> TcM (HsWrapper, result)+tcSkolemiseET _ et@(Infer {}) thing_inside+  = (idHsWrapper, ) <$> thing_inside et+tcSkolemiseET ctxt (Check ty) thing_inside+  = tcSkolemise ctxt ty $ \_ -> thing_inside . mkCheckExpType++checkConstraints :: SkolemInfo+                 -> [TcTyVar]           -- Skolems+                 -> [EvVar]             -- Given+                 -> TcM result+                 -> TcM (TcEvBinds, result)++checkConstraints skol_info skol_tvs given thing_inside+  = do { implication_needed <- implicationNeeded skol_info skol_tvs given++       ; if implication_needed+         then do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints thing_inside+                 ; (implics, ev_binds) <- buildImplicationFor tclvl skol_info skol_tvs given wanted+                 ; traceTc "checkConstraints" (ppr tclvl $$ ppr skol_tvs)+                 ; emitImplications implics+                 ; return (ev_binds, result) }++         else -- Fast path.  We check every function argument with+              -- tcPolyExpr, which uses tcSkolemise and hence checkConstraints.+              -- So this fast path is well-exercised+              do { res <- thing_inside+                 ; return (emptyTcEvBinds, res) } }++checkTvConstraints :: SkolemInfo+                   -> Maybe SDoc  -- User-written telescope, if present+                   -> TcM ([TcTyVar], result)+                   -> TcM ([TcTyVar], result)++checkTvConstraints skol_info m_telescope thing_inside+  = do { (tclvl, wanted, (skol_tvs, result))+             <- pushLevelAndCaptureConstraints thing_inside++       ; emitResidualTvConstraint skol_info m_telescope+                                  skol_tvs tclvl wanted++       ; return (skol_tvs, result) }++emitResidualTvConstraint :: SkolemInfo -> Maybe SDoc -> [TcTyVar]+                         -> TcLevel -> WantedConstraints -> TcM ()+emitResidualTvConstraint skol_info m_telescope skol_tvs tclvl wanted+  | isEmptyWC wanted+  = return ()+  | otherwise+  = do { ev_binds <- newNoTcEvBinds+       ; implic   <- newImplication+       ; let status | insolubleWC wanted = IC_Insoluble+                    | otherwise          = IC_Unsolved+             -- If the inner constraints are insoluble,+             -- we should mark the outer one similarly,+             -- so that insolubleWC works on the outer one++       ; emitImplication $+         implic { ic_status    = status+                , ic_tclvl     = tclvl+                , ic_skols     = skol_tvs+                , ic_no_eqs    = True+                , ic_telescope = m_telescope+                , ic_wanted    = wanted+                , ic_binds     = ev_binds+                , ic_info      = skol_info } }++implicationNeeded :: SkolemInfo -> [TcTyVar] -> [EvVar] -> TcM Bool+-- See Note [When to build an implication]+implicationNeeded skol_info skol_tvs given+  | null skol_tvs+  , null given+  , not (alwaysBuildImplication skol_info)+  = -- Empty skolems and givens+    do { tc_lvl <- getTcLevel+       ; if not (isTopTcLevel tc_lvl)  -- No implication needed if we are+         then return False             -- already inside an implication+         else+    do { dflags <- getDynFlags       -- If any deferral can happen,+                                     -- we must build an implication+       ; return (gopt Opt_DeferTypeErrors dflags ||+                 gopt Opt_DeferTypedHoles dflags ||+                 gopt Opt_DeferOutOfScopeVariables dflags) } }++  | otherwise     -- Non-empty skolems or givens+  = return True   -- Definitely need an implication++alwaysBuildImplication :: SkolemInfo -> Bool+-- See Note [When to build an implication]+alwaysBuildImplication _ = False++{-  Commmented out for now while I figure out about error messages.+    See #14185++alwaysBuildImplication (SigSkol ctxt _ _)+  = case ctxt of+      FunSigCtxt {} -> True  -- RHS of a binding with a signature+      _             -> False+alwaysBuildImplication (RuleSkol {})      = True+alwaysBuildImplication (InstSkol {})      = True+alwaysBuildImplication (FamInstSkol {})   = True+alwaysBuildImplication _                  = False+-}++buildImplicationFor :: TcLevel -> SkolemInfo -> [TcTyVar]+                   -> [EvVar] -> WantedConstraints+                   -> TcM (Bag Implication, TcEvBinds)+buildImplicationFor tclvl skol_info skol_tvs given wanted+  | isEmptyWC wanted && null given+             -- Optimisation : if there are no wanteds, and no givens+             -- don't generate an implication at all.+             -- Reason for the (null given): we don't want to lose+             -- the "inaccessible alternative" error check+  = return (emptyBag, emptyTcEvBinds)++  | otherwise+  = ASSERT2( all (isSkolemTyVar <||> isTyVarTyVar) skol_tvs, ppr skol_tvs )+      -- Why allow TyVarTvs? Because implicitly declared kind variables in+      -- non-CUSK type declarations are TyVarTvs, and we need to bring them+      -- into scope as a skolem in an implication. This is OK, though,+      -- because TyVarTvs will always remain tyvars, even after unification.+    do { ev_binds_var <- newTcEvBinds+       ; implic <- newImplication+       ; let implic' = implic { ic_tclvl  = tclvl+                              , ic_skols  = skol_tvs+                              , ic_given  = given+                              , ic_wanted = wanted+                              , ic_binds  = ev_binds_var+                              , ic_info   = skol_info }++       ; return (unitBag implic', TcEvBinds ev_binds_var) }++{- Note [When to build an implication]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have some 'skolems' and some 'givens', and we are+considering whether to wrap the constraints in their scope into an+implication.  We must /always/ so if either 'skolems' or 'givens' are+non-empty.  But what if both are empty?  You might think we could+always drop the implication.  Other things being equal, the fewer+implications the better.  Less clutter and overhead.  But we must+take care:++* If we have an unsolved [W] g :: a ~# b, and -fdefer-type-errors,+  we'll make a /term-level/ evidence binding for 'g = error "blah"'.+  We must have an EvBindsVar those bindings!, otherwise they end up as+  top-level unlifted bindings, which are verboten. This only matters+  at top level, so we check for that+  See also Note [Deferred errors for coercion holes] in TcErrors.+  cf #14149 for an example of what goes wrong.++* If you have+     f :: Int;  f = f_blah+     g :: Bool; g = g_blah+  If we don't build an implication for f or g (no tyvars, no givens),+  the constraints for f_blah and g_blah are solved together.  And that+  can yield /very/ confusing error messages, because we can get+      [W] C Int b1    -- from f_blah+      [W] C Int b2    -- from g_blan+  and fundpes can yield [D] b1 ~ b2, even though the two functions have+  literally nothing to do with each other.  #14185 is an example.+  Building an implication keeps them separage.+-}++{-+************************************************************************+*                                                                      *+                Boxy unification+*                                                                      *+************************************************************************++The exported functions are all defined as versions of some+non-exported generic functions.+-}++unifyType :: Maybe (HsExpr GhcRn)   -- ^ If present, has type 'ty1'+          -> TcTauType -> TcTauType -> TcM TcCoercionN+-- Actual and expected types+-- Returns a coercion : ty1 ~ ty2+unifyType thing ty1 ty2 = traceTc "utype" (ppr ty1 $$ ppr ty2 $$ ppr thing) >>+                          uType TypeLevel origin ty1 ty2+  where+    origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2+                          , uo_thing  = ppr <$> thing+                          , uo_visible = True } -- always called from a visible context++unifyKind :: Maybe (HsType GhcRn) -> TcKind -> TcKind -> TcM CoercionN+unifyKind thing ty1 ty2 = traceTc "ukind" (ppr ty1 $$ ppr ty2 $$ ppr thing) >>+                          uType KindLevel origin ty1 ty2+  where origin = TypeEqOrigin { uo_actual = ty1, uo_expected = ty2+                              , uo_thing  = ppr <$> thing+                              , uo_visible = True } -- also always from a visible context++---------------++{-+%************************************************************************+%*                                                                      *+                 uType and friends+%*                                                                      *+%************************************************************************++uType is the heart of the unifier.+-}++uType, uType_defer+  :: TypeOrKind+  -> CtOrigin+  -> TcType    -- ty1 is the *actual* type+  -> TcType    -- ty2 is the *expected* type+  -> TcM CoercionN++--------------+-- It is always safe to defer unification to the main constraint solver+-- See Note [Deferred unification]+uType_defer t_or_k origin ty1 ty2+  = do { co <- emitWantedEq origin t_or_k Nominal ty1 ty2++       -- Error trace only+       -- NB. do *not* call mkErrInfo unless tracing is on,+       --     because it is hugely expensive (#5631)+       ; whenDOptM Opt_D_dump_tc_trace $ do+            { ctxt <- getErrCtxt+            ; doc <- mkErrInfo emptyTidyEnv ctxt+            ; traceTc "utype_defer" (vcat [ debugPprType ty1+                                          , debugPprType ty2+                                          , pprCtOrigin origin+                                          , doc])+            ; traceTc "utype_defer2" (ppr co)+            }+       ; return co }++--------------+uType t_or_k origin orig_ty1 orig_ty2+  = do { tclvl <- getTcLevel+       ; traceTc "u_tys" $ vcat+              [ text "tclvl" <+> ppr tclvl+              , sep [ ppr orig_ty1, text "~", ppr orig_ty2]+              , pprCtOrigin origin]+       ; co <- go orig_ty1 orig_ty2+       ; if isReflCo co+            then traceTc "u_tys yields no coercion" Outputable.empty+            else traceTc "u_tys yields coercion:" (ppr co)+       ; return co }+  where+    go :: TcType -> TcType -> TcM CoercionN+        -- The arguments to 'go' are always semantically identical+        -- to orig_ty{1,2} except for looking through type synonyms++     -- Unwrap casts before looking for variables. This way, we can easily+     -- recognize (t |> co) ~ (t |> co), which is nice. Previously, we+     -- didn't do it this way, and then the unification above was deferred.+    go (CastTy t1 co1) t2+      = do { co_tys <- uType t_or_k origin t1 t2+           ; return (mkCoherenceLeftCo Nominal t1 co1 co_tys) }++    go t1 (CastTy t2 co2)+      = do { co_tys <- uType t_or_k origin t1 t2+           ; return (mkCoherenceRightCo Nominal t2 co2 co_tys) }++        -- Variables; go for uVar+        -- Note that we pass in *original* (before synonym expansion),+        -- so that type variables tend to get filled in with+        -- the most informative version of the type+    go (TyVarTy tv1) ty2+      = do { lookup_res <- lookupTcTyVar tv1+           ; case lookup_res of+               Filled ty1   -> do { traceTc "found filled tyvar" (ppr tv1 <+> text ":->" <+> ppr ty1)+                                  ; go ty1 ty2 }+               Unfilled _ -> uUnfilledVar origin t_or_k NotSwapped tv1 ty2 }+    go ty1 (TyVarTy tv2)+      = do { lookup_res <- lookupTcTyVar tv2+           ; case lookup_res of+               Filled ty2   -> do { traceTc "found filled tyvar" (ppr tv2 <+> text ":->" <+> ppr ty2)+                                  ; go ty1 ty2 }+               Unfilled _ -> uUnfilledVar origin t_or_k IsSwapped tv2 ty1 }++      -- See Note [Expanding synonyms during unification]+    go ty1@(TyConApp tc1 []) (TyConApp tc2 [])+      | tc1 == tc2+      = return $ mkNomReflCo ty1++        -- See Note [Expanding synonyms during unification]+        --+        -- Also NB that we recurse to 'go' so that we don't push a+        -- new item on the origin stack. As a result if we have+        --   type Foo = Int+        -- and we try to unify  Foo ~ Bool+        -- we'll end up saying "can't match Foo with Bool"+        -- rather than "can't match "Int with Bool".  See #4535.+    go ty1 ty2+      | Just ty1' <- tcView ty1 = go ty1' ty2+      | Just ty2' <- tcView ty2 = go ty1  ty2'++        -- Functions (or predicate functions) just check the two parts+    go (FunTy _ fun1 arg1) (FunTy _ fun2 arg2)+      = do { co_l <- uType t_or_k origin fun1 fun2+           ; co_r <- uType t_or_k origin arg1 arg2+           ; return $ mkFunCo Nominal co_l co_r }++        -- Always defer if a type synonym family (type function)+        -- is involved.  (Data families behave rigidly.)+    go ty1@(TyConApp tc1 _) ty2+      | isTypeFamilyTyCon tc1 = defer ty1 ty2+    go ty1 ty2@(TyConApp tc2 _)+      | isTypeFamilyTyCon tc2 = defer ty1 ty2++    go (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      -- See Note [Mismatched type lists and application decomposition]+      | tc1 == tc2, equalLength tys1 tys2+      = ASSERT2( isGenerativeTyCon tc1 Nominal, ppr tc1 )+        do { cos <- zipWith3M (uType t_or_k) origins' tys1 tys2+           ; return $ mkTyConAppCo Nominal tc1 cos }+      where+        origins' = map (\is_vis -> if is_vis then origin else toInvisibleOrigin origin)+                       (tcTyConVisibilities tc1)++    go (LitTy m) ty@(LitTy n)+      | m == n+      = return $ mkNomReflCo ty++        -- See Note [Care with type applications]+        -- Do not decompose FunTy against App;+        -- it's often a type error, so leave it for the constraint solver+    go (AppTy s1 t1) (AppTy s2 t2)+      = go_app (isNextArgVisible s1) s1 t1 s2 t2++    go (AppTy s1 t1) (TyConApp tc2 ts2)+      | Just (ts2', t2') <- snocView ts2+      = ASSERT( not (mustBeSaturated tc2) )+        go_app (isNextTyConArgVisible tc2 ts2') s1 t1 (TyConApp tc2 ts2') t2'++    go (TyConApp tc1 ts1) (AppTy s2 t2)+      | Just (ts1', t1') <- snocView ts1+      = ASSERT( not (mustBeSaturated tc1) )+        go_app (isNextTyConArgVisible tc1 ts1') (TyConApp tc1 ts1') t1' s2 t2++    go (CoercionTy co1) (CoercionTy co2)+      = do { let ty1 = coercionType co1+                 ty2 = coercionType co2+           ; kco <- uType KindLevel+                          (KindEqOrigin orig_ty1 (Just orig_ty2) origin+                                        (Just t_or_k))+                          ty1 ty2+           ; return $ mkProofIrrelCo Nominal kco co1 co2 }++        -- Anything else fails+        -- E.g. unifying for-all types, which is relative unusual+    go ty1 ty2 = defer ty1 ty2++    ------------------+    defer ty1 ty2   -- See Note [Check for equality before deferring]+      | ty1 `tcEqType` ty2 = return (mkNomReflCo ty1)+      | otherwise          = uType_defer t_or_k origin ty1 ty2++    ------------------+    go_app vis s1 t1 s2 t2+      = do { co_s <- uType t_or_k origin s1 s2+           ; let arg_origin+                   | vis       = origin+                   | otherwise = toInvisibleOrigin origin+           ; co_t <- uType t_or_k arg_origin t1 t2+           ; return $ mkAppCo co_s co_t }++{- Note [Check for equality before deferring]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Particularly in ambiguity checks we can get equalities like (ty ~ ty).+If ty involves a type function we may defer, which isn't very sensible.+An egregious example of this was in test T9872a, which has a type signature+       Proxy :: Proxy (Solutions Cubes)+Doing the ambiguity check on this signature generates the equality+   Solutions Cubes ~ Solutions Cubes+and currently the constraint solver normalises both sides at vast cost.+This little short-cut in 'defer' helps quite a bit.++Note [Care with type applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note: type applications need a bit of care!+They can match FunTy and TyConApp, so use splitAppTy_maybe+NB: we've already dealt with type variables and Notes,+so if one type is an App the other one jolly well better be too++Note [Mismatched type lists and application decomposition]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we find two TyConApps, you might think that the argument lists+are guaranteed equal length.  But they aren't. Consider matching+        w (T x) ~ Foo (T x y)+We do match (w ~ Foo) first, but in some circumstances we simply create+a deferred constraint; and then go ahead and match (T x ~ T x y).+This came up in #3950.++So either+   (a) either we must check for identical argument kinds+       when decomposing applications,++   (b) or we must be prepared for ill-kinded unification sub-problems++Currently we adopt (b) since it seems more robust -- no need to maintain+a global invariant.++Note [Expanding synonyms during unification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We expand synonyms during unification, but:+ * We expand *after* the variable case so that we tend to unify+   variables with un-expanded type synonym. This just makes it+   more likely that the inferred types will mention type synonyms+   understandable to the user++ * Similarly, we expand *after* the CastTy case, just in case the+   CastTy wraps a variable.++ * We expand *before* the TyConApp case.  For example, if we have+      type Phantom a = Int+   and are unifying+      Phantom Int ~ Phantom Char+   it is *wrong* to unify Int and Char.++ * The problem case immediately above can happen only with arguments+   to the tycon. So we check for nullary tycons *before* expanding.+   This is particularly helpful when checking (* ~ *), because * is+   now a type synonym.++Note [Deferred Unification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We may encounter a unification ty1 ~ ty2 that cannot be performed syntactically,+and yet its consistency is undetermined. Previously, there was no way to still+make it consistent. So a mismatch error was issued.++Now these unifications are deferred until constraint simplification, where type+family instances and given equations may (or may not) establish the consistency.+Deferred unifications are of the form+                F ... ~ ...+or              x ~ ...+where F is a type function and x is a type variable.+E.g.+        id :: x ~ y => x -> y+        id e = e++involves the unification x = y. It is deferred until we bring into account the+context x ~ y to establish that it holds.++If available, we defer original types (rather than those where closed type+synonyms have already been expanded via tcCoreView).  This is, as usual, to+improve error messages.+++************************************************************************+*                                                                      *+                 uVar and friends+*                                                                      *+************************************************************************++@uVar@ is called when at least one of the types being unified is a+variable.  It does {\em not} assume that the variable is a fixed point+of the substitution; rather, notice that @uVar@ (defined below) nips+back into @uTys@ if it turns out that the variable is already bound.+-}++----------+uUnfilledVar :: CtOrigin+             -> TypeOrKind+             -> SwapFlag+             -> TcTyVar        -- Tyvar 1+             -> TcTauType      -- Type 2+             -> TcM Coercion+-- "Unfilled" means that the variable is definitely not a filled-in meta tyvar+--            It might be a skolem, or untouchable, or meta++uUnfilledVar origin t_or_k swapped tv1 ty2+  = do { ty2 <- zonkTcType ty2+             -- Zonk to expose things to the+             -- occurs check, and so that if ty2+             -- looks like a type variable then it+             -- /is/ a type variable+       ; uUnfilledVar1 origin t_or_k swapped tv1 ty2 }++----------+uUnfilledVar1 :: CtOrigin+              -> TypeOrKind+              -> SwapFlag+              -> TcTyVar        -- Tyvar 1+              -> TcTauType      -- Type 2, zonked+              -> TcM Coercion+uUnfilledVar1 origin t_or_k swapped tv1 ty2+  | Just tv2 <- tcGetTyVar_maybe ty2+  = go tv2++  | otherwise+  = uUnfilledVar2 origin t_or_k swapped tv1 ty2++  where+    -- 'go' handles the case where both are+    -- tyvars so we might want to swap+    go tv2 | tv1 == tv2  -- Same type variable => no-op+           = return (mkNomReflCo (mkTyVarTy tv1))++           | swapOverTyVars tv1 tv2   -- Distinct type variables+           = uUnfilledVar2 origin t_or_k (flipSwap swapped)+                           tv2 (mkTyVarTy tv1)++           | otherwise+           = uUnfilledVar2 origin t_or_k swapped tv1 ty2++----------+uUnfilledVar2 :: CtOrigin+              -> TypeOrKind+              -> SwapFlag+              -> TcTyVar        -- Tyvar 1+              -> TcTauType      -- Type 2, zonked+              -> TcM Coercion+uUnfilledVar2 origin t_or_k swapped tv1 ty2+  = do { dflags  <- getDynFlags+       ; cur_lvl <- getTcLevel+       ; go dflags cur_lvl }+  where+    go dflags cur_lvl+      | canSolveByUnification cur_lvl tv1 ty2+      , Just ty2' <- metaTyVarUpdateOK dflags tv1 ty2+      = do { co_k <- uType KindLevel kind_origin (tcTypeKind ty2') (tyVarKind tv1)+           ; traceTc "uUnfilledVar2 ok" $+             vcat [ ppr tv1 <+> dcolon <+> ppr (tyVarKind tv1)+                  , ppr ty2 <+> dcolon <+> ppr (tcTypeKind  ty2)+                  , ppr (isTcReflCo co_k), ppr co_k ]++           ; if isTcReflCo co_k  -- only proceed if the kinds matched.++             then do { writeMetaTyVar tv1 ty2'+                     ; return (mkTcNomReflCo ty2') }++             else defer } -- This cannot be solved now.  See TcCanonical+                          -- Note [Equalities with incompatible kinds]++      | otherwise+      = do { traceTc "uUnfilledVar2 not ok" (ppr tv1 $$ ppr ty2)+               -- Occurs check or an untouchable: just defer+               -- NB: occurs check isn't necessarily fatal:+               --     eg tv1 occured in type family parameter+            ; defer }++    ty1 = mkTyVarTy tv1+    kind_origin = KindEqOrigin ty1 (Just ty2) origin (Just t_or_k)++    defer = unSwap swapped (uType_defer t_or_k origin) ty1 ty2++swapOverTyVars :: TcTyVar -> TcTyVar -> Bool+swapOverTyVars tv1 tv2+  -- Level comparison: see Note [TyVar/TyVar orientation]+  | lvl1 `strictlyDeeperThan` lvl2 = False+  | lvl2 `strictlyDeeperThan` lvl1 = True++  -- Priority: see Note [TyVar/TyVar orientation]+  | pri1 > pri2 = False+  | pri2 > pri1 = True++  -- Names: see Note [TyVar/TyVar orientation]+  | isSystemName tv2_name, not (isSystemName tv1_name) = True++  | otherwise = False++  where+    lvl1 = tcTyVarLevel tv1+    lvl2 = tcTyVarLevel tv2+    pri1 = lhsPriority tv1+    pri2 = lhsPriority tv2+    tv1_name = Var.varName tv1+    tv2_name = Var.varName tv2+++lhsPriority :: TcTyVar -> Int+-- Higher => more important to be on the LHS+-- See Note [TyVar/TyVar orientation]+lhsPriority tv+  = ASSERT2( isTyVar tv, ppr tv)+    case tcTyVarDetails tv of+      RuntimeUnk  -> 0+      SkolemTv {} -> 0+      MetaTv { mtv_info = info } -> case info of+                                     FlatSkolTv -> 1+                                     TyVarTv    -> 2+                                     TauTv      -> 3+                                     FlatMetaTv -> 4+{- Note [TyVar/TyVar orientation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given (a ~ b), should we orient the CTyEqCan as (a~b) or (b~a)?+This is a surprisingly tricky question!++First note: only swap if you have to!+   See Note [Avoid unnecessary swaps]++So we look for a positive reason to swap, using a three-step test:++* Level comparison. If 'a' has deeper level than 'b',+  put 'a' on the left.  See Note [Deeper level on the left]++* Priority.  If the levels are the same, look at what kind of+  type variable it is, using 'lhsPriority'++  - FlatMetaTv: Always put on the left.+    See Note [Fmv Orientation Invariant]+    NB: FlatMetaTvs always have the current level, never an+        outer one.  So nothing can be deeper than a FlatMetaTv+++  - TyVarTv/TauTv: if we have  tyv_tv ~ tau_tv, put tau_tv+                   on the left because there are fewer+                   restrictions on updating TauTvs++  - TyVarTv/TauTv:  put on the left either+     a) Because it's touchable and can be unified, or+     b) Even if it's not touchable, TcSimplify.floatEqualities+        looks for meta tyvars on the left++  - FlatSkolTv: Put on the left in preference to a SkolemTv+                See Note [Eliminate flat-skols]++* Names. If the level and priority comparisons are all+  equal, try to eliminate a TyVars with a System Name in+  favour of ones with a Name derived from a user type signature++* Age.  At one point in the past we tried to break any remaining+  ties by eliminating the younger type variable, based on their+  Uniques.  See Note [Eliminate younger unification variables]+  (which also explains why we don't do this any more)++Note [Deeper level on the left]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The most important thing is that we want to put tyvars with+the deepest level on the left.  The reason to do so differs for+Wanteds and Givens, but either way, deepest wins!  Simple.++* Wanteds.  Putting the deepest variable on the left maximise the+  chances that it's a touchable meta-tyvar which can be solved.++* Givens. Suppose we have something like+     forall a[2]. b[1] ~ a[2] => beta[1] ~ a[2]++  If we orient the Given a[2] on the left, we'll rewrite the Wanted to+  (beta[1] ~ b[1]), and that can float out of the implication.+  Otherwise it can't.  By putting the deepest variable on the left+  we maximise our changes of eliminating skolem capture.++  See also TcSMonad Note [Let-bound skolems] for another reason+  to orient with the deepest skolem on the left.++  IMPORTANT NOTE: this test does a level-number comparison on+  skolems, so it's important that skolems have (accurate) level+  numbers.++See #15009 for an further analysis of why "deepest on the left"+is a good plan.++Note [Fmv Orientation Invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   * We always orient a constraint+        fmv ~ alpha+     with fmv on the left, even if alpha is+     a touchable unification variable++Reason: doing it the other way round would unify alpha:=fmv, but that+really doesn't add any info to alpha.  But a later constraint alpha ~+Int might unlock everything.  Comment:9 of #12526 gives a detailed+example.++WARNING: I've gone to and fro on this one several times.+I'm now pretty sure that unifying alpha:=fmv is a bad idea!+So orienting with fmvs on the left is a good thing.++This example comes from IndTypesPerfMerge. (Others include+T10226, T10009.)+    From the ambiguity check for+      f :: (F a ~ a) => a+    we get:+          [G] F a ~ a+          [WD] F alpha ~ alpha, alpha ~ a++    From Givens we get+          [G] F a ~ fsk, fsk ~ a++    Now if we flatten we get+          [WD] alpha ~ fmv, F alpha ~ fmv, alpha ~ a++    Now, if we unified alpha := fmv, we'd get+          [WD] F fmv ~ fmv, [WD] fmv ~ a+    And now we are stuck.++So instead the Fmv Orientation Invariant puts the fmv on the+left, giving+      [WD] fmv ~ alpha, [WD] F alpha ~ fmv, [WD] alpha ~ a++    Now we get alpha:=a, and everything works out++Note [Eliminate flat-skols]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have  [G] Num (F [a])+then we flatten to+     [G] Num fsk+     [G] F [a] ~ fsk+where fsk is a flatten-skolem (FlatSkolTv). Suppose we have+      type instance F [a] = a+then we'll reduce the second constraint to+     [G] a ~ fsk+and then replace all uses of 'a' with fsk.  That's bad because+in error messages instead of saying 'a' we'll say (F [a]).  In all+places, including those where the programmer wrote 'a' in the first+place.  Very confusing!  See #7862.++Solution: re-orient a~fsk to fsk~a, so that we preferentially eliminate+the fsk.++Note [Avoid unnecessary swaps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we swap without actually improving matters, we can get an infinite loop.+Consider+    work item:  a ~ b+   inert item:  b ~ c+We canonicalise the work-item to (a ~ c).  If we then swap it before+adding to the inert set, we'll add (c ~ a), and therefore kick out the+inert guy, so we get+   new work item:  b ~ c+   inert item:     c ~ a+And now the cycle just repeats++Note [Eliminate younger unification variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a choice of unifying+     alpha := beta   or   beta := alpha+we try, if possible, to eliminate the "younger" one, as determined+by `ltUnique`.  Reason: the younger one is less likely to appear free in+an existing inert constraint, and hence we are less likely to be forced+into kicking out and rewriting inert constraints.++This is a performance optimisation only.  It turns out to fix+#14723 all by itself, but clearly not reliably so!++It's simple to implement (see nicer_to_update_tv2 in swapOverTyVars).+But, to my surprise, it didn't seem to make any significant difference+to the compiler's performance, so I didn't take it any further.  Still+it seemed to too nice to discard altogether, so I'm leaving these+notes.  SLPJ Jan 18.+-}++-- @trySpontaneousSolve wi@ solves equalities where one side is a+-- touchable unification variable.+-- Returns True <=> spontaneous solve happened+canSolveByUnification :: TcLevel -> TcTyVar -> TcType -> Bool+canSolveByUnification tclvl tv xi+  | isTouchableMetaTyVar tclvl tv+  = case metaTyVarInfo tv of+      TyVarTv -> is_tyvar xi+      _       -> True++  | otherwise    -- Untouchable+  = False+  where+    is_tyvar xi+      = case tcGetTyVar_maybe xi of+          Nothing -> False+          Just tv -> case tcTyVarDetails tv of+                       MetaTv { mtv_info = info }+                                   -> case info of+                                        TyVarTv -> True+                                        _       -> False+                       SkolemTv {} -> True+                       RuntimeUnk  -> True++{- Note [Prevent unification with type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We prevent unification with type families because of an uneasy compromise.+It's perfectly sound to unify with type families, and it even improves the+error messages in the testsuite. It also modestly improves performance, at+least in some cases. But it's disastrous for test case perf/compiler/T3064.+Here is the problem: Suppose we have (F ty) where we also have [G] F ty ~ a.+What do we do? Do we reduce F? Or do we use the given? Hard to know what's+best. GHC reduces. This is a disaster for T3064, where the type's size+spirals out of control during reduction. (We're not helped by the fact that+the flattener re-flattens all the arguments every time around.) If we prevent+unification with type families, then the solver happens to use the equality+before expanding the type family.++It would be lovely in the future to revisit this problem and remove this+extra, unnecessary check. But we retain it for now as it seems to work+better in practice.++Note [Refactoring hazard: checkTauTvUpdate]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+I (Richard E.) have a sad story about refactoring this code, retained here+to prevent others (or a future me!) from falling into the same traps.++It all started with #11407, which was caused by the fact that the TyVarTy+case of defer_me didn't look in the kind. But it seemed reasonable to+simply remove the defer_me check instead.++It referred to two Notes (since removed) that were out of date, and the+fast_check code in occurCheckExpand seemed to do just about the same thing as+defer_me. The one piece that defer_me did that wasn't repeated by+occurCheckExpand was the type-family check. (See Note [Prevent unification+with type families].) So I checked the result of occurCheckExpand for any+type family occurrences and deferred if there were any. This was done+in commit e9bf7bb5cc9fb3f87dd05111aa23da76b86a8967 .++This approach turned out not to be performant, because the expanded+type was bigger than the original type, and tyConsOfType (needed to+see if there are any type family occurrences) looks through type+synonyms. So it then struck me that we could dispense with the+defer_me check entirely. This simplified the code nicely, and it cut+the allocations in T5030 by half. But, as documented in Note [Prevent+unification with type families], this destroyed performance in+T3064. Regardless, I missed this regression and the change was+committed as 3f5d1a13f112f34d992f6b74656d64d95a3f506d .++Bottom lines:+ * defer_me is back, but now fixed w.r.t. #11407.+ * Tread carefully before you start to refactor here. There can be+   lots of hard-to-predict consequences.++Note [Type synonyms and the occur check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking we try to update a variable with type synonyms not+expanded, which improves later error messages, unless looking+inside a type synonym may help resolve a spurious occurs check+error. Consider:+          type A a = ()++          f :: (A a -> a -> ()) -> ()+          f = \ _ -> ()++          x :: ()+          x = f (\ x p -> p x)++We will eventually get a constraint of the form t ~ A t. The ok function above will+properly expand the type (A t) to just (), which is ok to be unified with t. If we had+unified with the original type A t, we would lead the type checker into an infinite loop.++Hence, if the occurs check fails for a type synonym application, then (and *only* then),+the ok function expands the synonym to detect opportunities for occurs check success using+the underlying definition of the type synonym.++The same applies later on in the constraint interaction code; see TcInteract,+function @occ_check_ok@.++Note [Non-TcTyVars in TcUnify]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because the same code is now shared between unifying types and unifying+kinds, we sometimes will see proper TyVars floating around the unifier.+Example (from test case polykinds/PolyKinds12):++    type family Apply (f :: k1 -> k2) (x :: k1) :: k2+    type instance Apply g y = g y++When checking the instance declaration, we first *kind-check* the LHS+and RHS, discovering that the instance really should be++    type instance Apply k3 k4 (g :: k3 -> k4) (y :: k3) = g y++During this kind-checking, all the tyvars will be TcTyVars. Then, however,+as a second pass, we desugar the RHS (which is done in functions prefixed+with "tc" in TcTyClsDecls"). By this time, all the kind-vars are proper+TyVars, not TcTyVars, get some kind unification must happen.++Thus, we always check if a TyVar is a TcTyVar before asking if it's a+meta-tyvar.++This used to not be necessary for type-checking (that is, before * :: *)+because expressions get desugared via an algorithm separate from+type-checking (with wrappers, etc.). Types get desugared very differently,+causing this wibble in behavior seen here.+-}++data LookupTyVarResult  -- The result of a lookupTcTyVar call+  = Unfilled TcTyVarDetails     -- SkolemTv or virgin MetaTv+  | Filled   TcType++lookupTcTyVar :: TcTyVar -> TcM LookupTyVarResult+lookupTcTyVar tyvar+  | MetaTv { mtv_ref = ref } <- details+  = do { meta_details <- readMutVar ref+       ; case meta_details of+           Indirect ty -> return (Filled ty)+           Flexi -> do { is_touchable <- isTouchableTcM tyvar+                             -- Note [Unifying untouchables]+                       ; if is_touchable then+                            return (Unfilled details)+                         else+                            return (Unfilled vanillaSkolemTv) } }+  | otherwise+  = return (Unfilled details)+  where+    details = tcTyVarDetails tyvar++{-+Note [Unifying untouchables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We treat an untouchable type variable as if it was a skolem.  That+ensures it won't unify with anything.  It's a slight hack, because+we return a made-up TcTyVarDetails, but I think it works smoothly.+-}++-- | Breaks apart a function kind into its pieces.+matchExpectedFunKind+  :: Outputable fun+  => fun             -- ^ type, only for errors+  -> Arity           -- ^ n: number of desired arrows+  -> TcKind          -- ^ fun_ kind+  -> TcM Coercion    -- ^ co :: fun_kind ~ (arg1 -> ... -> argn -> res)++matchExpectedFunKind hs_ty n k = go n k+  where+    go 0 k = return (mkNomReflCo k)++    go n k | Just k' <- tcView k = go n k'++    go n k@(TyVarTy kvar)+      | isMetaTyVar kvar+      = do { maybe_kind <- readMetaTyVar kvar+           ; case maybe_kind of+                Indirect fun_kind -> go n fun_kind+                Flexi ->             defer n k }++    go n (FunTy _ arg res)+      = do { co <- go (n-1) res+           ; return (mkTcFunCo Nominal (mkTcNomReflCo arg) co) }++    go n other+     = defer n other++    defer n k+      = do { arg_kinds <- newMetaKindVars n+           ; res_kind  <- newMetaKindVar+           ; let new_fun = mkVisFunTys arg_kinds res_kind+                 origin  = TypeEqOrigin { uo_actual   = k+                                        , uo_expected = new_fun+                                        , uo_thing    = Just (ppr hs_ty)+                                        , uo_visible  = True+                                        }+           ; uType KindLevel origin k new_fun }++{- *********************************************************************+*                                                                      *+                 Occurrence checking+*                                                                      *+********************************************************************* -}+++{-  Note [Occurrence checking: look inside kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are considering unifying+   (alpha :: *)  ~  Int -> (beta :: alpha -> alpha)+This may be an error (what is that alpha doing inside beta's kind?),+but we must not make the mistake of actually unifying or we'll+build an infinite data structure.  So when looking for occurrences+of alpha in the rhs, we must look in the kinds of type variables+that occur there.++NB: we may be able to remove the problem via expansion; see+    Note [Occurs check expansion].  So we have to try that.++Note [Checking for foralls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unless we have -XImpredicativeTypes (which is a totally unsupported+feature), we do not want to unify+    alpha ~ (forall a. a->a) -> Int+So we look for foralls hidden inside the type, and it's convenient+to do that at the same time as the occurs check (which looks for+occurrences of alpha).++However, it's not just a question of looking for foralls /anywhere/!+Consider+   (alpha :: forall k. k->*)  ~  (beta :: forall k. k->*)+This is legal; e.g. dependent/should_compile/T11635.++We don't want to reject it because of the forall in beta's kind,+but (see Note [Occurrence checking: look inside kinds]) we do+need to look in beta's kind.  So we carry a flag saying if a 'forall'+is OK, and sitch the flag on when stepping inside a kind.++Why is it OK?  Why does it not count as impredicative polymorphism?+The reason foralls are bad is because we reply on "seeing" foralls+when doing implicit instantiation.  But the forall inside the kind is+fine.  We'll generate a kind equality constraint+  (forall k. k->*) ~ (forall k. k->*)+to check that the kinds of lhs and rhs are compatible.  If alpha's+kind had instead been+  (alpha :: kappa)+then this kind equality would rightly complain about unifying kappa+with (forall k. k->*)++-}++data MetaTyVarUpdateResult a+  = MTVU_OK a+  | MTVU_Bad     -- Forall, predicate, or type family+  | MTVU_Occurs++instance Functor MetaTyVarUpdateResult where+      fmap = liftM++instance Applicative MetaTyVarUpdateResult where+      pure = MTVU_OK+      (<*>) = ap++instance Monad MetaTyVarUpdateResult where+  MTVU_OK x    >>= k = k x+  MTVU_Bad     >>= _ = MTVU_Bad+  MTVU_Occurs  >>= _ = MTVU_Occurs++occCheckForErrors :: DynFlags -> TcTyVar -> Type -> MetaTyVarUpdateResult ()+-- Just for error-message generation; so we return MetaTyVarUpdateResult+-- so the caller can report the right kind of error+-- Check whether+--   a) the given variable occurs in the given type.+--   b) there is a forall in the type (unless we have -XImpredicativeTypes)+occCheckForErrors dflags tv ty+  = case preCheck dflags True tv ty of+      MTVU_OK _   -> MTVU_OK ()+      MTVU_Bad    -> MTVU_Bad+      MTVU_Occurs -> case occCheckExpand [tv] ty of+                       Nothing -> MTVU_Occurs+                       Just _  -> MTVU_OK ()++----------------+metaTyVarUpdateOK :: DynFlags+                  -> TcTyVar             -- tv :: k1+                  -> TcType              -- ty :: k2+                  -> Maybe TcType        -- possibly-expanded ty+-- (metaTyVarUpdateOK tv ty)+-- We are about to update the meta-tyvar tv with ty+-- Check (a) that tv doesn't occur in ty (occurs check)+--       (b) that ty does not have any foralls+--           (in the impredicative case), or type functions+--+-- We have two possible outcomes:+-- (1) Return the type to update the type variable with,+--        [we know the update is ok]+-- (2) Return Nothing,+--        [the update might be dodgy]+--+-- Note that "Nothing" does not mean "definite error".  For example+--   type family F a+--   type instance F Int = Int+-- consider+--   a ~ F a+-- This is perfectly reasonable, if we later get a ~ Int.  For now, though,+-- we return Nothing, leaving it to the later constraint simplifier to+-- sort matters out.+--+-- See Note [Refactoring hazard: checkTauTvUpdate]++metaTyVarUpdateOK dflags tv ty+  = case preCheck dflags False tv ty of+         -- False <=> type families not ok+         -- See Note [Prevent unification with type families]+      MTVU_OK _   -> Just ty+      MTVU_Bad    -> Nothing  -- forall, predicate, or type function+      MTVU_Occurs -> occCheckExpand [tv] ty++preCheck :: DynFlags -> Bool -> TcTyVar -> TcType -> MetaTyVarUpdateResult ()+-- A quick check for+--   (a) a forall type (unless -XImpredicativeTypes)+--   (b) a predicate type (unless -XImpredicativeTypes)+--   (c) a type family+--   (d) an occurrence of the type variable (occurs check)+--+-- For (a), (b), and (c) we check only the top level of the type, NOT+-- inside the kinds of variables it mentions.  But for (c) we do+-- look in the kinds of course.++preCheck dflags ty_fam_ok tv ty+  = fast_check ty+  where+    details          = tcTyVarDetails tv+    impredicative_ok = canUnifyWithPolyType dflags details++    ok :: MetaTyVarUpdateResult ()+    ok = MTVU_OK ()++    fast_check :: TcType -> MetaTyVarUpdateResult ()+    fast_check (TyVarTy tv')+      | tv == tv' = MTVU_Occurs+      | otherwise = fast_check_occ (tyVarKind tv')+           -- See Note [Occurrence checking: look inside kinds]++    fast_check (TyConApp tc tys)+      | bad_tc tc              = MTVU_Bad+      | otherwise              = mapM fast_check tys >> ok+    fast_check (LitTy {})      = ok+    fast_check (FunTy{ft_af = af, ft_arg = a, ft_res = r})+      | InvisArg <- af+      , not impredicative_ok   = MTVU_Bad+      | otherwise              = fast_check a   >> fast_check r+    fast_check (AppTy fun arg) = fast_check fun >> fast_check arg+    fast_check (CastTy ty co)  = fast_check ty  >> fast_check_co co+    fast_check (CoercionTy co) = fast_check_co co+    fast_check (ForAllTy (Bndr tv' _) ty)+       | not impredicative_ok = MTVU_Bad+       | tv == tv'            = ok+       | otherwise = do { fast_check_occ (tyVarKind tv')+                        ; fast_check_occ ty }+       -- Under a forall we look only for occurrences of+       -- the type variable++     -- For kinds, we only do an occurs check; we do not worry+     -- about type families or foralls+     -- See Note [Checking for foralls]+    fast_check_occ k | tv `elemVarSet` tyCoVarsOfType k = MTVU_Occurs+                     | otherwise                        = ok++     -- For coercions, we are only doing an occurs check here;+     -- no bother about impredicativity in coercions, as they're+     -- inferred+    fast_check_co co | tv `elemVarSet` tyCoVarsOfCo co = MTVU_Occurs+                     | otherwise                       = ok++    bad_tc :: TyCon -> Bool+    bad_tc tc+      | not (impredicative_ok || isTauTyCon tc)     = True+      | not (ty_fam_ok        || isFamFreeTyCon tc) = True+      | otherwise                                   = False++canUnifyWithPolyType :: DynFlags -> TcTyVarDetails -> Bool+canUnifyWithPolyType dflags details+  = case details of+      MetaTv { mtv_info = TyVarTv }    -> False+      MetaTv { mtv_info = TauTv }      -> xopt LangExt.ImpredicativeTypes dflags+      _other                           -> True+          -- We can have non-meta tyvars in given constraints
+ compiler/typecheck/TcUnify.hs-boot view
@@ -0,0 +1,15 @@+module TcUnify where++import GhcPrelude+import TcType      ( TcTauType )+import TcRnTypes   ( TcM )+import TcEvidence  ( TcCoercion )+import HsExpr      ( HsExpr )+import HsTypes     ( HsType )+import HsExtension ( GhcRn )++-- This boot file exists only to tie the knot between+--              TcUnify and Inst++unifyType :: Maybe (HsExpr GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion+unifyKind :: Maybe (HsType GhcRn) -> TcTauType -> TcTauType -> TcM TcCoercion
+ compiler/typecheck/TcValidity.hs view
@@ -0,0 +1,2845 @@+{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++{-# LANGUAGE CPP, TupleSections, ViewPatterns #-}++module TcValidity (+  Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType,+  checkValidTheta,+  checkValidInstance, checkValidInstHead, validDerivPred,+  checkTySynRhs,+  checkValidCoAxiom, checkValidCoAxBranch,+  checkValidTyFamEqn, checkConsistentFamInst,+  badATErr, arityErr,+  checkTyConTelescope,+  allDistinctTyVars+  ) where++#include "HsVersions.h"++import GhcPrelude++import Maybes++-- friends:+import TcUnify    ( tcSubType_NC )+import TcSimplify ( simplifyAmbiguityCheck )+import ClsInst    ( matchGlobalInst, ClsInstResult(..), InstanceWhat(..), AssocInstInfo(..) )+import TyCoRep+import TcType hiding ( sizeType, sizeTypes )+import TysWiredIn ( heqTyConName, eqTyConName, coercibleTyConName )+import PrelNames+import Type+import Unify      ( tcMatchTyX_BM, BindFlag(..) )+import Coercion+import CoAxiom+import Class+import TyCon++-- others:+import IfaceType( pprIfaceType, pprIfaceTypeApp )+import ToIface  ( toIfaceTyCon, toIfaceTcArgs, toIfaceType )+import HsSyn            -- HsType+import TcRnMonad        -- TcType, amongst others+import TcEnv       ( tcInitTidyEnv, tcInitOpenTidyEnv )+import FunDeps+import FamInstEnv  ( isDominatedBy, injectiveBranches,+                     InjectivityCheckResult(..) )+import FamInst     ( makeInjectivityErrors )+import Name+import VarEnv+import VarSet+import Var         ( VarBndr(..), mkTyVar )+import Id          ( idType, idName )+import FV+import ErrUtils+import DynFlags+import Util+import ListSetOps+import SrcLoc+import Outputable+import Unique      ( mkAlphaTyVarUnique )+import Bag         ( emptyBag )+import qualified GHC.LanguageExtensions as LangExt++import Control.Monad+import Data.Foldable+import Data.List        ( (\\), nub )+import qualified Data.List.NonEmpty as NE++{-+************************************************************************+*                                                                      *+          Checking for ambiguity+*                                                                      *+************************************************************************++Note [The ambiguity check for type signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+checkAmbiguity is a check on *user-supplied type signatures*.  It is+*purely* there to report functions that cannot possibly be called.  So for+example we want to reject:+   f :: C a => Int+The idea is there can be no legal calls to 'f' because every call will+give rise to an ambiguous constraint.  We could soundly omit the+ambiguity check on type signatures entirely, at the expense of+delaying ambiguity errors to call sites.  Indeed, the flag+-XAllowAmbiguousTypes switches off the ambiguity check.++What about things like this:+   class D a b | a -> b where ..+   h :: D Int b => Int+The Int may well fix 'b' at the call site, so that signature should+not be rejected.  Moreover, using *visible* fundeps is too+conservative.  Consider+   class X a b where ...+   class D a b | a -> b where ...+   instance D a b => X [a] b where...+   h :: X a b => a -> a+Here h's type looks ambiguous in 'b', but here's a legal call:+   ...(h [True])...+That gives rise to a (X [Bool] beta) constraint, and using the+instance means we need (D Bool beta) and that fixes 'beta' via D's+fundep!++Behind all these special cases there is a simple guiding principle.+Consider++  f :: <type>+  f = ...blah...++  g :: <type>+  g = f++You would think that the definition of g would surely typecheck!+After all f has exactly the same type, and g=f. But in fact f's type+is instantiated and the instantiated constraints are solved against+the originals, so in the case an ambiguous type it won't work.+Consider our earlier example f :: C a => Int.  Then in g's definition,+we'll instantiate to (C alpha) and try to deduce (C alpha) from (C a),+and fail.++So in fact we use this as our *definition* of ambiguity.  We use a+very similar test for *inferred* types, to ensure that they are+unambiguous. See Note [Impedance matching] in TcBinds.++This test is very conveniently implemented by calling+    tcSubType <type> <type>+This neatly takes account of the functional dependecy stuff above,+and implicit parameter (see Note [Implicit parameters and ambiguity]).+And this is what checkAmbiguity does.++What about this, though?+   g :: C [a] => Int+Is every call to 'g' ambiguous?  After all, we might have+   instance C [a] where ...+at the call site.  So maybe that type is ok!  Indeed even f's+quintessentially ambiguous type might, just possibly be callable:+with -XFlexibleInstances we could have+  instance C a where ...+and now a call could be legal after all!  Well, we'll reject this+unless the instance is available *here*.++Note [When to call checkAmbiguity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We call checkAmbiguity+   (a) on user-specified type signatures+   (b) in checkValidType++Conncerning (b), you might wonder about nested foralls.  What about+    f :: forall b. (forall a. Eq a => b) -> b+The nested forall is ambiguous.  Originally we called checkAmbiguity+in the forall case of check_type, but that had two bad consequences:+  * We got two error messages about (Eq b) in a nested forall like this:+       g :: forall a. Eq a => forall b. Eq b => a -> a+  * If we try to check for ambiguity of a nested forall like+    (forall a. Eq a => b), the implication constraint doesn't bind+    all the skolems, which results in "No skolem info" in error+    messages (see #10432).++To avoid this, we call checkAmbiguity once, at the top, in checkValidType.+(I'm still a bit worried about unbound skolems when the type mentions+in-scope type variables.)++In fact, because of the co/contra-variance implemented in tcSubType,+this *does* catch function f above. too.++Concerning (a) the ambiguity check is only used for *user* types, not+for types coming from inteface files.  The latter can legitimately+have ambiguous types. Example++   class S a where s :: a -> (Int,Int)+   instance S Char where s _ = (1,1)+   f:: S a => [a] -> Int -> (Int,Int)+   f (_::[a]) x = (a*x,b)+        where (a,b) = s (undefined::a)++Here the worker for f gets the type+        fw :: forall a. S a => Int -> (# Int, Int #)+++Note [Implicit parameters and ambiguity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Only a *class* predicate can give rise to ambiguity+An *implicit parameter* cannot.  For example:+        foo :: (?x :: [a]) => Int+        foo = length ?x+is fine.  The call site will supply a particular 'x'++Furthermore, the type variables fixed by an implicit parameter+propagate to the others.  E.g.+        foo :: (Show a, ?x::[a]) => Int+        foo = show (?x++?x)+The type of foo looks ambiguous.  But it isn't, because at a call site+we might have+        let ?x = 5::Int in foo+and all is well.  In effect, implicit parameters are, well, parameters,+so we can take their type variables into account as part of the+"tau-tvs" stuff.  This is done in the function 'FunDeps.grow'.+-}++checkAmbiguity :: UserTypeCtxt -> Type -> TcM ()+checkAmbiguity ctxt ty+  | wantAmbiguityCheck ctxt+  = do { traceTc "Ambiguity check for" (ppr ty)+         -- Solve the constraints eagerly because an ambiguous type+         -- can cause a cascade of further errors.  Since the free+         -- tyvars are skolemised, we can safely use tcSimplifyTop+       ; allow_ambiguous <- xoptM LangExt.AllowAmbiguousTypes+       ; (_wrap, wanted) <- addErrCtxt (mk_msg allow_ambiguous) $+                            captureConstraints $+                            tcSubType_NC ctxt ty ty+       ; simplifyAmbiguityCheck ty wanted++       ; traceTc "Done ambiguity check for" (ppr ty) }++  | otherwise+  = return ()+ where+   mk_msg allow_ambiguous+     = vcat [ text "In the ambiguity check for" <+> what+            , ppUnless allow_ambiguous ambig_msg ]+   ambig_msg = text "To defer the ambiguity check to use sites, enable AllowAmbiguousTypes"+   what | Just n <- isSigMaybe ctxt = quotes (ppr n)+        | otherwise                 = pprUserTypeCtxt ctxt++wantAmbiguityCheck :: UserTypeCtxt -> Bool+wantAmbiguityCheck ctxt+  = case ctxt of  -- See Note [When we don't check for ambiguity]+      GhciCtxt {}  -> False+      TySynCtxt {} -> False+      TypeAppCtxt  -> False+      _            -> True++checkUserTypeError :: Type -> TcM ()+-- Check to see if the type signature mentions "TypeError blah"+-- anywhere in it, and fail if so.+--+-- Very unsatisfactorily (#11144) we need to tidy the type+-- because it may have come from an /inferred/ signature, not a+-- user-supplied one.  This is really only a half-baked fix;+-- the other errors in checkValidType don't do tidying, and so+-- may give bad error messages when given an inferred type.+checkUserTypeError = check+  where+  check ty+    | Just msg     <- userTypeError_maybe ty  = fail_with msg+    | Just (_,ts)  <- splitTyConApp_maybe ty  = mapM_ check ts+    | Just (t1,t2) <- splitAppTy_maybe ty     = check t1 >> check t2+    | Just (_,t1)  <- splitForAllTy_maybe ty  = check t1+    | otherwise                               = return ()++  fail_with msg = do { env0 <- tcInitTidyEnv+                     ; let (env1, tidy_msg) = tidyOpenType env0 msg+                     ; failWithTcM (env1, pprUserTypeErrorTy tidy_msg) }+++{- Note [When we don't check for ambiguity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a few places we do not want to check a user-specified type for ambiguity++* GhciCtxt: Allow ambiguous types in GHCi's :kind command+  E.g.   type family T a :: *  -- T :: forall k. k -> *+  Then :k T should work in GHCi, not complain that+  (T k) is ambiguous!++* TySynCtxt: type T a b = C a b => blah+  It may be that when we /use/ T, we'll give an 'a' or 'b' that somehow+  cure the ambiguity.  So we defer the ambiguity check to the use site.++  There is also an implementation reason (#11608).  In the RHS of+  a type synonym we don't (currently) instantiate 'a' and 'b' with+  TcTyVars before calling checkValidType, so we get asertion failures+  from doing an ambiguity check on a type with TyVars in it.  Fixing this+  would not be hard, but let's wait till there's a reason.++* TypeAppCtxt: visible type application+     f @ty+  No need to check ty for ambiguity+++************************************************************************+*                                                                      *+          Checking validity of a user-defined type+*                                                                      *+************************************************************************++When dealing with a user-written type, we first translate it from an HsType+to a Type, performing kind checking, and then check various things that should+be true about it.  We don't want to perform these checks at the same time+as the initial translation because (a) they are unnecessary for interface-file+types and (b) when checking a mutually recursive group of type and class decls,+we can't "look" at the tycons/classes yet.  Also, the checks are rather+diverse, and used to really mess up the other code.++One thing we check for is 'rank'.++        Rank 0:         monotypes (no foralls)+        Rank 1:         foralls at the front only, Rank 0 inside+        Rank 2:         foralls at the front, Rank 1 on left of fn arrow,++        basic ::= tyvar | T basic ... basic++        r2  ::= forall tvs. cxt => r2a+        r2a ::= r1 -> r2a | basic+        r1  ::= forall tvs. cxt => r0+        r0  ::= r0 -> r0 | basic++Another thing is to check that type synonyms are saturated.+This might not necessarily show up in kind checking.+        type A i = i+        data T k = MkT (k Int)+        f :: T A        -- BAD!+-}++checkValidType :: UserTypeCtxt -> Type -> TcM ()+-- Checks that a user-written type is valid for the given context+-- Assumes argument is fully zonked+-- Not used for instance decls; checkValidInstance instead+checkValidType ctxt ty+  = do { traceTc "checkValidType" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty))+       ; rankn_flag  <- xoptM LangExt.RankNTypes+       ; impred_flag <- xoptM LangExt.ImpredicativeTypes+       ; let gen_rank :: Rank -> Rank+             gen_rank r | rankn_flag = ArbitraryRank+                        | otherwise  = r++             rank1 = gen_rank r1+             rank0 = gen_rank r0++             r0 = rankZeroMonoType+             r1 = LimitedRank True r0++             rank+               = case ctxt of+                 DefaultDeclCtxt-> MustBeMonoType+                 ResSigCtxt     -> MustBeMonoType+                 PatSigCtxt     -> rank0+                 RuleSigCtxt _  -> rank1+                 TySynCtxt _    -> rank0++                 ExprSigCtxt    -> rank1+                 KindSigCtxt    -> rank1+                 TypeAppCtxt | impred_flag -> ArbitraryRank+                             | otherwise   -> tyConArgMonoType+                    -- Normally, ImpredicativeTypes is handled in check_arg_type,+                    -- but visible type applications don't go through there.+                    -- So we do this check here.++                 FunSigCtxt {}  -> rank1+                 InfSigCtxt _   -> ArbitraryRank        -- Inferred type+                 ConArgCtxt _   -> rank1 -- We are given the type of the entire+                                         -- constructor, hence rank 1+                 PatSynCtxt _   -> rank1++                 ForSigCtxt _   -> rank1+                 SpecInstCtxt   -> rank1+                 ThBrackCtxt    -> rank1+                 GhciCtxt {}    -> ArbitraryRank++                 TyVarBndrKindCtxt _ -> rank0+                 DataKindCtxt _      -> rank1+                 TySynKindCtxt _     -> rank1+                 TyFamResKindCtxt _  -> rank1++                 _              -> panic "checkValidType"+                                          -- Can't happen; not used for *user* sigs++       ; env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty)+       ; expand <- initialExpandMode+       ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt+                             , ve_rank = rank, ve_expand = expand }++       -- Check the internal validity of the type itself+       -- Fail if bad things happen, else we misleading+       -- (and more complicated) errors in checkAmbiguity+       ; checkNoErrs $+         do { check_type ve ty+            ; checkUserTypeError ty+            ; traceTc "done ct" (ppr ty) }++       -- Check for ambiguous types.  See Note [When to call checkAmbiguity]+       -- NB: this will happen even for monotypes, but that should be cheap;+       --     and there may be nested foralls for the subtype test to examine+       ; checkAmbiguity ctxt ty++       ; traceTc "checkValidType done" (ppr ty <+> text "::" <+> ppr (tcTypeKind ty)) }++checkValidMonoType :: Type -> TcM ()+-- Assumes argument is fully zonked+checkValidMonoType ty+  = do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypeList ty)+       ; expand <- initialExpandMode+       ; let ve = ValidityEnv{ ve_tidy_env = env, ve_ctxt = SigmaCtxt+                             , ve_rank = MustBeMonoType, ve_expand = expand }+       ; check_type ve ty }++checkTySynRhs :: UserTypeCtxt -> TcType -> TcM ()+checkTySynRhs ctxt ty+  | tcReturnsConstraintKind actual_kind+  = do { ck <- xoptM LangExt.ConstraintKinds+       ; if ck+         then  when (tcIsConstraintKind actual_kind)+                    (do { dflags <- getDynFlags+                        ; expand <- initialExpandMode+                        ; check_pred_ty emptyTidyEnv dflags ctxt expand ty })+         else addErrTcM (constraintSynErr emptyTidyEnv actual_kind) }++  | otherwise+  = return ()+  where+    actual_kind = tcTypeKind ty++{-+Note [Higher rank types]+~~~~~~~~~~~~~~~~~~~~~~~~+Technically+            Int -> forall a. a->a+is still a rank-1 type, but it's not Haskell 98 (#5957).  So the+validity checker allow a forall after an arrow only if we allow it+before -- that is, with Rank2Types or RankNTypes+-}++data Rank = ArbitraryRank         -- Any rank ok++          | LimitedRank   -- Note [Higher rank types]+                 Bool     -- Forall ok at top+                 Rank     -- Use for function arguments++          | MonoType SDoc   -- Monotype, with a suggestion of how it could be a polytype++          | MustBeMonoType  -- Monotype regardless of flags++instance Outputable Rank where+  ppr ArbitraryRank  = text "ArbitraryRank"+  ppr (LimitedRank top_forall_ok r)+                     = text "LimitedRank" <+> ppr top_forall_ok+                                          <+> parens (ppr r)+  ppr (MonoType msg) = text "MonoType" <+> parens msg+  ppr MustBeMonoType = text "MustBeMonoType"++rankZeroMonoType, tyConArgMonoType, synArgMonoType, constraintMonoType :: Rank+rankZeroMonoType   = MonoType (text "Perhaps you intended to use RankNTypes")+tyConArgMonoType   = MonoType (text "GHC doesn't yet support impredicative polymorphism")+synArgMonoType     = MonoType (text "Perhaps you intended to use LiberalTypeSynonyms")+constraintMonoType = MonoType (vcat [ text "A constraint must be a monotype"+                                    , text "Perhaps you intended to use QuantifiedConstraints" ])++funArgResRank :: Rank -> (Rank, Rank)             -- Function argument and result+funArgResRank (LimitedRank _ arg_rank) = (arg_rank, LimitedRank (forAllAllowed arg_rank) arg_rank)+funArgResRank other_rank               = (other_rank, other_rank)++forAllAllowed :: Rank -> Bool+forAllAllowed ArbitraryRank             = True+forAllAllowed (LimitedRank forall_ok _) = forall_ok+forAllAllowed _                         = False++allConstraintsAllowed :: UserTypeCtxt -> Bool+-- We don't allow arbitrary constraints in kinds+allConstraintsAllowed (TyVarBndrKindCtxt {}) = False+allConstraintsAllowed (DataKindCtxt {})      = False+allConstraintsAllowed (TySynKindCtxt {})     = False+allConstraintsAllowed (TyFamResKindCtxt {})  = False+allConstraintsAllowed _ = True++-- | Returns 'True' if the supplied 'UserTypeCtxt' is unambiguously not the+-- context for the type of a term, where visible, dependent quantification is+-- currently disallowed.+--+-- An example of something that is unambiguously the type of a term is the+-- @forall a -> a -> a@ in @foo :: forall a -> a -> a@. On the other hand, the+-- same type in @type family Foo :: forall a -> a -> a@ is unambiguously the+-- kind of a type, not the type of a term, so it is permitted.+--+-- For more examples, see+-- @testsuite/tests/dependent/should_compile/T16326_Compile*.hs@ (for places+-- where VDQ is permitted) and+-- @testsuite/tests/dependent/should_fail/T16326_Fail*.hs@ (for places where+-- VDQ is disallowed).+vdqAllowed :: UserTypeCtxt -> Bool+-- Currently allowed in the kinds of types...+vdqAllowed (KindSigCtxt {}) = True+vdqAllowed (TySynCtxt {}) = True+vdqAllowed (ThBrackCtxt {}) = True+vdqAllowed (GhciCtxt {}) = True+vdqAllowed (TyVarBndrKindCtxt {}) = True+vdqAllowed (DataKindCtxt {}) = True+vdqAllowed (TySynKindCtxt {}) = True+vdqAllowed (TyFamResKindCtxt {}) = True+-- ...but not in the types of terms.+vdqAllowed (ConArgCtxt {}) = False+  -- We could envision allowing VDQ in data constructor types so long as the+  -- constructor is only ever used at the type level, but for now, GHC adopts+  -- the stance that VDQ is never allowed in data constructor types.+vdqAllowed (FunSigCtxt {}) = False+vdqAllowed (InfSigCtxt {}) = False+vdqAllowed (ExprSigCtxt {}) = False+vdqAllowed (TypeAppCtxt {}) = False+vdqAllowed (PatSynCtxt {}) = False+vdqAllowed (PatSigCtxt {}) = False+vdqAllowed (RuleSigCtxt {}) = False+vdqAllowed (ResSigCtxt {}) = False+vdqAllowed (ForSigCtxt {}) = False+vdqAllowed (DefaultDeclCtxt {}) = False+-- We count class constraints as "types of terms". All of the cases below deal+-- with class constraints.+vdqAllowed (InstDeclCtxt {}) = False+vdqAllowed (SpecInstCtxt {}) = False+vdqAllowed (GenSigCtxt {}) = False+vdqAllowed (ClassSCCtxt {}) = False+vdqAllowed (SigmaCtxt {}) = False+vdqAllowed (DataTyCtxt {}) = False+vdqAllowed (DerivClauseCtxt {}) = False++{-+Note [Correctness and performance of type synonym validity checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the type A arg1 arg2, where A is a type synonym. How should we check+this type for validity? We have three distinct choices, corresponding to the+three constructors of ExpandMode:++1. Expand the application of A, and check the resulting type (`Expand`).+2. Don't expand the application of A. Only check the arguments (`NoExpand`).+3. Check the arguments *and* check the expanded type (`Both`).++It's tempting to think that we could always just pick choice (3), but this+results in serious performance issues when checking a type like in the+signature for `f` below:++  type S = ...+  f :: S (S (S (S (S (S ....(S Int)...))))++When checking the type of `f`, we'll check the outer `S` application with and+without expansion, and in *each* of those checks, we'll check the next `S`+application with and without expansion... the result is exponential blowup! So+clearly we don't want to use `Both` 100% of the time.++On the other hand, neither is it correct to use exclusively `Expand` or+exclusively `NoExpand` 100% of the time:++* If one always expands, then one can miss erroneous programs like the one in+  the `tcfail129` test case:++    type Foo a = String -> Maybe a+    type Bar m = m Int+    blah = undefined :: Bar Foo++  If we expand `Bar Foo` immediately, we'll miss the fact that the `Foo` type+  synonyms is unsaturated.+* If one never expands and only checks the arguments, then one can miss+  erroneous programs like the one in #16059:++    type Foo b = Eq b => b+    f :: forall b (a :: Foo b). Int++  The kind of `a` contains a constraint, which is illegal, but this will only+  be caught if `Foo b` is expanded.++Therefore, it's impossible to have these validity checks be simultaneously+correct and performant if one sticks exclusively to a single `ExpandMode`. In+that case, the solution is to vary the `ExpandMode`s! In more detail:++1. When we start validity checking, we start with `Expand` if+   LiberalTypeSynonyms is enabled (see Note [Liberal type synonyms] for why we+   do this), and we start with `Both` otherwise. The `initialExpandMode`+   function is responsible for this.+2. When expanding an application of a type synonym (in `check_syn_tc_app`), we+   determine which things to check based on the current `ExpandMode` argument.+   Importantly, if the current mode is `Both`, then we check the arguments in+   `NoExpand` mode and check the expanded type in `Both` mode.++   Switching to `NoExpand` when checking the arguments is vital to avoid+   exponential blowup. One consequence of this choice is that if you have+   the following type synonym in one module (with RankNTypes enabled):++     {-# LANGUAGE RankNTypes #-}+     module A where+     type A = forall a. a++   And you define the following in a separate module *without* RankNTypes+   enabled:++     module B where++     import A++     type Const a b = a+     f :: Const Int A -> Int++   Then `f` will be accepted, even though `A` (which is technically a rank-n+   type) appears in its type. We view this as an acceptable compromise, since+   `A` never appears in the type of `f` post-expansion. If `A` _did_ appear in+   a type post-expansion, such as in the following variant:++     g :: Const A A -> Int++   Then that would be rejected unless RankNTypes were enabled.+-}++-- | When validity-checking an application of a type synonym, should we+-- check the arguments, check the expanded type, or both?+-- See Note [Correctness and performance of type synonym validity checking]+data ExpandMode+  = Expand   -- ^ Only check the expanded type.+  | NoExpand -- ^ Only check the arguments.+  | Both     -- ^ Check both the arguments and the expanded type.++instance Outputable ExpandMode where+  ppr e = text $ case e of+                   Expand   -> "Expand"+                   NoExpand -> "NoExpand"+                   Both     -> "Both"++-- | If @LiberalTypeSynonyms@ is enabled, we start in 'Expand' mode for the+-- reasons explained in @Note [Liberal type synonyms]@. Otherwise, we start+-- in 'Both' mode.+initialExpandMode :: TcM ExpandMode+initialExpandMode = do+  liberal_flag <- xoptM LangExt.LiberalTypeSynonyms+  pure $ if liberal_flag then Expand else Both++-- | Information about a type being validity-checked.+data ValidityEnv = ValidityEnv+  { ve_tidy_env :: TidyEnv+  , ve_ctxt     :: UserTypeCtxt+  , ve_rank     :: Rank+  , ve_expand   :: ExpandMode }++instance Outputable ValidityEnv where+  ppr (ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt+                  , ve_rank = rank, ve_expand = expand }) =+    hang (text "ValidityEnv")+       2 (vcat [ text "ve_tidy_env" <+> ppr env+               , text "ve_ctxt"     <+> pprUserTypeCtxt ctxt+               , text "ve_rank"     <+> ppr rank+               , text "ve_expand"   <+> ppr expand ])++----------------------------------------+check_type :: ValidityEnv -> Type -> TcM ()+-- The args say what the *type context* requires, independent+-- of *flag* settings.  You test the flag settings at usage sites.+--+-- Rank is allowed rank for function args+-- Rank 0 means no for-alls anywhere++check_type _ (TyVarTy _) = return ()++check_type ve (AppTy ty1 ty2)+  = do  { check_type ve ty1+        ; check_arg_type False ve ty2 }++check_type ve ty@(TyConApp tc tys)+  | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc+  = check_syn_tc_app ve ty tc tys+  | isUnboxedTupleTyCon tc = check_ubx_tuple ve ty tys+  | otherwise              = mapM_ (check_arg_type False ve) tys++check_type _ (LitTy {}) = return ()++check_type ve (CastTy ty _) = check_type ve ty++-- Check for rank-n types, such as (forall x. x -> x) or (Show x => x).+--+-- Critically, this case must come *after* the case for TyConApp.+-- See Note [Liberal type synonyms].+check_type ve@(ValidityEnv{ ve_tidy_env = env, ve_ctxt = ctxt+                          , ve_rank = rank, ve_expand = expand }) ty+  | not (null tvbs && null theta)+  = do  { traceTc "check_type" (ppr ty $$ ppr (forAllAllowed rank))+        ; checkTcM (forAllAllowed rank) (forAllTyErr env rank ty)+                -- Reject e.g. (Maybe (?x::Int => Int)),+                -- with a decent error message++        ; checkConstraintsOK ve theta ty+                -- Reject forall (a :: Eq b => b). blah+                -- In a kind signature we don't allow constraints++        ; checkTcM (all (isInvisibleArgFlag . binderArgFlag) tvbs+                         || vdqAllowed ctxt)+                   (illegalVDQTyErr env ty)+                -- Reject visible, dependent quantification in the type of a+                -- term (e.g., `f :: forall a -> a -> Maybe a`)++        ; check_valid_theta env' SigmaCtxt expand theta+                -- Allow     type T = ?x::Int => Int -> Int+                -- but not   type T = ?x::Int++        ; check_type (ve{ve_tidy_env = env'}) tau+                -- Allow foralls to right of arrow++        ; checkEscapingKind env' tvbs' theta tau }+  where+    (tvbs, phi)   = tcSplitForAllVarBndrs ty+    (theta, tau)  = tcSplitPhiTy phi+    (env', tvbs') = tidyTyCoVarBinders env tvbs++check_type (ve@ValidityEnv{ve_rank = rank}) (FunTy _ arg_ty res_ty)+  = do  { check_type (ve{ve_rank = arg_rank}) arg_ty+        ; check_type (ve{ve_rank = res_rank}) res_ty }+  where+    (arg_rank, res_rank) = funArgResRank rank++check_type _ ty = pprPanic "check_type" (ppr ty)++----------------------------------------+check_syn_tc_app :: ValidityEnv+                 -> KindOrType -> TyCon -> [KindOrType] -> TcM ()+-- Used for type synonyms and type synonym families,+-- which must be saturated,+-- but not data families, which need not be saturated+check_syn_tc_app (ve@ValidityEnv{ ve_ctxt = ctxt, ve_expand = expand })+                 ty tc tys+  | tys `lengthAtLeast` tc_arity   -- Saturated+       -- Check that the synonym has enough args+       -- This applies equally to open and closed synonyms+       -- It's OK to have an *over-applied* type synonym+       --      data Tree a b = ...+       --      type Foo a = Tree [a]+       --      f :: Foo a b -> ...+  = case expand of+      _ |  isTypeFamilyTyCon tc+        -> check_args_only expand+      -- See Note [Correctness and performance of type synonym validity+      --           checking]+      Expand   -> check_expansion_only expand+      NoExpand -> check_args_only expand+      Both     -> check_args_only NoExpand *> check_expansion_only Both++  | GhciCtxt True <- ctxt  -- Accept outermost under-saturated type synonym or+                           -- type family constructors in GHCi :kind commands.+                           -- See Note [Unsaturated type synonyms in GHCi]+  = check_args_only expand++  | otherwise+  = failWithTc (tyConArityErr tc tys)+  where+    tc_arity  = tyConArity tc++    check_arg :: ExpandMode -> KindOrType -> TcM ()+    check_arg expand =+      check_arg_type (isTypeSynonymTyCon tc) (ve{ve_expand = expand})++    check_args_only, check_expansion_only :: ExpandMode -> TcM ()+    check_args_only expand = mapM_ (check_arg expand) tys++    check_expansion_only expand+      = ASSERT2( isTypeSynonymTyCon tc, ppr tc )+        case tcView ty of+         Just ty' -> let err_ctxt = text "In the expansion of type synonym"+                                    <+> quotes (ppr tc)+                     in addErrCtxt err_ctxt $+                        check_type (ve{ve_expand = expand}) ty'+         Nothing  -> pprPanic "check_syn_tc_app" (ppr ty)++{-+Note [Unsaturated type synonyms in GHCi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking, GHC disallows unsaturated uses of type synonyms or type+families. For instance, if one defines `type Const a b = a`, then GHC will not+permit using `Const` unless it is applied to (at least) two arguments. There is+an exception to this rule, however: GHCi's :kind command. For instance, it+is quite common to look up the kind of a type constructor like so:++  λ> :kind Const+  Const :: j -> k -> j+  λ> :kind Const Int+  Const Int :: k -> Type++Strictly speaking, the two uses of `Const` above are unsaturated, but this+is an extremely benign (and useful) example of unsaturation, so we allow it+here as a special case.++That being said, we do not allow unsaturation carte blanche in GHCi. Otherwise,+this GHCi interaction would be possible:++  λ> newtype Fix f = MkFix (f (Fix f))+  λ> type Id a = a+  λ> :kind Fix Id+  Fix Id :: Type++This is rather dodgy, so we move to disallow this. We only permit unsaturated+synonyms in GHCi if they are *top-level*—that is, if the synonym is the+outermost type being applied. This allows `Const` and `Const Int` in the+first example, but not `Fix Id` in the second example, as `Id` is not the+outermost type being applied (`Fix` is).++We track this outermost property in the GhciCtxt constructor of UserTypeCtxt.+A field of True in GhciCtxt indicates that we're in an outermost position. Any+time we invoke `check_arg` to check the validity of an argument, we switch the+field to False.+-}++----------------------------------------+check_ubx_tuple :: ValidityEnv -> KindOrType -> [KindOrType] -> TcM ()+check_ubx_tuple (ve@ValidityEnv{ve_tidy_env = env}) ty tys+  = do  { ub_tuples_allowed <- xoptM LangExt.UnboxedTuples+        ; checkTcM ub_tuples_allowed (ubxArgTyErr env ty)++        ; impred <- xoptM LangExt.ImpredicativeTypes+        ; let rank' = if impred then ArbitraryRank else tyConArgMonoType+                -- c.f. check_arg_type+                -- However, args are allowed to be unlifted, or+                -- more unboxed tuples, so can't use check_arg_ty+        ; mapM_ (check_type (ve{ve_rank = rank'})) tys }++----------------------------------------+check_arg_type+  :: Bool -- ^ Is this the argument to a type synonym?+  -> ValidityEnv -> KindOrType -> TcM ()+-- The sort of type that can instantiate a type variable,+-- or be the argument of a type constructor.+-- Not an unboxed tuple, but now *can* be a forall (since impredicativity)+-- Other unboxed types are very occasionally allowed as type+-- arguments depending on the kind of the type constructor+--+-- For example, we want to reject things like:+--+--      instance Ord a => Ord (forall s. T s a)+-- and+--      g :: T s (forall b.b)+--+-- NB: unboxed tuples can have polymorphic or unboxed args.+--     This happens in the workers for functions returning+--     product types with polymorphic components.+--     But not in user code.+-- Anyway, they are dealt with by a special case in check_tau_type++check_arg_type _ _ (CoercionTy {}) = return ()++check_arg_type type_syn (ve@ValidityEnv{ve_ctxt = ctxt, ve_rank = rank}) ty+  = do  { impred <- xoptM LangExt.ImpredicativeTypes+        ; let rank' = case rank of          -- Predictive => must be monotype+                        -- Rank-n arguments to type synonyms are OK, provided+                        -- that LiberalTypeSynonyms is enabled.+                        _ | type_syn       -> synArgMonoType+                        MustBeMonoType     -> MustBeMonoType  -- Monotype, regardless+                        _other | impred    -> ArbitraryRank+                               | otherwise -> tyConArgMonoType+                        -- Make sure that MustBeMonoType is propagated,+                        -- so that we don't suggest -XImpredicativeTypes in+                        --    (Ord (forall a.a)) => a -> a+                        -- and so that if it Must be a monotype, we check that it is!+              ctxt' :: UserTypeCtxt+              ctxt'+                | GhciCtxt _ <- ctxt = GhciCtxt False+                    -- When checking an argument, set the field of GhciCtxt to+                    -- False to indicate that we are no longer in an outermost+                    -- position (and thus unsaturated synonyms are no longer+                    -- allowed).+                    -- See Note [Unsaturated type synonyms in GHCi]+                | otherwise          = ctxt++        ; check_type (ve{ve_ctxt = ctxt', ve_rank = rank'}) ty }++----------------------------------------+forAllTyErr :: TidyEnv -> Rank -> Type -> (TidyEnv, SDoc)+forAllTyErr env rank ty+   = ( env+     , vcat [ hang herald 2 (ppr_tidy env ty)+            , suggestion ] )+  where+    (tvs, _theta, _tau) = tcSplitSigmaTy ty+    herald | null tvs  = text "Illegal qualified type:"+           | otherwise = text "Illegal polymorphic type:"+    suggestion = case rank of+                   LimitedRank {} -> text "Perhaps you intended to use RankNTypes"+                   MonoType d     -> d+                   _              -> Outputable.empty -- Polytype is always illegal++-- | Reject type variables that would escape their escape through a kind.+-- See @Note [Type variables escaping through kinds]@.+checkEscapingKind :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> TcM ()+checkEscapingKind env tvbs theta tau =+  case occCheckExpand (binderVars tvbs) phi_kind of+    -- Ensure that none of the tvs occur in the kind of the forall+    -- /after/ expanding type synonyms.+    -- See Note [Phantom type variables in kinds] in Type+    Nothing -> failWithTcM $ forAllEscapeErr env tvbs theta tau tau_kind+    Just _  -> pure ()+  where+    tau_kind              = tcTypeKind tau+    phi_kind | null theta = tau_kind+             | otherwise  = liftedTypeKind+        -- If there are any constraints, the kind is *. (#11405)++forAllEscapeErr :: TidyEnv -> [TyVarBinder] -> ThetaType -> Type -> Kind+                -> (TidyEnv, SDoc)+forAllEscapeErr env tvbs theta tau tau_kind+  = ( env+    , vcat [ hang (text "Quantified type's kind mentions quantified type variable")+                2 (text "type:" <+> quotes (ppr (mkSigmaTy tvbs theta tau)))+                -- NB: Don't tidy this type since the tvbs were already tidied+                -- previously, and re-tidying them will make the names of type+                -- variables different from tau_kind.+           , hang (text "where the body of the forall has this kind:")+                2 (quotes (ppr_tidy env tau_kind)) ] )++{-+Note [Type variables escaping through kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:++  type family T (r :: RuntimeRep) :: TYPE r+  foo :: forall r. T r++Something smells funny about the type of `foo`. If you spell out the kind+explicitly, it becomes clearer from where the smell originates:++  foo :: ((forall r. T r) :: TYPE r)++The type variable `r` appears in the result kind, which escapes the scope of+its binding site! This is not desirable, so we establish a validity check+(`checkEscapingKind`) to catch any type variables that might escape through+kinds in this way.+-}++ubxArgTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)+ubxArgTyErr env ty+  = ( env, vcat [ sep [ text "Illegal unboxed tuple type as function argument:"+                      , ppr_tidy env ty ]+                , text "Perhaps you intended to use UnboxedTuples" ] )++checkConstraintsOK :: ValidityEnv -> ThetaType -> Type -> TcM ()+checkConstraintsOK ve theta ty+  | null theta                         = return ()+  | allConstraintsAllowed (ve_ctxt ve) = return ()+  | otherwise+  = -- We are in a kind, where we allow only equality predicates+    -- See Note [Constraints in kinds] in TyCoRep, and #16263+    checkTcM (all isEqPred theta) $+    constraintTyErr (ve_tidy_env ve) ty++constraintTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)+constraintTyErr env ty+  = (env, text "Illegal constraint in a kind:" <+> ppr_tidy env ty)++-- | Reject a use of visible, dependent quantification in the type of a term.+illegalVDQTyErr :: TidyEnv -> Type -> (TidyEnv, SDoc)+illegalVDQTyErr env ty =+  (env, vcat+  [ hang (text "Illegal visible, dependent quantification" <+>+          text "in the type of a term:")+       2 (ppr_tidy env ty)+  , text "(GHC does not yet support this)" ] )++{-+Note [Liberal type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If -XLiberalTypeSynonyms is on, expand closed type synonyms *before*+doing validity checking.  This allows us to instantiate a synonym defn+with a for-all type, or with a partially-applied type synonym.+        e.g.   type T a b = a+               type S m   = m ()+               f :: S (T Int)+Here, T is partially applied, so it's illegal in H98.  But if you+expand S first, then T we get just+               f :: Int+which is fine.++IMPORTANT: suppose T is a type synonym.  Then we must do validity+checking on an appliation (T ty1 ty2)++        *either* before expansion (i.e. check ty1, ty2)+        *or* after expansion (i.e. expand T ty1 ty2, and then check)+        BUT NOT BOTH++If we do both, we get exponential behaviour!!++  data TIACons1 i r c = c i ::: r c+  type TIACons2 t x = TIACons1 t (TIACons1 t x)+  type TIACons3 t x = TIACons2 t (TIACons1 t x)+  type TIACons4 t x = TIACons2 t (TIACons2 t x)+  type TIACons7 t x = TIACons4 t (TIACons3 t x)++The order in which you do validity checking is also somewhat delicate. Consider+the `check_type` function, which drives the validity checking for unsaturated+uses of type synonyms. There is a special case for rank-n types, such as+(forall x. x -> x) or (Show x => x), since those require at least one language+extension to use. It used to be the case that this case came before every other+case, but this can lead to bugs. Imagine you have this scenario (from #15954):++  type A a = Int+  type B (a :: Type -> Type) = forall x. x -> x+  type C = B A++If the rank-n case came first, then in the process of checking for `forall`s+or contexts, we would expand away `B A` to `forall x. x -> x`. This is because+the functions that split apart `forall`s/contexts+(tcSplitForAllVarBndrs/tcSplitPhiTy) expand type synonyms! If `B A` is expanded+away to `forall x. x -> x` before the actually validity checks occur, we will+have completely obfuscated the fact that we had an unsaturated application of+the `A` type synonym.++We have since learned from our mistakes and now put this rank-n case /after/+the case for TyConApp, which ensures that an unsaturated `A` TyConApp will be+caught properly. But be careful! We can't make the rank-n case /last/ either,+as the FunTy case must came after the rank-n case. Otherwise, something like+(Eq a => Int) would be treated as a function type (FunTy), which just+wouldn't do.++************************************************************************+*                                                                      *+\subsection{Checking a theta or source type}+*                                                                      *+************************************************************************++Note [Implicit parameters in instance decls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Implicit parameters _only_ allowed in type signatures; not in instance+decls, superclasses etc. The reason for not allowing implicit params in+instances is a bit subtle.  If we allowed+  instance (?x::Int, Eq a) => Foo [a] where ...+then when we saw+     (e :: (?x::Int) => t)+it would be unclear how to discharge all the potential uses of the ?x+in e.  For example, a constraint Foo [Int] might come out of e, and+applying the instance decl would show up two uses of ?x.  #8912.+-}++checkValidTheta :: UserTypeCtxt -> ThetaType -> TcM ()+-- Assumes argument is fully zonked+checkValidTheta ctxt theta+  = addErrCtxtM (checkThetaCtxt ctxt theta) $+    do { env <- tcInitOpenTidyEnv (tyCoVarsOfTypesList theta)+       ; expand <- initialExpandMode+       ; check_valid_theta env ctxt expand theta }++-------------------------+check_valid_theta :: TidyEnv -> UserTypeCtxt -> ExpandMode+                  -> [PredType] -> TcM ()+check_valid_theta _ _ _ []+  = return ()+check_valid_theta env ctxt expand theta+  = do { dflags <- getDynFlags+       ; warnTcM (Reason Opt_WarnDuplicateConstraints)+                 (wopt Opt_WarnDuplicateConstraints dflags && notNull dups)+                 (dupPredWarn env dups)+       ; traceTc "check_valid_theta" (ppr theta)+       ; mapM_ (check_pred_ty env dflags ctxt expand) theta }+  where+    (_,dups) = removeDups nonDetCmpType theta+    -- It's OK to use nonDetCmpType because dups only appears in the+    -- warning++-------------------------+{- Note [Validity checking for constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We look through constraint synonyms so that we can see the underlying+constraint(s).  For example+   type Foo = ?x::Int+   instance Foo => C T+We should reject the instance because it has an implicit parameter in+the context.++But we record, in 'under_syn', whether we have looked under a synonym+to avoid requiring language extensions at the use site.  Main example+(#9838):++   {-# LANGUAGE ConstraintKinds #-}+   module A where+      type EqShow a = (Eq a, Show a)++   module B where+      import A+      foo :: EqShow a => a -> String++We don't want to require ConstraintKinds in module B.+-}++check_pred_ty :: TidyEnv -> DynFlags -> UserTypeCtxt -> ExpandMode+              -> PredType -> TcM ()+-- Check the validity of a predicate in a signature+-- See Note [Validity checking for constraints]+check_pred_ty env dflags ctxt expand pred+  = do { check_type ve pred+       ; check_pred_help False env dflags ctxt pred }+  where+    rank | xopt LangExt.QuantifiedConstraints dflags+         = ArbitraryRank+         | otherwise+         = constraintMonoType++    ve :: ValidityEnv+    ve = ValidityEnv{ ve_tidy_env = env+                    , ve_ctxt     = SigmaCtxt+                    , ve_rank     = rank+                    , ve_expand   = expand }++check_pred_help :: Bool    -- True <=> under a type synonym+                -> TidyEnv+                -> DynFlags -> UserTypeCtxt+                -> PredType -> TcM ()+check_pred_help under_syn env dflags ctxt pred+  | Just pred' <- tcView pred  -- Switch on under_syn when going under a+                                 -- synonym (#9838, yuk)+  = check_pred_help True env dflags ctxt pred'++  | otherwise  -- A bit like classifyPredType, but not the same+               -- E.g. we treat (~) like (~#); and we look inside tuples+  = case classifyPredType pred of+      ClassPred cls tys+        | isCTupleClass cls   -> check_tuple_pred under_syn env dflags ctxt pred tys+        | otherwise           -> check_class_pred env dflags ctxt pred cls tys++      EqPred NomEq _ _  -> -- a ~# b+                           check_eq_pred env dflags pred++      EqPred ReprEq _ _ -> -- Ugh!  When inferring types we may get+                           -- f :: (a ~R# b) => blha+                           -- And we want to treat that like (Coercible a b)+                           -- We should probably check argument shapes, but we+                           -- didn't do so before, so I'm leaving it for now+                           return ()++      ForAllPred _ theta head -> check_quant_pred env dflags ctxt pred theta head+      IrredPred {}            -> check_irred_pred under_syn env dflags ctxt pred++check_eq_pred :: TidyEnv -> DynFlags -> PredType -> TcM ()+check_eq_pred env dflags pred+  =         -- Equational constraints are valid in all contexts if type+            -- families are permitted+    checkTcM (xopt LangExt.TypeFamilies dflags+              || xopt LangExt.GADTs dflags)+             (eqPredTyErr env pred)++check_quant_pred :: TidyEnv -> DynFlags -> UserTypeCtxt+                 -> PredType -> ThetaType -> PredType -> TcM ()+check_quant_pred env dflags _ctxt pred theta head_pred+  = addErrCtxt (text "In the quantified constraint" <+> quotes (ppr pred)) $+    do { -- Check the instance head+         case classifyPredType head_pred of+            ClassPred cls tys -> checkValidInstHead SigmaCtxt cls tys+                                 -- SigmaCtxt tells checkValidInstHead that+                                 -- this is the head of a quantified constraint+            IrredPred {}      | hasTyVarHead head_pred+                              -> return ()+            _                 -> failWithTcM (badQuantHeadErr env pred)++         -- Check for termination+       ; unless (xopt LangExt.UndecidableInstances dflags) $+         checkInstTermination theta head_pred+    }++check_tuple_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> [PredType] -> TcM ()+check_tuple_pred under_syn env dflags ctxt pred ts+  = do { -- See Note [ConstraintKinds in predicates]+         checkTcM (under_syn || xopt LangExt.ConstraintKinds dflags)+                  (predTupleErr env pred)+       ; mapM_ (check_pred_help under_syn env dflags ctxt) ts }+    -- This case will not normally be executed because without+    -- -XConstraintKinds tuple types are only kind-checked as *++check_irred_pred :: Bool -> TidyEnv -> DynFlags -> UserTypeCtxt -> PredType -> TcM ()+check_irred_pred under_syn env dflags ctxt pred+    -- The predicate looks like (X t1 t2) or (x t1 t2) :: Constraint+    -- where X is a type function+  = do { -- If it looks like (x t1 t2), require ConstraintKinds+         --   see Note [ConstraintKinds in predicates]+         -- But (X t1 t2) is always ok because we just require ConstraintKinds+         -- at the definition site (#9838)+        failIfTcM (not under_syn && not (xopt LangExt.ConstraintKinds dflags)+                                && hasTyVarHead pred)+                  (predIrredErr env pred)++         -- Make sure it is OK to have an irred pred in this context+         -- See Note [Irreducible predicates in superclasses]+       ; failIfTcM (is_superclass ctxt+                    && not (xopt LangExt.UndecidableInstances dflags)+                    && has_tyfun_head pred)+                   (predSuperClassErr env pred) }+  where+    is_superclass ctxt = case ctxt of { ClassSCCtxt _ -> True; _ -> False }+    has_tyfun_head ty+      = case tcSplitTyConApp_maybe ty of+          Just (tc, _) -> isTypeFamilyTyCon tc+          Nothing      -> False++{- Note [ConstraintKinds in predicates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Don't check for -XConstraintKinds under a type synonym, because that+was done at the type synonym definition site; see #9838+e.g.   module A where+          type C a = (Eq a, Ix a)   -- Needs -XConstraintKinds+       module B where+          import A+          f :: C a => a -> a        -- Does *not* need -XConstraintKinds++Note [Irreducible predicates in superclasses]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Allowing type-family calls in class superclasses is somewhat dangerous+because we can write:++ type family Fooish x :: * -> Constraint+ type instance Fooish () = Foo+ class Fooish () a => Foo a where++This will cause the constraint simplifier to loop because every time we canonicalise a+(Foo a) class constraint we add a (Fooish () a) constraint which will be immediately+solved to add+canonicalise another (Foo a) constraint.  -}++-------------------------+check_class_pred :: TidyEnv -> DynFlags -> UserTypeCtxt+                 -> PredType -> Class -> [TcType] -> TcM ()+check_class_pred env dflags ctxt pred cls tys+  |  isEqPredClass cls    -- (~) and (~~) are classified as classes,+                          -- but here we want to treat them as equalities+  = -- pprTrace "check_class" (ppr cls) $+    check_eq_pred env dflags pred++  | isIPClass cls+  = do { check_arity+       ; checkTcM (okIPCtxt ctxt) (badIPPred env pred) }++  | otherwise     -- Includes Coercible+  = do { check_arity+       ; checkSimplifiableClassConstraint env dflags ctxt cls tys+       ; checkTcM arg_tys_ok (predTyVarErr env pred) }+  where+    check_arity = checkTc (tys `lengthIs` classArity cls)+                          (tyConArityErr (classTyCon cls) tys)++    -- Check the arguments of a class constraint+    flexible_contexts = xopt LangExt.FlexibleContexts     dflags+    undecidable_ok    = xopt LangExt.UndecidableInstances dflags+    arg_tys_ok = case ctxt of+        SpecInstCtxt -> True    -- {-# SPECIALISE instance Eq (T Int) #-} is fine+        InstDeclCtxt {} -> checkValidClsArgs (flexible_contexts || undecidable_ok) cls tys+                                -- Further checks on head and theta+                                -- in checkInstTermination+        _               -> checkValidClsArgs flexible_contexts cls tys++checkSimplifiableClassConstraint :: TidyEnv -> DynFlags -> UserTypeCtxt+                                 -> Class -> [TcType] -> TcM ()+-- See Note [Simplifiable given constraints]+checkSimplifiableClassConstraint env dflags ctxt cls tys+  | not (wopt Opt_WarnSimplifiableClassConstraints dflags)+  = return ()+  | xopt LangExt.MonoLocalBinds dflags+  = return ()++  | DataTyCtxt {} <- ctxt   -- Don't do this check for the "stupid theta"+  = return ()               -- of a data type declaration++  | cls `hasKey` coercibleTyConKey+  = return ()   -- Oddly, we treat (Coercible t1 t2) as unconditionally OK+                -- matchGlobalInst will reply "yes" because we can reduce+                -- (Coercible a b) to (a ~R# b)++  | otherwise+  = do { result <- matchGlobalInst dflags False cls tys+       ; case result of+           OneInst { cir_what = what }+              -> addWarnTc (Reason Opt_WarnSimplifiableClassConstraints)+                                   (simplifiable_constraint_warn what)+           _          -> return () }+  where+    pred = mkClassPred cls tys++    simplifiable_constraint_warn :: InstanceWhat -> SDoc+    simplifiable_constraint_warn what+     = vcat [ hang (text "The constraint" <+> quotes (ppr (tidyType env pred))+                    <+> text "matches")+                 2 (ppr_what what)+            , hang (text "This makes type inference for inner bindings fragile;")+                 2 (text "either use MonoLocalBinds, or simplify it using the instance") ]++    ppr_what BuiltinInstance = text "a built-in instance"+    ppr_what LocalInstance   = text "a locally-quantified instance"+    ppr_what (TopLevInstance { iw_dfun_id = dfun })+      = hang (text "instance" <+> pprSigmaType (idType dfun))+           2 (text "--" <+> pprDefinedAt (idName dfun))+++{- Note [Simplifiable given constraints]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A type signature like+   f :: Eq [(a,b)] => a -> b+is very fragile, for reasons described at length in TcInteract+Note [Instance and Given overlap].  As that Note discusses, for the+most part the clever stuff in TcInteract means that we don't use a+top-level instance if a local Given might fire, so there is no+fragility. But if we /infer/ the type of a local let-binding, things+can go wrong (#11948 is an example, discussed in the Note).++So this warning is switched on only if we have NoMonoLocalBinds; in+that case the warning discourages users from writing simplifiable+class constraints.++The warning only fires if the constraint in the signature+matches the top-level instances in only one way, and with no+unifiers -- that is, under the same circumstances that+TcInteract.matchInstEnv fires an interaction with the top+level instances.  For example (#13526), consider++  instance {-# OVERLAPPABLE #-} Eq (T a) where ...+  instance                   Eq (T Char) where ..+  f :: Eq (T a) => ...++We don't want to complain about this, even though the context+(Eq (T a)) matches an instance, because the user may be+deliberately deferring the choice so that the Eq (T Char)+has a chance to fire when 'f' is called.  And the fragility+only matters when there's a risk that the instance might+fire instead of the local 'given'; and there is no such+risk in this case.  Just use the same rules as for instance+firing!+-}++-------------------------+okIPCtxt :: UserTypeCtxt -> Bool+  -- See Note [Implicit parameters in instance decls]+okIPCtxt (FunSigCtxt {})        = True+okIPCtxt (InfSigCtxt {})        = True+okIPCtxt ExprSigCtxt            = True+okIPCtxt TypeAppCtxt            = True+okIPCtxt PatSigCtxt             = True+okIPCtxt ResSigCtxt             = True+okIPCtxt GenSigCtxt             = True+okIPCtxt (ConArgCtxt {})        = True+okIPCtxt (ForSigCtxt {})        = True  -- ??+okIPCtxt ThBrackCtxt            = True+okIPCtxt (GhciCtxt {})          = True+okIPCtxt SigmaCtxt              = True+okIPCtxt (DataTyCtxt {})        = True+okIPCtxt (PatSynCtxt {})        = True+okIPCtxt (TySynCtxt {})         = True   -- e.g.   type Blah = ?x::Int+                                         -- #11466++okIPCtxt (KindSigCtxt {})       = False+okIPCtxt (ClassSCCtxt {})       = False+okIPCtxt (InstDeclCtxt {})      = False+okIPCtxt (SpecInstCtxt {})      = False+okIPCtxt (RuleSigCtxt {})       = False+okIPCtxt DefaultDeclCtxt        = False+okIPCtxt DerivClauseCtxt        = False+okIPCtxt (TyVarBndrKindCtxt {}) = False+okIPCtxt (DataKindCtxt {})      = False+okIPCtxt (TySynKindCtxt {})     = False+okIPCtxt (TyFamResKindCtxt {})  = False++{-+Note [Kind polymorphic type classes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+MultiParam check:++    class C f where...   -- C :: forall k. k -> Constraint+    instance C Maybe where...++  The dictionary gets type [C * Maybe] even if it's not a MultiParam+  type class.++Flexibility check:++    class C f where...   -- C :: forall k. k -> Constraint+    data D a = D a+    instance C D where++  The dictionary gets type [C * (D *)]. IA0_TODO it should be+  generalized actually.+-}++checkThetaCtxt :: UserTypeCtxt -> ThetaType -> TidyEnv -> TcM (TidyEnv, SDoc)+checkThetaCtxt ctxt theta env+  = return ( env+           , vcat [ text "In the context:" <+> pprTheta (tidyTypes env theta)+                  , text "While checking" <+> pprUserTypeCtxt ctxt ] )++eqPredTyErr, predTupleErr, predIrredErr,+   predSuperClassErr, badQuantHeadErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)+badQuantHeadErr env pred+  = ( env+    , hang (text "Quantified predicate must have a class or type variable head:")+         2 (ppr_tidy env pred) )+eqPredTyErr  env pred+  = ( env+    , text "Illegal equational constraint" <+> ppr_tidy env pred $$+      parens (text "Use GADTs or TypeFamilies to permit this") )+predTupleErr env pred+  = ( env+    , hang (text "Illegal tuple constraint:" <+> ppr_tidy env pred)+         2 (parens constraintKindsMsg) )+predIrredErr env pred+  = ( env+    , hang (text "Illegal constraint:" <+> ppr_tidy env pred)+         2 (parens constraintKindsMsg) )+predSuperClassErr env pred+  = ( env+    , hang (text "Illegal constraint" <+> quotes (ppr_tidy env pred)+            <+> text "in a superclass context")+         2 (parens undecidableMsg) )++predTyVarErr :: TidyEnv -> PredType -> (TidyEnv, SDoc)+predTyVarErr env pred+  = (env+    , vcat [ hang (text "Non type-variable argument")+                2 (text "in the constraint:" <+> ppr_tidy env pred)+           , parens (text "Use FlexibleContexts to permit this") ])++badIPPred :: TidyEnv -> PredType -> (TidyEnv, SDoc)+badIPPred env pred+  = ( env+    , text "Illegal implicit parameter" <+> quotes (ppr_tidy env pred) )++constraintSynErr :: TidyEnv -> Type -> (TidyEnv, SDoc)+constraintSynErr env kind+  = ( env+    , hang (text "Illegal constraint synonym of kind:" <+> quotes (ppr_tidy env kind))+         2 (parens constraintKindsMsg) )++dupPredWarn :: TidyEnv -> [NE.NonEmpty PredType] -> (TidyEnv, SDoc)+dupPredWarn env dups+  = ( env+    , text "Duplicate constraint" <> plural primaryDups <> text ":"+      <+> pprWithCommas (ppr_tidy env) primaryDups )+  where+    primaryDups = map NE.head dups++tyConArityErr :: TyCon -> [TcType] -> SDoc+-- For type-constructor arity errors, be careful to report+-- the number of /visible/ arguments required and supplied,+-- ignoring the /invisible/ arguments, which the user does not see.+-- (e.g. #10516)+tyConArityErr tc tks+  = arityErr (ppr (tyConFlavour tc)) (tyConName tc)+             tc_type_arity tc_type_args+  where+    vis_tks = filterOutInvisibleTypes tc tks++    -- tc_type_arity = number of *type* args expected+    -- tc_type_args  = number of *type* args encountered+    tc_type_arity = count isVisibleTyConBinder (tyConBinders tc)+    tc_type_args  = length vis_tks++arityErr :: Outputable a => SDoc -> a -> Int -> Int -> SDoc+arityErr what name n m+  = hsep [ text "The" <+> what, quotes (ppr name), text "should have",+           n_arguments <> comma, text "but has been given",+           if m==0 then text "none" else int m]+    where+        n_arguments | n == 0 = text "no arguments"+                    | n == 1 = text "1 argument"+                    | True   = hsep [int n, text "arguments"]++{-+************************************************************************+*                                                                      *+\subsection{Checking for a decent instance head type}+*                                                                      *+************************************************************************++@checkValidInstHead@ checks the type {\em and} its syntactic constraints:+it must normally look like: @instance Foo (Tycon a b c ...) ...@++The exceptions to this syntactic checking: (1)~if the @GlasgowExts@+flag is on, or (2)~the instance is imported (they must have been+compiled elsewhere). In these cases, we let them go through anyway.++We can also have instances for functions: @instance Foo (a -> b) ...@.+-}++checkValidInstHead :: UserTypeCtxt -> Class -> [Type] -> TcM ()+checkValidInstHead ctxt clas cls_args+  = do { dflags   <- getDynFlags+       ; is_boot  <- tcIsHsBootOrSig+       ; is_sig   <- tcIsHsig+       ; check_valid_inst_head dflags is_boot is_sig ctxt clas cls_args+       }++{-++Note [Instances of built-in classes in signature files]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++User defined instances for KnownNat, KnownSymbol and Typeable are+disallowed -- they are generated when needed by GHC itself on-the-fly.++However, if they occur in a Backpack signature file, they have an+entirely different meaning. Suppose in M.hsig we see++  signature M where+    data T :: Nat+    instance KnownNat T++That says that any module satisfying M.hsig must provide a KnownNat+instance for T.  We absolultely need that instance when compiling a+module that imports M.hsig: see #15379 and+Note [Fabricating Evidence for Literals in Backpack] in ClsInst.++Hence, checkValidInstHead accepts a user-written instance declaration+in hsig files, where `is_sig` is True.++-}++check_valid_inst_head :: DynFlags -> Bool -> Bool+                      -> UserTypeCtxt -> Class -> [Type] -> TcM ()+-- Wow!  There are a surprising number of ad-hoc special cases here.+check_valid_inst_head dflags is_boot is_sig ctxt clas cls_args++  -- If not in an hs-boot file, abstract classes cannot have instances+  | isAbstractClass clas+  , not is_boot+  = failWithTc abstract_class_msg++  -- For Typeable, don't complain about instances for+  -- standalone deriving; they are no-ops, and we warn about+  -- it in TcDeriv.deriveStandalone.+  | clas_nm == typeableClassName+  , not is_sig+    -- Note [Instances of built-in classes in signature files]+  , hand_written_bindings+  = failWithTc rejected_class_msg++  -- Handwritten instances of KnownNat/KnownSymbol class+  -- are always forbidden (#12837)+  | clas_nm `elem` [ knownNatClassName, knownSymbolClassName ]+  , not is_sig+    -- Note [Instances of built-in classes in signature files]+  , hand_written_bindings+  = failWithTc rejected_class_msg++  -- For the most part we don't allow+  -- instances for (~), (~~), or Coercible;+  -- but we DO want to allow them in quantified constraints:+  --   f :: (forall a b. Coercible a b => Coercible (m a) (m b)) => ...m...+  | clas_nm `elem` [ heqTyConName, eqTyConName, coercibleTyConName ]+  , not quantified_constraint+  = failWithTc rejected_class_msg++  -- Check for hand-written Generic instances (disallowed in Safe Haskell)+  | clas_nm `elem` genericClassNames+  , hand_written_bindings+  =  do { failIfTc (safeLanguageOn dflags) gen_inst_err+        ; when (safeInferOn dflags) (recordUnsafeInfer emptyBag) }++  | clas_nm == hasFieldClassName+  = checkHasFieldInst clas cls_args++  | isCTupleClass clas+  = failWithTc tuple_class_msg++  -- Check language restrictions on the args to the class+  | check_h98_arg_shape+  , Just msg <- mb_ty_args_msg+  = failWithTc (instTypeErr clas cls_args msg)++  | otherwise+  = checkValidTypePats (classTyCon clas) cls_args+  where+    clas_nm = getName clas+    ty_args = filterOutInvisibleTypes (classTyCon clas) cls_args++    hand_written_bindings+        = case ctxt of+            InstDeclCtxt stand_alone -> not stand_alone+            SpecInstCtxt             -> False+            DerivClauseCtxt          -> False+            _                        -> True++    check_h98_arg_shape = case ctxt of+                            SpecInstCtxt    -> False+                            DerivClauseCtxt -> False+                            SigmaCtxt       -> False+                            _               -> True+        -- SigmaCtxt: once we are in quantified-constraint land, we+        -- aren't so picky about enforcing H98-language restrictions+        -- E.g. we want to allow a head like Coercible (m a) (m b)+++    -- When we are looking at the head of a quantified constraint,+    -- check_quant_pred sets ctxt to SigmaCtxt+    quantified_constraint = case ctxt of+                              SigmaCtxt -> True+                              _         -> False++    head_type_synonym_msg = parens (+                text "All instance types must be of the form (T t1 ... tn)" $$+                text "where T is not a synonym." $$+                text "Use TypeSynonymInstances if you want to disable this.")++    head_type_args_tyvars_msg = parens (vcat [+                text "All instance types must be of the form (T a1 ... an)",+                text "where a1 ... an are *distinct type variables*,",+                text "and each type variable appears at most once in the instance head.",+                text "Use FlexibleInstances if you want to disable this."])++    head_one_type_msg = parens $+                        text "Only one type can be given in an instance head." $$+                        text "Use MultiParamTypeClasses if you want to allow more, or zero."++    rejected_class_msg = text "Class" <+> quotes (ppr clas_nm)+                         <+> text "does not support user-specified instances"+    tuple_class_msg    = text "You can't specify an instance for a tuple constraint"++    gen_inst_err = rejected_class_msg $$ nest 2 (text "(in Safe Haskell)")++    abstract_class_msg = text "Cannot define instance for abstract class"+                         <+> quotes (ppr clas_nm)++    mb_ty_args_msg+      | not (xopt LangExt.TypeSynonymInstances dflags)+      , not (all tcInstHeadTyNotSynonym ty_args)+      = Just head_type_synonym_msg++      | not (xopt LangExt.FlexibleInstances dflags)+      , not (all tcInstHeadTyAppAllTyVars ty_args)+      = Just head_type_args_tyvars_msg++      | length ty_args /= 1+      , not (xopt LangExt.MultiParamTypeClasses dflags)+      , not (xopt LangExt.NullaryTypeClasses dflags && null ty_args)+      = Just head_one_type_msg++      | otherwise+      = Nothing++tcInstHeadTyNotSynonym :: Type -> Bool+-- Used in Haskell-98 mode, for the argument types of an instance head+-- These must not be type synonyms, but everywhere else type synonyms+-- are transparent, so we need a special function here+tcInstHeadTyNotSynonym ty+  = case ty of  -- Do not use splitTyConApp,+                -- because that expands synonyms!+        TyConApp tc _ -> not (isTypeSynonymTyCon tc)+        _ -> True++tcInstHeadTyAppAllTyVars :: Type -> Bool+-- Used in Haskell-98 mode, for the argument types of an instance head+-- These must be a constructor applied to type variable arguments+-- or a type-level literal.+-- But we allow kind instantiations.+tcInstHeadTyAppAllTyVars ty+  | Just (tc, tys) <- tcSplitTyConApp_maybe (dropCasts ty)+  = ok (filterOutInvisibleTypes tc tys)  -- avoid kinds+  | LitTy _ <- ty = True  -- accept type literals (#13833)+  | otherwise+  = False+  where+        -- Check that all the types are type variables,+        -- and that each is distinct+    ok tys = equalLength tvs tys && hasNoDups tvs+           where+             tvs = mapMaybe tcGetTyVar_maybe tys++dropCasts :: Type -> Type+-- See Note [Casts during validity checking]+-- This function can turn a well-kinded type into an ill-kinded+-- one, so I've kept it local to this module+-- To consider: drop only HoleCo casts+dropCasts (CastTy ty _)       = dropCasts ty+dropCasts (AppTy t1 t2)       = mkAppTy (dropCasts t1) (dropCasts t2)+dropCasts ty@(FunTy _ t1 t2)  = ty { ft_arg = dropCasts t1, ft_res = dropCasts t2 }+dropCasts (TyConApp tc tys)   = mkTyConApp tc (map dropCasts tys)+dropCasts (ForAllTy b ty)     = ForAllTy (dropCastsB b) (dropCasts ty)+dropCasts ty                  = ty  -- LitTy, TyVarTy, CoercionTy++dropCastsB :: TyVarBinder -> TyVarBinder+dropCastsB b = b   -- Don't bother in the kind of a forall++instTypeErr :: Class -> [Type] -> SDoc -> SDoc+instTypeErr cls tys msg+  = hang (hang (text "Illegal instance declaration for")+             2 (quotes (pprClassPred cls tys)))+       2 msg++-- | See Note [Validity checking of HasField instances]+checkHasFieldInst :: Class -> [Type] -> TcM ()+checkHasFieldInst cls tys@[_k_ty, x_ty, r_ty, _a_ty] =+  case splitTyConApp_maybe r_ty of+    Nothing -> whoops (text "Record data type must be specified")+    Just (tc, _)+      | isFamilyTyCon tc+                  -> whoops (text "Record data type may not be a data family")+      | otherwise -> case isStrLitTy x_ty of+       Just lbl+         | isJust (lookupTyConFieldLabel lbl tc)+                     -> whoops (ppr tc <+> text "already has a field"+                                       <+> quotes (ppr lbl))+         | otherwise -> return ()+       Nothing+         | null (tyConFieldLabels tc) -> return ()+         | otherwise -> whoops (ppr tc <+> text "has fields")+  where+    whoops = addErrTc . instTypeErr cls tys+checkHasFieldInst _ tys = pprPanic "checkHasFieldInst" (ppr tys)++{- Note [Casts during validity checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the (bogus)+     instance Eq Char#+We elaborate to  'Eq (Char# |> UnivCo(hole))'  where the hole is an+insoluble equality constraint for * ~ #.  We'll report the insoluble+constraint separately, but we don't want to *also* complain that Eq is+not applied to a type constructor.  So we look gaily look through+CastTys here.++Another example:  Eq (Either a).  Then we actually get a cast in+the middle:+   Eq ((Either |> g) a)+++Note [Validity checking of HasField instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The HasField class has magic constraint solving behaviour (see Note+[HasField instances] in TcInteract).  However, we permit users to+declare their own instances, provided they do not clash with the+built-in behaviour.  In particular, we forbid:++  1. `HasField _ r _` where r is a variable++  2. `HasField _ (T ...) _` if T is a data family+     (because it might have fields introduced later)++  3. `HasField x (T ...) _` where x is a variable,+      if T has any fields at all++  4. `HasField "foo" (T ...) _` if T has a "foo" field++The usual functional dependency checks also apply.+++Note [Valid 'deriving' predicate]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+validDerivPred checks for OK 'deriving' context.  See Note [Exotic+derived instance contexts] in TcDeriv.  However the predicate is+here because it uses sizeTypes, fvTypes.++It checks for three things++  * No repeated variables (hasNoDups fvs)++  * No type constructors.  This is done by comparing+        sizeTypes tys == length (fvTypes tys)+    sizeTypes counts variables and constructors; fvTypes returns variables.+    So if they are the same, there must be no constructors.  But there+    might be applications thus (f (g x)).++    Note that tys only includes the visible arguments of the class type+    constructor. Including the non-visible arguments can cause the following,+    perfectly valid instance to be rejected:+       class Category (cat :: k -> k -> *) where ...+       newtype T (c :: * -> * -> *) a b = MkT (c a b)+       instance Category c => Category (T c) where ...+    since the first argument to Category is a non-visible *, which sizeTypes+    would count as a constructor! See #11833.++  * Also check for a bizarre corner case, when the derived instance decl+    would look like+       instance C a b => D (T a) where ...+    Note that 'b' isn't a parameter of T.  This gives rise to all sorts of+    problems; in particular, it's hard to compare solutions for equality+    when finding the fixpoint, and that means the inferContext loop does+    not converge.  See #5287.++Note [Equality class instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We can't have users writing instances for the equality classes. But we+still need to be able to write instances for them ourselves. So we allow+instances only in the defining module.++-}++validDerivPred :: TyVarSet -> PredType -> Bool+-- See Note [Valid 'deriving' predicate]+validDerivPred tv_set pred+  = case classifyPredType pred of+       ClassPred cls tys -> cls `hasKey` typeableClassKey+                -- Typeable constraints are bigger than they appear due+                -- to kind polymorphism, but that's OK+                       || check_tys cls tys+       EqPred {}       -> False  -- reject equality constraints+       _               -> True   -- Non-class predicates are ok+  where+    check_tys cls tys+              = hasNoDups fvs+                   -- use sizePred to ignore implicit args+                && lengthIs fvs (sizePred pred)+                && all (`elemVarSet` tv_set) fvs+      where tys' = filterOutInvisibleTypes (classTyCon cls) tys+            fvs  = fvTypes tys'++{-+************************************************************************+*                                                                      *+\subsection{Checking instance for termination}+*                                                                      *+************************************************************************+-}++{- Note [Instances and constraint synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Currently, we don't allow instances for constraint synonyms at all.+Consider these (#13267):+  type C1 a = Show (a -> Bool)+  instance C1 Int where    -- I1+    show _ = "ur"++This elicits "show is not a (visible) method of class C1", which isn't+a great message. But it comes from the renamer, so it's hard to improve.++This needs a bit more care:+  type C2 a = (Show a, Show Int)+  instance C2 Int           -- I2++If we use (splitTyConApp_maybe tau) in checkValidInstance to decompose+the instance head, we'll expand the synonym on fly, and it'll look like+  instance (%,%) (Show Int, Show Int)+and we /really/ don't want that.  So we carefully do /not/ expand+synonyms, by matching on TyConApp directly.+-}++checkValidInstance :: UserTypeCtxt -> LHsSigType GhcRn -> Type -> TcM ()+checkValidInstance ctxt hs_type ty+  | not is_tc_app+  = failWithTc (hang (text "Instance head is not headed by a class:")+                   2 ( ppr tau))++  | isNothing mb_cls+  = failWithTc (vcat [ text "Illegal instance for a" <+> ppr (tyConFlavour tc)+                     , text "A class instance must be for a class" ])++  | not arity_ok+  = failWithTc (text "Arity mis-match in instance head")++  | otherwise+  = do  { setSrcSpan head_loc $+          checkValidInstHead ctxt clas inst_tys++        ; traceTc "checkValidInstance {" (ppr ty)++        ; env0 <- tcInitTidyEnv+        ; expand <- initialExpandMode+        ; check_valid_theta env0 ctxt expand theta++        -- The Termination and Coverate Conditions+        -- Check that instance inference will terminate (if we care)+        -- For Haskell 98 this will already have been done by checkValidTheta,+        -- but as we may be using other extensions we need to check.+        --+        -- Note that the Termination Condition is *more conservative* than+        -- the checkAmbiguity test we do on other type signatures+        --   e.g.  Bar a => Bar Int is ambiguous, but it also fails+        --   the termination condition, because 'a' appears more often+        --   in the constraint than in the head+        ; undecidable_ok <- xoptM LangExt.UndecidableInstances+        ; if undecidable_ok+          then checkAmbiguity ctxt ty+          else checkInstTermination theta tau++        ; traceTc "cvi 2" (ppr ty)++        ; case (checkInstCoverage undecidable_ok clas theta inst_tys) of+            IsValid      -> return ()   -- Check succeeded+            NotValid msg -> addErrTc (instTypeErr clas inst_tys msg)++        ; traceTc "End checkValidInstance }" empty++        ; return () }+  where+    (_tvs, theta, tau)   = tcSplitSigmaTy ty+    is_tc_app            = case tau of { TyConApp {} -> True; _ -> False }+    TyConApp tc inst_tys = tau   -- See Note [Instances and constraint synonyms]+    mb_cls               = tyConClass_maybe tc+    Just clas            = mb_cls+    arity_ok             = inst_tys `lengthIs` classArity clas++        -- The location of the "head" of the instance+    head_loc = getLoc (getLHsInstDeclHead hs_type)++{-+Note [Paterson conditions]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Termination test: the so-called "Paterson conditions" (see Section 5 of+"Understanding functional dependencies via Constraint Handling Rules,+JFP Jan 2007).++We check that each assertion in the context satisfies:+ (1) no variable has more occurrences in the assertion than in the head, and+ (2) the assertion has fewer constructors and variables (taken together+     and counting repetitions) than the head.+This is only needed with -fglasgow-exts, as Haskell 98 restrictions+(which have already been checked) guarantee termination.++The underlying idea is that++    for any ground substitution, each assertion in the+    context has fewer type constructors than the head.+-}++checkInstTermination :: ThetaType -> TcPredType -> TcM ()+-- See Note [Paterson conditions]+checkInstTermination theta head_pred+  = check_preds emptyVarSet theta+  where+   head_fvs  = fvType head_pred+   head_size = sizeType head_pred++   check_preds :: VarSet -> [PredType] -> TcM ()+   check_preds foralld_tvs preds = mapM_ (check foralld_tvs) preds++   check :: VarSet -> PredType -> TcM ()+   check foralld_tvs pred+     = case classifyPredType pred of+         EqPred {}    -> return ()  -- See #4200.+         IrredPred {} -> check2 foralld_tvs pred (sizeType pred)+         ClassPred cls tys+           | isTerminatingClass cls+           -> return ()++           | isCTupleClass cls  -- Look inside tuple predicates; #8359+           -> check_preds foralld_tvs tys++           | otherwise          -- Other ClassPreds+           -> check2 foralld_tvs pred bogus_size+           where+              bogus_size = 1 + sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys)+                               -- See Note [Invisible arguments and termination]++         ForAllPred tvs _ head_pred'+           -> check (foralld_tvs `extendVarSetList` binderVars tvs) head_pred'+              -- Termination of the quantified predicate itself is checked+              -- when the predicates are individually checked for validity++   check2 foralld_tvs pred pred_size+     | not (null bad_tvs)     = failWithTc (noMoreMsg bad_tvs what (ppr head_pred))+     | not (isTyFamFree pred) = failWithTc (nestedMsg what)+     | pred_size >= head_size = failWithTc (smallerMsg what (ppr head_pred))+     | otherwise              = return ()+     -- isTyFamFree: see Note [Type families in instance contexts]+     where+        what    = text "constraint" <+> quotes (ppr pred)+        bad_tvs = filterOut (`elemVarSet` foralld_tvs) (fvType pred)+                  \\ head_fvs++smallerMsg :: SDoc -> SDoc -> SDoc+smallerMsg what inst_head+  = vcat [ hang (text "The" <+> what)+              2 (sep [ text "is no smaller than"+                     , text "the instance head" <+> quotes inst_head ])+         , parens undecidableMsg ]++noMoreMsg :: [TcTyVar] -> SDoc -> SDoc -> SDoc+noMoreMsg tvs what inst_head+  = vcat [ hang (text "Variable" <> plural tvs1 <+> quotes (pprWithCommas ppr tvs1)+                <+> occurs <+> text "more often")+              2 (sep [ text "in the" <+> what+                     , text "than in the instance head" <+> quotes inst_head ])+         , parens undecidableMsg ]+  where+   tvs1   = nub tvs+   occurs = if isSingleton tvs1 then text "occurs"+                               else text "occur"++undecidableMsg, constraintKindsMsg :: SDoc+undecidableMsg     = text "Use UndecidableInstances to permit this"+constraintKindsMsg = text "Use ConstraintKinds to permit this"++{- Note [Type families in instance contexts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Are these OK?+  type family F a+  instance F a    => C (Maybe [a]) where ...+  intance C (F a) => C [[[a]]]     where ...++No: the type family in the instance head might blow up to an+arbitrarily large type, depending on how 'a' is instantiated.+So we require UndecidableInstances if we have a type family+in the instance head.  #15172.++Note [Invisible arguments and termination]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When checking the ​Paterson conditions for termination an instance+declaration, we check for the number of "constructors and variables"+in the instance head and constraints. Question: Do we look at++ * All the arguments, visible or invisible?+ * Just the visible arguments?++I think both will ensure termination, provided we are consistent.+Currently we are /not/ consistent, which is really a bug.  It's+described in #15177, which contains a number of examples.+The suspicious bits are the calls to filterOutInvisibleTypes.+-}+++{-+************************************************************************+*                                                                      *+        Checking type instance well-formedness and termination+*                                                                      *+************************************************************************+-}++checkValidCoAxiom :: CoAxiom Branched -> TcM ()+checkValidCoAxiom ax@(CoAxiom { co_ax_tc = fam_tc, co_ax_branches = branches })+  = do { mapM_ (checkValidCoAxBranch fam_tc) branch_list+       ; foldlM_ check_branch_compat [] branch_list }+  where+    branch_list = fromBranches branches+    injectivity = tyConInjectivityInfo fam_tc++    check_branch_compat :: [CoAxBranch]    -- previous branches in reverse order+                        -> CoAxBranch      -- current branch+                        -> TcM [CoAxBranch]-- current branch : previous branches+    -- Check for+    --   (a) this branch is dominated by previous ones+    --   (b) failure of injectivity+    check_branch_compat prev_branches cur_branch+      | cur_branch `isDominatedBy` prev_branches+      = do { addWarnAt NoReason (coAxBranchSpan cur_branch) $+             inaccessibleCoAxBranch fam_tc cur_branch+           ; return prev_branches }+      | otherwise+      = do { check_injectivity prev_branches cur_branch+           ; return (cur_branch : prev_branches) }++     -- Injectivity check: check whether a new (CoAxBranch) can extend+     -- already checked equations without violating injectivity+     -- annotation supplied by the user.+     -- See Note [Verifying injectivity annotation] in FamInstEnv+    check_injectivity prev_branches cur_branch+      | Injective inj <- injectivity+      = do { let conflicts =+                     fst $ foldl' (gather_conflicts inj prev_branches cur_branch)+                                 ([], 0) prev_branches+           ; mapM_ (\(err, span) -> setSrcSpan span $ addErr err)+                   (makeInjectivityErrors ax cur_branch inj conflicts) }+      | otherwise+      = return ()++    gather_conflicts inj prev_branches cur_branch (acc, n) branch+               -- n is 0-based index of branch in prev_branches+      = case injectiveBranches inj cur_branch branch of+          InjectivityUnified ax1 ax2+            | ax1 `isDominatedBy` (replace_br prev_branches n ax2)+                -> (acc, n + 1)+            | otherwise+                -> (branch : acc, n + 1)+          InjectivityAccepted -> (acc, n + 1)++    -- Replace n-th element in the list. Assumes 0-based indexing.+    replace_br :: [CoAxBranch] -> Int -> CoAxBranch -> [CoAxBranch]+    replace_br brs n br = take n brs ++ [br] ++ drop (n+1) brs+++-- Check that a "type instance" is well-formed (which includes decidability+-- unless -XUndecidableInstances is given).+--+checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM ()+checkValidCoAxBranch fam_tc+                    (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                                , cab_lhs = typats+                                , cab_rhs = rhs, cab_loc = loc })+  = setSrcSpan loc $+    checkValidTyFamEqn fam_tc (tvs++cvs) typats rhs++-- | Do validity checks on a type family equation, including consistency+-- with any enclosing class instance head, termination, and lack of+-- polytypes.+checkValidTyFamEqn :: TyCon   -- ^ of the type family+                   -> [Var]   -- ^ Bound variables in the equation+                   -> [Type]  -- ^ Type patterns+                   -> Type    -- ^ Rhs+                   -> TcM ()+checkValidTyFamEqn fam_tc qvs typats rhs+  = do { checkValidTypePats fam_tc typats++         -- Check for things used on the right but not bound on the left+       ; checkFamPatBinders fam_tc qvs typats rhs++         -- Check for oversaturated visible kind arguments in a type family+         -- equation.+         -- See Note [Oversaturated type family equations]+       ; when (isTypeFamilyTyCon fam_tc) $+           case drop (tyConArity fam_tc) typats of+             [] -> pure ()+             spec_arg:_ ->+               addErr $ text "Illegal oversaturated visible kind argument:"+                    <+> quotes (char '@' <> pprParendType spec_arg)++         -- The argument patterns, and RHS, are all boxed tau types+         -- E.g  Reject type family F (a :: k1) :: k2+         --             type instance F (forall a. a->a) = ...+         --             type instance F Int#             = ...+         --             type instance F Int              = forall a. a->a+         --             type instance F Int              = Int#+         -- See #9357+       ; checkValidMonoType rhs++         -- We have a decidable instance unless otherwise permitted+       ; undecidable_ok <- xoptM LangExt.UndecidableInstances+       ; traceTc "checkVTFE" (ppr fam_tc $$ ppr rhs $$ ppr (tcTyFamInsts rhs))+       ; unless undecidable_ok $+         mapM_ addErrTc (checkFamInstRhs fam_tc typats (tcTyFamInsts rhs)) }++-- Make sure that each type family application is+--   (1) strictly smaller than the lhs,+--   (2) mentions no type variable more often than the lhs, and+--   (3) does not contain any further type family instances.+--+checkFamInstRhs :: TyCon -> [Type]         -- LHS+                -> [(TyCon, [Type])]       -- type family calls in RHS+                -> [MsgDoc]+checkFamInstRhs lhs_tc lhs_tys famInsts+  = mapMaybe check famInsts+  where+   lhs_size  = sizeTyConAppArgs lhs_tc lhs_tys+   inst_head = pprType (TyConApp lhs_tc lhs_tys)+   lhs_fvs   = fvTypes lhs_tys+   check (tc, tys)+      | not (all isTyFamFree tys) = Just (nestedMsg what)+      | not (null bad_tvs)        = Just (noMoreMsg bad_tvs what inst_head)+      | lhs_size <= fam_app_size  = Just (smallerMsg what inst_head)+      | otherwise                 = Nothing+      where+        what = text "type family application"+               <+> quotes (pprType (TyConApp tc tys))+        fam_app_size = sizeTyConAppArgs tc tys+        bad_tvs      = fvTypes tys \\ lhs_fvs+                       -- The (\\) is list difference; e.g.+                       --   [a,b,a,a] \\ [a,a] = [b,a]+                       -- So we are counting repetitions++-----------------+checkFamPatBinders :: TyCon+                   -> [TcTyVar]   -- Bound on LHS of family instance+                   -> [TcType]    -- LHS patterns+                   -> Type        -- RHS+                   -> TcM ()+-- We do these binder checks now, in tcFamTyPatsAndGen, rather+-- than later, in checkValidFamEqn, for two reasons:+--   - We have the implicitly and explicitly+--     bound type variables conveniently to hand+--   - If implicit variables are out of scope it may+--     cause a crash; notably in tcConDecl in tcDataFamInstDecl+checkFamPatBinders fam_tc qtvs pats rhs+  = do { traceTc "checkFamPatBinders" $+         vcat [ debugPprType (mkTyConApp fam_tc pats)+              , ppr (mkTyConApp fam_tc pats)+              , text "qtvs:" <+> ppr qtvs+              , text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs)+              , text "pat_tvs:" <+> ppr pat_tvs+              , text "exact_pat_tvs:" <+> ppr exact_pat_tvs ]++         -- Check for implicitly-bound tyvars, mentioned on the+         -- RHS but not bound on the LHS+         --    data T            = MkT (forall (a::k). blah)+         --    data family D Int = MkD (forall (a::k). blah)+         -- In both cases, 'k' is not bound on the LHS, but is used on the RHS+         -- We catch the former in kcLHsQTyVars, and the latter right here+         -- See Note [Check type-family instance binders]+       ; check_tvs bad_rhs_tvs (text "mentioned in the RHS")+                               (text "bound on the LHS of")++         -- Check for explicitly forall'd variable that is not bound on LHS+         --    data instance forall a.  T Int = MkT Int+         -- See Note [Unused explicitly bound variables in a family pattern]+         -- See Note [Check type-family instance binders]+       ; check_tvs bad_qtvs (text "bound by a forall")+                            (text "used in")+       }+  where+    pat_tvs       = tyCoVarsOfTypes pats+    exact_pat_tvs = exactTyCoVarsOfTypes pats+    rhs_fvs       = tyCoFVsOfType rhs+    used_tvs      = pat_tvs `unionVarSet` fvVarSet rhs_fvs+    bad_qtvs      = filterOut (`elemVarSet` used_tvs) qtvs+                    -- Bound but not used at all+    bad_rhs_tvs   = filterOut (`elemVarSet` exact_pat_tvs) (fvVarList rhs_fvs)+                    -- Used on RHS but not bound on LHS+    dodgy_tvs     = pat_tvs `minusVarSet` exact_pat_tvs++    check_tvs tvs what what2+      = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $+        hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs+              <+> isOrAre tvs <+> what <> comma)+           2 (vcat [ text "but not" <+> what2 <+> text "the family instance"+                   , mk_extra tvs ])++    -- mk_extra: #7536: give a decent error message for+    --         type T a = Int+    --         type instance F (T a) = a+    mk_extra tvs = ppWhen (any (`elemVarSet` dodgy_tvs) tvs) $+                   hang (text "The real LHS (expanding synonyms) is:")+                      2 (pprTypeApp fam_tc (map expandTypeSynonyms pats))+++-- | Checks that a list of type patterns is valid in a matching (LHS)+-- position of a class instances or type/data family instance.+--+-- Specifically:+--    * All monotypes+--    * No type-family applications+checkValidTypePats :: TyCon -> [Type] -> TcM ()+checkValidTypePats tc pat_ty_args+  = do { -- Check that each of pat_ty_args is a monotype.+         -- One could imagine generalising to allow+         --      instance C (forall a. a->a)+         -- but we don't know what all the consequences might be.+         traverse_ checkValidMonoType pat_ty_args++       -- Ensure that no type family applications occur a type pattern+       ; case tcTyConAppTyFamInstsAndVis tc pat_ty_args of+            [] -> pure ()+            ((tf_is_invis_arg, tf_tc, tf_args):_) -> failWithTc $+               ty_fam_inst_illegal_err tf_is_invis_arg+                                       (mkTyConApp tf_tc tf_args) }+  where+    inst_ty = mkTyConApp tc pat_ty_args++    ty_fam_inst_illegal_err :: Bool -> Type -> SDoc+    ty_fam_inst_illegal_err invis_arg ty+      = pprWithExplicitKindsWhen invis_arg $+        hang (text "Illegal type synonym family application"+                <+> quotes (ppr ty) <+> text "in instance" <> colon)+           2 (ppr inst_ty)++-- Error messages++inaccessibleCoAxBranch :: TyCon -> CoAxBranch -> SDoc+inaccessibleCoAxBranch fam_tc cur_branch+  = text "Type family instance equation is overlapped:" $$+    nest 2 (pprCoAxBranchUser fam_tc cur_branch)++nestedMsg :: SDoc -> SDoc+nestedMsg what+  = sep [ text "Illegal nested" <+> what+        , parens undecidableMsg ]++badATErr :: Name -> Name -> SDoc+badATErr clas op+  = hsep [text "Class", quotes (ppr clas),+          text "does not have an associated type", quotes (ppr op)]+++-------------------------+checkConsistentFamInst :: AssocInstInfo+                       -> TyCon     -- ^ Family tycon+                       -> CoAxBranch+                       -> TcM ()+-- See Note [Checking consistent instantiation]++checkConsistentFamInst NotAssociated _ _+  = return ()++checkConsistentFamInst (InClsInst { ai_class = clas+                                  , ai_tyvars = inst_tvs+                                  , ai_inst_env = mini_env })+                       fam_tc branch+  = do { traceTc "checkConsistentFamInst" (vcat [ ppr inst_tvs+                                                , ppr arg_triples+                                                , ppr mini_env+                                                , ppr ax_tvs+                                                , ppr ax_arg_tys+                                                , ppr arg_triples ])+       -- Check that the associated type indeed comes from this class+       -- See [Mismatched class methods and associated type families]+       -- in TcInstDecls.+       ; checkTc (Just (classTyCon clas) == tyConAssoc_maybe fam_tc)+                 (badATErr (className clas) (tyConName fam_tc))++       ; check_match arg_triples+       }+  where+    (ax_tvs, ax_arg_tys, _) = etaExpandCoAxBranch branch++    arg_triples :: [(Type,Type, ArgFlag)]+    arg_triples = [ (cls_arg_ty, at_arg_ty, vis)+                  | (fam_tc_tv, vis, at_arg_ty)+                       <- zip3 (tyConTyVars fam_tc)+                               (tyConArgFlags fam_tc ax_arg_tys)+                               ax_arg_tys+                  , Just cls_arg_ty <- [lookupVarEnv mini_env fam_tc_tv] ]++    pp_wrong_at_arg vis+      = pprWithExplicitKindsWhen (isInvisibleArgFlag vis) $+        vcat [ text "Type indexes must match class instance head"+             , text "Expected:" <+> pp_expected_ty+             , text "  Actual:" <+> pp_actual_ty ]++    -- Fiddling around to arrange that wildcards unconditionally print as "_"+    -- We only need to print the LHS, not the RHS at all+    -- See Note [Printing conflicts with class header]+    (tidy_env1, _) = tidyVarBndrs emptyTidyEnv inst_tvs+    (tidy_env2, _) = tidyCoAxBndrsForUser tidy_env1 (ax_tvs \\ inst_tvs)++    pp_expected_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $+                     toIfaceTcArgs fam_tc $+                     [ case lookupVarEnv mini_env at_tv of+                         Just cls_arg_ty -> tidyType tidy_env2 cls_arg_ty+                         Nothing         -> mk_wildcard at_tv+                     | at_tv <- tyConTyVars fam_tc ]++    pp_actual_ty = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc) $+                   toIfaceTcArgs fam_tc $+                   tidyTypes tidy_env2 ax_arg_tys++    mk_wildcard at_tv = mkTyVarTy (mkTyVar tv_name (tyVarKind at_tv))+    tv_name = mkInternalName (mkAlphaTyVarUnique 1) (mkTyVarOcc "_") noSrcSpan++    -- For check_match, bind_me, see+    -- Note [Matching in the consistent-instantation check]+    check_match :: [(Type,Type,ArgFlag)] -> TcM ()+    check_match triples = go emptyTCvSubst emptyTCvSubst triples++    go _ _ [] = return ()+    go lr_subst rl_subst ((ty1,ty2,vis):triples)+      | Just lr_subst1 <- tcMatchTyX_BM bind_me lr_subst ty1 ty2+      , Just rl_subst1 <- tcMatchTyX_BM bind_me rl_subst ty2 ty1+      = go lr_subst1 rl_subst1 triples+      | otherwise+      = addErrTc (pp_wrong_at_arg vis)++    -- The /scoped/ type variables from the class-instance header+    -- should not be alpha-renamed.  Inferred ones can be.+    no_bind_set = mkVarSet inst_tvs+    bind_me tv | tv `elemVarSet` no_bind_set = Skolem+               | otherwise                   = BindMe+++{- Note [Check type-family instance binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a type family instance, we require (of course), type variables+used on the RHS are matched on the LHS. This is checked by+checkFamPatBinders.  Here is an interesting example:++    type family   T :: k+    type instance T = (Nothing :: Maybe a)++Upon a cursory glance, it may appear that the kind variable `a` is+free-floating above, since there are no (visible) LHS patterns in+`T`. However, there is an *invisible* pattern due to the return kind,+so inside of GHC, the instance looks closer to this:++    type family T @k :: k+    type instance T @(Maybe a) = (Nothing :: Maybe a)++Here, we can see that `a` really is bound by a LHS type pattern, so `a` is in+fact not unbound. Contrast that with this example (#13985)++    type instance T = Proxy (Nothing :: Maybe a)++This would looks like this inside of GHC:++    type instance T @(*) = Proxy (Nothing :: Maybe a)++So this time, `a` is neither bound by a visible nor invisible type pattern on+the LHS, so it would be reported as free-floating.++Finally, here's one more brain-teaser (from #9574). In the example below:++    class Funct f where+      type Codomain f :: *+    instance Funct ('KProxy :: KProxy o) where+      type Codomain 'KProxy = NatTr (Proxy :: o -> *)++As it turns out, `o` is not free-floating in this example. That is because `o`+bound by the kind signature of the LHS type pattern 'KProxy. To make this more+obvious, one can also write the instance like so:++    instance Funct ('KProxy :: KProxy o) where+      type Codomain ('KProxy :: KProxy o) = NatTr (Proxy :: o -> *)+++Note [Matching in the consistent-instantation check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Matching the class-instance header to family-instance tyvars is+tricker than it sounds.  Consider (#13972)+    class C (a :: k) where+      type T k :: Type+    instance C Left where+      type T (a -> Either a b) = Int++Here there are no lexically-scoped variables from (C Left).+Yet the real class-instance header is   C @(p -> Either @p @q)) (Left @p @q)+while the type-family instance is       T (a -> Either @a @b)+So we allow alpha-renaming of variables that don't come+from the class-instance header.++We track the lexically-scoped type variables from the+class-instance header in ai_tyvars.++Here's another example (#14045a)+    class C (a :: k) where+      data S (a :: k)+    instance C (z :: Bool) where+      data S :: Bool -> Type where++Again, there is no lexical connection, but we will get+   class-instance header:   C @Bool (z::Bool)+   family instance          S @Bool (a::Bool)++When looking for mis-matches, we check left-to-right,+kinds first.  If we look at types first, we'll fail to+suggest -fprint-explicit-kinds for a mis-match with+      T @k    vs    T @Type+somewhere deep inside the type++Note [Checking consistent instantiation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See #11450 for background discussion on this check.++  class C a b where+    type T a x b++With this class decl, if we have an instance decl+  instance C ty1 ty2 where ...+then the type instance must look like+     type T ty1 v ty2 = ...+with exactly 'ty1' for 'a', 'ty2' for 'b', and some type 'v' for 'x'.+For example:++  instance C [p] Int+    type T [p] y Int = (p,y,y)++Note that++* We used to allow completely different bound variables in the+  associated type instance; e.g.+    instance C [p] Int+      type T [q] y Int = ...+  But from GHC 8.2 onwards, we don't.  It's much simpler this way.+  See #11450.++* When the class variable isn't used on the RHS of the type instance,+  it's tempting to allow wildcards, thus+    instance C [p] Int+      type T [_] y Int = (y,y)+  But it's awkward to do the test, and it doesn't work if the+  variable is repeated:+    instance C (p,p) Int+      type T (_,_) y Int = (y,y)+  Even though 'p' is not used on the RHS, we still need to use 'p'+  on the LHS to establish the repeated pattern.  So to keep it simple+  we just require equality.++* For variables in associated type families that are not bound by the class+  itself, we do _not_ check if they are over-specific. In other words,+  it's perfectly acceptable to have an instance like this:++    instance C [p] Int where+      type T [p] (Maybe x) Int = x++  While the first and third arguments to T are required to be exactly [p] and+  Int, respectively, since they are bound by C, the second argument is allowed+  to be more specific than just a type variable. Furthermore, it is permissible+  to define multiple equations for T that differ only in the non-class-bound+  argument:++    instance C [p] Int where+      type T [p] (Maybe x)    Int = x+      type T [p] (Either x y) Int = x -> y++  We once considered requiring that non-class-bound variables in associated+  type family instances be instantiated with distinct type variables. However,+  that requirement proved too restrictive in practice, as there were examples+  of extremely simple associated type family instances that this check would+  reject, and fixing them required tiresome boilerplate in the form of+  auxiliary type families. For instance, you would have to define the above+  example as:++    instance C [p] Int where+      type T [p] x Int = CAux x++    type family CAux x where+      CAux (Maybe x)    = x+      CAux (Either x y) = x -> y++  We decided that this restriction wasn't buying us much, so we opted not+  to pursue that design (see also GHC #13398).++Implementation+  * Form the mini-envt from the class type variables a,b+    to the instance decl types [p],Int:   [a->[p], b->Int]++  * Look at the tyvars a,x,b of the type family constructor T+    (it shares tyvars with the class C)++  * Apply the mini-evnt to them, and check that the result is+    consistent with the instance types [p] y Int. (where y can be any type, as+    it is not scoped over the class type variables.++We make all the instance type variables scope over the+type instances, of course, which picks up non-obvious kinds.  Eg+   class Foo (a :: k) where+      type F a+   instance Foo (b :: k -> k) where+      type F b = Int+Here the instance is kind-indexed and really looks like+      type F (k->k) (b::k->k) = Int+But if the 'b' didn't scope, we would make F's instance too+poly-kinded.++Note [Printing conflicts with class header]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's remarkably painful to give a decent error message for conflicts+with the class header.  Consider+   clase C b where+     type F a b c+   instance C [b] where+     type F x Int _ _ = ...++Here we want to report a conflict between+    Expected: F _ [b] _+    Actual:   F x Int _ _++But if the type instance shadows the class variable like this+(rename/should_fail/T15828):+   instance C [b] where+     type forall b. F x (Tree b) _ _ = ...++then we must use a fresh variable name+    Expected: F _ [b] _+    Actual:   F x [b1] _ _++Notice that:+  - We want to print an underscore in the "Expected" type in+    positions where the class header has no influence over the+    parameter.  Hence the fancy footwork in pp_expected_ty++  - Although the binders in the axiom are aready tidy, we must+    re-tidy them to get a fresh variable name when we shadow++  - The (ax_tvs \\ inst_tvs) is to avoid tidying one of the+    class-instance variables a second time, from 'a' to 'a1' say.+    Remember, the ax_tvs of the axiom share identity with the+    class-instance variables, inst_tvs..++  - We use tidyCoAxBndrsForUser to get underscores rather than+    _1, _2, etc in the axiom tyvars; see the definition of+    tidyCoAxBndrsForUser++This all seems absurdly complicated.++Note [Unused explicitly bound variables in a family pattern]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Why is 'unusedExplicitForAllErr' not just a warning?++Consider the following examples:++  type instance F a = Maybe b+  type instance forall b. F a = Bool+  type instance forall b. F a = Maybe b++In every case, b is a type variable not determined by the LHS pattern. The+first is caught by the renamer, but we catch the last two here. Perhaps one+could argue that the second should be accepted, albeit with a warning, but+consider the fact that in a type family instance, there is no way to interact+with such a varable. At least with @x :: forall a. Int@ we can use visibile+type application, like @x \@Bool 1@. (Of course it does nothing, but it is+permissible.) In the type family case, the only sensible explanation is that+the user has made a mistake -- thus we throw an error.++Note [Oversaturated type family equations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Type family tycons have very rigid arities. We want to reject something like+this:++  type family Foo :: Type -> Type where+    Foo x = ...++Because Foo has arity zero (i.e., it doesn't bind anything to the left of the+double colon), we want to disallow any equation for Foo that has more than zero+arguments, such as `Foo x = ...`. The algorithm here is pretty simple: if an+equation has more arguments than the arity of the type family, reject.++Things get trickier when visible kind application enters the picture. Consider+the following example:++  type family Bar (x :: j) :: forall k. Either j k where+    Bar 5 @Symbol = ...++The arity of Bar is two, since it binds two variables, `j` and `x`. But even+though Bar's equation has two arguments, it's still invalid. Imagine the same+equation in Core:++    Bar Nat 5 Symbol = ...++Here, it becomes apparent that Bar is actually taking /three/ arguments! So+we can't just rely on a simple counting argument to reject+`Bar 5 @Symbol = ...`, since it only has two user-written arguments.+Moreover, there's one explicit argument (5) and one visible kind argument+(@Symbol), which matches up perfectly with the fact that Bar has one required+binder (x) and one specified binder (j), so that's not a valid way to detect+oversaturation either.++To solve this problem in a robust way, we do the following:++1. When kind-checking, we count the number of user-written *required*+   arguments and check if there is an equal number of required tycon binders.+   If not, reject. (See `wrongNumberOfParmsErr` in TcTyClsDecls.)++   We perform this step during kind-checking, not during validity checking,+   since we can give better error messages if we catch it early.+2. When validity checking, take all of the (Core) type patterns from on+   equation, drop the first n of them (where n is the arity of the type family+   tycon), and check if there are any types leftover. If so, reject.++   Why does this work? We know that after dropping the first n type patterns,+   none of the leftover types can be required arguments, since step (1) would+   have already caught that. Moreover, the only places where visible kind+   applications should be allowed are in the first n types, since those are the+   only arguments that can correspond to binding forms. Therefore, the+   remaining arguments must correspond to oversaturated uses of visible kind+   applications, which are precisely what we want to reject.++Note that we only perform this check for type families, and not for data+families. This is because it is perfectly acceptable to oversaturate data+family instance equations: see Note [Arity of data families] in FamInstEnv.++************************************************************************+*                                                                      *+   Telescope checking+*                                                                      *+************************************************************************++Note [Bad TyCon telescopes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Now that we can mix type and kind variables, there are an awful lot of+ways to shoot yourself in the foot. Here are some.++  data SameKind :: k -> k -> *   -- just to force unification++1.  data T1 a k (b :: k) (x :: SameKind a b)++The problem here is that we discover that a and b should have the same+kind. But this kind mentions k, which is bound *after* a.+(Testcase: dependent/should_fail/BadTelescope)++2.  data T2 a (c :: Proxy b) (d :: Proxy a) (x :: SameKind b d)++Note that b is not bound. Yet its kind mentions a. Because we have+a nice rule that all implicitly bound variables come before others,+this is bogus.++To catch these errors, we call checkTyConTelescope during kind-checking+datatype declarations.  This checks for++* Ill-scoped binders. From (1) and (2) above we can get putative+  kinds like+       T1 :: forall (a:k) (k:*) (b:k). SameKind a b -> *+  where 'k' is mentioned a's kind before k is bound++  This is easy to check for: just look for+  out-of-scope variables in the kind++* We should arguably also check for ambiguous binders+  but we don't.  See Note [Ambiguous kind vars].++See also+  * Note [Required, Specified, and Inferred for types] in TcTyClsDecls.+  * Note [Keeping scoped variables in order: Explicit] discusses how+    this check works for `forall x y z.` written in a type.++Note [Ambiguous kind vars]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to be concerned about ambiguous binders. Suppose we have the kind+     S1 :: forall k -> * -> *+     S2 :: forall k. * -> *+Here S1 is OK, because k is Required, and at a use of S1 we will+see (S1 *) or (S1 (*->*)) or whatever.++But S2 is /not/ OK because 'k' is Specfied (and hence invisible) and+we have no way (ever) to figure out how 'k' should be instantiated.+For example if we see (S2 Int), that tells us nothing about k's+instantiation.  (In this case we'll instantiate it to Any, but that+seems wrong.)  This is really the same test as we make for ambiguous+type in term type signatures.++Now, it's impossible for a Specified variable not to occur+at all in the kind -- after all, it is Specified so it must have+occurred.  (It /used/ to be possible; see tests T13983 and T7873.  But+with the advent of the forall-or-nothing rule for kind variables,+those strange cases went away.)++But one might worry about+    type v k = *+    S3 :: forall k. V k -> *+which appears to mention 'k' but doesn't really.  Or+    S4 :: forall k. F k -> *+where F is a type function.  But we simply don't check for+those cases of ambiguity, yet anyway.  The worst that can happen+is ambiguity at the call sites.++Historical note: this test used to be called reportFloatingKvs.+-}++-- | Check a list of binders to see if they make a valid telescope.+-- See Note [Bad TyCon telescopes]+type TelescopeAcc+      = ( TyVarSet   -- Bound earlier in the telescope+        , Bool       -- At least one binder occurred (in a kind) before+                     -- it was bound in the telescope.  E.g.+        )            --    T :: forall (a::k) k. blah++checkTyConTelescope :: TyCon -> TcM ()+checkTyConTelescope tc+  | bad_scope+  = -- See "Ill-scoped binders" in Note [Bad TyCon telescopes]+    addErr $+    vcat [ hang (text "The kind of" <+> quotes (ppr tc) <+> text "is ill-scoped")+              2 pp_tc_kind+         , extra+         , hang (text "Perhaps try this order instead:")+              2 (pprTyVars sorted_tvs) ]++  | otherwise+  = return ()+  where+    tcbs = tyConBinders tc+    tvs  = binderVars tcbs+    sorted_tvs = scopedSort tvs++    (_, bad_scope) = foldl add_one (emptyVarSet, False) tcbs++    add_one :: TelescopeAcc -> TyConBinder -> TelescopeAcc+    add_one (bound, bad_scope) tcb+      = ( bound `extendVarSet` tv+        , bad_scope || not (isEmptyVarSet (fkvs `minusVarSet` bound)) )+      where+        tv = binderVar tcb+        fkvs = tyCoVarsOfType (tyVarKind tv)++    inferred_tvs  = [ binderVar tcb+                    | tcb <- tcbs, Inferred == tyConBinderArgFlag tcb ]+    specified_tvs = [ binderVar tcb+                    | tcb <- tcbs, Specified == tyConBinderArgFlag tcb ]++    pp_inf  = parens (text "namely:" <+> pprTyVars inferred_tvs)+    pp_spec = parens (text "namely:" <+> pprTyVars specified_tvs)++    pp_tc_kind = text "Inferred kind:" <+> ppr tc <+> dcolon <+> ppr_untidy (tyConKind tc)+    ppr_untidy ty = pprIfaceType (toIfaceType ty)+      -- We need ppr_untidy here because pprType will tidy the type, which+      -- will turn the bogus kind we are trying to report+      --     T :: forall (a::k) k (b::k) -> blah+      -- into a misleadingly sanitised version+      --     T :: forall (a::k) k1 (b::k1) -> blah++    extra+      | null inferred_tvs && null specified_tvs+      = empty+      | null inferred_tvs+      = hang (text "NB: Specified variables")+           2 (sep [pp_spec, text "always come first"])+      | null specified_tvs+      = hang (text "NB: Inferred variables")+           2 (sep [pp_inf, text "always come first"])+      | otherwise+      = hang (text "NB: Inferred variables")+           2 (vcat [ sep [ pp_inf, text "always come first"]+                   , sep [text "then Specified variables", pp_spec]])++{-+************************************************************************+*                                                                      *+\subsection{Auxiliary functions}+*                                                                      *+************************************************************************+-}++-- Free variables of a type, retaining repetitions, and expanding synonyms+-- This ignores coercions, as coercions aren't user-written+fvType :: Type -> [TyCoVar]+fvType ty | Just exp_ty <- tcView ty = fvType exp_ty+fvType (TyVarTy tv)          = [tv]+fvType (TyConApp _ tys)      = fvTypes tys+fvType (LitTy {})            = []+fvType (AppTy fun arg)       = fvType fun ++ fvType arg+fvType (FunTy _ arg res)     = fvType arg ++ fvType res+fvType (ForAllTy (Bndr tv _) ty)+  = fvType (tyVarKind tv) +++    filter (/= tv) (fvType ty)+fvType (CastTy ty _)         = fvType ty+fvType (CoercionTy {})       = []++fvTypes :: [Type] -> [TyVar]+fvTypes tys                = concat (map fvType tys)++sizeType :: Type -> Int+-- Size of a type: the number of variables and constructors+sizeType ty | Just exp_ty <- tcView ty = sizeType exp_ty+sizeType (TyVarTy {})      = 1+sizeType (TyConApp tc tys) = 1 + sizeTyConAppArgs tc tys+sizeType (LitTy {})        = 1+sizeType (AppTy fun arg)   = sizeType fun + sizeType arg+sizeType (FunTy _ arg res) = sizeType arg + sizeType res + 1+sizeType (ForAllTy _ ty)   = sizeType ty+sizeType (CastTy ty _)     = sizeType ty+sizeType (CoercionTy _)    = 0++sizeTypes :: [Type] -> Int+sizeTypes = foldr ((+) . sizeType) 0++sizeTyConAppArgs :: TyCon -> [Type] -> Int+sizeTyConAppArgs _tc tys = sizeTypes tys -- (filterOutInvisibleTypes tc tys)+                           -- See Note [Invisible arguments and termination]++-- Size of a predicate+--+-- We are considering whether class constraints terminate.+-- Equality constraints and constraints for the implicit+-- parameter class always terminate so it is safe to say "size 0".+-- See #4200.+sizePred :: PredType -> Int+sizePred ty = goClass ty+  where+    goClass p = go (classifyPredType p)++    go (ClassPred cls tys')+      | isTerminatingClass cls = 0+      | otherwise = sizeTypes (filterOutInvisibleTypes (classTyCon cls) tys')+                    -- The filtering looks bogus+                    -- See Note [Invisible arguments and termination]+    go (EqPred {})           = 0+    go (IrredPred ty)        = sizeType ty+    go (ForAllPred _ _ pred) = goClass pred++-- | When this says "True", ignore this class constraint during+-- a termination check+isTerminatingClass :: Class -> Bool+isTerminatingClass cls+  = isIPClass cls    -- Implicit parameter constraints always terminate because+                     -- there are no instances for them --- they are only solved+                     -- by "local instances" in expressions+    || isEqPredClass cls+    || cls `hasKey` typeableClassKey+    || cls `hasKey` coercibleTyConKey++-- | Tidy before printing a type+ppr_tidy :: TidyEnv -> Type -> SDoc+ppr_tidy env ty = pprType (tidyType env ty)++allDistinctTyVars :: TyVarSet -> [KindOrType] -> Bool+-- (allDistinctTyVars tvs tys) returns True if tys are+-- a) all tyvars+-- b) all distinct+-- c) disjoint from tvs+allDistinctTyVars _    [] = True+allDistinctTyVars tkvs (ty : tys)+  = case getTyVar_maybe ty of+      Nothing -> False+      Just tv | tv `elemVarSet` tkvs -> False+              | otherwise -> allDistinctTyVars (tkvs `extendVarSet` tv) tys
+ compiler/utils/AsmUtils.hs view
@@ -0,0 +1,20 @@+-- | Various utilities used in generating assembler.+--+-- These are used not only by the native code generator, but also by the+-- "DriverPipeline".+module AsmUtils+    ( sectionType+    ) where++import GhcPrelude++import Platform+import Outputable++-- | Generate a section type (e.g. @\@progbits@). See #13937.+sectionType :: String -- ^ section type+            -> SDoc   -- ^ pretty assembler fragment+sectionType ty = sdocWithPlatform $ \platform ->+    case platformArch platform of+      ArchARM{} -> char '%' <> text ty+      _         -> char '@' <> text ty
+ compiler/utils/GraphBase.hs view
@@ -0,0 +1,107 @@++-- | Types for the general graph colorer.+module GraphBase (+        Triv,+        Graph (..),+        initGraph,+        graphMapModify,++        Node  (..),     newNode,+)+++where++import GhcPrelude++import UniqSet+import UniqFM+++-- | A fn to check if a node is trivially colorable+--      For graphs who's color classes are disjoint then a node is 'trivially colorable'+--      when it has less neighbors and exclusions than available colors for that node.+--+--      For graph's who's color classes overlap, ie some colors alias other colors, then+--      this can be a bit more tricky. There is a general way to calculate this, but+--      it's likely be too slow for use in the code. The coloring algorithm takes+--      a canned function which can be optimised by the user to be specific to the+--      specific graph being colored.+--+--      for details, see  "A Generalised Algorithm for Graph-Coloring Register Allocation"+--                              Smith, Ramsey, Holloway - PLDI 2004.+--+type Triv k cls color+        =  cls                  -- the class of the node we're trying to color.+        -> UniqSet k            -- the node's neighbors.+        -> UniqSet color        -- the node's exclusions.+        -> Bool+++-- | The Interference graph.+--      There used to be more fields, but they were turfed out in a previous revision.+--      maybe we'll want more later..+--+data Graph k cls color+        = Graph {+        -- | All active nodes in the graph.+          graphMap              :: UniqFM (Node k cls color)  }+++-- | An empty graph.+initGraph :: Graph k cls color+initGraph+        = Graph+        { graphMap              = emptyUFM }+++-- | Modify the finite map holding the nodes in the graph.+graphMapModify+        :: (UniqFM (Node k cls color) -> UniqFM (Node k cls color))+        -> Graph k cls color -> Graph k cls color++graphMapModify f graph+        = graph { graphMap      = f (graphMap graph) }++++-- | Graph nodes.+--      Represents a thing that can conflict with another thing.+--      For the register allocater the nodes represent registers.+--+data Node k cls color+        = Node {+        -- | A unique identifier for this node.+          nodeId                :: k++        -- | The class of this node,+        --      determines the set of colors that can be used.+        , nodeClass             :: cls++        -- | The color of this node, if any.+        , nodeColor             :: Maybe color++        -- | Neighbors which must be colored differently to this node.+        , nodeConflicts         :: UniqSet k++        -- | Colors that cannot be used by this node.+        , nodeExclusions        :: UniqSet color++        -- | Colors that this node would prefer to be, in decending order.+        , nodePreference        :: [color]++        -- | Neighbors that this node would like to be colored the same as.+        , nodeCoalesce          :: UniqSet k }+++-- | An empty node.+newNode :: k -> cls -> Node k cls color+newNode k cls+        = Node+        { nodeId                = k+        , nodeClass             = cls+        , nodeColor             = Nothing+        , nodeConflicts         = emptyUniqSet+        , nodeExclusions        = emptyUniqSet+        , nodePreference        = []+        , nodeCoalesce          = emptyUniqSet }
+ compiler/utils/GraphColor.hs view
@@ -0,0 +1,373 @@+-- | Graph Coloring.+--      This is a generic graph coloring library, abstracted over the type of+--      the node keys, nodes and colors.+--++module GraphColor (+        module GraphBase,+        module GraphOps,+        module GraphPpr,+        colorGraph+)++where++import GhcPrelude++import GraphBase+import GraphOps+import GraphPpr++import Unique+import UniqFM+import UniqSet+import Outputable++import Data.Maybe+import Data.List+++-- | Try to color a graph with this set of colors.+--      Uses Chaitin's algorithm to color the graph.+--      The graph is scanned for nodes which are deamed 'trivially colorable'. These nodes+--      are pushed onto a stack and removed from the graph.+--      Once this process is complete the graph can be colored by removing nodes from+--      the stack (ie in reverse order) and assigning them colors different to their neighbors.+--+colorGraph+        :: ( Uniquable  k, Uniquable cls,  Uniquable  color+           , Eq cls, Ord k+           , Outputable k, Outputable cls, Outputable color)+        => Bool                         -- ^ whether to do iterative coalescing+        -> Int                          -- ^ how many times we've tried to color this graph so far.+        -> UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).+        -> Triv   k cls color           -- ^ fn to decide whether a node is trivially colorable.+        -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.+        -> Graph  k cls color           -- ^ the graph to color.++        -> ( Graph k cls color          -- the colored graph.+           , UniqSet k                  -- the set of nodes that we couldn't find a color for.+           , UniqFM  k )                -- map of regs (r1 -> r2) that were coalesced+                                        --       r1 should be replaced by r2 in the source++colorGraph iterative spinCount colors triv spill graph0+ = let+        -- If we're not doing iterative coalescing then do an aggressive coalescing first time+        --      around and then conservative coalescing for subsequent passes.+        --+        --      Aggressive coalescing is a quick way to get rid of many reg-reg moves. However, if+        --      there is a lot of register pressure and we do it on every round then it can make the+        --      graph less colorable and prevent the algorithm from converging in a sensible number+        --      of cycles.+        --+        (graph_coalesced, kksCoalesce1)+         = if iterative+                then (graph0, [])+                else if spinCount == 0+                        then coalesceGraph True  triv graph0+                        else coalesceGraph False triv graph0++        -- run the scanner to slurp out all the trivially colorable nodes+        --      (and do coalescing if iterative coalescing is enabled)+        (ksTriv, ksProblems, kksCoalesce2)+                = colorScan iterative triv spill graph_coalesced++        -- If iterative coalescing is enabled, the scanner will coalesce the graph as does its business.+        --      We need to apply all the coalescences found by the scanner to the original+        --      graph before doing assignColors.+        --+        --      Because we've got the whole, non-pruned graph here we turn on aggressive coalecing+        --      to force all the (conservative) coalescences found during scanning.+        --+        (graph_scan_coalesced, _)+                = mapAccumL (coalesceNodes True triv) graph_coalesced kksCoalesce2++        -- color the trivially colorable nodes+        --      during scanning, keys of triv nodes were added to the front of the list as they were found+        --      this colors them in the reverse order, as required by the algorithm.+        (graph_triv, ksNoTriv)+                = assignColors colors graph_scan_coalesced ksTriv++        -- try and color the problem nodes+        --      problem nodes are the ones that were left uncolored because they weren't triv.+        --      theres a change we can color them here anyway.+        (graph_prob, ksNoColor)+                = assignColors colors graph_triv ksProblems++        -- if the trivially colorable nodes didn't color then something is probably wrong+        --      with the provided triv function.+        --+   in   if not $ null ksNoTriv+         then   pprPanic "colorGraph: trivially colorable nodes didn't color!" -- empty+                        (  empty+                        $$ text "ksTriv    = " <> ppr ksTriv+                        $$ text "ksNoTriv  = " <> ppr ksNoTriv+                        $$ text "colors    = " <> ppr colors+                        $$ empty+                        $$ dotGraph (\_ -> text "white") triv graph_triv)++         else   ( graph_prob+                , mkUniqSet ksNoColor   -- the nodes that didn't color (spills)+                , if iterative+                        then (listToUFM kksCoalesce2)+                        else (listToUFM kksCoalesce1))+++-- | Scan through the conflict graph separating out trivially colorable and+--      potentially uncolorable (problem) nodes.+--+--      Checking whether a node is trivially colorable or not is a reasonably expensive operation,+--      so after a triv node is found and removed from the graph it's no good to return to the 'start'+--      of the graph and recheck a bunch of nodes that will probably still be non-trivially colorable.+--+--      To ward against this, during each pass through the graph we collect up a list of triv nodes+--      that were found, and only remove them once we've finished the pass. The more nodes we can delete+--      at once the more likely it is that nodes we've already checked will become trivially colorable+--      for the next pass.+--+--      TODO:   add work lists to finding triv nodes is easier.+--              If we've just scanned the graph, and removed triv nodes, then the only+--              nodes that we need to rescan are the ones we've removed edges from.++colorScan+        :: ( Uniquable k, Uniquable cls, Uniquable color+           , Ord k,       Eq cls+           , Outputable k, Outputable cls)+        => Bool                         -- ^ whether to do iterative coalescing+        -> Triv k cls color             -- ^ fn to decide whether a node is trivially colorable+        -> (Graph k cls color -> k)     -- ^ fn to choose a node to potentially leave uncolored if nothing is trivially colorable.+        -> Graph k cls color            -- ^ the graph to scan++        -> ([k], [k], [(k, k)])         --  triv colorable nodes, problem nodes, pairs of nodes to coalesce++colorScan iterative triv spill graph+        = colorScan_spin iterative triv spill graph [] [] []++colorScan_spin+        :: ( Uniquable k, Uniquable cls, Uniquable color+           , Ord k,       Eq cls+           , Outputable k, Outputable cls)+        => Bool+        -> Triv k cls color+        -> (Graph k cls color -> k)+        -> Graph k cls color+        -> [k]+        -> [k]+        -> [(k, k)]+        -> ([k], [k], [(k, k)])++colorScan_spin iterative triv spill graph+        ksTriv ksSpill kksCoalesce++        -- if the graph is empty then we're done+        | isNullUFM $ graphMap graph+        = (ksTriv, ksSpill, reverse kksCoalesce)++        -- Simplify:+        --      Look for trivially colorable nodes.+        --      If we can find some then remove them from the graph and go back for more.+        --+        | nsTrivFound@(_:_)+                <-  scanGraph   (\node -> triv  (nodeClass node) (nodeConflicts node) (nodeExclusions node)++                                  -- for iterative coalescing we only want non-move related+                                  --    nodes here+                                  && (not iterative || isEmptyUniqSet (nodeCoalesce node)))+                        $ graph++        , ksTrivFound   <- map nodeId nsTrivFound+        , graph2        <- foldr (\k g -> let Just g' = delNode k g+                                          in  g')+                                graph ksTrivFound++        = colorScan_spin iterative triv spill graph2+                (ksTrivFound ++ ksTriv)+                ksSpill+                kksCoalesce++        -- Coalesce:+        --      If we're doing iterative coalescing and no triv nodes are available+        --      then it's time for a coalescing pass.+        | iterative+        = case coalesceGraph False triv graph of++                -- we were able to coalesce something+                --      go back to Simplify and see if this frees up more nodes to be trivially colorable.+                (graph2, kksCoalesceFound@(_:_))+                 -> colorScan_spin iterative triv spill graph2+                        ksTriv ksSpill (reverse kksCoalesceFound ++ kksCoalesce)++                -- Freeze:+                -- nothing could be coalesced (or was triv),+                --      time to choose a node to freeze and give up on ever coalescing it.+                (graph2, [])+                 -> case freezeOneInGraph graph2 of++                        -- we were able to freeze something+                        --      hopefully this will free up something for Simplify+                        (graph3, True)+                         -> colorScan_spin iterative triv spill graph3+                                ksTriv ksSpill kksCoalesce++                        -- we couldn't find something to freeze either+                        --      time for a spill+                        (graph3, False)+                         -> colorScan_spill iterative triv spill graph3+                                ksTriv ksSpill kksCoalesce++        -- spill time+        | otherwise+        = colorScan_spill iterative triv spill graph+                ksTriv ksSpill kksCoalesce+++-- Select:+-- we couldn't find any triv nodes or things to freeze or coalesce,+--      and the graph isn't empty yet.. We'll have to choose a spill+--      candidate and leave it uncolored.+--+colorScan_spill+        :: ( Uniquable k, Uniquable cls, Uniquable color+           , Ord k,       Eq cls+           , Outputable k, Outputable cls)+        => Bool+        -> Triv k cls color+        -> (Graph k cls color -> k)+        -> Graph k cls color+        -> [k]+        -> [k]+        -> [(k, k)]+        -> ([k], [k], [(k, k)])++colorScan_spill iterative triv spill graph+        ksTriv ksSpill kksCoalesce++ = let  kSpill          = spill graph+        Just graph'     = delNode kSpill graph+   in   colorScan_spin iterative triv spill graph'+                ksTriv (kSpill : ksSpill) kksCoalesce+++-- | Try to assign a color to all these nodes.++assignColors+        :: ( Uniquable k, Uniquable cls, Uniquable color+           , Outputable cls)+        => UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).+        -> Graph k cls color            -- ^ the graph+        -> [k]                          -- ^ nodes to assign a color to.+        -> ( Graph k cls color          -- the colored graph+           , [k])                       -- the nodes that didn't color.++assignColors colors graph ks+        = assignColors' colors graph [] ks++ where  assignColors' _ graph prob []+                = (graph, prob)++        assignColors' colors graph prob (k:ks)+         = case assignColor colors k graph of++                -- couldn't color this node+                Nothing         -> assignColors' colors graph (k : prob) ks++                -- this node colored ok, so do the rest+                Just graph'     -> assignColors' colors graph' prob ks+++        assignColor colors u graph+                | Just c        <- selectColor colors graph u+                = Just (setColor u c graph)++                | otherwise+                = Nothing++++-- | Select a color for a certain node+--      taking into account preferences, neighbors and exclusions.+--      returns Nothing if no color can be assigned to this node.+--+selectColor+        :: ( Uniquable k, Uniquable cls, Uniquable color+           , Outputable cls)+        => UniqFM (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).+        -> Graph k cls color            -- ^ the graph+        -> k                            -- ^ key of the node to select a color for.+        -> Maybe color++selectColor colors graph u+ = let  -- lookup the node+        Just node       = lookupNode graph u++        -- lookup the available colors for the class of this node.+        colors_avail+         = case lookupUFM colors (nodeClass node) of+                Nothing -> pprPanic "selectColor: no colors available for class " (ppr (nodeClass node))+                Just cs -> cs++        -- find colors we can't use because they're already being used+        --      by a node that conflicts with this one.+        Just nsConflicts+                        = sequence+                        $ map (lookupNode graph)+                        $ nonDetEltsUniqSet+                        $ nodeConflicts node+                        -- See Note [Unique Determinism and code generation]++        colors_conflict = mkUniqSet+                        $ catMaybes+                        $ map nodeColor nsConflicts++        -- the prefs of our neighbors+        colors_neighbor_prefs+                        = mkUniqSet+                        $ concat $ map nodePreference nsConflicts++        -- colors that are still valid for us+        colors_ok_ex    = minusUniqSet colors_avail (nodeExclusions node)+        colors_ok       = minusUniqSet colors_ok_ex colors_conflict++        -- the colors that we prefer, and are still ok+        colors_ok_pref  = intersectUniqSets+                                (mkUniqSet $ nodePreference node) colors_ok++        -- the colors that we could choose while being nice to our neighbors+        colors_ok_nice  = minusUniqSet+                                colors_ok colors_neighbor_prefs++        -- the best of all possible worlds..+        colors_ok_pref_nice+                        = intersectUniqSets+                                colors_ok_nice colors_ok_pref++        -- make the decision+        chooseColor++                -- everyone is happy, yay!+                | not $ isEmptyUniqSet colors_ok_pref_nice+                , c : _         <- filter (\x -> elementOfUniqSet x colors_ok_pref_nice)+                                        (nodePreference node)+                = Just c++                -- we've got one of our preferences+                | not $ isEmptyUniqSet colors_ok_pref+                , c : _         <- filter (\x -> elementOfUniqSet x colors_ok_pref)+                                        (nodePreference node)+                = Just c++                -- it wasn't a preference, but it was still ok+                | not $ isEmptyUniqSet colors_ok+                , c : _         <- nonDetEltsUniqSet colors_ok+                -- See Note [Unique Determinism and code generation]+                = Just c++                -- no colors were available for us this time.+                --      looks like we're going around the loop again..+                | otherwise+                = Nothing++   in   chooseColor+++
+ compiler/utils/GraphOps.hs view
@@ -0,0 +1,680 @@+-- | Basic operations on graphs.+--++module GraphOps (+        addNode,        delNode,        getNode,       lookupNode,     modNode,+        size,+        union,+        addConflict,    delConflict,    addConflicts,+        addCoalesce,    delCoalesce,+        addExclusion,   addExclusions,+        addPreference,+        coalesceNodes,  coalesceGraph,+        freezeNode,     freezeOneInGraph, freezeAllInGraph,+        scanGraph,+        setColor,+        validateGraph,+        slurpNodeConflictCount+)+where++import GhcPrelude++import GraphBase++import Outputable+import Unique+import UniqSet+import UniqFM++import Data.List        hiding (union)+import Data.Maybe++-- | Lookup a node from the graph.+lookupNode+        :: Uniquable k+        => Graph k cls color+        -> k -> Maybe (Node  k cls color)++lookupNode graph k+        = lookupUFM (graphMap graph) k+++-- | Get a node from the graph, throwing an error if it's not there+getNode+        :: Uniquable k+        => Graph k cls color+        -> k -> Node k cls color++getNode graph k+ = case lookupUFM (graphMap graph) k of+        Just node       -> node+        Nothing         -> panic "ColorOps.getNode: not found"+++-- | Add a node to the graph, linking up its edges+addNode :: Uniquable k+        => k -> Node k cls color+        -> Graph k cls color -> Graph k cls color++addNode k node graph+ = let+        -- add back conflict edges from other nodes to this one+        map_conflict =+          nonDetFoldUniqSet+            -- It's OK to use nonDetFoldUFM here because the+            -- operation is commutative+            (adjustUFM_C (\n -> n { nodeConflicts =+                                      addOneToUniqSet (nodeConflicts n) k}))+            (graphMap graph)+            (nodeConflicts node)++        -- add back coalesce edges from other nodes to this one+        map_coalesce =+          nonDetFoldUniqSet+            -- It's OK to use nonDetFoldUFM here because the+            -- operation is commutative+            (adjustUFM_C (\n -> n { nodeCoalesce =+                                      addOneToUniqSet (nodeCoalesce n) k}))+            map_conflict+            (nodeCoalesce node)++  in    graph+        { graphMap      = addToUFM map_coalesce k node}+++-- | Delete a node and all its edges from the graph.+delNode :: (Uniquable k)+        => k -> Graph k cls color -> Maybe (Graph k cls color)++delNode k graph+        | Just node     <- lookupNode graph k+        = let   -- delete conflict edges from other nodes to this one.+                graph1  = foldl' (\g k1 -> let Just g' = delConflict k1 k g in g') graph+                        $ nonDetEltsUniqSet (nodeConflicts node)++                -- delete coalesce edge from other nodes to this one.+                graph2  = foldl' (\g k1 -> let Just g' = delCoalesce k1 k g in g') graph1+                        $ nonDetEltsUniqSet (nodeCoalesce node)+                        -- See Note [Unique Determinism and code generation]++                -- delete the node+                graph3  = graphMapModify (\fm -> delFromUFM fm k) graph2++          in    Just graph3++        | otherwise+        = Nothing+++-- | Modify a node in the graph.+--      returns Nothing if the node isn't present.+--+modNode :: Uniquable k+        => (Node k cls color -> Node k cls color)+        -> k -> Graph k cls color -> Maybe (Graph k cls color)++modNode f k graph+ = case lookupNode graph k of+        Just Node{}+         -> Just+         $  graphMapModify+                 (\fm   -> let  Just node       = lookupUFM fm k+                                node'           = f node+                           in   addToUFM fm k node')+                graph++        Nothing -> Nothing+++-- | Get the size of the graph, O(n)+size    :: Graph k cls color -> Int++size graph+        = sizeUFM $ graphMap graph+++-- | Union two graphs together.+union   :: Graph k cls color -> Graph k cls color -> Graph k cls color++union   graph1 graph2+        = Graph+        { graphMap              = plusUFM (graphMap graph1) (graphMap graph2) }+++-- | Add a conflict between nodes to the graph, creating the nodes required.+--      Conflicts are virtual regs which need to be colored differently.+addConflict+        :: Uniquable k+        => (k, cls) -> (k, cls)+        -> Graph k cls color -> Graph k cls color++addConflict (u1, c1) (u2, c2)+ = let  addNeighbor u c u'+                = adjustWithDefaultUFM+                        (\node -> node { nodeConflicts = addOneToUniqSet (nodeConflicts node) u' })+                        (newNode u c)  { nodeConflicts = unitUniqSet u' }+                        u++   in   graphMapModify+        ( addNeighbor u1 c1 u2+        . addNeighbor u2 c2 u1)+++-- | Delete a conflict edge. k1 -> k2+--      returns Nothing if the node isn't in the graph+delConflict+        :: Uniquable k+        => k -> k+        -> Graph k cls color -> Maybe (Graph k cls color)++delConflict k1 k2+        = modNode+                (\node -> node { nodeConflicts = delOneFromUniqSet (nodeConflicts node) k2 })+                k1+++-- | Add some conflicts to the graph, creating nodes if required.+--      All the nodes in the set are taken to conflict with each other.+addConflicts+        :: Uniquable k+        => UniqSet k -> (k -> cls)+        -> Graph k cls color -> Graph k cls color++addConflicts conflicts getClass++        -- just a single node, but no conflicts, create the node anyway.+        | (u : [])      <- nonDetEltsUniqSet conflicts+        = graphMapModify+        $ adjustWithDefaultUFM+                id+                (newNode u (getClass u))+                u++        | otherwise+        = graphMapModify+        $ \fm -> foldl' (\g u  -> addConflictSet1 u getClass conflicts g) fm+                $ nonDetEltsUniqSet conflicts+                -- See Note [Unique Determinism and code generation]+++addConflictSet1 :: Uniquable k+                => k -> (k -> cls) -> UniqSet k+                -> UniqFM (Node k cls color)+                -> UniqFM (Node k cls color)+addConflictSet1 u getClass set+ = case delOneFromUniqSet set u of+    set' -> adjustWithDefaultUFM+                (\node -> node                  { nodeConflicts = unionUniqSets set' (nodeConflicts node) } )+                (newNode u (getClass u))        { nodeConflicts = set' }+                u+++-- | Add an exclusion to the graph, creating nodes if required.+--      These are extra colors that the node cannot use.+addExclusion+        :: (Uniquable k, Uniquable color)+        => k -> (k -> cls) -> color+        -> Graph k cls color -> Graph k cls color++addExclusion u getClass color+        = graphMapModify+        $ adjustWithDefaultUFM+                (\node -> node                  { nodeExclusions = addOneToUniqSet (nodeExclusions node) color })+                (newNode u (getClass u))        { nodeExclusions = unitUniqSet color }+                u++addExclusions+        :: (Uniquable k, Uniquable color)+        => k -> (k -> cls) -> [color]+        -> Graph k cls color -> Graph k cls color++addExclusions u getClass colors graph+        = foldr (addExclusion u getClass) graph colors+++-- | Add a coalescence edge to the graph, creating nodes if requried.+--      It is considered adventageous to assign the same color to nodes in a coalesence.+addCoalesce+        :: Uniquable k+        => (k, cls) -> (k, cls)+        -> Graph k cls color -> Graph k cls color++addCoalesce (u1, c1) (u2, c2)+ = let  addCoalesce u c u'+         =      adjustWithDefaultUFM+                        (\node -> node { nodeCoalesce = addOneToUniqSet (nodeCoalesce node) u' })+                        (newNode u c)  { nodeCoalesce = unitUniqSet u' }+                        u++   in   graphMapModify+        ( addCoalesce u1 c1 u2+        . addCoalesce u2 c2 u1)+++-- | Delete a coalescence edge (k1 -> k2) from the graph.+delCoalesce+        :: Uniquable k+        => k -> k+        -> Graph k cls color    -> Maybe (Graph k cls color)++delCoalesce k1 k2+        = modNode (\node -> node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k2 })+                k1+++-- | Add a color preference to the graph, creating nodes if required.+--      The most recently added preference is the most prefered.+--      The algorithm tries to assign a node it's prefered color if possible.+--+addPreference+        :: Uniquable k+        => (k, cls) -> color+        -> Graph k cls color -> Graph k cls color++addPreference (u, c) color+        = graphMapModify+        $ adjustWithDefaultUFM+                (\node -> node { nodePreference = color : (nodePreference node) })+                (newNode u c)  { nodePreference = [color] }+                u+++-- | Do aggressive coalescing on this graph.+--      returns the new graph and the list of pairs of nodes that got coalesced together.+--      for each pair, the resulting node will have the least key and be second in the pair.+--+coalesceGraph+        :: (Uniquable k, Ord k, Eq cls, Outputable k)+        => Bool                 -- ^ If True, coalesce nodes even if this might make the graph+                                --      less colorable (aggressive coalescing)+        -> Triv k cls color+        -> Graph k cls color+        -> ( Graph k cls color+           , [(k, k)])          -- pairs of nodes that were coalesced, in the order that the+                                --      coalescing was applied.++coalesceGraph aggressive triv graph+        = coalesceGraph' aggressive triv graph []++coalesceGraph'+        :: (Uniquable k, Ord k, Eq cls, Outputable k)+        => Bool+        -> Triv k cls color+        -> Graph k cls color+        -> [(k, k)]+        -> ( Graph k cls color+           , [(k, k)])+coalesceGraph' aggressive triv graph kkPairsAcc+ = let+        -- find all the nodes that have coalescence edges+        cNodes  = filter (\node -> not $ isEmptyUniqSet (nodeCoalesce node))+                $ nonDetEltsUFM $ graphMap graph+                -- See Note [Unique Determinism and code generation]++        -- build a list of pairs of keys for node's we'll try and coalesce+        --      every pair of nodes will appear twice in this list+        --      ie [(k1, k2), (k2, k1) ... ]+        --      This is ok, GrapOps.coalesceNodes handles this and it's convenient for+        --      build a list of what nodes get coalesced together for later on.+        --+        cList   = [ (nodeId node1, k2)+                        | node1 <- cNodes+                        , k2    <- nonDetEltsUniqSet $ nodeCoalesce node1 ]+                        -- See Note [Unique Determinism and code generation]++        -- do the coalescing, returning the new graph and a list of pairs of keys+        --      that got coalesced together.+        (graph', mPairs)+                = mapAccumL (coalesceNodes aggressive triv) graph cList++        -- keep running until there are no more coalesces can be found+   in   case catMaybes mPairs of+         []     -> (graph', reverse kkPairsAcc)+         pairs  -> coalesceGraph' aggressive triv graph' (reverse pairs ++ kkPairsAcc)+++-- | Coalesce this pair of nodes unconditionally \/ aggressively.+--      The resulting node is the one with the least key.+--+--      returns: Just    the pair of keys if the nodes were coalesced+--                       the second element of the pair being the least one+--+--               Nothing if either of the nodes weren't in the graph++coalesceNodes+        :: (Uniquable k, Ord k, Eq cls)+        => Bool                 -- ^ If True, coalesce nodes even if this might make the graph+                                --      less colorable (aggressive coalescing)+        -> Triv  k cls color+        -> Graph k cls color+        -> (k, k)               -- ^ keys of the nodes to be coalesced+        -> (Graph k cls color, Maybe (k, k))++coalesceNodes aggressive triv graph (k1, k2)+        | (kMin, kMax)  <- if k1 < k2+                                then (k1, k2)+                                else (k2, k1)++        -- the nodes being coalesced must be in the graph+        , Just nMin     <- lookupNode graph kMin+        , Just nMax     <- lookupNode graph kMax++        -- can't coalesce conflicting modes+        , not $ elementOfUniqSet kMin (nodeConflicts nMax)+        , not $ elementOfUniqSet kMax (nodeConflicts nMin)++        -- can't coalesce the same node+        , nodeId nMin /= nodeId nMax++        = coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax++        -- don't do the coalescing after all+        | otherwise+        = (graph, Nothing)++coalesceNodes_merge+        :: (Uniquable k, Eq cls)+        => Bool+        -> Triv  k cls color+        -> Graph k cls color+        -> k -> k+        -> Node k cls color+        -> Node k cls color+        -> (Graph k cls color, Maybe (k, k))++coalesceNodes_merge aggressive triv graph kMin kMax nMin nMax++        -- sanity checks+        | nodeClass nMin /= nodeClass nMax+        = error "GraphOps.coalesceNodes: can't coalesce nodes of different classes."++        | not (isNothing (nodeColor nMin) && isNothing (nodeColor nMax))+        = error "GraphOps.coalesceNodes: can't coalesce colored nodes."++        ---+        | otherwise+        = let+                -- the new node gets all the edges from its two components+                node    =+                 Node   { nodeId                = kMin+                        , nodeClass             = nodeClass nMin+                        , nodeColor             = Nothing++                        -- nodes don't conflict with themselves..+                        , nodeConflicts+                                = (unionUniqSets (nodeConflicts nMin) (nodeConflicts nMax))+                                        `delOneFromUniqSet` kMin+                                        `delOneFromUniqSet` kMax++                        , nodeExclusions        = unionUniqSets (nodeExclusions nMin) (nodeExclusions nMax)+                        , nodePreference        = nodePreference nMin ++ nodePreference nMax++                        -- nodes don't coalesce with themselves..+                        , nodeCoalesce+                                = (unionUniqSets (nodeCoalesce nMin) (nodeCoalesce nMax))+                                        `delOneFromUniqSet` kMin+                                        `delOneFromUniqSet` kMax+                        }++          in    coalesceNodes_check aggressive triv graph kMin kMax node++coalesceNodes_check+        :: Uniquable k+        => Bool+        -> Triv  k cls color+        -> Graph k cls color+        -> k -> k+        -> Node k cls color+        -> (Graph k cls color, Maybe (k, k))++coalesceNodes_check aggressive triv graph kMin kMax node++        -- Unless we're coalescing aggressively, if the result node is not trivially+        --      colorable then don't do the coalescing.+        | not aggressive+        , not $ triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)+        = (graph, Nothing)++        | otherwise+        = let -- delete the old nodes from the graph and add the new one+                Just graph1     = delNode kMax graph+                Just graph2     = delNode kMin graph1+                graph3          = addNode kMin node graph2++          in    (graph3, Just (kMax, kMin))+++-- | Freeze a node+--      This is for the iterative coalescer.+--      By freezing a node we give up on ever coalescing it.+--      Move all its coalesce edges into the frozen set - and update+--      back edges from other nodes.+--+freezeNode+        :: Uniquable k+        => k                    -- ^ key of the node to freeze+        -> Graph k cls color    -- ^ the graph+        -> Graph k cls color    -- ^ graph with that node frozen++freezeNode k+  = graphMapModify+  $ \fm ->+    let -- freeze all the edges in the node to be frozen+        Just node = lookupUFM fm k+        node'   = node+                { nodeCoalesce          = emptyUniqSet }++        fm1     = addToUFM fm k node'++        -- update back edges pointing to this node+        freezeEdge k node+         = if elementOfUniqSet k (nodeCoalesce node)+                then node { nodeCoalesce = delOneFromUniqSet (nodeCoalesce node) k }+                else node       -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set"+                                -- If the edge isn't actually in the coelesce set then just ignore it.++        fm2     = nonDetFoldUniqSet (adjustUFM_C (freezeEdge k)) fm1+                    -- It's OK to use nonDetFoldUFM here because the operation+                    -- is commutative+                        $ nodeCoalesce node++    in  fm2+++-- | Freeze one node in the graph+--      This if for the iterative coalescer.+--      Look for a move related node of low degree and freeze it.+--+--      We probably don't need to scan the whole graph looking for the node of absolute+--      lowest degree. Just sample the first few and choose the one with the lowest+--      degree out of those. Also, we don't make any distinction between conflicts of different+--      classes.. this is just a heuristic, after all.+--+--      IDEA:   freezing a node might free it up for Simplify.. would be good to check for triv+--              right here, and add it to a worklist if known triv\/non-move nodes.+--+freezeOneInGraph+        :: (Uniquable k)+        => Graph k cls color+        -> ( Graph k cls color          -- the new graph+           , Bool )                     -- whether we found a node to freeze++freezeOneInGraph graph+ = let  compareNodeDegree n1 n2+                = compare (sizeUniqSet $ nodeConflicts n1) (sizeUniqSet $ nodeConflicts n2)++        candidates+                = sortBy compareNodeDegree+                $ take 5        -- 5 isn't special, it's just a small number.+                $ scanGraph (\node -> not $ isEmptyUniqSet (nodeCoalesce node)) graph++   in   case candidates of++         -- there wasn't anything available to freeze+         []     -> (graph, False)++         -- we found something to freeze+         (n : _)+          -> ( freezeNode (nodeId n) graph+             , True)+++-- | Freeze all the nodes in the graph+--      for debugging the iterative allocator.+--+freezeAllInGraph+        :: (Uniquable k)+        => Graph k cls color+        -> Graph k cls color++freezeAllInGraph graph+        = foldr freezeNode graph+                $ map nodeId+                $ nonDetEltsUFM $ graphMap graph+                -- See Note [Unique Determinism and code generation]+++-- | Find all the nodes in the graph that meet some criteria+--+scanGraph+        :: (Node k cls color -> Bool)+        -> Graph k cls color+        -> [Node k cls color]++scanGraph match graph+        = filter match $ nonDetEltsUFM $ graphMap graph+          -- See Note [Unique Determinism and code generation]+++-- | validate the internal structure of a graph+--      all its edges should point to valid nodes+--      If they don't then throw an error+--+validateGraph+        :: (Uniquable k, Outputable k, Eq color)+        => SDoc                         -- ^ extra debugging info to display on error+        -> Bool                         -- ^ whether this graph is supposed to be colored.+        -> Graph k cls color            -- ^ graph to validate+        -> Graph k cls color            -- ^ validated graph++validateGraph doc isColored graph++        -- Check that all edges point to valid nodes.+        | edges         <- unionManyUniqSets+                                (  (map nodeConflicts       $ nonDetEltsUFM $ graphMap graph)+                                ++ (map nodeCoalesce        $ nonDetEltsUFM $ graphMap graph))++        , nodes         <- mkUniqSet $ map nodeId $ nonDetEltsUFM $ graphMap graph+        , badEdges      <- minusUniqSet edges nodes+        , not $ isEmptyUniqSet badEdges+        = pprPanic "GraphOps.validateGraph"+                (  text "Graph has edges that point to non-existent nodes"+                $$ text "  bad edges: " <> pprUFM (getUniqSet badEdges) (vcat . map ppr)+                $$ doc )++        -- Check that no conflicting nodes have the same color+        | badNodes      <- filter (not . (checkNode graph))+                        $ nonDetEltsUFM $ graphMap graph+                           -- See Note [Unique Determinism and code generation]+        , not $ null badNodes+        = pprPanic "GraphOps.validateGraph"+                (  text "Node has same color as one of it's conflicts"+                $$ text "  bad nodes: " <> hcat (map (ppr . nodeId) badNodes)+                $$ doc)++        -- If this is supposed to be a colored graph,+        --      check that all nodes have a color.+        | isColored+        , badNodes      <- filter (\n -> isNothing $ nodeColor n)+                        $  nonDetEltsUFM $ graphMap graph+        , not $ null badNodes+        = pprPanic "GraphOps.validateGraph"+                (  text "Supposably colored graph has uncolored nodes."+                $$ text "  uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes)+                $$ doc )+++        -- graph looks ok+        | otherwise+        = graph+++-- | If this node is colored, check that all the nodes which+--      conflict with it have different colors.+checkNode+        :: (Uniquable k, Eq color)+        => Graph k cls color+        -> Node  k cls color+        -> Bool                 -- ^ True if this node is ok++checkNode graph node+        | Just color            <- nodeColor node+        , Just neighbors        <- sequence $ map (lookupNode graph)+                                $  nonDetEltsUniqSet $ nodeConflicts node+            -- See Note [Unique Determinism and code generation]++        , neighbourColors       <- catMaybes $ map nodeColor neighbors+        , elem color neighbourColors+        = False++        | otherwise+        = True++++-- | Slurp out a map of how many nodes had a certain number of conflict neighbours++slurpNodeConflictCount+        :: Graph k cls color+        -> UniqFM (Int, Int)    -- ^ (conflict neighbours, num nodes with that many conflicts)++slurpNodeConflictCount graph+        = addListToUFM_C+                (\(c1, n1) (_, n2) -> (c1, n1 + n2))+                emptyUFM+        $ map   (\node+                  -> let count  = sizeUniqSet $ nodeConflicts node+                     in  (count, (count, 1)))+        $ nonDetEltsUFM+        -- See Note [Unique Determinism and code generation]+        $ graphMap graph+++-- | Set the color of a certain node+setColor+        :: Uniquable k+        => k -> color+        -> Graph k cls color -> Graph k cls color++setColor u color+        = graphMapModify+        $ adjustUFM_C+                (\n -> n { nodeColor = Just color })+                u+++{-# INLINE adjustWithDefaultUFM #-}+adjustWithDefaultUFM+        :: Uniquable k+        => (a -> a) -> a -> k+        -> UniqFM a -> UniqFM a++adjustWithDefaultUFM f def k map+        = addToUFM_C+                (\old _ -> f old)+                map+                k def++-- Argument order different from UniqFM's adjustUFM+{-# INLINE adjustUFM_C #-}+adjustUFM_C+        :: Uniquable k+        => (a -> a)+        -> k -> UniqFM a -> UniqFM a++adjustUFM_C f k map+ = case lookupUFM map k of+        Nothing -> map+        Just a  -> addToUFM map k (f a)+
+ compiler/utils/GraphPpr.hs view
@@ -0,0 +1,173 @@++-- | Pretty printing of graphs.++module GraphPpr (+        dumpGraph,+        dotGraph+)+where++import GhcPrelude++import GraphBase++import Outputable+import Unique+import UniqSet+import UniqFM++import Data.List+import Data.Maybe+++-- | Pretty print a graph in a somewhat human readable format.+dumpGraph+        :: (Outputable k, Outputable color)+        => Graph k cls color -> SDoc++dumpGraph graph+        =  text "Graph"+        $$ pprUFM (graphMap graph) (vcat . map dumpNode)++dumpNode+        :: (Outputable k, Outputable color)+        => Node k cls color -> SDoc++dumpNode node+        =  text "Node " <> ppr (nodeId node)+        $$ text "conflicts "+                <> parens (int (sizeUniqSet $ nodeConflicts node))+                <> text " = "+                <> ppr (nodeConflicts node)++        $$ text "exclusions "+                <> parens (int (sizeUniqSet $ nodeExclusions node))+                <> text " = "+                <> ppr (nodeExclusions node)++        $$ text "coalesce "+                <> parens (int (sizeUniqSet $ nodeCoalesce node))+                <> text " = "+                <> ppr (nodeCoalesce node)++        $$ space++++-- | Pretty print a graph in graphviz .dot format.+--      Conflicts get solid edges.+--      Coalescences get dashed edges.+dotGraph+        :: ( Uniquable k+           , Outputable k, Outputable cls, Outputable color)+        => (color -> SDoc)  -- ^ What graphviz color to use for each node color+                            --  It's usually safe to return X11 style colors here,+                            --  ie "red", "green" etc or a hex triplet #aaff55 etc+        -> Triv k cls color+        -> Graph k cls color -> SDoc++dotGraph colorMap triv graph+ = let  nodes   = nonDetEltsUFM $ graphMap graph+                  -- See Note [Unique Determinism and code generation]+   in   vcat+                (  [ text "graph G {" ]+                ++ map (dotNode colorMap triv) nodes+                ++ (catMaybes $ snd $ mapAccumL dotNodeEdges emptyUniqSet nodes)+                ++ [ text "}"+                   , space ])+++dotNode :: ( Outputable k, Outputable cls, Outputable color)+        => (color -> SDoc)+        -> Triv k cls color+        -> Node k cls color -> SDoc++dotNode colorMap triv node+ = let  name    = ppr $ nodeId node+        cls     = ppr $ nodeClass node++        excludes+                = hcat $ punctuate space+                $ map (\n -> text "-" <> ppr n)+                $ nonDetEltsUniqSet $ nodeExclusions node+                -- See Note [Unique Determinism and code generation]++        preferences+                = hcat $ punctuate space+                $ map (\n -> text "+" <> ppr n)+                $ nodePreference node++        expref  = if and [isEmptyUniqSet (nodeExclusions node), null (nodePreference node)]+                        then empty+                        else text "\\n" <> (excludes <+> preferences)++        -- if the node has been colored then show that,+        --      otherwise indicate whether it looks trivially colorable.+        color+                | Just c        <- nodeColor node+                = text "\\n(" <> ppr c <> text ")"++                | triv (nodeClass node) (nodeConflicts node) (nodeExclusions node)+                = text "\\n(" <> text "triv" <> text ")"++                | otherwise+                = text "\\n(" <> text "spill?" <> text ")"++        label   =  name <> text " :: " <> cls+                <> expref+                <> color++        pcolorC = case nodeColor node of+                        Nothing -> text "style=filled fillcolor=white"+                        Just c  -> text "style=filled fillcolor=" <> doubleQuotes (colorMap c)+++        pout    = text "node [label=" <> doubleQuotes label <> space <> pcolorC <> text "]"+                <> space <> doubleQuotes name+                <> text ";"++ in     pout+++-- | Nodes in the graph are doubly linked, but we only want one edge for each+--      conflict if the graphviz graph. Traverse over the graph, but make sure+--      to only print the edges for each node once.++dotNodeEdges+        :: ( Uniquable k+           , Outputable k)+        => UniqSet k+        -> Node k cls color+        -> (UniqSet k, Maybe SDoc)++dotNodeEdges visited node+        | elementOfUniqSet (nodeId node) visited+        = ( visited+          , Nothing)++        | otherwise+        = let   dconflicts+                        = map (dotEdgeConflict (nodeId node))+                        $ nonDetEltsUniqSet+                        -- See Note [Unique Determinism and code generation]+                        $ minusUniqSet (nodeConflicts node) visited++                dcoalesces+                        = map (dotEdgeCoalesce (nodeId node))+                        $ nonDetEltsUniqSet+                        -- See Note [Unique Determinism and code generation]+                        $ minusUniqSet (nodeCoalesce node) visited++                out     =  vcat dconflicts+                        $$ vcat dcoalesces++          in    ( addOneToUniqSet visited (nodeId node)+                , Just out)++        where   dotEdgeConflict u1 u2+                        = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)+                        <> text ";"++                dotEdgeCoalesce u1 u2+                        = doubleQuotes (ppr u1) <> text " -- " <> doubleQuotes (ppr u2)+                        <> space <> text "[ style = dashed ];"
+ compiler/utils/ListT.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-------------------------------------------------------------------------+-- |+-- Module      : Control.Monad.Logic+-- Copyright   : (c) Dan Doel+-- License     : BSD3+--+-- Maintainer  : dan.doel@gmail.com+-- Stability   : experimental+-- Portability : non-portable (multi-parameter type classes)+--+-- A backtracking, logic programming monad.+--+--    Adapted from the paper+--    /Backtracking, Interleaving, and Terminating+--        Monad Transformers/, by+--    Oleg Kiselyov, Chung-chieh Shan, Daniel P. Friedman, Amr Sabry+--    (<http://www.cs.rutgers.edu/~ccshan/logicprog/ListT-icfp2005.pdf>).+-------------------------------------------------------------------------++module ListT (+    ListT(..),+    runListT,+    select,+    fold+  ) where++import GhcPrelude++import Control.Applicative++import Control.Monad+import Control.Monad.Fail as MonadFail++-------------------------------------------------------------------------+-- | A monad transformer for performing backtracking computations+-- layered over another monad 'm'+newtype ListT m a =+    ListT { unListT :: forall r. (a -> m r -> m r) -> m r -> m r }++select :: Monad m => [a] -> ListT m a+select xs = foldr (<|>) mzero (map pure xs)++fold :: ListT m a -> (a -> m r -> m r) -> m r -> m r+fold = runListT++-------------------------------------------------------------------------+-- | Runs a ListT computation with the specified initial success and+-- failure continuations.+runListT :: ListT m a -> (a -> m r -> m r) -> m r -> m r+runListT = unListT++instance Functor (ListT f) where+    fmap f lt = ListT $ \sk fk -> unListT lt (sk . f) fk++instance Applicative (ListT f) where+    pure a = ListT $ \sk fk -> sk a fk+    f <*> a = ListT $ \sk fk -> unListT f (\g fk' -> unListT a (sk . g) fk') fk++instance Alternative (ListT f) where+    empty = ListT $ \_ fk -> fk+    f1 <|> f2 = ListT $ \sk fk -> unListT f1 sk (unListT f2 sk fk)++instance Monad (ListT m) where+    m >>= f = ListT $ \sk fk -> unListT m (\a fk' -> unListT (f a) sk fk') fk+#if !MIN_VERSION_base(4,13,0)+    fail = MonadFail.fail+#endif++instance MonadFail.MonadFail (ListT m) where+    fail _ = ListT $ \_ fk -> fk++instance MonadPlus (ListT m) where+    mzero = ListT $ \_ fk -> fk+    m1 `mplus` m2 = ListT $ \sk fk -> unListT m1 sk (unListT m2 sk fk)
+ compiler/utils/State.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE UnboxedTuples #-}++module State where++import GhcPrelude++newtype State s a = State { runState' :: s -> (# a, s #) }++instance Functor (State s) where+    fmap f m  = State $ \s -> case runState' m s of+                              (# r, s' #) -> (# f r, s' #)++instance Applicative (State s) where+   pure x   = State $ \s -> (# x, s #)+   m <*> n  = State $ \s -> case runState' m s of+                            (# f, s' #) -> case runState' n s' of+                                           (# x, s'' #) -> (# f x, s'' #)++instance Monad (State s) where+    m >>= n  = State $ \s -> case runState' m s of+                             (# r, s' #) -> runState' (n r) s'++get :: State s s+get = State $ \s -> (# s, s #)++gets :: (s -> a) -> State s a+gets f = State $ \s -> (# f s, s #)++put :: s -> State s ()+put s' = State $ \_ -> (# (), s' #)++modify :: (s -> s) -> State s ()+modify f = State $ \s -> (# (), f s #)+++evalState :: State s a -> s -> a+evalState s i = case runState' s i of+                (# a, _ #) -> a+++execState :: State s a -> s -> s+execState s i = case runState' s i of+                (# _, s' #) -> s'+++runState :: State s a -> s -> (a, s)+runState s i = case runState' s i of+               (# a, s' #) -> (a, s')
+ compiler/utils/Stream.hs view
@@ -0,0 +1,106 @@+-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 2012+--+-- Monadic streams+--+-- -----------------------------------------------------------------------------+module Stream (+    Stream(..), yield, liftIO,+    collect, fromList,+    Stream.map, Stream.mapM, Stream.mapAccumL+  ) where++import GhcPrelude++import Control.Monad++-- |+-- @Stream m a b@ is a computation in some Monad @m@ that delivers a sequence+-- of elements of type @a@ followed by a result of type @b@.+--+-- More concretely, a value of type @Stream m a b@ can be run using @runStream@+-- in the Monad @m@, and it delivers either+--+--  * the final result: @Left b@, or+--  * @Right (a,str)@, where @a@ is the next element in the stream, and @str@+--    is a computation to get the rest of the stream.+--+-- Stream is itself a Monad, and provides an operation 'yield' that+-- produces a new element of the stream.  This makes it convenient to turn+-- existing monadic computations into streams.+--+-- The idea is that Stream is useful for making a monadic computation+-- that produces values from time to time.  This can be used for+-- knitting together two complex monadic operations, so that the+-- producer does not have to produce all its values before the+-- consumer starts consuming them.  We make the producer into a+-- Stream, and the consumer pulls on the stream each time it wants a+-- new value.+--+newtype Stream m a b = Stream { runStream :: m (Either b (a, Stream m a b)) }++instance Monad f => Functor (Stream f a) where+  fmap = liftM++instance Monad m => Applicative (Stream m a) where+  pure a = Stream (return (Left a))+  (<*>) = ap++instance Monad m => Monad (Stream m a) where++  Stream m >>= k = Stream $ do+                r <- m+                case r of+                  Left b        -> runStream (k b)+                  Right (a,str) -> return (Right (a, str >>= k))++yield :: Monad m => a -> Stream m a ()+yield a = Stream (return (Right (a, return ())))++liftIO :: IO a -> Stream IO b a+liftIO io = Stream $ io >>= return . Left++-- | Turn a Stream into an ordinary list, by demanding all the elements.+collect :: Monad m => Stream m a () -> m [a]+collect str = go str []+ where+  go str acc = do+    r <- runStream str+    case r of+      Left () -> return (reverse acc)+      Right (a, str') -> go str' (a:acc)++-- | Turn a list into a 'Stream', by yielding each element in turn.+fromList :: Monad m => [a] -> Stream m a ()+fromList = mapM_ yield++-- | Apply a function to each element of a 'Stream', lazily+map :: Monad m => (a -> b) -> Stream m a x -> Stream m b x+map f str = Stream $ do+   r <- runStream str+   case r of+     Left x -> return (Left x)+     Right (a, str') -> return (Right (f a, Stream.map f str'))++-- | Apply a monadic operation to each element of a 'Stream', lazily+mapM :: Monad m => (a -> m b) -> Stream m a x -> Stream m b x+mapM f str = Stream $ do+   r <- runStream str+   case r of+     Left x -> return (Left x)+     Right (a, str') -> do+        b <- f a+        return (Right (b, Stream.mapM f str'))++-- | analog of the list-based 'mapAccumL' on Streams.  This is a simple+-- way to map over a Stream while carrying some state around.+mapAccumL :: Monad m => (c -> a -> m (c,b)) -> c -> Stream m a ()+          -> Stream m b c+mapAccumL f c str = Stream $ do+  r <- runStream str+  case r of+    Left  () -> return (Left c)+    Right (a, str') -> do+      (c',b) <- f c a+      return (Right (b, mapAccumL f c' str'))
+ compiler/utils/UnVarGraph.hs view
@@ -0,0 +1,145 @@+{-++Copyright (c) 2014 Joachim Breitner++A data structure for undirected graphs of variables+(or in plain terms: Sets of unordered pairs of numbers)+++This is very specifically tailored for the use in CallArity. In particular it+stores the graph as a union of complete and complete bipartite graph, which+would be very expensive to store as sets of edges or as adjanceny lists.++It does not normalize the graphs. This means that g `unionUnVarGraph` g is+equal to g, but twice as expensive and large.++-}+module UnVarGraph+    ( UnVarSet+    , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets+    , delUnVarSet+    , elemUnVarSet, isEmptyUnVarSet+    , UnVarGraph+    , emptyUnVarGraph+    , unionUnVarGraph, unionUnVarGraphs+    , completeGraph, completeBipartiteGraph+    , neighbors+    , hasLoopAt+    , delNode+    ) where++import GhcPrelude++import Id+import VarEnv+import UniqFM+import Outputable+import Bag+import Unique++import qualified Data.IntSet as S++-- We need a type for sets of variables (UnVarSet).+-- We do not use VarSet, because for that we need to have the actual variable+-- at hand, and we do not have that when we turn the domain of a VarEnv into a UnVarSet.+-- Therefore, use a IntSet directly (which is likely also a bit more efficient).++-- Set of uniques, i.e. for adjancet nodes+newtype UnVarSet = UnVarSet (S.IntSet)+    deriving Eq++k :: Var -> Int+k v = getKey (getUnique v)++emptyUnVarSet :: UnVarSet+emptyUnVarSet = UnVarSet S.empty++elemUnVarSet :: Var -> UnVarSet -> Bool+elemUnVarSet v (UnVarSet s) = k v `S.member` s+++isEmptyUnVarSet :: UnVarSet -> Bool+isEmptyUnVarSet (UnVarSet s) = S.null s++delUnVarSet :: UnVarSet -> Var -> UnVarSet+delUnVarSet (UnVarSet s) v = UnVarSet $ k v `S.delete` s++mkUnVarSet :: [Var] -> UnVarSet+mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs++varEnvDom :: VarEnv a -> UnVarSet+varEnvDom ae = UnVarSet $ ufmToSet_Directly ae++unionUnVarSet :: UnVarSet -> UnVarSet -> UnVarSet+unionUnVarSet (UnVarSet set1) (UnVarSet set2) = UnVarSet (set1 `S.union` set2)++unionUnVarSets :: [UnVarSet] -> UnVarSet+unionUnVarSets = foldr unionUnVarSet emptyUnVarSet++instance Outputable UnVarSet where+    ppr (UnVarSet s) = braces $+        hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s]+++-- The graph type. A list of complete bipartite graphs+data Gen = CBPG UnVarSet UnVarSet -- complete bipartite+         | CG   UnVarSet          -- complete+newtype UnVarGraph = UnVarGraph (Bag Gen)++emptyUnVarGraph :: UnVarGraph+emptyUnVarGraph = UnVarGraph emptyBag++unionUnVarGraph :: UnVarGraph -> UnVarGraph -> UnVarGraph+{-+Premature optimisation, it seems.+unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])+    | s1 == s3 && s2 == s4+    = pprTrace "unionUnVarGraph fired" empty $+      completeGraph (s1 `unionUnVarSet` s2)+unionUnVarGraph (UnVarGraph [CBPG s1 s2]) (UnVarGraph [CG s3, CG s4])+    | s2 == s3 && s1 == s4+    = pprTrace "unionUnVarGraph fired2" empty $+      completeGraph (s1 `unionUnVarSet` s2)+-}+unionUnVarGraph (UnVarGraph g1) (UnVarGraph g2)+    = -- pprTrace "unionUnVarGraph" (ppr (length g1, length g2)) $+      UnVarGraph (g1 `unionBags` g2)++unionUnVarGraphs :: [UnVarGraph] -> UnVarGraph+unionUnVarGraphs = foldl' unionUnVarGraph emptyUnVarGraph++-- completeBipartiteGraph A B = { {a,b} | a ∈ A, b ∈ B }+completeBipartiteGraph :: UnVarSet -> UnVarSet -> UnVarGraph+completeBipartiteGraph s1 s2 = prune $ UnVarGraph $ unitBag $ CBPG s1 s2++completeGraph :: UnVarSet -> UnVarGraph+completeGraph s = prune $ UnVarGraph $ unitBag $ CG s++neighbors :: UnVarGraph -> Var -> UnVarSet+neighbors (UnVarGraph g) v = unionUnVarSets $ concatMap go $ bagToList g+  where go (CG s)       = (if v `elemUnVarSet` s then [s] else [])+        go (CBPG s1 s2) = (if v `elemUnVarSet` s1 then [s2] else []) +++                          (if v `elemUnVarSet` s2 then [s1] else [])++-- hasLoopAt G v <=> v--v ∈ G+hasLoopAt :: UnVarGraph -> Var -> Bool+hasLoopAt (UnVarGraph g) v = any go $ bagToList g+  where go (CG s)       = v `elemUnVarSet` s+        go (CBPG s1 s2) = v `elemUnVarSet` s1 && v `elemUnVarSet` s2+++delNode :: UnVarGraph -> Var -> UnVarGraph+delNode (UnVarGraph g) v = prune $ UnVarGraph $ mapBag go g+  where go (CG s)       = CG (s `delUnVarSet` v)+        go (CBPG s1 s2) = CBPG (s1 `delUnVarSet` v) (s2 `delUnVarSet` v)++prune :: UnVarGraph -> UnVarGraph+prune (UnVarGraph g) = UnVarGraph $ filterBag go g+  where go (CG s)       = not (isEmptyUnVarSet s)+        go (CBPG s1 s2) = not (isEmptyUnVarSet s1) && not (isEmptyUnVarSet s2)++instance Outputable Gen where+    ppr (CG s)       = ppr s  <> char '²'+    ppr (CBPG s1 s2) = ppr s1 <+> char 'x' <+> ppr s2+instance Outputable UnVarGraph where+    ppr (UnVarGraph g) = ppr g
+ compiler/utils/UniqMap.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# OPTIONS_GHC -Wall #-}++-- Like 'UniqFM', these are maps for keys which are Uniquable.+-- Unlike 'UniqFM', these maps also remember their keys, which+-- makes them a much better drop in replacement for 'Data.Map.Map'.+--+-- Key preservation is right-biased.+module UniqMap (+    UniqMap,+    emptyUniqMap,+    isNullUniqMap,+    unitUniqMap,+    listToUniqMap,+    listToUniqMap_C,+    addToUniqMap,+    addListToUniqMap,+    addToUniqMap_C,+    addToUniqMap_Acc,+    alterUniqMap,+    addListToUniqMap_C,+    adjustUniqMap,+    delFromUniqMap,+    delListFromUniqMap,+    plusUniqMap,+    plusUniqMap_C,+    plusMaybeUniqMap_C,+    plusUniqMapList,+    minusUniqMap,+    intersectUniqMap,+    disjointUniqMap,+    mapUniqMap,+    filterUniqMap,+    partitionUniqMap,+    sizeUniqMap,+    elemUniqMap,+    lookupUniqMap,+    lookupWithDefaultUniqMap,+    anyUniqMap,+    allUniqMap,+    -- Non-deterministic functions omitted+) where++import GhcPrelude++import UniqFM++import Unique+import Outputable++import Data.Semigroup as Semi ( Semigroup(..) )+import Data.Coerce+import Data.Maybe+import Data.Data++-- | Maps indexed by 'Uniquable' keys+newtype UniqMap k a = UniqMap (UniqFM (k, a))+    deriving (Data, Eq, Functor)+type role UniqMap nominal representational++instance Semigroup (UniqMap k a) where+  (<>) = plusUniqMap++instance Monoid (UniqMap k a) where+    mempty = emptyUniqMap+    mappend = (Semi.<>)++instance (Outputable k, Outputable a) => Outputable (UniqMap k a) where+    ppr (UniqMap m) =+        brackets $ fsep $ punctuate comma $+        [ ppr k <+> text "->" <+> ppr v+        | (k, v) <- eltsUFM m ]++liftC :: (a -> a -> a) -> (k, a) -> (k, a) -> (k, a)+liftC f (_, v) (k', v') = (k', f v v')++emptyUniqMap :: UniqMap k a+emptyUniqMap = UniqMap emptyUFM++isNullUniqMap :: UniqMap k a -> Bool+isNullUniqMap (UniqMap m) = isNullUFM m++unitUniqMap :: Uniquable k => k -> a -> UniqMap k a+unitUniqMap k v = UniqMap (unitUFM k (k, v))++listToUniqMap :: Uniquable k => [(k,a)] -> UniqMap k a+listToUniqMap kvs = UniqMap (listToUFM [ (k,(k,v)) | (k,v) <- kvs])++listToUniqMap_C :: Uniquable k => (a -> a -> a) -> [(k,a)] -> UniqMap k a+listToUniqMap_C f kvs = UniqMap $+    listToUFM_C (liftC f) [ (k,(k,v)) | (k,v) <- kvs]++addToUniqMap :: Uniquable k => UniqMap k a -> k -> a -> UniqMap k a+addToUniqMap (UniqMap m) k v = UniqMap $ addToUFM m k (k, v)++addListToUniqMap :: Uniquable k => UniqMap k a -> [(k,a)] -> UniqMap k a+addListToUniqMap (UniqMap m) kvs = UniqMap $+    addListToUFM m [(k,(k,v)) | (k,v) <- kvs]++addToUniqMap_C :: Uniquable k+               => (a -> a -> a)+               -> UniqMap k a+               -> k+               -> a+               -> UniqMap k a+addToUniqMap_C f (UniqMap m) k v = UniqMap $+    addToUFM_C (liftC f) m k (k, v)++addToUniqMap_Acc :: Uniquable k+                 => (b -> a -> a)+                 -> (b -> a)+                 -> UniqMap k a+                 -> k+                 -> b+                 -> UniqMap k a+addToUniqMap_Acc exi new (UniqMap m) k0 v0 = UniqMap $+    addToUFM_Acc (\b (k, v) -> (k, exi b v))+                 (\b -> (k0, new b))+                 m k0 v0++alterUniqMap :: Uniquable k+             => (Maybe a -> Maybe a)+             -> UniqMap k a+             -> k+             -> UniqMap k a+alterUniqMap f (UniqMap m) k = UniqMap $+    alterUFM (fmap (k,) . f . fmap snd) m k++addListToUniqMap_C+    :: Uniquable k+    => (a -> a -> a)+    -> UniqMap k a+    -> [(k, a)]+    -> UniqMap k a+addListToUniqMap_C f (UniqMap m) kvs = UniqMap $+    addListToUFM_C (liftC f) m+        [(k,(k,v)) | (k,v) <- kvs]++adjustUniqMap+    :: Uniquable k+    => (a -> a)+    -> UniqMap k a+    -> k+    -> UniqMap k a+adjustUniqMap f (UniqMap m) k = UniqMap $+    adjustUFM (\(_,v) -> (k,f v)) m k++delFromUniqMap :: Uniquable k => UniqMap k a -> k -> UniqMap k a+delFromUniqMap (UniqMap m) k = UniqMap $ delFromUFM m k++delListFromUniqMap :: Uniquable k => UniqMap k a -> [k] -> UniqMap k a+delListFromUniqMap (UniqMap m) ks = UniqMap $ delListFromUFM m ks++plusUniqMap :: UniqMap k a -> UniqMap k a -> UniqMap k a+plusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ plusUFM m1 m2++plusUniqMap_C :: (a -> a -> a) -> UniqMap k a -> UniqMap k a -> UniqMap k a+plusUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $+    plusUFM_C (liftC f) m1 m2++plusMaybeUniqMap_C :: (a -> a -> Maybe a) -> UniqMap k a -> UniqMap k a -> UniqMap k a+plusMaybeUniqMap_C f (UniqMap m1) (UniqMap m2) = UniqMap $+    plusMaybeUFM_C (\(_, v) (k', v') -> fmap (k',) (f v v')) m1 m2++plusUniqMapList :: [UniqMap k a] -> UniqMap k a+plusUniqMapList xs = UniqMap $ plusUFMList (coerce xs)++minusUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a+minusUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ minusUFM m1 m2++intersectUniqMap :: UniqMap k a -> UniqMap k b -> UniqMap k a+intersectUniqMap (UniqMap m1) (UniqMap m2) = UniqMap $ intersectUFM m1 m2++disjointUniqMap :: UniqMap k a -> UniqMap k b -> Bool+disjointUniqMap (UniqMap m1) (UniqMap m2) = disjointUFM m1 m2++mapUniqMap :: (a -> b) -> UniqMap k a -> UniqMap k b+mapUniqMap f (UniqMap m) = UniqMap $ mapUFM (fmap f) m -- (,) k instance++filterUniqMap :: (a -> Bool) -> UniqMap k a -> UniqMap k a+filterUniqMap f (UniqMap m) = UniqMap $ filterUFM (f . snd) m++partitionUniqMap :: (a -> Bool) -> UniqMap k a -> (UniqMap k a, UniqMap k a)+partitionUniqMap f (UniqMap m) =+    coerce $ partitionUFM (f . snd) m++sizeUniqMap :: UniqMap k a -> Int+sizeUniqMap (UniqMap m) = sizeUFM m++elemUniqMap :: Uniquable k => k -> UniqMap k a -> Bool+elemUniqMap k (UniqMap m) = elemUFM k m++lookupUniqMap :: Uniquable k => UniqMap k a -> k -> Maybe a+lookupUniqMap (UniqMap m) k = fmap snd (lookupUFM m k)++lookupWithDefaultUniqMap :: Uniquable k => UniqMap k a -> a -> k -> a+lookupWithDefaultUniqMap (UniqMap m) a k = fromMaybe a (fmap snd (lookupUFM m k))++anyUniqMap :: (a -> Bool) -> UniqMap k a -> Bool+anyUniqMap f (UniqMap m) = anyUFM (f . snd) m++allUniqMap :: (a -> Bool) -> UniqMap k a -> Bool+allUniqMap f (UniqMap m) = allUFM (f . snd) m
+ compiler/utils/md5.h view
@@ -0,0 +1,18 @@+/* MD5 message digest */+#pragma once++#include "HsFFI.h"++typedef HsWord32 word32;+typedef HsWord8  byte;++struct MD5Context {+        word32 buf[4];+        word32 bytes[2];+        word32 in[16];+};++void MD5Init(struct MD5Context *context);+void MD5Update(struct MD5Context *context, byte const *buf, int len);+void MD5Final(byte digest[16], struct MD5Context *context);+void MD5Transform(word32 buf[4], word32 const in[16]);
+ ghc-lib.cabal view
@@ -0,0 +1,692 @@+cabal-version: >=1.22+build-type: Simple+name: ghc-lib+version: 0.1.0+license: BSD3+license-file: LICENSE+category: Development+author: The GHC Team and Digital Asset+maintainer: Digital Asset+synopsis: The GHC API, decoupled from GHC versions+description: A package equivalent to the @ghc@ package, but which can be loaded on many compiler versions.+homepage: https://github.com/digital-asset/ghc-lib+bug-reports: https://github.com/digital-asset/ghc-lib/issues+data-dir: ghc-lib/stage1/lib+data-files:+    settings+    llvm-targets+    llvm-passes+    platformConstants+extra-source-files:+    ghc-lib/generated/ghcautoconf.h+    ghc-lib/generated/ghcplatform.h+    ghc-lib/generated/ghcversion.h+    ghc-lib/generated/DerivedConstants.h+    ghc-lib/generated/GHCConstantsHaskellExports.hs+    ghc-lib/generated/GHCConstantsHaskellType.hs+    ghc-lib/generated/GHCConstantsHaskellWrappers.hs+    ghc-lib/stage1/compiler/build/ghc_boot_platform.h+    ghc-lib/stage1/compiler/build/primop-can-fail.hs-incl+    ghc-lib/stage1/compiler/build/primop-code-size.hs-incl+    ghc-lib/stage1/compiler/build/primop-commutable.hs-incl+    ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl+    ghc-lib/stage1/compiler/build/primop-fixity.hs-incl+    ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl+    ghc-lib/stage1/compiler/build/primop-list.hs-incl+    ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl+    ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl+    ghc-lib/stage1/compiler/build/primop-strictness.hs-incl+    ghc-lib/stage1/compiler/build/primop-tag.hs-incl+    ghc-lib/stage1/compiler/build/primop-vector-tycons.hs-incl+    ghc-lib/stage1/compiler/build/primop-vector-tys-exports.hs-incl+    ghc-lib/stage1/compiler/build/primop-vector-tys.hs-incl+    ghc-lib/stage1/compiler/build/primop-vector-uniques.hs-incl+    includes/*.h+    includes/CodeGen.Platform.hs+    includes/rts/*.h+    includes/rts/storage/*.h+    includes/rts/prof/*.h+    compiler/nativeGen/*.h+    compiler/utils/*.h+    compiler/*.h+tested-with: GHC==8.6.3, GHC==8.4.3+source-repository head+    type: git+    location: git@github.com:digital-asset/ghc-lib.git++library+    default-language:   Haskell2010+    default-extensions: NoImplicitPrelude+    include-dirs:+        ghc-lib/generated+        ghc-lib/stage1/compiler/build+        compiler+        compiler/utils+    ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS+    cc-options: -DTHREADED_RTS+    cpp-options: -DSTAGE=2 -DTHREADED_RTS -DGHCI -DGHC_IN_GHCI+    if !os(windows)+        build-depends: unix+    else+        build-depends: Win32+    build-depends:+        ghc-prim > 0.2 && < 0.6,+        base >= 4.11 && < 4.14,+        containers >= 0.5 && < 0.7,+        bytestring >= 0.9 && < 0.11,+        binary == 0.8.*,+        filepath >= 1 && < 1.5,+        directory >= 1 && < 1.4,+        array >= 0.1 && < 0.6,+        deepseq >= 1.4 && < 1.5,+        pretty == 1.1.*,+        time >= 1.4 && < 1.10,+        transformers == 0.5.*,+        process >= 1 && < 1.7,+        hpc == 0.6.*,+        ghc-lib-parser+    build-tools: alex >= 3.1, happy >= 1.19.4+    other-extensions:+        BangPatterns+        CPP+        DataKinds+        DefaultSignatures+        DeriveDataTypeable+        DeriveFoldable+        DeriveFunctor+        DeriveGeneric+        DeriveTraversable+        DisambiguateRecordFields+        ExistentialQuantification+        ExplicitForAll+        FlexibleContexts+        FlexibleInstances+        GADTs+        GeneralizedNewtypeDeriving+        InstanceSigs+        MagicHash+        MultiParamTypeClasses+        NamedFieldPuns+        NondecreasingIndentation+        RankNTypes+        RecordWildCards+        RoleAnnotations+        ScopedTypeVariables+        StandaloneDeriving+        Trustworthy+        TupleSections+        TypeFamilies+        TypeSynonymInstances+        UnboxedTuples+        UndecidableInstances+    hs-source-dirs:+        compiler+        compiler/backpack+        compiler/cmm+        compiler/codeGen+        compiler/coreSyn+        compiler/deSugar+        compiler/ghci+        compiler/hieFile+        compiler/hsSyn+        compiler/iface+        compiler/llvmGen+        compiler/main+        compiler/nativeGen+        compiler/prelude+        compiler/profiling+        compiler/rename+        compiler/simplCore+        compiler/simplStg+        compiler/specialise+        compiler/stgSyn+        compiler/stranal+        compiler/typecheck+        compiler/utils+        ghc-lib/stage1/compiler/build+        libraries/ghc-boot+        libraries/ghci+        libraries/template-haskell+    autogen-modules:+        Paths_ghc_lib+    reexported-modules:+        Annotations,+        ApiAnnotation,+        Avail,+        Bag,+        BasicTypes,+        BinFingerprint,+        Binary,+        BkpSyn,+        BooleanFormula,+        BufWrite,+        ByteCodeTypes,+        Class,+        CmdLineParser,+        CmmType,+        CoAxiom,+        Coercion,+        ConLike,+        Config,+        Constants,+        CoreArity,+        CoreFVs,+        CoreMap,+        CoreMonad,+        CoreOpt,+        CoreSeq,+        CoreStats,+        CoreSubst,+        CoreSyn,+        CoreTidy,+        CoreUnfold,+        CoreUtils,+        CostCentre,+        CostCentreState,+        Ctype,+        DataCon,+        Demand,+        Digraph,+        DriverPhases,+        DynFlags,+        Encoding,+        EnumSet,+        ErrUtils,+        Exception,+        FV,+        FamInstEnv,+        FastFunctions,+        FastMutInt,+        FastString,+        FastStringEnv,+        FieldLabel,+        FileCleanup,+        Fingerprint,+        FiniteMap,+        ForeignCall,+        GHC.Exts.Heap,+        GHC.Exts.Heap.ClosureTypes,+        GHC.Exts.Heap.Closures,+        GHC.Exts.Heap.Constants,+        GHC.Exts.Heap.InfoTable,+        GHC.Exts.Heap.InfoTable.Types,+        GHC.Exts.Heap.InfoTableProf,+        GHC.Exts.Heap.Utils,+        GHC.ForeignSrcLang,+        GHC.ForeignSrcLang.Type,+        GHC.LanguageExtensions,+        GHC.LanguageExtensions.Type,+        GHC.Lexeme,+        GHC.PackageDb,+        GHC.Serialized,+        GHCi.BreakArray,+        GHCi.FFI,+        GHCi.Message,+        GHCi.RemoteTypes,+        GHCi.TH.Binary,+        GhcMonad,+        GhcPrelude,+        HaddockUtils,+        Hooks,+        HsBinds,+        HsDecls,+        HsDoc,+        HsExpr,+        HsExtension,+        HsImpExp,+        HsInstances,+        HsLit,+        HsPat,+        HsSyn,+        HsTypes,+        HsUtils,+        HscTypes,+        IOEnv,+        Id,+        IdInfo,+        IfaceSyn,+        IfaceType,+        InstEnv,+        InteractiveEvalTypes,+        Json,+        Kind,+        KnownUniques,+        Language.Haskell.TH,+        Language.Haskell.TH.LanguageExtensions,+        Language.Haskell.TH.Lib,+        Language.Haskell.TH.Lib.Internal,+        Language.Haskell.TH.Lib.Map,+        Language.Haskell.TH.Ppr,+        Language.Haskell.TH.PprLib,+        Language.Haskell.TH.Syntax,+        Lexeme,+        Lexer,+        LinkerTypes,+        ListSetOps,+        Literal,+        Maybes,+        MkCore,+        MkId,+        Module,+        MonadUtils,+        Name,+        NameCache,+        NameEnv,+        NameSet,+        OccName,+        OccurAnal,+        OptCoercion,+        OrdList,+        Outputable,+        PackageConfig,+        Packages,+        Pair,+        Panic,+        Parser,+        PatSyn,+        PipelineMonad,+        PlaceHolder,+        Platform,+        PlatformConstants,+        Plugins,+        PmExpr,+        PprColour,+        PprCore,+        PrelNames,+        PrelRules,+        Pretty,+        PrimOp,+        RdrHsSyn,+        RdrName,+        RepType,+        Rules,+        SizedSeq,+        SrcLoc,+        StringBuffer,+        SysTools.BaseDir,+        SysTools.Terminal,+        TcEvidence,+        TcRnTypes,+        TcType,+        ToIface,+        TrieMap,+        TyCoRep,+        TyCon,+        Type,+        TysPrim,+        TysWiredIn,+        Unify,+        UniqDFM,+        UniqDSet,+        UniqFM,+        UniqSet,+        UniqSupply,+        Unique,+        Util,+        Var,+        VarEnv,+        VarSet+    exposed-modules:+        Paths_ghc_lib+        Ar+        AsmCodeGen+        AsmUtils+        BinIface+        Bitmap+        BlockId+        BlockLayout+        BuildTyCl+        ByteCodeAsm+        ByteCodeGen+        ByteCodeInstr+        ByteCodeItbls+        ByteCodeLink+        CFG+        CLabel+        CPrim+        CSE+        CallArity+        CgUtils+        Check+        ClsInst+        Cmm+        CmmBuildInfoTables+        CmmCallConv+        CmmCommonBlockElim+        CmmContFlowOpt+        CmmExpr+        CmmImplementSwitchPlans+        CmmInfo+        CmmLayoutStack+        CmmLex+        CmmLint+        CmmLive+        CmmMachOp+        CmmMonad+        CmmNode+        CmmOpt+        CmmParse+        CmmPipeline+        CmmProcPoint+        CmmSink+        CmmSwitch+        CmmUtils+        CodeGen.Platform+        CodeGen.Platform.ARM+        CodeGen.Platform.ARM64+        CodeGen.Platform.NoRegs+        CodeGen.Platform.PPC+        CodeGen.Platform.SPARC+        CodeGen.Platform.X86+        CodeGen.Platform.X86_64+        CodeOutput+        Convert+        CoreLint+        CorePrep+        CoreToStg+        Coverage+        Debug+        Debugger+        Desugar+        DmdAnal+        DriverBkp+        DriverMkDepend+        DriverPipeline+        DsArrows+        DsBinds+        DsCCall+        DsExpr+        DsForeign+        DsGRHSs+        DsListComp+        DsMeta+        DsMonad+        DsUsage+        DsUtils+        Dwarf+        Dwarf.Constants+        Dwarf.Types+        DynamicLoading+        Elf+        Exitify+        ExtractDocs+        FamInst+        Finder+        FlagChecker+        FloatIn+        FloatOut+        Format+        FunDeps+        GHC+        GHC.HandleEncoding+        GHCi+        GHCi.BinaryArray+        GHCi.CreateBCO+        GHCi.InfoTable+        GHCi.ObjLink+        GHCi.ResolvedBCO+        GHCi.Run+        GHCi.Signals+        GHCi.StaticPtrTable+        GHCi.TH+        GhcMake+        GhcPlugins+        GraphBase+        GraphColor+        GraphOps+        GraphPpr+        HeaderInfo+        HieAst+        HieBin+        HieDebug+        HieTypes+        HieUtils+        Hoopl.Block+        Hoopl.Collections+        Hoopl.Dataflow+        Hoopl.Graph+        Hoopl.Label+        HsDumpAst+        HscMain+        HscStats+        IfaceEnv+        Inst+        Instruction+        InteractiveEval+        Language.Haskell.TH.Quote+        LiberateCase+        Linker+        ListT+        Llvm+        Llvm.AbsSyn+        Llvm.MetaData+        Llvm.PpLlvm+        Llvm.Types+        LlvmCodeGen+        LlvmCodeGen.Base+        LlvmCodeGen.CodeGen+        LlvmCodeGen.Data+        LlvmCodeGen.Ppr+        LlvmCodeGen.Regs+        LlvmMangler+        LoadIface+        Match+        MatchCon+        MatchLit+        MkGraph+        MkIface+        NCGMonad+        NameShape+        PIC+        PPC.CodeGen+        PPC.Cond+        PPC.Instr+        PPC.Ppr+        PPC.RegInfo+        PPC.Regs+        PprBase+        PprC+        PprCmm+        PprCmmDecl+        PprCmmExpr+        PprTyThing+        PrelInfo+        ProfInit+        Reg+        RegAlloc.Graph.ArchBase+        RegAlloc.Graph.ArchX86+        RegAlloc.Graph.Coalesce+        RegAlloc.Graph.Main+        RegAlloc.Graph.Spill+        RegAlloc.Graph.SpillClean+        RegAlloc.Graph.SpillCost+        RegAlloc.Graph.Stats+        RegAlloc.Graph.TrivColorable+        RegAlloc.Linear.Base+        RegAlloc.Linear.FreeRegs+        RegAlloc.Linear.JoinToTargets+        RegAlloc.Linear.Main+        RegAlloc.Linear.PPC.FreeRegs+        RegAlloc.Linear.SPARC.FreeRegs+        RegAlloc.Linear.StackMap+        RegAlloc.Linear.State+        RegAlloc.Linear.Stats+        RegAlloc.Linear.X86.FreeRegs+        RegAlloc.Linear.X86_64.FreeRegs+        RegAlloc.Liveness+        RegClass+        RnBinds+        RnEnv+        RnExpr+        RnFixity+        RnHsDoc+        RnModIface+        RnNames+        RnPat+        RnSource+        RnSplice+        RnTypes+        RnUnbound+        RnUtils+        RtClosureInspect+        SAT+        SMRep+        SPARC.AddrMode+        SPARC.Base+        SPARC.CodeGen+        SPARC.CodeGen.Amode+        SPARC.CodeGen.Base+        SPARC.CodeGen.CondCode+        SPARC.CodeGen.Expand+        SPARC.CodeGen.Gen32+        SPARC.CodeGen.Gen64+        SPARC.CodeGen.Sanity+        SPARC.Cond+        SPARC.Imm+        SPARC.Instr+        SPARC.Ppr+        SPARC.Regs+        SPARC.ShortcutJump+        SPARC.Stack+        SetLevels+        SimplCore+        SimplEnv+        SimplMonad+        SimplStg+        SimplUtils+        Simplify+        SpecConstr+        Specialise+        State+        StaticPtrTable+        StgCmm+        StgCmmArgRep+        StgCmmBind+        StgCmmClosure+        StgCmmCon+        StgCmmEnv+        StgCmmExpr+        StgCmmExtCode+        StgCmmForeign+        StgCmmHeap+        StgCmmHpc+        StgCmmLayout+        StgCmmMonad+        StgCmmPrim+        StgCmmProf+        StgCmmTicky+        StgCmmUtils+        StgCse+        StgFVs+        StgLiftLams+        StgLiftLams.Analysis+        StgLiftLams.LiftM+        StgLiftLams.Transformation+        StgLint+        StgStats+        StgSubst+        StgSyn+        Stream+        SysTools+        SysTools.ExtraObj+        SysTools.Info+        SysTools.Process+        SysTools.Tasks+        THNames+        TargetReg+        TcAnnotations+        TcArrows+        TcBackpack+        TcBinds+        TcCanonical+        TcClassDcl+        TcDefaults+        TcDeriv+        TcDerivInfer+        TcDerivUtils+        TcEnv+        TcErrors+        TcEvTerm+        TcExpr+        TcFlatten+        TcForeign+        TcGenDeriv+        TcGenFunctor+        TcGenGenerics+        TcHoleErrors+        TcHsSyn+        TcHsType+        TcIface+        TcInstDcls+        TcInteract+        TcMType+        TcMatches+        TcPat+        TcPatSyn+        TcPluginM+        TcRnDriver+        TcRnExports+        TcRnMonad+        TcRules+        TcSMonad+        TcSigs+        TcSimplify+        TcSplice+        TcTyClsDecls+        TcTyDecls+        TcTypeNats+        TcTypeable+        TcUnify+        TcValidity+        TidyPgm+        TmOracle+        UnVarGraph+        UnariseStg+        UniqMap+        WorkWrap+        WwLib+        X86.CodeGen+        X86.Cond+        X86.Instr+        X86.Ppr+        X86.RegInfo+        X86.Regs++executable ghc-lib+    default-language:   Haskell2010+    if !os(windows)+        build-depends: unix+    else+        build-depends: Win32+    build-depends:+        base == 4.*, array, bytestring, directory, process, filepath,+        containers, deepseq, ghc-prim, haskeline, time, transformers,+        ghc-lib+    hs-source-dirs: ghc+    ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS+    cc-options: -DTHREADED_RTS+    cpp-options: -DGHCI -DTHREADED_RTS -DGHC_LOADED_INTO_GHCI+    other-modules:+        GHCi.Leak+        GHCi.UI+        GHCi.UI.Info+        GHCi.UI.Monad+        GHCi.UI.Tags+        GHCi.Util+    other-extensions:+        BangPatterns+        CPP+        FlexibleInstances+        LambdaCase+        MagicHash+        MultiWayIf+        NondecreasingIndentation+        OverloadedStrings+        RankNTypes+        RecordWildCards+        ScopedTypeVariables+        TupleSections+        UnboxedTuples+        ViewPatterns+    default-extensions: NoImplicitPrelude+    main-is: Main.hs
+ ghc-lib/generated/DerivedConstants.h view
@@ -0,0 +1,554 @@+/* This file is created automatically.  Do not edit by hand.*/++#define CONTROL_GROUP_CONST_291 291+#define STD_HDR_SIZE 1+#define PROF_HDR_SIZE 2+#define BLOCK_SIZE 4096+#define MBLOCK_SIZE 1048576+#define BLOCKS_PER_MBLOCK 252+#define TICKY_BIN_COUNT 9+#define OFFSET_StgRegTable_rR1 0+#define OFFSET_StgRegTable_rR2 8+#define OFFSET_StgRegTable_rR3 16+#define OFFSET_StgRegTable_rR4 24+#define OFFSET_StgRegTable_rR5 32+#define OFFSET_StgRegTable_rR6 40+#define OFFSET_StgRegTable_rR7 48+#define OFFSET_StgRegTable_rR8 56+#define OFFSET_StgRegTable_rR9 64+#define OFFSET_StgRegTable_rR10 72+#define OFFSET_StgRegTable_rF1 80+#define OFFSET_StgRegTable_rF2 84+#define OFFSET_StgRegTable_rF3 88+#define OFFSET_StgRegTable_rF4 92+#define OFFSET_StgRegTable_rF5 96+#define OFFSET_StgRegTable_rF6 100+#define OFFSET_StgRegTable_rD1 104+#define OFFSET_StgRegTable_rD2 112+#define OFFSET_StgRegTable_rD3 120+#define OFFSET_StgRegTable_rD4 128+#define OFFSET_StgRegTable_rD5 136+#define OFFSET_StgRegTable_rD6 144+#define OFFSET_StgRegTable_rXMM1 152+#define OFFSET_StgRegTable_rXMM2 168+#define OFFSET_StgRegTable_rXMM3 184+#define OFFSET_StgRegTable_rXMM4 200+#define OFFSET_StgRegTable_rXMM5 216+#define OFFSET_StgRegTable_rXMM6 232+#define OFFSET_StgRegTable_rYMM1 248+#define OFFSET_StgRegTable_rYMM2 280+#define OFFSET_StgRegTable_rYMM3 312+#define OFFSET_StgRegTable_rYMM4 344+#define OFFSET_StgRegTable_rYMM5 376+#define OFFSET_StgRegTable_rYMM6 408+#define OFFSET_StgRegTable_rZMM1 440+#define OFFSET_StgRegTable_rZMM2 504+#define OFFSET_StgRegTable_rZMM3 568+#define OFFSET_StgRegTable_rZMM4 632+#define OFFSET_StgRegTable_rZMM5 696+#define OFFSET_StgRegTable_rZMM6 760+#define OFFSET_StgRegTable_rL1 824+#define OFFSET_StgRegTable_rSp 832+#define OFFSET_StgRegTable_rSpLim 840+#define OFFSET_StgRegTable_rHp 848+#define OFFSET_StgRegTable_rHpLim 856+#define OFFSET_StgRegTable_rCCCS 864+#define OFFSET_StgRegTable_rCurrentTSO 872+#define OFFSET_StgRegTable_rCurrentNursery 888+#define OFFSET_StgRegTable_rHpAlloc 904+#define OFFSET_StgRegTable_rRet 912+#define REP_StgRegTable_rRet b64+#define StgRegTable_rRet(__ptr__) REP_StgRegTable_rRet[__ptr__+OFFSET_StgRegTable_rRet]+#define OFFSET_StgRegTable_rNursery 880+#define REP_StgRegTable_rNursery b64+#define StgRegTable_rNursery(__ptr__) REP_StgRegTable_rNursery[__ptr__+OFFSET_StgRegTable_rNursery]+#define OFFSET_stgEagerBlackholeInfo -24+#define OFFSET_stgGCEnter1 -16+#define OFFSET_stgGCFun -8+#define OFFSET_Capability_r 24+#define OFFSET_Capability_lock 1096+#define OFFSET_Capability_no 944+#define REP_Capability_no b32+#define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no]+#define OFFSET_Capability_mut_lists 1016+#define REP_Capability_mut_lists b64+#define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists]+#define OFFSET_Capability_context_switch 1064+#define REP_Capability_context_switch b32+#define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch]+#define OFFSET_Capability_interrupt 1068+#define REP_Capability_interrupt b32+#define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt]+#define OFFSET_Capability_sparks 1200+#define REP_Capability_sparks b64+#define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks]+#define OFFSET_Capability_total_allocated 1072+#define REP_Capability_total_allocated b64+#define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated]+#define OFFSET_Capability_weak_ptr_list_hd 1048+#define REP_Capability_weak_ptr_list_hd b64+#define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd]+#define OFFSET_Capability_weak_ptr_list_tl 1056+#define REP_Capability_weak_ptr_list_tl b64+#define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl]+#define OFFSET_bdescr_start 0+#define REP_bdescr_start b64+#define bdescr_start(__ptr__) REP_bdescr_start[__ptr__+OFFSET_bdescr_start]+#define OFFSET_bdescr_free 8+#define REP_bdescr_free b64+#define bdescr_free(__ptr__) REP_bdescr_free[__ptr__+OFFSET_bdescr_free]+#define OFFSET_bdescr_blocks 48+#define REP_bdescr_blocks b32+#define bdescr_blocks(__ptr__) REP_bdescr_blocks[__ptr__+OFFSET_bdescr_blocks]+#define OFFSET_bdescr_gen_no 40+#define REP_bdescr_gen_no b16+#define bdescr_gen_no(__ptr__) REP_bdescr_gen_no[__ptr__+OFFSET_bdescr_gen_no]+#define OFFSET_bdescr_link 16+#define REP_bdescr_link b64+#define bdescr_link(__ptr__) REP_bdescr_link[__ptr__+OFFSET_bdescr_link]+#define OFFSET_bdescr_flags 46+#define REP_bdescr_flags b16+#define bdescr_flags(__ptr__) REP_bdescr_flags[__ptr__+OFFSET_bdescr_flags]+#define SIZEOF_generation 384+#define OFFSET_generation_n_new_large_words 56+#define REP_generation_n_new_large_words b64+#define generation_n_new_large_words(__ptr__) REP_generation_n_new_large_words[__ptr__+OFFSET_generation_n_new_large_words]+#define OFFSET_generation_weak_ptr_list 112+#define REP_generation_weak_ptr_list b64+#define generation_weak_ptr_list(__ptr__) REP_generation_weak_ptr_list[__ptr__+OFFSET_generation_weak_ptr_list]+#define SIZEOF_CostCentreStack 96+#define OFFSET_CostCentreStack_ccsID 0+#define REP_CostCentreStack_ccsID b64+#define CostCentreStack_ccsID(__ptr__) REP_CostCentreStack_ccsID[__ptr__+OFFSET_CostCentreStack_ccsID]+#define OFFSET_CostCentreStack_mem_alloc 72+#define REP_CostCentreStack_mem_alloc b64+#define CostCentreStack_mem_alloc(__ptr__) REP_CostCentreStack_mem_alloc[__ptr__+OFFSET_CostCentreStack_mem_alloc]+#define OFFSET_CostCentreStack_scc_count 48+#define REP_CostCentreStack_scc_count b64+#define CostCentreStack_scc_count(__ptr__) REP_CostCentreStack_scc_count[__ptr__+OFFSET_CostCentreStack_scc_count]+#define OFFSET_CostCentreStack_prevStack 16+#define REP_CostCentreStack_prevStack b64+#define CostCentreStack_prevStack(__ptr__) REP_CostCentreStack_prevStack[__ptr__+OFFSET_CostCentreStack_prevStack]+#define OFFSET_CostCentre_ccID 0+#define REP_CostCentre_ccID b64+#define CostCentre_ccID(__ptr__) REP_CostCentre_ccID[__ptr__+OFFSET_CostCentre_ccID]+#define OFFSET_CostCentre_link 56+#define REP_CostCentre_link b64+#define CostCentre_link(__ptr__) REP_CostCentre_link[__ptr__+OFFSET_CostCentre_link]+#define OFFSET_StgHeader_info 0+#define REP_StgHeader_info b64+#define StgHeader_info(__ptr__) REP_StgHeader_info[__ptr__+OFFSET_StgHeader_info]+#define OFFSET_StgHeader_ccs 8+#define REP_StgHeader_ccs b64+#define StgHeader_ccs(__ptr__) REP_StgHeader_ccs[__ptr__+OFFSET_StgHeader_ccs]+#define OFFSET_StgHeader_ldvw 16+#define REP_StgHeader_ldvw b64+#define StgHeader_ldvw(__ptr__) REP_StgHeader_ldvw[__ptr__+OFFSET_StgHeader_ldvw]+#define SIZEOF_StgSMPThunkHeader 8+#define OFFSET_StgClosure_payload 0+#define StgClosure_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgClosure_payload + WDS(__ix__)]+#define OFFSET_StgEntCounter_allocs 48+#define REP_StgEntCounter_allocs b64+#define StgEntCounter_allocs(__ptr__) REP_StgEntCounter_allocs[__ptr__+OFFSET_StgEntCounter_allocs]+#define OFFSET_StgEntCounter_allocd 16+#define REP_StgEntCounter_allocd b64+#define StgEntCounter_allocd(__ptr__) REP_StgEntCounter_allocd[__ptr__+OFFSET_StgEntCounter_allocd]+#define OFFSET_StgEntCounter_registeredp 0+#define REP_StgEntCounter_registeredp b64+#define StgEntCounter_registeredp(__ptr__) REP_StgEntCounter_registeredp[__ptr__+OFFSET_StgEntCounter_registeredp]+#define OFFSET_StgEntCounter_link 56+#define REP_StgEntCounter_link b64+#define StgEntCounter_link(__ptr__) REP_StgEntCounter_link[__ptr__+OFFSET_StgEntCounter_link]+#define OFFSET_StgEntCounter_entry_count 40+#define REP_StgEntCounter_entry_count b64+#define StgEntCounter_entry_count(__ptr__) REP_StgEntCounter_entry_count[__ptr__+OFFSET_StgEntCounter_entry_count]+#define SIZEOF_StgUpdateFrame_NoHdr 8+#define SIZEOF_StgUpdateFrame (SIZEOF_StgHeader+8)+#define SIZEOF_StgCatchFrame_NoHdr 16+#define SIZEOF_StgCatchFrame (SIZEOF_StgHeader+16)+#define SIZEOF_StgStopFrame_NoHdr 0+#define SIZEOF_StgStopFrame (SIZEOF_StgHeader+0)+#define SIZEOF_StgMutArrPtrs_NoHdr 16+#define SIZEOF_StgMutArrPtrs (SIZEOF_StgHeader+16)+#define OFFSET_StgMutArrPtrs_ptrs 0+#define REP_StgMutArrPtrs_ptrs b64+#define StgMutArrPtrs_ptrs(__ptr__) REP_StgMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_ptrs]+#define OFFSET_StgMutArrPtrs_size 8+#define REP_StgMutArrPtrs_size b64+#define StgMutArrPtrs_size(__ptr__) REP_StgMutArrPtrs_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutArrPtrs_size]+#define SIZEOF_StgSmallMutArrPtrs_NoHdr 8+#define SIZEOF_StgSmallMutArrPtrs (SIZEOF_StgHeader+8)+#define OFFSET_StgSmallMutArrPtrs_ptrs 0+#define REP_StgSmallMutArrPtrs_ptrs b64+#define StgSmallMutArrPtrs_ptrs(__ptr__) REP_StgSmallMutArrPtrs_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgSmallMutArrPtrs_ptrs]+#define SIZEOF_StgArrBytes_NoHdr 8+#define SIZEOF_StgArrBytes (SIZEOF_StgHeader+8)+#define OFFSET_StgArrBytes_bytes 0+#define REP_StgArrBytes_bytes b64+#define StgArrBytes_bytes(__ptr__) REP_StgArrBytes_bytes[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_bytes]+#define OFFSET_StgArrBytes_payload 8+#define StgArrBytes_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgArrBytes_payload + WDS(__ix__)]+#define OFFSET_StgTSO__link 0+#define REP_StgTSO__link b64+#define StgTSO__link(__ptr__) REP_StgTSO__link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO__link]+#define OFFSET_StgTSO_global_link 8+#define REP_StgTSO_global_link b64+#define StgTSO_global_link(__ptr__) REP_StgTSO_global_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_global_link]+#define OFFSET_StgTSO_what_next 24+#define REP_StgTSO_what_next b16+#define StgTSO_what_next(__ptr__) REP_StgTSO_what_next[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_what_next]+#define OFFSET_StgTSO_why_blocked 26+#define REP_StgTSO_why_blocked b16+#define StgTSO_why_blocked(__ptr__) REP_StgTSO_why_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_why_blocked]+#define OFFSET_StgTSO_block_info 32+#define REP_StgTSO_block_info b64+#define StgTSO_block_info(__ptr__) REP_StgTSO_block_info[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_block_info]+#define OFFSET_StgTSO_blocked_exceptions 80+#define REP_StgTSO_blocked_exceptions b64+#define StgTSO_blocked_exceptions(__ptr__) REP_StgTSO_blocked_exceptions[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_blocked_exceptions]+#define OFFSET_StgTSO_id 40+#define REP_StgTSO_id b32+#define StgTSO_id(__ptr__) REP_StgTSO_id[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_id]+#define OFFSET_StgTSO_cap 64+#define REP_StgTSO_cap b64+#define StgTSO_cap(__ptr__) REP_StgTSO_cap[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cap]+#define OFFSET_StgTSO_saved_errno 44+#define REP_StgTSO_saved_errno b32+#define StgTSO_saved_errno(__ptr__) REP_StgTSO_saved_errno[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_saved_errno]+#define OFFSET_StgTSO_trec 72+#define REP_StgTSO_trec b64+#define StgTSO_trec(__ptr__) REP_StgTSO_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_trec]+#define OFFSET_StgTSO_flags 28+#define REP_StgTSO_flags b32+#define StgTSO_flags(__ptr__) REP_StgTSO_flags[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_flags]+#define OFFSET_StgTSO_dirty 48+#define REP_StgTSO_dirty b32+#define StgTSO_dirty(__ptr__) REP_StgTSO_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_dirty]+#define OFFSET_StgTSO_bq 88+#define REP_StgTSO_bq b64+#define StgTSO_bq(__ptr__) REP_StgTSO_bq[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_bq]+#define OFFSET_StgTSO_alloc_limit 96+#define REP_StgTSO_alloc_limit b64+#define StgTSO_alloc_limit(__ptr__) REP_StgTSO_alloc_limit[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_alloc_limit]+#define OFFSET_StgTSO_cccs 112+#define REP_StgTSO_cccs b64+#define StgTSO_cccs(__ptr__) REP_StgTSO_cccs[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cccs]+#define OFFSET_StgTSO_stackobj 16+#define REP_StgTSO_stackobj b64+#define StgTSO_stackobj(__ptr__) REP_StgTSO_stackobj[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_stackobj]+#define OFFSET_StgStack_sp 8+#define REP_StgStack_sp b64+#define StgStack_sp(__ptr__) REP_StgStack_sp[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_sp]+#define OFFSET_StgStack_stack 16+#define OFFSET_StgStack_stack_size 0+#define REP_StgStack_stack_size b32+#define StgStack_stack_size(__ptr__) REP_StgStack_stack_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_stack_size]+#define OFFSET_StgStack_dirty 4+#define REP_StgStack_dirty b32+#define StgStack_dirty(__ptr__) REP_StgStack_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_dirty]+#define SIZEOF_StgTSOProfInfo 8+#define OFFSET_StgUpdateFrame_updatee 0+#define REP_StgUpdateFrame_updatee b64+#define StgUpdateFrame_updatee(__ptr__) REP_StgUpdateFrame_updatee[__ptr__+SIZEOF_StgHeader+OFFSET_StgUpdateFrame_updatee]+#define OFFSET_StgCatchFrame_handler 8+#define REP_StgCatchFrame_handler b64+#define StgCatchFrame_handler(__ptr__) REP_StgCatchFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_handler]+#define OFFSET_StgCatchFrame_exceptions_blocked 0+#define REP_StgCatchFrame_exceptions_blocked b64+#define StgCatchFrame_exceptions_blocked(__ptr__) REP_StgCatchFrame_exceptions_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_exceptions_blocked]+#define SIZEOF_StgPAP_NoHdr 16+#define SIZEOF_StgPAP (SIZEOF_StgHeader+16)+#define OFFSET_StgPAP_n_args 4+#define REP_StgPAP_n_args b32+#define StgPAP_n_args(__ptr__) REP_StgPAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_n_args]+#define OFFSET_StgPAP_fun 8+#define REP_StgPAP_fun gcptr+#define StgPAP_fun(__ptr__) REP_StgPAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_fun]+#define OFFSET_StgPAP_arity 0+#define REP_StgPAP_arity b32+#define StgPAP_arity(__ptr__) REP_StgPAP_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_arity]+#define OFFSET_StgPAP_payload 16+#define StgPAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgPAP_payload + WDS(__ix__)]+#define SIZEOF_StgAP_NoThunkHdr 16+#define SIZEOF_StgAP_NoHdr 24+#define SIZEOF_StgAP (SIZEOF_StgHeader+24)+#define OFFSET_StgAP_n_args 12+#define REP_StgAP_n_args b32+#define StgAP_n_args(__ptr__) REP_StgAP_n_args[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_n_args]+#define OFFSET_StgAP_fun 16+#define REP_StgAP_fun gcptr+#define StgAP_fun(__ptr__) REP_StgAP_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_fun]+#define OFFSET_StgAP_payload 24+#define StgAP_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_payload + WDS(__ix__)]+#define SIZEOF_StgAP_STACK_NoThunkHdr 16+#define SIZEOF_StgAP_STACK_NoHdr 24+#define SIZEOF_StgAP_STACK (SIZEOF_StgHeader+24)+#define OFFSET_StgAP_STACK_size 8+#define REP_StgAP_STACK_size b64+#define StgAP_STACK_size(__ptr__) REP_StgAP_STACK_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_size]+#define OFFSET_StgAP_STACK_fun 16+#define REP_StgAP_STACK_fun gcptr+#define StgAP_STACK_fun(__ptr__) REP_StgAP_STACK_fun[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_fun]+#define OFFSET_StgAP_STACK_payload 24+#define StgAP_STACK_payload(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgAP_STACK_payload + WDS(__ix__)]+#define SIZEOF_StgSelector_NoThunkHdr 8+#define SIZEOF_StgSelector_NoHdr 16+#define SIZEOF_StgSelector (SIZEOF_StgHeader+16)+#define OFFSET_StgInd_indirectee 0+#define REP_StgInd_indirectee gcptr+#define StgInd_indirectee(__ptr__) REP_StgInd_indirectee[__ptr__+SIZEOF_StgHeader+OFFSET_StgInd_indirectee]+#define SIZEOF_StgMutVar_NoHdr 8+#define SIZEOF_StgMutVar (SIZEOF_StgHeader+8)+#define OFFSET_StgMutVar_var 0+#define REP_StgMutVar_var b64+#define StgMutVar_var(__ptr__) REP_StgMutVar_var[__ptr__+SIZEOF_StgHeader+OFFSET_StgMutVar_var]+#define SIZEOF_StgAtomicallyFrame_NoHdr 16+#define SIZEOF_StgAtomicallyFrame (SIZEOF_StgHeader+16)+#define OFFSET_StgAtomicallyFrame_code 0+#define REP_StgAtomicallyFrame_code b64+#define StgAtomicallyFrame_code(__ptr__) REP_StgAtomicallyFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_code]+#define OFFSET_StgAtomicallyFrame_result 8+#define REP_StgAtomicallyFrame_result b64+#define StgAtomicallyFrame_result(__ptr__) REP_StgAtomicallyFrame_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgAtomicallyFrame_result]+#define OFFSET_StgTRecHeader_enclosing_trec 0+#define REP_StgTRecHeader_enclosing_trec b64+#define StgTRecHeader_enclosing_trec(__ptr__) REP_StgTRecHeader_enclosing_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTRecHeader_enclosing_trec]+#define SIZEOF_StgCatchSTMFrame_NoHdr 16+#define SIZEOF_StgCatchSTMFrame (SIZEOF_StgHeader+16)+#define OFFSET_StgCatchSTMFrame_handler 8+#define REP_StgCatchSTMFrame_handler b64+#define StgCatchSTMFrame_handler(__ptr__) REP_StgCatchSTMFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_handler]+#define OFFSET_StgCatchSTMFrame_code 0+#define REP_StgCatchSTMFrame_code b64+#define StgCatchSTMFrame_code(__ptr__) REP_StgCatchSTMFrame_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchSTMFrame_code]+#define SIZEOF_StgCatchRetryFrame_NoHdr 24+#define SIZEOF_StgCatchRetryFrame (SIZEOF_StgHeader+24)+#define OFFSET_StgCatchRetryFrame_running_alt_code 0+#define REP_StgCatchRetryFrame_running_alt_code b64+#define StgCatchRetryFrame_running_alt_code(__ptr__) REP_StgCatchRetryFrame_running_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_running_alt_code]+#define OFFSET_StgCatchRetryFrame_first_code 8+#define REP_StgCatchRetryFrame_first_code b64+#define StgCatchRetryFrame_first_code(__ptr__) REP_StgCatchRetryFrame_first_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_first_code]+#define OFFSET_StgCatchRetryFrame_alt_code 16+#define REP_StgCatchRetryFrame_alt_code b64+#define StgCatchRetryFrame_alt_code(__ptr__) REP_StgCatchRetryFrame_alt_code[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchRetryFrame_alt_code]+#define OFFSET_StgTVarWatchQueue_closure 0+#define REP_StgTVarWatchQueue_closure b64+#define StgTVarWatchQueue_closure(__ptr__) REP_StgTVarWatchQueue_closure[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_closure]+#define OFFSET_StgTVarWatchQueue_next_queue_entry 8+#define REP_StgTVarWatchQueue_next_queue_entry b64+#define StgTVarWatchQueue_next_queue_entry(__ptr__) REP_StgTVarWatchQueue_next_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_next_queue_entry]+#define OFFSET_StgTVarWatchQueue_prev_queue_entry 16+#define REP_StgTVarWatchQueue_prev_queue_entry b64+#define StgTVarWatchQueue_prev_queue_entry(__ptr__) REP_StgTVarWatchQueue_prev_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVarWatchQueue_prev_queue_entry]+#define SIZEOF_StgTVar_NoHdr 24+#define SIZEOF_StgTVar (SIZEOF_StgHeader+24)+#define OFFSET_StgTVar_current_value 0+#define REP_StgTVar_current_value b64+#define StgTVar_current_value(__ptr__) REP_StgTVar_current_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_current_value]+#define OFFSET_StgTVar_first_watch_queue_entry 8+#define REP_StgTVar_first_watch_queue_entry b64+#define StgTVar_first_watch_queue_entry(__ptr__) REP_StgTVar_first_watch_queue_entry[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_first_watch_queue_entry]+#define OFFSET_StgTVar_num_updates 16+#define REP_StgTVar_num_updates b64+#define StgTVar_num_updates(__ptr__) REP_StgTVar_num_updates[__ptr__+SIZEOF_StgHeader+OFFSET_StgTVar_num_updates]+#define SIZEOF_StgWeak_NoHdr 40+#define SIZEOF_StgWeak (SIZEOF_StgHeader+40)+#define OFFSET_StgWeak_link 32+#define REP_StgWeak_link b64+#define StgWeak_link(__ptr__) REP_StgWeak_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_link]+#define OFFSET_StgWeak_key 8+#define REP_StgWeak_key b64+#define StgWeak_key(__ptr__) REP_StgWeak_key[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_key]+#define OFFSET_StgWeak_value 16+#define REP_StgWeak_value b64+#define StgWeak_value(__ptr__) REP_StgWeak_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_value]+#define OFFSET_StgWeak_finalizer 24+#define REP_StgWeak_finalizer b64+#define StgWeak_finalizer(__ptr__) REP_StgWeak_finalizer[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_finalizer]+#define OFFSET_StgWeak_cfinalizers 0+#define REP_StgWeak_cfinalizers b64+#define StgWeak_cfinalizers(__ptr__) REP_StgWeak_cfinalizers[__ptr__+SIZEOF_StgHeader+OFFSET_StgWeak_cfinalizers]+#define SIZEOF_StgCFinalizerList_NoHdr 40+#define SIZEOF_StgCFinalizerList (SIZEOF_StgHeader+40)+#define OFFSET_StgCFinalizerList_link 0+#define REP_StgCFinalizerList_link b64+#define StgCFinalizerList_link(__ptr__) REP_StgCFinalizerList_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_link]+#define OFFSET_StgCFinalizerList_fptr 8+#define REP_StgCFinalizerList_fptr b64+#define StgCFinalizerList_fptr(__ptr__) REP_StgCFinalizerList_fptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_fptr]+#define OFFSET_StgCFinalizerList_ptr 16+#define REP_StgCFinalizerList_ptr b64+#define StgCFinalizerList_ptr(__ptr__) REP_StgCFinalizerList_ptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_ptr]+#define OFFSET_StgCFinalizerList_eptr 24+#define REP_StgCFinalizerList_eptr b64+#define StgCFinalizerList_eptr(__ptr__) REP_StgCFinalizerList_eptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_eptr]+#define OFFSET_StgCFinalizerList_flag 32+#define REP_StgCFinalizerList_flag b64+#define StgCFinalizerList_flag(__ptr__) REP_StgCFinalizerList_flag[__ptr__+SIZEOF_StgHeader+OFFSET_StgCFinalizerList_flag]+#define SIZEOF_StgMVar_NoHdr 24+#define SIZEOF_StgMVar (SIZEOF_StgHeader+24)+#define OFFSET_StgMVar_head 0+#define REP_StgMVar_head b64+#define StgMVar_head(__ptr__) REP_StgMVar_head[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_head]+#define OFFSET_StgMVar_tail 8+#define REP_StgMVar_tail b64+#define StgMVar_tail(__ptr__) REP_StgMVar_tail[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_tail]+#define OFFSET_StgMVar_value 16+#define REP_StgMVar_value b64+#define StgMVar_value(__ptr__) REP_StgMVar_value[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVar_value]+#define SIZEOF_StgMVarTSOQueue_NoHdr 16+#define SIZEOF_StgMVarTSOQueue (SIZEOF_StgHeader+16)+#define OFFSET_StgMVarTSOQueue_link 0+#define REP_StgMVarTSOQueue_link b64+#define StgMVarTSOQueue_link(__ptr__) REP_StgMVarTSOQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_link]+#define OFFSET_StgMVarTSOQueue_tso 8+#define REP_StgMVarTSOQueue_tso b64+#define StgMVarTSOQueue_tso(__ptr__) REP_StgMVarTSOQueue_tso[__ptr__+SIZEOF_StgHeader+OFFSET_StgMVarTSOQueue_tso]+#define SIZEOF_StgBCO_NoHdr 32+#define SIZEOF_StgBCO (SIZEOF_StgHeader+32)+#define OFFSET_StgBCO_instrs 0+#define REP_StgBCO_instrs b64+#define StgBCO_instrs(__ptr__) REP_StgBCO_instrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_instrs]+#define OFFSET_StgBCO_literals 8+#define REP_StgBCO_literals b64+#define StgBCO_literals(__ptr__) REP_StgBCO_literals[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_literals]+#define OFFSET_StgBCO_ptrs 16+#define REP_StgBCO_ptrs b64+#define StgBCO_ptrs(__ptr__) REP_StgBCO_ptrs[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_ptrs]+#define OFFSET_StgBCO_arity 24+#define REP_StgBCO_arity b32+#define StgBCO_arity(__ptr__) REP_StgBCO_arity[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_arity]+#define OFFSET_StgBCO_size 28+#define REP_StgBCO_size b32+#define StgBCO_size(__ptr__) REP_StgBCO_size[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_size]+#define OFFSET_StgBCO_bitmap 32+#define StgBCO_bitmap(__ptr__,__ix__) W_[__ptr__+SIZEOF_StgHeader+OFFSET_StgBCO_bitmap + WDS(__ix__)]+#define SIZEOF_StgStableName_NoHdr 8+#define SIZEOF_StgStableName (SIZEOF_StgHeader+8)+#define OFFSET_StgStableName_sn 0+#define REP_StgStableName_sn b64+#define StgStableName_sn(__ptr__) REP_StgStableName_sn[__ptr__+SIZEOF_StgHeader+OFFSET_StgStableName_sn]+#define SIZEOF_StgBlockingQueue_NoHdr 32+#define SIZEOF_StgBlockingQueue (SIZEOF_StgHeader+32)+#define OFFSET_StgBlockingQueue_bh 8+#define REP_StgBlockingQueue_bh b64+#define StgBlockingQueue_bh(__ptr__) REP_StgBlockingQueue_bh[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_bh]+#define OFFSET_StgBlockingQueue_owner 16+#define REP_StgBlockingQueue_owner b64+#define StgBlockingQueue_owner(__ptr__) REP_StgBlockingQueue_owner[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_owner]+#define OFFSET_StgBlockingQueue_queue 24+#define REP_StgBlockingQueue_queue b64+#define StgBlockingQueue_queue(__ptr__) REP_StgBlockingQueue_queue[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_queue]+#define OFFSET_StgBlockingQueue_link 0+#define REP_StgBlockingQueue_link b64+#define StgBlockingQueue_link(__ptr__) REP_StgBlockingQueue_link[__ptr__+SIZEOF_StgHeader+OFFSET_StgBlockingQueue_link]+#define SIZEOF_MessageBlackHole_NoHdr 24+#define SIZEOF_MessageBlackHole (SIZEOF_StgHeader+24)+#define OFFSET_MessageBlackHole_link 0+#define REP_MessageBlackHole_link b64+#define MessageBlackHole_link(__ptr__) REP_MessageBlackHole_link[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_link]+#define OFFSET_MessageBlackHole_tso 8+#define REP_MessageBlackHole_tso b64+#define MessageBlackHole_tso(__ptr__) REP_MessageBlackHole_tso[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_tso]+#define OFFSET_MessageBlackHole_bh 16+#define REP_MessageBlackHole_bh b64+#define MessageBlackHole_bh(__ptr__) REP_MessageBlackHole_bh[__ptr__+SIZEOF_StgHeader+OFFSET_MessageBlackHole_bh]+#define SIZEOF_StgCompactNFData_NoHdr 64+#define SIZEOF_StgCompactNFData (SIZEOF_StgHeader+64)+#define OFFSET_StgCompactNFData_totalW 0+#define REP_StgCompactNFData_totalW b64+#define StgCompactNFData_totalW(__ptr__) REP_StgCompactNFData_totalW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_totalW]+#define OFFSET_StgCompactNFData_autoBlockW 8+#define REP_StgCompactNFData_autoBlockW b64+#define StgCompactNFData_autoBlockW(__ptr__) REP_StgCompactNFData_autoBlockW[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_autoBlockW]+#define OFFSET_StgCompactNFData_nursery 32+#define REP_StgCompactNFData_nursery b64+#define StgCompactNFData_nursery(__ptr__) REP_StgCompactNFData_nursery[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_nursery]+#define OFFSET_StgCompactNFData_last 40+#define REP_StgCompactNFData_last b64+#define StgCompactNFData_last(__ptr__) REP_StgCompactNFData_last[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_last]+#define OFFSET_StgCompactNFData_hp 16+#define REP_StgCompactNFData_hp b64+#define StgCompactNFData_hp(__ptr__) REP_StgCompactNFData_hp[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hp]+#define OFFSET_StgCompactNFData_hpLim 24+#define REP_StgCompactNFData_hpLim b64+#define StgCompactNFData_hpLim(__ptr__) REP_StgCompactNFData_hpLim[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hpLim]+#define OFFSET_StgCompactNFData_hash 48+#define REP_StgCompactNFData_hash b64+#define StgCompactNFData_hash(__ptr__) REP_StgCompactNFData_hash[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_hash]+#define OFFSET_StgCompactNFData_result 56+#define REP_StgCompactNFData_result b64+#define StgCompactNFData_result(__ptr__) REP_StgCompactNFData_result[__ptr__+SIZEOF_StgHeader+OFFSET_StgCompactNFData_result]+#define SIZEOF_StgCompactNFDataBlock 24+#define OFFSET_StgCompactNFDataBlock_self 0+#define REP_StgCompactNFDataBlock_self b64+#define StgCompactNFDataBlock_self(__ptr__) REP_StgCompactNFDataBlock_self[__ptr__+OFFSET_StgCompactNFDataBlock_self]+#define OFFSET_StgCompactNFDataBlock_owner 8+#define REP_StgCompactNFDataBlock_owner b64+#define StgCompactNFDataBlock_owner(__ptr__) REP_StgCompactNFDataBlock_owner[__ptr__+OFFSET_StgCompactNFDataBlock_owner]+#define OFFSET_StgCompactNFDataBlock_next 16+#define REP_StgCompactNFDataBlock_next b64+#define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]+#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 269+#define REP_RtsFlags_ProfFlags_showCCSOnException b8+#define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException]+#define OFFSET_RtsFlags_DebugFlags_apply 210+#define REP_RtsFlags_DebugFlags_apply b8+#define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]+#define OFFSET_RtsFlags_DebugFlags_sanity 206+#define REP_RtsFlags_DebugFlags_sanity b8+#define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]+#define OFFSET_RtsFlags_DebugFlags_weak 202+#define REP_RtsFlags_DebugFlags_weak b8+#define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak]+#define OFFSET_RtsFlags_GcFlags_initialStkSize 16+#define REP_RtsFlags_GcFlags_initialStkSize b32+#define RtsFlags_GcFlags_initialStkSize(__ptr__) REP_RtsFlags_GcFlags_initialStkSize[__ptr__+OFFSET_RtsFlags_GcFlags_initialStkSize]+#define OFFSET_RtsFlags_MiscFlags_tickInterval 176+#define REP_RtsFlags_MiscFlags_tickInterval b64+#define RtsFlags_MiscFlags_tickInterval(__ptr__) REP_RtsFlags_MiscFlags_tickInterval[__ptr__+OFFSET_RtsFlags_MiscFlags_tickInterval]+#define SIZEOF_StgFunInfoExtraFwd 32+#define OFFSET_StgFunInfoExtraFwd_slow_apply 24+#define REP_StgFunInfoExtraFwd_slow_apply b64+#define StgFunInfoExtraFwd_slow_apply(__ptr__) REP_StgFunInfoExtraFwd_slow_apply[__ptr__+OFFSET_StgFunInfoExtraFwd_slow_apply]+#define OFFSET_StgFunInfoExtraFwd_fun_type 0+#define REP_StgFunInfoExtraFwd_fun_type b32+#define StgFunInfoExtraFwd_fun_type(__ptr__) REP_StgFunInfoExtraFwd_fun_type[__ptr__+OFFSET_StgFunInfoExtraFwd_fun_type]+#define OFFSET_StgFunInfoExtraFwd_arity 4+#define REP_StgFunInfoExtraFwd_arity b32+#define StgFunInfoExtraFwd_arity(__ptr__) REP_StgFunInfoExtraFwd_arity[__ptr__+OFFSET_StgFunInfoExtraFwd_arity]+#define OFFSET_StgFunInfoExtraFwd_bitmap 16+#define REP_StgFunInfoExtraFwd_bitmap b64+#define StgFunInfoExtraFwd_bitmap(__ptr__) REP_StgFunInfoExtraFwd_bitmap[__ptr__+OFFSET_StgFunInfoExtraFwd_bitmap]+#define SIZEOF_StgFunInfoExtraRev 24+#define OFFSET_StgFunInfoExtraRev_slow_apply_offset 0+#define REP_StgFunInfoExtraRev_slow_apply_offset b32+#define StgFunInfoExtraRev_slow_apply_offset(__ptr__) REP_StgFunInfoExtraRev_slow_apply_offset[__ptr__+OFFSET_StgFunInfoExtraRev_slow_apply_offset]+#define OFFSET_StgFunInfoExtraRev_fun_type 16+#define REP_StgFunInfoExtraRev_fun_type b32+#define StgFunInfoExtraRev_fun_type(__ptr__) REP_StgFunInfoExtraRev_fun_type[__ptr__+OFFSET_StgFunInfoExtraRev_fun_type]+#define OFFSET_StgFunInfoExtraRev_arity 20+#define REP_StgFunInfoExtraRev_arity b32+#define StgFunInfoExtraRev_arity(__ptr__) REP_StgFunInfoExtraRev_arity[__ptr__+OFFSET_StgFunInfoExtraRev_arity]+#define OFFSET_StgFunInfoExtraRev_bitmap 8+#define REP_StgFunInfoExtraRev_bitmap b64+#define StgFunInfoExtraRev_bitmap(__ptr__) REP_StgFunInfoExtraRev_bitmap[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap]+#define OFFSET_StgFunInfoExtraRev_bitmap_offset 8+#define REP_StgFunInfoExtraRev_bitmap_offset b32+#define StgFunInfoExtraRev_bitmap_offset(__ptr__) REP_StgFunInfoExtraRev_bitmap_offset[__ptr__+OFFSET_StgFunInfoExtraRev_bitmap_offset]+#define OFFSET_StgLargeBitmap_size 0+#define REP_StgLargeBitmap_size b64+#define StgLargeBitmap_size(__ptr__) REP_StgLargeBitmap_size[__ptr__+OFFSET_StgLargeBitmap_size]+#define OFFSET_StgLargeBitmap_bitmap 8+#define SIZEOF_snEntry 24+#define OFFSET_snEntry_sn_obj 16+#define REP_snEntry_sn_obj b64+#define snEntry_sn_obj(__ptr__) REP_snEntry_sn_obj[__ptr__+OFFSET_snEntry_sn_obj]+#define OFFSET_snEntry_addr 0+#define REP_snEntry_addr b64+#define snEntry_addr(__ptr__) REP_snEntry_addr[__ptr__+OFFSET_snEntry_addr]+#define SIZEOF_spEntry 8+#define OFFSET_spEntry_addr 0+#define REP_spEntry_addr b64+#define spEntry_addr(__ptr__) REP_spEntry_addr[__ptr__+OFFSET_spEntry_addr]
+ ghc-lib/generated/GHCConstantsHaskellExports.hs view
@@ -0,0 +1,125 @@+    cONTROL_GROUP_CONST_291,+    sTD_HDR_SIZE,+    pROF_HDR_SIZE,+    bLOCK_SIZE,+    bLOCKS_PER_MBLOCK,+    tICKY_BIN_COUNT,+    oFFSET_StgRegTable_rR1,+    oFFSET_StgRegTable_rR2,+    oFFSET_StgRegTable_rR3,+    oFFSET_StgRegTable_rR4,+    oFFSET_StgRegTable_rR5,+    oFFSET_StgRegTable_rR6,+    oFFSET_StgRegTable_rR7,+    oFFSET_StgRegTable_rR8,+    oFFSET_StgRegTable_rR9,+    oFFSET_StgRegTable_rR10,+    oFFSET_StgRegTable_rF1,+    oFFSET_StgRegTable_rF2,+    oFFSET_StgRegTable_rF3,+    oFFSET_StgRegTable_rF4,+    oFFSET_StgRegTable_rF5,+    oFFSET_StgRegTable_rF6,+    oFFSET_StgRegTable_rD1,+    oFFSET_StgRegTable_rD2,+    oFFSET_StgRegTable_rD3,+    oFFSET_StgRegTable_rD4,+    oFFSET_StgRegTable_rD5,+    oFFSET_StgRegTable_rD6,+    oFFSET_StgRegTable_rXMM1,+    oFFSET_StgRegTable_rXMM2,+    oFFSET_StgRegTable_rXMM3,+    oFFSET_StgRegTable_rXMM4,+    oFFSET_StgRegTable_rXMM5,+    oFFSET_StgRegTable_rXMM6,+    oFFSET_StgRegTable_rYMM1,+    oFFSET_StgRegTable_rYMM2,+    oFFSET_StgRegTable_rYMM3,+    oFFSET_StgRegTable_rYMM4,+    oFFSET_StgRegTable_rYMM5,+    oFFSET_StgRegTable_rYMM6,+    oFFSET_StgRegTable_rZMM1,+    oFFSET_StgRegTable_rZMM2,+    oFFSET_StgRegTable_rZMM3,+    oFFSET_StgRegTable_rZMM4,+    oFFSET_StgRegTable_rZMM5,+    oFFSET_StgRegTable_rZMM6,+    oFFSET_StgRegTable_rL1,+    oFFSET_StgRegTable_rSp,+    oFFSET_StgRegTable_rSpLim,+    oFFSET_StgRegTable_rHp,+    oFFSET_StgRegTable_rHpLim,+    oFFSET_StgRegTable_rCCCS,+    oFFSET_StgRegTable_rCurrentTSO,+    oFFSET_StgRegTable_rCurrentNursery,+    oFFSET_StgRegTable_rHpAlloc,+    oFFSET_stgEagerBlackholeInfo,+    oFFSET_stgGCEnter1,+    oFFSET_stgGCFun,+    oFFSET_Capability_r,+    oFFSET_bdescr_start,+    oFFSET_bdescr_free,+    oFFSET_bdescr_blocks,+    oFFSET_bdescr_flags,+    sIZEOF_CostCentreStack,+    oFFSET_CostCentreStack_mem_alloc,+    oFFSET_CostCentreStack_scc_count,+    oFFSET_StgHeader_ccs,+    oFFSET_StgHeader_ldvw,+    sIZEOF_StgSMPThunkHeader,+    oFFSET_StgEntCounter_allocs,+    oFFSET_StgEntCounter_allocd,+    oFFSET_StgEntCounter_registeredp,+    oFFSET_StgEntCounter_link,+    oFFSET_StgEntCounter_entry_count,+    sIZEOF_StgUpdateFrame_NoHdr,+    sIZEOF_StgMutArrPtrs_NoHdr,+    oFFSET_StgMutArrPtrs_ptrs,+    oFFSET_StgMutArrPtrs_size,+    sIZEOF_StgSmallMutArrPtrs_NoHdr,+    oFFSET_StgSmallMutArrPtrs_ptrs,+    sIZEOF_StgArrBytes_NoHdr,+    oFFSET_StgArrBytes_bytes,+    oFFSET_StgTSO_alloc_limit,+    oFFSET_StgTSO_cccs,+    oFFSET_StgTSO_stackobj,+    oFFSET_StgStack_sp,+    oFFSET_StgStack_stack,+    oFFSET_StgUpdateFrame_updatee,+    oFFSET_StgFunInfoExtraFwd_arity,+    sIZEOF_StgFunInfoExtraRev,+    oFFSET_StgFunInfoExtraRev_arity,+    mAX_SPEC_SELECTEE_SIZE,+    mAX_SPEC_AP_SIZE,+    mIN_PAYLOAD_SIZE,+    mIN_INTLIKE,+    mAX_INTLIKE,+    mIN_CHARLIKE,+    mAX_CHARLIKE,+    mUT_ARR_PTRS_CARD_BITS,+    mAX_Vanilla_REG,+    mAX_Float_REG,+    mAX_Double_REG,+    mAX_Long_REG,+    mAX_XMM_REG,+    mAX_Real_Vanilla_REG,+    mAX_Real_Float_REG,+    mAX_Real_Double_REG,+    mAX_Real_XMM_REG,+    mAX_Real_Long_REG,+    rESERVED_C_STACK_BYTES,+    rESERVED_STACK_WORDS,+    aP_STACK_SPLIM,+    wORD_SIZE,+    dOUBLE_SIZE,+    cINT_SIZE,+    cLONG_SIZE,+    cLONG_LONG_SIZE,+    bITMAP_BITS_SHIFT,+    tAG_BITS,+    wORDS_BIGENDIAN,+    dYNAMIC_BY_DEFAULT,+    lDV_SHIFT,+    iLDV_CREATE_MASK,+    iLDV_STATE_CREATE,+    iLDV_STATE_USE,
+ ghc-lib/generated/GHCConstantsHaskellType.hs view
@@ -0,0 +1,134 @@+data PlatformConstants = PlatformConstants {+    pc_platformConstants :: ()+    , pc_CONTROL_GROUP_CONST_291 :: Int+    , pc_STD_HDR_SIZE :: Int+    , pc_PROF_HDR_SIZE :: Int+    , pc_BLOCK_SIZE :: Int+    , pc_BLOCKS_PER_MBLOCK :: Int+    , pc_TICKY_BIN_COUNT :: Int+    , pc_OFFSET_StgRegTable_rR1 :: Int+    , pc_OFFSET_StgRegTable_rR2 :: Int+    , pc_OFFSET_StgRegTable_rR3 :: Int+    , pc_OFFSET_StgRegTable_rR4 :: Int+    , pc_OFFSET_StgRegTable_rR5 :: Int+    , pc_OFFSET_StgRegTable_rR6 :: Int+    , pc_OFFSET_StgRegTable_rR7 :: Int+    , pc_OFFSET_StgRegTable_rR8 :: Int+    , pc_OFFSET_StgRegTable_rR9 :: Int+    , pc_OFFSET_StgRegTable_rR10 :: Int+    , pc_OFFSET_StgRegTable_rF1 :: Int+    , pc_OFFSET_StgRegTable_rF2 :: Int+    , pc_OFFSET_StgRegTable_rF3 :: Int+    , pc_OFFSET_StgRegTable_rF4 :: Int+    , pc_OFFSET_StgRegTable_rF5 :: Int+    , pc_OFFSET_StgRegTable_rF6 :: Int+    , pc_OFFSET_StgRegTable_rD1 :: Int+    , pc_OFFSET_StgRegTable_rD2 :: Int+    , pc_OFFSET_StgRegTable_rD3 :: Int+    , pc_OFFSET_StgRegTable_rD4 :: Int+    , pc_OFFSET_StgRegTable_rD5 :: Int+    , pc_OFFSET_StgRegTable_rD6 :: Int+    , pc_OFFSET_StgRegTable_rXMM1 :: Int+    , pc_OFFSET_StgRegTable_rXMM2 :: Int+    , pc_OFFSET_StgRegTable_rXMM3 :: Int+    , pc_OFFSET_StgRegTable_rXMM4 :: Int+    , pc_OFFSET_StgRegTable_rXMM5 :: Int+    , pc_OFFSET_StgRegTable_rXMM6 :: Int+    , pc_OFFSET_StgRegTable_rYMM1 :: Int+    , pc_OFFSET_StgRegTable_rYMM2 :: Int+    , pc_OFFSET_StgRegTable_rYMM3 :: Int+    , pc_OFFSET_StgRegTable_rYMM4 :: Int+    , pc_OFFSET_StgRegTable_rYMM5 :: Int+    , pc_OFFSET_StgRegTable_rYMM6 :: Int+    , pc_OFFSET_StgRegTable_rZMM1 :: Int+    , pc_OFFSET_StgRegTable_rZMM2 :: Int+    , pc_OFFSET_StgRegTable_rZMM3 :: Int+    , pc_OFFSET_StgRegTable_rZMM4 :: Int+    , pc_OFFSET_StgRegTable_rZMM5 :: Int+    , pc_OFFSET_StgRegTable_rZMM6 :: Int+    , pc_OFFSET_StgRegTable_rL1 :: Int+    , pc_OFFSET_StgRegTable_rSp :: Int+    , pc_OFFSET_StgRegTable_rSpLim :: Int+    , pc_OFFSET_StgRegTable_rHp :: Int+    , pc_OFFSET_StgRegTable_rHpLim :: Int+    , pc_OFFSET_StgRegTable_rCCCS :: Int+    , pc_OFFSET_StgRegTable_rCurrentTSO :: Int+    , pc_OFFSET_StgRegTable_rCurrentNursery :: Int+    , pc_OFFSET_StgRegTable_rHpAlloc :: Int+    , pc_OFFSET_stgEagerBlackholeInfo :: Int+    , pc_OFFSET_stgGCEnter1 :: Int+    , pc_OFFSET_stgGCFun :: Int+    , pc_OFFSET_Capability_r :: Int+    , pc_OFFSET_bdescr_start :: Int+    , pc_OFFSET_bdescr_free :: Int+    , pc_OFFSET_bdescr_blocks :: Int+    , pc_OFFSET_bdescr_flags :: Int+    , pc_SIZEOF_CostCentreStack :: Int+    , pc_OFFSET_CostCentreStack_mem_alloc :: Int+    , pc_REP_CostCentreStack_mem_alloc :: Int+    , pc_OFFSET_CostCentreStack_scc_count :: Int+    , pc_REP_CostCentreStack_scc_count :: Int+    , pc_OFFSET_StgHeader_ccs :: Int+    , pc_OFFSET_StgHeader_ldvw :: Int+    , pc_SIZEOF_StgSMPThunkHeader :: Int+    , pc_OFFSET_StgEntCounter_allocs :: Int+    , pc_REP_StgEntCounter_allocs :: Int+    , pc_OFFSET_StgEntCounter_allocd :: Int+    , pc_REP_StgEntCounter_allocd :: Int+    , pc_OFFSET_StgEntCounter_registeredp :: Int+    , pc_OFFSET_StgEntCounter_link :: Int+    , pc_OFFSET_StgEntCounter_entry_count :: Int+    , pc_SIZEOF_StgUpdateFrame_NoHdr :: Int+    , pc_SIZEOF_StgMutArrPtrs_NoHdr :: Int+    , pc_OFFSET_StgMutArrPtrs_ptrs :: Int+    , pc_OFFSET_StgMutArrPtrs_size :: Int+    , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr :: Int+    , pc_OFFSET_StgSmallMutArrPtrs_ptrs :: Int+    , pc_SIZEOF_StgArrBytes_NoHdr :: Int+    , pc_OFFSET_StgArrBytes_bytes :: Int+    , pc_OFFSET_StgTSO_alloc_limit :: Int+    , pc_OFFSET_StgTSO_cccs :: Int+    , pc_OFFSET_StgTSO_stackobj :: Int+    , pc_OFFSET_StgStack_sp :: Int+    , pc_OFFSET_StgStack_stack :: Int+    , pc_OFFSET_StgUpdateFrame_updatee :: Int+    , pc_OFFSET_StgFunInfoExtraFwd_arity :: Int+    , pc_REP_StgFunInfoExtraFwd_arity :: Int+    , pc_SIZEOF_StgFunInfoExtraRev :: Int+    , pc_OFFSET_StgFunInfoExtraRev_arity :: Int+    , pc_REP_StgFunInfoExtraRev_arity :: Int+    , pc_MAX_SPEC_SELECTEE_SIZE :: Int+    , pc_MAX_SPEC_AP_SIZE :: Int+    , pc_MIN_PAYLOAD_SIZE :: Int+    , pc_MIN_INTLIKE :: Int+    , pc_MAX_INTLIKE :: Int+    , pc_MIN_CHARLIKE :: Int+    , pc_MAX_CHARLIKE :: Int+    , pc_MUT_ARR_PTRS_CARD_BITS :: Int+    , pc_MAX_Vanilla_REG :: Int+    , pc_MAX_Float_REG :: Int+    , pc_MAX_Double_REG :: Int+    , pc_MAX_Long_REG :: Int+    , pc_MAX_XMM_REG :: Int+    , pc_MAX_Real_Vanilla_REG :: Int+    , pc_MAX_Real_Float_REG :: Int+    , pc_MAX_Real_Double_REG :: Int+    , pc_MAX_Real_XMM_REG :: Int+    , pc_MAX_Real_Long_REG :: Int+    , pc_RESERVED_C_STACK_BYTES :: Int+    , pc_RESERVED_STACK_WORDS :: Int+    , pc_AP_STACK_SPLIM :: Int+    , pc_WORD_SIZE :: Int+    , pc_DOUBLE_SIZE :: Int+    , pc_CINT_SIZE :: Int+    , pc_CLONG_SIZE :: Int+    , pc_CLONG_LONG_SIZE :: Int+    , pc_BITMAP_BITS_SHIFT :: Int+    , pc_TAG_BITS :: Int+    , pc_WORDS_BIGENDIAN :: Bool+    , pc_DYNAMIC_BY_DEFAULT :: Bool+    , pc_LDV_SHIFT :: Int+    , pc_ILDV_CREATE_MASK :: Integer+    , pc_ILDV_STATE_CREATE :: Integer+    , pc_ILDV_STATE_USE :: Integer+  } deriving Read
+ ghc-lib/generated/GHCConstantsHaskellWrappers.hs view
@@ -0,0 +1,250 @@+cONTROL_GROUP_CONST_291 :: DynFlags -> Int+cONTROL_GROUP_CONST_291 dflags = pc_CONTROL_GROUP_CONST_291 (sPlatformConstants (settings dflags))+sTD_HDR_SIZE :: DynFlags -> Int+sTD_HDR_SIZE dflags = pc_STD_HDR_SIZE (sPlatformConstants (settings dflags))+pROF_HDR_SIZE :: DynFlags -> Int+pROF_HDR_SIZE dflags = pc_PROF_HDR_SIZE (sPlatformConstants (settings dflags))+bLOCK_SIZE :: DynFlags -> Int+bLOCK_SIZE dflags = pc_BLOCK_SIZE (sPlatformConstants (settings dflags))+bLOCKS_PER_MBLOCK :: DynFlags -> Int+bLOCKS_PER_MBLOCK dflags = pc_BLOCKS_PER_MBLOCK (sPlatformConstants (settings dflags))+tICKY_BIN_COUNT :: DynFlags -> Int+tICKY_BIN_COUNT dflags = pc_TICKY_BIN_COUNT (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR1 :: DynFlags -> Int+oFFSET_StgRegTable_rR1 dflags = pc_OFFSET_StgRegTable_rR1 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR2 :: DynFlags -> Int+oFFSET_StgRegTable_rR2 dflags = pc_OFFSET_StgRegTable_rR2 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR3 :: DynFlags -> Int+oFFSET_StgRegTable_rR3 dflags = pc_OFFSET_StgRegTable_rR3 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR4 :: DynFlags -> Int+oFFSET_StgRegTable_rR4 dflags = pc_OFFSET_StgRegTable_rR4 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR5 :: DynFlags -> Int+oFFSET_StgRegTable_rR5 dflags = pc_OFFSET_StgRegTable_rR5 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR6 :: DynFlags -> Int+oFFSET_StgRegTable_rR6 dflags = pc_OFFSET_StgRegTable_rR6 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR7 :: DynFlags -> Int+oFFSET_StgRegTable_rR7 dflags = pc_OFFSET_StgRegTable_rR7 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR8 :: DynFlags -> Int+oFFSET_StgRegTable_rR8 dflags = pc_OFFSET_StgRegTable_rR8 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR9 :: DynFlags -> Int+oFFSET_StgRegTable_rR9 dflags = pc_OFFSET_StgRegTable_rR9 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rR10 :: DynFlags -> Int+oFFSET_StgRegTable_rR10 dflags = pc_OFFSET_StgRegTable_rR10 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rF1 :: DynFlags -> Int+oFFSET_StgRegTable_rF1 dflags = pc_OFFSET_StgRegTable_rF1 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rF2 :: DynFlags -> Int+oFFSET_StgRegTable_rF2 dflags = pc_OFFSET_StgRegTable_rF2 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rF3 :: DynFlags -> Int+oFFSET_StgRegTable_rF3 dflags = pc_OFFSET_StgRegTable_rF3 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rF4 :: DynFlags -> Int+oFFSET_StgRegTable_rF4 dflags = pc_OFFSET_StgRegTable_rF4 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rF5 :: DynFlags -> Int+oFFSET_StgRegTable_rF5 dflags = pc_OFFSET_StgRegTable_rF5 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rF6 :: DynFlags -> Int+oFFSET_StgRegTable_rF6 dflags = pc_OFFSET_StgRegTable_rF6 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rD1 :: DynFlags -> Int+oFFSET_StgRegTable_rD1 dflags = pc_OFFSET_StgRegTable_rD1 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rD2 :: DynFlags -> Int+oFFSET_StgRegTable_rD2 dflags = pc_OFFSET_StgRegTable_rD2 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rD3 :: DynFlags -> Int+oFFSET_StgRegTable_rD3 dflags = pc_OFFSET_StgRegTable_rD3 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rD4 :: DynFlags -> Int+oFFSET_StgRegTable_rD4 dflags = pc_OFFSET_StgRegTable_rD4 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rD5 :: DynFlags -> Int+oFFSET_StgRegTable_rD5 dflags = pc_OFFSET_StgRegTable_rD5 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rD6 :: DynFlags -> Int+oFFSET_StgRegTable_rD6 dflags = pc_OFFSET_StgRegTable_rD6 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rXMM1 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM1 dflags = pc_OFFSET_StgRegTable_rXMM1 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rXMM2 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM2 dflags = pc_OFFSET_StgRegTable_rXMM2 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rXMM3 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM3 dflags = pc_OFFSET_StgRegTable_rXMM3 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rXMM4 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM4 dflags = pc_OFFSET_StgRegTable_rXMM4 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rXMM5 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM5 dflags = pc_OFFSET_StgRegTable_rXMM5 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rXMM6 :: DynFlags -> Int+oFFSET_StgRegTable_rXMM6 dflags = pc_OFFSET_StgRegTable_rXMM6 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rYMM1 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM1 dflags = pc_OFFSET_StgRegTable_rYMM1 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rYMM2 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM2 dflags = pc_OFFSET_StgRegTable_rYMM2 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rYMM3 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM3 dflags = pc_OFFSET_StgRegTable_rYMM3 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rYMM4 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM4 dflags = pc_OFFSET_StgRegTable_rYMM4 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rYMM5 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM5 dflags = pc_OFFSET_StgRegTable_rYMM5 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rYMM6 :: DynFlags -> Int+oFFSET_StgRegTable_rYMM6 dflags = pc_OFFSET_StgRegTable_rYMM6 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rZMM1 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM1 dflags = pc_OFFSET_StgRegTable_rZMM1 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rZMM2 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM2 dflags = pc_OFFSET_StgRegTable_rZMM2 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rZMM3 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM3 dflags = pc_OFFSET_StgRegTable_rZMM3 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rZMM4 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM4 dflags = pc_OFFSET_StgRegTable_rZMM4 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rZMM5 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM5 dflags = pc_OFFSET_StgRegTable_rZMM5 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rZMM6 :: DynFlags -> Int+oFFSET_StgRegTable_rZMM6 dflags = pc_OFFSET_StgRegTable_rZMM6 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rL1 :: DynFlags -> Int+oFFSET_StgRegTable_rL1 dflags = pc_OFFSET_StgRegTable_rL1 (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rSp :: DynFlags -> Int+oFFSET_StgRegTable_rSp dflags = pc_OFFSET_StgRegTable_rSp (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rSpLim :: DynFlags -> Int+oFFSET_StgRegTable_rSpLim dflags = pc_OFFSET_StgRegTable_rSpLim (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rHp :: DynFlags -> Int+oFFSET_StgRegTable_rHp dflags = pc_OFFSET_StgRegTable_rHp (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rHpLim :: DynFlags -> Int+oFFSET_StgRegTable_rHpLim dflags = pc_OFFSET_StgRegTable_rHpLim (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rCCCS :: DynFlags -> Int+oFFSET_StgRegTable_rCCCS dflags = pc_OFFSET_StgRegTable_rCCCS (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rCurrentTSO :: DynFlags -> Int+oFFSET_StgRegTable_rCurrentTSO dflags = pc_OFFSET_StgRegTable_rCurrentTSO (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rCurrentNursery :: DynFlags -> Int+oFFSET_StgRegTable_rCurrentNursery dflags = pc_OFFSET_StgRegTable_rCurrentNursery (sPlatformConstants (settings dflags))+oFFSET_StgRegTable_rHpAlloc :: DynFlags -> Int+oFFSET_StgRegTable_rHpAlloc dflags = pc_OFFSET_StgRegTable_rHpAlloc (sPlatformConstants (settings dflags))+oFFSET_stgEagerBlackholeInfo :: DynFlags -> Int+oFFSET_stgEagerBlackholeInfo dflags = pc_OFFSET_stgEagerBlackholeInfo (sPlatformConstants (settings dflags))+oFFSET_stgGCEnter1 :: DynFlags -> Int+oFFSET_stgGCEnter1 dflags = pc_OFFSET_stgGCEnter1 (sPlatformConstants (settings dflags))+oFFSET_stgGCFun :: DynFlags -> Int+oFFSET_stgGCFun dflags = pc_OFFSET_stgGCFun (sPlatformConstants (settings dflags))+oFFSET_Capability_r :: DynFlags -> Int+oFFSET_Capability_r dflags = pc_OFFSET_Capability_r (sPlatformConstants (settings dflags))+oFFSET_bdescr_start :: DynFlags -> Int+oFFSET_bdescr_start dflags = pc_OFFSET_bdescr_start (sPlatformConstants (settings dflags))+oFFSET_bdescr_free :: DynFlags -> Int+oFFSET_bdescr_free dflags = pc_OFFSET_bdescr_free (sPlatformConstants (settings dflags))+oFFSET_bdescr_blocks :: DynFlags -> Int+oFFSET_bdescr_blocks dflags = pc_OFFSET_bdescr_blocks (sPlatformConstants (settings dflags))+oFFSET_bdescr_flags :: DynFlags -> Int+oFFSET_bdescr_flags dflags = pc_OFFSET_bdescr_flags (sPlatformConstants (settings dflags))+sIZEOF_CostCentreStack :: DynFlags -> Int+sIZEOF_CostCentreStack dflags = pc_SIZEOF_CostCentreStack (sPlatformConstants (settings dflags))+oFFSET_CostCentreStack_mem_alloc :: DynFlags -> Int+oFFSET_CostCentreStack_mem_alloc dflags = pc_OFFSET_CostCentreStack_mem_alloc (sPlatformConstants (settings dflags))+oFFSET_CostCentreStack_scc_count :: DynFlags -> Int+oFFSET_CostCentreStack_scc_count dflags = pc_OFFSET_CostCentreStack_scc_count (sPlatformConstants (settings dflags))+oFFSET_StgHeader_ccs :: DynFlags -> Int+oFFSET_StgHeader_ccs dflags = pc_OFFSET_StgHeader_ccs (sPlatformConstants (settings dflags))+oFFSET_StgHeader_ldvw :: DynFlags -> Int+oFFSET_StgHeader_ldvw dflags = pc_OFFSET_StgHeader_ldvw (sPlatformConstants (settings dflags))+sIZEOF_StgSMPThunkHeader :: DynFlags -> Int+sIZEOF_StgSMPThunkHeader dflags = pc_SIZEOF_StgSMPThunkHeader (sPlatformConstants (settings dflags))+oFFSET_StgEntCounter_allocs :: DynFlags -> Int+oFFSET_StgEntCounter_allocs dflags = pc_OFFSET_StgEntCounter_allocs (sPlatformConstants (settings dflags))+oFFSET_StgEntCounter_allocd :: DynFlags -> Int+oFFSET_StgEntCounter_allocd dflags = pc_OFFSET_StgEntCounter_allocd (sPlatformConstants (settings dflags))+oFFSET_StgEntCounter_registeredp :: DynFlags -> Int+oFFSET_StgEntCounter_registeredp dflags = pc_OFFSET_StgEntCounter_registeredp (sPlatformConstants (settings dflags))+oFFSET_StgEntCounter_link :: DynFlags -> Int+oFFSET_StgEntCounter_link dflags = pc_OFFSET_StgEntCounter_link (sPlatformConstants (settings dflags))+oFFSET_StgEntCounter_entry_count :: DynFlags -> Int+oFFSET_StgEntCounter_entry_count dflags = pc_OFFSET_StgEntCounter_entry_count (sPlatformConstants (settings dflags))+sIZEOF_StgUpdateFrame_NoHdr :: DynFlags -> Int+sIZEOF_StgUpdateFrame_NoHdr dflags = pc_SIZEOF_StgUpdateFrame_NoHdr (sPlatformConstants (settings dflags))+sIZEOF_StgMutArrPtrs_NoHdr :: DynFlags -> Int+sIZEOF_StgMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgMutArrPtrs_NoHdr (sPlatformConstants (settings dflags))+oFFSET_StgMutArrPtrs_ptrs :: DynFlags -> Int+oFFSET_StgMutArrPtrs_ptrs dflags = pc_OFFSET_StgMutArrPtrs_ptrs (sPlatformConstants (settings dflags))+oFFSET_StgMutArrPtrs_size :: DynFlags -> Int+oFFSET_StgMutArrPtrs_size dflags = pc_OFFSET_StgMutArrPtrs_size (sPlatformConstants (settings dflags))+sIZEOF_StgSmallMutArrPtrs_NoHdr :: DynFlags -> Int+sIZEOF_StgSmallMutArrPtrs_NoHdr dflags = pc_SIZEOF_StgSmallMutArrPtrs_NoHdr (sPlatformConstants (settings dflags))+oFFSET_StgSmallMutArrPtrs_ptrs :: DynFlags -> Int+oFFSET_StgSmallMutArrPtrs_ptrs dflags = pc_OFFSET_StgSmallMutArrPtrs_ptrs (sPlatformConstants (settings dflags))+sIZEOF_StgArrBytes_NoHdr :: DynFlags -> Int+sIZEOF_StgArrBytes_NoHdr dflags = pc_SIZEOF_StgArrBytes_NoHdr (sPlatformConstants (settings dflags))+oFFSET_StgArrBytes_bytes :: DynFlags -> Int+oFFSET_StgArrBytes_bytes dflags = pc_OFFSET_StgArrBytes_bytes (sPlatformConstants (settings dflags))+oFFSET_StgTSO_alloc_limit :: DynFlags -> Int+oFFSET_StgTSO_alloc_limit dflags = pc_OFFSET_StgTSO_alloc_limit (sPlatformConstants (settings dflags))+oFFSET_StgTSO_cccs :: DynFlags -> Int+oFFSET_StgTSO_cccs dflags = pc_OFFSET_StgTSO_cccs (sPlatformConstants (settings dflags))+oFFSET_StgTSO_stackobj :: DynFlags -> Int+oFFSET_StgTSO_stackobj dflags = pc_OFFSET_StgTSO_stackobj (sPlatformConstants (settings dflags))+oFFSET_StgStack_sp :: DynFlags -> Int+oFFSET_StgStack_sp dflags = pc_OFFSET_StgStack_sp (sPlatformConstants (settings dflags))+oFFSET_StgStack_stack :: DynFlags -> Int+oFFSET_StgStack_stack dflags = pc_OFFSET_StgStack_stack (sPlatformConstants (settings dflags))+oFFSET_StgUpdateFrame_updatee :: DynFlags -> Int+oFFSET_StgUpdateFrame_updatee dflags = pc_OFFSET_StgUpdateFrame_updatee (sPlatformConstants (settings dflags))+oFFSET_StgFunInfoExtraFwd_arity :: DynFlags -> Int+oFFSET_StgFunInfoExtraFwd_arity dflags = pc_OFFSET_StgFunInfoExtraFwd_arity (sPlatformConstants (settings dflags))+sIZEOF_StgFunInfoExtraRev :: DynFlags -> Int+sIZEOF_StgFunInfoExtraRev dflags = pc_SIZEOF_StgFunInfoExtraRev (sPlatformConstants (settings dflags))+oFFSET_StgFunInfoExtraRev_arity :: DynFlags -> Int+oFFSET_StgFunInfoExtraRev_arity dflags = pc_OFFSET_StgFunInfoExtraRev_arity (sPlatformConstants (settings dflags))+mAX_SPEC_SELECTEE_SIZE :: DynFlags -> Int+mAX_SPEC_SELECTEE_SIZE dflags = pc_MAX_SPEC_SELECTEE_SIZE (sPlatformConstants (settings dflags))+mAX_SPEC_AP_SIZE :: DynFlags -> Int+mAX_SPEC_AP_SIZE dflags = pc_MAX_SPEC_AP_SIZE (sPlatformConstants (settings dflags))+mIN_PAYLOAD_SIZE :: DynFlags -> Int+mIN_PAYLOAD_SIZE dflags = pc_MIN_PAYLOAD_SIZE (sPlatformConstants (settings dflags))+mIN_INTLIKE :: DynFlags -> Int+mIN_INTLIKE dflags = pc_MIN_INTLIKE (sPlatformConstants (settings dflags))+mAX_INTLIKE :: DynFlags -> Int+mAX_INTLIKE dflags = pc_MAX_INTLIKE (sPlatformConstants (settings dflags))+mIN_CHARLIKE :: DynFlags -> Int+mIN_CHARLIKE dflags = pc_MIN_CHARLIKE (sPlatformConstants (settings dflags))+mAX_CHARLIKE :: DynFlags -> Int+mAX_CHARLIKE dflags = pc_MAX_CHARLIKE (sPlatformConstants (settings dflags))+mUT_ARR_PTRS_CARD_BITS :: DynFlags -> Int+mUT_ARR_PTRS_CARD_BITS dflags = pc_MUT_ARR_PTRS_CARD_BITS (sPlatformConstants (settings dflags))+mAX_Vanilla_REG :: DynFlags -> Int+mAX_Vanilla_REG dflags = pc_MAX_Vanilla_REG (sPlatformConstants (settings dflags))+mAX_Float_REG :: DynFlags -> Int+mAX_Float_REG dflags = pc_MAX_Float_REG (sPlatformConstants (settings dflags))+mAX_Double_REG :: DynFlags -> Int+mAX_Double_REG dflags = pc_MAX_Double_REG (sPlatformConstants (settings dflags))+mAX_Long_REG :: DynFlags -> Int+mAX_Long_REG dflags = pc_MAX_Long_REG (sPlatformConstants (settings dflags))+mAX_XMM_REG :: DynFlags -> Int+mAX_XMM_REG dflags = pc_MAX_XMM_REG (sPlatformConstants (settings dflags))+mAX_Real_Vanilla_REG :: DynFlags -> Int+mAX_Real_Vanilla_REG dflags = pc_MAX_Real_Vanilla_REG (sPlatformConstants (settings dflags))+mAX_Real_Float_REG :: DynFlags -> Int+mAX_Real_Float_REG dflags = pc_MAX_Real_Float_REG (sPlatformConstants (settings dflags))+mAX_Real_Double_REG :: DynFlags -> Int+mAX_Real_Double_REG dflags = pc_MAX_Real_Double_REG (sPlatformConstants (settings dflags))+mAX_Real_XMM_REG :: DynFlags -> Int+mAX_Real_XMM_REG dflags = pc_MAX_Real_XMM_REG (sPlatformConstants (settings dflags))+mAX_Real_Long_REG :: DynFlags -> Int+mAX_Real_Long_REG dflags = pc_MAX_Real_Long_REG (sPlatformConstants (settings dflags))+rESERVED_C_STACK_BYTES :: DynFlags -> Int+rESERVED_C_STACK_BYTES dflags = pc_RESERVED_C_STACK_BYTES (sPlatformConstants (settings dflags))+rESERVED_STACK_WORDS :: DynFlags -> Int+rESERVED_STACK_WORDS dflags = pc_RESERVED_STACK_WORDS (sPlatformConstants (settings dflags))+aP_STACK_SPLIM :: DynFlags -> Int+aP_STACK_SPLIM dflags = pc_AP_STACK_SPLIM (sPlatformConstants (settings dflags))+wORD_SIZE :: DynFlags -> Int+wORD_SIZE dflags = pc_WORD_SIZE (sPlatformConstants (settings dflags))+dOUBLE_SIZE :: DynFlags -> Int+dOUBLE_SIZE dflags = pc_DOUBLE_SIZE (sPlatformConstants (settings dflags))+cINT_SIZE :: DynFlags -> Int+cINT_SIZE dflags = pc_CINT_SIZE (sPlatformConstants (settings dflags))+cLONG_SIZE :: DynFlags -> Int+cLONG_SIZE dflags = pc_CLONG_SIZE (sPlatformConstants (settings dflags))+cLONG_LONG_SIZE :: DynFlags -> Int+cLONG_LONG_SIZE dflags = pc_CLONG_LONG_SIZE (sPlatformConstants (settings dflags))+bITMAP_BITS_SHIFT :: DynFlags -> Int+bITMAP_BITS_SHIFT dflags = pc_BITMAP_BITS_SHIFT (sPlatformConstants (settings dflags))+tAG_BITS :: DynFlags -> Int+tAG_BITS dflags = pc_TAG_BITS (sPlatformConstants (settings dflags))+wORDS_BIGENDIAN :: DynFlags -> Bool+wORDS_BIGENDIAN dflags = pc_WORDS_BIGENDIAN (sPlatformConstants (settings dflags))+dYNAMIC_BY_DEFAULT :: DynFlags -> Bool+dYNAMIC_BY_DEFAULT dflags = pc_DYNAMIC_BY_DEFAULT (sPlatformConstants (settings dflags))+lDV_SHIFT :: DynFlags -> Int+lDV_SHIFT dflags = pc_LDV_SHIFT (sPlatformConstants (settings dflags))+iLDV_CREATE_MASK :: DynFlags -> Integer+iLDV_CREATE_MASK dflags = pc_ILDV_CREATE_MASK (sPlatformConstants (settings dflags))+iLDV_STATE_CREATE :: DynFlags -> Integer+iLDV_STATE_CREATE dflags = pc_ILDV_STATE_CREATE (sPlatformConstants (settings dflags))+iLDV_STATE_USE :: DynFlags -> Integer+iLDV_STATE_USE dflags = pc_ILDV_STATE_USE (sPlatformConstants (settings dflags))
+ ghc-lib/generated/ghcautoconf.h view
@@ -0,0 +1,542 @@+#ifndef __GHCAUTOCONF_H__+#define __GHCAUTOCONF_H__+/* mk/config.h.  Generated from config.h.in by configure.  */+/* mk/config.h.in.  Generated from configure.ac by autoheader.  */++/* Define if building universal (internal helper macro) */+/* #undef AC_APPLE_UNIVERSAL_BUILD */++/* The alignment of a `char'. */+#define ALIGNMENT_CHAR 1++/* The alignment of a `double'. */+#define ALIGNMENT_DOUBLE 8++/* The alignment of a `float'. */+#define ALIGNMENT_FLOAT 4++/* The alignment of a `int'. */+#define ALIGNMENT_INT 4++/* The alignment of a `int16_t'. */+#define ALIGNMENT_INT16_T 2++/* The alignment of a `int32_t'. */+#define ALIGNMENT_INT32_T 4++/* The alignment of a `int64_t'. */+#define ALIGNMENT_INT64_T 8++/* The alignment of a `int8_t'. */+#define ALIGNMENT_INT8_T 1++/* The alignment of a `long'. */+#define ALIGNMENT_LONG 8++/* The alignment of a `long long'. */+#define ALIGNMENT_LONG_LONG 8++/* The alignment of a `short'. */+#define ALIGNMENT_SHORT 2++/* The alignment of a `uint16_t'. */+#define ALIGNMENT_UINT16_T 2++/* The alignment of a `uint32_t'. */+#define ALIGNMENT_UINT32_T 4++/* The alignment of a `uint64_t'. */+#define ALIGNMENT_UINT64_T 8++/* The alignment of a `uint8_t'. */+#define ALIGNMENT_UINT8_T 1++/* The alignment of a `unsigned char'. */+#define ALIGNMENT_UNSIGNED_CHAR 1++/* The alignment of a `unsigned int'. */+#define ALIGNMENT_UNSIGNED_INT 4++/* The alignment of a `unsigned long'. */+#define ALIGNMENT_UNSIGNED_LONG 8++/* The alignment of a `unsigned long long'. */+#define ALIGNMENT_UNSIGNED_LONG_LONG 8++/* The alignment of a `unsigned short'. */+#define ALIGNMENT_UNSIGNED_SHORT 2++/* The alignment of a `void *'. */+#define ALIGNMENT_VOID_P 8++/* Define to 1 if __thread is supported */+#define CC_SUPPORTS_TLS 1++/* Define to one of `_getb67', `GETB67', `getb67' for Cray-2 and Cray-YMP+   systems. This function is required for `alloca.c' support on those systems.+   */+/* #undef CRAY_STACKSEG_END */++/* Define to 1 if using `alloca.c'. */+/* #undef C_ALLOCA */++/* Define to 1 if your processor stores words of floats with the most+   significant byte first */+/* #undef FLOAT_WORDS_BIGENDIAN */++/* Has visibility hidden */+#define HAS_VISIBILITY_HIDDEN 1++/* Define to 1 if you have `alloca', as a function or macro. */+#define HAVE_ALLOCA 1++/* Define to 1 if you have <alloca.h> and it should be used (not on Ultrix).+   */+#define HAVE_ALLOCA_H 1++/* Define to 1 if you have the <bfd.h> header file. */+/* #undef HAVE_BFD_H */++/* Does GCC support __atomic primitives? */+#define HAVE_C11_ATOMICS $CONF_GCC_SUPPORTS__ATOMICS++/* Define to 1 if you have the `clock_gettime' function. */+#define HAVE_CLOCK_GETTIME 1++/* Define to 1 if you have the `ctime_r' function. */+#define HAVE_CTIME_R 1++/* Define to 1 if you have the <ctype.h> header file. */+#define HAVE_CTYPE_H 1++/* Define to 1 if you have the declaration of `ctime_r', and to 0 if you+   don't. */+#define HAVE_DECL_CTIME_R 1++/* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you+   don't. */+/* #undef HAVE_DECL_MADV_DONTNEED */++/* Define to 1 if you have the declaration of `MADV_FREE', and to 0 if you+   don't. */+/* #undef HAVE_DECL_MADV_FREE */++/* Define to 1 if you have the declaration of `MAP_NORESERVE', and to 0 if you+   don't. */+/* #undef HAVE_DECL_MAP_NORESERVE */++/* Define to 1 if you have the <dirent.h> header file. */+#define HAVE_DIRENT_H 1++/* Define to 1 if you have the <dlfcn.h> header file. */+#define HAVE_DLFCN_H 1++/* Define to 1 if you have the <errno.h> header file. */+#define HAVE_ERRNO_H 1++/* Define to 1 if you have the `eventfd' function. */+/* #undef HAVE_EVENTFD */++/* Define to 1 if you have the <fcntl.h> header file. */+#define HAVE_FCNTL_H 1++/* Define to 1 if you have the <ffi.h> header file. */+/* #undef HAVE_FFI_H */++/* Define to 1 if you have the `fork' function. */+#define HAVE_FORK 1++/* Define to 1 if you have the `getclock' function. */+/* #undef HAVE_GETCLOCK */++/* Define to 1 if you have the `GetModuleFileName' function. */+/* #undef HAVE_GETMODULEFILENAME */++/* Define to 1 if you have the `getrusage' function. */+#define HAVE_GETRUSAGE 1++/* Define to 1 if you have the `gettimeofday' function. */+#define HAVE_GETTIMEOFDAY 1++/* Define to 1 if you have the <grp.h> header file. */+#define HAVE_GRP_H 1++/* Define to 1 if you have the <inttypes.h> header file. */+#define HAVE_INTTYPES_H 1++/* Define to 1 if you have the `bfd' library (-lbfd). */+/* #undef HAVE_LIBBFD */++/* Define to 1 if you have the `dl' library (-ldl). */+#define HAVE_LIBDL 1++/* Define to 1 if you have libffi. */+/* #undef HAVE_LIBFFI */++/* Define to 1 if you have the `iberty' library (-liberty). */+/* #undef HAVE_LIBIBERTY */++/* Define to 1 if you need to link with libm */+#define HAVE_LIBM 1++/* Define to 1 if you have libnuma */+#define HAVE_LIBNUMA 0++/* Define to 1 if you have the `pthread' library (-lpthread). */+#define HAVE_LIBPTHREAD 1++/* Define to 1 if you have the `rt' library (-lrt). */+/* #undef HAVE_LIBRT */++/* Define to 1 if you have the <limits.h> header file. */+#define HAVE_LIMITS_H 1++/* Define to 1 if you have the <locale.h> header file. */+#define HAVE_LOCALE_H 1++/* Define to 1 if the system has the type `long long'. */+#define HAVE_LONG_LONG 1++/* Define to 1 if you have the <memory.h> header file. */+#define HAVE_MEMORY_H 1++/* Define to 1 if you have the mingwex library. */+/* #undef HAVE_MINGWEX */++/* Define to 1 if you have the <nlist.h> header file. */+#define HAVE_NLIST_H 1++/* Define to 1 if you have the <numaif.h> header file. */+/* #undef HAVE_NUMAIF_H */++/* Define to 1 if you have the <numa.h> header file. */+/* #undef HAVE_NUMA_H */++/* Define to 1 if we have printf$LDBLStub (Apple Mac OS >= 10.4, PPC). */+#define HAVE_PRINTF_LDBLSTUB 0++/* Define to 1 if you have the <pthread.h> header file. */+#define HAVE_PTHREAD_H 1++/* Define to 1 if you have the glibc version of pthread_setname_np */+/* #undef HAVE_PTHREAD_SETNAME_NP */++/* Define to 1 if you have the <pwd.h> header file. */+#define HAVE_PWD_H 1++/* Define to 1 if you have the <sched.h> header file. */+#define HAVE_SCHED_H 1++/* Define to 1 if you have the `sched_setaffinity' function. */+/* #undef HAVE_SCHED_SETAFFINITY */++/* Define to 1 if you have the `setitimer' function. */+#define HAVE_SETITIMER 1++/* Define to 1 if you have the `setlocale' function. */+#define HAVE_SETLOCALE 1++/* Define to 1 if you have the `siginterrupt' function. */+#define HAVE_SIGINTERRUPT 1++/* Define to 1 if you have the <signal.h> header file. */+#define HAVE_SIGNAL_H 1++/* Define to 1 if you have the <stdint.h> header file. */+#define HAVE_STDINT_H 1++/* Define to 1 if you have the <stdlib.h> header file. */+#define HAVE_STDLIB_H 1++/* Define to 1 if you have the <strings.h> header file. */+#define HAVE_STRINGS_H 1++/* Define to 1 if you have the <string.h> header file. */+#define HAVE_STRING_H 1++/* Define to 1 if Apple-style dead-stripping is supported. */+#define HAVE_SUBSECTIONS_VIA_SYMBOLS 1++/* Define to 1 if you have the `sysconf' function. */+#define HAVE_SYSCONF 1++/* Define to 1 if you have the <sys/cpuset.h> header file. */+/* #undef HAVE_SYS_CPUSET_H */++/* Define to 1 if you have the <sys/eventfd.h> header file. */+/* #undef HAVE_SYS_EVENTFD_H */++/* Define to 1 if you have the <sys/mman.h> header file. */+#define HAVE_SYS_MMAN_H 1++/* Define to 1 if you have the <sys/param.h> header file. */+#define HAVE_SYS_PARAM_H 1++/* Define to 1 if you have the <sys/resource.h> header file. */+#define HAVE_SYS_RESOURCE_H 1++/* Define to 1 if you have the <sys/select.h> header file. */+#define HAVE_SYS_SELECT_H 1++/* Define to 1 if you have the <sys/stat.h> header file. */+#define HAVE_SYS_STAT_H 1++/* Define to 1 if you have the <sys/timeb.h> header file. */+#define HAVE_SYS_TIMEB_H 1++/* Define to 1 if you have the <sys/timerfd.h> header file. */+/* #undef HAVE_SYS_TIMERFD_H */++/* Define to 1 if you have the <sys/timers.h> header file. */+/* #undef HAVE_SYS_TIMERS_H */++/* Define to 1 if you have the <sys/times.h> header file. */+#define HAVE_SYS_TIMES_H 1++/* Define to 1 if you have the <sys/time.h> header file. */+#define HAVE_SYS_TIME_H 1++/* Define to 1 if you have the <sys/types.h> header file. */+#define HAVE_SYS_TYPES_H 1++/* Define to 1 if you have the <sys/utsname.h> header file. */+#define HAVE_SYS_UTSNAME_H 1++/* Define to 1 if you have the <sys/wait.h> header file. */+#define HAVE_SYS_WAIT_H 1++/* Define to 1 if you have the <termios.h> header file. */+#define HAVE_TERMIOS_H 1++/* Define to 1 if you have the `timer_settime' function. */+/* #undef HAVE_TIMER_SETTIME */++/* Define to 1 if you have the `times' function. */+#define HAVE_TIMES 1++/* Define to 1 if you have the <time.h> header file. */+#define HAVE_TIME_H 1++/* Define to 1 if you have the <unistd.h> header file. */+#define HAVE_UNISTD_H 1++/* Define to 1 if you have the <utime.h> header file. */+#define HAVE_UTIME_H 1++/* Define to 1 if you have the `vfork' function. */+#define HAVE_VFORK 1++/* Define to 1 if you have the <vfork.h> header file. */+/* #undef HAVE_VFORK_H */++/* Define to 1 if you have the <windows.h> header file. */+/* #undef HAVE_WINDOWS_H */++/* Define to 1 if you have the `WinExec' function. */+/* #undef HAVE_WINEXEC */++/* Define to 1 if you have the <winsock.h> header file. */+/* #undef HAVE_WINSOCK_H */++/* Define to 1 if `fork' works. */+#define HAVE_WORKING_FORK 1++/* Define to 1 if `vfork' works. */+#define HAVE_WORKING_VFORK 1++/* Define to 1 if C symbols have a leading underscore added by the compiler.+   */+#define LEADING_UNDERSCORE 1++/* Define 1 if we need to link code using pthreads with -lpthread */+#define NEED_PTHREAD_LIB 0++/* Define to the address where bug reports for this package should be sent. */+/* #undef PACKAGE_BUGREPORT */++/* Define to the full name of this package. */+/* #undef PACKAGE_NAME */++/* Define to the full name and version of this package. */+/* #undef PACKAGE_STRING */++/* Define to the one symbol short name of this package. */+/* #undef PACKAGE_TARNAME */++/* Define to the home page for this package. */+/* #undef PACKAGE_URL */++/* Define to the version of this package. */+/* #undef PACKAGE_VERSION */++/* Use mmap in the runtime linker */+#define RTS_LINKER_USE_MMAP 1++/* The size of `char', as computed by sizeof. */+#define SIZEOF_CHAR 1++/* The size of `double', as computed by sizeof. */+#define SIZEOF_DOUBLE 8++/* The size of `float', as computed by sizeof. */+#define SIZEOF_FLOAT 4++/* The size of `int', as computed by sizeof. */+#define SIZEOF_INT 4++/* The size of `int16_t', as computed by sizeof. */+#define SIZEOF_INT16_T 2++/* The size of `int32_t', as computed by sizeof. */+#define SIZEOF_INT32_T 4++/* The size of `int64_t', as computed by sizeof. */+#define SIZEOF_INT64_T 8++/* The size of `int8_t', as computed by sizeof. */+#define SIZEOF_INT8_T 1++/* The size of `long', as computed by sizeof. */+#define SIZEOF_LONG 8++/* The size of `long long', as computed by sizeof. */+#define SIZEOF_LONG_LONG 8++/* The size of `short', as computed by sizeof. */+#define SIZEOF_SHORT 2++/* The size of `uint16_t', as computed by sizeof. */+#define SIZEOF_UINT16_T 2++/* The size of `uint32_t', as computed by sizeof. */+#define SIZEOF_UINT32_T 4++/* The size of `uint64_t', as computed by sizeof. */+#define SIZEOF_UINT64_T 8++/* The size of `uint8_t', as computed by sizeof. */+#define SIZEOF_UINT8_T 1++/* The size of `unsigned char', as computed by sizeof. */+#define SIZEOF_UNSIGNED_CHAR 1++/* The size of `unsigned int', as computed by sizeof. */+#define SIZEOF_UNSIGNED_INT 4++/* The size of `unsigned long', as computed by sizeof. */+#define SIZEOF_UNSIGNED_LONG 8++/* The size of `unsigned long long', as computed by sizeof. */+#define SIZEOF_UNSIGNED_LONG_LONG 8++/* The size of `unsigned short', as computed by sizeof. */+#define SIZEOF_UNSIGNED_SHORT 2++/* The size of `void *', as computed by sizeof. */+#define SIZEOF_VOID_P 8++/* If using the C implementation of alloca, define if you know the+   direction of stack growth for your system; otherwise it will be+   automatically deduced at runtime.+	STACK_DIRECTION > 0 => grows toward higher addresses+	STACK_DIRECTION < 0 => grows toward lower addresses+	STACK_DIRECTION = 0 => direction of growth unknown */+/* #undef STACK_DIRECTION */++/* Define to 1 if you have the ANSI C header files. */+#define STDC_HEADERS 1++/* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */+#define TIME_WITH_SYS_TIME 1++/* Enable single heap address space support */+#define USE_LARGE_ADDRESS_SPACE 1++/* Set to 1 to use libdw */+#define USE_LIBDW 0++/* Enable extensions on AIX 3, Interix.  */+#ifndef _ALL_SOURCE+# define _ALL_SOURCE 1+#endif+/* Enable GNU extensions on systems that have them.  */+#ifndef _GNU_SOURCE+# define _GNU_SOURCE 1+#endif+/* Enable threading extensions on Solaris.  */+#ifndef _POSIX_PTHREAD_SEMANTICS+# define _POSIX_PTHREAD_SEMANTICS 1+#endif+/* Enable extensions on HP NonStop.  */+#ifndef _TANDEM_SOURCE+# define _TANDEM_SOURCE 1+#endif+/* Enable general extensions on Solaris.  */+#ifndef __EXTENSIONS__+# define __EXTENSIONS__ 1+#endif+++/* Define to 1 if we can use timer_create(CLOCK_REALTIME,...) */+/* #undef USE_TIMER_CREATE */++/* Define WORDS_BIGENDIAN to 1 if your processor stores words with the most+   significant byte first (like Motorola and SPARC, unlike Intel). */+#if defined AC_APPLE_UNIVERSAL_BUILD+# if defined __BIG_ENDIAN__+#  define WORDS_BIGENDIAN 1+# endif+#else+# ifndef WORDS_BIGENDIAN+/* #  undef WORDS_BIGENDIAN */+# endif+#endif++/* Enable large inode numbers on Mac OS X 10.5.  */+#ifndef _DARWIN_USE_64_BIT_INODE+# define _DARWIN_USE_64_BIT_INODE 1+#endif++/* Number of bits in a file offset, on hosts where this is settable. */+/* #undef _FILE_OFFSET_BITS */++/* Define for large files, on AIX-style hosts. */+/* #undef _LARGE_FILES */++/* Define to 1 if on MINIX. */+/* #undef _MINIX */++/* Define to 2 if the system does not provide POSIX.1 features except with+   this defined. */+/* #undef _POSIX_1_SOURCE */++/* Define to 1 if you need to in order for `stat' and other things to work. */+/* #undef _POSIX_SOURCE */++/* ARM pre v6 */+/* #undef arm_HOST_ARCH_PRE_ARMv6 */++/* ARM pre v7 */+/* #undef arm_HOST_ARCH_PRE_ARMv7 */++/* Define to empty if `const' does not conform to ANSI C. */+/* #undef const */++/* Define to `int' if <sys/types.h> does not define. */+/* #undef pid_t */++/* The supported LLVM version number */+#define sUPPORTED_LLVM_VERSION (7,0)++/* Define to `unsigned int' if <sys/types.h> does not define. */+/* #undef size_t */++/* Define as `fork' if `vfork' does not work. */+/* #undef vfork */++#define TABLES_NEXT_TO_CODE 1++#define llvm_CC_FLAVOR 1++#define clang_CC_FLAVOR 1+#endif /* __GHCAUTOCONF_H__ */
+ ghc-lib/generated/ghcplatform.h view
@@ -0,0 +1,34 @@+#ifndef __GHCPLATFORM_H__+#define __GHCPLATFORM_H__++#define BuildPlatform_TYPE  x86_64_apple_darwin+#define HostPlatform_TYPE   x86_64_apple_darwin++#define x86_64_apple_darwin_BUILD 1+#define x86_64_apple_darwin_HOST 1++#define x86_64_BUILD_ARCH 1+#define x86_64_HOST_ARCH 1+#define BUILD_ARCH "x86_64"+#define HOST_ARCH "x86_64"++#define darwin_BUILD_OS 1+#define darwin_HOST_OS 1+#define BUILD_OS "darwin"+#define HOST_OS "darwin"++#define apple_BUILD_VENDOR 1+#define apple_HOST_VENDOR 1+#define BUILD_VENDOR "apple"+#define HOST_VENDOR "apple"++/* These TARGET macros are for backwards compatibility... DO NOT USE! */+#define TargetPlatform_TYPE x86_64_apple_darwin+#define x86_64_apple_darwin_TARGET 1+#define x86_64_TARGET_ARCH 1+#define TARGET_ARCH "x86_64"+#define darwin_TARGET_OS 1+#define TARGET_OS "darwin"+#define apple_TARGET_VENDOR 1++#endif /* __GHCPLATFORM_H__ */
+ ghc-lib/generated/ghcversion.h view
@@ -0,0 +1,19 @@+#ifndef __GHCVERSION_H__+#define __GHCVERSION_H__++#ifndef __GLASGOW_HASKELL__+# define __GLASGOW_HASKELL__ 809+#endif++#define __GLASGOW_HASKELL_PATCHLEVEL1__ 0+#define __GLASGOW_HASKELL_PATCHLEVEL2__ 20190522++#define MIN_VERSION_GLASGOW_HASKELL(ma,mi,pl1,pl2) (\+   ((ma)*100+(mi)) <  __GLASGOW_HASKELL__ || \+   ((ma)*100+(mi)) == __GLASGOW_HASKELL__    \+          && (pl1) <  __GLASGOW_HASKELL_PATCHLEVEL1__ || \+   ((ma)*100+(mi)) == __GLASGOW_HASKELL__    \+          && (pl1) == __GLASGOW_HASKELL_PATCHLEVEL1__ \+          && (pl2) <= __GLASGOW_HASKELL_PATCHLEVEL2__ )++#endif /* __GHCVERSION_H__ */
+ ghc-lib/stage1/compiler/build/ghc_boot_platform.h view
@@ -0,0 +1,33 @@+#ifndef __PLATFORM_H__+#define __PLATFORM_H__++#define BuildPlatform_NAME  "x86_64-apple-darwin"+#define HostPlatform_NAME   "x86_64-apple-darwin"++#define x86_64_apple_darwin_BUILD 1+#define x86_64_apple_darwin_HOST 1+#define x86_64_apple_darwin_TARGET 1++#define x86_64_BUILD_ARCH 1+#define x86_64_HOST_ARCH 1+#define x86_64_TARGET_ARCH 1+#define BUILD_ARCH "x86_64"+#define HOST_ARCH "x86_64"+#define TARGET_ARCH "x86_64"+#define LLVM_TARGET "x86_64-apple-darwin"++#define darwin_BUILD_OS 1+#define darwin_HOST_OS 1+#define darwin_TARGET_OS 1+#define BUILD_OS "darwin"+#define HOST_OS "darwin"+#define TARGET_OS "darwin"++#define apple_BUILD_VENDOR 1+#define apple_HOST_VENDOR 1+#define apple_TARGET_VENDOR  1+#define BUILD_VENDOR "apple"+#define HOST_VENDOR "apple"+#define TARGET_VENDOR "apple"++#endif /* __PLATFORM_H__ */
+ ghc-lib/stage1/compiler/build/primop-can-fail.hs-incl view
@@ -0,0 +1,231 @@+primOpCanFail IntQuotOp = True+primOpCanFail IntRemOp = True+primOpCanFail IntQuotRemOp = True+primOpCanFail Int8QuotOp = True+primOpCanFail Int8RemOp = True+primOpCanFail Int8QuotRemOp = True+primOpCanFail Word8QuotOp = True+primOpCanFail Word8RemOp = True+primOpCanFail Word8QuotRemOp = True+primOpCanFail Int16QuotOp = True+primOpCanFail Int16RemOp = True+primOpCanFail Int16QuotRemOp = True+primOpCanFail Word16QuotOp = True+primOpCanFail Word16RemOp = True+primOpCanFail Word16QuotRemOp = True+primOpCanFail WordQuotOp = True+primOpCanFail WordRemOp = True+primOpCanFail WordQuotRemOp = True+primOpCanFail WordQuotRem2Op = True+primOpCanFail DoubleDivOp = True+primOpCanFail DoubleLogOp = True+primOpCanFail DoubleAsinOp = True+primOpCanFail DoubleAcosOp = True+primOpCanFail FloatDivOp = True+primOpCanFail FloatLogOp = True+primOpCanFail FloatAsinOp = True+primOpCanFail FloatAcosOp = True+primOpCanFail ReadArrayOp = True+primOpCanFail WriteArrayOp = True+primOpCanFail IndexArrayOp = True+primOpCanFail CopyArrayOp = True+primOpCanFail CopyMutableArrayOp = True+primOpCanFail CloneArrayOp = True+primOpCanFail CloneMutableArrayOp = True+primOpCanFail FreezeArrayOp = True+primOpCanFail ThawArrayOp = True+primOpCanFail ReadSmallArrayOp = True+primOpCanFail WriteSmallArrayOp = True+primOpCanFail IndexSmallArrayOp = True+primOpCanFail CopySmallArrayOp = True+primOpCanFail CopySmallMutableArrayOp = True+primOpCanFail CloneSmallArrayOp = True+primOpCanFail CloneSmallMutableArrayOp = True+primOpCanFail FreezeSmallArrayOp = True+primOpCanFail ThawSmallArrayOp = True+primOpCanFail IndexByteArrayOp_Char = True+primOpCanFail IndexByteArrayOp_WideChar = True+primOpCanFail IndexByteArrayOp_Int = True+primOpCanFail IndexByteArrayOp_Word = True+primOpCanFail IndexByteArrayOp_Addr = True+primOpCanFail IndexByteArrayOp_Float = True+primOpCanFail IndexByteArrayOp_Double = True+primOpCanFail IndexByteArrayOp_StablePtr = True+primOpCanFail IndexByteArrayOp_Int8 = True+primOpCanFail IndexByteArrayOp_Int16 = True+primOpCanFail IndexByteArrayOp_Int32 = True+primOpCanFail IndexByteArrayOp_Int64 = True+primOpCanFail IndexByteArrayOp_Word8 = True+primOpCanFail IndexByteArrayOp_Word16 = True+primOpCanFail IndexByteArrayOp_Word32 = True+primOpCanFail IndexByteArrayOp_Word64 = True+primOpCanFail IndexByteArrayOp_Word8AsChar = True+primOpCanFail IndexByteArrayOp_Word8AsWideChar = True+primOpCanFail IndexByteArrayOp_Word8AsAddr = True+primOpCanFail IndexByteArrayOp_Word8AsFloat = True+primOpCanFail IndexByteArrayOp_Word8AsDouble = True+primOpCanFail IndexByteArrayOp_Word8AsStablePtr = True+primOpCanFail IndexByteArrayOp_Word8AsInt16 = True+primOpCanFail IndexByteArrayOp_Word8AsInt32 = True+primOpCanFail IndexByteArrayOp_Word8AsInt64 = True+primOpCanFail IndexByteArrayOp_Word8AsInt = True+primOpCanFail IndexByteArrayOp_Word8AsWord16 = True+primOpCanFail IndexByteArrayOp_Word8AsWord32 = True+primOpCanFail IndexByteArrayOp_Word8AsWord64 = True+primOpCanFail IndexByteArrayOp_Word8AsWord = True+primOpCanFail ReadByteArrayOp_Char = True+primOpCanFail ReadByteArrayOp_WideChar = True+primOpCanFail ReadByteArrayOp_Int = True+primOpCanFail ReadByteArrayOp_Word = True+primOpCanFail ReadByteArrayOp_Addr = True+primOpCanFail ReadByteArrayOp_Float = True+primOpCanFail ReadByteArrayOp_Double = True+primOpCanFail ReadByteArrayOp_StablePtr = True+primOpCanFail ReadByteArrayOp_Int8 = True+primOpCanFail ReadByteArrayOp_Int16 = True+primOpCanFail ReadByteArrayOp_Int32 = True+primOpCanFail ReadByteArrayOp_Int64 = True+primOpCanFail ReadByteArrayOp_Word8 = True+primOpCanFail ReadByteArrayOp_Word16 = True+primOpCanFail ReadByteArrayOp_Word32 = True+primOpCanFail ReadByteArrayOp_Word64 = True+primOpCanFail ReadByteArrayOp_Word8AsChar = True+primOpCanFail ReadByteArrayOp_Word8AsWideChar = True+primOpCanFail ReadByteArrayOp_Word8AsAddr = True+primOpCanFail ReadByteArrayOp_Word8AsFloat = True+primOpCanFail ReadByteArrayOp_Word8AsDouble = True+primOpCanFail ReadByteArrayOp_Word8AsStablePtr = True+primOpCanFail ReadByteArrayOp_Word8AsInt16 = True+primOpCanFail ReadByteArrayOp_Word8AsInt32 = True+primOpCanFail ReadByteArrayOp_Word8AsInt64 = True+primOpCanFail ReadByteArrayOp_Word8AsInt = True+primOpCanFail ReadByteArrayOp_Word8AsWord16 = True+primOpCanFail ReadByteArrayOp_Word8AsWord32 = True+primOpCanFail ReadByteArrayOp_Word8AsWord64 = True+primOpCanFail ReadByteArrayOp_Word8AsWord = True+primOpCanFail WriteByteArrayOp_Char = True+primOpCanFail WriteByteArrayOp_WideChar = True+primOpCanFail WriteByteArrayOp_Int = True+primOpCanFail WriteByteArrayOp_Word = True+primOpCanFail WriteByteArrayOp_Addr = True+primOpCanFail WriteByteArrayOp_Float = True+primOpCanFail WriteByteArrayOp_Double = True+primOpCanFail WriteByteArrayOp_StablePtr = True+primOpCanFail WriteByteArrayOp_Int8 = True+primOpCanFail WriteByteArrayOp_Int16 = True+primOpCanFail WriteByteArrayOp_Int32 = True+primOpCanFail WriteByteArrayOp_Int64 = True+primOpCanFail WriteByteArrayOp_Word8 = True+primOpCanFail WriteByteArrayOp_Word16 = True+primOpCanFail WriteByteArrayOp_Word32 = True+primOpCanFail WriteByteArrayOp_Word64 = True+primOpCanFail WriteByteArrayOp_Word8AsChar = True+primOpCanFail WriteByteArrayOp_Word8AsWideChar = True+primOpCanFail WriteByteArrayOp_Word8AsAddr = True+primOpCanFail WriteByteArrayOp_Word8AsFloat = True+primOpCanFail WriteByteArrayOp_Word8AsDouble = True+primOpCanFail WriteByteArrayOp_Word8AsStablePtr = True+primOpCanFail WriteByteArrayOp_Word8AsInt16 = True+primOpCanFail WriteByteArrayOp_Word8AsInt32 = True+primOpCanFail WriteByteArrayOp_Word8AsInt64 = True+primOpCanFail WriteByteArrayOp_Word8AsInt = True+primOpCanFail WriteByteArrayOp_Word8AsWord16 = True+primOpCanFail WriteByteArrayOp_Word8AsWord32 = True+primOpCanFail WriteByteArrayOp_Word8AsWord64 = True+primOpCanFail WriteByteArrayOp_Word8AsWord = True+primOpCanFail CompareByteArraysOp = True+primOpCanFail CopyByteArrayOp = True+primOpCanFail CopyMutableByteArrayOp = True+primOpCanFail CopyByteArrayToAddrOp = True+primOpCanFail CopyMutableByteArrayToAddrOp = True+primOpCanFail CopyAddrToByteArrayOp = True+primOpCanFail SetByteArrayOp = True+primOpCanFail AtomicReadByteArrayOp_Int = True+primOpCanFail AtomicWriteByteArrayOp_Int = True+primOpCanFail CasByteArrayOp_Int = True+primOpCanFail FetchAddByteArrayOp_Int = True+primOpCanFail FetchSubByteArrayOp_Int = True+primOpCanFail FetchAndByteArrayOp_Int = True+primOpCanFail FetchNandByteArrayOp_Int = True+primOpCanFail FetchOrByteArrayOp_Int = True+primOpCanFail FetchXorByteArrayOp_Int = True+primOpCanFail IndexArrayArrayOp_ByteArray = True+primOpCanFail IndexArrayArrayOp_ArrayArray = True+primOpCanFail ReadArrayArrayOp_ByteArray = True+primOpCanFail ReadArrayArrayOp_MutableByteArray = True+primOpCanFail ReadArrayArrayOp_ArrayArray = True+primOpCanFail ReadArrayArrayOp_MutableArrayArray = True+primOpCanFail WriteArrayArrayOp_ByteArray = True+primOpCanFail WriteArrayArrayOp_MutableByteArray = True+primOpCanFail WriteArrayArrayOp_ArrayArray = True+primOpCanFail WriteArrayArrayOp_MutableArrayArray = True+primOpCanFail CopyArrayArrayOp = True+primOpCanFail CopyMutableArrayArrayOp = True+primOpCanFail IndexOffAddrOp_Char = True+primOpCanFail IndexOffAddrOp_WideChar = True+primOpCanFail IndexOffAddrOp_Int = True+primOpCanFail IndexOffAddrOp_Word = True+primOpCanFail IndexOffAddrOp_Addr = True+primOpCanFail IndexOffAddrOp_Float = True+primOpCanFail IndexOffAddrOp_Double = True+primOpCanFail IndexOffAddrOp_StablePtr = True+primOpCanFail IndexOffAddrOp_Int8 = True+primOpCanFail IndexOffAddrOp_Int16 = True+primOpCanFail IndexOffAddrOp_Int32 = True+primOpCanFail IndexOffAddrOp_Int64 = True+primOpCanFail IndexOffAddrOp_Word8 = True+primOpCanFail IndexOffAddrOp_Word16 = True+primOpCanFail IndexOffAddrOp_Word32 = True+primOpCanFail IndexOffAddrOp_Word64 = True+primOpCanFail ReadOffAddrOp_Char = True+primOpCanFail ReadOffAddrOp_WideChar = True+primOpCanFail ReadOffAddrOp_Int = True+primOpCanFail ReadOffAddrOp_Word = True+primOpCanFail ReadOffAddrOp_Addr = True+primOpCanFail ReadOffAddrOp_Float = True+primOpCanFail ReadOffAddrOp_Double = True+primOpCanFail ReadOffAddrOp_StablePtr = True+primOpCanFail ReadOffAddrOp_Int8 = True+primOpCanFail ReadOffAddrOp_Int16 = True+primOpCanFail ReadOffAddrOp_Int32 = True+primOpCanFail ReadOffAddrOp_Int64 = True+primOpCanFail ReadOffAddrOp_Word8 = True+primOpCanFail ReadOffAddrOp_Word16 = True+primOpCanFail ReadOffAddrOp_Word32 = True+primOpCanFail ReadOffAddrOp_Word64 = True+primOpCanFail WriteOffAddrOp_Char = True+primOpCanFail WriteOffAddrOp_WideChar = True+primOpCanFail WriteOffAddrOp_Int = True+primOpCanFail WriteOffAddrOp_Word = True+primOpCanFail WriteOffAddrOp_Addr = True+primOpCanFail WriteOffAddrOp_Float = True+primOpCanFail WriteOffAddrOp_Double = True+primOpCanFail WriteOffAddrOp_StablePtr = True+primOpCanFail WriteOffAddrOp_Int8 = True+primOpCanFail WriteOffAddrOp_Int16 = True+primOpCanFail WriteOffAddrOp_Int32 = True+primOpCanFail WriteOffAddrOp_Int64 = True+primOpCanFail WriteOffAddrOp_Word8 = True+primOpCanFail WriteOffAddrOp_Word16 = True+primOpCanFail WriteOffAddrOp_Word32 = True+primOpCanFail WriteOffAddrOp_Word64 = True+primOpCanFail AtomicModifyMutVar2Op = True+primOpCanFail AtomicModifyMutVar_Op = True+primOpCanFail ReallyUnsafePtrEqualityOp = True+primOpCanFail (VecInsertOp _ _ _) = True+primOpCanFail (VecDivOp _ _ _) = True+primOpCanFail (VecQuotOp _ _ _) = True+primOpCanFail (VecRemOp _ _ _) = True+primOpCanFail (VecIndexByteArrayOp _ _ _) = True+primOpCanFail (VecReadByteArrayOp _ _ _) = True+primOpCanFail (VecWriteByteArrayOp _ _ _) = True+primOpCanFail (VecIndexOffAddrOp _ _ _) = True+primOpCanFail (VecReadOffAddrOp _ _ _) = True+primOpCanFail (VecWriteOffAddrOp _ _ _) = True+primOpCanFail (VecIndexScalarByteArrayOp _ _ _) = True+primOpCanFail (VecReadScalarByteArrayOp _ _ _) = True+primOpCanFail (VecWriteScalarByteArrayOp _ _ _) = True+primOpCanFail (VecIndexScalarOffAddrOp _ _ _) = True+primOpCanFail (VecReadScalarOffAddrOp _ _ _) = True+primOpCanFail (VecWriteScalarOffAddrOp _ _ _) = True+primOpCanFail _ = False
+ ghc-lib/stage1/compiler/build/primop-code-size.hs-incl view
@@ -0,0 +1,57 @@+primOpCodeSize OrdOp = 0+primOpCodeSize IntAddCOp = 2+primOpCodeSize IntSubCOp = 2+primOpCodeSize ChrOp = 0+primOpCodeSize Int2WordOp = 0+primOpCodeSize WordAddCOp = 2+primOpCodeSize WordSubCOp = 2+primOpCodeSize WordAdd2Op = 2+primOpCodeSize Word2IntOp = 0+primOpCodeSize DoubleExpOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleLogOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleSqrtOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleSinOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleCosOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleTanOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleAsinOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleAcosOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleAtanOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleSinhOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleCoshOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleTanhOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleAsinhOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleAcoshOp =  primOpCodeSizeForeignCall +primOpCodeSize DoubleAtanhOp =  primOpCodeSizeForeignCall +primOpCodeSize DoublePowerOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatExpOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatLogOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatSqrtOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatSinOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatCosOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatTanOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatAsinOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatAcosOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatAtanOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatSinhOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatCoshOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatTanhOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatAsinhOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatAcoshOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatAtanhOp =  primOpCodeSizeForeignCall +primOpCodeSize FloatPowerOp =  primOpCodeSizeForeignCall +primOpCodeSize WriteArrayOp = 2+primOpCodeSize CopyByteArrayOp =  primOpCodeSizeForeignCall + 4+primOpCodeSize CopyMutableByteArrayOp =  primOpCodeSizeForeignCall + 4 +primOpCodeSize CopyByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4+primOpCodeSize CopyMutableByteArrayToAddrOp =  primOpCodeSizeForeignCall + 4+primOpCodeSize CopyAddrToByteArrayOp =  primOpCodeSizeForeignCall + 4+primOpCodeSize SetByteArrayOp =  primOpCodeSizeForeignCall + 4 +primOpCodeSize Addr2IntOp = 0+primOpCodeSize Int2AddrOp = 0+primOpCodeSize WriteMutVarOp =  primOpCodeSizeForeignCall +primOpCodeSize TouchOp =  0 +primOpCodeSize ParOp =  primOpCodeSizeForeignCall +primOpCodeSize SparkOp =  primOpCodeSizeForeignCall +primOpCodeSize AddrToAnyOp = 0+primOpCodeSize AnyToAddrOp = 0+primOpCodeSize _ =  primOpCodeSizeDefault
+ ghc-lib/stage1/compiler/build/primop-commutable.hs-incl view
@@ -0,0 +1,38 @@+commutableOp CharEqOp = True+commutableOp CharNeOp = True+commutableOp IntAddOp = True+commutableOp IntMulOp = True+commutableOp IntMulMayOfloOp = True+commutableOp AndIOp = True+commutableOp OrIOp = True+commutableOp XorIOp = True+commutableOp IntAddCOp = True+commutableOp IntEqOp = True+commutableOp IntNeOp = True+commutableOp Int8AddOp = True+commutableOp Int8MulOp = True+commutableOp Word8AddOp = True+commutableOp Word8MulOp = True+commutableOp Int16AddOp = True+commutableOp Int16MulOp = True+commutableOp Word16AddOp = True+commutableOp Word16MulOp = True+commutableOp WordAddOp = True+commutableOp WordAddCOp = True+commutableOp WordAdd2Op = True+commutableOp WordMulOp = True+commutableOp WordMul2Op = True+commutableOp AndOp = True+commutableOp OrOp = True+commutableOp XorOp = True+commutableOp DoubleEqOp = True+commutableOp DoubleNeOp = True+commutableOp DoubleAddOp = True+commutableOp DoubleMulOp = True+commutableOp FloatEqOp = True+commutableOp FloatNeOp = True+commutableOp FloatAddOp = True+commutableOp FloatMulOp = True+commutableOp (VecAddOp _ _ _) = True+commutableOp (VecMulOp _ _ _) = True+commutableOp _ = False
+ ghc-lib/stage1/compiler/build/primop-data-decl.hs-incl view
@@ -0,0 +1,580 @@+data PrimOp+   = CharGtOp+   | CharGeOp+   | CharEqOp+   | CharNeOp+   | CharLtOp+   | CharLeOp+   | OrdOp+   | IntAddOp+   | IntSubOp+   | IntMulOp+   | IntMulMayOfloOp+   | IntQuotOp+   | IntRemOp+   | IntQuotRemOp+   | AndIOp+   | OrIOp+   | XorIOp+   | NotIOp+   | IntNegOp+   | IntAddCOp+   | IntSubCOp+   | IntGtOp+   | IntGeOp+   | IntEqOp+   | IntNeOp+   | IntLtOp+   | IntLeOp+   | ChrOp+   | Int2WordOp+   | Int2FloatOp+   | Int2DoubleOp+   | Word2FloatOp+   | Word2DoubleOp+   | ISllOp+   | ISraOp+   | ISrlOp+   | Int8Extend+   | Int8Narrow+   | Int8NegOp+   | Int8AddOp+   | Int8SubOp+   | Int8MulOp+   | Int8QuotOp+   | Int8RemOp+   | Int8QuotRemOp+   | Int8EqOp+   | Int8GeOp+   | Int8GtOp+   | Int8LeOp+   | Int8LtOp+   | Int8NeOp+   | Word8Extend+   | Word8Narrow+   | Word8NotOp+   | Word8AddOp+   | Word8SubOp+   | Word8MulOp+   | Word8QuotOp+   | Word8RemOp+   | Word8QuotRemOp+   | Word8EqOp+   | Word8GeOp+   | Word8GtOp+   | Word8LeOp+   | Word8LtOp+   | Word8NeOp+   | Int16Extend+   | Int16Narrow+   | Int16NegOp+   | Int16AddOp+   | Int16SubOp+   | Int16MulOp+   | Int16QuotOp+   | Int16RemOp+   | Int16QuotRemOp+   | Int16EqOp+   | Int16GeOp+   | Int16GtOp+   | Int16LeOp+   | Int16LtOp+   | Int16NeOp+   | Word16Extend+   | Word16Narrow+   | Word16NotOp+   | Word16AddOp+   | Word16SubOp+   | Word16MulOp+   | Word16QuotOp+   | Word16RemOp+   | Word16QuotRemOp+   | Word16EqOp+   | Word16GeOp+   | Word16GtOp+   | Word16LeOp+   | Word16LtOp+   | Word16NeOp+   | WordAddOp+   | WordAddCOp+   | WordSubCOp+   | WordAdd2Op+   | WordSubOp+   | WordMulOp+   | WordMul2Op+   | WordQuotOp+   | WordRemOp+   | WordQuotRemOp+   | WordQuotRem2Op+   | AndOp+   | OrOp+   | XorOp+   | NotOp+   | SllOp+   | SrlOp+   | Word2IntOp+   | WordGtOp+   | WordGeOp+   | WordEqOp+   | WordNeOp+   | WordLtOp+   | WordLeOp+   | PopCnt8Op+   | PopCnt16Op+   | PopCnt32Op+   | PopCnt64Op+   | PopCntOp+   | Pdep8Op+   | Pdep16Op+   | Pdep32Op+   | Pdep64Op+   | PdepOp+   | Pext8Op+   | Pext16Op+   | Pext32Op+   | Pext64Op+   | PextOp+   | Clz8Op+   | Clz16Op+   | Clz32Op+   | Clz64Op+   | ClzOp+   | Ctz8Op+   | Ctz16Op+   | Ctz32Op+   | Ctz64Op+   | CtzOp+   | BSwap16Op+   | BSwap32Op+   | BSwap64Op+   | BSwapOp+   | BRev8Op+   | BRev16Op+   | BRev32Op+   | BRev64Op+   | BRevOp+   | Narrow8IntOp+   | Narrow16IntOp+   | Narrow32IntOp+   | Narrow8WordOp+   | Narrow16WordOp+   | Narrow32WordOp+   | DoubleGtOp+   | DoubleGeOp+   | DoubleEqOp+   | DoubleNeOp+   | DoubleLtOp+   | DoubleLeOp+   | DoubleAddOp+   | DoubleSubOp+   | DoubleMulOp+   | DoubleDivOp+   | DoubleNegOp+   | DoubleFabsOp+   | Double2IntOp+   | Double2FloatOp+   | DoubleExpOp+   | DoubleLogOp+   | DoubleSqrtOp+   | DoubleSinOp+   | DoubleCosOp+   | DoubleTanOp+   | DoubleAsinOp+   | DoubleAcosOp+   | DoubleAtanOp+   | DoubleSinhOp+   | DoubleCoshOp+   | DoubleTanhOp+   | DoubleAsinhOp+   | DoubleAcoshOp+   | DoubleAtanhOp+   | DoublePowerOp+   | DoubleDecode_2IntOp+   | DoubleDecode_Int64Op+   | FloatGtOp+   | FloatGeOp+   | FloatEqOp+   | FloatNeOp+   | FloatLtOp+   | FloatLeOp+   | FloatAddOp+   | FloatSubOp+   | FloatMulOp+   | FloatDivOp+   | FloatNegOp+   | FloatFabsOp+   | Float2IntOp+   | FloatExpOp+   | FloatLogOp+   | FloatSqrtOp+   | FloatSinOp+   | FloatCosOp+   | FloatTanOp+   | FloatAsinOp+   | FloatAcosOp+   | FloatAtanOp+   | FloatSinhOp+   | FloatCoshOp+   | FloatTanhOp+   | FloatAsinhOp+   | FloatAcoshOp+   | FloatAtanhOp+   | FloatPowerOp+   | Float2DoubleOp+   | FloatDecode_IntOp+   | NewArrayOp+   | SameMutableArrayOp+   | ReadArrayOp+   | WriteArrayOp+   | SizeofArrayOp+   | SizeofMutableArrayOp+   | IndexArrayOp+   | UnsafeFreezeArrayOp+   | UnsafeThawArrayOp+   | CopyArrayOp+   | CopyMutableArrayOp+   | CloneArrayOp+   | CloneMutableArrayOp+   | FreezeArrayOp+   | ThawArrayOp+   | CasArrayOp+   | NewSmallArrayOp+   | SameSmallMutableArrayOp+   | ReadSmallArrayOp+   | WriteSmallArrayOp+   | SizeofSmallArrayOp+   | SizeofSmallMutableArrayOp+   | IndexSmallArrayOp+   | UnsafeFreezeSmallArrayOp+   | UnsafeThawSmallArrayOp+   | CopySmallArrayOp+   | CopySmallMutableArrayOp+   | CloneSmallArrayOp+   | CloneSmallMutableArrayOp+   | FreezeSmallArrayOp+   | ThawSmallArrayOp+   | CasSmallArrayOp+   | NewByteArrayOp_Char+   | NewPinnedByteArrayOp_Char+   | NewAlignedPinnedByteArrayOp_Char+   | MutableByteArrayIsPinnedOp+   | ByteArrayIsPinnedOp+   | ByteArrayContents_Char+   | SameMutableByteArrayOp+   | ShrinkMutableByteArrayOp_Char+   | ResizeMutableByteArrayOp_Char+   | UnsafeFreezeByteArrayOp+   | SizeofByteArrayOp+   | SizeofMutableByteArrayOp+   | GetSizeofMutableByteArrayOp+   | IndexByteArrayOp_Char+   | IndexByteArrayOp_WideChar+   | IndexByteArrayOp_Int+   | IndexByteArrayOp_Word+   | IndexByteArrayOp_Addr+   | IndexByteArrayOp_Float+   | IndexByteArrayOp_Double+   | IndexByteArrayOp_StablePtr+   | IndexByteArrayOp_Int8+   | IndexByteArrayOp_Int16+   | IndexByteArrayOp_Int32+   | IndexByteArrayOp_Int64+   | IndexByteArrayOp_Word8+   | IndexByteArrayOp_Word16+   | IndexByteArrayOp_Word32+   | IndexByteArrayOp_Word64+   | IndexByteArrayOp_Word8AsChar+   | IndexByteArrayOp_Word8AsWideChar+   | IndexByteArrayOp_Word8AsAddr+   | IndexByteArrayOp_Word8AsFloat+   | IndexByteArrayOp_Word8AsDouble+   | IndexByteArrayOp_Word8AsStablePtr+   | IndexByteArrayOp_Word8AsInt16+   | IndexByteArrayOp_Word8AsInt32+   | IndexByteArrayOp_Word8AsInt64+   | IndexByteArrayOp_Word8AsInt+   | IndexByteArrayOp_Word8AsWord16+   | IndexByteArrayOp_Word8AsWord32+   | IndexByteArrayOp_Word8AsWord64+   | IndexByteArrayOp_Word8AsWord+   | ReadByteArrayOp_Char+   | ReadByteArrayOp_WideChar+   | ReadByteArrayOp_Int+   | ReadByteArrayOp_Word+   | ReadByteArrayOp_Addr+   | ReadByteArrayOp_Float+   | ReadByteArrayOp_Double+   | ReadByteArrayOp_StablePtr+   | ReadByteArrayOp_Int8+   | ReadByteArrayOp_Int16+   | ReadByteArrayOp_Int32+   | ReadByteArrayOp_Int64+   | ReadByteArrayOp_Word8+   | ReadByteArrayOp_Word16+   | ReadByteArrayOp_Word32+   | ReadByteArrayOp_Word64+   | ReadByteArrayOp_Word8AsChar+   | ReadByteArrayOp_Word8AsWideChar+   | ReadByteArrayOp_Word8AsAddr+   | ReadByteArrayOp_Word8AsFloat+   | ReadByteArrayOp_Word8AsDouble+   | ReadByteArrayOp_Word8AsStablePtr+   | ReadByteArrayOp_Word8AsInt16+   | ReadByteArrayOp_Word8AsInt32+   | ReadByteArrayOp_Word8AsInt64+   | ReadByteArrayOp_Word8AsInt+   | ReadByteArrayOp_Word8AsWord16+   | ReadByteArrayOp_Word8AsWord32+   | ReadByteArrayOp_Word8AsWord64+   | ReadByteArrayOp_Word8AsWord+   | WriteByteArrayOp_Char+   | WriteByteArrayOp_WideChar+   | WriteByteArrayOp_Int+   | WriteByteArrayOp_Word+   | WriteByteArrayOp_Addr+   | WriteByteArrayOp_Float+   | WriteByteArrayOp_Double+   | WriteByteArrayOp_StablePtr+   | WriteByteArrayOp_Int8+   | WriteByteArrayOp_Int16+   | WriteByteArrayOp_Int32+   | WriteByteArrayOp_Int64+   | WriteByteArrayOp_Word8+   | WriteByteArrayOp_Word16+   | WriteByteArrayOp_Word32+   | WriteByteArrayOp_Word64+   | WriteByteArrayOp_Word8AsChar+   | WriteByteArrayOp_Word8AsWideChar+   | WriteByteArrayOp_Word8AsAddr+   | WriteByteArrayOp_Word8AsFloat+   | WriteByteArrayOp_Word8AsDouble+   | WriteByteArrayOp_Word8AsStablePtr+   | WriteByteArrayOp_Word8AsInt16+   | WriteByteArrayOp_Word8AsInt32+   | WriteByteArrayOp_Word8AsInt64+   | WriteByteArrayOp_Word8AsInt+   | WriteByteArrayOp_Word8AsWord16+   | WriteByteArrayOp_Word8AsWord32+   | WriteByteArrayOp_Word8AsWord64+   | WriteByteArrayOp_Word8AsWord+   | CompareByteArraysOp+   | CopyByteArrayOp+   | CopyMutableByteArrayOp+   | CopyByteArrayToAddrOp+   | CopyMutableByteArrayToAddrOp+   | CopyAddrToByteArrayOp+   | SetByteArrayOp+   | AtomicReadByteArrayOp_Int+   | AtomicWriteByteArrayOp_Int+   | CasByteArrayOp_Int+   | FetchAddByteArrayOp_Int+   | FetchSubByteArrayOp_Int+   | FetchAndByteArrayOp_Int+   | FetchNandByteArrayOp_Int+   | FetchOrByteArrayOp_Int+   | FetchXorByteArrayOp_Int+   | NewArrayArrayOp+   | SameMutableArrayArrayOp+   | UnsafeFreezeArrayArrayOp+   | SizeofArrayArrayOp+   | SizeofMutableArrayArrayOp+   | IndexArrayArrayOp_ByteArray+   | IndexArrayArrayOp_ArrayArray+   | ReadArrayArrayOp_ByteArray+   | ReadArrayArrayOp_MutableByteArray+   | ReadArrayArrayOp_ArrayArray+   | ReadArrayArrayOp_MutableArrayArray+   | WriteArrayArrayOp_ByteArray+   | WriteArrayArrayOp_MutableByteArray+   | WriteArrayArrayOp_ArrayArray+   | WriteArrayArrayOp_MutableArrayArray+   | CopyArrayArrayOp+   | CopyMutableArrayArrayOp+   | AddrAddOp+   | AddrSubOp+   | AddrRemOp+   | Addr2IntOp+   | Int2AddrOp+   | AddrGtOp+   | AddrGeOp+   | AddrEqOp+   | AddrNeOp+   | AddrLtOp+   | AddrLeOp+   | IndexOffAddrOp_Char+   | IndexOffAddrOp_WideChar+   | IndexOffAddrOp_Int+   | IndexOffAddrOp_Word+   | IndexOffAddrOp_Addr+   | IndexOffAddrOp_Float+   | IndexOffAddrOp_Double+   | IndexOffAddrOp_StablePtr+   | IndexOffAddrOp_Int8+   | IndexOffAddrOp_Int16+   | IndexOffAddrOp_Int32+   | IndexOffAddrOp_Int64+   | IndexOffAddrOp_Word8+   | IndexOffAddrOp_Word16+   | IndexOffAddrOp_Word32+   | IndexOffAddrOp_Word64+   | ReadOffAddrOp_Char+   | ReadOffAddrOp_WideChar+   | ReadOffAddrOp_Int+   | ReadOffAddrOp_Word+   | ReadOffAddrOp_Addr+   | ReadOffAddrOp_Float+   | ReadOffAddrOp_Double+   | ReadOffAddrOp_StablePtr+   | ReadOffAddrOp_Int8+   | ReadOffAddrOp_Int16+   | ReadOffAddrOp_Int32+   | ReadOffAddrOp_Int64+   | ReadOffAddrOp_Word8+   | ReadOffAddrOp_Word16+   | ReadOffAddrOp_Word32+   | ReadOffAddrOp_Word64+   | WriteOffAddrOp_Char+   | WriteOffAddrOp_WideChar+   | WriteOffAddrOp_Int+   | WriteOffAddrOp_Word+   | WriteOffAddrOp_Addr+   | WriteOffAddrOp_Float+   | WriteOffAddrOp_Double+   | WriteOffAddrOp_StablePtr+   | WriteOffAddrOp_Int8+   | WriteOffAddrOp_Int16+   | WriteOffAddrOp_Int32+   | WriteOffAddrOp_Int64+   | WriteOffAddrOp_Word8+   | WriteOffAddrOp_Word16+   | WriteOffAddrOp_Word32+   | WriteOffAddrOp_Word64+   | NewMutVarOp+   | ReadMutVarOp+   | WriteMutVarOp+   | SameMutVarOp+   | AtomicModifyMutVar2Op+   | AtomicModifyMutVar_Op+   | CasMutVarOp+   | CatchOp+   | RaiseOp+   | RaiseIOOp+   | MaskAsyncExceptionsOp+   | MaskUninterruptibleOp+   | UnmaskAsyncExceptionsOp+   | MaskStatus+   | AtomicallyOp+   | RetryOp+   | CatchRetryOp+   | CatchSTMOp+   | NewTVarOp+   | ReadTVarOp+   | ReadTVarIOOp+   | WriteTVarOp+   | SameTVarOp+   | NewMVarOp+   | TakeMVarOp+   | TryTakeMVarOp+   | PutMVarOp+   | TryPutMVarOp+   | ReadMVarOp+   | TryReadMVarOp+   | SameMVarOp+   | IsEmptyMVarOp+   | DelayOp+   | WaitReadOp+   | WaitWriteOp+   | ForkOp+   | ForkOnOp+   | KillThreadOp+   | YieldOp+   | MyThreadIdOp+   | LabelThreadOp+   | IsCurrentThreadBoundOp+   | NoDuplicateOp+   | ThreadStatusOp+   | MkWeakOp+   | MkWeakNoFinalizerOp+   | AddCFinalizerToWeakOp+   | DeRefWeakOp+   | FinalizeWeakOp+   | TouchOp+   | MakeStablePtrOp+   | DeRefStablePtrOp+   | EqStablePtrOp+   | MakeStableNameOp+   | EqStableNameOp+   | StableNameToIntOp+   | CompactNewOp+   | CompactResizeOp+   | CompactContainsOp+   | CompactContainsAnyOp+   | CompactGetFirstBlockOp+   | CompactGetNextBlockOp+   | CompactAllocateBlockOp+   | CompactFixupPointersOp+   | CompactAdd+   | CompactAddWithSharing+   | CompactSize+   | ReallyUnsafePtrEqualityOp+   | ParOp+   | SparkOp+   | SeqOp+   | GetSparkOp+   | NumSparks+   | DataToTagOp+   | TagToEnumOp+   | AddrToAnyOp+   | AnyToAddrOp+   | MkApUpd0_Op+   | NewBCOOp+   | UnpackClosureOp+   | ClosureSizeOp+   | GetApStackValOp+   | GetCCSOfOp+   | GetCurrentCCSOp+   | ClearCCSOp+   | TraceEventOp+   | TraceEventBinaryOp+   | TraceMarkerOp+   | GetThreadAllocationCounter+   | SetThreadAllocationCounter+   | VecBroadcastOp PrimOpVecCat Length Width+   | VecPackOp PrimOpVecCat Length Width+   | VecUnpackOp PrimOpVecCat Length Width+   | VecInsertOp PrimOpVecCat Length Width+   | VecAddOp PrimOpVecCat Length Width+   | VecSubOp PrimOpVecCat Length Width+   | VecMulOp PrimOpVecCat Length Width+   | VecDivOp PrimOpVecCat Length Width+   | VecQuotOp PrimOpVecCat Length Width+   | VecRemOp PrimOpVecCat Length Width+   | VecNegOp PrimOpVecCat Length Width+   | VecIndexByteArrayOp PrimOpVecCat Length Width+   | VecReadByteArrayOp PrimOpVecCat Length Width+   | VecWriteByteArrayOp PrimOpVecCat Length Width+   | VecIndexOffAddrOp PrimOpVecCat Length Width+   | VecReadOffAddrOp PrimOpVecCat Length Width+   | VecWriteOffAddrOp PrimOpVecCat Length Width+   | VecIndexScalarByteArrayOp PrimOpVecCat Length Width+   | VecReadScalarByteArrayOp PrimOpVecCat Length Width+   | VecWriteScalarByteArrayOp PrimOpVecCat Length Width+   | VecIndexScalarOffAddrOp PrimOpVecCat Length Width+   | VecReadScalarOffAddrOp PrimOpVecCat Length Width+   | VecWriteScalarOffAddrOp PrimOpVecCat Length Width+   | PrefetchByteArrayOp3+   | PrefetchMutableByteArrayOp3+   | PrefetchAddrOp3+   | PrefetchValueOp3+   | PrefetchByteArrayOp2+   | PrefetchMutableByteArrayOp2+   | PrefetchAddrOp2+   | PrefetchValueOp2+   | PrefetchByteArrayOp1+   | PrefetchMutableByteArrayOp1+   | PrefetchAddrOp1+   | PrefetchValueOp1+   | PrefetchByteArrayOp0+   | PrefetchMutableByteArrayOp0+   | PrefetchAddrOp0+   | PrefetchValueOp0
+ ghc-lib/stage1/compiler/build/primop-fixity.hs-incl view
@@ -0,0 +1,20 @@+primOpFixity IntAddOp = Just (Fixity NoSourceText 6 InfixL)+primOpFixity IntSubOp = Just (Fixity NoSourceText 6 InfixL)+primOpFixity IntMulOp = Just (Fixity NoSourceText 7 InfixL)+primOpFixity IntGtOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity IntGeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity IntEqOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity IntNeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity IntLtOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity IntLeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleGtOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleGeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleEqOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleNeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleLtOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleLeOp = Just (Fixity NoSourceText 4 InfixN)+primOpFixity DoubleAddOp = Just (Fixity NoSourceText 6 InfixL)+primOpFixity DoubleSubOp = Just (Fixity NoSourceText 6 InfixL)+primOpFixity DoubleMulOp = Just (Fixity NoSourceText 7 InfixL)+primOpFixity DoubleDivOp = Just (Fixity NoSourceText 7 InfixL)+primOpFixity _ = Nothing
+ ghc-lib/stage1/compiler/build/primop-has-side-effects.hs-incl view
@@ -0,0 +1,242 @@+primOpHasSideEffects NewArrayOp = True+primOpHasSideEffects ReadArrayOp = True+primOpHasSideEffects WriteArrayOp = True+primOpHasSideEffects UnsafeFreezeArrayOp = True+primOpHasSideEffects UnsafeThawArrayOp = True+primOpHasSideEffects CopyArrayOp = True+primOpHasSideEffects CopyMutableArrayOp = True+primOpHasSideEffects CloneArrayOp = True+primOpHasSideEffects CloneMutableArrayOp = True+primOpHasSideEffects FreezeArrayOp = True+primOpHasSideEffects ThawArrayOp = True+primOpHasSideEffects CasArrayOp = True+primOpHasSideEffects NewSmallArrayOp = True+primOpHasSideEffects ReadSmallArrayOp = True+primOpHasSideEffects WriteSmallArrayOp = True+primOpHasSideEffects UnsafeFreezeSmallArrayOp = True+primOpHasSideEffects UnsafeThawSmallArrayOp = True+primOpHasSideEffects CopySmallArrayOp = True+primOpHasSideEffects CopySmallMutableArrayOp = True+primOpHasSideEffects CloneSmallArrayOp = True+primOpHasSideEffects CloneSmallMutableArrayOp = True+primOpHasSideEffects FreezeSmallArrayOp = True+primOpHasSideEffects ThawSmallArrayOp = True+primOpHasSideEffects CasSmallArrayOp = True+primOpHasSideEffects NewByteArrayOp_Char = True+primOpHasSideEffects NewPinnedByteArrayOp_Char = True+primOpHasSideEffects NewAlignedPinnedByteArrayOp_Char = True+primOpHasSideEffects ShrinkMutableByteArrayOp_Char = True+primOpHasSideEffects ResizeMutableByteArrayOp_Char = True+primOpHasSideEffects UnsafeFreezeByteArrayOp = True+primOpHasSideEffects ReadByteArrayOp_Char = True+primOpHasSideEffects ReadByteArrayOp_WideChar = True+primOpHasSideEffects ReadByteArrayOp_Int = True+primOpHasSideEffects ReadByteArrayOp_Word = True+primOpHasSideEffects ReadByteArrayOp_Addr = True+primOpHasSideEffects ReadByteArrayOp_Float = True+primOpHasSideEffects ReadByteArrayOp_Double = True+primOpHasSideEffects ReadByteArrayOp_StablePtr = True+primOpHasSideEffects ReadByteArrayOp_Int8 = True+primOpHasSideEffects ReadByteArrayOp_Int16 = True+primOpHasSideEffects ReadByteArrayOp_Int32 = True+primOpHasSideEffects ReadByteArrayOp_Int64 = True+primOpHasSideEffects ReadByteArrayOp_Word8 = True+primOpHasSideEffects ReadByteArrayOp_Word16 = True+primOpHasSideEffects ReadByteArrayOp_Word32 = True+primOpHasSideEffects ReadByteArrayOp_Word64 = True+primOpHasSideEffects ReadByteArrayOp_Word8AsChar = True+primOpHasSideEffects ReadByteArrayOp_Word8AsWideChar = True+primOpHasSideEffects ReadByteArrayOp_Word8AsAddr = True+primOpHasSideEffects ReadByteArrayOp_Word8AsFloat = True+primOpHasSideEffects ReadByteArrayOp_Word8AsDouble = True+primOpHasSideEffects ReadByteArrayOp_Word8AsStablePtr = True+primOpHasSideEffects ReadByteArrayOp_Word8AsInt16 = True+primOpHasSideEffects ReadByteArrayOp_Word8AsInt32 = True+primOpHasSideEffects ReadByteArrayOp_Word8AsInt64 = True+primOpHasSideEffects ReadByteArrayOp_Word8AsInt = True+primOpHasSideEffects ReadByteArrayOp_Word8AsWord16 = True+primOpHasSideEffects ReadByteArrayOp_Word8AsWord32 = True+primOpHasSideEffects ReadByteArrayOp_Word8AsWord64 = True+primOpHasSideEffects ReadByteArrayOp_Word8AsWord = True+primOpHasSideEffects WriteByteArrayOp_Char = True+primOpHasSideEffects WriteByteArrayOp_WideChar = True+primOpHasSideEffects WriteByteArrayOp_Int = True+primOpHasSideEffects WriteByteArrayOp_Word = True+primOpHasSideEffects WriteByteArrayOp_Addr = True+primOpHasSideEffects WriteByteArrayOp_Float = True+primOpHasSideEffects WriteByteArrayOp_Double = True+primOpHasSideEffects WriteByteArrayOp_StablePtr = True+primOpHasSideEffects WriteByteArrayOp_Int8 = True+primOpHasSideEffects WriteByteArrayOp_Int16 = True+primOpHasSideEffects WriteByteArrayOp_Int32 = True+primOpHasSideEffects WriteByteArrayOp_Int64 = True+primOpHasSideEffects WriteByteArrayOp_Word8 = True+primOpHasSideEffects WriteByteArrayOp_Word16 = True+primOpHasSideEffects WriteByteArrayOp_Word32 = True+primOpHasSideEffects WriteByteArrayOp_Word64 = True+primOpHasSideEffects WriteByteArrayOp_Word8AsChar = True+primOpHasSideEffects WriteByteArrayOp_Word8AsWideChar = True+primOpHasSideEffects WriteByteArrayOp_Word8AsAddr = True+primOpHasSideEffects WriteByteArrayOp_Word8AsFloat = True+primOpHasSideEffects WriteByteArrayOp_Word8AsDouble = True+primOpHasSideEffects WriteByteArrayOp_Word8AsStablePtr = True+primOpHasSideEffects WriteByteArrayOp_Word8AsInt16 = True+primOpHasSideEffects WriteByteArrayOp_Word8AsInt32 = True+primOpHasSideEffects WriteByteArrayOp_Word8AsInt64 = True+primOpHasSideEffects WriteByteArrayOp_Word8AsInt = True+primOpHasSideEffects WriteByteArrayOp_Word8AsWord16 = True+primOpHasSideEffects WriteByteArrayOp_Word8AsWord32 = True+primOpHasSideEffects WriteByteArrayOp_Word8AsWord64 = True+primOpHasSideEffects WriteByteArrayOp_Word8AsWord = True+primOpHasSideEffects CopyByteArrayOp = True+primOpHasSideEffects CopyMutableByteArrayOp = True+primOpHasSideEffects CopyByteArrayToAddrOp = True+primOpHasSideEffects CopyMutableByteArrayToAddrOp = True+primOpHasSideEffects CopyAddrToByteArrayOp = True+primOpHasSideEffects SetByteArrayOp = True+primOpHasSideEffects AtomicReadByteArrayOp_Int = True+primOpHasSideEffects AtomicWriteByteArrayOp_Int = True+primOpHasSideEffects CasByteArrayOp_Int = True+primOpHasSideEffects FetchAddByteArrayOp_Int = True+primOpHasSideEffects FetchSubByteArrayOp_Int = True+primOpHasSideEffects FetchAndByteArrayOp_Int = True+primOpHasSideEffects FetchNandByteArrayOp_Int = True+primOpHasSideEffects FetchOrByteArrayOp_Int = True+primOpHasSideEffects FetchXorByteArrayOp_Int = True+primOpHasSideEffects NewArrayArrayOp = True+primOpHasSideEffects UnsafeFreezeArrayArrayOp = True+primOpHasSideEffects ReadArrayArrayOp_ByteArray = True+primOpHasSideEffects ReadArrayArrayOp_MutableByteArray = True+primOpHasSideEffects ReadArrayArrayOp_ArrayArray = True+primOpHasSideEffects ReadArrayArrayOp_MutableArrayArray = True+primOpHasSideEffects WriteArrayArrayOp_ByteArray = True+primOpHasSideEffects WriteArrayArrayOp_MutableByteArray = True+primOpHasSideEffects WriteArrayArrayOp_ArrayArray = True+primOpHasSideEffects WriteArrayArrayOp_MutableArrayArray = True+primOpHasSideEffects CopyArrayArrayOp = True+primOpHasSideEffects CopyMutableArrayArrayOp = True+primOpHasSideEffects ReadOffAddrOp_Char = True+primOpHasSideEffects ReadOffAddrOp_WideChar = True+primOpHasSideEffects ReadOffAddrOp_Int = True+primOpHasSideEffects ReadOffAddrOp_Word = True+primOpHasSideEffects ReadOffAddrOp_Addr = True+primOpHasSideEffects ReadOffAddrOp_Float = True+primOpHasSideEffects ReadOffAddrOp_Double = True+primOpHasSideEffects ReadOffAddrOp_StablePtr = True+primOpHasSideEffects ReadOffAddrOp_Int8 = True+primOpHasSideEffects ReadOffAddrOp_Int16 = True+primOpHasSideEffects ReadOffAddrOp_Int32 = True+primOpHasSideEffects ReadOffAddrOp_Int64 = True+primOpHasSideEffects ReadOffAddrOp_Word8 = True+primOpHasSideEffects ReadOffAddrOp_Word16 = True+primOpHasSideEffects ReadOffAddrOp_Word32 = True+primOpHasSideEffects ReadOffAddrOp_Word64 = True+primOpHasSideEffects WriteOffAddrOp_Char = True+primOpHasSideEffects WriteOffAddrOp_WideChar = True+primOpHasSideEffects WriteOffAddrOp_Int = True+primOpHasSideEffects WriteOffAddrOp_Word = True+primOpHasSideEffects WriteOffAddrOp_Addr = True+primOpHasSideEffects WriteOffAddrOp_Float = True+primOpHasSideEffects WriteOffAddrOp_Double = True+primOpHasSideEffects WriteOffAddrOp_StablePtr = True+primOpHasSideEffects WriteOffAddrOp_Int8 = True+primOpHasSideEffects WriteOffAddrOp_Int16 = True+primOpHasSideEffects WriteOffAddrOp_Int32 = True+primOpHasSideEffects WriteOffAddrOp_Int64 = True+primOpHasSideEffects WriteOffAddrOp_Word8 = True+primOpHasSideEffects WriteOffAddrOp_Word16 = True+primOpHasSideEffects WriteOffAddrOp_Word32 = True+primOpHasSideEffects WriteOffAddrOp_Word64 = True+primOpHasSideEffects NewMutVarOp = True+primOpHasSideEffects ReadMutVarOp = True+primOpHasSideEffects WriteMutVarOp = True+primOpHasSideEffects AtomicModifyMutVar2Op = True+primOpHasSideEffects AtomicModifyMutVar_Op = True+primOpHasSideEffects CasMutVarOp = True+primOpHasSideEffects CatchOp = True+primOpHasSideEffects RaiseOp = True+primOpHasSideEffects RaiseIOOp = True+primOpHasSideEffects MaskAsyncExceptionsOp = True+primOpHasSideEffects MaskUninterruptibleOp = True+primOpHasSideEffects UnmaskAsyncExceptionsOp = True+primOpHasSideEffects MaskStatus = True+primOpHasSideEffects AtomicallyOp = True+primOpHasSideEffects RetryOp = True+primOpHasSideEffects CatchRetryOp = True+primOpHasSideEffects CatchSTMOp = True+primOpHasSideEffects NewTVarOp = True+primOpHasSideEffects ReadTVarOp = True+primOpHasSideEffects ReadTVarIOOp = True+primOpHasSideEffects WriteTVarOp = True+primOpHasSideEffects NewMVarOp = True+primOpHasSideEffects TakeMVarOp = True+primOpHasSideEffects TryTakeMVarOp = True+primOpHasSideEffects PutMVarOp = True+primOpHasSideEffects TryPutMVarOp = True+primOpHasSideEffects ReadMVarOp = True+primOpHasSideEffects TryReadMVarOp = True+primOpHasSideEffects IsEmptyMVarOp = True+primOpHasSideEffects DelayOp = True+primOpHasSideEffects WaitReadOp = True+primOpHasSideEffects WaitWriteOp = True+primOpHasSideEffects ForkOp = True+primOpHasSideEffects ForkOnOp = True+primOpHasSideEffects KillThreadOp = True+primOpHasSideEffects YieldOp = True+primOpHasSideEffects MyThreadIdOp = True+primOpHasSideEffects LabelThreadOp = True+primOpHasSideEffects IsCurrentThreadBoundOp = True+primOpHasSideEffects NoDuplicateOp = True+primOpHasSideEffects ThreadStatusOp = True+primOpHasSideEffects MkWeakOp = True+primOpHasSideEffects MkWeakNoFinalizerOp = True+primOpHasSideEffects AddCFinalizerToWeakOp = True+primOpHasSideEffects DeRefWeakOp = True+primOpHasSideEffects FinalizeWeakOp = True+primOpHasSideEffects TouchOp = True+primOpHasSideEffects MakeStablePtrOp = True+primOpHasSideEffects DeRefStablePtrOp = True+primOpHasSideEffects EqStablePtrOp = True+primOpHasSideEffects MakeStableNameOp = True+primOpHasSideEffects CompactNewOp = True+primOpHasSideEffects CompactResizeOp = True+primOpHasSideEffects CompactAllocateBlockOp = True+primOpHasSideEffects CompactFixupPointersOp = True+primOpHasSideEffects CompactAdd = True+primOpHasSideEffects CompactAddWithSharing = True+primOpHasSideEffects CompactSize = True+primOpHasSideEffects ParOp = True+primOpHasSideEffects SparkOp = True+primOpHasSideEffects GetSparkOp = True+primOpHasSideEffects NumSparks = True+primOpHasSideEffects NewBCOOp = True+primOpHasSideEffects TraceEventOp = True+primOpHasSideEffects TraceEventBinaryOp = True+primOpHasSideEffects TraceMarkerOp = True+primOpHasSideEffects GetThreadAllocationCounter = True+primOpHasSideEffects SetThreadAllocationCounter = True+primOpHasSideEffects (VecReadByteArrayOp _ _ _) = True+primOpHasSideEffects (VecWriteByteArrayOp _ _ _) = True+primOpHasSideEffects (VecReadOffAddrOp _ _ _) = True+primOpHasSideEffects (VecWriteOffAddrOp _ _ _) = True+primOpHasSideEffects (VecReadScalarByteArrayOp _ _ _) = True+primOpHasSideEffects (VecWriteScalarByteArrayOp _ _ _) = True+primOpHasSideEffects (VecReadScalarOffAddrOp _ _ _) = True+primOpHasSideEffects (VecWriteScalarOffAddrOp _ _ _) = True+primOpHasSideEffects PrefetchByteArrayOp3 = True+primOpHasSideEffects PrefetchMutableByteArrayOp3 = True+primOpHasSideEffects PrefetchAddrOp3 = True+primOpHasSideEffects PrefetchValueOp3 = True+primOpHasSideEffects PrefetchByteArrayOp2 = True+primOpHasSideEffects PrefetchMutableByteArrayOp2 = True+primOpHasSideEffects PrefetchAddrOp2 = True+primOpHasSideEffects PrefetchValueOp2 = True+primOpHasSideEffects PrefetchByteArrayOp1 = True+primOpHasSideEffects PrefetchMutableByteArrayOp1 = True+primOpHasSideEffects PrefetchAddrOp1 = True+primOpHasSideEffects PrefetchValueOp1 = True+primOpHasSideEffects PrefetchByteArrayOp0 = True+primOpHasSideEffects PrefetchMutableByteArrayOp0 = True+primOpHasSideEffects PrefetchAddrOp0 = True+primOpHasSideEffects PrefetchValueOp0 = True+primOpHasSideEffects _ = False
+ ghc-lib/stage1/compiler/build/primop-list.hs-incl view
@@ -0,0 +1,1199 @@+   [CharGtOp+   , CharGeOp+   , CharEqOp+   , CharNeOp+   , CharLtOp+   , CharLeOp+   , OrdOp+   , IntAddOp+   , IntSubOp+   , IntMulOp+   , IntMulMayOfloOp+   , IntQuotOp+   , IntRemOp+   , IntQuotRemOp+   , AndIOp+   , OrIOp+   , XorIOp+   , NotIOp+   , IntNegOp+   , IntAddCOp+   , IntSubCOp+   , IntGtOp+   , IntGeOp+   , IntEqOp+   , IntNeOp+   , IntLtOp+   , IntLeOp+   , ChrOp+   , Int2WordOp+   , Int2FloatOp+   , Int2DoubleOp+   , Word2FloatOp+   , Word2DoubleOp+   , ISllOp+   , ISraOp+   , ISrlOp+   , Int8Extend+   , Int8Narrow+   , Int8NegOp+   , Int8AddOp+   , Int8SubOp+   , Int8MulOp+   , Int8QuotOp+   , Int8RemOp+   , Int8QuotRemOp+   , Int8EqOp+   , Int8GeOp+   , Int8GtOp+   , Int8LeOp+   , Int8LtOp+   , Int8NeOp+   , Word8Extend+   , Word8Narrow+   , Word8NotOp+   , Word8AddOp+   , Word8SubOp+   , Word8MulOp+   , Word8QuotOp+   , Word8RemOp+   , Word8QuotRemOp+   , Word8EqOp+   , Word8GeOp+   , Word8GtOp+   , Word8LeOp+   , Word8LtOp+   , Word8NeOp+   , Int16Extend+   , Int16Narrow+   , Int16NegOp+   , Int16AddOp+   , Int16SubOp+   , Int16MulOp+   , Int16QuotOp+   , Int16RemOp+   , Int16QuotRemOp+   , Int16EqOp+   , Int16GeOp+   , Int16GtOp+   , Int16LeOp+   , Int16LtOp+   , Int16NeOp+   , Word16Extend+   , Word16Narrow+   , Word16NotOp+   , Word16AddOp+   , Word16SubOp+   , Word16MulOp+   , Word16QuotOp+   , Word16RemOp+   , Word16QuotRemOp+   , Word16EqOp+   , Word16GeOp+   , Word16GtOp+   , Word16LeOp+   , Word16LtOp+   , Word16NeOp+   , WordAddOp+   , WordAddCOp+   , WordSubCOp+   , WordAdd2Op+   , WordSubOp+   , WordMulOp+   , WordMul2Op+   , WordQuotOp+   , WordRemOp+   , WordQuotRemOp+   , WordQuotRem2Op+   , AndOp+   , OrOp+   , XorOp+   , NotOp+   , SllOp+   , SrlOp+   , Word2IntOp+   , WordGtOp+   , WordGeOp+   , WordEqOp+   , WordNeOp+   , WordLtOp+   , WordLeOp+   , PopCnt8Op+   , PopCnt16Op+   , PopCnt32Op+   , PopCnt64Op+   , PopCntOp+   , Pdep8Op+   , Pdep16Op+   , Pdep32Op+   , Pdep64Op+   , PdepOp+   , Pext8Op+   , Pext16Op+   , Pext32Op+   , Pext64Op+   , PextOp+   , Clz8Op+   , Clz16Op+   , Clz32Op+   , Clz64Op+   , ClzOp+   , Ctz8Op+   , Ctz16Op+   , Ctz32Op+   , Ctz64Op+   , CtzOp+   , BSwap16Op+   , BSwap32Op+   , BSwap64Op+   , BSwapOp+   , BRev8Op+   , BRev16Op+   , BRev32Op+   , BRev64Op+   , BRevOp+   , Narrow8IntOp+   , Narrow16IntOp+   , Narrow32IntOp+   , Narrow8WordOp+   , Narrow16WordOp+   , Narrow32WordOp+   , DoubleGtOp+   , DoubleGeOp+   , DoubleEqOp+   , DoubleNeOp+   , DoubleLtOp+   , DoubleLeOp+   , DoubleAddOp+   , DoubleSubOp+   , DoubleMulOp+   , DoubleDivOp+   , DoubleNegOp+   , DoubleFabsOp+   , Double2IntOp+   , Double2FloatOp+   , DoubleExpOp+   , DoubleLogOp+   , DoubleSqrtOp+   , DoubleSinOp+   , DoubleCosOp+   , DoubleTanOp+   , DoubleAsinOp+   , DoubleAcosOp+   , DoubleAtanOp+   , DoubleSinhOp+   , DoubleCoshOp+   , DoubleTanhOp+   , DoubleAsinhOp+   , DoubleAcoshOp+   , DoubleAtanhOp+   , DoublePowerOp+   , DoubleDecode_2IntOp+   , DoubleDecode_Int64Op+   , FloatGtOp+   , FloatGeOp+   , FloatEqOp+   , FloatNeOp+   , FloatLtOp+   , FloatLeOp+   , FloatAddOp+   , FloatSubOp+   , FloatMulOp+   , FloatDivOp+   , FloatNegOp+   , FloatFabsOp+   , Float2IntOp+   , FloatExpOp+   , FloatLogOp+   , FloatSqrtOp+   , FloatSinOp+   , FloatCosOp+   , FloatTanOp+   , FloatAsinOp+   , FloatAcosOp+   , FloatAtanOp+   , FloatSinhOp+   , FloatCoshOp+   , FloatTanhOp+   , FloatAsinhOp+   , FloatAcoshOp+   , FloatAtanhOp+   , FloatPowerOp+   , Float2DoubleOp+   , FloatDecode_IntOp+   , NewArrayOp+   , SameMutableArrayOp+   , ReadArrayOp+   , WriteArrayOp+   , SizeofArrayOp+   , SizeofMutableArrayOp+   , IndexArrayOp+   , UnsafeFreezeArrayOp+   , UnsafeThawArrayOp+   , CopyArrayOp+   , CopyMutableArrayOp+   , CloneArrayOp+   , CloneMutableArrayOp+   , FreezeArrayOp+   , ThawArrayOp+   , CasArrayOp+   , NewSmallArrayOp+   , SameSmallMutableArrayOp+   , ReadSmallArrayOp+   , WriteSmallArrayOp+   , SizeofSmallArrayOp+   , SizeofSmallMutableArrayOp+   , IndexSmallArrayOp+   , UnsafeFreezeSmallArrayOp+   , UnsafeThawSmallArrayOp+   , CopySmallArrayOp+   , CopySmallMutableArrayOp+   , CloneSmallArrayOp+   , CloneSmallMutableArrayOp+   , FreezeSmallArrayOp+   , ThawSmallArrayOp+   , CasSmallArrayOp+   , NewByteArrayOp_Char+   , NewPinnedByteArrayOp_Char+   , NewAlignedPinnedByteArrayOp_Char+   , MutableByteArrayIsPinnedOp+   , ByteArrayIsPinnedOp+   , ByteArrayContents_Char+   , SameMutableByteArrayOp+   , ShrinkMutableByteArrayOp_Char+   , ResizeMutableByteArrayOp_Char+   , UnsafeFreezeByteArrayOp+   , SizeofByteArrayOp+   , SizeofMutableByteArrayOp+   , GetSizeofMutableByteArrayOp+   , IndexByteArrayOp_Char+   , IndexByteArrayOp_WideChar+   , IndexByteArrayOp_Int+   , IndexByteArrayOp_Word+   , IndexByteArrayOp_Addr+   , IndexByteArrayOp_Float+   , IndexByteArrayOp_Double+   , IndexByteArrayOp_StablePtr+   , IndexByteArrayOp_Int8+   , IndexByteArrayOp_Int16+   , IndexByteArrayOp_Int32+   , IndexByteArrayOp_Int64+   , IndexByteArrayOp_Word8+   , IndexByteArrayOp_Word16+   , IndexByteArrayOp_Word32+   , IndexByteArrayOp_Word64+   , IndexByteArrayOp_Word8AsChar+   , IndexByteArrayOp_Word8AsWideChar+   , IndexByteArrayOp_Word8AsAddr+   , IndexByteArrayOp_Word8AsFloat+   , IndexByteArrayOp_Word8AsDouble+   , IndexByteArrayOp_Word8AsStablePtr+   , IndexByteArrayOp_Word8AsInt16+   , IndexByteArrayOp_Word8AsInt32+   , IndexByteArrayOp_Word8AsInt64+   , IndexByteArrayOp_Word8AsInt+   , IndexByteArrayOp_Word8AsWord16+   , IndexByteArrayOp_Word8AsWord32+   , IndexByteArrayOp_Word8AsWord64+   , IndexByteArrayOp_Word8AsWord+   , ReadByteArrayOp_Char+   , ReadByteArrayOp_WideChar+   , ReadByteArrayOp_Int+   , ReadByteArrayOp_Word+   , ReadByteArrayOp_Addr+   , ReadByteArrayOp_Float+   , ReadByteArrayOp_Double+   , ReadByteArrayOp_StablePtr+   , ReadByteArrayOp_Int8+   , ReadByteArrayOp_Int16+   , ReadByteArrayOp_Int32+   , ReadByteArrayOp_Int64+   , ReadByteArrayOp_Word8+   , ReadByteArrayOp_Word16+   , ReadByteArrayOp_Word32+   , ReadByteArrayOp_Word64+   , ReadByteArrayOp_Word8AsChar+   , ReadByteArrayOp_Word8AsWideChar+   , ReadByteArrayOp_Word8AsAddr+   , ReadByteArrayOp_Word8AsFloat+   , ReadByteArrayOp_Word8AsDouble+   , ReadByteArrayOp_Word8AsStablePtr+   , ReadByteArrayOp_Word8AsInt16+   , ReadByteArrayOp_Word8AsInt32+   , ReadByteArrayOp_Word8AsInt64+   , ReadByteArrayOp_Word8AsInt+   , ReadByteArrayOp_Word8AsWord16+   , ReadByteArrayOp_Word8AsWord32+   , ReadByteArrayOp_Word8AsWord64+   , ReadByteArrayOp_Word8AsWord+   , WriteByteArrayOp_Char+   , WriteByteArrayOp_WideChar+   , WriteByteArrayOp_Int+   , WriteByteArrayOp_Word+   , WriteByteArrayOp_Addr+   , WriteByteArrayOp_Float+   , WriteByteArrayOp_Double+   , WriteByteArrayOp_StablePtr+   , WriteByteArrayOp_Int8+   , WriteByteArrayOp_Int16+   , WriteByteArrayOp_Int32+   , WriteByteArrayOp_Int64+   , WriteByteArrayOp_Word8+   , WriteByteArrayOp_Word16+   , WriteByteArrayOp_Word32+   , WriteByteArrayOp_Word64+   , WriteByteArrayOp_Word8AsChar+   , WriteByteArrayOp_Word8AsWideChar+   , WriteByteArrayOp_Word8AsAddr+   , WriteByteArrayOp_Word8AsFloat+   , WriteByteArrayOp_Word8AsDouble+   , WriteByteArrayOp_Word8AsStablePtr+   , WriteByteArrayOp_Word8AsInt16+   , WriteByteArrayOp_Word8AsInt32+   , WriteByteArrayOp_Word8AsInt64+   , WriteByteArrayOp_Word8AsInt+   , WriteByteArrayOp_Word8AsWord16+   , WriteByteArrayOp_Word8AsWord32+   , WriteByteArrayOp_Word8AsWord64+   , WriteByteArrayOp_Word8AsWord+   , CompareByteArraysOp+   , CopyByteArrayOp+   , CopyMutableByteArrayOp+   , CopyByteArrayToAddrOp+   , CopyMutableByteArrayToAddrOp+   , CopyAddrToByteArrayOp+   , SetByteArrayOp+   , AtomicReadByteArrayOp_Int+   , AtomicWriteByteArrayOp_Int+   , CasByteArrayOp_Int+   , FetchAddByteArrayOp_Int+   , FetchSubByteArrayOp_Int+   , FetchAndByteArrayOp_Int+   , FetchNandByteArrayOp_Int+   , FetchOrByteArrayOp_Int+   , FetchXorByteArrayOp_Int+   , NewArrayArrayOp+   , SameMutableArrayArrayOp+   , UnsafeFreezeArrayArrayOp+   , SizeofArrayArrayOp+   , SizeofMutableArrayArrayOp+   , IndexArrayArrayOp_ByteArray+   , IndexArrayArrayOp_ArrayArray+   , ReadArrayArrayOp_ByteArray+   , ReadArrayArrayOp_MutableByteArray+   , ReadArrayArrayOp_ArrayArray+   , ReadArrayArrayOp_MutableArrayArray+   , WriteArrayArrayOp_ByteArray+   , WriteArrayArrayOp_MutableByteArray+   , WriteArrayArrayOp_ArrayArray+   , WriteArrayArrayOp_MutableArrayArray+   , CopyArrayArrayOp+   , CopyMutableArrayArrayOp+   , AddrAddOp+   , AddrSubOp+   , AddrRemOp+   , Addr2IntOp+   , Int2AddrOp+   , AddrGtOp+   , AddrGeOp+   , AddrEqOp+   , AddrNeOp+   , AddrLtOp+   , AddrLeOp+   , IndexOffAddrOp_Char+   , IndexOffAddrOp_WideChar+   , IndexOffAddrOp_Int+   , IndexOffAddrOp_Word+   , IndexOffAddrOp_Addr+   , IndexOffAddrOp_Float+   , IndexOffAddrOp_Double+   , IndexOffAddrOp_StablePtr+   , IndexOffAddrOp_Int8+   , IndexOffAddrOp_Int16+   , IndexOffAddrOp_Int32+   , IndexOffAddrOp_Int64+   , IndexOffAddrOp_Word8+   , IndexOffAddrOp_Word16+   , IndexOffAddrOp_Word32+   , IndexOffAddrOp_Word64+   , ReadOffAddrOp_Char+   , ReadOffAddrOp_WideChar+   , ReadOffAddrOp_Int+   , ReadOffAddrOp_Word+   , ReadOffAddrOp_Addr+   , ReadOffAddrOp_Float+   , ReadOffAddrOp_Double+   , ReadOffAddrOp_StablePtr+   , ReadOffAddrOp_Int8+   , ReadOffAddrOp_Int16+   , ReadOffAddrOp_Int32+   , ReadOffAddrOp_Int64+   , ReadOffAddrOp_Word8+   , ReadOffAddrOp_Word16+   , ReadOffAddrOp_Word32+   , ReadOffAddrOp_Word64+   , WriteOffAddrOp_Char+   , WriteOffAddrOp_WideChar+   , WriteOffAddrOp_Int+   , WriteOffAddrOp_Word+   , WriteOffAddrOp_Addr+   , WriteOffAddrOp_Float+   , WriteOffAddrOp_Double+   , WriteOffAddrOp_StablePtr+   , WriteOffAddrOp_Int8+   , WriteOffAddrOp_Int16+   , WriteOffAddrOp_Int32+   , WriteOffAddrOp_Int64+   , WriteOffAddrOp_Word8+   , WriteOffAddrOp_Word16+   , WriteOffAddrOp_Word32+   , WriteOffAddrOp_Word64+   , NewMutVarOp+   , ReadMutVarOp+   , WriteMutVarOp+   , SameMutVarOp+   , AtomicModifyMutVar2Op+   , AtomicModifyMutVar_Op+   , CasMutVarOp+   , CatchOp+   , RaiseOp+   , RaiseIOOp+   , MaskAsyncExceptionsOp+   , MaskUninterruptibleOp+   , UnmaskAsyncExceptionsOp+   , MaskStatus+   , AtomicallyOp+   , RetryOp+   , CatchRetryOp+   , CatchSTMOp+   , NewTVarOp+   , ReadTVarOp+   , ReadTVarIOOp+   , WriteTVarOp+   , SameTVarOp+   , NewMVarOp+   , TakeMVarOp+   , TryTakeMVarOp+   , PutMVarOp+   , TryPutMVarOp+   , ReadMVarOp+   , TryReadMVarOp+   , SameMVarOp+   , IsEmptyMVarOp+   , DelayOp+   , WaitReadOp+   , WaitWriteOp+   , ForkOp+   , ForkOnOp+   , KillThreadOp+   , YieldOp+   , MyThreadIdOp+   , LabelThreadOp+   , IsCurrentThreadBoundOp+   , NoDuplicateOp+   , ThreadStatusOp+   , MkWeakOp+   , MkWeakNoFinalizerOp+   , AddCFinalizerToWeakOp+   , DeRefWeakOp+   , FinalizeWeakOp+   , TouchOp+   , MakeStablePtrOp+   , DeRefStablePtrOp+   , EqStablePtrOp+   , MakeStableNameOp+   , EqStableNameOp+   , StableNameToIntOp+   , CompactNewOp+   , CompactResizeOp+   , CompactContainsOp+   , CompactContainsAnyOp+   , CompactGetFirstBlockOp+   , CompactGetNextBlockOp+   , CompactAllocateBlockOp+   , CompactFixupPointersOp+   , CompactAdd+   , CompactAddWithSharing+   , CompactSize+   , ReallyUnsafePtrEqualityOp+   , ParOp+   , SparkOp+   , SeqOp+   , GetSparkOp+   , NumSparks+   , DataToTagOp+   , TagToEnumOp+   , AddrToAnyOp+   , AnyToAddrOp+   , MkApUpd0_Op+   , NewBCOOp+   , UnpackClosureOp+   , ClosureSizeOp+   , GetApStackValOp+   , GetCCSOfOp+   , GetCurrentCCSOp+   , ClearCCSOp+   , TraceEventOp+   , TraceEventBinaryOp+   , TraceMarkerOp+   , GetThreadAllocationCounter+   , SetThreadAllocationCounter+   , (VecBroadcastOp IntVec 16 W8)+   , (VecBroadcastOp IntVec 8 W16)+   , (VecBroadcastOp IntVec 4 W32)+   , (VecBroadcastOp IntVec 2 W64)+   , (VecBroadcastOp IntVec 32 W8)+   , (VecBroadcastOp IntVec 16 W16)+   , (VecBroadcastOp IntVec 8 W32)+   , (VecBroadcastOp IntVec 4 W64)+   , (VecBroadcastOp IntVec 64 W8)+   , (VecBroadcastOp IntVec 32 W16)+   , (VecBroadcastOp IntVec 16 W32)+   , (VecBroadcastOp IntVec 8 W64)+   , (VecBroadcastOp WordVec 16 W8)+   , (VecBroadcastOp WordVec 8 W16)+   , (VecBroadcastOp WordVec 4 W32)+   , (VecBroadcastOp WordVec 2 W64)+   , (VecBroadcastOp WordVec 32 W8)+   , (VecBroadcastOp WordVec 16 W16)+   , (VecBroadcastOp WordVec 8 W32)+   , (VecBroadcastOp WordVec 4 W64)+   , (VecBroadcastOp WordVec 64 W8)+   , (VecBroadcastOp WordVec 32 W16)+   , (VecBroadcastOp WordVec 16 W32)+   , (VecBroadcastOp WordVec 8 W64)+   , (VecBroadcastOp FloatVec 4 W32)+   , (VecBroadcastOp FloatVec 2 W64)+   , (VecBroadcastOp FloatVec 8 W32)+   , (VecBroadcastOp FloatVec 4 W64)+   , (VecBroadcastOp FloatVec 16 W32)+   , (VecBroadcastOp FloatVec 8 W64)+   , (VecPackOp IntVec 16 W8)+   , (VecPackOp IntVec 8 W16)+   , (VecPackOp IntVec 4 W32)+   , (VecPackOp IntVec 2 W64)+   , (VecPackOp IntVec 32 W8)+   , (VecPackOp IntVec 16 W16)+   , (VecPackOp IntVec 8 W32)+   , (VecPackOp IntVec 4 W64)+   , (VecPackOp IntVec 64 W8)+   , (VecPackOp IntVec 32 W16)+   , (VecPackOp IntVec 16 W32)+   , (VecPackOp IntVec 8 W64)+   , (VecPackOp WordVec 16 W8)+   , (VecPackOp WordVec 8 W16)+   , (VecPackOp WordVec 4 W32)+   , (VecPackOp WordVec 2 W64)+   , (VecPackOp WordVec 32 W8)+   , (VecPackOp WordVec 16 W16)+   , (VecPackOp WordVec 8 W32)+   , (VecPackOp WordVec 4 W64)+   , (VecPackOp WordVec 64 W8)+   , (VecPackOp WordVec 32 W16)+   , (VecPackOp WordVec 16 W32)+   , (VecPackOp WordVec 8 W64)+   , (VecPackOp FloatVec 4 W32)+   , (VecPackOp FloatVec 2 W64)+   , (VecPackOp FloatVec 8 W32)+   , (VecPackOp FloatVec 4 W64)+   , (VecPackOp FloatVec 16 W32)+   , (VecPackOp FloatVec 8 W64)+   , (VecUnpackOp IntVec 16 W8)+   , (VecUnpackOp IntVec 8 W16)+   , (VecUnpackOp IntVec 4 W32)+   , (VecUnpackOp IntVec 2 W64)+   , (VecUnpackOp IntVec 32 W8)+   , (VecUnpackOp IntVec 16 W16)+   , (VecUnpackOp IntVec 8 W32)+   , (VecUnpackOp IntVec 4 W64)+   , (VecUnpackOp IntVec 64 W8)+   , (VecUnpackOp IntVec 32 W16)+   , (VecUnpackOp IntVec 16 W32)+   , (VecUnpackOp IntVec 8 W64)+   , (VecUnpackOp WordVec 16 W8)+   , (VecUnpackOp WordVec 8 W16)+   , (VecUnpackOp WordVec 4 W32)+   , (VecUnpackOp WordVec 2 W64)+   , (VecUnpackOp WordVec 32 W8)+   , (VecUnpackOp WordVec 16 W16)+   , (VecUnpackOp WordVec 8 W32)+   , (VecUnpackOp WordVec 4 W64)+   , (VecUnpackOp WordVec 64 W8)+   , (VecUnpackOp WordVec 32 W16)+   , (VecUnpackOp WordVec 16 W32)+   , (VecUnpackOp WordVec 8 W64)+   , (VecUnpackOp FloatVec 4 W32)+   , (VecUnpackOp FloatVec 2 W64)+   , (VecUnpackOp FloatVec 8 W32)+   , (VecUnpackOp FloatVec 4 W64)+   , (VecUnpackOp FloatVec 16 W32)+   , (VecUnpackOp FloatVec 8 W64)+   , (VecInsertOp IntVec 16 W8)+   , (VecInsertOp IntVec 8 W16)+   , (VecInsertOp IntVec 4 W32)+   , (VecInsertOp IntVec 2 W64)+   , (VecInsertOp IntVec 32 W8)+   , (VecInsertOp IntVec 16 W16)+   , (VecInsertOp IntVec 8 W32)+   , (VecInsertOp IntVec 4 W64)+   , (VecInsertOp IntVec 64 W8)+   , (VecInsertOp IntVec 32 W16)+   , (VecInsertOp IntVec 16 W32)+   , (VecInsertOp IntVec 8 W64)+   , (VecInsertOp WordVec 16 W8)+   , (VecInsertOp WordVec 8 W16)+   , (VecInsertOp WordVec 4 W32)+   , (VecInsertOp WordVec 2 W64)+   , (VecInsertOp WordVec 32 W8)+   , (VecInsertOp WordVec 16 W16)+   , (VecInsertOp WordVec 8 W32)+   , (VecInsertOp WordVec 4 W64)+   , (VecInsertOp WordVec 64 W8)+   , (VecInsertOp WordVec 32 W16)+   , (VecInsertOp WordVec 16 W32)+   , (VecInsertOp WordVec 8 W64)+   , (VecInsertOp FloatVec 4 W32)+   , (VecInsertOp FloatVec 2 W64)+   , (VecInsertOp FloatVec 8 W32)+   , (VecInsertOp FloatVec 4 W64)+   , (VecInsertOp FloatVec 16 W32)+   , (VecInsertOp FloatVec 8 W64)+   , (VecAddOp IntVec 16 W8)+   , (VecAddOp IntVec 8 W16)+   , (VecAddOp IntVec 4 W32)+   , (VecAddOp IntVec 2 W64)+   , (VecAddOp IntVec 32 W8)+   , (VecAddOp IntVec 16 W16)+   , (VecAddOp IntVec 8 W32)+   , (VecAddOp IntVec 4 W64)+   , (VecAddOp IntVec 64 W8)+   , (VecAddOp IntVec 32 W16)+   , (VecAddOp IntVec 16 W32)+   , (VecAddOp IntVec 8 W64)+   , (VecAddOp WordVec 16 W8)+   , (VecAddOp WordVec 8 W16)+   , (VecAddOp WordVec 4 W32)+   , (VecAddOp WordVec 2 W64)+   , (VecAddOp WordVec 32 W8)+   , (VecAddOp WordVec 16 W16)+   , (VecAddOp WordVec 8 W32)+   , (VecAddOp WordVec 4 W64)+   , (VecAddOp WordVec 64 W8)+   , (VecAddOp WordVec 32 W16)+   , (VecAddOp WordVec 16 W32)+   , (VecAddOp WordVec 8 W64)+   , (VecAddOp FloatVec 4 W32)+   , (VecAddOp FloatVec 2 W64)+   , (VecAddOp FloatVec 8 W32)+   , (VecAddOp FloatVec 4 W64)+   , (VecAddOp FloatVec 16 W32)+   , (VecAddOp FloatVec 8 W64)+   , (VecSubOp IntVec 16 W8)+   , (VecSubOp IntVec 8 W16)+   , (VecSubOp IntVec 4 W32)+   , (VecSubOp IntVec 2 W64)+   , (VecSubOp IntVec 32 W8)+   , (VecSubOp IntVec 16 W16)+   , (VecSubOp IntVec 8 W32)+   , (VecSubOp IntVec 4 W64)+   , (VecSubOp IntVec 64 W8)+   , (VecSubOp IntVec 32 W16)+   , (VecSubOp IntVec 16 W32)+   , (VecSubOp IntVec 8 W64)+   , (VecSubOp WordVec 16 W8)+   , (VecSubOp WordVec 8 W16)+   , (VecSubOp WordVec 4 W32)+   , (VecSubOp WordVec 2 W64)+   , (VecSubOp WordVec 32 W8)+   , (VecSubOp WordVec 16 W16)+   , (VecSubOp WordVec 8 W32)+   , (VecSubOp WordVec 4 W64)+   , (VecSubOp WordVec 64 W8)+   , (VecSubOp WordVec 32 W16)+   , (VecSubOp WordVec 16 W32)+   , (VecSubOp WordVec 8 W64)+   , (VecSubOp FloatVec 4 W32)+   , (VecSubOp FloatVec 2 W64)+   , (VecSubOp FloatVec 8 W32)+   , (VecSubOp FloatVec 4 W64)+   , (VecSubOp FloatVec 16 W32)+   , (VecSubOp FloatVec 8 W64)+   , (VecMulOp IntVec 16 W8)+   , (VecMulOp IntVec 8 W16)+   , (VecMulOp IntVec 4 W32)+   , (VecMulOp IntVec 2 W64)+   , (VecMulOp IntVec 32 W8)+   , (VecMulOp IntVec 16 W16)+   , (VecMulOp IntVec 8 W32)+   , (VecMulOp IntVec 4 W64)+   , (VecMulOp IntVec 64 W8)+   , (VecMulOp IntVec 32 W16)+   , (VecMulOp IntVec 16 W32)+   , (VecMulOp IntVec 8 W64)+   , (VecMulOp WordVec 16 W8)+   , (VecMulOp WordVec 8 W16)+   , (VecMulOp WordVec 4 W32)+   , (VecMulOp WordVec 2 W64)+   , (VecMulOp WordVec 32 W8)+   , (VecMulOp WordVec 16 W16)+   , (VecMulOp WordVec 8 W32)+   , (VecMulOp WordVec 4 W64)+   , (VecMulOp WordVec 64 W8)+   , (VecMulOp WordVec 32 W16)+   , (VecMulOp WordVec 16 W32)+   , (VecMulOp WordVec 8 W64)+   , (VecMulOp FloatVec 4 W32)+   , (VecMulOp FloatVec 2 W64)+   , (VecMulOp FloatVec 8 W32)+   , (VecMulOp FloatVec 4 W64)+   , (VecMulOp FloatVec 16 W32)+   , (VecMulOp FloatVec 8 W64)+   , (VecDivOp FloatVec 4 W32)+   , (VecDivOp FloatVec 2 W64)+   , (VecDivOp FloatVec 8 W32)+   , (VecDivOp FloatVec 4 W64)+   , (VecDivOp FloatVec 16 W32)+   , (VecDivOp FloatVec 8 W64)+   , (VecQuotOp IntVec 16 W8)+   , (VecQuotOp IntVec 8 W16)+   , (VecQuotOp IntVec 4 W32)+   , (VecQuotOp IntVec 2 W64)+   , (VecQuotOp IntVec 32 W8)+   , (VecQuotOp IntVec 16 W16)+   , (VecQuotOp IntVec 8 W32)+   , (VecQuotOp IntVec 4 W64)+   , (VecQuotOp IntVec 64 W8)+   , (VecQuotOp IntVec 32 W16)+   , (VecQuotOp IntVec 16 W32)+   , (VecQuotOp IntVec 8 W64)+   , (VecQuotOp WordVec 16 W8)+   , (VecQuotOp WordVec 8 W16)+   , (VecQuotOp WordVec 4 W32)+   , (VecQuotOp WordVec 2 W64)+   , (VecQuotOp WordVec 32 W8)+   , (VecQuotOp WordVec 16 W16)+   , (VecQuotOp WordVec 8 W32)+   , (VecQuotOp WordVec 4 W64)+   , (VecQuotOp WordVec 64 W8)+   , (VecQuotOp WordVec 32 W16)+   , (VecQuotOp WordVec 16 W32)+   , (VecQuotOp WordVec 8 W64)+   , (VecRemOp IntVec 16 W8)+   , (VecRemOp IntVec 8 W16)+   , (VecRemOp IntVec 4 W32)+   , (VecRemOp IntVec 2 W64)+   , (VecRemOp IntVec 32 W8)+   , (VecRemOp IntVec 16 W16)+   , (VecRemOp IntVec 8 W32)+   , (VecRemOp IntVec 4 W64)+   , (VecRemOp IntVec 64 W8)+   , (VecRemOp IntVec 32 W16)+   , (VecRemOp IntVec 16 W32)+   , (VecRemOp IntVec 8 W64)+   , (VecRemOp WordVec 16 W8)+   , (VecRemOp WordVec 8 W16)+   , (VecRemOp WordVec 4 W32)+   , (VecRemOp WordVec 2 W64)+   , (VecRemOp WordVec 32 W8)+   , (VecRemOp WordVec 16 W16)+   , (VecRemOp WordVec 8 W32)+   , (VecRemOp WordVec 4 W64)+   , (VecRemOp WordVec 64 W8)+   , (VecRemOp WordVec 32 W16)+   , (VecRemOp WordVec 16 W32)+   , (VecRemOp WordVec 8 W64)+   , (VecNegOp IntVec 16 W8)+   , (VecNegOp IntVec 8 W16)+   , (VecNegOp IntVec 4 W32)+   , (VecNegOp IntVec 2 W64)+   , (VecNegOp IntVec 32 W8)+   , (VecNegOp IntVec 16 W16)+   , (VecNegOp IntVec 8 W32)+   , (VecNegOp IntVec 4 W64)+   , (VecNegOp IntVec 64 W8)+   , (VecNegOp IntVec 32 W16)+   , (VecNegOp IntVec 16 W32)+   , (VecNegOp IntVec 8 W64)+   , (VecNegOp FloatVec 4 W32)+   , (VecNegOp FloatVec 2 W64)+   , (VecNegOp FloatVec 8 W32)+   , (VecNegOp FloatVec 4 W64)+   , (VecNegOp FloatVec 16 W32)+   , (VecNegOp FloatVec 8 W64)+   , (VecIndexByteArrayOp IntVec 16 W8)+   , (VecIndexByteArrayOp IntVec 8 W16)+   , (VecIndexByteArrayOp IntVec 4 W32)+   , (VecIndexByteArrayOp IntVec 2 W64)+   , (VecIndexByteArrayOp IntVec 32 W8)+   , (VecIndexByteArrayOp IntVec 16 W16)+   , (VecIndexByteArrayOp IntVec 8 W32)+   , (VecIndexByteArrayOp IntVec 4 W64)+   , (VecIndexByteArrayOp IntVec 64 W8)+   , (VecIndexByteArrayOp IntVec 32 W16)+   , (VecIndexByteArrayOp IntVec 16 W32)+   , (VecIndexByteArrayOp IntVec 8 W64)+   , (VecIndexByteArrayOp WordVec 16 W8)+   , (VecIndexByteArrayOp WordVec 8 W16)+   , (VecIndexByteArrayOp WordVec 4 W32)+   , (VecIndexByteArrayOp WordVec 2 W64)+   , (VecIndexByteArrayOp WordVec 32 W8)+   , (VecIndexByteArrayOp WordVec 16 W16)+   , (VecIndexByteArrayOp WordVec 8 W32)+   , (VecIndexByteArrayOp WordVec 4 W64)+   , (VecIndexByteArrayOp WordVec 64 W8)+   , (VecIndexByteArrayOp WordVec 32 W16)+   , (VecIndexByteArrayOp WordVec 16 W32)+   , (VecIndexByteArrayOp WordVec 8 W64)+   , (VecIndexByteArrayOp FloatVec 4 W32)+   , (VecIndexByteArrayOp FloatVec 2 W64)+   , (VecIndexByteArrayOp FloatVec 8 W32)+   , (VecIndexByteArrayOp FloatVec 4 W64)+   , (VecIndexByteArrayOp FloatVec 16 W32)+   , (VecIndexByteArrayOp FloatVec 8 W64)+   , (VecReadByteArrayOp IntVec 16 W8)+   , (VecReadByteArrayOp IntVec 8 W16)+   , (VecReadByteArrayOp IntVec 4 W32)+   , (VecReadByteArrayOp IntVec 2 W64)+   , (VecReadByteArrayOp IntVec 32 W8)+   , (VecReadByteArrayOp IntVec 16 W16)+   , (VecReadByteArrayOp IntVec 8 W32)+   , (VecReadByteArrayOp IntVec 4 W64)+   , (VecReadByteArrayOp IntVec 64 W8)+   , (VecReadByteArrayOp IntVec 32 W16)+   , (VecReadByteArrayOp IntVec 16 W32)+   , (VecReadByteArrayOp IntVec 8 W64)+   , (VecReadByteArrayOp WordVec 16 W8)+   , (VecReadByteArrayOp WordVec 8 W16)+   , (VecReadByteArrayOp WordVec 4 W32)+   , (VecReadByteArrayOp WordVec 2 W64)+   , (VecReadByteArrayOp WordVec 32 W8)+   , (VecReadByteArrayOp WordVec 16 W16)+   , (VecReadByteArrayOp WordVec 8 W32)+   , (VecReadByteArrayOp WordVec 4 W64)+   , (VecReadByteArrayOp WordVec 64 W8)+   , (VecReadByteArrayOp WordVec 32 W16)+   , (VecReadByteArrayOp WordVec 16 W32)+   , (VecReadByteArrayOp WordVec 8 W64)+   , (VecReadByteArrayOp FloatVec 4 W32)+   , (VecReadByteArrayOp FloatVec 2 W64)+   , (VecReadByteArrayOp FloatVec 8 W32)+   , (VecReadByteArrayOp FloatVec 4 W64)+   , (VecReadByteArrayOp FloatVec 16 W32)+   , (VecReadByteArrayOp FloatVec 8 W64)+   , (VecWriteByteArrayOp IntVec 16 W8)+   , (VecWriteByteArrayOp IntVec 8 W16)+   , (VecWriteByteArrayOp IntVec 4 W32)+   , (VecWriteByteArrayOp IntVec 2 W64)+   , (VecWriteByteArrayOp IntVec 32 W8)+   , (VecWriteByteArrayOp IntVec 16 W16)+   , (VecWriteByteArrayOp IntVec 8 W32)+   , (VecWriteByteArrayOp IntVec 4 W64)+   , (VecWriteByteArrayOp IntVec 64 W8)+   , (VecWriteByteArrayOp IntVec 32 W16)+   , (VecWriteByteArrayOp IntVec 16 W32)+   , (VecWriteByteArrayOp IntVec 8 W64)+   , (VecWriteByteArrayOp WordVec 16 W8)+   , (VecWriteByteArrayOp WordVec 8 W16)+   , (VecWriteByteArrayOp WordVec 4 W32)+   , (VecWriteByteArrayOp WordVec 2 W64)+   , (VecWriteByteArrayOp WordVec 32 W8)+   , (VecWriteByteArrayOp WordVec 16 W16)+   , (VecWriteByteArrayOp WordVec 8 W32)+   , (VecWriteByteArrayOp WordVec 4 W64)+   , (VecWriteByteArrayOp WordVec 64 W8)+   , (VecWriteByteArrayOp WordVec 32 W16)+   , (VecWriteByteArrayOp WordVec 16 W32)+   , (VecWriteByteArrayOp WordVec 8 W64)+   , (VecWriteByteArrayOp FloatVec 4 W32)+   , (VecWriteByteArrayOp FloatVec 2 W64)+   , (VecWriteByteArrayOp FloatVec 8 W32)+   , (VecWriteByteArrayOp FloatVec 4 W64)+   , (VecWriteByteArrayOp FloatVec 16 W32)+   , (VecWriteByteArrayOp FloatVec 8 W64)+   , (VecIndexOffAddrOp IntVec 16 W8)+   , (VecIndexOffAddrOp IntVec 8 W16)+   , (VecIndexOffAddrOp IntVec 4 W32)+   , (VecIndexOffAddrOp IntVec 2 W64)+   , (VecIndexOffAddrOp IntVec 32 W8)+   , (VecIndexOffAddrOp IntVec 16 W16)+   , (VecIndexOffAddrOp IntVec 8 W32)+   , (VecIndexOffAddrOp IntVec 4 W64)+   , (VecIndexOffAddrOp IntVec 64 W8)+   , (VecIndexOffAddrOp IntVec 32 W16)+   , (VecIndexOffAddrOp IntVec 16 W32)+   , (VecIndexOffAddrOp IntVec 8 W64)+   , (VecIndexOffAddrOp WordVec 16 W8)+   , (VecIndexOffAddrOp WordVec 8 W16)+   , (VecIndexOffAddrOp WordVec 4 W32)+   , (VecIndexOffAddrOp WordVec 2 W64)+   , (VecIndexOffAddrOp WordVec 32 W8)+   , (VecIndexOffAddrOp WordVec 16 W16)+   , (VecIndexOffAddrOp WordVec 8 W32)+   , (VecIndexOffAddrOp WordVec 4 W64)+   , (VecIndexOffAddrOp WordVec 64 W8)+   , (VecIndexOffAddrOp WordVec 32 W16)+   , (VecIndexOffAddrOp WordVec 16 W32)+   , (VecIndexOffAddrOp WordVec 8 W64)+   , (VecIndexOffAddrOp FloatVec 4 W32)+   , (VecIndexOffAddrOp FloatVec 2 W64)+   , (VecIndexOffAddrOp FloatVec 8 W32)+   , (VecIndexOffAddrOp FloatVec 4 W64)+   , (VecIndexOffAddrOp FloatVec 16 W32)+   , (VecIndexOffAddrOp FloatVec 8 W64)+   , (VecReadOffAddrOp IntVec 16 W8)+   , (VecReadOffAddrOp IntVec 8 W16)+   , (VecReadOffAddrOp IntVec 4 W32)+   , (VecReadOffAddrOp IntVec 2 W64)+   , (VecReadOffAddrOp IntVec 32 W8)+   , (VecReadOffAddrOp IntVec 16 W16)+   , (VecReadOffAddrOp IntVec 8 W32)+   , (VecReadOffAddrOp IntVec 4 W64)+   , (VecReadOffAddrOp IntVec 64 W8)+   , (VecReadOffAddrOp IntVec 32 W16)+   , (VecReadOffAddrOp IntVec 16 W32)+   , (VecReadOffAddrOp IntVec 8 W64)+   , (VecReadOffAddrOp WordVec 16 W8)+   , (VecReadOffAddrOp WordVec 8 W16)+   , (VecReadOffAddrOp WordVec 4 W32)+   , (VecReadOffAddrOp WordVec 2 W64)+   , (VecReadOffAddrOp WordVec 32 W8)+   , (VecReadOffAddrOp WordVec 16 W16)+   , (VecReadOffAddrOp WordVec 8 W32)+   , (VecReadOffAddrOp WordVec 4 W64)+   , (VecReadOffAddrOp WordVec 64 W8)+   , (VecReadOffAddrOp WordVec 32 W16)+   , (VecReadOffAddrOp WordVec 16 W32)+   , (VecReadOffAddrOp WordVec 8 W64)+   , (VecReadOffAddrOp FloatVec 4 W32)+   , (VecReadOffAddrOp FloatVec 2 W64)+   , (VecReadOffAddrOp FloatVec 8 W32)+   , (VecReadOffAddrOp FloatVec 4 W64)+   , (VecReadOffAddrOp FloatVec 16 W32)+   , (VecReadOffAddrOp FloatVec 8 W64)+   , (VecWriteOffAddrOp IntVec 16 W8)+   , (VecWriteOffAddrOp IntVec 8 W16)+   , (VecWriteOffAddrOp IntVec 4 W32)+   , (VecWriteOffAddrOp IntVec 2 W64)+   , (VecWriteOffAddrOp IntVec 32 W8)+   , (VecWriteOffAddrOp IntVec 16 W16)+   , (VecWriteOffAddrOp IntVec 8 W32)+   , (VecWriteOffAddrOp IntVec 4 W64)+   , (VecWriteOffAddrOp IntVec 64 W8)+   , (VecWriteOffAddrOp IntVec 32 W16)+   , (VecWriteOffAddrOp IntVec 16 W32)+   , (VecWriteOffAddrOp IntVec 8 W64)+   , (VecWriteOffAddrOp WordVec 16 W8)+   , (VecWriteOffAddrOp WordVec 8 W16)+   , (VecWriteOffAddrOp WordVec 4 W32)+   , (VecWriteOffAddrOp WordVec 2 W64)+   , (VecWriteOffAddrOp WordVec 32 W8)+   , (VecWriteOffAddrOp WordVec 16 W16)+   , (VecWriteOffAddrOp WordVec 8 W32)+   , (VecWriteOffAddrOp WordVec 4 W64)+   , (VecWriteOffAddrOp WordVec 64 W8)+   , (VecWriteOffAddrOp WordVec 32 W16)+   , (VecWriteOffAddrOp WordVec 16 W32)+   , (VecWriteOffAddrOp WordVec 8 W64)+   , (VecWriteOffAddrOp FloatVec 4 W32)+   , (VecWriteOffAddrOp FloatVec 2 W64)+   , (VecWriteOffAddrOp FloatVec 8 W32)+   , (VecWriteOffAddrOp FloatVec 4 W64)+   , (VecWriteOffAddrOp FloatVec 16 W32)+   , (VecWriteOffAddrOp FloatVec 8 W64)+   , (VecIndexScalarByteArrayOp IntVec 16 W8)+   , (VecIndexScalarByteArrayOp IntVec 8 W16)+   , (VecIndexScalarByteArrayOp IntVec 4 W32)+   , (VecIndexScalarByteArrayOp IntVec 2 W64)+   , (VecIndexScalarByteArrayOp IntVec 32 W8)+   , (VecIndexScalarByteArrayOp IntVec 16 W16)+   , (VecIndexScalarByteArrayOp IntVec 8 W32)+   , (VecIndexScalarByteArrayOp IntVec 4 W64)+   , (VecIndexScalarByteArrayOp IntVec 64 W8)+   , (VecIndexScalarByteArrayOp IntVec 32 W16)+   , (VecIndexScalarByteArrayOp IntVec 16 W32)+   , (VecIndexScalarByteArrayOp IntVec 8 W64)+   , (VecIndexScalarByteArrayOp WordVec 16 W8)+   , (VecIndexScalarByteArrayOp WordVec 8 W16)+   , (VecIndexScalarByteArrayOp WordVec 4 W32)+   , (VecIndexScalarByteArrayOp WordVec 2 W64)+   , (VecIndexScalarByteArrayOp WordVec 32 W8)+   , (VecIndexScalarByteArrayOp WordVec 16 W16)+   , (VecIndexScalarByteArrayOp WordVec 8 W32)+   , (VecIndexScalarByteArrayOp WordVec 4 W64)+   , (VecIndexScalarByteArrayOp WordVec 64 W8)+   , (VecIndexScalarByteArrayOp WordVec 32 W16)+   , (VecIndexScalarByteArrayOp WordVec 16 W32)+   , (VecIndexScalarByteArrayOp WordVec 8 W64)+   , (VecIndexScalarByteArrayOp FloatVec 4 W32)+   , (VecIndexScalarByteArrayOp FloatVec 2 W64)+   , (VecIndexScalarByteArrayOp FloatVec 8 W32)+   , (VecIndexScalarByteArrayOp FloatVec 4 W64)+   , (VecIndexScalarByteArrayOp FloatVec 16 W32)+   , (VecIndexScalarByteArrayOp FloatVec 8 W64)+   , (VecReadScalarByteArrayOp IntVec 16 W8)+   , (VecReadScalarByteArrayOp IntVec 8 W16)+   , (VecReadScalarByteArrayOp IntVec 4 W32)+   , (VecReadScalarByteArrayOp IntVec 2 W64)+   , (VecReadScalarByteArrayOp IntVec 32 W8)+   , (VecReadScalarByteArrayOp IntVec 16 W16)+   , (VecReadScalarByteArrayOp IntVec 8 W32)+   , (VecReadScalarByteArrayOp IntVec 4 W64)+   , (VecReadScalarByteArrayOp IntVec 64 W8)+   , (VecReadScalarByteArrayOp IntVec 32 W16)+   , (VecReadScalarByteArrayOp IntVec 16 W32)+   , (VecReadScalarByteArrayOp IntVec 8 W64)+   , (VecReadScalarByteArrayOp WordVec 16 W8)+   , (VecReadScalarByteArrayOp WordVec 8 W16)+   , (VecReadScalarByteArrayOp WordVec 4 W32)+   , (VecReadScalarByteArrayOp WordVec 2 W64)+   , (VecReadScalarByteArrayOp WordVec 32 W8)+   , (VecReadScalarByteArrayOp WordVec 16 W16)+   , (VecReadScalarByteArrayOp WordVec 8 W32)+   , (VecReadScalarByteArrayOp WordVec 4 W64)+   , (VecReadScalarByteArrayOp WordVec 64 W8)+   , (VecReadScalarByteArrayOp WordVec 32 W16)+   , (VecReadScalarByteArrayOp WordVec 16 W32)+   , (VecReadScalarByteArrayOp WordVec 8 W64)+   , (VecReadScalarByteArrayOp FloatVec 4 W32)+   , (VecReadScalarByteArrayOp FloatVec 2 W64)+   , (VecReadScalarByteArrayOp FloatVec 8 W32)+   , (VecReadScalarByteArrayOp FloatVec 4 W64)+   , (VecReadScalarByteArrayOp FloatVec 16 W32)+   , (VecReadScalarByteArrayOp FloatVec 8 W64)+   , (VecWriteScalarByteArrayOp IntVec 16 W8)+   , (VecWriteScalarByteArrayOp IntVec 8 W16)+   , (VecWriteScalarByteArrayOp IntVec 4 W32)+   , (VecWriteScalarByteArrayOp IntVec 2 W64)+   , (VecWriteScalarByteArrayOp IntVec 32 W8)+   , (VecWriteScalarByteArrayOp IntVec 16 W16)+   , (VecWriteScalarByteArrayOp IntVec 8 W32)+   , (VecWriteScalarByteArrayOp IntVec 4 W64)+   , (VecWriteScalarByteArrayOp IntVec 64 W8)+   , (VecWriteScalarByteArrayOp IntVec 32 W16)+   , (VecWriteScalarByteArrayOp IntVec 16 W32)+   , (VecWriteScalarByteArrayOp IntVec 8 W64)+   , (VecWriteScalarByteArrayOp WordVec 16 W8)+   , (VecWriteScalarByteArrayOp WordVec 8 W16)+   , (VecWriteScalarByteArrayOp WordVec 4 W32)+   , (VecWriteScalarByteArrayOp WordVec 2 W64)+   , (VecWriteScalarByteArrayOp WordVec 32 W8)+   , (VecWriteScalarByteArrayOp WordVec 16 W16)+   , (VecWriteScalarByteArrayOp WordVec 8 W32)+   , (VecWriteScalarByteArrayOp WordVec 4 W64)+   , (VecWriteScalarByteArrayOp WordVec 64 W8)+   , (VecWriteScalarByteArrayOp WordVec 32 W16)+   , (VecWriteScalarByteArrayOp WordVec 16 W32)+   , (VecWriteScalarByteArrayOp WordVec 8 W64)+   , (VecWriteScalarByteArrayOp FloatVec 4 W32)+   , (VecWriteScalarByteArrayOp FloatVec 2 W64)+   , (VecWriteScalarByteArrayOp FloatVec 8 W32)+   , (VecWriteScalarByteArrayOp FloatVec 4 W64)+   , (VecWriteScalarByteArrayOp FloatVec 16 W32)+   , (VecWriteScalarByteArrayOp FloatVec 8 W64)+   , (VecIndexScalarOffAddrOp IntVec 16 W8)+   , (VecIndexScalarOffAddrOp IntVec 8 W16)+   , (VecIndexScalarOffAddrOp IntVec 4 W32)+   , (VecIndexScalarOffAddrOp IntVec 2 W64)+   , (VecIndexScalarOffAddrOp IntVec 32 W8)+   , (VecIndexScalarOffAddrOp IntVec 16 W16)+   , (VecIndexScalarOffAddrOp IntVec 8 W32)+   , (VecIndexScalarOffAddrOp IntVec 4 W64)+   , (VecIndexScalarOffAddrOp IntVec 64 W8)+   , (VecIndexScalarOffAddrOp IntVec 32 W16)+   , (VecIndexScalarOffAddrOp IntVec 16 W32)+   , (VecIndexScalarOffAddrOp IntVec 8 W64)+   , (VecIndexScalarOffAddrOp WordVec 16 W8)+   , (VecIndexScalarOffAddrOp WordVec 8 W16)+   , (VecIndexScalarOffAddrOp WordVec 4 W32)+   , (VecIndexScalarOffAddrOp WordVec 2 W64)+   , (VecIndexScalarOffAddrOp WordVec 32 W8)+   , (VecIndexScalarOffAddrOp WordVec 16 W16)+   , (VecIndexScalarOffAddrOp WordVec 8 W32)+   , (VecIndexScalarOffAddrOp WordVec 4 W64)+   , (VecIndexScalarOffAddrOp WordVec 64 W8)+   , (VecIndexScalarOffAddrOp WordVec 32 W16)+   , (VecIndexScalarOffAddrOp WordVec 16 W32)+   , (VecIndexScalarOffAddrOp WordVec 8 W64)+   , (VecIndexScalarOffAddrOp FloatVec 4 W32)+   , (VecIndexScalarOffAddrOp FloatVec 2 W64)+   , (VecIndexScalarOffAddrOp FloatVec 8 W32)+   , (VecIndexScalarOffAddrOp FloatVec 4 W64)+   , (VecIndexScalarOffAddrOp FloatVec 16 W32)+   , (VecIndexScalarOffAddrOp FloatVec 8 W64)+   , (VecReadScalarOffAddrOp IntVec 16 W8)+   , (VecReadScalarOffAddrOp IntVec 8 W16)+   , (VecReadScalarOffAddrOp IntVec 4 W32)+   , (VecReadScalarOffAddrOp IntVec 2 W64)+   , (VecReadScalarOffAddrOp IntVec 32 W8)+   , (VecReadScalarOffAddrOp IntVec 16 W16)+   , (VecReadScalarOffAddrOp IntVec 8 W32)+   , (VecReadScalarOffAddrOp IntVec 4 W64)+   , (VecReadScalarOffAddrOp IntVec 64 W8)+   , (VecReadScalarOffAddrOp IntVec 32 W16)+   , (VecReadScalarOffAddrOp IntVec 16 W32)+   , (VecReadScalarOffAddrOp IntVec 8 W64)+   , (VecReadScalarOffAddrOp WordVec 16 W8)+   , (VecReadScalarOffAddrOp WordVec 8 W16)+   , (VecReadScalarOffAddrOp WordVec 4 W32)+   , (VecReadScalarOffAddrOp WordVec 2 W64)+   , (VecReadScalarOffAddrOp WordVec 32 W8)+   , (VecReadScalarOffAddrOp WordVec 16 W16)+   , (VecReadScalarOffAddrOp WordVec 8 W32)+   , (VecReadScalarOffAddrOp WordVec 4 W64)+   , (VecReadScalarOffAddrOp WordVec 64 W8)+   , (VecReadScalarOffAddrOp WordVec 32 W16)+   , (VecReadScalarOffAddrOp WordVec 16 W32)+   , (VecReadScalarOffAddrOp WordVec 8 W64)+   , (VecReadScalarOffAddrOp FloatVec 4 W32)+   , (VecReadScalarOffAddrOp FloatVec 2 W64)+   , (VecReadScalarOffAddrOp FloatVec 8 W32)+   , (VecReadScalarOffAddrOp FloatVec 4 W64)+   , (VecReadScalarOffAddrOp FloatVec 16 W32)+   , (VecReadScalarOffAddrOp FloatVec 8 W64)+   , (VecWriteScalarOffAddrOp IntVec 16 W8)+   , (VecWriteScalarOffAddrOp IntVec 8 W16)+   , (VecWriteScalarOffAddrOp IntVec 4 W32)+   , (VecWriteScalarOffAddrOp IntVec 2 W64)+   , (VecWriteScalarOffAddrOp IntVec 32 W8)+   , (VecWriteScalarOffAddrOp IntVec 16 W16)+   , (VecWriteScalarOffAddrOp IntVec 8 W32)+   , (VecWriteScalarOffAddrOp IntVec 4 W64)+   , (VecWriteScalarOffAddrOp IntVec 64 W8)+   , (VecWriteScalarOffAddrOp IntVec 32 W16)+   , (VecWriteScalarOffAddrOp IntVec 16 W32)+   , (VecWriteScalarOffAddrOp IntVec 8 W64)+   , (VecWriteScalarOffAddrOp WordVec 16 W8)+   , (VecWriteScalarOffAddrOp WordVec 8 W16)+   , (VecWriteScalarOffAddrOp WordVec 4 W32)+   , (VecWriteScalarOffAddrOp WordVec 2 W64)+   , (VecWriteScalarOffAddrOp WordVec 32 W8)+   , (VecWriteScalarOffAddrOp WordVec 16 W16)+   , (VecWriteScalarOffAddrOp WordVec 8 W32)+   , (VecWriteScalarOffAddrOp WordVec 4 W64)+   , (VecWriteScalarOffAddrOp WordVec 64 W8)+   , (VecWriteScalarOffAddrOp WordVec 32 W16)+   , (VecWriteScalarOffAddrOp WordVec 16 W32)+   , (VecWriteScalarOffAddrOp WordVec 8 W64)+   , (VecWriteScalarOffAddrOp FloatVec 4 W32)+   , (VecWriteScalarOffAddrOp FloatVec 2 W64)+   , (VecWriteScalarOffAddrOp FloatVec 8 W32)+   , (VecWriteScalarOffAddrOp FloatVec 4 W64)+   , (VecWriteScalarOffAddrOp FloatVec 16 W32)+   , (VecWriteScalarOffAddrOp FloatVec 8 W64)+   , PrefetchByteArrayOp3+   , PrefetchMutableByteArrayOp3+   , PrefetchAddrOp3+   , PrefetchValueOp3+   , PrefetchByteArrayOp2+   , PrefetchMutableByteArrayOp2+   , PrefetchAddrOp2+   , PrefetchValueOp2+   , PrefetchByteArrayOp1+   , PrefetchMutableByteArrayOp1+   , PrefetchAddrOp1+   , PrefetchValueOp1+   , PrefetchByteArrayOp0+   , PrefetchMutableByteArrayOp0+   , PrefetchAddrOp0+   , PrefetchValueOp0+   ]
+ ghc-lib/stage1/compiler/build/primop-out-of-line.hs-incl view
@@ -0,0 +1,102 @@+primOpOutOfLine DoubleDecode_2IntOp = True+primOpOutOfLine DoubleDecode_Int64Op = True+primOpOutOfLine FloatDecode_IntOp = True+primOpOutOfLine NewArrayOp = True+primOpOutOfLine UnsafeThawArrayOp = True+primOpOutOfLine CopyArrayOp = True+primOpOutOfLine CopyMutableArrayOp = True+primOpOutOfLine CloneArrayOp = True+primOpOutOfLine CloneMutableArrayOp = True+primOpOutOfLine FreezeArrayOp = True+primOpOutOfLine ThawArrayOp = True+primOpOutOfLine CasArrayOp = True+primOpOutOfLine NewSmallArrayOp = True+primOpOutOfLine UnsafeThawSmallArrayOp = True+primOpOutOfLine CopySmallArrayOp = True+primOpOutOfLine CopySmallMutableArrayOp = True+primOpOutOfLine CloneSmallArrayOp = True+primOpOutOfLine CloneSmallMutableArrayOp = True+primOpOutOfLine FreezeSmallArrayOp = True+primOpOutOfLine ThawSmallArrayOp = True+primOpOutOfLine CasSmallArrayOp = True+primOpOutOfLine NewByteArrayOp_Char = True+primOpOutOfLine NewPinnedByteArrayOp_Char = True+primOpOutOfLine NewAlignedPinnedByteArrayOp_Char = True+primOpOutOfLine MutableByteArrayIsPinnedOp = True+primOpOutOfLine ByteArrayIsPinnedOp = True+primOpOutOfLine ShrinkMutableByteArrayOp_Char = True+primOpOutOfLine ResizeMutableByteArrayOp_Char = True+primOpOutOfLine NewArrayArrayOp = True+primOpOutOfLine CopyArrayArrayOp = True+primOpOutOfLine CopyMutableArrayArrayOp = True+primOpOutOfLine NewMutVarOp = True+primOpOutOfLine AtomicModifyMutVar2Op = True+primOpOutOfLine AtomicModifyMutVar_Op = True+primOpOutOfLine CasMutVarOp = True+primOpOutOfLine CatchOp = True+primOpOutOfLine RaiseOp = True+primOpOutOfLine RaiseIOOp = True+primOpOutOfLine MaskAsyncExceptionsOp = True+primOpOutOfLine MaskUninterruptibleOp = True+primOpOutOfLine UnmaskAsyncExceptionsOp = True+primOpOutOfLine MaskStatus = True+primOpOutOfLine AtomicallyOp = True+primOpOutOfLine RetryOp = True+primOpOutOfLine CatchRetryOp = True+primOpOutOfLine CatchSTMOp = True+primOpOutOfLine NewTVarOp = True+primOpOutOfLine ReadTVarOp = True+primOpOutOfLine ReadTVarIOOp = True+primOpOutOfLine WriteTVarOp = True+primOpOutOfLine NewMVarOp = True+primOpOutOfLine TakeMVarOp = True+primOpOutOfLine TryTakeMVarOp = True+primOpOutOfLine PutMVarOp = True+primOpOutOfLine TryPutMVarOp = True+primOpOutOfLine ReadMVarOp = True+primOpOutOfLine TryReadMVarOp = True+primOpOutOfLine IsEmptyMVarOp = True+primOpOutOfLine DelayOp = True+primOpOutOfLine WaitReadOp = True+primOpOutOfLine WaitWriteOp = True+primOpOutOfLine ForkOp = True+primOpOutOfLine ForkOnOp = True+primOpOutOfLine KillThreadOp = True+primOpOutOfLine YieldOp = True+primOpOutOfLine LabelThreadOp = True+primOpOutOfLine IsCurrentThreadBoundOp = True+primOpOutOfLine NoDuplicateOp = True+primOpOutOfLine ThreadStatusOp = True+primOpOutOfLine MkWeakOp = True+primOpOutOfLine MkWeakNoFinalizerOp = True+primOpOutOfLine AddCFinalizerToWeakOp = True+primOpOutOfLine DeRefWeakOp = True+primOpOutOfLine FinalizeWeakOp = True+primOpOutOfLine MakeStablePtrOp = True+primOpOutOfLine DeRefStablePtrOp = True+primOpOutOfLine MakeStableNameOp = True+primOpOutOfLine CompactNewOp = True+primOpOutOfLine CompactResizeOp = True+primOpOutOfLine CompactContainsOp = True+primOpOutOfLine CompactContainsAnyOp = True+primOpOutOfLine CompactGetFirstBlockOp = True+primOpOutOfLine CompactGetNextBlockOp = True+primOpOutOfLine CompactAllocateBlockOp = True+primOpOutOfLine CompactFixupPointersOp = True+primOpOutOfLine CompactAdd = True+primOpOutOfLine CompactAddWithSharing = True+primOpOutOfLine CompactSize = True+primOpOutOfLine GetSparkOp = True+primOpOutOfLine NumSparks = True+primOpOutOfLine MkApUpd0_Op = True+primOpOutOfLine NewBCOOp = True+primOpOutOfLine UnpackClosureOp = True+primOpOutOfLine ClosureSizeOp = True+primOpOutOfLine GetApStackValOp = True+primOpOutOfLine ClearCCSOp = True+primOpOutOfLine TraceEventOp = True+primOpOutOfLine TraceEventBinaryOp = True+primOpOutOfLine TraceMarkerOp = True+primOpOutOfLine GetThreadAllocationCounter = True+primOpOutOfLine SetThreadAllocationCounter = True+primOpOutOfLine _ = False
+ ghc-lib/stage1/compiler/build/primop-primop-info.hs-incl view
@@ -0,0 +1,1198 @@+primOpInfo CharGtOp = mkCompare (fsLit "gtChar#") charPrimTy+primOpInfo CharGeOp = mkCompare (fsLit "geChar#") charPrimTy+primOpInfo CharEqOp = mkCompare (fsLit "eqChar#") charPrimTy+primOpInfo CharNeOp = mkCompare (fsLit "neChar#") charPrimTy+primOpInfo CharLtOp = mkCompare (fsLit "ltChar#") charPrimTy+primOpInfo CharLeOp = mkCompare (fsLit "leChar#") charPrimTy+primOpInfo OrdOp = mkGenPrimOp (fsLit "ord#")  [] [charPrimTy] (intPrimTy)+primOpInfo IntAddOp = mkDyadic (fsLit "+#") intPrimTy+primOpInfo IntSubOp = mkDyadic (fsLit "-#") intPrimTy+primOpInfo IntMulOp = mkDyadic (fsLit "*#") intPrimTy+primOpInfo IntMulMayOfloOp = mkDyadic (fsLit "mulIntMayOflo#") intPrimTy+primOpInfo IntQuotOp = mkDyadic (fsLit "quotInt#") intPrimTy+primOpInfo IntRemOp = mkDyadic (fsLit "remInt#") intPrimTy+primOpInfo IntQuotRemOp = mkGenPrimOp (fsLit "quotRemInt#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo AndIOp = mkDyadic (fsLit "andI#") intPrimTy+primOpInfo OrIOp = mkDyadic (fsLit "orI#") intPrimTy+primOpInfo XorIOp = mkDyadic (fsLit "xorI#") intPrimTy+primOpInfo NotIOp = mkMonadic (fsLit "notI#") intPrimTy+primOpInfo IntNegOp = mkMonadic (fsLit "negateInt#") intPrimTy+primOpInfo IntAddCOp = mkGenPrimOp (fsLit "addIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo IntSubCOp = mkGenPrimOp (fsLit "subIntC#")  [] [intPrimTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo IntGtOp = mkCompare (fsLit ">#") intPrimTy+primOpInfo IntGeOp = mkCompare (fsLit ">=#") intPrimTy+primOpInfo IntEqOp = mkCompare (fsLit "==#") intPrimTy+primOpInfo IntNeOp = mkCompare (fsLit "/=#") intPrimTy+primOpInfo IntLtOp = mkCompare (fsLit "<#") intPrimTy+primOpInfo IntLeOp = mkCompare (fsLit "<=#") intPrimTy+primOpInfo ChrOp = mkGenPrimOp (fsLit "chr#")  [] [intPrimTy] (charPrimTy)+primOpInfo Int2WordOp = mkGenPrimOp (fsLit "int2Word#")  [] [intPrimTy] (wordPrimTy)+primOpInfo Int2FloatOp = mkGenPrimOp (fsLit "int2Float#")  [] [intPrimTy] (floatPrimTy)+primOpInfo Int2DoubleOp = mkGenPrimOp (fsLit "int2Double#")  [] [intPrimTy] (doublePrimTy)+primOpInfo Word2FloatOp = mkGenPrimOp (fsLit "word2Float#")  [] [wordPrimTy] (floatPrimTy)+primOpInfo Word2DoubleOp = mkGenPrimOp (fsLit "word2Double#")  [] [wordPrimTy] (doublePrimTy)+primOpInfo ISllOp = mkGenPrimOp (fsLit "uncheckedIShiftL#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo ISraOp = mkGenPrimOp (fsLit "uncheckedIShiftRA#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo ISrlOp = mkGenPrimOp (fsLit "uncheckedIShiftRL#")  [] [intPrimTy, intPrimTy] (intPrimTy)+primOpInfo Int8Extend = mkGenPrimOp (fsLit "extendInt8#")  [] [int8PrimTy] (intPrimTy)+primOpInfo Int8Narrow = mkGenPrimOp (fsLit "narrowInt8#")  [] [intPrimTy] (int8PrimTy)+primOpInfo Int8NegOp = mkMonadic (fsLit "negateInt8#") int8PrimTy+primOpInfo Int8AddOp = mkDyadic (fsLit "plusInt8#") int8PrimTy+primOpInfo Int8SubOp = mkDyadic (fsLit "subInt8#") int8PrimTy+primOpInfo Int8MulOp = mkDyadic (fsLit "timesInt8#") int8PrimTy+primOpInfo Int8QuotOp = mkDyadic (fsLit "quotInt8#") int8PrimTy+primOpInfo Int8RemOp = mkDyadic (fsLit "remInt8#") int8PrimTy+primOpInfo Int8QuotRemOp = mkGenPrimOp (fsLit "quotRemInt8#")  [] [int8PrimTy, int8PrimTy] ((mkTupleTy Unboxed [int8PrimTy, int8PrimTy]))+primOpInfo Int8EqOp = mkCompare (fsLit "eqInt8#") int8PrimTy+primOpInfo Int8GeOp = mkCompare (fsLit "geInt8#") int8PrimTy+primOpInfo Int8GtOp = mkCompare (fsLit "gtInt8#") int8PrimTy+primOpInfo Int8LeOp = mkCompare (fsLit "leInt8#") int8PrimTy+primOpInfo Int8LtOp = mkCompare (fsLit "ltInt8#") int8PrimTy+primOpInfo Int8NeOp = mkCompare (fsLit "neInt8#") int8PrimTy+primOpInfo Word8Extend = mkGenPrimOp (fsLit "extendWord8#")  [] [word8PrimTy] (wordPrimTy)+primOpInfo Word8Narrow = mkGenPrimOp (fsLit "narrowWord8#")  [] [wordPrimTy] (word8PrimTy)+primOpInfo Word8NotOp = mkMonadic (fsLit "notWord8#") word8PrimTy+primOpInfo Word8AddOp = mkDyadic (fsLit "plusWord8#") word8PrimTy+primOpInfo Word8SubOp = mkDyadic (fsLit "subWord8#") word8PrimTy+primOpInfo Word8MulOp = mkDyadic (fsLit "timesWord8#") word8PrimTy+primOpInfo Word8QuotOp = mkDyadic (fsLit "quotWord8#") word8PrimTy+primOpInfo Word8RemOp = mkDyadic (fsLit "remWord8#") word8PrimTy+primOpInfo Word8QuotRemOp = mkGenPrimOp (fsLit "quotRemWord8#")  [] [word8PrimTy, word8PrimTy] ((mkTupleTy Unboxed [word8PrimTy, word8PrimTy]))+primOpInfo Word8EqOp = mkCompare (fsLit "eqWord8#") word8PrimTy+primOpInfo Word8GeOp = mkCompare (fsLit "geWord8#") word8PrimTy+primOpInfo Word8GtOp = mkCompare (fsLit "gtWord8#") word8PrimTy+primOpInfo Word8LeOp = mkCompare (fsLit "leWord8#") word8PrimTy+primOpInfo Word8LtOp = mkCompare (fsLit "ltWord8#") word8PrimTy+primOpInfo Word8NeOp = mkCompare (fsLit "neWord8#") word8PrimTy+primOpInfo Int16Extend = mkGenPrimOp (fsLit "extendInt16#")  [] [int16PrimTy] (intPrimTy)+primOpInfo Int16Narrow = mkGenPrimOp (fsLit "narrowInt16#")  [] [intPrimTy] (int16PrimTy)+primOpInfo Int16NegOp = mkMonadic (fsLit "negateInt16#") int16PrimTy+primOpInfo Int16AddOp = mkDyadic (fsLit "plusInt16#") int16PrimTy+primOpInfo Int16SubOp = mkDyadic (fsLit "subInt16#") int16PrimTy+primOpInfo Int16MulOp = mkDyadic (fsLit "timesInt16#") int16PrimTy+primOpInfo Int16QuotOp = mkDyadic (fsLit "quotInt16#") int16PrimTy+primOpInfo Int16RemOp = mkDyadic (fsLit "remInt16#") int16PrimTy+primOpInfo Int16QuotRemOp = mkGenPrimOp (fsLit "quotRemInt16#")  [] [int16PrimTy, int16PrimTy] ((mkTupleTy Unboxed [int16PrimTy, int16PrimTy]))+primOpInfo Int16EqOp = mkCompare (fsLit "eqInt16#") int16PrimTy+primOpInfo Int16GeOp = mkCompare (fsLit "geInt16#") int16PrimTy+primOpInfo Int16GtOp = mkCompare (fsLit "gtInt16#") int16PrimTy+primOpInfo Int16LeOp = mkCompare (fsLit "leInt16#") int16PrimTy+primOpInfo Int16LtOp = mkCompare (fsLit "ltInt16#") int16PrimTy+primOpInfo Int16NeOp = mkCompare (fsLit "neInt16#") int16PrimTy+primOpInfo Word16Extend = mkGenPrimOp (fsLit "extendWord16#")  [] [word16PrimTy] (wordPrimTy)+primOpInfo Word16Narrow = mkGenPrimOp (fsLit "narrowWord16#")  [] [wordPrimTy] (word16PrimTy)+primOpInfo Word16NotOp = mkMonadic (fsLit "notWord16#") word16PrimTy+primOpInfo Word16AddOp = mkDyadic (fsLit "plusWord16#") word16PrimTy+primOpInfo Word16SubOp = mkDyadic (fsLit "subWord16#") word16PrimTy+primOpInfo Word16MulOp = mkDyadic (fsLit "timesWord16#") word16PrimTy+primOpInfo Word16QuotOp = mkDyadic (fsLit "quotWord16#") word16PrimTy+primOpInfo Word16RemOp = mkDyadic (fsLit "remWord16#") word16PrimTy+primOpInfo Word16QuotRemOp = mkGenPrimOp (fsLit "quotRemWord16#")  [] [word16PrimTy, word16PrimTy] ((mkTupleTy Unboxed [word16PrimTy, word16PrimTy]))+primOpInfo Word16EqOp = mkCompare (fsLit "eqWord16#") word16PrimTy+primOpInfo Word16GeOp = mkCompare (fsLit "geWord16#") word16PrimTy+primOpInfo Word16GtOp = mkCompare (fsLit "gtWord16#") word16PrimTy+primOpInfo Word16LeOp = mkCompare (fsLit "leWord16#") word16PrimTy+primOpInfo Word16LtOp = mkCompare (fsLit "ltWord16#") word16PrimTy+primOpInfo Word16NeOp = mkCompare (fsLit "neWord16#") word16PrimTy+primOpInfo WordAddOp = mkDyadic (fsLit "plusWord#") wordPrimTy+primOpInfo WordAddCOp = mkGenPrimOp (fsLit "addWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))+primOpInfo WordSubCOp = mkGenPrimOp (fsLit "subWordC#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, intPrimTy]))+primOpInfo WordAdd2Op = mkGenPrimOp (fsLit "plusWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo WordSubOp = mkDyadic (fsLit "minusWord#") wordPrimTy+primOpInfo WordMulOp = mkDyadic (fsLit "timesWord#") wordPrimTy+primOpInfo WordMul2Op = mkGenPrimOp (fsLit "timesWord2#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo WordQuotOp = mkDyadic (fsLit "quotWord#") wordPrimTy+primOpInfo WordRemOp = mkDyadic (fsLit "remWord#") wordPrimTy+primOpInfo WordQuotRemOp = mkGenPrimOp (fsLit "quotRemWord#")  [] [wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo WordQuotRem2Op = mkGenPrimOp (fsLit "quotRemWord2#")  [] [wordPrimTy, wordPrimTy, wordPrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo AndOp = mkDyadic (fsLit "and#") wordPrimTy+primOpInfo OrOp = mkDyadic (fsLit "or#") wordPrimTy+primOpInfo XorOp = mkDyadic (fsLit "xor#") wordPrimTy+primOpInfo NotOp = mkMonadic (fsLit "not#") wordPrimTy+primOpInfo SllOp = mkGenPrimOp (fsLit "uncheckedShiftL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)+primOpInfo SrlOp = mkGenPrimOp (fsLit "uncheckedShiftRL#")  [] [wordPrimTy, intPrimTy] (wordPrimTy)+primOpInfo Word2IntOp = mkGenPrimOp (fsLit "word2Int#")  [] [wordPrimTy] (intPrimTy)+primOpInfo WordGtOp = mkCompare (fsLit "gtWord#") wordPrimTy+primOpInfo WordGeOp = mkCompare (fsLit "geWord#") wordPrimTy+primOpInfo WordEqOp = mkCompare (fsLit "eqWord#") wordPrimTy+primOpInfo WordNeOp = mkCompare (fsLit "neWord#") wordPrimTy+primOpInfo WordLtOp = mkCompare (fsLit "ltWord#") wordPrimTy+primOpInfo WordLeOp = mkCompare (fsLit "leWord#") wordPrimTy+primOpInfo PopCnt8Op = mkMonadic (fsLit "popCnt8#") wordPrimTy+primOpInfo PopCnt16Op = mkMonadic (fsLit "popCnt16#") wordPrimTy+primOpInfo PopCnt32Op = mkMonadic (fsLit "popCnt32#") wordPrimTy+primOpInfo PopCnt64Op = mkGenPrimOp (fsLit "popCnt64#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo PopCntOp = mkMonadic (fsLit "popCnt#") wordPrimTy+primOpInfo Pdep8Op = mkDyadic (fsLit "pdep8#") wordPrimTy+primOpInfo Pdep16Op = mkDyadic (fsLit "pdep16#") wordPrimTy+primOpInfo Pdep32Op = mkDyadic (fsLit "pdep32#") wordPrimTy+primOpInfo Pdep64Op = mkGenPrimOp (fsLit "pdep64#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo PdepOp = mkDyadic (fsLit "pdep#") wordPrimTy+primOpInfo Pext8Op = mkDyadic (fsLit "pext8#") wordPrimTy+primOpInfo Pext16Op = mkDyadic (fsLit "pext16#") wordPrimTy+primOpInfo Pext32Op = mkDyadic (fsLit "pext32#") wordPrimTy+primOpInfo Pext64Op = mkGenPrimOp (fsLit "pext64#")  [] [wordPrimTy, wordPrimTy] (wordPrimTy)+primOpInfo PextOp = mkDyadic (fsLit "pext#") wordPrimTy+primOpInfo Clz8Op = mkMonadic (fsLit "clz8#") wordPrimTy+primOpInfo Clz16Op = mkMonadic (fsLit "clz16#") wordPrimTy+primOpInfo Clz32Op = mkMonadic (fsLit "clz32#") wordPrimTy+primOpInfo Clz64Op = mkGenPrimOp (fsLit "clz64#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo ClzOp = mkMonadic (fsLit "clz#") wordPrimTy+primOpInfo Ctz8Op = mkMonadic (fsLit "ctz8#") wordPrimTy+primOpInfo Ctz16Op = mkMonadic (fsLit "ctz16#") wordPrimTy+primOpInfo Ctz32Op = mkMonadic (fsLit "ctz32#") wordPrimTy+primOpInfo Ctz64Op = mkGenPrimOp (fsLit "ctz64#")  [] [wordPrimTy] (wordPrimTy)+primOpInfo CtzOp = mkMonadic (fsLit "ctz#") wordPrimTy+primOpInfo BSwap16Op = mkMonadic (fsLit "byteSwap16#") wordPrimTy+primOpInfo BSwap32Op = mkMonadic (fsLit "byteSwap32#") wordPrimTy+primOpInfo BSwap64Op = mkMonadic (fsLit "byteSwap64#") wordPrimTy+primOpInfo BSwapOp = mkMonadic (fsLit "byteSwap#") wordPrimTy+primOpInfo BRev8Op = mkMonadic (fsLit "bitReverse8#") wordPrimTy+primOpInfo BRev16Op = mkMonadic (fsLit "bitReverse16#") wordPrimTy+primOpInfo BRev32Op = mkMonadic (fsLit "bitReverse32#") wordPrimTy+primOpInfo BRev64Op = mkMonadic (fsLit "bitReverse64#") wordPrimTy+primOpInfo BRevOp = mkMonadic (fsLit "bitReverse#") wordPrimTy+primOpInfo Narrow8IntOp = mkMonadic (fsLit "narrow8Int#") intPrimTy+primOpInfo Narrow16IntOp = mkMonadic (fsLit "narrow16Int#") intPrimTy+primOpInfo Narrow32IntOp = mkMonadic (fsLit "narrow32Int#") intPrimTy+primOpInfo Narrow8WordOp = mkMonadic (fsLit "narrow8Word#") wordPrimTy+primOpInfo Narrow16WordOp = mkMonadic (fsLit "narrow16Word#") wordPrimTy+primOpInfo Narrow32WordOp = mkMonadic (fsLit "narrow32Word#") wordPrimTy+primOpInfo DoubleGtOp = mkCompare (fsLit ">##") doublePrimTy+primOpInfo DoubleGeOp = mkCompare (fsLit ">=##") doublePrimTy+primOpInfo DoubleEqOp = mkCompare (fsLit "==##") doublePrimTy+primOpInfo DoubleNeOp = mkCompare (fsLit "/=##") doublePrimTy+primOpInfo DoubleLtOp = mkCompare (fsLit "<##") doublePrimTy+primOpInfo DoubleLeOp = mkCompare (fsLit "<=##") doublePrimTy+primOpInfo DoubleAddOp = mkDyadic (fsLit "+##") doublePrimTy+primOpInfo DoubleSubOp = mkDyadic (fsLit "-##") doublePrimTy+primOpInfo DoubleMulOp = mkDyadic (fsLit "*##") doublePrimTy+primOpInfo DoubleDivOp = mkDyadic (fsLit "/##") doublePrimTy+primOpInfo DoubleNegOp = mkMonadic (fsLit "negateDouble#") doublePrimTy+primOpInfo DoubleFabsOp = mkMonadic (fsLit "fabsDouble#") doublePrimTy+primOpInfo Double2IntOp = mkGenPrimOp (fsLit "double2Int#")  [] [doublePrimTy] (intPrimTy)+primOpInfo Double2FloatOp = mkGenPrimOp (fsLit "double2Float#")  [] [doublePrimTy] (floatPrimTy)+primOpInfo DoubleExpOp = mkMonadic (fsLit "expDouble#") doublePrimTy+primOpInfo DoubleLogOp = mkMonadic (fsLit "logDouble#") doublePrimTy+primOpInfo DoubleSqrtOp = mkMonadic (fsLit "sqrtDouble#") doublePrimTy+primOpInfo DoubleSinOp = mkMonadic (fsLit "sinDouble#") doublePrimTy+primOpInfo DoubleCosOp = mkMonadic (fsLit "cosDouble#") doublePrimTy+primOpInfo DoubleTanOp = mkMonadic (fsLit "tanDouble#") doublePrimTy+primOpInfo DoubleAsinOp = mkMonadic (fsLit "asinDouble#") doublePrimTy+primOpInfo DoubleAcosOp = mkMonadic (fsLit "acosDouble#") doublePrimTy+primOpInfo DoubleAtanOp = mkMonadic (fsLit "atanDouble#") doublePrimTy+primOpInfo DoubleSinhOp = mkMonadic (fsLit "sinhDouble#") doublePrimTy+primOpInfo DoubleCoshOp = mkMonadic (fsLit "coshDouble#") doublePrimTy+primOpInfo DoubleTanhOp = mkMonadic (fsLit "tanhDouble#") doublePrimTy+primOpInfo DoubleAsinhOp = mkMonadic (fsLit "asinhDouble#") doublePrimTy+primOpInfo DoubleAcoshOp = mkMonadic (fsLit "acoshDouble#") doublePrimTy+primOpInfo DoubleAtanhOp = mkMonadic (fsLit "atanhDouble#") doublePrimTy+primOpInfo DoublePowerOp = mkDyadic (fsLit "**##") doublePrimTy+primOpInfo DoubleDecode_2IntOp = mkGenPrimOp (fsLit "decodeDouble_2Int#")  [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, wordPrimTy, wordPrimTy, intPrimTy]))+primOpInfo DoubleDecode_Int64Op = mkGenPrimOp (fsLit "decodeDouble_Int64#")  [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo FloatGtOp = mkCompare (fsLit "gtFloat#") floatPrimTy+primOpInfo FloatGeOp = mkCompare (fsLit "geFloat#") floatPrimTy+primOpInfo FloatEqOp = mkCompare (fsLit "eqFloat#") floatPrimTy+primOpInfo FloatNeOp = mkCompare (fsLit "neFloat#") floatPrimTy+primOpInfo FloatLtOp = mkCompare (fsLit "ltFloat#") floatPrimTy+primOpInfo FloatLeOp = mkCompare (fsLit "leFloat#") floatPrimTy+primOpInfo FloatAddOp = mkDyadic (fsLit "plusFloat#") floatPrimTy+primOpInfo FloatSubOp = mkDyadic (fsLit "minusFloat#") floatPrimTy+primOpInfo FloatMulOp = mkDyadic (fsLit "timesFloat#") floatPrimTy+primOpInfo FloatDivOp = mkDyadic (fsLit "divideFloat#") floatPrimTy+primOpInfo FloatNegOp = mkMonadic (fsLit "negateFloat#") floatPrimTy+primOpInfo FloatFabsOp = mkMonadic (fsLit "fabsFloat#") floatPrimTy+primOpInfo Float2IntOp = mkGenPrimOp (fsLit "float2Int#")  [] [floatPrimTy] (intPrimTy)+primOpInfo FloatExpOp = mkMonadic (fsLit "expFloat#") floatPrimTy+primOpInfo FloatLogOp = mkMonadic (fsLit "logFloat#") floatPrimTy+primOpInfo FloatSqrtOp = mkMonadic (fsLit "sqrtFloat#") floatPrimTy+primOpInfo FloatSinOp = mkMonadic (fsLit "sinFloat#") floatPrimTy+primOpInfo FloatCosOp = mkMonadic (fsLit "cosFloat#") floatPrimTy+primOpInfo FloatTanOp = mkMonadic (fsLit "tanFloat#") floatPrimTy+primOpInfo FloatAsinOp = mkMonadic (fsLit "asinFloat#") floatPrimTy+primOpInfo FloatAcosOp = mkMonadic (fsLit "acosFloat#") floatPrimTy+primOpInfo FloatAtanOp = mkMonadic (fsLit "atanFloat#") floatPrimTy+primOpInfo FloatSinhOp = mkMonadic (fsLit "sinhFloat#") floatPrimTy+primOpInfo FloatCoshOp = mkMonadic (fsLit "coshFloat#") floatPrimTy+primOpInfo FloatTanhOp = mkMonadic (fsLit "tanhFloat#") floatPrimTy+primOpInfo FloatAsinhOp = mkMonadic (fsLit "asinhFloat#") floatPrimTy+primOpInfo FloatAcoshOp = mkMonadic (fsLit "acoshFloat#") floatPrimTy+primOpInfo FloatAtanhOp = mkMonadic (fsLit "atanhFloat#") floatPrimTy+primOpInfo FloatPowerOp = mkDyadic (fsLit "powerFloat#") floatPrimTy+primOpInfo Float2DoubleOp = mkGenPrimOp (fsLit "float2Double#")  [] [floatPrimTy] (doublePrimTy)+primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#")  [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo NewArrayOp = mkGenPrimOp (fsLit "newArray#")  [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo SameMutableArrayOp = mkGenPrimOp (fsLit "sameMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo ReadArrayOp = mkGenPrimOp (fsLit "readArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo WriteArrayOp = mkGenPrimOp (fsLit "writeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SizeofArrayOp = mkGenPrimOp (fsLit "sizeofArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy] (intPrimTy)+primOpInfo SizeofMutableArrayOp = mkGenPrimOp (fsLit "sizeofMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo IndexArrayOp = mkGenPrimOp (fsLit "indexArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy]))+primOpInfo UnsafeFreezeArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy]))+primOpInfo UnsafeThawArrayOp = mkGenPrimOp (fsLit "unsafeThawArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo CopyArrayOp = mkGenPrimOp (fsLit "copyArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyMutableArrayOp = mkGenPrimOp (fsLit "copyMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CloneArrayOp = mkGenPrimOp (fsLit "cloneArray#")  [alphaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkArrayPrimTy alphaTy)+primOpInfo CloneMutableArrayOp = mkGenPrimOp (fsLit "cloneMutableArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo FreezeArrayOp = mkGenPrimOp (fsLit "freezeArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayPrimTy alphaTy]))+primOpInfo ThawArrayOp = mkGenPrimOp (fsLit "thawArray#")  [alphaTyVar, deltaTyVar] [mkArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo CasArrayOp = mkGenPrimOp (fsLit "casArray#")  [deltaTyVar, alphaTyVar] [mkMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo NewSmallArrayOp = mkGenPrimOp (fsLit "newSmallArray#")  [alphaTyVar, deltaTyVar] [intPrimTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo SameSmallMutableArrayOp = mkGenPrimOp (fsLit "sameSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo ReadSmallArrayOp = mkGenPrimOp (fsLit "readSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo WriteSmallArrayOp = mkGenPrimOp (fsLit "writeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SizeofSmallArrayOp = mkGenPrimOp (fsLit "sizeofSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy] (intPrimTy)+primOpInfo SizeofSmallMutableArrayOp = mkGenPrimOp (fsLit "sizeofSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo IndexSmallArrayOp = mkGenPrimOp (fsLit "indexSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy] ((mkTupleTy Unboxed [alphaTy]))+primOpInfo UnsafeFreezeSmallArrayOp = mkGenPrimOp (fsLit "unsafeFreezeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy]))+primOpInfo UnsafeThawSmallArrayOp = mkGenPrimOp (fsLit "unsafeThawSmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo CopySmallArrayOp = mkGenPrimOp (fsLit "copySmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopySmallMutableArrayOp = mkGenPrimOp (fsLit "copySmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CloneSmallArrayOp = mkGenPrimOp (fsLit "cloneSmallArray#")  [alphaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy] (mkSmallArrayPrimTy alphaTy)+primOpInfo CloneSmallMutableArrayOp = mkGenPrimOp (fsLit "cloneSmallMutableArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo FreezeSmallArrayOp = mkGenPrimOp (fsLit "freezeSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallArrayPrimTy alphaTy]))+primOpInfo ThawSmallArrayOp = mkGenPrimOp (fsLit "thawSmallArray#")  [alphaTyVar, deltaTyVar] [mkSmallArrayPrimTy alphaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkSmallMutableArrayPrimTy deltaTy alphaTy]))+primOpInfo CasSmallArrayOp = mkGenPrimOp (fsLit "casSmallArray#")  [deltaTyVar, alphaTyVar] [mkSmallMutableArrayPrimTy deltaTy alphaTy, intPrimTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo NewByteArrayOp_Char = mkGenPrimOp (fsLit "newByteArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo NewPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newPinnedByteArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo NewAlignedPinnedByteArrayOp_Char = mkGenPrimOp (fsLit "newAlignedPinnedByteArray#")  [deltaTyVar] [intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo MutableByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isMutableByteArrayPinned#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)+primOpInfo ByteArrayIsPinnedOp = mkGenPrimOp (fsLit "isByteArrayPinned#")  [] [byteArrayPrimTy] (intPrimTy)+primOpInfo ByteArrayContents_Char = mkGenPrimOp (fsLit "byteArrayContents#")  [] [byteArrayPrimTy] (addrPrimTy)+primOpInfo SameMutableByteArrayOp = mkGenPrimOp (fsLit "sameMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy] (intPrimTy)+primOpInfo ShrinkMutableByteArrayOp_Char = mkGenPrimOp (fsLit "shrinkMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo ResizeMutableByteArrayOp_Char = mkGenPrimOp (fsLit "resizeMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo UnsafeFreezeByteArrayOp = mkGenPrimOp (fsLit "unsafeFreezeByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy]))+primOpInfo SizeofByteArrayOp = mkGenPrimOp (fsLit "sizeofByteArray#")  [] [byteArrayPrimTy] (intPrimTy)+primOpInfo SizeofMutableByteArrayOp = mkGenPrimOp (fsLit "sizeofMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy)+primOpInfo GetSizeofMutableByteArrayOp = mkGenPrimOp (fsLit "getSizeofMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo IndexByteArrayOp_Char = mkGenPrimOp (fsLit "indexCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexByteArrayOp_WideChar = mkGenPrimOp (fsLit "indexWideCharArray#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexByteArrayOp_Int = mkGenPrimOp (fsLit "indexIntArray#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word = mkGenPrimOp (fsLit "indexWordArray#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Addr = mkGenPrimOp (fsLit "indexAddrArray#")  [] [byteArrayPrimTy, intPrimTy] (addrPrimTy)+primOpInfo IndexByteArrayOp_Float = mkGenPrimOp (fsLit "indexFloatArray#")  [] [byteArrayPrimTy, intPrimTy] (floatPrimTy)+primOpInfo IndexByteArrayOp_Double = mkGenPrimOp (fsLit "indexDoubleArray#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)+primOpInfo IndexByteArrayOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrArray#")  [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)+primOpInfo IndexByteArrayOp_Int8 = mkGenPrimOp (fsLit "indexInt8Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Int16 = mkGenPrimOp (fsLit "indexInt16Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Int32 = mkGenPrimOp (fsLit "indexInt32Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Int64 = mkGenPrimOp (fsLit "indexInt64Array#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word8 = mkGenPrimOp (fsLit "indexWord8Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word16 = mkGenPrimOp (fsLit "indexWord16Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word32 = mkGenPrimOp (fsLit "indexWord32Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word64 = mkGenPrimOp (fsLit "indexWord64Array#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "indexWord8ArrayAsChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "indexWord8ArrayAsWideChar#")  [] [byteArrayPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "indexWord8ArrayAsAddr#")  [] [byteArrayPrimTy, intPrimTy] (addrPrimTy)+primOpInfo IndexByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "indexWord8ArrayAsFloat#")  [] [byteArrayPrimTy, intPrimTy] (floatPrimTy)+primOpInfo IndexByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "indexWord8ArrayAsDouble#")  [] [byteArrayPrimTy, intPrimTy] (doublePrimTy)+primOpInfo IndexByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "indexWord8ArrayAsStablePtr#")  [alphaTyVar] [byteArrayPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)+primOpInfo IndexByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt16#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt32#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8ArrayAsInt64#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "indexWord8ArrayAsInt#")  [] [byteArrayPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord16#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord32#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8ArrayAsWord64#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "indexWord8ArrayAsWord#")  [] [byteArrayPrimTy, intPrimTy] (wordPrimTy)+primOpInfo ReadByteArrayOp_Char = mkGenPrimOp (fsLit "readCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadByteArrayOp_WideChar = mkGenPrimOp (fsLit "readWideCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadByteArrayOp_Int = mkGenPrimOp (fsLit "readIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word = mkGenPrimOp (fsLit "readWordArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Addr = mkGenPrimOp (fsLit "readAddrArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo ReadByteArrayOp_Float = mkGenPrimOp (fsLit "readFloatArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))+primOpInfo ReadByteArrayOp_Double = mkGenPrimOp (fsLit "readDoubleArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))+primOpInfo ReadByteArrayOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrArray#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))+primOpInfo ReadByteArrayOp_Int8 = mkGenPrimOp (fsLit "readInt8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Int16 = mkGenPrimOp (fsLit "readInt16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Int32 = mkGenPrimOp (fsLit "readInt32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Int64 = mkGenPrimOp (fsLit "readInt64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word8 = mkGenPrimOp (fsLit "readWord8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word16 = mkGenPrimOp (fsLit "readWord16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word32 = mkGenPrimOp (fsLit "readWord32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word64 = mkGenPrimOp (fsLit "readWord64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "readWord8ArrayAsChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "readWord8ArrayAsWideChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "readWord8ArrayAsAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "readWord8ArrayAsFloat#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "readWord8ArrayAsDouble#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))+primOpInfo ReadByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "readWord8ArrayAsStablePtr#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))+primOpInfo ReadByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "readWord8ArrayAsInt16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8ArrayAsInt32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8ArrayAsInt64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "readWord8ArrayAsInt#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "readWord8ArrayAsWord16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "readWord8ArrayAsWord32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8ArrayAsWord64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "readWord8ArrayAsWord#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo WriteByteArrayOp_Char = mkGenPrimOp (fsLit "writeCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_WideChar = mkGenPrimOp (fsLit "writeWideCharArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int = mkGenPrimOp (fsLit "writeIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word = mkGenPrimOp (fsLit "writeWordArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Addr = mkGenPrimOp (fsLit "writeAddrArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Float = mkGenPrimOp (fsLit "writeFloatArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Double = mkGenPrimOp (fsLit "writeDoubleArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrArray#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int8 = mkGenPrimOp (fsLit "writeInt8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int16 = mkGenPrimOp (fsLit "writeInt16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int32 = mkGenPrimOp (fsLit "writeInt32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Int64 = mkGenPrimOp (fsLit "writeInt64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8 = mkGenPrimOp (fsLit "writeWord8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word16 = mkGenPrimOp (fsLit "writeWord16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word32 = mkGenPrimOp (fsLit "writeWord32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word64 = mkGenPrimOp (fsLit "writeWord64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsChar = mkGenPrimOp (fsLit "writeWord8ArrayAsChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWideChar = mkGenPrimOp (fsLit "writeWord8ArrayAsWideChar#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsAddr = mkGenPrimOp (fsLit "writeWord8ArrayAsAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsFloat = mkGenPrimOp (fsLit "writeWord8ArrayAsFloat#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsDouble = mkGenPrimOp (fsLit "writeWord8ArrayAsDouble#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsStablePtr = mkGenPrimOp (fsLit "writeWord8ArrayAsStablePtr#")  [deltaTyVar, alphaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsInt16 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8ArrayAsInt64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsInt = mkGenPrimOp (fsLit "writeWord8ArrayAsInt#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWord16 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWord32 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8ArrayAsWord64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteByteArrayOp_Word8AsWord = mkGenPrimOp (fsLit "writeWord8ArrayAsWord#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CompareByteArraysOp = mkGenPrimOp (fsLit "compareByteArrays#")  [] [byteArrayPrimTy, intPrimTy, byteArrayPrimTy, intPrimTy, intPrimTy] (intPrimTy)+primOpInfo CopyByteArrayOp = mkGenPrimOp (fsLit "copyByteArray#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyMutableByteArrayOp = mkGenPrimOp (fsLit "copyMutableByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyByteArrayToAddrOp = mkGenPrimOp (fsLit "copyByteArrayToAddr#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyMutableByteArrayToAddrOp = mkGenPrimOp (fsLit "copyMutableByteArrayToAddr#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyAddrToByteArrayOp = mkGenPrimOp (fsLit "copyAddrToByteArray#")  [deltaTyVar] [addrPrimTy, mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SetByteArrayOp = mkGenPrimOp (fsLit "setByteArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo AtomicReadByteArrayOp_Int = mkGenPrimOp (fsLit "atomicReadIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo AtomicWriteByteArrayOp_Int = mkGenPrimOp (fsLit "atomicWriteIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CasByteArrayOp_Int = mkGenPrimOp (fsLit "casIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchAddByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAddIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchSubByteArrayOp_Int = mkGenPrimOp (fsLit "fetchSubIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchAndByteArrayOp_Int = mkGenPrimOp (fsLit "fetchAndIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchNandByteArrayOp_Int = mkGenPrimOp (fsLit "fetchNandIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchOrByteArrayOp_Int = mkGenPrimOp (fsLit "fetchOrIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo FetchXorByteArrayOp_Int = mkGenPrimOp (fsLit "fetchXorIntArray#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo NewArrayArrayOp = mkGenPrimOp (fsLit "newArrayArray#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy]))+primOpInfo SameMutableArrayArrayOp = mkGenPrimOp (fsLit "sameMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy] (intPrimTy)+primOpInfo UnsafeFreezeArrayArrayOp = mkGenPrimOp (fsLit "unsafeFreezeArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy]))+primOpInfo SizeofArrayArrayOp = mkGenPrimOp (fsLit "sizeofArrayArray#")  [] [mkArrayArrayPrimTy] (intPrimTy)+primOpInfo SizeofMutableArrayArrayOp = mkGenPrimOp (fsLit "sizeofMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy] (intPrimTy)+primOpInfo IndexArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "indexByteArrayArray#")  [] [mkArrayArrayPrimTy, intPrimTy] (byteArrayPrimTy)+primOpInfo IndexArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "indexArrayArrayArray#")  [] [mkArrayArrayPrimTy, intPrimTy] (mkArrayArrayPrimTy)+primOpInfo ReadArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "readByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy]))+primOpInfo ReadArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "readMutableByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy]))+primOpInfo ReadArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "readArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkArrayArrayPrimTy]))+primOpInfo ReadArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "readMutableArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableArrayArrayPrimTy deltaTy]))+primOpInfo WriteArrayArrayOp_ByteArray = mkGenPrimOp (fsLit "writeByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteArrayArrayOp_MutableByteArray = mkGenPrimOp (fsLit "writeMutableByteArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteArrayArrayOp_ArrayArray = mkGenPrimOp (fsLit "writeArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkArrayArrayPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteArrayArrayOp_MutableArrayArray = mkGenPrimOp (fsLit "writeMutableArrayArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyArrayArrayOp = mkGenPrimOp (fsLit "copyArrayArray#")  [deltaTyVar] [mkArrayArrayPrimTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo CopyMutableArrayArrayOp = mkGenPrimOp (fsLit "copyMutableArrayArray#")  [deltaTyVar] [mkMutableArrayArrayPrimTy deltaTy, intPrimTy, mkMutableArrayArrayPrimTy deltaTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo AddrAddOp = mkGenPrimOp (fsLit "plusAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)+primOpInfo AddrSubOp = mkGenPrimOp (fsLit "minusAddr#")  [] [addrPrimTy, addrPrimTy] (intPrimTy)+primOpInfo AddrRemOp = mkGenPrimOp (fsLit "remAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo Addr2IntOp = mkGenPrimOp (fsLit "addr2Int#")  [] [addrPrimTy] (intPrimTy)+primOpInfo Int2AddrOp = mkGenPrimOp (fsLit "int2Addr#")  [] [intPrimTy] (addrPrimTy)+primOpInfo AddrGtOp = mkCompare (fsLit "gtAddr#") addrPrimTy+primOpInfo AddrGeOp = mkCompare (fsLit "geAddr#") addrPrimTy+primOpInfo AddrEqOp = mkCompare (fsLit "eqAddr#") addrPrimTy+primOpInfo AddrNeOp = mkCompare (fsLit "neAddr#") addrPrimTy+primOpInfo AddrLtOp = mkCompare (fsLit "ltAddr#") addrPrimTy+primOpInfo AddrLeOp = mkCompare (fsLit "leAddr#") addrPrimTy+primOpInfo IndexOffAddrOp_Char = mkGenPrimOp (fsLit "indexCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexOffAddrOp_WideChar = mkGenPrimOp (fsLit "indexWideCharOffAddr#")  [] [addrPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexOffAddrOp_Int = mkGenPrimOp (fsLit "indexIntOffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Word = mkGenPrimOp (fsLit "indexWordOffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexOffAddrOp_Addr = mkGenPrimOp (fsLit "indexAddrOffAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)+primOpInfo IndexOffAddrOp_Float = mkGenPrimOp (fsLit "indexFloatOffAddr#")  [] [addrPrimTy, intPrimTy] (floatPrimTy)+primOpInfo IndexOffAddrOp_Double = mkGenPrimOp (fsLit "indexDoubleOffAddr#")  [] [addrPrimTy, intPrimTy] (doublePrimTy)+primOpInfo IndexOffAddrOp_StablePtr = mkGenPrimOp (fsLit "indexStablePtrOffAddr#")  [alphaTyVar] [addrPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)+primOpInfo IndexOffAddrOp_Int8 = mkGenPrimOp (fsLit "indexInt8OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Int16 = mkGenPrimOp (fsLit "indexInt16OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Int32 = mkGenPrimOp (fsLit "indexInt32OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Word8 = mkGenPrimOp (fsLit "indexWord8OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexOffAddrOp_Word16 = mkGenPrimOp (fsLit "indexWord16OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadOffAddrOp_Int = mkGenPrimOp (fsLit "readIntOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Word = mkGenPrimOp (fsLit "readWordOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadOffAddrOp_Addr = mkGenPrimOp (fsLit "readAddrOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo ReadOffAddrOp_Float = mkGenPrimOp (fsLit "readFloatOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))+primOpInfo ReadOffAddrOp_Double = mkGenPrimOp (fsLit "readDoubleOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))+primOpInfo ReadOffAddrOp_StablePtr = mkGenPrimOp (fsLit "readStablePtrOffAddr#")  [deltaTyVar, alphaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))+primOpInfo ReadOffAddrOp_Int8 = mkGenPrimOp (fsLit "readInt8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Int16 = mkGenPrimOp (fsLit "readInt16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Int32 = mkGenPrimOp (fsLit "readInt32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Word8 = mkGenPrimOp (fsLit "readWord8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadOffAddrOp_Word16 = mkGenPrimOp (fsLit "readWord16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int = mkGenPrimOp (fsLit "writeIntOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word = mkGenPrimOp (fsLit "writeWordOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Addr = mkGenPrimOp (fsLit "writeAddrOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Float = mkGenPrimOp (fsLit "writeFloatOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Double = mkGenPrimOp (fsLit "writeDoubleOffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_StablePtr = mkGenPrimOp (fsLit "writeStablePtrOffAddr#")  [alphaTyVar, deltaTyVar] [addrPrimTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int8 = mkGenPrimOp (fsLit "writeInt8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int16 = mkGenPrimOp (fsLit "writeInt16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int32 = mkGenPrimOp (fsLit "writeInt32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8 = mkGenPrimOp (fsLit "writeWord8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word16 = mkGenPrimOp (fsLit "writeWord16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo NewMutVarOp = mkGenPrimOp (fsLit "newMutVar#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutVarPrimTy deltaTy alphaTy]))+primOpInfo ReadMutVarOp = mkGenPrimOp (fsLit "readMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo WriteMutVarOp = mkGenPrimOp (fsLit "writeMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SameMutVarOp = mkGenPrimOp (fsLit "sameMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, mkMutVarPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo AtomicModifyMutVar2Op = mkGenPrimOp (fsLit "atomicModifyMutVar2#")  [deltaTyVar, alphaTyVar, gammaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTy (alphaTy) (gammaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, gammaTy]))+primOpInfo AtomicModifyMutVar_Op = mkGenPrimOp (fsLit "atomicModifyMutVar_#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, (mkVisFunTy (alphaTy) (alphaTy)), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy, alphaTy]))+primOpInfo CasMutVarOp = mkGenPrimOp (fsLit "casMutVar#")  [deltaTyVar, alphaTyVar] [mkMutVarPrimTy deltaTy alphaTy, alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo CatchOp = mkGenPrimOp (fsLit "catch#")  [alphaTyVar, betaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (betaTy) ((mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo RaiseOp = mkGenPrimOp (fsLit "raise#")  [betaTyVar, runtimeRep1TyVar, openAlphaTyVar] [betaTy] (openAlphaTy)+primOpInfo RaiseIOOp = mkGenPrimOp (fsLit "raiseIO#")  [alphaTyVar, betaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy]))+primOpInfo MaskAsyncExceptionsOp = mkGenPrimOp (fsLit "maskAsyncExceptions#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo MaskUninterruptibleOp = mkGenPrimOp (fsLit "maskUninterruptible#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo UnmaskAsyncExceptionsOp = mkGenPrimOp (fsLit "unmaskAsyncExceptions#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo MaskStatus = mkGenPrimOp (fsLit "getMaskingState#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo AtomicallyOp = mkGenPrimOp (fsLit "atomically#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo RetryOp = mkGenPrimOp (fsLit "retry#")  [alphaTyVar] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CatchRetryOp = mkGenPrimOp (fsLit "catchRetry#")  [alphaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CatchSTMOp = mkGenPrimOp (fsLit "catchSTM#")  [alphaTyVar, betaTyVar] [(mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))), (mkVisFunTy (betaTy) ((mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo NewTVarOp = mkGenPrimOp (fsLit "newTVar#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkTVarPrimTy deltaTy alphaTy]))+primOpInfo ReadTVarOp = mkGenPrimOp (fsLit "readTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo ReadTVarIOOp = mkGenPrimOp (fsLit "readTVarIO#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo WriteTVarOp = mkGenPrimOp (fsLit "writeTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo SameTVarOp = mkGenPrimOp (fsLit "sameTVar#")  [deltaTyVar, alphaTyVar] [mkTVarPrimTy deltaTy alphaTy, mkTVarPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo NewMVarOp = mkGenPrimOp (fsLit "newMVar#")  [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMVarPrimTy deltaTy alphaTy]))+primOpInfo TakeMVarOp = mkGenPrimOp (fsLit "takeMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo TryTakeMVarOp = mkGenPrimOp (fsLit "tryTakeMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo PutMVarOp = mkGenPrimOp (fsLit "putMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo TryPutMVarOp = mkGenPrimOp (fsLit "tryPutMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadMVarOp = mkGenPrimOp (fsLit "readMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo TryReadMVarOp = mkGenPrimOp (fsLit "tryReadMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo SameMVarOp = mkGenPrimOp (fsLit "sameMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkMVarPrimTy deltaTy alphaTy] (intPrimTy)+primOpInfo IsEmptyMVarOp = mkGenPrimOp (fsLit "isEmptyMVar#")  [deltaTyVar, alphaTyVar] [mkMVarPrimTy deltaTy alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo DelayOp = mkGenPrimOp (fsLit "delay#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WaitReadOp = mkGenPrimOp (fsLit "waitRead#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WaitWriteOp = mkGenPrimOp (fsLit "waitWrite#")  [deltaTyVar] [intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo ForkOp = mkGenPrimOp (fsLit "fork#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))+primOpInfo ForkOnOp = mkGenPrimOp (fsLit "forkOn#")  [alphaTyVar] [intPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))+primOpInfo KillThreadOp = mkGenPrimOp (fsLit "killThread#")  [alphaTyVar] [threadIdPrimTy, alphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo YieldOp = mkGenPrimOp (fsLit "yield#")  [] [mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo MyThreadIdOp = mkGenPrimOp (fsLit "myThreadId#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, threadIdPrimTy]))+primOpInfo LabelThreadOp = mkGenPrimOp (fsLit "labelThread#")  [] [threadIdPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo IsCurrentThreadBoundOp = mkGenPrimOp (fsLit "isCurrentThreadBound#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo NoDuplicateOp = mkGenPrimOp (fsLit "noDuplicate#")  [deltaTyVar] [mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo ThreadStatusOp = mkGenPrimOp (fsLit "threadStatus#")  [] [threadIdPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo MkWeakOp = mkGenPrimOp (fsLit "mkWeak#")  [runtimeRep1TyVar, openAlphaTyVar, betaTyVar, gammaTyVar] [openAlphaTy, betaTy, (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, gammaTy]))), mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy]))+primOpInfo MkWeakNoFinalizerOp = mkGenPrimOp (fsLit "mkWeakNoFinalizer#")  [runtimeRep1TyVar, openAlphaTyVar, betaTyVar] [openAlphaTy, betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkWeakPrimTy betaTy]))+primOpInfo AddCFinalizerToWeakOp = mkGenPrimOp (fsLit "addCFinalizerToWeak#")  [betaTyVar] [addrPrimTy, addrPrimTy, intPrimTy, addrPrimTy, mkWeakPrimTy betaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo DeRefWeakOp = mkGenPrimOp (fsLit "deRefWeak#")  [alphaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, alphaTy]))+primOpInfo FinalizeWeakOp = mkGenPrimOp (fsLit "finalizeWeak#")  [alphaTyVar, betaTyVar] [mkWeakPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy, (mkVisFunTy (mkStatePrimTy realWorldTy) ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, betaTy])))]))+primOpInfo TouchOp = mkGenPrimOp (fsLit "touch#")  [runtimeRep1TyVar, openAlphaTyVar] [openAlphaTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo MakeStablePtrOp = mkGenPrimOp (fsLit "makeStablePtr#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStablePtrPrimTy alphaTy]))+primOpInfo DeRefStablePtrOp = mkGenPrimOp (fsLit "deRefStablePtr#")  [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo EqStablePtrOp = mkGenPrimOp (fsLit "eqStablePtr#")  [alphaTyVar] [mkStablePtrPrimTy alphaTy, mkStablePtrPrimTy alphaTy] (intPrimTy)+primOpInfo MakeStableNameOp = mkGenPrimOp (fsLit "makeStableName#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, mkStableNamePrimTy alphaTy]))+primOpInfo EqStableNameOp = mkGenPrimOp (fsLit "eqStableName#")  [alphaTyVar, betaTyVar] [mkStableNamePrimTy alphaTy, mkStableNamePrimTy betaTy] (intPrimTy)+primOpInfo StableNameToIntOp = mkGenPrimOp (fsLit "stableNameToInt#")  [alphaTyVar] [mkStableNamePrimTy alphaTy] (intPrimTy)+primOpInfo CompactNewOp = mkGenPrimOp (fsLit "compactNew#")  [] [wordPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy]))+primOpInfo CompactResizeOp = mkGenPrimOp (fsLit "compactResize#")  [] [compactPrimTy, wordPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo CompactContainsOp = mkGenPrimOp (fsLit "compactContains#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo CompactContainsAnyOp = mkGenPrimOp (fsLit "compactContainsAny#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo CompactGetFirstBlockOp = mkGenPrimOp (fsLit "compactGetFirstBlock#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))+primOpInfo CompactGetNextBlockOp = mkGenPrimOp (fsLit "compactGetNextBlock#")  [] [compactPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy, wordPrimTy]))+primOpInfo CompactAllocateBlockOp = mkGenPrimOp (fsLit "compactAllocateBlock#")  [] [wordPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))+primOpInfo CompactFixupPointersOp = mkGenPrimOp (fsLit "compactFixupPointers#")  [] [addrPrimTy, addrPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, compactPrimTy, addrPrimTy]))+primOpInfo CompactAdd = mkGenPrimOp (fsLit "compactAdd#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CompactAddWithSharing = mkGenPrimOp (fsLit "compactAddWithSharing#")  [alphaTyVar] [compactPrimTy, alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, alphaTy]))+primOpInfo CompactSize = mkGenPrimOp (fsLit "compactSize#")  [] [compactPrimTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, wordPrimTy]))+primOpInfo ReallyUnsafePtrEqualityOp = mkGenPrimOp (fsLit "reallyUnsafePtrEquality#")  [alphaTyVar] [alphaTy, alphaTy] (intPrimTy)+primOpInfo ParOp = mkGenPrimOp (fsLit "par#")  [alphaTyVar] [alphaTy] (intPrimTy)+primOpInfo SparkOp = mkGenPrimOp (fsLit "spark#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo SeqOp = mkGenPrimOp (fsLit "seq#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#")  [deltaTyVar, alphaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy]))+primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#")  [deltaTyVar] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#")  [alphaTyVar] [alphaTy] (intPrimTy)+primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#")  [alphaTyVar] [intPrimTy] (alphaTy)+primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#")  [alphaTyVar] [addrPrimTy] ((mkTupleTy Unboxed [alphaTy]))+primOpInfo AnyToAddrOp = mkGenPrimOp (fsLit "anyToAddr#")  [alphaTyVar] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))+primOpInfo MkApUpd0_Op = mkGenPrimOp (fsLit "mkApUpd0#")  [alphaTyVar] [bcoPrimTy] ((mkTupleTy Unboxed [alphaTy]))+primOpInfo NewBCOOp = mkGenPrimOp (fsLit "newBCO#")  [alphaTyVar, deltaTyVar] [byteArrayPrimTy, byteArrayPrimTy, mkArrayPrimTy alphaTy, intPrimTy, byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, bcoPrimTy]))+primOpInfo UnpackClosureOp = mkGenPrimOp (fsLit "unpackClosure#")  [alphaTyVar, betaTyVar] [alphaTy] ((mkTupleTy Unboxed [addrPrimTy, byteArrayPrimTy, mkArrayPrimTy betaTy]))+primOpInfo ClosureSizeOp = mkGenPrimOp (fsLit "closureSize#")  [alphaTyVar] [alphaTy] (intPrimTy)+primOpInfo GetApStackValOp = mkGenPrimOp (fsLit "getApStackVal#")  [alphaTyVar, betaTyVar] [alphaTy, intPrimTy] ((mkTupleTy Unboxed [intPrimTy, betaTy]))+primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#")  [deltaTyVar, alphaTyVar] [(mkVisFunTy (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))+primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#")  [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#")  [deltaTyVar] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo GetThreadAllocationCounter = mkGenPrimOp (fsLit "getThreadAllocationCounter#")  [] [mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, intPrimTy]))+primOpInfo SetThreadAllocationCounter = mkGenPrimOp (fsLit "setThreadAllocationCounter#")  [] [intPrimTy, mkStatePrimTy realWorldTy] (mkStatePrimTy realWorldTy)+primOpInfo (VecBroadcastOp IntVec 16 W8) = mkGenPrimOp (fsLit "broadcastInt8X16#")  [] [intPrimTy] (int8X16PrimTy)+primOpInfo (VecBroadcastOp IntVec 8 W16) = mkGenPrimOp (fsLit "broadcastInt16X8#")  [] [intPrimTy] (int16X8PrimTy)+primOpInfo (VecBroadcastOp IntVec 4 W32) = mkGenPrimOp (fsLit "broadcastInt32X4#")  [] [intPrimTy] (int32X4PrimTy)+primOpInfo (VecBroadcastOp IntVec 2 W64) = mkGenPrimOp (fsLit "broadcastInt64X2#")  [] [intPrimTy] (int64X2PrimTy)+primOpInfo (VecBroadcastOp IntVec 32 W8) = mkGenPrimOp (fsLit "broadcastInt8X32#")  [] [intPrimTy] (int8X32PrimTy)+primOpInfo (VecBroadcastOp IntVec 16 W16) = mkGenPrimOp (fsLit "broadcastInt16X16#")  [] [intPrimTy] (int16X16PrimTy)+primOpInfo (VecBroadcastOp IntVec 8 W32) = mkGenPrimOp (fsLit "broadcastInt32X8#")  [] [intPrimTy] (int32X8PrimTy)+primOpInfo (VecBroadcastOp IntVec 4 W64) = mkGenPrimOp (fsLit "broadcastInt64X4#")  [] [intPrimTy] (int64X4PrimTy)+primOpInfo (VecBroadcastOp IntVec 64 W8) = mkGenPrimOp (fsLit "broadcastInt8X64#")  [] [intPrimTy] (int8X64PrimTy)+primOpInfo (VecBroadcastOp IntVec 32 W16) = mkGenPrimOp (fsLit "broadcastInt16X32#")  [] [intPrimTy] (int16X32PrimTy)+primOpInfo (VecBroadcastOp IntVec 16 W32) = mkGenPrimOp (fsLit "broadcastInt32X16#")  [] [intPrimTy] (int32X16PrimTy)+primOpInfo (VecBroadcastOp IntVec 8 W64) = mkGenPrimOp (fsLit "broadcastInt64X8#")  [] [intPrimTy] (int64X8PrimTy)+primOpInfo (VecBroadcastOp WordVec 16 W8) = mkGenPrimOp (fsLit "broadcastWord8X16#")  [] [wordPrimTy] (word8X16PrimTy)+primOpInfo (VecBroadcastOp WordVec 8 W16) = mkGenPrimOp (fsLit "broadcastWord16X8#")  [] [wordPrimTy] (word16X8PrimTy)+primOpInfo (VecBroadcastOp WordVec 4 W32) = mkGenPrimOp (fsLit "broadcastWord32X4#")  [] [wordPrimTy] (word32X4PrimTy)+primOpInfo (VecBroadcastOp WordVec 2 W64) = mkGenPrimOp (fsLit "broadcastWord64X2#")  [] [wordPrimTy] (word64X2PrimTy)+primOpInfo (VecBroadcastOp WordVec 32 W8) = mkGenPrimOp (fsLit "broadcastWord8X32#")  [] [wordPrimTy] (word8X32PrimTy)+primOpInfo (VecBroadcastOp WordVec 16 W16) = mkGenPrimOp (fsLit "broadcastWord16X16#")  [] [wordPrimTy] (word16X16PrimTy)+primOpInfo (VecBroadcastOp WordVec 8 W32) = mkGenPrimOp (fsLit "broadcastWord32X8#")  [] [wordPrimTy] (word32X8PrimTy)+primOpInfo (VecBroadcastOp WordVec 4 W64) = mkGenPrimOp (fsLit "broadcastWord64X4#")  [] [wordPrimTy] (word64X4PrimTy)+primOpInfo (VecBroadcastOp WordVec 64 W8) = mkGenPrimOp (fsLit "broadcastWord8X64#")  [] [wordPrimTy] (word8X64PrimTy)+primOpInfo (VecBroadcastOp WordVec 32 W16) = mkGenPrimOp (fsLit "broadcastWord16X32#")  [] [wordPrimTy] (word16X32PrimTy)+primOpInfo (VecBroadcastOp WordVec 16 W32) = mkGenPrimOp (fsLit "broadcastWord32X16#")  [] [wordPrimTy] (word32X16PrimTy)+primOpInfo (VecBroadcastOp WordVec 8 W64) = mkGenPrimOp (fsLit "broadcastWord64X8#")  [] [wordPrimTy] (word64X8PrimTy)+primOpInfo (VecBroadcastOp FloatVec 4 W32) = mkGenPrimOp (fsLit "broadcastFloatX4#")  [] [floatPrimTy] (floatX4PrimTy)+primOpInfo (VecBroadcastOp FloatVec 2 W64) = mkGenPrimOp (fsLit "broadcastDoubleX2#")  [] [doublePrimTy] (doubleX2PrimTy)+primOpInfo (VecBroadcastOp FloatVec 8 W32) = mkGenPrimOp (fsLit "broadcastFloatX8#")  [] [floatPrimTy] (floatX8PrimTy)+primOpInfo (VecBroadcastOp FloatVec 4 W64) = mkGenPrimOp (fsLit "broadcastDoubleX4#")  [] [doublePrimTy] (doubleX4PrimTy)+primOpInfo (VecBroadcastOp FloatVec 16 W32) = mkGenPrimOp (fsLit "broadcastFloatX16#")  [] [floatPrimTy] (floatX16PrimTy)+primOpInfo (VecBroadcastOp FloatVec 8 W64) = mkGenPrimOp (fsLit "broadcastDoubleX8#")  [] [doublePrimTy] (doubleX8PrimTy)+primOpInfo (VecPackOp IntVec 16 W8) = mkGenPrimOp (fsLit "packInt8X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X16PrimTy)+primOpInfo (VecPackOp IntVec 8 W16) = mkGenPrimOp (fsLit "packInt16X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X8PrimTy)+primOpInfo (VecPackOp IntVec 4 W32) = mkGenPrimOp (fsLit "packInt32X4#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X4PrimTy)+primOpInfo (VecPackOp IntVec 2 W64) = mkGenPrimOp (fsLit "packInt64X2#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy])] (int64X2PrimTy)+primOpInfo (VecPackOp IntVec 32 W8) = mkGenPrimOp (fsLit "packInt8X32#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X32PrimTy)+primOpInfo (VecPackOp IntVec 16 W16) = mkGenPrimOp (fsLit "packInt16X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X16PrimTy)+primOpInfo (VecPackOp IntVec 8 W32) = mkGenPrimOp (fsLit "packInt32X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X8PrimTy)+primOpInfo (VecPackOp IntVec 4 W64) = mkGenPrimOp (fsLit "packInt64X4#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X4PrimTy)+primOpInfo (VecPackOp IntVec 64 W8) = mkGenPrimOp (fsLit "packInt8X64#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int8X64PrimTy)+primOpInfo (VecPackOp IntVec 32 W16) = mkGenPrimOp (fsLit "packInt16X32#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int16X32PrimTy)+primOpInfo (VecPackOp IntVec 16 W32) = mkGenPrimOp (fsLit "packInt32X16#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int32X16PrimTy)+primOpInfo (VecPackOp IntVec 8 W64) = mkGenPrimOp (fsLit "packInt64X8#")  [] [(mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy])] (int64X8PrimTy)+primOpInfo (VecPackOp WordVec 16 W8) = mkGenPrimOp (fsLit "packWord8X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X16PrimTy)+primOpInfo (VecPackOp WordVec 8 W16) = mkGenPrimOp (fsLit "packWord16X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X8PrimTy)+primOpInfo (VecPackOp WordVec 4 W32) = mkGenPrimOp (fsLit "packWord32X4#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X4PrimTy)+primOpInfo (VecPackOp WordVec 2 W64) = mkGenPrimOp (fsLit "packWord64X2#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy])] (word64X2PrimTy)+primOpInfo (VecPackOp WordVec 32 W8) = mkGenPrimOp (fsLit "packWord8X32#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X32PrimTy)+primOpInfo (VecPackOp WordVec 16 W16) = mkGenPrimOp (fsLit "packWord16X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X16PrimTy)+primOpInfo (VecPackOp WordVec 8 W32) = mkGenPrimOp (fsLit "packWord32X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X8PrimTy)+primOpInfo (VecPackOp WordVec 4 W64) = mkGenPrimOp (fsLit "packWord64X4#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X4PrimTy)+primOpInfo (VecPackOp WordVec 64 W8) = mkGenPrimOp (fsLit "packWord8X64#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word8X64PrimTy)+primOpInfo (VecPackOp WordVec 32 W16) = mkGenPrimOp (fsLit "packWord16X32#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word16X32PrimTy)+primOpInfo (VecPackOp WordVec 16 W32) = mkGenPrimOp (fsLit "packWord32X16#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word32X16PrimTy)+primOpInfo (VecPackOp WordVec 8 W64) = mkGenPrimOp (fsLit "packWord64X8#")  [] [(mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy])] (word64X8PrimTy)+primOpInfo (VecPackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "packFloatX4#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX4PrimTy)+primOpInfo (VecPackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "packDoubleX2#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy])] (doubleX2PrimTy)+primOpInfo (VecPackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "packFloatX8#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX8PrimTy)+primOpInfo (VecPackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "packDoubleX4#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX4PrimTy)+primOpInfo (VecPackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "packFloatX16#")  [] [(mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy])] (floatX16PrimTy)+primOpInfo (VecPackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "packDoubleX8#")  [] [(mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy])] (doubleX8PrimTy)+primOpInfo (VecUnpackOp IntVec 16 W8) = mkGenPrimOp (fsLit "unpackInt8X16#")  [] [int8X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 8 W16) = mkGenPrimOp (fsLit "unpackInt16X8#")  [] [int16X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 4 W32) = mkGenPrimOp (fsLit "unpackInt32X4#")  [] [int32X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 2 W64) = mkGenPrimOp (fsLit "unpackInt64X2#")  [] [int64X2PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 32 W8) = mkGenPrimOp (fsLit "unpackInt8X32#")  [] [int8X32PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 16 W16) = mkGenPrimOp (fsLit "unpackInt16X16#")  [] [int16X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 8 W32) = mkGenPrimOp (fsLit "unpackInt32X8#")  [] [int32X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 4 W64) = mkGenPrimOp (fsLit "unpackInt64X4#")  [] [int64X4PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 64 W8) = mkGenPrimOp (fsLit "unpackInt8X64#")  [] [int8X64PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 32 W16) = mkGenPrimOp (fsLit "unpackInt16X32#")  [] [int16X32PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 16 W32) = mkGenPrimOp (fsLit "unpackInt32X16#")  [] [int32X16PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp IntVec 8 W64) = mkGenPrimOp (fsLit "unpackInt64X8#")  [] [int64X8PrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy]))+primOpInfo (VecUnpackOp WordVec 16 W8) = mkGenPrimOp (fsLit "unpackWord8X16#")  [] [word8X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 8 W16) = mkGenPrimOp (fsLit "unpackWord16X8#")  [] [word16X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 4 W32) = mkGenPrimOp (fsLit "unpackWord32X4#")  [] [word32X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 2 W64) = mkGenPrimOp (fsLit "unpackWord64X2#")  [] [word64X2PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 32 W8) = mkGenPrimOp (fsLit "unpackWord8X32#")  [] [word8X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 16 W16) = mkGenPrimOp (fsLit "unpackWord16X16#")  [] [word16X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 8 W32) = mkGenPrimOp (fsLit "unpackWord32X8#")  [] [word32X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 4 W64) = mkGenPrimOp (fsLit "unpackWord64X4#")  [] [word64X4PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 64 W8) = mkGenPrimOp (fsLit "unpackWord8X64#")  [] [word8X64PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 32 W16) = mkGenPrimOp (fsLit "unpackWord16X32#")  [] [word16X32PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 16 W32) = mkGenPrimOp (fsLit "unpackWord32X16#")  [] [word32X16PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp WordVec 8 W64) = mkGenPrimOp (fsLit "unpackWord64X8#")  [] [word64X8PrimTy] ((mkTupleTy Unboxed [wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy, wordPrimTy]))+primOpInfo (VecUnpackOp FloatVec 4 W32) = mkGenPrimOp (fsLit "unpackFloatX4#")  [] [floatX4PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))+primOpInfo (VecUnpackOp FloatVec 2 W64) = mkGenPrimOp (fsLit "unpackDoubleX2#")  [] [doubleX2PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy]))+primOpInfo (VecUnpackOp FloatVec 8 W32) = mkGenPrimOp (fsLit "unpackFloatX8#")  [] [floatX8PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))+primOpInfo (VecUnpackOp FloatVec 4 W64) = mkGenPrimOp (fsLit "unpackDoubleX4#")  [] [doubleX4PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))+primOpInfo (VecUnpackOp FloatVec 16 W32) = mkGenPrimOp (fsLit "unpackFloatX16#")  [] [floatX16PrimTy] ((mkTupleTy Unboxed [floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy, floatPrimTy]))+primOpInfo (VecUnpackOp FloatVec 8 W64) = mkGenPrimOp (fsLit "unpackDoubleX8#")  [] [doubleX8PrimTy] ((mkTupleTy Unboxed [doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy, doublePrimTy]))+primOpInfo (VecInsertOp IntVec 16 W8) = mkGenPrimOp (fsLit "insertInt8X16#")  [] [int8X16PrimTy, intPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecInsertOp IntVec 8 W16) = mkGenPrimOp (fsLit "insertInt16X8#")  [] [int16X8PrimTy, intPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecInsertOp IntVec 4 W32) = mkGenPrimOp (fsLit "insertInt32X4#")  [] [int32X4PrimTy, intPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecInsertOp IntVec 2 W64) = mkGenPrimOp (fsLit "insertInt64X2#")  [] [int64X2PrimTy, intPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecInsertOp IntVec 32 W8) = mkGenPrimOp (fsLit "insertInt8X32#")  [] [int8X32PrimTy, intPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecInsertOp IntVec 16 W16) = mkGenPrimOp (fsLit "insertInt16X16#")  [] [int16X16PrimTy, intPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecInsertOp IntVec 8 W32) = mkGenPrimOp (fsLit "insertInt32X8#")  [] [int32X8PrimTy, intPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecInsertOp IntVec 4 W64) = mkGenPrimOp (fsLit "insertInt64X4#")  [] [int64X4PrimTy, intPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecInsertOp IntVec 64 W8) = mkGenPrimOp (fsLit "insertInt8X64#")  [] [int8X64PrimTy, intPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecInsertOp IntVec 32 W16) = mkGenPrimOp (fsLit "insertInt16X32#")  [] [int16X32PrimTy, intPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecInsertOp IntVec 16 W32) = mkGenPrimOp (fsLit "insertInt32X16#")  [] [int32X16PrimTy, intPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecInsertOp IntVec 8 W64) = mkGenPrimOp (fsLit "insertInt64X8#")  [] [int64X8PrimTy, intPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecInsertOp WordVec 16 W8) = mkGenPrimOp (fsLit "insertWord8X16#")  [] [word8X16PrimTy, wordPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecInsertOp WordVec 8 W16) = mkGenPrimOp (fsLit "insertWord16X8#")  [] [word16X8PrimTy, wordPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecInsertOp WordVec 4 W32) = mkGenPrimOp (fsLit "insertWord32X4#")  [] [word32X4PrimTy, wordPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecInsertOp WordVec 2 W64) = mkGenPrimOp (fsLit "insertWord64X2#")  [] [word64X2PrimTy, wordPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecInsertOp WordVec 32 W8) = mkGenPrimOp (fsLit "insertWord8X32#")  [] [word8X32PrimTy, wordPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecInsertOp WordVec 16 W16) = mkGenPrimOp (fsLit "insertWord16X16#")  [] [word16X16PrimTy, wordPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecInsertOp WordVec 8 W32) = mkGenPrimOp (fsLit "insertWord32X8#")  [] [word32X8PrimTy, wordPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecInsertOp WordVec 4 W64) = mkGenPrimOp (fsLit "insertWord64X4#")  [] [word64X4PrimTy, wordPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecInsertOp WordVec 64 W8) = mkGenPrimOp (fsLit "insertWord8X64#")  [] [word8X64PrimTy, wordPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecInsertOp WordVec 32 W16) = mkGenPrimOp (fsLit "insertWord16X32#")  [] [word16X32PrimTy, wordPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecInsertOp WordVec 16 W32) = mkGenPrimOp (fsLit "insertWord32X16#")  [] [word32X16PrimTy, wordPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecInsertOp WordVec 8 W64) = mkGenPrimOp (fsLit "insertWord64X8#")  [] [word64X8PrimTy, wordPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecInsertOp FloatVec 4 W32) = mkGenPrimOp (fsLit "insertFloatX4#")  [] [floatX4PrimTy, floatPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecInsertOp FloatVec 2 W64) = mkGenPrimOp (fsLit "insertDoubleX2#")  [] [doubleX2PrimTy, doublePrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecInsertOp FloatVec 8 W32) = mkGenPrimOp (fsLit "insertFloatX8#")  [] [floatX8PrimTy, floatPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecInsertOp FloatVec 4 W64) = mkGenPrimOp (fsLit "insertDoubleX4#")  [] [doubleX4PrimTy, doublePrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecInsertOp FloatVec 16 W32) = mkGenPrimOp (fsLit "insertFloatX16#")  [] [floatX16PrimTy, floatPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecInsertOp FloatVec 8 W64) = mkGenPrimOp (fsLit "insertDoubleX8#")  [] [doubleX8PrimTy, doublePrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecAddOp IntVec 16 W8) = mkDyadic (fsLit "plusInt8X16#") int8X16PrimTy+primOpInfo (VecAddOp IntVec 8 W16) = mkDyadic (fsLit "plusInt16X8#") int16X8PrimTy+primOpInfo (VecAddOp IntVec 4 W32) = mkDyadic (fsLit "plusInt32X4#") int32X4PrimTy+primOpInfo (VecAddOp IntVec 2 W64) = mkDyadic (fsLit "plusInt64X2#") int64X2PrimTy+primOpInfo (VecAddOp IntVec 32 W8) = mkDyadic (fsLit "plusInt8X32#") int8X32PrimTy+primOpInfo (VecAddOp IntVec 16 W16) = mkDyadic (fsLit "plusInt16X16#") int16X16PrimTy+primOpInfo (VecAddOp IntVec 8 W32) = mkDyadic (fsLit "plusInt32X8#") int32X8PrimTy+primOpInfo (VecAddOp IntVec 4 W64) = mkDyadic (fsLit "plusInt64X4#") int64X4PrimTy+primOpInfo (VecAddOp IntVec 64 W8) = mkDyadic (fsLit "plusInt8X64#") int8X64PrimTy+primOpInfo (VecAddOp IntVec 32 W16) = mkDyadic (fsLit "plusInt16X32#") int16X32PrimTy+primOpInfo (VecAddOp IntVec 16 W32) = mkDyadic (fsLit "plusInt32X16#") int32X16PrimTy+primOpInfo (VecAddOp IntVec 8 W64) = mkDyadic (fsLit "plusInt64X8#") int64X8PrimTy+primOpInfo (VecAddOp WordVec 16 W8) = mkDyadic (fsLit "plusWord8X16#") word8X16PrimTy+primOpInfo (VecAddOp WordVec 8 W16) = mkDyadic (fsLit "plusWord16X8#") word16X8PrimTy+primOpInfo (VecAddOp WordVec 4 W32) = mkDyadic (fsLit "plusWord32X4#") word32X4PrimTy+primOpInfo (VecAddOp WordVec 2 W64) = mkDyadic (fsLit "plusWord64X2#") word64X2PrimTy+primOpInfo (VecAddOp WordVec 32 W8) = mkDyadic (fsLit "plusWord8X32#") word8X32PrimTy+primOpInfo (VecAddOp WordVec 16 W16) = mkDyadic (fsLit "plusWord16X16#") word16X16PrimTy+primOpInfo (VecAddOp WordVec 8 W32) = mkDyadic (fsLit "plusWord32X8#") word32X8PrimTy+primOpInfo (VecAddOp WordVec 4 W64) = mkDyadic (fsLit "plusWord64X4#") word64X4PrimTy+primOpInfo (VecAddOp WordVec 64 W8) = mkDyadic (fsLit "plusWord8X64#") word8X64PrimTy+primOpInfo (VecAddOp WordVec 32 W16) = mkDyadic (fsLit "plusWord16X32#") word16X32PrimTy+primOpInfo (VecAddOp WordVec 16 W32) = mkDyadic (fsLit "plusWord32X16#") word32X16PrimTy+primOpInfo (VecAddOp WordVec 8 W64) = mkDyadic (fsLit "plusWord64X8#") word64X8PrimTy+primOpInfo (VecAddOp FloatVec 4 W32) = mkDyadic (fsLit "plusFloatX4#") floatX4PrimTy+primOpInfo (VecAddOp FloatVec 2 W64) = mkDyadic (fsLit "plusDoubleX2#") doubleX2PrimTy+primOpInfo (VecAddOp FloatVec 8 W32) = mkDyadic (fsLit "plusFloatX8#") floatX8PrimTy+primOpInfo (VecAddOp FloatVec 4 W64) = mkDyadic (fsLit "plusDoubleX4#") doubleX4PrimTy+primOpInfo (VecAddOp FloatVec 16 W32) = mkDyadic (fsLit "plusFloatX16#") floatX16PrimTy+primOpInfo (VecAddOp FloatVec 8 W64) = mkDyadic (fsLit "plusDoubleX8#") doubleX8PrimTy+primOpInfo (VecSubOp IntVec 16 W8) = mkDyadic (fsLit "minusInt8X16#") int8X16PrimTy+primOpInfo (VecSubOp IntVec 8 W16) = mkDyadic (fsLit "minusInt16X8#") int16X8PrimTy+primOpInfo (VecSubOp IntVec 4 W32) = mkDyadic (fsLit "minusInt32X4#") int32X4PrimTy+primOpInfo (VecSubOp IntVec 2 W64) = mkDyadic (fsLit "minusInt64X2#") int64X2PrimTy+primOpInfo (VecSubOp IntVec 32 W8) = mkDyadic (fsLit "minusInt8X32#") int8X32PrimTy+primOpInfo (VecSubOp IntVec 16 W16) = mkDyadic (fsLit "minusInt16X16#") int16X16PrimTy+primOpInfo (VecSubOp IntVec 8 W32) = mkDyadic (fsLit "minusInt32X8#") int32X8PrimTy+primOpInfo (VecSubOp IntVec 4 W64) = mkDyadic (fsLit "minusInt64X4#") int64X4PrimTy+primOpInfo (VecSubOp IntVec 64 W8) = mkDyadic (fsLit "minusInt8X64#") int8X64PrimTy+primOpInfo (VecSubOp IntVec 32 W16) = mkDyadic (fsLit "minusInt16X32#") int16X32PrimTy+primOpInfo (VecSubOp IntVec 16 W32) = mkDyadic (fsLit "minusInt32X16#") int32X16PrimTy+primOpInfo (VecSubOp IntVec 8 W64) = mkDyadic (fsLit "minusInt64X8#") int64X8PrimTy+primOpInfo (VecSubOp WordVec 16 W8) = mkDyadic (fsLit "minusWord8X16#") word8X16PrimTy+primOpInfo (VecSubOp WordVec 8 W16) = mkDyadic (fsLit "minusWord16X8#") word16X8PrimTy+primOpInfo (VecSubOp WordVec 4 W32) = mkDyadic (fsLit "minusWord32X4#") word32X4PrimTy+primOpInfo (VecSubOp WordVec 2 W64) = mkDyadic (fsLit "minusWord64X2#") word64X2PrimTy+primOpInfo (VecSubOp WordVec 32 W8) = mkDyadic (fsLit "minusWord8X32#") word8X32PrimTy+primOpInfo (VecSubOp WordVec 16 W16) = mkDyadic (fsLit "minusWord16X16#") word16X16PrimTy+primOpInfo (VecSubOp WordVec 8 W32) = mkDyadic (fsLit "minusWord32X8#") word32X8PrimTy+primOpInfo (VecSubOp WordVec 4 W64) = mkDyadic (fsLit "minusWord64X4#") word64X4PrimTy+primOpInfo (VecSubOp WordVec 64 W8) = mkDyadic (fsLit "minusWord8X64#") word8X64PrimTy+primOpInfo (VecSubOp WordVec 32 W16) = mkDyadic (fsLit "minusWord16X32#") word16X32PrimTy+primOpInfo (VecSubOp WordVec 16 W32) = mkDyadic (fsLit "minusWord32X16#") word32X16PrimTy+primOpInfo (VecSubOp WordVec 8 W64) = mkDyadic (fsLit "minusWord64X8#") word64X8PrimTy+primOpInfo (VecSubOp FloatVec 4 W32) = mkDyadic (fsLit "minusFloatX4#") floatX4PrimTy+primOpInfo (VecSubOp FloatVec 2 W64) = mkDyadic (fsLit "minusDoubleX2#") doubleX2PrimTy+primOpInfo (VecSubOp FloatVec 8 W32) = mkDyadic (fsLit "minusFloatX8#") floatX8PrimTy+primOpInfo (VecSubOp FloatVec 4 W64) = mkDyadic (fsLit "minusDoubleX4#") doubleX4PrimTy+primOpInfo (VecSubOp FloatVec 16 W32) = mkDyadic (fsLit "minusFloatX16#") floatX16PrimTy+primOpInfo (VecSubOp FloatVec 8 W64) = mkDyadic (fsLit "minusDoubleX8#") doubleX8PrimTy+primOpInfo (VecMulOp IntVec 16 W8) = mkDyadic (fsLit "timesInt8X16#") int8X16PrimTy+primOpInfo (VecMulOp IntVec 8 W16) = mkDyadic (fsLit "timesInt16X8#") int16X8PrimTy+primOpInfo (VecMulOp IntVec 4 W32) = mkDyadic (fsLit "timesInt32X4#") int32X4PrimTy+primOpInfo (VecMulOp IntVec 2 W64) = mkDyadic (fsLit "timesInt64X2#") int64X2PrimTy+primOpInfo (VecMulOp IntVec 32 W8) = mkDyadic (fsLit "timesInt8X32#") int8X32PrimTy+primOpInfo (VecMulOp IntVec 16 W16) = mkDyadic (fsLit "timesInt16X16#") int16X16PrimTy+primOpInfo (VecMulOp IntVec 8 W32) = mkDyadic (fsLit "timesInt32X8#") int32X8PrimTy+primOpInfo (VecMulOp IntVec 4 W64) = mkDyadic (fsLit "timesInt64X4#") int64X4PrimTy+primOpInfo (VecMulOp IntVec 64 W8) = mkDyadic (fsLit "timesInt8X64#") int8X64PrimTy+primOpInfo (VecMulOp IntVec 32 W16) = mkDyadic (fsLit "timesInt16X32#") int16X32PrimTy+primOpInfo (VecMulOp IntVec 16 W32) = mkDyadic (fsLit "timesInt32X16#") int32X16PrimTy+primOpInfo (VecMulOp IntVec 8 W64) = mkDyadic (fsLit "timesInt64X8#") int64X8PrimTy+primOpInfo (VecMulOp WordVec 16 W8) = mkDyadic (fsLit "timesWord8X16#") word8X16PrimTy+primOpInfo (VecMulOp WordVec 8 W16) = mkDyadic (fsLit "timesWord16X8#") word16X8PrimTy+primOpInfo (VecMulOp WordVec 4 W32) = mkDyadic (fsLit "timesWord32X4#") word32X4PrimTy+primOpInfo (VecMulOp WordVec 2 W64) = mkDyadic (fsLit "timesWord64X2#") word64X2PrimTy+primOpInfo (VecMulOp WordVec 32 W8) = mkDyadic (fsLit "timesWord8X32#") word8X32PrimTy+primOpInfo (VecMulOp WordVec 16 W16) = mkDyadic (fsLit "timesWord16X16#") word16X16PrimTy+primOpInfo (VecMulOp WordVec 8 W32) = mkDyadic (fsLit "timesWord32X8#") word32X8PrimTy+primOpInfo (VecMulOp WordVec 4 W64) = mkDyadic (fsLit "timesWord64X4#") word64X4PrimTy+primOpInfo (VecMulOp WordVec 64 W8) = mkDyadic (fsLit "timesWord8X64#") word8X64PrimTy+primOpInfo (VecMulOp WordVec 32 W16) = mkDyadic (fsLit "timesWord16X32#") word16X32PrimTy+primOpInfo (VecMulOp WordVec 16 W32) = mkDyadic (fsLit "timesWord32X16#") word32X16PrimTy+primOpInfo (VecMulOp WordVec 8 W64) = mkDyadic (fsLit "timesWord64X8#") word64X8PrimTy+primOpInfo (VecMulOp FloatVec 4 W32) = mkDyadic (fsLit "timesFloatX4#") floatX4PrimTy+primOpInfo (VecMulOp FloatVec 2 W64) = mkDyadic (fsLit "timesDoubleX2#") doubleX2PrimTy+primOpInfo (VecMulOp FloatVec 8 W32) = mkDyadic (fsLit "timesFloatX8#") floatX8PrimTy+primOpInfo (VecMulOp FloatVec 4 W64) = mkDyadic (fsLit "timesDoubleX4#") doubleX4PrimTy+primOpInfo (VecMulOp FloatVec 16 W32) = mkDyadic (fsLit "timesFloatX16#") floatX16PrimTy+primOpInfo (VecMulOp FloatVec 8 W64) = mkDyadic (fsLit "timesDoubleX8#") doubleX8PrimTy+primOpInfo (VecDivOp FloatVec 4 W32) = mkDyadic (fsLit "divideFloatX4#") floatX4PrimTy+primOpInfo (VecDivOp FloatVec 2 W64) = mkDyadic (fsLit "divideDoubleX2#") doubleX2PrimTy+primOpInfo (VecDivOp FloatVec 8 W32) = mkDyadic (fsLit "divideFloatX8#") floatX8PrimTy+primOpInfo (VecDivOp FloatVec 4 W64) = mkDyadic (fsLit "divideDoubleX4#") doubleX4PrimTy+primOpInfo (VecDivOp FloatVec 16 W32) = mkDyadic (fsLit "divideFloatX16#") floatX16PrimTy+primOpInfo (VecDivOp FloatVec 8 W64) = mkDyadic (fsLit "divideDoubleX8#") doubleX8PrimTy+primOpInfo (VecQuotOp IntVec 16 W8) = mkDyadic (fsLit "quotInt8X16#") int8X16PrimTy+primOpInfo (VecQuotOp IntVec 8 W16) = mkDyadic (fsLit "quotInt16X8#") int16X8PrimTy+primOpInfo (VecQuotOp IntVec 4 W32) = mkDyadic (fsLit "quotInt32X4#") int32X4PrimTy+primOpInfo (VecQuotOp IntVec 2 W64) = mkDyadic (fsLit "quotInt64X2#") int64X2PrimTy+primOpInfo (VecQuotOp IntVec 32 W8) = mkDyadic (fsLit "quotInt8X32#") int8X32PrimTy+primOpInfo (VecQuotOp IntVec 16 W16) = mkDyadic (fsLit "quotInt16X16#") int16X16PrimTy+primOpInfo (VecQuotOp IntVec 8 W32) = mkDyadic (fsLit "quotInt32X8#") int32X8PrimTy+primOpInfo (VecQuotOp IntVec 4 W64) = mkDyadic (fsLit "quotInt64X4#") int64X4PrimTy+primOpInfo (VecQuotOp IntVec 64 W8) = mkDyadic (fsLit "quotInt8X64#") int8X64PrimTy+primOpInfo (VecQuotOp IntVec 32 W16) = mkDyadic (fsLit "quotInt16X32#") int16X32PrimTy+primOpInfo (VecQuotOp IntVec 16 W32) = mkDyadic (fsLit "quotInt32X16#") int32X16PrimTy+primOpInfo (VecQuotOp IntVec 8 W64) = mkDyadic (fsLit "quotInt64X8#") int64X8PrimTy+primOpInfo (VecQuotOp WordVec 16 W8) = mkDyadic (fsLit "quotWord8X16#") word8X16PrimTy+primOpInfo (VecQuotOp WordVec 8 W16) = mkDyadic (fsLit "quotWord16X8#") word16X8PrimTy+primOpInfo (VecQuotOp WordVec 4 W32) = mkDyadic (fsLit "quotWord32X4#") word32X4PrimTy+primOpInfo (VecQuotOp WordVec 2 W64) = mkDyadic (fsLit "quotWord64X2#") word64X2PrimTy+primOpInfo (VecQuotOp WordVec 32 W8) = mkDyadic (fsLit "quotWord8X32#") word8X32PrimTy+primOpInfo (VecQuotOp WordVec 16 W16) = mkDyadic (fsLit "quotWord16X16#") word16X16PrimTy+primOpInfo (VecQuotOp WordVec 8 W32) = mkDyadic (fsLit "quotWord32X8#") word32X8PrimTy+primOpInfo (VecQuotOp WordVec 4 W64) = mkDyadic (fsLit "quotWord64X4#") word64X4PrimTy+primOpInfo (VecQuotOp WordVec 64 W8) = mkDyadic (fsLit "quotWord8X64#") word8X64PrimTy+primOpInfo (VecQuotOp WordVec 32 W16) = mkDyadic (fsLit "quotWord16X32#") word16X32PrimTy+primOpInfo (VecQuotOp WordVec 16 W32) = mkDyadic (fsLit "quotWord32X16#") word32X16PrimTy+primOpInfo (VecQuotOp WordVec 8 W64) = mkDyadic (fsLit "quotWord64X8#") word64X8PrimTy+primOpInfo (VecRemOp IntVec 16 W8) = mkDyadic (fsLit "remInt8X16#") int8X16PrimTy+primOpInfo (VecRemOp IntVec 8 W16) = mkDyadic (fsLit "remInt16X8#") int16X8PrimTy+primOpInfo (VecRemOp IntVec 4 W32) = mkDyadic (fsLit "remInt32X4#") int32X4PrimTy+primOpInfo (VecRemOp IntVec 2 W64) = mkDyadic (fsLit "remInt64X2#") int64X2PrimTy+primOpInfo (VecRemOp IntVec 32 W8) = mkDyadic (fsLit "remInt8X32#") int8X32PrimTy+primOpInfo (VecRemOp IntVec 16 W16) = mkDyadic (fsLit "remInt16X16#") int16X16PrimTy+primOpInfo (VecRemOp IntVec 8 W32) = mkDyadic (fsLit "remInt32X8#") int32X8PrimTy+primOpInfo (VecRemOp IntVec 4 W64) = mkDyadic (fsLit "remInt64X4#") int64X4PrimTy+primOpInfo (VecRemOp IntVec 64 W8) = mkDyadic (fsLit "remInt8X64#") int8X64PrimTy+primOpInfo (VecRemOp IntVec 32 W16) = mkDyadic (fsLit "remInt16X32#") int16X32PrimTy+primOpInfo (VecRemOp IntVec 16 W32) = mkDyadic (fsLit "remInt32X16#") int32X16PrimTy+primOpInfo (VecRemOp IntVec 8 W64) = mkDyadic (fsLit "remInt64X8#") int64X8PrimTy+primOpInfo (VecRemOp WordVec 16 W8) = mkDyadic (fsLit "remWord8X16#") word8X16PrimTy+primOpInfo (VecRemOp WordVec 8 W16) = mkDyadic (fsLit "remWord16X8#") word16X8PrimTy+primOpInfo (VecRemOp WordVec 4 W32) = mkDyadic (fsLit "remWord32X4#") word32X4PrimTy+primOpInfo (VecRemOp WordVec 2 W64) = mkDyadic (fsLit "remWord64X2#") word64X2PrimTy+primOpInfo (VecRemOp WordVec 32 W8) = mkDyadic (fsLit "remWord8X32#") word8X32PrimTy+primOpInfo (VecRemOp WordVec 16 W16) = mkDyadic (fsLit "remWord16X16#") word16X16PrimTy+primOpInfo (VecRemOp WordVec 8 W32) = mkDyadic (fsLit "remWord32X8#") word32X8PrimTy+primOpInfo (VecRemOp WordVec 4 W64) = mkDyadic (fsLit "remWord64X4#") word64X4PrimTy+primOpInfo (VecRemOp WordVec 64 W8) = mkDyadic (fsLit "remWord8X64#") word8X64PrimTy+primOpInfo (VecRemOp WordVec 32 W16) = mkDyadic (fsLit "remWord16X32#") word16X32PrimTy+primOpInfo (VecRemOp WordVec 16 W32) = mkDyadic (fsLit "remWord32X16#") word32X16PrimTy+primOpInfo (VecRemOp WordVec 8 W64) = mkDyadic (fsLit "remWord64X8#") word64X8PrimTy+primOpInfo (VecNegOp IntVec 16 W8) = mkMonadic (fsLit "negateInt8X16#") int8X16PrimTy+primOpInfo (VecNegOp IntVec 8 W16) = mkMonadic (fsLit "negateInt16X8#") int16X8PrimTy+primOpInfo (VecNegOp IntVec 4 W32) = mkMonadic (fsLit "negateInt32X4#") int32X4PrimTy+primOpInfo (VecNegOp IntVec 2 W64) = mkMonadic (fsLit "negateInt64X2#") int64X2PrimTy+primOpInfo (VecNegOp IntVec 32 W8) = mkMonadic (fsLit "negateInt8X32#") int8X32PrimTy+primOpInfo (VecNegOp IntVec 16 W16) = mkMonadic (fsLit "negateInt16X16#") int16X16PrimTy+primOpInfo (VecNegOp IntVec 8 W32) = mkMonadic (fsLit "negateInt32X8#") int32X8PrimTy+primOpInfo (VecNegOp IntVec 4 W64) = mkMonadic (fsLit "negateInt64X4#") int64X4PrimTy+primOpInfo (VecNegOp IntVec 64 W8) = mkMonadic (fsLit "negateInt8X64#") int8X64PrimTy+primOpInfo (VecNegOp IntVec 32 W16) = mkMonadic (fsLit "negateInt16X32#") int16X32PrimTy+primOpInfo (VecNegOp IntVec 16 W32) = mkMonadic (fsLit "negateInt32X16#") int32X16PrimTy+primOpInfo (VecNegOp IntVec 8 W64) = mkMonadic (fsLit "negateInt64X8#") int64X8PrimTy+primOpInfo (VecNegOp FloatVec 4 W32) = mkMonadic (fsLit "negateFloatX4#") floatX4PrimTy+primOpInfo (VecNegOp FloatVec 2 W64) = mkMonadic (fsLit "negateDoubleX2#") doubleX2PrimTy+primOpInfo (VecNegOp FloatVec 8 W32) = mkMonadic (fsLit "negateFloatX8#") floatX8PrimTy+primOpInfo (VecNegOp FloatVec 4 W64) = mkMonadic (fsLit "negateDoubleX4#") doubleX4PrimTy+primOpInfo (VecNegOp FloatVec 16 W32) = mkMonadic (fsLit "negateFloatX16#") floatX16PrimTy+primOpInfo (VecNegOp FloatVec 8 W64) = mkMonadic (fsLit "negateDoubleX8#") doubleX8PrimTy+primOpInfo (VecIndexByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecIndexByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64Array#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32Array#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16Array#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecIndexByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8Array#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16Array#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecIndexByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8Array#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecReadByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))+primOpInfo (VecReadByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))+primOpInfo (VecReadByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))+primOpInfo (VecReadByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))+primOpInfo (VecWriteByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8Array#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecIndexOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecIndexOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64X2OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64X4OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8X64OffAddr#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16X32OffAddr#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32X16OffAddr#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecIndexOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64X8OffAddr#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatX4OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleX2OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatX8OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleX4OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatX16OffAddr#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecIndexOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleX8OffAddr#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecReadOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))+primOpInfo (VecReadOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))+primOpInfo (VecReadOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleX2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatX16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))+primOpInfo (VecReadOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))+primOpInfo (VecWriteOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64X2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64X4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8X64OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16X32OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32X16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64X8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleX2OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleX4OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatX16OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleX8OffAddr#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X16#")  [] [byteArrayPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X8#")  [] [byteArrayPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X4#")  [] [byteArrayPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X2#")  [] [byteArrayPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X32#")  [] [byteArrayPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X16#")  [] [byteArrayPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X8#")  [] [byteArrayPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X4#")  [] [byteArrayPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8ArrayAsInt8X64#")  [] [byteArrayPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16ArrayAsInt16X32#")  [] [byteArrayPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32ArrayAsInt32X16#")  [] [byteArrayPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64ArrayAsInt64X8#")  [] [byteArrayPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X16#")  [] [byteArrayPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X8#")  [] [byteArrayPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X4#")  [] [byteArrayPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X2#")  [] [byteArrayPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X32#")  [] [byteArrayPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X16#")  [] [byteArrayPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X8#")  [] [byteArrayPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X4#")  [] [byteArrayPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8ArrayAsWord8X64#")  [] [byteArrayPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16ArrayAsWord16X32#")  [] [byteArrayPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32ArrayAsWord32X16#")  [] [byteArrayPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64ArrayAsWord64X8#")  [] [byteArrayPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX4#")  [] [byteArrayPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX2#")  [] [byteArrayPrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX8#")  [] [byteArrayPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX4#")  [] [byteArrayPrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatArrayAsFloatX16#")  [] [byteArrayPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecIndexScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleArrayAsDoubleX8#")  [] [byteArrayPrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8ArrayAsInt8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16ArrayAsInt16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32ArrayAsInt32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64ArrayAsInt64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8ArrayAsWord8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16ArrayAsWord16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32ArrayAsWord32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64ArrayAsWord64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatArrayAsFloatX16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))+primOpInfo (VecReadScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleArrayAsDoubleX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8ArrayAsInt8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16ArrayAsInt16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32ArrayAsInt32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64ArrayAsInt64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8ArrayAsWord8X64#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16ArrayAsWord16X32#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32ArrayAsWord32X16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64ArrayAsWord64X8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX4#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatArrayAsFloatX16#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarByteArrayOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleArrayAsDoubleX8#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X16#")  [] [addrPrimTy, intPrimTy] (int8X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X8#")  [] [addrPrimTy, intPrimTy] (int16X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X4#")  [] [addrPrimTy, intPrimTy] (int32X4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X2#")  [] [addrPrimTy, intPrimTy] (int64X2PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X32#")  [] [addrPrimTy, intPrimTy] (int8X32PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X16#")  [] [addrPrimTy, intPrimTy] (int16X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X8#")  [] [addrPrimTy, intPrimTy] (int32X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X4#")  [] [addrPrimTy, intPrimTy] (int64X4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "indexInt8OffAddrAsInt8X64#")  [] [addrPrimTy, intPrimTy] (int8X64PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "indexInt16OffAddrAsInt16X32#")  [] [addrPrimTy, intPrimTy] (int16X32PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "indexInt32OffAddrAsInt32X16#")  [] [addrPrimTy, intPrimTy] (int32X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "indexInt64OffAddrAsInt64X8#")  [] [addrPrimTy, intPrimTy] (int64X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X16#")  [] [addrPrimTy, intPrimTy] (word8X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X8#")  [] [addrPrimTy, intPrimTy] (word16X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X4#")  [] [addrPrimTy, intPrimTy] (word32X4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X2#")  [] [addrPrimTy, intPrimTy] (word64X2PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X32#")  [] [addrPrimTy, intPrimTy] (word8X32PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X16#")  [] [addrPrimTy, intPrimTy] (word16X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X8#")  [] [addrPrimTy, intPrimTy] (word32X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X4#")  [] [addrPrimTy, intPrimTy] (word64X4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord8X64#")  [] [addrPrimTy, intPrimTy] (word8X64PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "indexWord16OffAddrAsWord16X32#")  [] [addrPrimTy, intPrimTy] (word16X32PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "indexWord32OffAddrAsWord32X16#")  [] [addrPrimTy, intPrimTy] (word32X16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "indexWord64OffAddrAsWord64X8#")  [] [addrPrimTy, intPrimTy] (word64X8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX4#")  [] [addrPrimTy, intPrimTy] (floatX4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX2#")  [] [addrPrimTy, intPrimTy] (doubleX2PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX8#")  [] [addrPrimTy, intPrimTy] (floatX8PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX4#")  [] [addrPrimTy, intPrimTy] (doubleX4PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "indexFloatOffAddrAsFloatX16#")  [] [addrPrimTy, intPrimTy] (floatX16PrimTy)+primOpInfo (VecIndexScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "indexDoubleOffAddrAsDoubleX8#")  [] [addrPrimTy, intPrimTy] (doubleX8PrimTy)+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X2PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X32PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "readInt8OffAddrAsInt8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int8X64PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "readInt16OffAddrAsInt16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16X32PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "readInt32OffAddrAsInt32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "readInt64OffAddrAsInt64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X2PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X32PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "readWord8OffAddrAsWord8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word8X64PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "readWord16OffAddrAsWord16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16X32PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "readWord32OffAddrAsWord32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32X16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "readWord64OffAddrAsWord64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64X8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX2PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX8PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX4PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "readFloatOffAddrAsFloatX16#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatX16PrimTy]))+primOpInfo (VecReadScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "readDoubleOffAddrAsDoubleX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doubleX8PrimTy]))+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 2 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 4 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 64 W8) = mkGenPrimOp (fsLit "writeInt8OffAddrAsInt8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, int8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 32 W16) = mkGenPrimOp (fsLit "writeInt16OffAddrAsInt16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, int16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 16 W32) = mkGenPrimOp (fsLit "writeInt32OffAddrAsInt32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, int32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp IntVec 8 W64) = mkGenPrimOp (fsLit "writeInt64OffAddrAsInt64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, int64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 2 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X2#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 4 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X4#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 64 W8) = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord8X64#")  [deltaTyVar] [addrPrimTy, intPrimTy, word8X64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 32 W16) = mkGenPrimOp (fsLit "writeWord16OffAddrAsWord16X32#")  [deltaTyVar] [addrPrimTy, intPrimTy, word16X32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 16 W32) = mkGenPrimOp (fsLit "writeWord32OffAddrAsWord32X16#")  [deltaTyVar] [addrPrimTy, intPrimTy, word32X16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp WordVec 8 W64) = mkGenPrimOp (fsLit "writeWord64OffAddrAsWord64X8#")  [deltaTyVar] [addrPrimTy, intPrimTy, word64X8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 2 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX2#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX2PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 4 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX4#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX4PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 16 W32) = mkGenPrimOp (fsLit "writeFloatOffAddrAsFloatX16#")  [deltaTyVar] [addrPrimTy, intPrimTy, floatX16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo (VecWriteScalarOffAddrOp FloatVec 8 W64) = mkGenPrimOp (fsLit "writeDoubleOffAddrAsDoubleX8#")  [deltaTyVar] [addrPrimTy, intPrimTy, doubleX8PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchByteArrayOp3 = mkGenPrimOp (fsLit "prefetchByteArray3#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchMutableByteArrayOp3 = mkGenPrimOp (fsLit "prefetchMutableByteArray3#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchAddrOp3 = mkGenPrimOp (fsLit "prefetchAddr3#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchValueOp3 = mkGenPrimOp (fsLit "prefetchValue3#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchByteArrayOp2 = mkGenPrimOp (fsLit "prefetchByteArray2#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchMutableByteArrayOp2 = mkGenPrimOp (fsLit "prefetchMutableByteArray2#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchAddrOp2 = mkGenPrimOp (fsLit "prefetchAddr2#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchValueOp2 = mkGenPrimOp (fsLit "prefetchValue2#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchByteArrayOp1 = mkGenPrimOp (fsLit "prefetchByteArray1#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchMutableByteArrayOp1 = mkGenPrimOp (fsLit "prefetchMutableByteArray1#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchAddrOp1 = mkGenPrimOp (fsLit "prefetchAddr1#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchValueOp1 = mkGenPrimOp (fsLit "prefetchValue1#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchByteArrayOp0 = mkGenPrimOp (fsLit "prefetchByteArray0#")  [deltaTyVar] [byteArrayPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchMutableByteArrayOp0 = mkGenPrimOp (fsLit "prefetchMutableByteArray0#")  [deltaTyVar] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchAddrOp0 = mkGenPrimOp (fsLit "prefetchAddr0#")  [deltaTyVar] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo PrefetchValueOp0 = mkGenPrimOp (fsLit "prefetchValue0#")  [alphaTyVar, deltaTyVar] [alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
+ ghc-lib/stage1/compiler/build/primop-strictness.hs-incl view
@@ -0,0 +1,22 @@+primOpStrictness CatchOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd+                                                 , lazyApply2Dmd+                                                 , topDmd] topRes +primOpStrictness RaiseOp =  \ _arity -> mkClosedStrictSig [topDmd] botRes +primOpStrictness RaiseIOOp =  \ _arity -> mkClosedStrictSig [topDmd, topDmd] botRes +primOpStrictness MaskAsyncExceptionsOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes +primOpStrictness MaskUninterruptibleOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes +primOpStrictness UnmaskAsyncExceptionsOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes +primOpStrictness AtomicallyOp =  \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topRes +primOpStrictness RetryOp =  \ _arity -> mkClosedStrictSig [topDmd] botRes +primOpStrictness CatchRetryOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd+                                                 , lazyApply1Dmd+                                                 , topDmd ] topRes +primOpStrictness CatchSTMOp =  \ _arity -> mkClosedStrictSig [ lazyApply1Dmd+                                                 , lazyApply2Dmd+                                                 , topDmd ] topRes +primOpStrictness DataToTagOp =  \ _arity -> mkClosedStrictSig [evalDmd] topRes +primOpStrictness PrefetchValueOp3 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes +primOpStrictness PrefetchValueOp2 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes +primOpStrictness PrefetchValueOp1 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes +primOpStrictness PrefetchValueOp0 =  \ _arity -> mkClosedStrictSig [botDmd, topDmd] topRes +primOpStrictness _ =  \ arity -> mkClosedStrictSig (replicate arity topDmd) topRes
+ ghc-lib/stage1/compiler/build/primop-tag.hs-incl view
@@ -0,0 +1,1201 @@+maxPrimOpTag :: Int+maxPrimOpTag = 1198+primOpTag :: PrimOp -> Int+primOpTag CharGtOp = 1+primOpTag CharGeOp = 2+primOpTag CharEqOp = 3+primOpTag CharNeOp = 4+primOpTag CharLtOp = 5+primOpTag CharLeOp = 6+primOpTag OrdOp = 7+primOpTag IntAddOp = 8+primOpTag IntSubOp = 9+primOpTag IntMulOp = 10+primOpTag IntMulMayOfloOp = 11+primOpTag IntQuotOp = 12+primOpTag IntRemOp = 13+primOpTag IntQuotRemOp = 14+primOpTag AndIOp = 15+primOpTag OrIOp = 16+primOpTag XorIOp = 17+primOpTag NotIOp = 18+primOpTag IntNegOp = 19+primOpTag IntAddCOp = 20+primOpTag IntSubCOp = 21+primOpTag IntGtOp = 22+primOpTag IntGeOp = 23+primOpTag IntEqOp = 24+primOpTag IntNeOp = 25+primOpTag IntLtOp = 26+primOpTag IntLeOp = 27+primOpTag ChrOp = 28+primOpTag Int2WordOp = 29+primOpTag Int2FloatOp = 30+primOpTag Int2DoubleOp = 31+primOpTag Word2FloatOp = 32+primOpTag Word2DoubleOp = 33+primOpTag ISllOp = 34+primOpTag ISraOp = 35+primOpTag ISrlOp = 36+primOpTag Int8Extend = 37+primOpTag Int8Narrow = 38+primOpTag Int8NegOp = 39+primOpTag Int8AddOp = 40+primOpTag Int8SubOp = 41+primOpTag Int8MulOp = 42+primOpTag Int8QuotOp = 43+primOpTag Int8RemOp = 44+primOpTag Int8QuotRemOp = 45+primOpTag Int8EqOp = 46+primOpTag Int8GeOp = 47+primOpTag Int8GtOp = 48+primOpTag Int8LeOp = 49+primOpTag Int8LtOp = 50+primOpTag Int8NeOp = 51+primOpTag Word8Extend = 52+primOpTag Word8Narrow = 53+primOpTag Word8NotOp = 54+primOpTag Word8AddOp = 55+primOpTag Word8SubOp = 56+primOpTag Word8MulOp = 57+primOpTag Word8QuotOp = 58+primOpTag Word8RemOp = 59+primOpTag Word8QuotRemOp = 60+primOpTag Word8EqOp = 61+primOpTag Word8GeOp = 62+primOpTag Word8GtOp = 63+primOpTag Word8LeOp = 64+primOpTag Word8LtOp = 65+primOpTag Word8NeOp = 66+primOpTag Int16Extend = 67+primOpTag Int16Narrow = 68+primOpTag Int16NegOp = 69+primOpTag Int16AddOp = 70+primOpTag Int16SubOp = 71+primOpTag Int16MulOp = 72+primOpTag Int16QuotOp = 73+primOpTag Int16RemOp = 74+primOpTag Int16QuotRemOp = 75+primOpTag Int16EqOp = 76+primOpTag Int16GeOp = 77+primOpTag Int16GtOp = 78+primOpTag Int16LeOp = 79+primOpTag Int16LtOp = 80+primOpTag Int16NeOp = 81+primOpTag Word16Extend = 82+primOpTag Word16Narrow = 83+primOpTag Word16NotOp = 84+primOpTag Word16AddOp = 85+primOpTag Word16SubOp = 86+primOpTag Word16MulOp = 87+primOpTag Word16QuotOp = 88+primOpTag Word16RemOp = 89+primOpTag Word16QuotRemOp = 90+primOpTag Word16EqOp = 91+primOpTag Word16GeOp = 92+primOpTag Word16GtOp = 93+primOpTag Word16LeOp = 94+primOpTag Word16LtOp = 95+primOpTag Word16NeOp = 96+primOpTag WordAddOp = 97+primOpTag WordAddCOp = 98+primOpTag WordSubCOp = 99+primOpTag WordAdd2Op = 100+primOpTag WordSubOp = 101+primOpTag WordMulOp = 102+primOpTag WordMul2Op = 103+primOpTag WordQuotOp = 104+primOpTag WordRemOp = 105+primOpTag WordQuotRemOp = 106+primOpTag WordQuotRem2Op = 107+primOpTag AndOp = 108+primOpTag OrOp = 109+primOpTag XorOp = 110+primOpTag NotOp = 111+primOpTag SllOp = 112+primOpTag SrlOp = 113+primOpTag Word2IntOp = 114+primOpTag WordGtOp = 115+primOpTag WordGeOp = 116+primOpTag WordEqOp = 117+primOpTag WordNeOp = 118+primOpTag WordLtOp = 119+primOpTag WordLeOp = 120+primOpTag PopCnt8Op = 121+primOpTag PopCnt16Op = 122+primOpTag PopCnt32Op = 123+primOpTag PopCnt64Op = 124+primOpTag PopCntOp = 125+primOpTag Pdep8Op = 126+primOpTag Pdep16Op = 127+primOpTag Pdep32Op = 128+primOpTag Pdep64Op = 129+primOpTag PdepOp = 130+primOpTag Pext8Op = 131+primOpTag Pext16Op = 132+primOpTag Pext32Op = 133+primOpTag Pext64Op = 134+primOpTag PextOp = 135+primOpTag Clz8Op = 136+primOpTag Clz16Op = 137+primOpTag Clz32Op = 138+primOpTag Clz64Op = 139+primOpTag ClzOp = 140+primOpTag Ctz8Op = 141+primOpTag Ctz16Op = 142+primOpTag Ctz32Op = 143+primOpTag Ctz64Op = 144+primOpTag CtzOp = 145+primOpTag BSwap16Op = 146+primOpTag BSwap32Op = 147+primOpTag BSwap64Op = 148+primOpTag BSwapOp = 149+primOpTag BRev8Op = 150+primOpTag BRev16Op = 151+primOpTag BRev32Op = 152+primOpTag BRev64Op = 153+primOpTag BRevOp = 154+primOpTag Narrow8IntOp = 155+primOpTag Narrow16IntOp = 156+primOpTag Narrow32IntOp = 157+primOpTag Narrow8WordOp = 158+primOpTag Narrow16WordOp = 159+primOpTag Narrow32WordOp = 160+primOpTag DoubleGtOp = 161+primOpTag DoubleGeOp = 162+primOpTag DoubleEqOp = 163+primOpTag DoubleNeOp = 164+primOpTag DoubleLtOp = 165+primOpTag DoubleLeOp = 166+primOpTag DoubleAddOp = 167+primOpTag DoubleSubOp = 168+primOpTag DoubleMulOp = 169+primOpTag DoubleDivOp = 170+primOpTag DoubleNegOp = 171+primOpTag DoubleFabsOp = 172+primOpTag Double2IntOp = 173+primOpTag Double2FloatOp = 174+primOpTag DoubleExpOp = 175+primOpTag DoubleLogOp = 176+primOpTag DoubleSqrtOp = 177+primOpTag DoubleSinOp = 178+primOpTag DoubleCosOp = 179+primOpTag DoubleTanOp = 180+primOpTag DoubleAsinOp = 181+primOpTag DoubleAcosOp = 182+primOpTag DoubleAtanOp = 183+primOpTag DoubleSinhOp = 184+primOpTag DoubleCoshOp = 185+primOpTag DoubleTanhOp = 186+primOpTag DoubleAsinhOp = 187+primOpTag DoubleAcoshOp = 188+primOpTag DoubleAtanhOp = 189+primOpTag DoublePowerOp = 190+primOpTag DoubleDecode_2IntOp = 191+primOpTag DoubleDecode_Int64Op = 192+primOpTag FloatGtOp = 193+primOpTag FloatGeOp = 194+primOpTag FloatEqOp = 195+primOpTag FloatNeOp = 196+primOpTag FloatLtOp = 197+primOpTag FloatLeOp = 198+primOpTag FloatAddOp = 199+primOpTag FloatSubOp = 200+primOpTag FloatMulOp = 201+primOpTag FloatDivOp = 202+primOpTag FloatNegOp = 203+primOpTag FloatFabsOp = 204+primOpTag Float2IntOp = 205+primOpTag FloatExpOp = 206+primOpTag FloatLogOp = 207+primOpTag FloatSqrtOp = 208+primOpTag FloatSinOp = 209+primOpTag FloatCosOp = 210+primOpTag FloatTanOp = 211+primOpTag FloatAsinOp = 212+primOpTag FloatAcosOp = 213+primOpTag FloatAtanOp = 214+primOpTag FloatSinhOp = 215+primOpTag FloatCoshOp = 216+primOpTag FloatTanhOp = 217+primOpTag FloatAsinhOp = 218+primOpTag FloatAcoshOp = 219+primOpTag FloatAtanhOp = 220+primOpTag FloatPowerOp = 221+primOpTag Float2DoubleOp = 222+primOpTag FloatDecode_IntOp = 223+primOpTag NewArrayOp = 224+primOpTag SameMutableArrayOp = 225+primOpTag ReadArrayOp = 226+primOpTag WriteArrayOp = 227+primOpTag SizeofArrayOp = 228+primOpTag SizeofMutableArrayOp = 229+primOpTag IndexArrayOp = 230+primOpTag UnsafeFreezeArrayOp = 231+primOpTag UnsafeThawArrayOp = 232+primOpTag CopyArrayOp = 233+primOpTag CopyMutableArrayOp = 234+primOpTag CloneArrayOp = 235+primOpTag CloneMutableArrayOp = 236+primOpTag FreezeArrayOp = 237+primOpTag ThawArrayOp = 238+primOpTag CasArrayOp = 239+primOpTag NewSmallArrayOp = 240+primOpTag SameSmallMutableArrayOp = 241+primOpTag ReadSmallArrayOp = 242+primOpTag WriteSmallArrayOp = 243+primOpTag SizeofSmallArrayOp = 244+primOpTag SizeofSmallMutableArrayOp = 245+primOpTag IndexSmallArrayOp = 246+primOpTag UnsafeFreezeSmallArrayOp = 247+primOpTag UnsafeThawSmallArrayOp = 248+primOpTag CopySmallArrayOp = 249+primOpTag CopySmallMutableArrayOp = 250+primOpTag CloneSmallArrayOp = 251+primOpTag CloneSmallMutableArrayOp = 252+primOpTag FreezeSmallArrayOp = 253+primOpTag ThawSmallArrayOp = 254+primOpTag CasSmallArrayOp = 255+primOpTag NewByteArrayOp_Char = 256+primOpTag NewPinnedByteArrayOp_Char = 257+primOpTag NewAlignedPinnedByteArrayOp_Char = 258+primOpTag MutableByteArrayIsPinnedOp = 259+primOpTag ByteArrayIsPinnedOp = 260+primOpTag ByteArrayContents_Char = 261+primOpTag SameMutableByteArrayOp = 262+primOpTag ShrinkMutableByteArrayOp_Char = 263+primOpTag ResizeMutableByteArrayOp_Char = 264+primOpTag UnsafeFreezeByteArrayOp = 265+primOpTag SizeofByteArrayOp = 266+primOpTag SizeofMutableByteArrayOp = 267+primOpTag GetSizeofMutableByteArrayOp = 268+primOpTag IndexByteArrayOp_Char = 269+primOpTag IndexByteArrayOp_WideChar = 270+primOpTag IndexByteArrayOp_Int = 271+primOpTag IndexByteArrayOp_Word = 272+primOpTag IndexByteArrayOp_Addr = 273+primOpTag IndexByteArrayOp_Float = 274+primOpTag IndexByteArrayOp_Double = 275+primOpTag IndexByteArrayOp_StablePtr = 276+primOpTag IndexByteArrayOp_Int8 = 277+primOpTag IndexByteArrayOp_Int16 = 278+primOpTag IndexByteArrayOp_Int32 = 279+primOpTag IndexByteArrayOp_Int64 = 280+primOpTag IndexByteArrayOp_Word8 = 281+primOpTag IndexByteArrayOp_Word16 = 282+primOpTag IndexByteArrayOp_Word32 = 283+primOpTag IndexByteArrayOp_Word64 = 284+primOpTag IndexByteArrayOp_Word8AsChar = 285+primOpTag IndexByteArrayOp_Word8AsWideChar = 286+primOpTag IndexByteArrayOp_Word8AsAddr = 287+primOpTag IndexByteArrayOp_Word8AsFloat = 288+primOpTag IndexByteArrayOp_Word8AsDouble = 289+primOpTag IndexByteArrayOp_Word8AsStablePtr = 290+primOpTag IndexByteArrayOp_Word8AsInt16 = 291+primOpTag IndexByteArrayOp_Word8AsInt32 = 292+primOpTag IndexByteArrayOp_Word8AsInt64 = 293+primOpTag IndexByteArrayOp_Word8AsInt = 294+primOpTag IndexByteArrayOp_Word8AsWord16 = 295+primOpTag IndexByteArrayOp_Word8AsWord32 = 296+primOpTag IndexByteArrayOp_Word8AsWord64 = 297+primOpTag IndexByteArrayOp_Word8AsWord = 298+primOpTag ReadByteArrayOp_Char = 299+primOpTag ReadByteArrayOp_WideChar = 300+primOpTag ReadByteArrayOp_Int = 301+primOpTag ReadByteArrayOp_Word = 302+primOpTag ReadByteArrayOp_Addr = 303+primOpTag ReadByteArrayOp_Float = 304+primOpTag ReadByteArrayOp_Double = 305+primOpTag ReadByteArrayOp_StablePtr = 306+primOpTag ReadByteArrayOp_Int8 = 307+primOpTag ReadByteArrayOp_Int16 = 308+primOpTag ReadByteArrayOp_Int32 = 309+primOpTag ReadByteArrayOp_Int64 = 310+primOpTag ReadByteArrayOp_Word8 = 311+primOpTag ReadByteArrayOp_Word16 = 312+primOpTag ReadByteArrayOp_Word32 = 313+primOpTag ReadByteArrayOp_Word64 = 314+primOpTag ReadByteArrayOp_Word8AsChar = 315+primOpTag ReadByteArrayOp_Word8AsWideChar = 316+primOpTag ReadByteArrayOp_Word8AsAddr = 317+primOpTag ReadByteArrayOp_Word8AsFloat = 318+primOpTag ReadByteArrayOp_Word8AsDouble = 319+primOpTag ReadByteArrayOp_Word8AsStablePtr = 320+primOpTag ReadByteArrayOp_Word8AsInt16 = 321+primOpTag ReadByteArrayOp_Word8AsInt32 = 322+primOpTag ReadByteArrayOp_Word8AsInt64 = 323+primOpTag ReadByteArrayOp_Word8AsInt = 324+primOpTag ReadByteArrayOp_Word8AsWord16 = 325+primOpTag ReadByteArrayOp_Word8AsWord32 = 326+primOpTag ReadByteArrayOp_Word8AsWord64 = 327+primOpTag ReadByteArrayOp_Word8AsWord = 328+primOpTag WriteByteArrayOp_Char = 329+primOpTag WriteByteArrayOp_WideChar = 330+primOpTag WriteByteArrayOp_Int = 331+primOpTag WriteByteArrayOp_Word = 332+primOpTag WriteByteArrayOp_Addr = 333+primOpTag WriteByteArrayOp_Float = 334+primOpTag WriteByteArrayOp_Double = 335+primOpTag WriteByteArrayOp_StablePtr = 336+primOpTag WriteByteArrayOp_Int8 = 337+primOpTag WriteByteArrayOp_Int16 = 338+primOpTag WriteByteArrayOp_Int32 = 339+primOpTag WriteByteArrayOp_Int64 = 340+primOpTag WriteByteArrayOp_Word8 = 341+primOpTag WriteByteArrayOp_Word16 = 342+primOpTag WriteByteArrayOp_Word32 = 343+primOpTag WriteByteArrayOp_Word64 = 344+primOpTag WriteByteArrayOp_Word8AsChar = 345+primOpTag WriteByteArrayOp_Word8AsWideChar = 346+primOpTag WriteByteArrayOp_Word8AsAddr = 347+primOpTag WriteByteArrayOp_Word8AsFloat = 348+primOpTag WriteByteArrayOp_Word8AsDouble = 349+primOpTag WriteByteArrayOp_Word8AsStablePtr = 350+primOpTag WriteByteArrayOp_Word8AsInt16 = 351+primOpTag WriteByteArrayOp_Word8AsInt32 = 352+primOpTag WriteByteArrayOp_Word8AsInt64 = 353+primOpTag WriteByteArrayOp_Word8AsInt = 354+primOpTag WriteByteArrayOp_Word8AsWord16 = 355+primOpTag WriteByteArrayOp_Word8AsWord32 = 356+primOpTag WriteByteArrayOp_Word8AsWord64 = 357+primOpTag WriteByteArrayOp_Word8AsWord = 358+primOpTag CompareByteArraysOp = 359+primOpTag CopyByteArrayOp = 360+primOpTag CopyMutableByteArrayOp = 361+primOpTag CopyByteArrayToAddrOp = 362+primOpTag CopyMutableByteArrayToAddrOp = 363+primOpTag CopyAddrToByteArrayOp = 364+primOpTag SetByteArrayOp = 365+primOpTag AtomicReadByteArrayOp_Int = 366+primOpTag AtomicWriteByteArrayOp_Int = 367+primOpTag CasByteArrayOp_Int = 368+primOpTag FetchAddByteArrayOp_Int = 369+primOpTag FetchSubByteArrayOp_Int = 370+primOpTag FetchAndByteArrayOp_Int = 371+primOpTag FetchNandByteArrayOp_Int = 372+primOpTag FetchOrByteArrayOp_Int = 373+primOpTag FetchXorByteArrayOp_Int = 374+primOpTag NewArrayArrayOp = 375+primOpTag SameMutableArrayArrayOp = 376+primOpTag UnsafeFreezeArrayArrayOp = 377+primOpTag SizeofArrayArrayOp = 378+primOpTag SizeofMutableArrayArrayOp = 379+primOpTag IndexArrayArrayOp_ByteArray = 380+primOpTag IndexArrayArrayOp_ArrayArray = 381+primOpTag ReadArrayArrayOp_ByteArray = 382+primOpTag ReadArrayArrayOp_MutableByteArray = 383+primOpTag ReadArrayArrayOp_ArrayArray = 384+primOpTag ReadArrayArrayOp_MutableArrayArray = 385+primOpTag WriteArrayArrayOp_ByteArray = 386+primOpTag WriteArrayArrayOp_MutableByteArray = 387+primOpTag WriteArrayArrayOp_ArrayArray = 388+primOpTag WriteArrayArrayOp_MutableArrayArray = 389+primOpTag CopyArrayArrayOp = 390+primOpTag CopyMutableArrayArrayOp = 391+primOpTag AddrAddOp = 392+primOpTag AddrSubOp = 393+primOpTag AddrRemOp = 394+primOpTag Addr2IntOp = 395+primOpTag Int2AddrOp = 396+primOpTag AddrGtOp = 397+primOpTag AddrGeOp = 398+primOpTag AddrEqOp = 399+primOpTag AddrNeOp = 400+primOpTag AddrLtOp = 401+primOpTag AddrLeOp = 402+primOpTag IndexOffAddrOp_Char = 403+primOpTag IndexOffAddrOp_WideChar = 404+primOpTag IndexOffAddrOp_Int = 405+primOpTag IndexOffAddrOp_Word = 406+primOpTag IndexOffAddrOp_Addr = 407+primOpTag IndexOffAddrOp_Float = 408+primOpTag IndexOffAddrOp_Double = 409+primOpTag IndexOffAddrOp_StablePtr = 410+primOpTag IndexOffAddrOp_Int8 = 411+primOpTag IndexOffAddrOp_Int16 = 412+primOpTag IndexOffAddrOp_Int32 = 413+primOpTag IndexOffAddrOp_Int64 = 414+primOpTag IndexOffAddrOp_Word8 = 415+primOpTag IndexOffAddrOp_Word16 = 416+primOpTag IndexOffAddrOp_Word32 = 417+primOpTag IndexOffAddrOp_Word64 = 418+primOpTag ReadOffAddrOp_Char = 419+primOpTag ReadOffAddrOp_WideChar = 420+primOpTag ReadOffAddrOp_Int = 421+primOpTag ReadOffAddrOp_Word = 422+primOpTag ReadOffAddrOp_Addr = 423+primOpTag ReadOffAddrOp_Float = 424+primOpTag ReadOffAddrOp_Double = 425+primOpTag ReadOffAddrOp_StablePtr = 426+primOpTag ReadOffAddrOp_Int8 = 427+primOpTag ReadOffAddrOp_Int16 = 428+primOpTag ReadOffAddrOp_Int32 = 429+primOpTag ReadOffAddrOp_Int64 = 430+primOpTag ReadOffAddrOp_Word8 = 431+primOpTag ReadOffAddrOp_Word16 = 432+primOpTag ReadOffAddrOp_Word32 = 433+primOpTag ReadOffAddrOp_Word64 = 434+primOpTag WriteOffAddrOp_Char = 435+primOpTag WriteOffAddrOp_WideChar = 436+primOpTag WriteOffAddrOp_Int = 437+primOpTag WriteOffAddrOp_Word = 438+primOpTag WriteOffAddrOp_Addr = 439+primOpTag WriteOffAddrOp_Float = 440+primOpTag WriteOffAddrOp_Double = 441+primOpTag WriteOffAddrOp_StablePtr = 442+primOpTag WriteOffAddrOp_Int8 = 443+primOpTag WriteOffAddrOp_Int16 = 444+primOpTag WriteOffAddrOp_Int32 = 445+primOpTag WriteOffAddrOp_Int64 = 446+primOpTag WriteOffAddrOp_Word8 = 447+primOpTag WriteOffAddrOp_Word16 = 448+primOpTag WriteOffAddrOp_Word32 = 449+primOpTag WriteOffAddrOp_Word64 = 450+primOpTag NewMutVarOp = 451+primOpTag ReadMutVarOp = 452+primOpTag WriteMutVarOp = 453+primOpTag SameMutVarOp = 454+primOpTag AtomicModifyMutVar2Op = 455+primOpTag AtomicModifyMutVar_Op = 456+primOpTag CasMutVarOp = 457+primOpTag CatchOp = 458+primOpTag RaiseOp = 459+primOpTag RaiseIOOp = 460+primOpTag MaskAsyncExceptionsOp = 461+primOpTag MaskUninterruptibleOp = 462+primOpTag UnmaskAsyncExceptionsOp = 463+primOpTag MaskStatus = 464+primOpTag AtomicallyOp = 465+primOpTag RetryOp = 466+primOpTag CatchRetryOp = 467+primOpTag CatchSTMOp = 468+primOpTag NewTVarOp = 469+primOpTag ReadTVarOp = 470+primOpTag ReadTVarIOOp = 471+primOpTag WriteTVarOp = 472+primOpTag SameTVarOp = 473+primOpTag NewMVarOp = 474+primOpTag TakeMVarOp = 475+primOpTag TryTakeMVarOp = 476+primOpTag PutMVarOp = 477+primOpTag TryPutMVarOp = 478+primOpTag ReadMVarOp = 479+primOpTag TryReadMVarOp = 480+primOpTag SameMVarOp = 481+primOpTag IsEmptyMVarOp = 482+primOpTag DelayOp = 483+primOpTag WaitReadOp = 484+primOpTag WaitWriteOp = 485+primOpTag ForkOp = 486+primOpTag ForkOnOp = 487+primOpTag KillThreadOp = 488+primOpTag YieldOp = 489+primOpTag MyThreadIdOp = 490+primOpTag LabelThreadOp = 491+primOpTag IsCurrentThreadBoundOp = 492+primOpTag NoDuplicateOp = 493+primOpTag ThreadStatusOp = 494+primOpTag MkWeakOp = 495+primOpTag MkWeakNoFinalizerOp = 496+primOpTag AddCFinalizerToWeakOp = 497+primOpTag DeRefWeakOp = 498+primOpTag FinalizeWeakOp = 499+primOpTag TouchOp = 500+primOpTag MakeStablePtrOp = 501+primOpTag DeRefStablePtrOp = 502+primOpTag EqStablePtrOp = 503+primOpTag MakeStableNameOp = 504+primOpTag EqStableNameOp = 505+primOpTag StableNameToIntOp = 506+primOpTag CompactNewOp = 507+primOpTag CompactResizeOp = 508+primOpTag CompactContainsOp = 509+primOpTag CompactContainsAnyOp = 510+primOpTag CompactGetFirstBlockOp = 511+primOpTag CompactGetNextBlockOp = 512+primOpTag CompactAllocateBlockOp = 513+primOpTag CompactFixupPointersOp = 514+primOpTag CompactAdd = 515+primOpTag CompactAddWithSharing = 516+primOpTag CompactSize = 517+primOpTag ReallyUnsafePtrEqualityOp = 518+primOpTag ParOp = 519+primOpTag SparkOp = 520+primOpTag SeqOp = 521+primOpTag GetSparkOp = 522+primOpTag NumSparks = 523+primOpTag DataToTagOp = 524+primOpTag TagToEnumOp = 525+primOpTag AddrToAnyOp = 526+primOpTag AnyToAddrOp = 527+primOpTag MkApUpd0_Op = 528+primOpTag NewBCOOp = 529+primOpTag UnpackClosureOp = 530+primOpTag ClosureSizeOp = 531+primOpTag GetApStackValOp = 532+primOpTag GetCCSOfOp = 533+primOpTag GetCurrentCCSOp = 534+primOpTag ClearCCSOp = 535+primOpTag TraceEventOp = 536+primOpTag TraceEventBinaryOp = 537+primOpTag TraceMarkerOp = 538+primOpTag GetThreadAllocationCounter = 539+primOpTag SetThreadAllocationCounter = 540+primOpTag (VecBroadcastOp IntVec 16 W8) = 541+primOpTag (VecBroadcastOp IntVec 8 W16) = 542+primOpTag (VecBroadcastOp IntVec 4 W32) = 543+primOpTag (VecBroadcastOp IntVec 2 W64) = 544+primOpTag (VecBroadcastOp IntVec 32 W8) = 545+primOpTag (VecBroadcastOp IntVec 16 W16) = 546+primOpTag (VecBroadcastOp IntVec 8 W32) = 547+primOpTag (VecBroadcastOp IntVec 4 W64) = 548+primOpTag (VecBroadcastOp IntVec 64 W8) = 549+primOpTag (VecBroadcastOp IntVec 32 W16) = 550+primOpTag (VecBroadcastOp IntVec 16 W32) = 551+primOpTag (VecBroadcastOp IntVec 8 W64) = 552+primOpTag (VecBroadcastOp WordVec 16 W8) = 553+primOpTag (VecBroadcastOp WordVec 8 W16) = 554+primOpTag (VecBroadcastOp WordVec 4 W32) = 555+primOpTag (VecBroadcastOp WordVec 2 W64) = 556+primOpTag (VecBroadcastOp WordVec 32 W8) = 557+primOpTag (VecBroadcastOp WordVec 16 W16) = 558+primOpTag (VecBroadcastOp WordVec 8 W32) = 559+primOpTag (VecBroadcastOp WordVec 4 W64) = 560+primOpTag (VecBroadcastOp WordVec 64 W8) = 561+primOpTag (VecBroadcastOp WordVec 32 W16) = 562+primOpTag (VecBroadcastOp WordVec 16 W32) = 563+primOpTag (VecBroadcastOp WordVec 8 W64) = 564+primOpTag (VecBroadcastOp FloatVec 4 W32) = 565+primOpTag (VecBroadcastOp FloatVec 2 W64) = 566+primOpTag (VecBroadcastOp FloatVec 8 W32) = 567+primOpTag (VecBroadcastOp FloatVec 4 W64) = 568+primOpTag (VecBroadcastOp FloatVec 16 W32) = 569+primOpTag (VecBroadcastOp FloatVec 8 W64) = 570+primOpTag (VecPackOp IntVec 16 W8) = 571+primOpTag (VecPackOp IntVec 8 W16) = 572+primOpTag (VecPackOp IntVec 4 W32) = 573+primOpTag (VecPackOp IntVec 2 W64) = 574+primOpTag (VecPackOp IntVec 32 W8) = 575+primOpTag (VecPackOp IntVec 16 W16) = 576+primOpTag (VecPackOp IntVec 8 W32) = 577+primOpTag (VecPackOp IntVec 4 W64) = 578+primOpTag (VecPackOp IntVec 64 W8) = 579+primOpTag (VecPackOp IntVec 32 W16) = 580+primOpTag (VecPackOp IntVec 16 W32) = 581+primOpTag (VecPackOp IntVec 8 W64) = 582+primOpTag (VecPackOp WordVec 16 W8) = 583+primOpTag (VecPackOp WordVec 8 W16) = 584+primOpTag (VecPackOp WordVec 4 W32) = 585+primOpTag (VecPackOp WordVec 2 W64) = 586+primOpTag (VecPackOp WordVec 32 W8) = 587+primOpTag (VecPackOp WordVec 16 W16) = 588+primOpTag (VecPackOp WordVec 8 W32) = 589+primOpTag (VecPackOp WordVec 4 W64) = 590+primOpTag (VecPackOp WordVec 64 W8) = 591+primOpTag (VecPackOp WordVec 32 W16) = 592+primOpTag (VecPackOp WordVec 16 W32) = 593+primOpTag (VecPackOp WordVec 8 W64) = 594+primOpTag (VecPackOp FloatVec 4 W32) = 595+primOpTag (VecPackOp FloatVec 2 W64) = 596+primOpTag (VecPackOp FloatVec 8 W32) = 597+primOpTag (VecPackOp FloatVec 4 W64) = 598+primOpTag (VecPackOp FloatVec 16 W32) = 599+primOpTag (VecPackOp FloatVec 8 W64) = 600+primOpTag (VecUnpackOp IntVec 16 W8) = 601+primOpTag (VecUnpackOp IntVec 8 W16) = 602+primOpTag (VecUnpackOp IntVec 4 W32) = 603+primOpTag (VecUnpackOp IntVec 2 W64) = 604+primOpTag (VecUnpackOp IntVec 32 W8) = 605+primOpTag (VecUnpackOp IntVec 16 W16) = 606+primOpTag (VecUnpackOp IntVec 8 W32) = 607+primOpTag (VecUnpackOp IntVec 4 W64) = 608+primOpTag (VecUnpackOp IntVec 64 W8) = 609+primOpTag (VecUnpackOp IntVec 32 W16) = 610+primOpTag (VecUnpackOp IntVec 16 W32) = 611+primOpTag (VecUnpackOp IntVec 8 W64) = 612+primOpTag (VecUnpackOp WordVec 16 W8) = 613+primOpTag (VecUnpackOp WordVec 8 W16) = 614+primOpTag (VecUnpackOp WordVec 4 W32) = 615+primOpTag (VecUnpackOp WordVec 2 W64) = 616+primOpTag (VecUnpackOp WordVec 32 W8) = 617+primOpTag (VecUnpackOp WordVec 16 W16) = 618+primOpTag (VecUnpackOp WordVec 8 W32) = 619+primOpTag (VecUnpackOp WordVec 4 W64) = 620+primOpTag (VecUnpackOp WordVec 64 W8) = 621+primOpTag (VecUnpackOp WordVec 32 W16) = 622+primOpTag (VecUnpackOp WordVec 16 W32) = 623+primOpTag (VecUnpackOp WordVec 8 W64) = 624+primOpTag (VecUnpackOp FloatVec 4 W32) = 625+primOpTag (VecUnpackOp FloatVec 2 W64) = 626+primOpTag (VecUnpackOp FloatVec 8 W32) = 627+primOpTag (VecUnpackOp FloatVec 4 W64) = 628+primOpTag (VecUnpackOp FloatVec 16 W32) = 629+primOpTag (VecUnpackOp FloatVec 8 W64) = 630+primOpTag (VecInsertOp IntVec 16 W8) = 631+primOpTag (VecInsertOp IntVec 8 W16) = 632+primOpTag (VecInsertOp IntVec 4 W32) = 633+primOpTag (VecInsertOp IntVec 2 W64) = 634+primOpTag (VecInsertOp IntVec 32 W8) = 635+primOpTag (VecInsertOp IntVec 16 W16) = 636+primOpTag (VecInsertOp IntVec 8 W32) = 637+primOpTag (VecInsertOp IntVec 4 W64) = 638+primOpTag (VecInsertOp IntVec 64 W8) = 639+primOpTag (VecInsertOp IntVec 32 W16) = 640+primOpTag (VecInsertOp IntVec 16 W32) = 641+primOpTag (VecInsertOp IntVec 8 W64) = 642+primOpTag (VecInsertOp WordVec 16 W8) = 643+primOpTag (VecInsertOp WordVec 8 W16) = 644+primOpTag (VecInsertOp WordVec 4 W32) = 645+primOpTag (VecInsertOp WordVec 2 W64) = 646+primOpTag (VecInsertOp WordVec 32 W8) = 647+primOpTag (VecInsertOp WordVec 16 W16) = 648+primOpTag (VecInsertOp WordVec 8 W32) = 649+primOpTag (VecInsertOp WordVec 4 W64) = 650+primOpTag (VecInsertOp WordVec 64 W8) = 651+primOpTag (VecInsertOp WordVec 32 W16) = 652+primOpTag (VecInsertOp WordVec 16 W32) = 653+primOpTag (VecInsertOp WordVec 8 W64) = 654+primOpTag (VecInsertOp FloatVec 4 W32) = 655+primOpTag (VecInsertOp FloatVec 2 W64) = 656+primOpTag (VecInsertOp FloatVec 8 W32) = 657+primOpTag (VecInsertOp FloatVec 4 W64) = 658+primOpTag (VecInsertOp FloatVec 16 W32) = 659+primOpTag (VecInsertOp FloatVec 8 W64) = 660+primOpTag (VecAddOp IntVec 16 W8) = 661+primOpTag (VecAddOp IntVec 8 W16) = 662+primOpTag (VecAddOp IntVec 4 W32) = 663+primOpTag (VecAddOp IntVec 2 W64) = 664+primOpTag (VecAddOp IntVec 32 W8) = 665+primOpTag (VecAddOp IntVec 16 W16) = 666+primOpTag (VecAddOp IntVec 8 W32) = 667+primOpTag (VecAddOp IntVec 4 W64) = 668+primOpTag (VecAddOp IntVec 64 W8) = 669+primOpTag (VecAddOp IntVec 32 W16) = 670+primOpTag (VecAddOp IntVec 16 W32) = 671+primOpTag (VecAddOp IntVec 8 W64) = 672+primOpTag (VecAddOp WordVec 16 W8) = 673+primOpTag (VecAddOp WordVec 8 W16) = 674+primOpTag (VecAddOp WordVec 4 W32) = 675+primOpTag (VecAddOp WordVec 2 W64) = 676+primOpTag (VecAddOp WordVec 32 W8) = 677+primOpTag (VecAddOp WordVec 16 W16) = 678+primOpTag (VecAddOp WordVec 8 W32) = 679+primOpTag (VecAddOp WordVec 4 W64) = 680+primOpTag (VecAddOp WordVec 64 W8) = 681+primOpTag (VecAddOp WordVec 32 W16) = 682+primOpTag (VecAddOp WordVec 16 W32) = 683+primOpTag (VecAddOp WordVec 8 W64) = 684+primOpTag (VecAddOp FloatVec 4 W32) = 685+primOpTag (VecAddOp FloatVec 2 W64) = 686+primOpTag (VecAddOp FloatVec 8 W32) = 687+primOpTag (VecAddOp FloatVec 4 W64) = 688+primOpTag (VecAddOp FloatVec 16 W32) = 689+primOpTag (VecAddOp FloatVec 8 W64) = 690+primOpTag (VecSubOp IntVec 16 W8) = 691+primOpTag (VecSubOp IntVec 8 W16) = 692+primOpTag (VecSubOp IntVec 4 W32) = 693+primOpTag (VecSubOp IntVec 2 W64) = 694+primOpTag (VecSubOp IntVec 32 W8) = 695+primOpTag (VecSubOp IntVec 16 W16) = 696+primOpTag (VecSubOp IntVec 8 W32) = 697+primOpTag (VecSubOp IntVec 4 W64) = 698+primOpTag (VecSubOp IntVec 64 W8) = 699+primOpTag (VecSubOp IntVec 32 W16) = 700+primOpTag (VecSubOp IntVec 16 W32) = 701+primOpTag (VecSubOp IntVec 8 W64) = 702+primOpTag (VecSubOp WordVec 16 W8) = 703+primOpTag (VecSubOp WordVec 8 W16) = 704+primOpTag (VecSubOp WordVec 4 W32) = 705+primOpTag (VecSubOp WordVec 2 W64) = 706+primOpTag (VecSubOp WordVec 32 W8) = 707+primOpTag (VecSubOp WordVec 16 W16) = 708+primOpTag (VecSubOp WordVec 8 W32) = 709+primOpTag (VecSubOp WordVec 4 W64) = 710+primOpTag (VecSubOp WordVec 64 W8) = 711+primOpTag (VecSubOp WordVec 32 W16) = 712+primOpTag (VecSubOp WordVec 16 W32) = 713+primOpTag (VecSubOp WordVec 8 W64) = 714+primOpTag (VecSubOp FloatVec 4 W32) = 715+primOpTag (VecSubOp FloatVec 2 W64) = 716+primOpTag (VecSubOp FloatVec 8 W32) = 717+primOpTag (VecSubOp FloatVec 4 W64) = 718+primOpTag (VecSubOp FloatVec 16 W32) = 719+primOpTag (VecSubOp FloatVec 8 W64) = 720+primOpTag (VecMulOp IntVec 16 W8) = 721+primOpTag (VecMulOp IntVec 8 W16) = 722+primOpTag (VecMulOp IntVec 4 W32) = 723+primOpTag (VecMulOp IntVec 2 W64) = 724+primOpTag (VecMulOp IntVec 32 W8) = 725+primOpTag (VecMulOp IntVec 16 W16) = 726+primOpTag (VecMulOp IntVec 8 W32) = 727+primOpTag (VecMulOp IntVec 4 W64) = 728+primOpTag (VecMulOp IntVec 64 W8) = 729+primOpTag (VecMulOp IntVec 32 W16) = 730+primOpTag (VecMulOp IntVec 16 W32) = 731+primOpTag (VecMulOp IntVec 8 W64) = 732+primOpTag (VecMulOp WordVec 16 W8) = 733+primOpTag (VecMulOp WordVec 8 W16) = 734+primOpTag (VecMulOp WordVec 4 W32) = 735+primOpTag (VecMulOp WordVec 2 W64) = 736+primOpTag (VecMulOp WordVec 32 W8) = 737+primOpTag (VecMulOp WordVec 16 W16) = 738+primOpTag (VecMulOp WordVec 8 W32) = 739+primOpTag (VecMulOp WordVec 4 W64) = 740+primOpTag (VecMulOp WordVec 64 W8) = 741+primOpTag (VecMulOp WordVec 32 W16) = 742+primOpTag (VecMulOp WordVec 16 W32) = 743+primOpTag (VecMulOp WordVec 8 W64) = 744+primOpTag (VecMulOp FloatVec 4 W32) = 745+primOpTag (VecMulOp FloatVec 2 W64) = 746+primOpTag (VecMulOp FloatVec 8 W32) = 747+primOpTag (VecMulOp FloatVec 4 W64) = 748+primOpTag (VecMulOp FloatVec 16 W32) = 749+primOpTag (VecMulOp FloatVec 8 W64) = 750+primOpTag (VecDivOp FloatVec 4 W32) = 751+primOpTag (VecDivOp FloatVec 2 W64) = 752+primOpTag (VecDivOp FloatVec 8 W32) = 753+primOpTag (VecDivOp FloatVec 4 W64) = 754+primOpTag (VecDivOp FloatVec 16 W32) = 755+primOpTag (VecDivOp FloatVec 8 W64) = 756+primOpTag (VecQuotOp IntVec 16 W8) = 757+primOpTag (VecQuotOp IntVec 8 W16) = 758+primOpTag (VecQuotOp IntVec 4 W32) = 759+primOpTag (VecQuotOp IntVec 2 W64) = 760+primOpTag (VecQuotOp IntVec 32 W8) = 761+primOpTag (VecQuotOp IntVec 16 W16) = 762+primOpTag (VecQuotOp IntVec 8 W32) = 763+primOpTag (VecQuotOp IntVec 4 W64) = 764+primOpTag (VecQuotOp IntVec 64 W8) = 765+primOpTag (VecQuotOp IntVec 32 W16) = 766+primOpTag (VecQuotOp IntVec 16 W32) = 767+primOpTag (VecQuotOp IntVec 8 W64) = 768+primOpTag (VecQuotOp WordVec 16 W8) = 769+primOpTag (VecQuotOp WordVec 8 W16) = 770+primOpTag (VecQuotOp WordVec 4 W32) = 771+primOpTag (VecQuotOp WordVec 2 W64) = 772+primOpTag (VecQuotOp WordVec 32 W8) = 773+primOpTag (VecQuotOp WordVec 16 W16) = 774+primOpTag (VecQuotOp WordVec 8 W32) = 775+primOpTag (VecQuotOp WordVec 4 W64) = 776+primOpTag (VecQuotOp WordVec 64 W8) = 777+primOpTag (VecQuotOp WordVec 32 W16) = 778+primOpTag (VecQuotOp WordVec 16 W32) = 779+primOpTag (VecQuotOp WordVec 8 W64) = 780+primOpTag (VecRemOp IntVec 16 W8) = 781+primOpTag (VecRemOp IntVec 8 W16) = 782+primOpTag (VecRemOp IntVec 4 W32) = 783+primOpTag (VecRemOp IntVec 2 W64) = 784+primOpTag (VecRemOp IntVec 32 W8) = 785+primOpTag (VecRemOp IntVec 16 W16) = 786+primOpTag (VecRemOp IntVec 8 W32) = 787+primOpTag (VecRemOp IntVec 4 W64) = 788+primOpTag (VecRemOp IntVec 64 W8) = 789+primOpTag (VecRemOp IntVec 32 W16) = 790+primOpTag (VecRemOp IntVec 16 W32) = 791+primOpTag (VecRemOp IntVec 8 W64) = 792+primOpTag (VecRemOp WordVec 16 W8) = 793+primOpTag (VecRemOp WordVec 8 W16) = 794+primOpTag (VecRemOp WordVec 4 W32) = 795+primOpTag (VecRemOp WordVec 2 W64) = 796+primOpTag (VecRemOp WordVec 32 W8) = 797+primOpTag (VecRemOp WordVec 16 W16) = 798+primOpTag (VecRemOp WordVec 8 W32) = 799+primOpTag (VecRemOp WordVec 4 W64) = 800+primOpTag (VecRemOp WordVec 64 W8) = 801+primOpTag (VecRemOp WordVec 32 W16) = 802+primOpTag (VecRemOp WordVec 16 W32) = 803+primOpTag (VecRemOp WordVec 8 W64) = 804+primOpTag (VecNegOp IntVec 16 W8) = 805+primOpTag (VecNegOp IntVec 8 W16) = 806+primOpTag (VecNegOp IntVec 4 W32) = 807+primOpTag (VecNegOp IntVec 2 W64) = 808+primOpTag (VecNegOp IntVec 32 W8) = 809+primOpTag (VecNegOp IntVec 16 W16) = 810+primOpTag (VecNegOp IntVec 8 W32) = 811+primOpTag (VecNegOp IntVec 4 W64) = 812+primOpTag (VecNegOp IntVec 64 W8) = 813+primOpTag (VecNegOp IntVec 32 W16) = 814+primOpTag (VecNegOp IntVec 16 W32) = 815+primOpTag (VecNegOp IntVec 8 W64) = 816+primOpTag (VecNegOp FloatVec 4 W32) = 817+primOpTag (VecNegOp FloatVec 2 W64) = 818+primOpTag (VecNegOp FloatVec 8 W32) = 819+primOpTag (VecNegOp FloatVec 4 W64) = 820+primOpTag (VecNegOp FloatVec 16 W32) = 821+primOpTag (VecNegOp FloatVec 8 W64) = 822+primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 823+primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 824+primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 825+primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 826+primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 827+primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 828+primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 829+primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 830+primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 831+primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 832+primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 833+primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 834+primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 835+primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 836+primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 837+primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 838+primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 839+primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 840+primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 841+primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 842+primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 843+primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 844+primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 845+primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 846+primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 847+primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 848+primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 849+primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 850+primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 851+primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 852+primOpTag (VecReadByteArrayOp IntVec 16 W8) = 853+primOpTag (VecReadByteArrayOp IntVec 8 W16) = 854+primOpTag (VecReadByteArrayOp IntVec 4 W32) = 855+primOpTag (VecReadByteArrayOp IntVec 2 W64) = 856+primOpTag (VecReadByteArrayOp IntVec 32 W8) = 857+primOpTag (VecReadByteArrayOp IntVec 16 W16) = 858+primOpTag (VecReadByteArrayOp IntVec 8 W32) = 859+primOpTag (VecReadByteArrayOp IntVec 4 W64) = 860+primOpTag (VecReadByteArrayOp IntVec 64 W8) = 861+primOpTag (VecReadByteArrayOp IntVec 32 W16) = 862+primOpTag (VecReadByteArrayOp IntVec 16 W32) = 863+primOpTag (VecReadByteArrayOp IntVec 8 W64) = 864+primOpTag (VecReadByteArrayOp WordVec 16 W8) = 865+primOpTag (VecReadByteArrayOp WordVec 8 W16) = 866+primOpTag (VecReadByteArrayOp WordVec 4 W32) = 867+primOpTag (VecReadByteArrayOp WordVec 2 W64) = 868+primOpTag (VecReadByteArrayOp WordVec 32 W8) = 869+primOpTag (VecReadByteArrayOp WordVec 16 W16) = 870+primOpTag (VecReadByteArrayOp WordVec 8 W32) = 871+primOpTag (VecReadByteArrayOp WordVec 4 W64) = 872+primOpTag (VecReadByteArrayOp WordVec 64 W8) = 873+primOpTag (VecReadByteArrayOp WordVec 32 W16) = 874+primOpTag (VecReadByteArrayOp WordVec 16 W32) = 875+primOpTag (VecReadByteArrayOp WordVec 8 W64) = 876+primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 877+primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 878+primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 879+primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 880+primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 881+primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 882+primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 883+primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 884+primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 885+primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 886+primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 887+primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 888+primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 889+primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 890+primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 891+primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 892+primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 893+primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 894+primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 895+primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 896+primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 897+primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 898+primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 899+primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 900+primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 901+primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 902+primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 903+primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 904+primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 905+primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 906+primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 907+primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 908+primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 909+primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 910+primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 911+primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 912+primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 913+primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 914+primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 915+primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 916+primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 917+primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 918+primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 919+primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 920+primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 921+primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 922+primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 923+primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 924+primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 925+primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 926+primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 927+primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 928+primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 929+primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 930+primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 931+primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 932+primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 933+primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 934+primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 935+primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 936+primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 937+primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 938+primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 939+primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 940+primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 941+primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 942+primOpTag (VecReadOffAddrOp IntVec 16 W8) = 943+primOpTag (VecReadOffAddrOp IntVec 8 W16) = 944+primOpTag (VecReadOffAddrOp IntVec 4 W32) = 945+primOpTag (VecReadOffAddrOp IntVec 2 W64) = 946+primOpTag (VecReadOffAddrOp IntVec 32 W8) = 947+primOpTag (VecReadOffAddrOp IntVec 16 W16) = 948+primOpTag (VecReadOffAddrOp IntVec 8 W32) = 949+primOpTag (VecReadOffAddrOp IntVec 4 W64) = 950+primOpTag (VecReadOffAddrOp IntVec 64 W8) = 951+primOpTag (VecReadOffAddrOp IntVec 32 W16) = 952+primOpTag (VecReadOffAddrOp IntVec 16 W32) = 953+primOpTag (VecReadOffAddrOp IntVec 8 W64) = 954+primOpTag (VecReadOffAddrOp WordVec 16 W8) = 955+primOpTag (VecReadOffAddrOp WordVec 8 W16) = 956+primOpTag (VecReadOffAddrOp WordVec 4 W32) = 957+primOpTag (VecReadOffAddrOp WordVec 2 W64) = 958+primOpTag (VecReadOffAddrOp WordVec 32 W8) = 959+primOpTag (VecReadOffAddrOp WordVec 16 W16) = 960+primOpTag (VecReadOffAddrOp WordVec 8 W32) = 961+primOpTag (VecReadOffAddrOp WordVec 4 W64) = 962+primOpTag (VecReadOffAddrOp WordVec 64 W8) = 963+primOpTag (VecReadOffAddrOp WordVec 32 W16) = 964+primOpTag (VecReadOffAddrOp WordVec 16 W32) = 965+primOpTag (VecReadOffAddrOp WordVec 8 W64) = 966+primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 967+primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 968+primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 969+primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 970+primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 971+primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 972+primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 973+primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 974+primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 975+primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 976+primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 977+primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 978+primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 979+primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 980+primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 981+primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 982+primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 983+primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 984+primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 985+primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 986+primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 987+primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 988+primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 989+primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 990+primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 991+primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 992+primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 993+primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 994+primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 995+primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 996+primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 997+primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 998+primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 999+primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1000+primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1001+primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1002+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1003+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1004+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1005+primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1006+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1007+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1008+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1009+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1010+primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1011+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1012+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1013+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1014+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1015+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1016+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1017+primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1018+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1019+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1020+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1021+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1022+primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1023+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1024+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1025+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1026+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1027+primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1028+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1029+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1030+primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1031+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1032+primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1033+primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1034+primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1035+primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1036+primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1037+primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1038+primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1039+primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1040+primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1041+primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1042+primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1043+primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1044+primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1045+primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1046+primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1047+primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1048+primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1049+primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1050+primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1051+primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1052+primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1053+primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1054+primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1055+primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1056+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1057+primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1058+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1059+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1060+primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1061+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1062+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1063+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1064+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1065+primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1066+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1067+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1068+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1069+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1070+primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1071+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1072+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1073+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1074+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1075+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1076+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1077+primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1078+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1079+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1080+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1081+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1082+primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1083+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1084+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1085+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1086+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1087+primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1088+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1089+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1090+primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1091+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1092+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1093+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1094+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1095+primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1096+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1097+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1098+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1099+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1100+primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1101+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1102+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1103+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1104+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1105+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1106+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1107+primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1108+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1109+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1110+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1111+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1112+primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1113+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1114+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1115+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1116+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1117+primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1118+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1119+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1120+primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1121+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1122+primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1123+primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1124+primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1125+primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1126+primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1127+primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1128+primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1129+primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1130+primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1131+primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1132+primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1133+primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1134+primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1135+primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1136+primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1137+primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1138+primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1139+primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1140+primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1141+primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1142+primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1143+primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1144+primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1145+primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1146+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1147+primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1148+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1149+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1150+primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1151+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1152+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1153+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1154+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1155+primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1156+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1157+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1158+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1159+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1160+primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1161+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1162+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1163+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1164+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1165+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1166+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1167+primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1168+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1169+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1170+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1171+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1172+primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1173+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1174+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1175+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1176+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1177+primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1178+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1179+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1180+primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1181+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1182+primOpTag PrefetchByteArrayOp3 = 1183+primOpTag PrefetchMutableByteArrayOp3 = 1184+primOpTag PrefetchAddrOp3 = 1185+primOpTag PrefetchValueOp3 = 1186+primOpTag PrefetchByteArrayOp2 = 1187+primOpTag PrefetchMutableByteArrayOp2 = 1188+primOpTag PrefetchAddrOp2 = 1189+primOpTag PrefetchValueOp2 = 1190+primOpTag PrefetchByteArrayOp1 = 1191+primOpTag PrefetchMutableByteArrayOp1 = 1192+primOpTag PrefetchAddrOp1 = 1193+primOpTag PrefetchValueOp1 = 1194+primOpTag PrefetchByteArrayOp0 = 1195+primOpTag PrefetchMutableByteArrayOp0 = 1196+primOpTag PrefetchAddrOp0 = 1197+primOpTag PrefetchValueOp0 = 1198
+ ghc-lib/stage1/compiler/build/primop-vector-tycons.hs-incl view
@@ -0,0 +1,30 @@+    , int8X16PrimTyCon+    , int16X8PrimTyCon+    , int32X4PrimTyCon+    , int64X2PrimTyCon+    , int8X32PrimTyCon+    , int16X16PrimTyCon+    , int32X8PrimTyCon+    , int64X4PrimTyCon+    , int8X64PrimTyCon+    , int16X32PrimTyCon+    , int32X16PrimTyCon+    , int64X8PrimTyCon+    , word8X16PrimTyCon+    , word16X8PrimTyCon+    , word32X4PrimTyCon+    , word64X2PrimTyCon+    , word8X32PrimTyCon+    , word16X16PrimTyCon+    , word32X8PrimTyCon+    , word64X4PrimTyCon+    , word8X64PrimTyCon+    , word16X32PrimTyCon+    , word32X16PrimTyCon+    , word64X8PrimTyCon+    , floatX4PrimTyCon+    , doubleX2PrimTyCon+    , floatX8PrimTyCon+    , doubleX4PrimTyCon+    , floatX16PrimTyCon+    , doubleX8PrimTyCon
+ ghc-lib/stage1/compiler/build/primop-vector-tys-exports.hs-incl view
@@ -0,0 +1,30 @@+        int8X16PrimTy, int8X16PrimTyCon,+        int16X8PrimTy, int16X8PrimTyCon,+        int32X4PrimTy, int32X4PrimTyCon,+        int64X2PrimTy, int64X2PrimTyCon,+        int8X32PrimTy, int8X32PrimTyCon,+        int16X16PrimTy, int16X16PrimTyCon,+        int32X8PrimTy, int32X8PrimTyCon,+        int64X4PrimTy, int64X4PrimTyCon,+        int8X64PrimTy, int8X64PrimTyCon,+        int16X32PrimTy, int16X32PrimTyCon,+        int32X16PrimTy, int32X16PrimTyCon,+        int64X8PrimTy, int64X8PrimTyCon,+        word8X16PrimTy, word8X16PrimTyCon,+        word16X8PrimTy, word16X8PrimTyCon,+        word32X4PrimTy, word32X4PrimTyCon,+        word64X2PrimTy, word64X2PrimTyCon,+        word8X32PrimTy, word8X32PrimTyCon,+        word16X16PrimTy, word16X16PrimTyCon,+        word32X8PrimTy, word32X8PrimTyCon,+        word64X4PrimTy, word64X4PrimTyCon,+        word8X64PrimTy, word8X64PrimTyCon,+        word16X32PrimTy, word16X32PrimTyCon,+        word32X16PrimTy, word32X16PrimTyCon,+        word64X8PrimTy, word64X8PrimTyCon,+        floatX4PrimTy, floatX4PrimTyCon,+        doubleX2PrimTy, doubleX2PrimTyCon,+        floatX8PrimTy, floatX8PrimTyCon,+        doubleX4PrimTy, doubleX4PrimTyCon,+        floatX16PrimTy, floatX16PrimTyCon,+        doubleX8PrimTy, doubleX8PrimTyCon,
+ ghc-lib/stage1/compiler/build/primop-vector-tys.hs-incl view
@@ -0,0 +1,180 @@+int8X16PrimTyConName :: Name+int8X16PrimTyConName = mkPrimTc (fsLit "Int8X16#") int8X16PrimTyConKey int8X16PrimTyCon+int8X16PrimTy :: Type+int8X16PrimTy = mkTyConTy int8X16PrimTyCon+int8X16PrimTyCon :: TyCon+int8X16PrimTyCon = pcPrimTyCon0 int8X16PrimTyConName (VecRep 16 Int8ElemRep)+int16X8PrimTyConName :: Name+int16X8PrimTyConName = mkPrimTc (fsLit "Int16X8#") int16X8PrimTyConKey int16X8PrimTyCon+int16X8PrimTy :: Type+int16X8PrimTy = mkTyConTy int16X8PrimTyCon+int16X8PrimTyCon :: TyCon+int16X8PrimTyCon = pcPrimTyCon0 int16X8PrimTyConName (VecRep 8 Int16ElemRep)+int32X4PrimTyConName :: Name+int32X4PrimTyConName = mkPrimTc (fsLit "Int32X4#") int32X4PrimTyConKey int32X4PrimTyCon+int32X4PrimTy :: Type+int32X4PrimTy = mkTyConTy int32X4PrimTyCon+int32X4PrimTyCon :: TyCon+int32X4PrimTyCon = pcPrimTyCon0 int32X4PrimTyConName (VecRep 4 Int32ElemRep)+int64X2PrimTyConName :: Name+int64X2PrimTyConName = mkPrimTc (fsLit "Int64X2#") int64X2PrimTyConKey int64X2PrimTyCon+int64X2PrimTy :: Type+int64X2PrimTy = mkTyConTy int64X2PrimTyCon+int64X2PrimTyCon :: TyCon+int64X2PrimTyCon = pcPrimTyCon0 int64X2PrimTyConName (VecRep 2 Int64ElemRep)+int8X32PrimTyConName :: Name+int8X32PrimTyConName = mkPrimTc (fsLit "Int8X32#") int8X32PrimTyConKey int8X32PrimTyCon+int8X32PrimTy :: Type+int8X32PrimTy = mkTyConTy int8X32PrimTyCon+int8X32PrimTyCon :: TyCon+int8X32PrimTyCon = pcPrimTyCon0 int8X32PrimTyConName (VecRep 32 Int8ElemRep)+int16X16PrimTyConName :: Name+int16X16PrimTyConName = mkPrimTc (fsLit "Int16X16#") int16X16PrimTyConKey int16X16PrimTyCon+int16X16PrimTy :: Type+int16X16PrimTy = mkTyConTy int16X16PrimTyCon+int16X16PrimTyCon :: TyCon+int16X16PrimTyCon = pcPrimTyCon0 int16X16PrimTyConName (VecRep 16 Int16ElemRep)+int32X8PrimTyConName :: Name+int32X8PrimTyConName = mkPrimTc (fsLit "Int32X8#") int32X8PrimTyConKey int32X8PrimTyCon+int32X8PrimTy :: Type+int32X8PrimTy = mkTyConTy int32X8PrimTyCon+int32X8PrimTyCon :: TyCon+int32X8PrimTyCon = pcPrimTyCon0 int32X8PrimTyConName (VecRep 8 Int32ElemRep)+int64X4PrimTyConName :: Name+int64X4PrimTyConName = mkPrimTc (fsLit "Int64X4#") int64X4PrimTyConKey int64X4PrimTyCon+int64X4PrimTy :: Type+int64X4PrimTy = mkTyConTy int64X4PrimTyCon+int64X4PrimTyCon :: TyCon+int64X4PrimTyCon = pcPrimTyCon0 int64X4PrimTyConName (VecRep 4 Int64ElemRep)+int8X64PrimTyConName :: Name+int8X64PrimTyConName = mkPrimTc (fsLit "Int8X64#") int8X64PrimTyConKey int8X64PrimTyCon+int8X64PrimTy :: Type+int8X64PrimTy = mkTyConTy int8X64PrimTyCon+int8X64PrimTyCon :: TyCon+int8X64PrimTyCon = pcPrimTyCon0 int8X64PrimTyConName (VecRep 64 Int8ElemRep)+int16X32PrimTyConName :: Name+int16X32PrimTyConName = mkPrimTc (fsLit "Int16X32#") int16X32PrimTyConKey int16X32PrimTyCon+int16X32PrimTy :: Type+int16X32PrimTy = mkTyConTy int16X32PrimTyCon+int16X32PrimTyCon :: TyCon+int16X32PrimTyCon = pcPrimTyCon0 int16X32PrimTyConName (VecRep 32 Int16ElemRep)+int32X16PrimTyConName :: Name+int32X16PrimTyConName = mkPrimTc (fsLit "Int32X16#") int32X16PrimTyConKey int32X16PrimTyCon+int32X16PrimTy :: Type+int32X16PrimTy = mkTyConTy int32X16PrimTyCon+int32X16PrimTyCon :: TyCon+int32X16PrimTyCon = pcPrimTyCon0 int32X16PrimTyConName (VecRep 16 Int32ElemRep)+int64X8PrimTyConName :: Name+int64X8PrimTyConName = mkPrimTc (fsLit "Int64X8#") int64X8PrimTyConKey int64X8PrimTyCon+int64X8PrimTy :: Type+int64X8PrimTy = mkTyConTy int64X8PrimTyCon+int64X8PrimTyCon :: TyCon+int64X8PrimTyCon = pcPrimTyCon0 int64X8PrimTyConName (VecRep 8 Int64ElemRep)+word8X16PrimTyConName :: Name+word8X16PrimTyConName = mkPrimTc (fsLit "Word8X16#") word8X16PrimTyConKey word8X16PrimTyCon+word8X16PrimTy :: Type+word8X16PrimTy = mkTyConTy word8X16PrimTyCon+word8X16PrimTyCon :: TyCon+word8X16PrimTyCon = pcPrimTyCon0 word8X16PrimTyConName (VecRep 16 Word8ElemRep)+word16X8PrimTyConName :: Name+word16X8PrimTyConName = mkPrimTc (fsLit "Word16X8#") word16X8PrimTyConKey word16X8PrimTyCon+word16X8PrimTy :: Type+word16X8PrimTy = mkTyConTy word16X8PrimTyCon+word16X8PrimTyCon :: TyCon+word16X8PrimTyCon = pcPrimTyCon0 word16X8PrimTyConName (VecRep 8 Word16ElemRep)+word32X4PrimTyConName :: Name+word32X4PrimTyConName = mkPrimTc (fsLit "Word32X4#") word32X4PrimTyConKey word32X4PrimTyCon+word32X4PrimTy :: Type+word32X4PrimTy = mkTyConTy word32X4PrimTyCon+word32X4PrimTyCon :: TyCon+word32X4PrimTyCon = pcPrimTyCon0 word32X4PrimTyConName (VecRep 4 Word32ElemRep)+word64X2PrimTyConName :: Name+word64X2PrimTyConName = mkPrimTc (fsLit "Word64X2#") word64X2PrimTyConKey word64X2PrimTyCon+word64X2PrimTy :: Type+word64X2PrimTy = mkTyConTy word64X2PrimTyCon+word64X2PrimTyCon :: TyCon+word64X2PrimTyCon = pcPrimTyCon0 word64X2PrimTyConName (VecRep 2 Word64ElemRep)+word8X32PrimTyConName :: Name+word8X32PrimTyConName = mkPrimTc (fsLit "Word8X32#") word8X32PrimTyConKey word8X32PrimTyCon+word8X32PrimTy :: Type+word8X32PrimTy = mkTyConTy word8X32PrimTyCon+word8X32PrimTyCon :: TyCon+word8X32PrimTyCon = pcPrimTyCon0 word8X32PrimTyConName (VecRep 32 Word8ElemRep)+word16X16PrimTyConName :: Name+word16X16PrimTyConName = mkPrimTc (fsLit "Word16X16#") word16X16PrimTyConKey word16X16PrimTyCon+word16X16PrimTy :: Type+word16X16PrimTy = mkTyConTy word16X16PrimTyCon+word16X16PrimTyCon :: TyCon+word16X16PrimTyCon = pcPrimTyCon0 word16X16PrimTyConName (VecRep 16 Word16ElemRep)+word32X8PrimTyConName :: Name+word32X8PrimTyConName = mkPrimTc (fsLit "Word32X8#") word32X8PrimTyConKey word32X8PrimTyCon+word32X8PrimTy :: Type+word32X8PrimTy = mkTyConTy word32X8PrimTyCon+word32X8PrimTyCon :: TyCon+word32X8PrimTyCon = pcPrimTyCon0 word32X8PrimTyConName (VecRep 8 Word32ElemRep)+word64X4PrimTyConName :: Name+word64X4PrimTyConName = mkPrimTc (fsLit "Word64X4#") word64X4PrimTyConKey word64X4PrimTyCon+word64X4PrimTy :: Type+word64X4PrimTy = mkTyConTy word64X4PrimTyCon+word64X4PrimTyCon :: TyCon+word64X4PrimTyCon = pcPrimTyCon0 word64X4PrimTyConName (VecRep 4 Word64ElemRep)+word8X64PrimTyConName :: Name+word8X64PrimTyConName = mkPrimTc (fsLit "Word8X64#") word8X64PrimTyConKey word8X64PrimTyCon+word8X64PrimTy :: Type+word8X64PrimTy = mkTyConTy word8X64PrimTyCon+word8X64PrimTyCon :: TyCon+word8X64PrimTyCon = pcPrimTyCon0 word8X64PrimTyConName (VecRep 64 Word8ElemRep)+word16X32PrimTyConName :: Name+word16X32PrimTyConName = mkPrimTc (fsLit "Word16X32#") word16X32PrimTyConKey word16X32PrimTyCon+word16X32PrimTy :: Type+word16X32PrimTy = mkTyConTy word16X32PrimTyCon+word16X32PrimTyCon :: TyCon+word16X32PrimTyCon = pcPrimTyCon0 word16X32PrimTyConName (VecRep 32 Word16ElemRep)+word32X16PrimTyConName :: Name+word32X16PrimTyConName = mkPrimTc (fsLit "Word32X16#") word32X16PrimTyConKey word32X16PrimTyCon+word32X16PrimTy :: Type+word32X16PrimTy = mkTyConTy word32X16PrimTyCon+word32X16PrimTyCon :: TyCon+word32X16PrimTyCon = pcPrimTyCon0 word32X16PrimTyConName (VecRep 16 Word32ElemRep)+word64X8PrimTyConName :: Name+word64X8PrimTyConName = mkPrimTc (fsLit "Word64X8#") word64X8PrimTyConKey word64X8PrimTyCon+word64X8PrimTy :: Type+word64X8PrimTy = mkTyConTy word64X8PrimTyCon+word64X8PrimTyCon :: TyCon+word64X8PrimTyCon = pcPrimTyCon0 word64X8PrimTyConName (VecRep 8 Word64ElemRep)+floatX4PrimTyConName :: Name+floatX4PrimTyConName = mkPrimTc (fsLit "FloatX4#") floatX4PrimTyConKey floatX4PrimTyCon+floatX4PrimTy :: Type+floatX4PrimTy = mkTyConTy floatX4PrimTyCon+floatX4PrimTyCon :: TyCon+floatX4PrimTyCon = pcPrimTyCon0 floatX4PrimTyConName (VecRep 4 FloatElemRep)+doubleX2PrimTyConName :: Name+doubleX2PrimTyConName = mkPrimTc (fsLit "DoubleX2#") doubleX2PrimTyConKey doubleX2PrimTyCon+doubleX2PrimTy :: Type+doubleX2PrimTy = mkTyConTy doubleX2PrimTyCon+doubleX2PrimTyCon :: TyCon+doubleX2PrimTyCon = pcPrimTyCon0 doubleX2PrimTyConName (VecRep 2 DoubleElemRep)+floatX8PrimTyConName :: Name+floatX8PrimTyConName = mkPrimTc (fsLit "FloatX8#") floatX8PrimTyConKey floatX8PrimTyCon+floatX8PrimTy :: Type+floatX8PrimTy = mkTyConTy floatX8PrimTyCon+floatX8PrimTyCon :: TyCon+floatX8PrimTyCon = pcPrimTyCon0 floatX8PrimTyConName (VecRep 8 FloatElemRep)+doubleX4PrimTyConName :: Name+doubleX4PrimTyConName = mkPrimTc (fsLit "DoubleX4#") doubleX4PrimTyConKey doubleX4PrimTyCon+doubleX4PrimTy :: Type+doubleX4PrimTy = mkTyConTy doubleX4PrimTyCon+doubleX4PrimTyCon :: TyCon+doubleX4PrimTyCon = pcPrimTyCon0 doubleX4PrimTyConName (VecRep 4 DoubleElemRep)+floatX16PrimTyConName :: Name+floatX16PrimTyConName = mkPrimTc (fsLit "FloatX16#") floatX16PrimTyConKey floatX16PrimTyCon+floatX16PrimTy :: Type+floatX16PrimTy = mkTyConTy floatX16PrimTyCon+floatX16PrimTyCon :: TyCon+floatX16PrimTyCon = pcPrimTyCon0 floatX16PrimTyConName (VecRep 16 FloatElemRep)+doubleX8PrimTyConName :: Name+doubleX8PrimTyConName = mkPrimTc (fsLit "DoubleX8#") doubleX8PrimTyConKey doubleX8PrimTyCon+doubleX8PrimTy :: Type+doubleX8PrimTy = mkTyConTy doubleX8PrimTyCon+doubleX8PrimTyCon :: TyCon+doubleX8PrimTyCon = pcPrimTyCon0 doubleX8PrimTyConName (VecRep 8 DoubleElemRep)
+ ghc-lib/stage1/compiler/build/primop-vector-uniques.hs-incl view
@@ -0,0 +1,60 @@+int8X16PrimTyConKey :: Unique+int8X16PrimTyConKey = mkPreludeTyConUnique 300+int16X8PrimTyConKey :: Unique+int16X8PrimTyConKey = mkPreludeTyConUnique 301+int32X4PrimTyConKey :: Unique+int32X4PrimTyConKey = mkPreludeTyConUnique 302+int64X2PrimTyConKey :: Unique+int64X2PrimTyConKey = mkPreludeTyConUnique 303+int8X32PrimTyConKey :: Unique+int8X32PrimTyConKey = mkPreludeTyConUnique 304+int16X16PrimTyConKey :: Unique+int16X16PrimTyConKey = mkPreludeTyConUnique 305+int32X8PrimTyConKey :: Unique+int32X8PrimTyConKey = mkPreludeTyConUnique 306+int64X4PrimTyConKey :: Unique+int64X4PrimTyConKey = mkPreludeTyConUnique 307+int8X64PrimTyConKey :: Unique+int8X64PrimTyConKey = mkPreludeTyConUnique 308+int16X32PrimTyConKey :: Unique+int16X32PrimTyConKey = mkPreludeTyConUnique 309+int32X16PrimTyConKey :: Unique+int32X16PrimTyConKey = mkPreludeTyConUnique 310+int64X8PrimTyConKey :: Unique+int64X8PrimTyConKey = mkPreludeTyConUnique 311+word8X16PrimTyConKey :: Unique+word8X16PrimTyConKey = mkPreludeTyConUnique 312+word16X8PrimTyConKey :: Unique+word16X8PrimTyConKey = mkPreludeTyConUnique 313+word32X4PrimTyConKey :: Unique+word32X4PrimTyConKey = mkPreludeTyConUnique 314+word64X2PrimTyConKey :: Unique+word64X2PrimTyConKey = mkPreludeTyConUnique 315+word8X32PrimTyConKey :: Unique+word8X32PrimTyConKey = mkPreludeTyConUnique 316+word16X16PrimTyConKey :: Unique+word16X16PrimTyConKey = mkPreludeTyConUnique 317+word32X8PrimTyConKey :: Unique+word32X8PrimTyConKey = mkPreludeTyConUnique 318+word64X4PrimTyConKey :: Unique+word64X4PrimTyConKey = mkPreludeTyConUnique 319+word8X64PrimTyConKey :: Unique+word8X64PrimTyConKey = mkPreludeTyConUnique 320+word16X32PrimTyConKey :: Unique+word16X32PrimTyConKey = mkPreludeTyConUnique 321+word32X16PrimTyConKey :: Unique+word32X16PrimTyConKey = mkPreludeTyConUnique 322+word64X8PrimTyConKey :: Unique+word64X8PrimTyConKey = mkPreludeTyConUnique 323+floatX4PrimTyConKey :: Unique+floatX4PrimTyConKey = mkPreludeTyConUnique 324+doubleX2PrimTyConKey :: Unique+doubleX2PrimTyConKey = mkPreludeTyConUnique 325+floatX8PrimTyConKey :: Unique+floatX8PrimTyConKey = mkPreludeTyConUnique 326+doubleX4PrimTyConKey :: Unique+doubleX4PrimTyConKey = mkPreludeTyConUnique 327+floatX16PrimTyConKey :: Unique+floatX16PrimTyConKey = mkPreludeTyConUnique 328+doubleX8PrimTyConKey :: Unique+doubleX8PrimTyConKey = mkPreludeTyConUnique 329
+ ghc-lib/stage1/lib/llvm-passes view
@@ -0,0 +1,5 @@+[+(0, "-mem2reg -globalopt"),+(1, "-O1 -globalopt"),+(2, "-O2")+]
+ ghc-lib/stage1/lib/llvm-targets view
@@ -0,0 +1,31 @@+[("i386-unknown-windows", ("e-m:x-p:32:32-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", ""))+,("i686-unknown-windows", ("e-m:x-p:32:32-i64:64-f80:32-n8:16:32-a:0:32-S32", "pentium4", ""))+,("x86_64-unknown-windows", ("e-m:w-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))+,("arm-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))+,("armv6-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1136jf-s", "+strict-align"))+,("armv6l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))+,("armv7-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7a-unknown-linux-gnueabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("armv7l-unknown-linux-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("aarch64-unknown-linux-gnu", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))+,("aarch64-unknown-linux", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))+,("i386-unknown-linux-gnu", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))+,("i386-unknown-linux", ("e-m:e-p:32:32-f64:32:64-f80:32-n8:16:32-S128", "pentium4", ""))+,("x86_64-unknown-linux-gnu", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))+,("x86_64-unknown-linux", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))+,("armv7-unknown-linux-androideabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", ""))+,("aarch64-unknown-linux-android", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))+,("powerpc64le-unknown-linux", ("e-m:e-i64:64-n32:64", "ppc64le", ""))+,("amd64-portbld-freebsd", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))+,("x86_64-unknown-freebsd", ("e-m:e-i64:64-f80:128-n8:16:32:64-S128", "x86-64", ""))+,("arm-unknown-nto-qnx-eabi", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm7tdmi", "+strict-align"))+,("i386-apple-darwin", ("e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128", "yonah", ""))+,("x86_64-apple-darwin", ("e-m:o-i64:64-f80:128-n8:16:32:64-S128", "core2", ""))+,("armv7-apple-ios", ("e-m:o-p:32:32-f64:32:64-v64:32:64-v128:32:128-a:0:32-n32-S32", "generic", ""))+,("aarch64-apple-ios", ("e-m:o-i64:64-i128:128-n32:64-S128", "generic", "+neon"))+,("i386-apple-ios", ("e-m:o-p:32:32-f64:32:64-f80:128-n8:16:32-S128", "yonah", ""))+,("x86_64-apple-ios", ("e-m:o-i64:64-f80:128-n8:16:32:64-S128", "core2", ""))+,("aarch64-unknown-freebsd", ("e-m:e-i8:8:32-i16:16:32-i64:64-i128:128-n32:64-S128", "generic", "+neon"))+,("armv6-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "arm1176jzf-s", "+strict-align"))+,("armv7-unknown-freebsd-gnueabihf", ("e-m:e-p:32:32-i64:64-v128:64:128-a:0:32-n32-S64", "generic", "+strict-align"))+]
+ ghc-lib/stage1/lib/platformConstants view
@@ -0,0 +1,134 @@+PlatformConstants {+    pc_platformConstants = ()+    , pc_CONTROL_GROUP_CONST_291 = 291+    , pc_STD_HDR_SIZE = 1+    , pc_PROF_HDR_SIZE = 2+    , pc_BLOCK_SIZE = 4096+    , pc_BLOCKS_PER_MBLOCK = 252+    , pc_TICKY_BIN_COUNT = 9+    , pc_OFFSET_StgRegTable_rR1 = 0+    , pc_OFFSET_StgRegTable_rR2 = 8+    , pc_OFFSET_StgRegTable_rR3 = 16+    , pc_OFFSET_StgRegTable_rR4 = 24+    , pc_OFFSET_StgRegTable_rR5 = 32+    , pc_OFFSET_StgRegTable_rR6 = 40+    , pc_OFFSET_StgRegTable_rR7 = 48+    , pc_OFFSET_StgRegTable_rR8 = 56+    , pc_OFFSET_StgRegTable_rR9 = 64+    , pc_OFFSET_StgRegTable_rR10 = 72+    , pc_OFFSET_StgRegTable_rF1 = 80+    , pc_OFFSET_StgRegTable_rF2 = 84+    , pc_OFFSET_StgRegTable_rF3 = 88+    , pc_OFFSET_StgRegTable_rF4 = 92+    , pc_OFFSET_StgRegTable_rF5 = 96+    , pc_OFFSET_StgRegTable_rF6 = 100+    , pc_OFFSET_StgRegTable_rD1 = 104+    , pc_OFFSET_StgRegTable_rD2 = 112+    , pc_OFFSET_StgRegTable_rD3 = 120+    , pc_OFFSET_StgRegTable_rD4 = 128+    , pc_OFFSET_StgRegTable_rD5 = 136+    , pc_OFFSET_StgRegTable_rD6 = 144+    , pc_OFFSET_StgRegTable_rXMM1 = 152+    , pc_OFFSET_StgRegTable_rXMM2 = 168+    , pc_OFFSET_StgRegTable_rXMM3 = 184+    , pc_OFFSET_StgRegTable_rXMM4 = 200+    , pc_OFFSET_StgRegTable_rXMM5 = 216+    , pc_OFFSET_StgRegTable_rXMM6 = 232+    , pc_OFFSET_StgRegTable_rYMM1 = 248+    , pc_OFFSET_StgRegTable_rYMM2 = 280+    , pc_OFFSET_StgRegTable_rYMM3 = 312+    , pc_OFFSET_StgRegTable_rYMM4 = 344+    , pc_OFFSET_StgRegTable_rYMM5 = 376+    , pc_OFFSET_StgRegTable_rYMM6 = 408+    , pc_OFFSET_StgRegTable_rZMM1 = 440+    , pc_OFFSET_StgRegTable_rZMM2 = 504+    , pc_OFFSET_StgRegTable_rZMM3 = 568+    , pc_OFFSET_StgRegTable_rZMM4 = 632+    , pc_OFFSET_StgRegTable_rZMM5 = 696+    , pc_OFFSET_StgRegTable_rZMM6 = 760+    , pc_OFFSET_StgRegTable_rL1 = 824+    , pc_OFFSET_StgRegTable_rSp = 832+    , pc_OFFSET_StgRegTable_rSpLim = 840+    , pc_OFFSET_StgRegTable_rHp = 848+    , pc_OFFSET_StgRegTable_rHpLim = 856+    , pc_OFFSET_StgRegTable_rCCCS = 864+    , pc_OFFSET_StgRegTable_rCurrentTSO = 872+    , pc_OFFSET_StgRegTable_rCurrentNursery = 888+    , pc_OFFSET_StgRegTable_rHpAlloc = 904+    , pc_OFFSET_stgEagerBlackholeInfo = -24+    , pc_OFFSET_stgGCEnter1 = -16+    , pc_OFFSET_stgGCFun = -8+    , pc_OFFSET_Capability_r = 24+    , pc_OFFSET_bdescr_start = 0+    , pc_OFFSET_bdescr_free = 8+    , pc_OFFSET_bdescr_blocks = 48+    , pc_OFFSET_bdescr_flags = 46+    , pc_SIZEOF_CostCentreStack = 96+    , pc_OFFSET_CostCentreStack_mem_alloc = 72+    , pc_REP_CostCentreStack_mem_alloc = 8+    , pc_OFFSET_CostCentreStack_scc_count = 48+    , pc_REP_CostCentreStack_scc_count = 8+    , pc_OFFSET_StgHeader_ccs = 8+    , pc_OFFSET_StgHeader_ldvw = 16+    , pc_SIZEOF_StgSMPThunkHeader = 8+    , pc_OFFSET_StgEntCounter_allocs = 48+    , pc_REP_StgEntCounter_allocs = 8+    , pc_OFFSET_StgEntCounter_allocd = 16+    , pc_REP_StgEntCounter_allocd = 8+    , pc_OFFSET_StgEntCounter_registeredp = 0+    , pc_OFFSET_StgEntCounter_link = 56+    , pc_OFFSET_StgEntCounter_entry_count = 40+    , pc_SIZEOF_StgUpdateFrame_NoHdr = 8+    , pc_SIZEOF_StgMutArrPtrs_NoHdr = 16+    , pc_OFFSET_StgMutArrPtrs_ptrs = 0+    , pc_OFFSET_StgMutArrPtrs_size = 8+    , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = 8+    , pc_OFFSET_StgSmallMutArrPtrs_ptrs = 0+    , pc_SIZEOF_StgArrBytes_NoHdr = 8+    , pc_OFFSET_StgArrBytes_bytes = 0+    , pc_OFFSET_StgTSO_alloc_limit = 96+    , pc_OFFSET_StgTSO_cccs = 112+    , pc_OFFSET_StgTSO_stackobj = 16+    , pc_OFFSET_StgStack_sp = 8+    , pc_OFFSET_StgStack_stack = 16+    , pc_OFFSET_StgUpdateFrame_updatee = 0+    , pc_OFFSET_StgFunInfoExtraFwd_arity = 4+    , pc_REP_StgFunInfoExtraFwd_arity = 4+    , pc_SIZEOF_StgFunInfoExtraRev = 24+    , pc_OFFSET_StgFunInfoExtraRev_arity = 20+    , pc_REP_StgFunInfoExtraRev_arity = 4+    , pc_MAX_SPEC_SELECTEE_SIZE = 15+    , pc_MAX_SPEC_AP_SIZE = 7+    , pc_MIN_PAYLOAD_SIZE = 1+    , pc_MIN_INTLIKE = -16+    , pc_MAX_INTLIKE = 16+    , pc_MIN_CHARLIKE = 0+    , pc_MAX_CHARLIKE = 255+    , pc_MUT_ARR_PTRS_CARD_BITS = 7+    , pc_MAX_Vanilla_REG = 10+    , pc_MAX_Float_REG = 6+    , pc_MAX_Double_REG = 6+    , pc_MAX_Long_REG = 1+    , pc_MAX_XMM_REG = 6+    , pc_MAX_Real_Vanilla_REG = 6+    , pc_MAX_Real_Float_REG = 6+    , pc_MAX_Real_Double_REG = 6+    , pc_MAX_Real_XMM_REG = 6+    , pc_MAX_Real_Long_REG = 0+    , pc_RESERVED_C_STACK_BYTES = 16384+    , pc_RESERVED_STACK_WORDS = 21+    , pc_AP_STACK_SPLIM = 1024+    , pc_WORD_SIZE = 8+    , pc_DOUBLE_SIZE = 8+    , pc_CINT_SIZE = 4+    , pc_CLONG_SIZE = 8+    , pc_CLONG_LONG_SIZE = 8+    , pc_BITMAP_BITS_SHIFT = 6+    , pc_TAG_BITS = 3+    , pc_WORDS_BIGENDIAN = False+    , pc_DYNAMIC_BY_DEFAULT = False+    , pc_LDV_SHIFT = 30+    , pc_ILDV_CREATE_MASK = 1152921503533105152+    , pc_ILDV_STATE_CREATE = 0+    , pc_ILDV_STATE_USE = 1152921504606846976+  }
+ ghc-lib/stage1/lib/settings view
@@ -0,0 +1,47 @@+[("GCC extra via C opts", "-fwrapv -fno-builtin")+,("C compiler command", "gcc")+,("C compiler flags", "")+,("C compiler link flags", "")+,("C compiler supports -no-pie", "NO")+,("Haskell CPP command", "gcc")+,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")+,("ld command", "ld")+,("ld flags", "")+,("ld supports compact unwind", "YES")+,("ld supports build-id", "NO")+,("ld supports filelist", "YES")+,("ld is GNU ld", "NO")+,("ar command", "ar")+,("ar flags", "qcls")+,("ar supports at file", "NO")+,("ranlib command", "ranlib")+,("touch command", "touch")+,("dllwrap command", "/bin/false")+,("windres command", "/bin/false")+,("libtool command", "libtool")+,("unlit command", "$topdir/bin/ghc-lib/stage0/lib/bin/unlit")+,("cross compiling", "NO")+,("target platform string", "x86_64-apple-darwin")+,("target os", "OSDarwin")+,("target arch", "ArchX86_64")+,("target word size", "8")+,("target has GNU nonexec stack", "False")+,("target has .ident directive", "True")+,("target has subsections via symbols", "True")+,("target has RTS linker", "YES")+,("Unregisterised", "NO")+,("LLVM llc command", "llc")+,("LLVM opt command", "opt")+,("LLVM clang command", "clang")+,("integer library", "integer-simple")+,("Use interpreter", "YES")+,("Use native code generator", "YES")+,("Support SMP", "YES")+,("RTS ways", "YES")+,("Tables next to code", "YES")+,("Leading underscore", "NO")+,("Use LibFFI", "NO")+,("Use Threads", "YES")+,("Use Debugging", "NO")+,("RTS expects libdw", "NO")+]
+ ghc/GHCi/Leak.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE RecordWildCards, LambdaCase #-}+module GHCi.Leak+  ( LeakIndicators+  , getLeakIndicators+  , checkLeakIndicators+  ) where++import Control.Monad+import Data.Bits+import DynFlags ( sTargetPlatform )+import Foreign.Ptr (ptrToIntPtr, intPtrToPtr)+import GHC+import GHC.Ptr (Ptr (..))+import GHCi.Util+import HscTypes+import Outputable+import Platform (target32Bit)+import Prelude+import System.Mem+import System.Mem.Weak+import UniqDFM++-- Checking for space leaks in GHCi. See #15111, and the+-- -fghci-leak-check flag.++data LeakIndicators = LeakIndicators [LeakModIndicators]++data LeakModIndicators = LeakModIndicators+  { leakMod :: Weak HomeModInfo+  , leakIface :: Weak ModIface+  , leakDetails :: Weak ModDetails+  , leakLinkable :: Maybe (Weak Linkable)+  }++-- | Grab weak references to some of the data structures representing+-- the currently loaded modules.+getLeakIndicators :: HscEnv -> IO LeakIndicators+getLeakIndicators HscEnv{..} =+  fmap LeakIndicators $+    forM (eltsUDFM hsc_HPT) $ \hmi@HomeModInfo{..} -> do+      leakMod <- mkWeakPtr hmi Nothing+      leakIface <- mkWeakPtr hm_iface Nothing+      leakDetails <- mkWeakPtr hm_details Nothing+      leakLinkable <- mapM (`mkWeakPtr` Nothing) hm_linkable+      return $ LeakModIndicators{..}++-- | Look at the LeakIndicators collected by an earlier call to+-- `getLeakIndicators`, and print messasges if any of them are still+-- alive.+checkLeakIndicators :: DynFlags -> LeakIndicators -> IO ()+checkLeakIndicators dflags (LeakIndicators leakmods)  = do+  performGC+  forM_ leakmods $ \LeakModIndicators{..} -> do+    deRefWeak leakMod >>= \case+      Nothing -> return ()+      Just hmi ->+        report ("HomeModInfo for " +++          showSDoc dflags (ppr (mi_module (hm_iface hmi)))) (Just hmi)+    deRefWeak leakIface >>= report "ModIface"+    deRefWeak leakDetails >>= report "ModDetails"+    forM_ leakLinkable $ \l -> deRefWeak l >>= report "Linkable"+ where+  report :: String -> Maybe a -> IO ()+  report _ Nothing = return ()+  report msg (Just a) = do+    addr <- anyToPtr a+    putStrLn ("-fghci-leak-check: " ++ msg ++ " is still alive at " +++              show (maskTagBits addr))++  tagBits+    | target32Bit (sTargetPlatform (settings dflags)) = 2+    | otherwise = 3++  maskTagBits :: Ptr a -> Ptr a+  maskTagBits p = intPtrToPtr (ptrToIntPtr p .&. complement (shiftL 1 tagBits - 1))
+ ghc/GHCi/UI.hs view
@@ -0,0 +1,4055 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS -fno-cse #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++-----------------------------------------------------------------------------+--+-- GHC Interactive User Interface+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module GHCi.UI (+        interactiveUI,+        GhciSettings(..),+        defaultGhciSettings,+        ghciCommands,+        ghciWelcomeMsg+    ) where++#include "HsVersions.h"++-- GHCi+import qualified GHCi.UI.Monad as GhciMonad ( args, runStmt, runDecls' )+import GHCi.UI.Monad hiding ( args, runStmt )+import GHCi.UI.Tags+import GHCi.UI.Info+import Debugger++-- The GHC interface+import GHCi+import GHCi.RemoteTypes+import GHCi.BreakArray+import DynFlags+import ErrUtils hiding (traceCmd)+import Finder+import GhcMonad ( modifySession )+import qualified GHC+import GHC ( LoadHowMuch(..), Target(..),  TargetId(..), InteractiveImport(..),+             TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,+             GetDocsFailure(..),+             getModuleGraph, handleSourceError )+import HscMain (hscParseDeclsWithLocation, hscParseStmtWithLocation)+import HsImpExp+import HsSyn+import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,+                  setInteractivePrintName, hsc_dflags, msObjFilePath, runInteractiveHsc,+                  hsc_dynLinker )+import Module+import Name+import Packages ( trusted, getPackageDetails, getInstalledPackageDetails,+                  listVisibleModuleNames, pprFlag )+import IfaceSyn ( showToHeader )+import PprTyThing+import PrelNames+import RdrName ( getGRE_NameQualifier_maybes, getRdrName )+import SrcLoc+import qualified Lexer++import StringBuffer+import Outputable hiding ( printForUser, printForUserPartWay )++import DynamicLoading ( initializePlugins )++-- Other random utilities+import BasicTypes hiding ( isTopLevel )+import Config+import Digraph+import Encoding+import FastString+import Linker+import Maybes ( orElse, expectJust )+import NameSet+import Panic hiding ( showException )+import Util+import qualified GHC.LanguageExtensions as LangExt+import Bag (unitBag)++-- Haskell Libraries+import System.Console.Haskeline as Haskeline++import Control.Applicative hiding (empty)+import Control.DeepSeq (deepseq)+import Control.Monad as Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except++import Data.Array+import qualified Data.ByteString.Char8 as BS+import Data.Char+import Data.Function+import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )+import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,+                   partition, sort, sortBy, (\\) )+import qualified Data.Set as S+import Data.Maybe+import Data.Map (Map)+import qualified Data.Map as M+import Data.Time.LocalTime ( getZonedTime )+import Data.Time.Format ( formatTime, defaultTimeLocale )+import Data.Version ( showVersion )+import Prelude hiding ((<>))++import Exception hiding (catch)+import Foreign hiding (void)+import GHC.Stack hiding (SrcLoc(..))++import System.Directory+import System.Environment+import System.Exit ( exitWith, ExitCode(..) )+import System.FilePath+import System.Info+import System.IO+import System.IO.Error+import System.IO.Unsafe ( unsafePerformIO )+import System.Process+import Text.Printf+import Text.Read ( readMaybe )+import Text.Read.Lex (isSymbolChar)++import Unsafe.Coerce++#if !defined(mingw32_HOST_OS)+import System.Posix hiding ( getEnv )+#else+import qualified System.Win32+#endif++import GHC.IO.Exception ( IOErrorType(InvalidArgument) )+import GHC.IO.Handle ( hFlushAll )+import GHC.TopHandler ( topHandler )++import GHCi.Leak++-----------------------------------------------------------------------------++data GhciSettings = GhciSettings {+        availableCommands :: [Command],+        shortHelpText     :: String,+        fullHelpText      :: String,+        defPrompt         :: PromptFunction,+        defPromptCont     :: PromptFunction+    }++defaultGhciSettings :: GhciSettings+defaultGhciSettings =+    GhciSettings {+        availableCommands = ghciCommands,+        shortHelpText     = defShortHelpText,+        defPrompt         = default_prompt,+        defPromptCont     = default_prompt_cont,+        fullHelpText      = defFullHelpText+    }++ghciWelcomeMsg :: String+ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion +++                 ": https://www.haskell.org/ghc/  :? for help"++ghciCommands :: [Command]+ghciCommands = map mkCmd [+  -- Hugs users are accustomed to :e, so make sure it doesn't overlap+  ("?",         keepGoing help,                 noCompletion),+  ("add",       keepGoingPaths addModule,       completeFilename),+  ("abandon",   keepGoing abandonCmd,           noCompletion),+  ("break",     keepGoing breakCmd,             completeIdentifier),+  ("back",      keepGoing backCmd,              noCompletion),+  ("browse",    keepGoing' (browseCmd False),   completeModule),+  ("browse!",   keepGoing' (browseCmd True),    completeModule),+  ("cd",        keepGoing' changeDirectory,     completeFilename),+  ("check",     keepGoing' checkModule,         completeHomeModule),+  ("continue",  keepGoing continueCmd,          noCompletion),+  ("cmd",       keepGoing cmdCmd,               completeExpression),+  ("ctags",     keepGoing createCTagsWithLineNumbersCmd, completeFilename),+  ("ctags!",    keepGoing createCTagsWithRegExesCmd, completeFilename),+  ("def",       keepGoing (defineMacro False),  completeExpression),+  ("def!",      keepGoing (defineMacro True),   completeExpression),+  ("delete",    keepGoing deleteCmd,            noCompletion),+  ("doc",       keepGoing' docCmd,              completeIdentifier),+  ("edit",      keepGoing' editFile,            completeFilename),+  ("etags",     keepGoing createETagsFileCmd,   completeFilename),+  ("force",     keepGoing forceCmd,             completeExpression),+  ("forward",   keepGoing forwardCmd,           noCompletion),+  ("help",      keepGoing help,                 noCompletion),+  ("history",   keepGoing historyCmd,           noCompletion),+  ("info",      keepGoing' (info False),        completeIdentifier),+  ("info!",     keepGoing' (info True),         completeIdentifier),+  ("issafe",    keepGoing' isSafeCmd,           completeModule),+  ("kind",      keepGoing' (kindOfType False),  completeIdentifier),+  ("kind!",     keepGoing' (kindOfType True),   completeIdentifier),+  ("load",      keepGoingPaths loadModule_,     completeHomeModuleOrFile),+  ("load!",     keepGoingPaths loadModuleDefer, completeHomeModuleOrFile),+  ("list",      keepGoing' listCmd,             noCompletion),+  ("module",    keepGoing moduleCmd,            completeSetModule),+  ("main",      keepGoing runMain,              completeFilename),+  ("print",     keepGoing printCmd,             completeExpression),+  ("quit",      quit,                           noCompletion),+  ("reload",    keepGoing' reloadModule,        noCompletion),+  ("reload!",   keepGoing' reloadModuleDefer,   noCompletion),+  ("run",       keepGoing runRun,               completeFilename),+  ("script",    keepGoing' scriptCmd,           completeFilename),+  ("set",       keepGoing setCmd,               completeSetOptions),+  ("seti",      keepGoing setiCmd,              completeSeti),+  ("show",      keepGoing showCmd,              completeShowOptions),+  ("showi",     keepGoing showiCmd,             completeShowiOptions),+  ("sprint",    keepGoing sprintCmd,            completeExpression),+  ("step",      keepGoing stepCmd,              completeIdentifier),+  ("steplocal", keepGoing stepLocalCmd,         completeIdentifier),+  ("stepmodule",keepGoing stepModuleCmd,        completeIdentifier),+  ("type",      keepGoing' typeOfExpr,          completeExpression),+  ("trace",     keepGoing traceCmd,             completeExpression),+  ("unadd",     keepGoingPaths unAddModule,     completeFilename),+  ("undef",     keepGoing undefineMacro,        completeMacro),+  ("unset",     keepGoing unsetOptions,         completeSetOptions),+  ("where",     keepGoing whereCmd,             noCompletion)+  ] ++ map mkCmdHidden [ -- hidden commands+  ("all-types", keepGoing' allTypesCmd),+  ("complete",  keepGoing completeCmd),+  ("loc-at",    keepGoing' locAtCmd),+  ("type-at",   keepGoing' typeAtCmd),+  ("uses",      keepGoing' usesCmd)+  ]+ where+  mkCmd (n,a,c) = Command { cmdName = n+                          , cmdAction = a+                          , cmdHidden = False+                          , cmdCompletionFunc = c+                          }++  mkCmdHidden (n,a) = Command { cmdName = n+                              , cmdAction = a+                              , cmdHidden = True+                              , cmdCompletionFunc = noCompletion+                              }++-- We initialize readline (in the interactiveUI function) to use+-- word_break_chars as the default set of completion word break characters.+-- This can be overridden for a particular command (for example, filename+-- expansion shouldn't consider '/' to be a word break) by setting the third+-- entry in the Command tuple above.+--+-- NOTE: in order for us to override the default correctly, any custom entry+-- must be a SUBSET of word_break_chars.+word_break_chars :: String+word_break_chars = spaces ++ specials ++ symbols++symbols, specials, spaces :: String+symbols = "!#$%&*+/<=>?@\\^|-~"+specials = "(),;[]`{}"+spaces = " \t\n"++flagWordBreakChars :: String+flagWordBreakChars = " \t\n"+++keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)+keepGoing a str = keepGoing' (lift . a) str++keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool+keepGoing' a str = a str >> return False++keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)+keepGoingPaths a str+ = do case toArgs str of+          Left err -> liftIO $ hPutStrLn stderr err+          Right args -> a args+      return False++defShortHelpText :: String+defShortHelpText = "use :? for help.\n"++defFullHelpText :: String+defFullHelpText =+  " Commands available from the prompt:\n" +++  "\n" +++  "   <statement>                 evaluate/run <statement>\n" +++  "   :                           repeat last command\n" +++  "   :{\\n ..lines.. \\n:}\\n       multiline command\n" +++  "   :add [*]<module> ...        add module(s) to the current target set\n" +++  "   :browse[!] [[*]<mod>]       display the names defined by module <mod>\n" +++  "                               (!: more details; *: all top-level names)\n" +++  "   :cd <dir>                   change directory to <dir>\n" +++  "   :cmd <expr>                 run the commands returned by <expr>::IO String\n" +++  "   :complete <dom> [<rng>] <s> list completions for partial input string\n" +++  "   :ctags[!] [<file>]          create tags file <file> for Vi (default: \"tags\")\n" +++  "                               (!: use regex instead of line number)\n" +++  "   :def <cmd> <expr>           define command :<cmd> (later defined command has\n" +++  "                               precedence, ::<cmd> is always a builtin command)\n" +++  "   :doc <name>                 display docs for the given name (experimental)\n" +++  "   :edit <file>                edit file\n" +++  "   :edit                       edit last module\n" +++  "   :etags [<file>]             create tags file <file> for Emacs (default: \"TAGS\")\n" +++  "   :help, :?                   display this list of commands\n" +++  "   :info[!] [<name> ...]       display information about the given names\n" +++  "                               (!: do not filter instances)\n" +++  "   :issafe [<mod>]             display safe haskell information of module <mod>\n" +++  "   :kind[!] <type>             show the kind of <type>\n" +++  "                               (!: also print the normalised type)\n" +++  "   :load[!] [*]<module> ...    load module(s) and their dependents\n" +++  "                               (!: defer type errors)\n" +++  "   :main [<arguments> ...]     run the main function with the given arguments\n" +++  "   :module [+/-] [*]<mod> ...  set the context for expression evaluation\n" +++  "   :quit                       exit GHCi\n" +++  "   :reload[!]                  reload the current module set\n" +++  "                               (!: defer type errors)\n" +++  "   :run function [<arguments> ...] run the function with the given arguments\n" +++  "   :script <file>              run the script <file>\n" +++  "   :type <expr>                show the type of <expr>\n" +++  "   :type +d <expr>             show the type of <expr>, defaulting type variables\n" +++  "   :type +v <expr>             show the type of <expr>, with its specified tyvars\n" +++  "   :unadd <module> ...         remove module(s) from the current target set\n" +++  "   :undef <cmd>                undefine user-defined command :<cmd>\n" +++  "   :!<command>                 run the shell command <command>\n" +++  "\n" +++  " -- Commands for debugging:\n" +++  "\n" +++  "   :abandon                    at a breakpoint, abandon current computation\n" +++  "   :back [<n>]                 go back in the history N steps (after :trace)\n" +++  "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" +++  "   :break <name>               set a breakpoint on the specified function\n" +++  "   :continue                   resume after a breakpoint\n" +++  "   :delete <number>            delete the specified breakpoint\n" +++  "   :delete *                   delete all breakpoints\n" +++  "   :force <expr>               print <expr>, forcing unevaluated parts\n" +++  "   :forward [<n>]              go forward in the history N step s(after :back)\n" +++  "   :history [<n>]              after :trace, show the execution history\n" +++  "   :list                       show the source code around current breakpoint\n" +++  "   :list <identifier>          show the source code for <identifier>\n" +++  "   :list [<module>] <line>     show the source code around line number <line>\n" +++  "   :print [<name> ...]         show a value without forcing its computation\n" +++  "   :sprint [<name> ...]        simplified version of :print\n" +++  "   :step                       single-step after stopping at a breakpoint\n"+++  "   :step <expr>                single-step into <expr>\n"+++  "   :steplocal                  single-step within the current top-level binding\n"+++  "   :stepmodule                 single-step restricted to the current module\n"+++  "   :trace                      trace after stopping at a breakpoint\n"+++  "   :trace <expr>               evaluate <expr> with tracing on (see :history)\n"++++  "\n" +++  " -- Commands for changing settings:\n" +++  "\n" +++  "   :set <option> ...           set options\n" +++  "   :seti <option> ...          set options for interactive evaluation only\n" +++  "   :set local-config { source | ignore }\n" +++  "                               set whether to source .ghci in current dir\n" +++  "                               (loading untrusted config is a security issue)\n" +++  "   :set args <arg> ...         set the arguments returned by System.getArgs\n" +++  "   :set prog <progname>        set the value returned by System.getProgName\n" +++  "   :set prompt <prompt>        set the prompt used in GHCi\n" +++  "   :set prompt-cont <prompt>   set the continuation prompt used in GHCi\n" +++  "   :set prompt-function <expr> set the function to handle the prompt\n" +++  "   :set prompt-cont-function <expr>\n" +++  "                               set the function to handle the continuation prompt\n" +++  "   :set editor <cmd>           set the command used for :edit\n" +++  "   :set stop [<n>] <cmd>       set the command to run when a breakpoint is hit\n" +++  "   :unset <option> ...         unset options\n" +++  "\n" +++  "  Options for ':set' and ':unset':\n" +++  "\n" +++  "    +m            allow multiline commands\n" +++  "    +r            revert top-level expressions after each evaluation\n" +++  "    +s            print timing/memory stats after each evaluation\n" +++  "    +t            print type after evaluation\n" +++  "    +c            collect type/location info after loading modules\n" +++  "    -<flags>      most GHC command line flags can also be set here\n" +++  "                         (eg. -v2, -XFlexibleInstances, etc.)\n" +++  "                    for GHCi-specific flags, see User's Guide,\n"+++  "                    Flag reference, Interactive-mode options\n" +++  "\n" +++  " -- Commands for displaying information:\n" +++  "\n" +++  "   :show bindings              show the current bindings made at the prompt\n" +++  "   :show breaks                show the active breakpoints\n" +++  "   :show context               show the breakpoint context\n" +++  "   :show imports               show the current imports\n" +++  "   :show linker                show current linker state\n" +++  "   :show modules               show the currently loaded modules\n" +++  "   :show packages              show the currently active package flags\n" +++  "   :show paths                 show the currently active search paths\n" +++  "   :show language              show the currently active language flags\n" +++  "   :show targets               show the current set of targets\n" +++  "   :show <setting>             show value of <setting>, which is one of\n" +++  "                                  [args, prog, editor, stop]\n" +++  "   :showi language             show language flags for interactive evaluation\n" +++  "\n"++findEditor :: IO String+findEditor = do+  getEnv "EDITOR"+    `catchIO` \_ -> do+#if defined(mingw32_HOST_OS)+        win <- System.Win32.getWindowsDirectory+        return (win </> "notepad.exe")+#else+        return ""+#endif++default_progname, default_stop :: String+default_progname = "<interactive>"+default_stop = ""++default_prompt, default_prompt_cont :: PromptFunction+default_prompt = generatePromptFunctionFromString "%s> "+default_prompt_cont = generatePromptFunctionFromString "%s| "++default_args :: [String]+default_args = []++interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]+              -> Ghc ()+interactiveUI config srcs maybe_exprs = do+   -- HACK! If we happen to get into an infinite loop (eg the user+   -- types 'let x=x in x' at the prompt), then the thread will block+   -- on a blackhole, and become unreachable during GC.  The GC will+   -- detect that it is unreachable and send it the NonTermination+   -- exception.  However, since the thread is unreachable, everything+   -- it refers to might be finalized, including the standard Handles.+   -- This sounds like a bug, but we don't have a good solution right+   -- now.+   _ <- liftIO $ newStablePtr stdin+   _ <- liftIO $ newStablePtr stdout+   _ <- liftIO $ newStablePtr stderr++    -- Initialise buffering for the *interpreted* I/O system+   (nobuffering, flush) <- initInterpBuffering++   -- The initial set of DynFlags used for interactive evaluation is the same+   -- as the global DynFlags, plus -XExtendedDefaultRules and+   -- -XNoMonomorphismRestriction.+   -- See note [Changing language extensions for interactive evaluation] #10857+   dflags <- getDynFlags+   let dflags' = (xopt_set_unlessExplSpec+                      LangExt.ExtendedDefaultRules xopt_set)+               . (xopt_set_unlessExplSpec+                      LangExt.MonomorphismRestriction xopt_unset)+               $ dflags+   GHC.setInteractiveDynFlags dflags'++   lastErrLocationsRef <- liftIO $ newIORef []+   progDynFlags <- GHC.getProgramDynFlags+   _ <- GHC.setProgramDynFlags $+      -- Ensure we don't override the user's log action lest we break+      -- -ddump-json (#14078)+      progDynFlags { log_action = ghciLogAction (log_action progDynFlags)+                                                lastErrLocationsRef }++   when (isNothing maybe_exprs) $ do+        -- Only for GHCi (not runghc and ghc -e):++        -- Turn buffering off for the compiled program's stdout/stderr+        turnOffBuffering_ nobuffering+        -- Turn buffering off for GHCi's stdout+        liftIO $ hFlush stdout+        liftIO $ hSetBuffering stdout NoBuffering+        -- We don't want the cmd line to buffer any input that might be+        -- intended for the program, so unbuffer stdin.+        liftIO $ hSetBuffering stdin NoBuffering+        liftIO $ hSetBuffering stderr NoBuffering+#if defined(mingw32_HOST_OS)+        -- On Unix, stdin will use the locale encoding.  The IO library+        -- doesn't do this on Windows (yet), so for now we use UTF-8,+        -- for consistency with GHC 6.10 and to make the tests work.+        liftIO $ hSetEncoding stdin utf8+#endif++   default_editor <- liftIO $ findEditor+   eval_wrapper <- mkEvalWrapper default_progname default_args+   let prelude_import = simpleImportDecl preludeModuleName+   startGHCi (runGHCi srcs maybe_exprs)+        GHCiState{ progname           = default_progname,+                   args               = default_args,+                   evalWrapper        = eval_wrapper,+                   prompt             = defPrompt config,+                   prompt_cont        = defPromptCont config,+                   stop               = default_stop,+                   editor             = default_editor,+                   options            = [],+                   localConfig        = SourceLocalConfig,+                   -- We initialize line number as 0, not 1, because we use+                   -- current line number while reporting errors which is+                   -- incremented after reading a line.+                   line_number        = 0,+                   break_ctr          = 0,+                   breaks             = [],+                   tickarrays         = emptyModuleEnv,+                   ghci_commands      = availableCommands config,+                   ghci_macros        = [],+                   last_command       = Nothing,+                   cmd_wrapper        = (cmdSuccess =<<),+                   cmdqueue           = [],+                   remembered_ctx     = [],+                   transient_ctx      = [],+                   extra_imports      = [],+                   prelude_imports    = [prelude_import],+                   ghc_e              = isJust maybe_exprs,+                   short_help         = shortHelpText config,+                   long_help          = fullHelpText config,+                   lastErrorLocations = lastErrLocationsRef,+                   mod_infos          = M.empty,+                   flushStdHandles    = flush,+                   noBuffering        = nobuffering+                 }++   return ()++{-+Note [Changing language extensions for interactive evaluation]+--------------------------------------------------------------+GHCi maintains two sets of options:++- The "loading options" apply when loading modules+- The "interactive options" apply when evaluating expressions and commands+    typed at the GHCi prompt.++The loading options are mostly created in ghc/Main.hs:main' from the command+line flags. In the function ghc/GHCi/UI.hs:interactiveUI the loading options+are copied to the interactive options.++These interactive options (but not the loading options!) are supplemented+unconditionally by setting ExtendedDefaultRules ON and+MonomorphismRestriction OFF. The unconditional setting of these options+eventually overwrite settings already specified at the command line.++Therefore instead of unconditionally setting ExtendedDefaultRules and+NoMonomorphismRestriction for the interactive options, we use the function+'xopt_set_unlessExplSpec' to first check whether the extension has already+specified at the command line.++The ghci config file has not yet been processed.+-}++resetLastErrorLocations :: GhciMonad m => m ()+resetLastErrorLocations = do+    st <- getGHCiState+    liftIO $ writeIORef (lastErrorLocations st) []++ghciLogAction :: LogAction -> IORef [(FastString, Int)] ->  LogAction+ghciLogAction old_log_action lastErrLocations+              dflags flag severity srcSpan style msg = do+    old_log_action dflags flag severity srcSpan style msg+    case severity of+        SevError -> case srcSpan of+            RealSrcSpan rsp -> modifyIORef lastErrLocations+                (++ [(srcLocFile (realSrcSpanStart rsp), srcLocLine (realSrcSpanStart rsp))])+            _ -> return ()+        _ -> return ()++withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a+withGhcAppData right left = do+    either_dir <- tryIO (getAppUserDataDirectory "ghc")+    case either_dir of+        Right dir ->+            do createDirectoryIfMissing False dir `catchIO` \_ -> return ()+               right dir+        _ -> left++runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()+runGHCi paths maybe_exprs = do+  dflags <- getDynFlags+  let+   ignore_dot_ghci = gopt Opt_IgnoreDotGhci dflags++   app_user_dir = liftIO $ withGhcAppData+                    (\dir -> return (Just (dir </> "ghci.conf")))+                    (return Nothing)++   home_dir = do+    either_dir <- liftIO $ tryIO (getEnv "HOME")+    case either_dir of+      Right home -> return (Just (home </> ".ghci"))+      _ -> return Nothing++   canonicalizePath' :: FilePath -> IO (Maybe FilePath)+   canonicalizePath' fp = liftM Just (canonicalizePath fp)+                `catchIO` \_ -> return Nothing++   sourceConfigFile :: FilePath -> GHCi ()+   sourceConfigFile file = do+     exists <- liftIO $ doesFileExist file+     when exists $ do+       either_hdl <- liftIO $ tryIO (openFile file ReadMode)+       case either_hdl of+         Left _e   -> return ()+         -- NOTE: this assumes that runInputT won't affect the terminal;+         -- can we assume this will always be the case?+         -- This would be a good place for runFileInputT.+         Right hdl ->+             do runInputTWithPrefs defaultPrefs defaultSettings $+                          runCommands $ fileLoop hdl+                liftIO (hClose hdl `catchIO` \_ -> return ())+                -- Don't print a message if this is really ghc -e (#11478).+                -- Also, let the user silence the message with -v0+                -- (the default verbosity in GHCi is 1).+                when (isNothing maybe_exprs && verbosity dflags > 0) $+                  liftIO $ putStrLn ("Loaded GHCi configuration from " ++ file)++  --++  setGHCContextFromGHCiState++  processedCfgs <- if ignore_dot_ghci+    then pure []+    else do+      userCfgs <- do+        paths <- catMaybes <$> sequence [ app_user_dir, home_dir ]+        checkedPaths <- liftIO $ filterM checkFileAndDirPerms paths+        liftIO . fmap (nub . catMaybes) $ mapM canonicalizePath' checkedPaths++      localCfg <- do+        let path = ".ghci"+        ok <- liftIO $ checkFileAndDirPerms path+        if ok then liftIO $ canonicalizePath' path else pure Nothing++      mapM_ sourceConfigFile userCfgs+        -- Process the global and user .ghci+        -- (but not $CWD/.ghci or CLI args, yet)++      behaviour <- localConfig <$> getGHCiState++      processedLocalCfg <- case localCfg of+        Just path | path `notElem` userCfgs ->+          -- don't read .ghci twice if CWD is $HOME+          case behaviour of+            SourceLocalConfig -> localCfg <$ sourceConfigFile path+            IgnoreLocalConfig -> pure Nothing+        _ -> pure Nothing++      pure $ maybe id (:) processedLocalCfg userCfgs++  let arg_cfgs = reverse $ ghciScripts dflags+    -- -ghci-script are collected in reverse order+    -- We don't require that a script explicitly added by -ghci-script+    -- is owned by the current user. (#6017)++  mapM_ sourceConfigFile $ nub arg_cfgs \\ processedCfgs+    -- Dedup, and remove any configs we already processed.+    -- Importantly, if $PWD/.ghci was ignored due to configuration,+    -- explicitly specifying it does cause it to be processed.++  -- Perform a :load for files given on the GHCi command line+  -- When in -e mode, if the load fails then we want to stop+  -- immediately rather than going on to evaluate the expression.+  when (not (null paths)) $ do+     ok <- ghciHandle (\e -> do showException e; return Failed) $+                -- TODO: this is a hack.+                runInputTWithPrefs defaultPrefs defaultSettings $+                    loadModule paths+     when (isJust maybe_exprs && failed ok) $+        liftIO (exitWith (ExitFailure 1))++  installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)++  -- if verbosity is greater than 0, or we are connected to a+  -- terminal, display the prompt in the interactive loop.+  is_tty <- liftIO (hIsTerminalDevice stdin)+  let show_prompt = verbosity dflags > 0 || is_tty++  -- reset line number+  modifyGHCiState $ \st -> st{line_number=0}++  case maybe_exprs of+        Nothing ->+          do+            -- enter the interactive loop+            runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty+        Just exprs -> do+            -- just evaluate the expression we were given+            enqueueCommands exprs+            let hdle e = do st <- getGHCiState+                            -- flush the interpreter's stdout/stderr on exit (#3890)+                            flushInterpBuffers+                            -- Jump through some hoops to get the+                            -- current progname in the exception text:+                            -- <progname>: <exception>+                            liftIO $ withProgName (progname st)+                                   $ topHandler e+                                   -- this used to be topHandlerFastExit, see #2228+            runInputTWithPrefs defaultPrefs defaultSettings $ do+                -- make `ghc -e` exit nonzero on invalid input, see #7962+                _ <- runCommands' hdle+                     (Just $ hdle (toException $ ExitFailure 1) >> return ())+                     (return Nothing)+                return ()++  -- and finally, exit+  liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."++runGHCiInput :: InputT GHCi a -> GHCi a+runGHCiInput f = do+    dflags <- getDynFlags+    let ghciHistory = gopt Opt_GhciHistory dflags+    let localGhciHistory = gopt Opt_LocalGhciHistory dflags+    currentDirectory <- liftIO $ getCurrentDirectory++    histFile <- case (ghciHistory, localGhciHistory) of+      (True, True) -> return (Just (currentDirectory </> ".ghci_history"))+      (True, _) -> liftIO $ withGhcAppData+        (\dir -> return (Just (dir </> "ghci_history"))) (return Nothing)+      _ -> return Nothing++    runInputT+        (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})+        f++-- | How to get the next input line from the user+nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)+nextInputLine show_prompt is_tty+  | is_tty = do+    prmpt <- if show_prompt then lift mkPrompt else return ""+    r <- getInputLine prmpt+    incrementLineNo+    return r+  | otherwise = do+    when show_prompt $ lift mkPrompt >>= liftIO . putStr+    fileLoop stdin++-- NOTE: We only read .ghci files if they are owned by the current user,+-- and aren't world writable (files owned by root are ok, see #9324).+-- Otherwise, we could be accidentally running code planted by+-- a malicious third party.++-- Furthermore, We only read ./.ghci if . is owned by the current user+-- and isn't writable by anyone else.  I think this is sufficient: we+-- don't need to check .. and ../.. etc. because "."  always refers to+-- the same directory while a process is running.++checkFileAndDirPerms :: FilePath -> IO Bool+checkFileAndDirPerms file = do+  file_ok <- checkPerms file+  -- Do not check dir perms when .ghci doesn't exist, otherwise GHCi will+  -- print some confusing and useless warnings in some cases (e.g. in+  -- travis). Note that we can't add a test for this, as all ghci tests should+  -- run with -ignore-dot-ghci, which means we never get here.+  if file_ok then checkPerms (getDirectory file) else return False+  where+  getDirectory f = case takeDirectory f of+    "" -> "."+    d -> d++checkPerms :: FilePath -> IO Bool+#if defined(mingw32_HOST_OS)+checkPerms _ = return True+#else+checkPerms file =+  handleIO (\_ -> return False) $ do+    st <- getFileStatus file+    me <- getRealUserID+    let mode = System.Posix.fileMode st+        ok = (fileOwner st == me || fileOwner st == 0) &&+             groupWriteMode /= mode `intersectFileModes` groupWriteMode &&+             otherWriteMode /= mode `intersectFileModes` otherWriteMode+    unless ok $+      -- #8248: Improving warning to include a possible fix.+      putStrLn $ "*** WARNING: " ++ file +++                 " is writable by someone else, IGNORING!" +++                 "\nSuggested fix: execute 'chmod go-w " ++ file ++ "'"+    return ok+#endif++incrementLineNo :: GhciMonad m => m ()+incrementLineNo = modifyGHCiState incLineNo+  where+    incLineNo st = st { line_number = line_number st + 1 }++fileLoop :: GhciMonad m => Handle -> m (Maybe String)+fileLoop hdl = do+   l <- liftIO $ tryIO $ hGetLine hdl+   case l of+        Left e | isEOFError e              -> return Nothing+               | -- as we share stdin with the program, the program+                 -- might have already closed it, so we might get a+                 -- handle-closed exception. We therefore catch that+                 -- too.+                 isIllegalOperation e      -> return Nothing+               | InvalidArgument <- etype  -> return Nothing+               | otherwise                 -> liftIO $ ioError e+                where etype = ioeGetErrorType e+                -- treat InvalidArgument in the same way as EOF:+                -- this can happen if the user closed stdin, or+                -- perhaps did getContents which closes stdin at+                -- EOF.+        Right l' -> do+           incrementLineNo+           return (Just l')++formatCurrentTime :: String -> IO String+formatCurrentTime format =+  getZonedTime >>= return . (formatTime defaultTimeLocale format)++getUserName :: IO String+getUserName = do+#if defined(mingw32_HOST_OS)+  getEnv "USERNAME"+    `catchIO` \e -> do+      putStrLn $ show e+      return ""+#else+  getLoginName+#endif++getInfoForPrompt :: GhciMonad m => m (SDoc, [String], Int)+getInfoForPrompt = do+  st <- getGHCiState+  imports <- GHC.getContext+  resumes <- GHC.getResumeContext++  context_bit <-+        case resumes of+            [] -> return empty+            r:_ -> do+                let ix = GHC.resumeHistoryIx r+                if ix == 0+                   then return (brackets (ppr (GHC.resumeSpan r)) <> space)+                   else do+                        let hist = GHC.resumeHistory r !! (ix-1)+                        pan <- GHC.getHistorySpan hist+                        return (brackets (ppr (negate ix) <> char ':'+                                          <+> ppr pan) <> space)++  let+        dots | _:rs <- resumes, not (null rs) = text "... "+             | otherwise = empty++        rev_imports = reverse imports -- rightmost are the most recent++        myIdeclName d | Just m <- ideclAs d = unLoc m+                      | otherwise           = unLoc (ideclName d)++        modules_names =+             ['*':(moduleNameString m) | IIModule m <- rev_imports] +++             [moduleNameString (myIdeclName d) | IIDecl d <- rev_imports]+        line = 1 + line_number st++  return (dots <> context_bit, modules_names, line)++parseCallEscape :: String -> (String, String)+parseCallEscape s+  | not (all isSpace beforeOpen) = ("", "")+  | null sinceOpen               = ("", "")+  | null sinceClosed             = ("", "")+  | null cmd                     = ("", "")+  | otherwise                    = (cmd, tail sinceClosed)+  where+    (beforeOpen, sinceOpen) = span (/='(') s+    (cmd, sinceClosed) = span (/=')') (tail sinceOpen)++checkPromptStringForErrors :: String -> Maybe String+checkPromptStringForErrors ('%':'c':'a':'l':'l':xs) =+  case parseCallEscape xs of+    ("", "") -> Just ("Incorrect %call syntax. " +++                      "Should be %call(a command and arguments).")+    (_, afterClosed) -> checkPromptStringForErrors afterClosed+checkPromptStringForErrors ('%':'%':xs) = checkPromptStringForErrors xs+checkPromptStringForErrors (_:xs) = checkPromptStringForErrors xs+checkPromptStringForErrors "" = Nothing++generatePromptFunctionFromString :: String -> PromptFunction+generatePromptFunctionFromString promptS modules_names line =+        processString promptS+  where+        processString :: String -> GHCi SDoc+        processString ('%':'s':xs) =+            liftM2 (<>) (return modules_list) (processString xs)+            where+              modules_list = hsep $ map text modules_names+        processString ('%':'l':xs) =+            liftM2 (<>) (return $ ppr line) (processString xs)+        processString ('%':'d':xs) =+            liftM2 (<>) (liftM text formatted_time) (processString xs)+            where+              formatted_time = liftIO $ formatCurrentTime "%a %b %d"+        processString ('%':'t':xs) =+            liftM2 (<>) (liftM text formatted_time) (processString xs)+            where+              formatted_time = liftIO $ formatCurrentTime "%H:%M:%S"+        processString ('%':'T':xs) = do+            liftM2 (<>) (liftM text formatted_time) (processString xs)+            where+              formatted_time = liftIO $ formatCurrentTime "%I:%M:%S"+        processString ('%':'@':xs) = do+            liftM2 (<>) (liftM text formatted_time) (processString xs)+            where+              formatted_time = liftIO $ formatCurrentTime "%I:%M %P"+        processString ('%':'A':xs) = do+            liftM2 (<>) (liftM text formatted_time) (processString xs)+            where+              formatted_time = liftIO $ formatCurrentTime "%H:%M"+        processString ('%':'u':xs) =+            liftM2 (<>) (liftM text user_name) (processString xs)+            where+              user_name = liftIO $ getUserName+        processString ('%':'w':xs) =+            liftM2 (<>) (liftM text current_directory) (processString xs)+            where+              current_directory = liftIO $ getCurrentDirectory+        processString ('%':'o':xs) =+            liftM ((text os) <>) (processString xs)+        processString ('%':'a':xs) =+            liftM ((text arch) <>) (processString xs)+        processString ('%':'N':xs) =+            liftM ((text compilerName) <>) (processString xs)+        processString ('%':'V':xs) =+            liftM ((text $ showVersion compilerVersion) <>) (processString xs)+        processString ('%':'c':'a':'l':'l':xs) = do+            respond <- liftIO $ do+                (code, out, err) <-+                    readProcessWithExitCode+                    (head list_words) (tail list_words) ""+                    `catchIO` \e -> return (ExitFailure 1, "", show e)+                case code of+                    ExitSuccess -> return out+                    _ -> do+                        hPutStrLn stderr err+                        return ""+            liftM ((text respond) <>) (processString afterClosed)+            where+              (cmd, afterClosed) = parseCallEscape xs+              list_words = words cmd+        processString ('%':'%':xs) =+            liftM ((char '%') <>) (processString xs)+        processString (x:xs) =+            liftM (char x <>) (processString xs)+        processString "" =+            return empty++mkPrompt :: GHCi String+mkPrompt = do+  st <- getGHCiState+  dflags <- getDynFlags+  (context, modules_names, line) <- getInfoForPrompt++  prompt_string <- (prompt st) modules_names line+  let prompt_doc = context <> prompt_string++  return (showSDoc dflags prompt_doc)++queryQueue :: GhciMonad m => m (Maybe String)+queryQueue = do+  st <- getGHCiState+  case cmdqueue st of+    []   -> return Nothing+    c:cs -> do setGHCiState st{ cmdqueue = cs }+               return (Just c)++-- Reconfigurable pretty-printing Ticket #5461+installInteractivePrint :: GHC.GhcMonad m => Maybe String -> Bool -> m ()+installInteractivePrint Nothing _  = return ()+installInteractivePrint (Just ipFun) exprmode = do+  ok <- trySuccess $ do+                names <- GHC.parseName ipFun+                let name = case names of+                             name':_ -> name'+                             [] -> panic "installInteractivePrint"+                modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name+                                      in he{hsc_IC = new_ic})+                return Succeeded++  when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))++-- | The main read-eval-print loop+runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()+runCommands gCmd = runCommands' handler Nothing gCmd >> return ()++runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler+             -> Maybe (GHCi ()) -- ^ Source error handler+             -> InputT GHCi (Maybe String)+             -> InputT GHCi (Maybe Bool)+         -- We want to return () here, but have to return (Maybe Bool)+         -- because gmask is not polymorphic enough: we want to use+         -- unmask at two different types.+runCommands' eh sourceErrorHandler gCmd = gmask $ \unmask -> do+    b <- ghandle (\e -> case fromException e of+                          Just UserInterrupt -> return $ Just False+                          _ -> case fromException e of+                                 Just ghce ->+                                   do liftIO (print (ghce :: GhcException))+                                      return Nothing+                                 _other ->+                                   liftIO (Exception.throwIO e))+            (unmask $ runOneCommand eh gCmd)+    case b of+      Nothing -> return Nothing+      Just success -> do+        unless success $ maybe (return ()) lift sourceErrorHandler+        unmask $ runCommands' eh sourceErrorHandler gCmd++-- | Evaluate a single line of user input (either :<command> or Haskell code).+-- A result of Nothing means there was no more input to process.+-- Otherwise the result is Just b where b is True if the command succeeded;+-- this is relevant only to ghc -e, which will exit with status 1+-- if the command was unsuccessful. GHCi will continue in either case.+runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)+            -> InputT GHCi (Maybe Bool)+runOneCommand eh gCmd = do+  -- run a previously queued command if there is one, otherwise get new+  -- input from user+  mb_cmd0 <- noSpace (lift queryQueue)+  mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0+  case mb_cmd1 of+    Nothing -> return Nothing+    Just c  -> do+      st <- getGHCiState+      ghciHandle (\e -> lift $ eh e >>= return . Just) $+        handleSourceError printErrorAndFail $+          cmd_wrapper st $ doCommand c+               -- source error's are handled by runStmt+               -- is the handler necessary here?+  where+    printErrorAndFail err = do+        GHC.printException err+        return $ Just False     -- Exit ghc -e, but not GHCi++    noSpace q = q >>= maybe (return Nothing)+                            (\c -> case removeSpaces c of+                                     ""   -> noSpace q+                                     ":{" -> multiLineCmd q+                                     _    -> return (Just c) )+    multiLineCmd q = do+      st <- getGHCiState+      let p = prompt st+      setGHCiState st{ prompt = prompt_cont st }+      mb_cmd <- collectCommand q "" `GHC.gfinally`+                modifyGHCiState (\st' -> st' { prompt = p })+      return mb_cmd+    -- we can't use removeSpaces for the sublines here, so+    -- multiline commands are somewhat more brittle against+    -- fileformat errors (such as \r in dos input on unix),+    -- we get rid of any extra spaces for the ":}" test;+    -- we also avoid silent failure if ":}" is not found;+    -- and since there is no (?) valid occurrence of \r (as+    -- opposed to its String representation, "\r") inside a+    -- ghci command, we replace any such with ' ' (argh:-(+    collectCommand q c = q >>=+      maybe (liftIO (ioError collectError))+            (\l->if removeSpaces l == ":}"+                 then return (Just c)+                 else collectCommand q (c ++ "\n" ++ map normSpace l))+      where normSpace '\r' = ' '+            normSpace   x  = x+    -- SDM (2007-11-07): is userError the one to use here?+    collectError = userError "unterminated multiline command :{ .. :}"++    -- | Handle a line of input+    doCommand :: String -> InputT GHCi CommandResult++    -- command+    doCommand stmt | stmt'@(':' : cmd) <- removeSpaces stmt = do+      (stats, result) <- runWithStats (const Nothing) $ specialCommand cmd+      let processResult True = Nothing+          processResult False = Just True+      return $ CommandComplete stmt' (processResult <$> result) stats++    -- haskell+    doCommand stmt = do+      -- if 'stmt' was entered via ':{' it will contain '\n's+      let stmt_nl_cnt = length [ () | '\n' <- stmt ]+      ml <- lift $ isOptionSet Multiline+      if ml && stmt_nl_cnt == 0 -- don't trigger automatic multi-line mode for ':{'-multiline input+        then do+          fst_line_num <- line_number <$> getGHCiState+          mb_stmt <- checkInputForLayout stmt gCmd+          case mb_stmt of+            Nothing -> return CommandIncomplete+            Just ml_stmt -> do+              -- temporarily compensate line-number for multi-line input+              (stats, result) <- runAndPrintStats runAllocs $ lift $+                runStmtWithLineNum fst_line_num ml_stmt GHC.RunToCompletion+              return $+                CommandComplete ml_stmt (Just . runSuccess <$> result) stats+        else do -- single line input and :{ - multiline input+          last_line_num <- line_number <$> getGHCiState+          -- reconstruct first line num from last line num and stmt+          let fst_line_num | stmt_nl_cnt > 0 = last_line_num - (stmt_nl_cnt2 + 1)+                           | otherwise = last_line_num -- single line input+              stmt_nl_cnt2 = length [ () | '\n' <- stmt' ]+              stmt' = dropLeadingWhiteLines stmt -- runStmt doesn't like leading empty lines+          -- temporarily compensate line-number for multi-line input+          (stats, result) <- runAndPrintStats runAllocs $ lift $+            runStmtWithLineNum fst_line_num stmt' GHC.RunToCompletion+          return $ CommandComplete stmt' (Just . runSuccess <$> result) stats++    -- runStmt wrapper for temporarily overridden line-number+    runStmtWithLineNum :: Int -> String -> SingleStep+                       -> GHCi (Maybe GHC.ExecResult)+    runStmtWithLineNum lnum stmt step = do+        st0 <- getGHCiState+        setGHCiState st0 { line_number = lnum }+        result <- runStmt stmt step+        -- restore original line_number+        getGHCiState >>= \st -> setGHCiState st { line_number = line_number st0 }+        return result++    -- note: this is subtly different from 'unlines . dropWhile (all isSpace) . lines'+    dropLeadingWhiteLines s | (l0,'\n':r) <- break (=='\n') s+                            , all isSpace l0 = dropLeadingWhiteLines r+                            | otherwise = s+++-- #4316+-- lex the input.  If there is an unclosed layout context, request input+checkInputForLayout+  :: GhciMonad m => String -> m (Maybe String) -> m (Maybe String)+checkInputForLayout stmt getStmt = do+   dflags' <- getDynFlags+   let dflags = xopt_set dflags' LangExt.AlternativeLayoutRule+   st0 <- getGHCiState+   let buf'   =  stringToStringBuffer stmt+       loc    = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1+       pstate = Lexer.mkPState dflags buf' loc+   case Lexer.unP goToEnd pstate of+     (Lexer.POk _ False) -> return $ Just stmt+     _other              -> do+       st1 <- getGHCiState+       let p = prompt st1+       setGHCiState st1{ prompt = prompt_cont st1 }+       mb_stmt <- ghciHandle (\ex -> case fromException ex of+                            Just UserInterrupt -> return Nothing+                            _ -> case fromException ex of+                                 Just ghce ->+                                   do liftIO (print (ghce :: GhcException))+                                      return Nothing+                                 _other -> liftIO (Exception.throwIO ex))+                     getStmt+       modifyGHCiState (\st' -> st' { prompt = p })+       -- the recursive call does not recycle parser state+       -- as we use a new string buffer+       case mb_stmt of+         Nothing  -> return Nothing+         Just str -> if str == ""+           then return $ Just stmt+           else do+             checkInputForLayout (stmt++"\n"++str) getStmt+     where goToEnd = do+             eof <- Lexer.nextIsEOF+             if eof+               then Lexer.activeContext+               else Lexer.lexer False return >> goToEnd++enqueueCommands :: GhciMonad m => [String] -> m ()+enqueueCommands cmds = do+  -- make sure we force any exceptions in the commands while we're+  -- still inside the exception handler, otherwise bad things will+  -- happen (see #10501)+  cmds `deepseq` return ()+  modifyGHCiState $ \st -> st{ cmdqueue = cmds ++ cmdqueue st }++-- | Entry point to execute some haskell code from user.+-- The return value True indicates success, as in `runOneCommand`.+runStmt :: GhciMonad m => String -> SingleStep -> m (Maybe GHC.ExecResult)+runStmt input step = do+  dflags <- GHC.getInteractiveDynFlags+  -- In GHCi, we disable `-fdefer-type-errors`, as well as `-fdefer-type-holes`+  -- and `-fdefer-out-of-scope-variables` for **naked expressions**. The+  -- declarations and statements are not affected.+  -- See Note [Deferred type errors in GHCi] in typecheck/TcRnDriver.hs+  st <- getGHCiState+  let source = progname st+  let line = line_number st++  if | GHC.isStmt dflags input -> do+         hsc_env <- GHC.getSession+         mb_stmt <- liftIO (runInteractiveHsc hsc_env (hscParseStmtWithLocation source line input))+         case mb_stmt of+           Nothing ->+             -- empty statement / comment+             return (Just exec_complete)+           Just stmt ->+             run_stmt stmt++     | GHC.isImport dflags input -> run_import++     -- Every import declaration should be handled by `run_import`. As GHCi+     -- in general only accepts one command at a time, we simply throw an+     -- exception when the input contains multiple commands of which at least+     -- one is an import command (see #10663).+     | GHC.hasImport dflags input -> throwGhcException+       (CmdLineError "error: expecting a single import declaration")++     -- Otherwise assume a declaration (or a list of declarations)+     -- Note: `GHC.isDecl` returns False on input like+     -- `data Infix a b = a :@: b; infixl 4 :@:`+     -- and should therefore not be used here.+     | otherwise -> do+         hsc_env <- GHC.getSession+         decls <- liftIO (hscParseDeclsWithLocation hsc_env source line input)+         run_decls decls+  where+    exec_complete = GHC.ExecComplete (Right []) 0++    run_import = do+      addImportToContext input+      return (Just exec_complete)++    run_stmt :: GhciMonad m => GhciLStmt GhcPs -> m (Maybe GHC.ExecResult)+    run_stmt stmt = do+           m_result <- GhciMonad.runStmt stmt input step+           case m_result of+               Nothing     -> return Nothing+               Just result -> Just <$> afterRunStmt (const True) result++    -- `x = y` (a declaration) should be treated as `let x = y` (a statement).+    -- The reason is because GHCi wasn't designed to support `x = y`, but then+    -- b98ff3 (#7253) added support for it, except it did not do a good job and+    -- caused problems like:+    --+    --  - not adding the binders defined this way in the necessary places caused+    --    `x = y` to not work in some cases (#12091).+    --  - some GHCi command crashed after `x = y` (#15721)+    --  - warning generation did not work for `x = y` (#11606)+    --  - because `x = y` is a declaration (instead of a statement) differences+    --    in generated code caused confusion (#16089)+    --+    -- Instead of dealing with all these problems individually here we fix this+    -- mess by just treating `x = y` as `let x = y`.+    run_decls :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe GHC.ExecResult)+    -- Only turn `FunBind` and `VarBind` into statements, other bindings+    -- (e.g. `PatBind`) need to stay as decls.+    run_decls [L l (ValD _ bind@FunBind{})] = run_stmt (mk_stmt l bind)+    run_decls [L l (ValD _ bind@VarBind{})] = run_stmt (mk_stmt l bind)+    -- Note that any `x = y` declarations below will be run as declarations+    -- instead of statements (e.g. `...; x = y; ...`)+    run_decls decls = do+      -- In the new IO library, read handles buffer data even if the Handle+      -- is set to NoBuffering.  This causes problems for GHCi where there+      -- are really two stdin Handles.  So we flush any bufferred data in+      -- GHCi's stdin Handle here (only relevant if stdin is attached to+      -- a file, otherwise the read buffer can't be flushed).+      _ <- liftIO $ tryIO $ hFlushAll stdin+      m_result <- GhciMonad.runDecls' decls+      forM m_result $ \result ->+        afterRunStmt (const True) (GHC.ExecComplete (Right result) 0)++    mk_stmt :: SrcSpan -> HsBind GhcPs -> GhciLStmt GhcPs+    mk_stmt loc bind =+      let l = L loc+      in l (LetStmt noExt (l (HsValBinds noExt (ValBinds noExt (unitBag (l bind)) []))))++-- | Clean up the GHCi environment after a statement has run+afterRunStmt :: GhciMonad m+             => (SrcSpan -> Bool) -> GHC.ExecResult -> m GHC.ExecResult+afterRunStmt step_here run_result = do+  resumes <- GHC.getResumeContext+  case run_result of+     GHC.ExecComplete{..} ->+       case execResult of+          Left ex -> liftIO $ Exception.throwIO ex+          Right names -> do+            show_types <- isOptionSet ShowType+            when show_types $ printTypeOfNames names+     GHC.ExecBreak names mb_info+         | isNothing  mb_info ||+           step_here (GHC.resumeSpan $ head resumes) -> do+               mb_id_loc <- toBreakIdAndLocation mb_info+               let bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc+               if (null bCmd)+                 then printStoppedAtBreakInfo (head resumes) names+                 else enqueueCommands [bCmd]+               -- run the command set with ":set stop <cmd>"+               st <- getGHCiState+               enqueueCommands [stop st]+               return ()+         | otherwise -> resume step_here GHC.SingleStep >>=+                        afterRunStmt step_here >> return ()++  flushInterpBuffers+  withSignalHandlers $ do+     b <- isOptionSet RevertCAFs+     when b revertCAFs++  return run_result++runSuccess :: Maybe GHC.ExecResult -> Bool+runSuccess run_result+  | Just (GHC.ExecComplete { execResult = Right _ }) <- run_result = True+  | otherwise = False++runAllocs :: Maybe GHC.ExecResult -> Maybe Integer+runAllocs m = do+  res <- m+  case res of+    GHC.ExecComplete{..} -> Just (fromIntegral execAllocation)+    _ -> Nothing++toBreakIdAndLocation :: GhciMonad m+                     => Maybe GHC.BreakInfo -> m (Maybe (Int, BreakLocation))+toBreakIdAndLocation Nothing = return Nothing+toBreakIdAndLocation (Just inf) = do+  let md = GHC.breakInfo_module inf+      nm = GHC.breakInfo_number inf+  st <- getGHCiState+  return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,+                                  breakModule loc == md,+                                  breakTick loc == nm ]++printStoppedAtBreakInfo :: GHC.GhcMonad m => Resume -> [Name] -> m ()+printStoppedAtBreakInfo res names = do+  printForUser $ pprStopped res+  --  printTypeOfNames session names+  let namesSorted = sortBy compareNames names+  tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted+  docs <- mapM pprTypeAndContents [i | AnId i <- tythings]+  printForUserPartWay $ vcat docs++printTypeOfNames :: GHC.GhcMonad m => [Name] -> m ()+printTypeOfNames names+ = mapM_ (printTypeOfName ) $ sortBy compareNames names++compareNames :: Name -> Name -> Ordering+n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2+    where compareWith n = (getOccString n, getSrcSpan n)++printTypeOfName :: GHC.GhcMonad m => Name -> m ()+printTypeOfName n+   = do maybe_tything <- GHC.lookupName n+        case maybe_tything of+            Nothing    -> return ()+            Just thing -> printTyThing thing+++data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand++-- | Entry point for execution a ':<command>' input from user+specialCommand :: String -> InputT GHCi Bool+specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)+specialCommand str = do+  let (cmd,rest) = break isSpace str+  maybe_cmd <- lookupCommand cmd+  htxt <- short_help <$> getGHCiState+  case maybe_cmd of+    GotCommand cmd -> (cmdAction cmd) (dropWhile isSpace rest)+    BadCommand ->+      do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"+                           ++ htxt)+         return False+    NoLastCommand ->+      do liftIO $ hPutStr stdout ("there is no last command to perform\n"+                           ++ htxt)+         return False++shellEscape :: MonadIO m => String -> m Bool+shellEscape str = liftIO (system str >> return False)++lookupCommand :: GhciMonad m => String -> m (MaybeCommand)+lookupCommand "" = do+  st <- getGHCiState+  case last_command st of+      Just c -> return $ GotCommand c+      Nothing -> return NoLastCommand+lookupCommand str = do+  mc <- lookupCommand' str+  modifyGHCiState (\st -> st { last_command = mc })+  return $ case mc of+           Just c -> GotCommand c+           Nothing -> BadCommand++lookupCommand' :: GhciMonad m => String -> m (Maybe Command)+lookupCommand' ":" = return Nothing+lookupCommand' str' = do+  macros    <- ghci_macros <$> getGHCiState+  ghci_cmds <- ghci_commands <$> getGHCiState++  let ghci_cmds_nohide = filter (not . cmdHidden) ghci_cmds++  let (str, xcmds) = case str' of+          ':' : rest -> (rest, [])     -- "::" selects a builtin command+          _          -> (str', macros) -- otherwise include macros in lookup++      lookupExact  s = find $ (s ==)           . cmdName+      lookupPrefix s = find $ (s `isPrefixOf`) . cmdName++      -- hidden commands can only be matched exact+      builtinPfxMatch = lookupPrefix str ghci_cmds_nohide++  -- first, look for exact match (while preferring macros); then, look+  -- for first prefix match (preferring builtins), *unless* a macro+  -- overrides the builtin; see #8305 for motivation+  return $ lookupExact str xcmds <|>+           lookupExact str ghci_cmds <|>+           (builtinPfxMatch >>= \c -> lookupExact (cmdName c) xcmds) <|>+           builtinPfxMatch <|>+           lookupPrefix str xcmds++getCurrentBreakSpan :: GHC.GhcMonad m => m (Maybe SrcSpan)+getCurrentBreakSpan = do+  resumes <- GHC.getResumeContext+  case resumes of+    [] -> return Nothing+    (r:_) -> do+        let ix = GHC.resumeHistoryIx r+        if ix == 0+           then return (Just (GHC.resumeSpan r))+           else do+                let hist = GHC.resumeHistory r !! (ix-1)+                pan <- GHC.getHistorySpan hist+                return (Just pan)++getCallStackAtCurrentBreakpoint :: GHC.GhcMonad m => m (Maybe [String])+getCallStackAtCurrentBreakpoint = do+  resumes <- GHC.getResumeContext+  case resumes of+    [] -> return Nothing+    (r:_) -> do+       hsc_env <- GHC.getSession+       Just <$> liftIO (costCentreStackInfo hsc_env (GHC.resumeCCS r))++getCurrentBreakModule :: GHC.GhcMonad m => m (Maybe Module)+getCurrentBreakModule = do+  resumes <- GHC.getResumeContext+  case resumes of+    [] -> return Nothing+    (r:_) -> do+        let ix = GHC.resumeHistoryIx r+        if ix == 0+           then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)+           else do+                let hist = GHC.resumeHistory r !! (ix-1)+                return $ Just $ GHC.getHistoryModule  hist++-----------------------------------------------------------------------------+--+-- Commands+--+-----------------------------------------------------------------------------++noArgs :: MonadIO m => m () -> String -> m ()+noArgs m "" = m+noArgs _ _  = liftIO $ putStrLn "This command takes no arguments"++withSandboxOnly :: GHC.GhcMonad m => String -> m () -> m ()+withSandboxOnly cmd this = do+   dflags <- getDynFlags+   if not (gopt Opt_GhciSandbox dflags)+      then printForUser (text cmd <+>+                         ptext (sLit "is not supported with -fno-ghci-sandbox"))+      else this++-----------------------------------------------------------------------------+-- :help++help :: GhciMonad m => String -> m ()+help _ = do+    txt <- long_help `fmap` getGHCiState+    liftIO $ putStr txt++-----------------------------------------------------------------------------+-- :info++info :: GHC.GhcMonad m => Bool -> String -> m ()+info _ "" = throwGhcException (CmdLineError "syntax: ':i <thing-you-want-info-about>'")+info allInfo s  = handleSourceError GHC.printException $ do+    unqual <- GHC.getPrintUnqual+    dflags <- getDynFlags+    sdocs  <- mapM (infoThing allInfo) (words s)+    mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs++infoThing :: GHC.GhcMonad m => Bool -> String -> m SDoc+infoThing allInfo str = do+    names     <- GHC.parseName str+    mb_stuffs <- mapM (GHC.getInfo allInfo) names+    let filtered = filterOutChildren (\(t,_f,_ci,_fi,_sd) -> t)+                                     (catMaybes mb_stuffs)+    return $ vcat (intersperse (text "") $ map pprInfo filtered)++  -- Filter out names whose parent is also there Good+  -- example is '[]', which is both a type and data+  -- constructor in the same type+filterOutChildren :: (a -> TyThing) -> [a] -> [a]+filterOutChildren get_thing xs+  = filterOut has_parent xs+  where+    all_names = mkNameSet (map (getName . get_thing) xs)+    has_parent x = case tyThingParent_maybe (get_thing x) of+                     Just p  -> getName p `elemNameSet` all_names+                     Nothing -> False++pprInfo :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc+pprInfo (thing, fixity, cls_insts, fam_insts, docs)+  =  docs+  $$ pprTyThingInContextLoc thing+  $$ show_fixity+  $$ vcat (map GHC.pprInstance cls_insts)+  $$ vcat (map GHC.pprFamInst  fam_insts)+  where+    show_fixity+        | fixity == GHC.defaultFixity = empty+        | otherwise                   = ppr fixity <+> pprInfixName (GHC.getName thing)++-----------------------------------------------------------------------------+-- :main++runMain :: GhciMonad m => String -> m ()+runMain s = case toArgs s of+            Left err   -> liftIO (hPutStrLn stderr err)+            Right args ->+                do dflags <- getDynFlags+                   let main = fromMaybe "main" (mainFunIs dflags)+                   -- Wrap the main function in 'void' to discard its value instead+                   -- of printing it (#9086). See Haskell 2010 report Chapter 5.+                   doWithArgs args $ "Control.Monad.void (" ++ main ++ ")"++-----------------------------------------------------------------------------+-- :run++runRun :: GhciMonad m => String -> m ()+runRun s = case toCmdArgs s of+           Left err          -> liftIO (hPutStrLn stderr err)+           Right (cmd, args) -> doWithArgs args cmd++doWithArgs :: GhciMonad m => [String] -> String -> m ()+doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " +++                                       show args ++ " (" ++ cmd ++ ")"]++-----------------------------------------------------------------------------+-- :cd++changeDirectory :: GhciMonad m => String -> m ()+changeDirectory "" = do+  -- :cd on its own changes to the user's home directory+  either_dir <- liftIO $ tryIO getHomeDirectory+  case either_dir of+     Left _e -> return ()+     Right dir -> changeDirectory dir+changeDirectory dir = do+  graph <- GHC.getModuleGraph+  when (not (null $ GHC.mgModSummaries graph)) $+        liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."+  GHC.setTargets []+  _ <- GHC.load LoadAllTargets+  setContextAfterLoad False []+  GHC.workingDirectoryChanged+  dir' <- expandPath dir+  liftIO $ setCurrentDirectory dir'+  dflags <- getDynFlags+  -- With -fexternal-interpreter, we have to change the directory of the subprocess too.+  -- (this gives consistent behaviour with and without -fexternal-interpreter)+  when (gopt Opt_ExternalInterpreter dflags) $ do+    hsc_env <- GHC.getSession+    fhv <- compileGHCiExpr $+      "System.Directory.setCurrentDirectory " ++ show dir'+    liftIO $ evalIO hsc_env fhv++trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag+trySuccess act =+    handleSourceError (\e -> do GHC.printException e+                                return Failed) $ do+      act++-----------------------------------------------------------------------------+-- :edit++editFile :: GhciMonad m => String -> m ()+editFile str =+  do file <- if null str then chooseEditFile else expandPath str+     st <- getGHCiState+     errs <- liftIO $ readIORef $ lastErrorLocations st+     let cmd = editor st+     when (null cmd)+       $ throwGhcException (CmdLineError "editor not set, use :set editor")+     lineOpt <- liftIO $ do+         let sameFile p1 p2 = liftA2 (==) (canonicalizePath p1) (canonicalizePath p2)+              `catchIO` (\_ -> return False)++         curFileErrs <- filterM (\(f, _) -> unpackFS f `sameFile` file) errs+         return $ case curFileErrs of+             (_, line):_ -> " +" ++ show line+             _ -> ""+     let cmdArgs = ' ':(file ++ lineOpt)+     code <- liftIO $ system (cmd ++ cmdArgs)++     when (code == ExitSuccess)+       $ reloadModule ""++-- The user didn't specify a file so we pick one for them.+-- Our strategy is to pick the first module that failed to load,+-- or otherwise the first target.+--+-- XXX: Can we figure out what happened if the depndecy analysis fails+--      (e.g., because the porgrammeer mistyped the name of a module)?+-- XXX: Can we figure out the location of an error to pass to the editor?+-- XXX: if we could figure out the list of errors that occured during the+-- last load/reaload, then we could start the editor focused on the first+-- of those.+chooseEditFile :: GHC.GhcMonad m => m String+chooseEditFile =+  do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x++     graph <- GHC.getModuleGraph+     failed_graph <-+       GHC.mkModuleGraph <$> filterM hasFailed (GHC.mgModSummaries graph)+     let order g  = flattenSCCs $ GHC.topSortModuleGraph True g Nothing+         pick xs  = case xs of+                      x : _ -> GHC.ml_hs_file (GHC.ms_location x)+                      _     -> Nothing++     case pick (order failed_graph) of+       Just file -> return file+       Nothing   ->+         do targets <- GHC.getTargets+            case msum (map fromTarget targets) of+              Just file -> return file+              Nothing   -> throwGhcException (CmdLineError "No files to edit.")++  where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f+        fromTarget _ = Nothing -- when would we get a module target?+++-----------------------------------------------------------------------------+-- :def++defineMacro :: GhciMonad m => Bool{-overwrite-} -> String -> m ()+defineMacro _ (':':_) = liftIO $ putStrLn+                          "macro name cannot start with a colon"+defineMacro _ ('!':_) = liftIO $ putStrLn+                          "macro name cannot start with an exclamation mark"+                          -- little code duplication allows to grep error msg+defineMacro overwrite s = do+  let (macro_name, definition) = break isSpace s+  macros <- ghci_macros <$> getGHCiState+  let defined = map cmdName macros+  if null macro_name+        then if null defined+                then liftIO $ putStrLn "no macros defined"+                else liftIO $ putStr ("the following macros are defined:\n" +++                                      unlines defined)+  else do+    isCommand <- isJust <$> lookupCommand' macro_name+    let check_newname+          | macro_name `elem` defined = throwGhcException (CmdLineError+            ("macro '" ++ macro_name ++ "' is already defined. " ++ hint))+          | isCommand = throwGhcException (CmdLineError+            ("macro '" ++ macro_name ++ "' overwrites builtin command. " ++ hint))+          | otherwise = return ()+        hint = " Use ':def!' to overwrite."++    unless overwrite check_newname+    -- compile the expression+    handleSourceError GHC.printException $ do+      step <- getGhciStepIO+      expr <- GHC.parseExpr definition+      -- > ghciStepIO . definition :: String -> IO String+      let stringTy = nlHsTyVar stringTy_RDR+          ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy+          body = nlHsVar compose_RDR `mkHsApp` (nlHsPar step)+                                     `mkHsApp` (nlHsPar expr)+          tySig = mkLHsSigWcType (stringTy `nlHsFunTy` ioM)+          new_expr = L (getLoc expr) $ ExprWithTySig noExt body tySig+      hv <- GHC.compileParsedExprRemote new_expr++      let newCmd = Command { cmdName = macro_name+                           , cmdAction = lift . runMacro hv+                           , cmdHidden = False+                           , cmdCompletionFunc = noCompletion+                           }++      -- later defined macros have precedence+      modifyGHCiState $ \s ->+        let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]+        in s { ghci_macros = newCmd : filtered }++runMacro+  :: GhciMonad m+  => GHC.ForeignHValue  -- String -> IO String+  -> String+  -> m Bool+runMacro fun s = do+  hsc_env <- GHC.getSession+  str <- liftIO $ evalStringToIOString hsc_env fun s+  enqueueCommands (lines str)+  return False+++-----------------------------------------------------------------------------+-- :undef++undefineMacro :: GhciMonad m => String -> m ()+undefineMacro str = mapM_ undef (words str)+ where undef macro_name = do+        cmds <- ghci_macros <$> getGHCiState+        if (macro_name `notElem` map cmdName cmds)+           then throwGhcException (CmdLineError+                ("macro '" ++ macro_name ++ "' is not defined"))+           else do+            -- This is a tad racy but really, it's a shell+            modifyGHCiState $ \s ->+                s { ghci_macros = filter ((/= macro_name) . cmdName)+                                         (ghci_macros s) }+++-----------------------------------------------------------------------------+-- :cmd++cmdCmd :: GhciMonad m => String -> m ()+cmdCmd str = handleSourceError GHC.printException $ do+    step <- getGhciStepIO+    expr <- GHC.parseExpr str+    -- > ghciStepIO str :: IO String+    let new_expr = step `mkHsApp` expr+    hv <- GHC.compileParsedExprRemote new_expr++    hsc_env <- GHC.getSession+    cmds <- liftIO $ evalString hsc_env hv+    enqueueCommands (lines cmds)++-- | Generate a typed ghciStepIO expression+-- @ghciStepIO :: Ty String -> IO String@.+getGhciStepIO :: GHC.GhcMonad m => m (LHsExpr GhcPs)+getGhciStepIO = do+  ghciTyConName <- GHC.getGHCiMonad+  let stringTy = nlHsTyVar stringTy_RDR+      ghciM = nlHsTyVar (getRdrName ghciTyConName) `nlHsAppTy` stringTy+      ioM = nlHsTyVar (getRdrName ioTyConName) `nlHsAppTy` stringTy+      body = nlHsVar (getRdrName ghciStepIoMName)+      tySig = mkLHsSigWcType (ghciM `nlHsFunTy` ioM)+  return $ noLoc $ ExprWithTySig noExt body tySig++-----------------------------------------------------------------------------+-- :check++checkModule :: GhciMonad m => String -> m ()+checkModule m = do+  let modl = GHC.mkModuleName m+  ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do+          r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl+          dflags <- getDynFlags+          liftIO $ putStrLn $ showSDoc dflags $+           case GHC.moduleInfo r of+             cm | Just scope <- GHC.modInfoTopLevelScope cm ->+                let+                    (loc, glob) = ASSERT( all isExternalName scope )+                                  partition ((== modl) . GHC.moduleName . GHC.nameModule) scope+                in+                        (text "global names: " <+> ppr glob) $$+                        (text "local  names: " <+> ppr loc)+             _ -> empty+          return True+  afterLoad (successIf ok) False++-----------------------------------------------------------------------------+-- :doc++docCmd :: GHC.GhcMonad m => String -> m ()+docCmd "" =+  throwGhcException (CmdLineError "syntax: ':doc <thing-you-want-docs-for>'")+docCmd s  = do+  -- TODO: Maybe also get module headers for module names+  names <- GHC.parseName s+  e_docss <- mapM GHC.getDocs names+  sdocs <- mapM (either handleGetDocsFailure (pure . pprDocs)) e_docss+  let sdocs' = vcat (intersperse (text "") sdocs)+  unqual <- GHC.getPrintUnqual+  dflags <- getDynFlags+  (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs'++-- TODO: also print arg docs.+pprDocs :: (Maybe HsDocString, Map Int HsDocString) -> SDoc+pprDocs (mb_decl_docs, _arg_docs) =+  maybe+    (text "<has no documentation>")+    (text . unpackHDS)+    mb_decl_docs++handleGetDocsFailure :: GHC.GhcMonad m => GetDocsFailure -> m SDoc+handleGetDocsFailure no_docs = do+  dflags <- getDynFlags+  let msg = showPpr dflags no_docs+  throwGhcException $ case no_docs of+    NameHasNoModule {} -> Sorry msg+    NoDocsInIface {} -> InstallationError msg+    InteractiveName -> ProgramError msg++-----------------------------------------------------------------------------+-- :load, :add, :reload++-- | Sets '-fdefer-type-errors' if 'defer' is true, executes 'load' and unsets+-- '-fdefer-type-errors' again if it has not been set before.+wrapDeferTypeErrors :: GHC.GhcMonad m => m a -> m a+wrapDeferTypeErrors load =+  gbracket+    (do+      -- Force originalFlags to avoid leaking the associated HscEnv+      !originalFlags <- getDynFlags+      void $ GHC.setProgramDynFlags $+         setGeneralFlag' Opt_DeferTypeErrors originalFlags+      return originalFlags)+    (\originalFlags -> void $ GHC.setProgramDynFlags originalFlags)+    (\_ -> load)++loadModule :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag+loadModule fs = do+  (_, result) <- runAndPrintStats (const Nothing) (loadModule' fs)+  either (liftIO . Exception.throwIO) return result++-- | @:load@ command+loadModule_ :: GhciMonad m => [FilePath] -> m ()+loadModule_ fs = void $ loadModule (zip fs (repeat Nothing))++loadModuleDefer :: GhciMonad m => [FilePath] -> m ()+loadModuleDefer = wrapDeferTypeErrors . loadModule_++loadModule' :: GhciMonad m => [(FilePath, Maybe Phase)] -> m SuccessFlag+loadModule' files = do+  let (filenames, phases) = unzip files+  exp_filenames <- mapM expandPath filenames+  let files' = zip exp_filenames phases+  targets <- mapM (uncurry GHC.guessTarget) files'++  -- NOTE: we used to do the dependency anal first, so that if it+  -- fails we didn't throw away the current set of modules.  This would+  -- require some re-working of the GHC interface, so we'll leave it+  -- as a ToDo for now.++  hsc_env <- GHC.getSession++  -- Grab references to the currently loaded modules so that we can+  -- see if they leak.+  let !dflags = hsc_dflags hsc_env+  leak_indicators <- if gopt Opt_GhciLeakCheck dflags+    then liftIO $ getLeakIndicators hsc_env+    else return (panic "no leak indicators")++  -- unload first+  _ <- GHC.abandonAll+  discardActiveBreakPoints+  GHC.setTargets []+  _ <- GHC.load LoadAllTargets++  GHC.setTargets targets+  success <- doLoadAndCollectInfo False LoadAllTargets+  when (gopt Opt_GhciLeakCheck dflags) $+    liftIO $ checkLeakIndicators dflags leak_indicators+  return success++-- | @:add@ command+addModule :: GhciMonad m => [FilePath] -> m ()+addModule files = do+  revertCAFs -- always revert CAFs on load/add.+  files' <- mapM expandPath files+  targets <- mapM (\m -> GHC.guessTarget m Nothing) files'+  targets' <- filterM checkTarget targets+  -- remove old targets with the same id; e.g. for :add *M+  mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets' ]+  mapM_ GHC.addTarget targets'+  _ <- doLoadAndCollectInfo False LoadAllTargets+  return ()+  where+    checkTarget :: GHC.GhcMonad m => Target -> m Bool+    checkTarget (Target (TargetModule m) _ _) = checkTargetModule m+    checkTarget (Target (TargetFile f _) _ _) = liftIO $ checkTargetFile f++    checkTargetModule :: GHC.GhcMonad m => ModuleName -> m Bool+    checkTargetModule m = do+      hsc_env <- GHC.getSession+      result <- liftIO $+        Finder.findImportedModule hsc_env m (Just (fsLit "this"))+      case result of+        Found _ _ -> return True+        _ -> (liftIO $ putStrLn $+          "Module " ++ moduleNameString m ++ " not found") >> return False++    checkTargetFile :: String -> IO Bool+    checkTargetFile f = do+      exists <- (doesFileExist f) :: IO Bool+      unless exists $ putStrLn $ "File " ++ f ++ " not found"+      return exists++-- | @:unadd@ command+unAddModule :: GhciMonad m => [FilePath] -> m ()+unAddModule files = do+  files' <- mapM expandPath files+  targets <- mapM (\m -> GHC.guessTarget m Nothing) files'+  mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]+  _ <- doLoadAndCollectInfo False LoadAllTargets+  return ()++-- | @:reload@ command+reloadModule :: GhciMonad m => String -> m ()+reloadModule m = void $ doLoadAndCollectInfo True loadTargets+  where+    loadTargets | null m    = LoadAllTargets+                | otherwise = LoadUpTo (GHC.mkModuleName m)++reloadModuleDefer :: GhciMonad m => String -> m ()+reloadModuleDefer = wrapDeferTypeErrors . reloadModule++-- | Load/compile targets and (optionally) collect module-info+--+-- This collects the necessary SrcSpan annotated type information (via+-- 'collectInfo') required by the @:all-types@, @:loc-at@, @:type-at@,+-- and @:uses@ commands.+--+-- Meta-info collection is not enabled by default and needs to be+-- enabled explicitly via @:set +c@.  The reason is that collecting+-- the type-information for all sub-spans can be quite expensive, and+-- since those commands are designed to be used by editors and+-- tooling, it's useless to collect this data for normal GHCi+-- sessions.+doLoadAndCollectInfo :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag+doLoadAndCollectInfo retain_context howmuch = do+  doCollectInfo <- isOptionSet CollectInfo++  doLoad retain_context howmuch >>= \case+    Succeeded | doCollectInfo -> do+      mod_summaries <- GHC.mgModSummaries <$> getModuleGraph+      loaded <- filterM GHC.isLoaded $ map GHC.ms_mod_name mod_summaries+      v <- mod_infos <$> getGHCiState+      !newInfos <- collectInfo v loaded+      modifyGHCiState (\st -> st { mod_infos = newInfos })+      return Succeeded+    flag -> return flag++doLoad :: GhciMonad m => Bool -> LoadHowMuch -> m SuccessFlag+doLoad retain_context howmuch = do+  -- turn off breakpoints before we load: we can't turn them off later, because+  -- the ModBreaks will have gone away.+  discardActiveBreakPoints++  resetLastErrorLocations+  -- Enable buffering stdout and stderr as we're compiling. Keeping these+  -- handles unbuffered will just slow the compilation down, especially when+  -- compiling in parallel.+  gbracket (liftIO $ do hSetBuffering stdout LineBuffering+                        hSetBuffering stderr LineBuffering)+           (\_ ->+            liftIO $ do hSetBuffering stdout NoBuffering+                        hSetBuffering stderr NoBuffering) $ \_ -> do+      ok <- trySuccess $ GHC.load howmuch+      afterLoad ok retain_context+      return ok+++afterLoad+  :: GhciMonad m+  => SuccessFlag+  -> Bool   -- keep the remembered_ctx, as far as possible (:reload)+  -> m ()+afterLoad ok retain_context = do+  revertCAFs  -- always revert CAFs on load.+  discardTickArrays+  loaded_mods <- getLoadedModules+  modulesLoadedMsg ok loaded_mods+  setContextAfterLoad retain_context loaded_mods++setContextAfterLoad :: GhciMonad m => Bool -> [GHC.ModSummary] -> m ()+setContextAfterLoad keep_ctxt [] = do+  setContextKeepingPackageModules keep_ctxt []+setContextAfterLoad keep_ctxt ms = do+  -- load a target if one is available, otherwise load the topmost module.+  targets <- GHC.getTargets+  case [ m | Just m <- map (findTarget ms) targets ] of+        []    ->+          let graph = GHC.mkModuleGraph ms+              graph' = flattenSCCs (GHC.topSortModuleGraph True graph Nothing)+          in load_this (last graph')+        (m:_) ->+          load_this m+ where+   findTarget mds t+    = case filter (`matches` t) mds of+        []    -> Nothing+        (m:_) -> Just m++   summary `matches` Target (TargetModule m) _ _+        = GHC.ms_mod_name summary == m+   summary `matches` Target (TargetFile f _) _ _+        | Just f' <- GHC.ml_hs_file (GHC.ms_location summary)   = f == f'+   _ `matches` _+        = False++   load_this summary | m <- GHC.ms_mod summary = do+        is_interp <- GHC.moduleIsInterpreted m+        dflags <- getDynFlags+        let star_ok = is_interp && not (safeLanguageOn dflags)+              -- We import the module with a * iff+              --   - it is interpreted, and+              --   - -XSafe is off (it doesn't allow *-imports)+        let new_ctx | star_ok   = [mkIIModule (GHC.moduleName m)]+                    | otherwise = [mkIIDecl   (GHC.moduleName m)]+        setContextKeepingPackageModules keep_ctxt new_ctx+++-- | Keep any package modules (except Prelude) when changing the context.+setContextKeepingPackageModules+  :: GhciMonad m+  => Bool                 -- True  <=> keep all of remembered_ctx+                          -- False <=> just keep package imports+  -> [InteractiveImport]  -- new context+  -> m ()+setContextKeepingPackageModules keep_ctx trans_ctx = do++  st <- getGHCiState+  let rem_ctx = remembered_ctx st+  new_rem_ctx <- if keep_ctx then return rem_ctx+                             else keepPackageImports rem_ctx+  setGHCiState st{ remembered_ctx = new_rem_ctx,+                   transient_ctx  = filterSubsumed new_rem_ctx trans_ctx }+  setGHCContextFromGHCiState++-- | Filters a list of 'InteractiveImport', clearing out any home package+-- imports so only imports from external packages are preserved.  ('IIModule'+-- counts as a home package import, because we are only able to bring a+-- full top-level into scope when the source is available.)+keepPackageImports+  :: GHC.GhcMonad m => [InteractiveImport] -> m [InteractiveImport]+keepPackageImports = filterM is_pkg_import+  where+     is_pkg_import :: GHC.GhcMonad m => InteractiveImport -> m Bool+     is_pkg_import (IIModule _) = return False+     is_pkg_import (IIDecl d)+         = do e <- gtry $ GHC.findModule mod_name (fmap sl_fs $ ideclPkgQual d)+              case e :: Either SomeException Module of+                Left _  -> return False+                Right m -> return (not (isHomeModule m))+        where+          mod_name = unLoc (ideclName d)+++modulesLoadedMsg :: GHC.GhcMonad m => SuccessFlag -> [GHC.ModSummary] -> m ()+modulesLoadedMsg ok mods = do+  dflags <- getDynFlags+  unqual <- GHC.getPrintUnqual++  msg <- if gopt Opt_ShowLoadedModules dflags+         then do+               mod_names <- mapM mod_name mods+               let mod_commas+                     | null mods = text "none."+                     | otherwise = hsep (punctuate comma mod_names) <> text "."+               return $ status <> text ", modules loaded:" <+> mod_commas+         else do+               return $ status <> text ","+                    <+> speakNOf (length mods) (text "module") <+> "loaded."++  when (verbosity dflags > 0) $+     liftIO $ putStrLn $ showSDocForUser dflags unqual msg+  where+    status = case ok of+                  Failed    -> text "Failed"+                  Succeeded -> text "Ok"++    mod_name mod = do+        is_interpreted <- GHC.moduleIsBootOrNotObjectLinkable mod+        return $ if is_interpreted+                 then ppr (GHC.ms_mod mod)+                 else ppr (GHC.ms_mod mod)+                      <+> parens (text $ normalise $ msObjFilePath mod)+                      -- Fix #9887++-- | Run an 'ExceptT' wrapped 'GhcMonad' while handling source errors+-- and printing 'throwE' strings to 'stderr'+runExceptGhcMonad :: GHC.GhcMonad m => ExceptT SDoc m () -> m ()+runExceptGhcMonad act = handleSourceError GHC.printException $+                        either handleErr pure =<<+                        runExceptT act+  where+    handleErr sdoc = do+        dflags <- getDynFlags+        liftIO . hPutStrLn stderr . showSDocForUser dflags alwaysQualify $ sdoc++-- | Inverse of 'runExceptT' for \"pure\" computations+-- (c.f. 'except' for 'Except')+exceptT :: Applicative m => Either e a -> ExceptT e m a+exceptT = ExceptT . pure++-----------------------------------------------------------------------------+-- | @:type@ command. See also Note [TcRnExprMode] in TcRnDriver.++typeOfExpr :: GHC.GhcMonad m => String -> m ()+typeOfExpr str = handleSourceError GHC.printException $ do+    let (mode, expr_str) = case break isSpace str of+          ("+d", rest) -> (GHC.TM_Default, dropWhile isSpace rest)+          ("+v", rest) -> (GHC.TM_NoInst,  dropWhile isSpace rest)+          _            -> (GHC.TM_Inst,    str)+    ty <- GHC.exprType mode expr_str+    printForUser $ sep [text expr_str, nest 2 (dcolon <+> pprTypeForUser ty)]++-----------------------------------------------------------------------------+-- | @:type-at@ command++typeAtCmd :: GhciMonad m => String -> m ()+typeAtCmd str = runExceptGhcMonad $ do+    (span',sample) <- exceptT $ parseSpanArg str+    infos      <- lift $ mod_infos <$> getGHCiState+    (info, ty) <- findType infos span' sample+    lift $ printForUserModInfo (modinfoInfo info)+                               (sep [text sample,nest 2 (dcolon <+> ppr ty)])++-----------------------------------------------------------------------------+-- | @:uses@ command++usesCmd :: GhciMonad m => String -> m ()+usesCmd str = runExceptGhcMonad $ do+    (span',sample) <- exceptT $ parseSpanArg str+    infos  <- lift $ mod_infos <$> getGHCiState+    uses   <- findNameUses infos span' sample+    forM_ uses (liftIO . putStrLn . showSrcSpan)++-----------------------------------------------------------------------------+-- | @:loc-at@ command++locAtCmd :: GhciMonad m => String -> m ()+locAtCmd str = runExceptGhcMonad $ do+    (span',sample) <- exceptT $ parseSpanArg str+    infos    <- lift $ mod_infos <$> getGHCiState+    (_,_,sp) <- findLoc infos span' sample+    liftIO . putStrLn . showSrcSpan $ sp++-----------------------------------------------------------------------------+-- | @:all-types@ command++allTypesCmd :: GhciMonad m => String -> m ()+allTypesCmd _ = runExceptGhcMonad $ do+    infos <- lift $ mod_infos <$> getGHCiState+    forM_ (M.elems infos) $ \mi ->+        forM_ (modinfoSpans mi) (lift . printSpan)+  where+    printSpan span'+      | Just ty <- spaninfoType span' = do+        df <- getDynFlags+        let tyInfo = unwords . words $+                     showSDocForUser df alwaysQualify (pprTypeForUser ty)+        liftIO . putStrLn $+            showRealSrcSpan (spaninfoSrcSpan span') ++ ": " ++ tyInfo+      | otherwise = return ()++-----------------------------------------------------------------------------+-- Helpers for locAtCmd/typeAtCmd/usesCmd++-- | Parse a span: <module-name/filepath> <sl> <sc> <el> <ec> <string>+parseSpanArg :: String -> Either SDoc (RealSrcSpan,String)+parseSpanArg s = do+    (fp,s0) <- readAsString (skipWs s)+    s0'     <- skipWs1 s0+    (sl,s1) <- readAsInt s0'+    s1'     <- skipWs1 s1+    (sc,s2) <- readAsInt s1'+    s2'     <- skipWs1 s2+    (el,s3) <- readAsInt s2'+    s3'     <- skipWs1 s3+    (ec,s4) <- readAsInt s3'++    trailer <- case s4 of+        [] -> Right ""+        _  -> skipWs1 s4++    let fs    = mkFastString fp+        span' = mkRealSrcSpan (mkRealSrcLoc fs sl sc)+                              -- End column of RealSrcSpan is the column+                              -- after the end of the span.+                              (mkRealSrcLoc fs el (ec + 1))++    return (span',trailer)+  where+    readAsInt :: String -> Either SDoc (Int,String)+    readAsInt "" = Left "Premature end of string while expecting Int"+    readAsInt s0 = case reads s0 of+        [s_rest] -> Right s_rest+        _        -> Left ("Couldn't read" <+> text (show s0) <+> "as Int")++    readAsString :: String -> Either SDoc (String,String)+    readAsString s0+      | '"':_ <- s0 = case reads s0 of+          [s_rest] -> Right s_rest+          _        -> leftRes+      | s_rest@(_:_,_) <- breakWs s0 = Right s_rest+      | otherwise = leftRes+      where+        leftRes = Left ("Couldn't read" <+> text (show s0) <+> "as String")++    skipWs1 :: String -> Either SDoc String+    skipWs1 (c:cs) | isWs c = Right (skipWs cs)+    skipWs1 s0 = Left ("Expected whitespace in" <+> text (show s0))++    isWs    = (`elem` [' ','\t'])+    skipWs  = dropWhile isWs+    breakWs = break isWs+++-- | Pretty-print \"real\" 'SrcSpan's as+-- @<filename>:(<line>,<col>)-(<line-end>,<col-end>)@+-- while simply unpacking 'UnhelpfulSpan's+showSrcSpan :: SrcSpan -> String+showSrcSpan (UnhelpfulSpan s)  = unpackFS s+showSrcSpan (RealSrcSpan spn)  = showRealSrcSpan spn++-- | Variant of 'showSrcSpan' for 'RealSrcSpan's+showRealSrcSpan :: RealSrcSpan -> String+showRealSrcSpan spn = concat [ fp, ":(", show sl, ",", show sc+                             , ")-(", show el, ",", show ec, ")"+                             ]+  where+    fp = unpackFS (srcSpanFile spn)+    sl = srcSpanStartLine spn+    sc = srcSpanStartCol  spn+    el = srcSpanEndLine   spn+    -- The end column is the column after the end of the span see the+    -- RealSrcSpan module+    ec = let ec' = srcSpanEndCol    spn in if ec' == 0 then 0 else ec' - 1++-----------------------------------------------------------------------------+-- | @:kind@ command++kindOfType :: GHC.GhcMonad m => Bool -> String -> m ()+kindOfType norm str = handleSourceError GHC.printException $ do+    (ty, kind) <- GHC.typeKind norm str+    printForUser $ vcat [ text str <+> dcolon <+> pprTypeForUser kind+                        , ppWhen norm $ equals <+> pprTypeForUser ty ]++-----------------------------------------------------------------------------+-- :quit++quit :: Monad m => String -> m Bool+quit _ = return True+++-----------------------------------------------------------------------------+-- :script++-- running a script file #1363++scriptCmd :: String -> InputT GHCi ()+scriptCmd ws = do+  case words ws of+    [s]    -> runScript s+    _      -> throwGhcException (CmdLineError "syntax:  :script <filename>")++runScript :: String    -- ^ filename+           -> InputT GHCi ()+runScript filename = do+  filename' <- expandPath filename+  either_script <- liftIO $ tryIO (openFile filename' ReadMode)+  case either_script of+    Left _err    -> throwGhcException (CmdLineError $ "IO error:  \""++filename++"\" "+                      ++(ioeGetErrorString _err))+    Right script -> do+      st <- getGHCiState+      let prog = progname st+          line = line_number st+      setGHCiState st{progname=filename',line_number=0}+      scriptLoop script+      liftIO $ hClose script+      new_st <- getGHCiState+      setGHCiState new_st{progname=prog,line_number=line}+  where scriptLoop script = do+          res <- runOneCommand handler $ fileLoop script+          case res of+            Nothing -> return ()+            Just s  -> if s+              then scriptLoop script+              else return ()++-----------------------------------------------------------------------------+-- :issafe++-- Displaying Safe Haskell properties of a module++isSafeCmd :: GHC.GhcMonad m => String -> m ()+isSafeCmd m =+    case words m of+        [s] | looksLikeModuleName s -> do+            md <- lookupModule s+            isSafeModule md+        [] -> do md <- guessCurrentModule "issafe"+                 isSafeModule md+        _ -> throwGhcException (CmdLineError "syntax:  :issafe <module>")++isSafeModule :: GHC.GhcMonad m => Module -> m ()+isSafeModule m = do+    mb_mod_info <- GHC.getModuleInfo m+    when (isNothing mb_mod_info)+         (throwGhcException $ CmdLineError $ "unknown module: " ++ mname)++    dflags <- getDynFlags+    let iface = GHC.modInfoIface $ fromJust mb_mod_info+    when (isNothing iface)+         (throwGhcException $ CmdLineError $ "can't load interface file for module: " +++                                    (GHC.moduleNameString $ GHC.moduleName m))++    (msafe, pkgs) <- GHC.moduleTrustReqs m+    let trust  = showPpr dflags $ getSafeMode $ GHC.mi_trust $ fromJust iface+        pkg    = if packageTrusted dflags m then "trusted" else "untrusted"+        (good, bad) = tallyPkgs dflags pkgs++    -- print info to user...+    liftIO $ putStrLn $ "Trust type is (Module: " ++ trust ++ ", Package: " ++ pkg ++ ")"+    liftIO $ putStrLn $ "Package Trust: " ++ (if packageTrustOn dflags then "On" else "Off")+    when (not $ S.null good)+         (liftIO $ putStrLn $ "Trusted package dependencies (trusted): " +++                        (intercalate ", " $ map (showPpr dflags) (S.toList good)))+    case msafe && S.null bad of+        True -> liftIO $ putStrLn $ mname ++ " is trusted!"+        False -> do+            when (not $ null bad)+                 (liftIO $ putStrLn $ "Trusted package dependencies (untrusted): "+                            ++ (intercalate ", " $ map (showPpr dflags) (S.toList bad)))+            liftIO $ putStrLn $ mname ++ " is NOT trusted!"++  where+    mname = GHC.moduleNameString $ GHC.moduleName m++    packageTrusted dflags md+        | thisPackage dflags == moduleUnitId md = True+        | otherwise = trusted $ getPackageDetails dflags (moduleUnitId md)++    tallyPkgs dflags deps | not (packageTrustOn dflags) = (S.empty, S.empty)+                          | otherwise = S.partition part deps+        where part pkg = trusted $ getInstalledPackageDetails dflags pkg++-----------------------------------------------------------------------------+-- :browse++-- Browsing a module's contents++browseCmd :: GHC.GhcMonad m => Bool -> String -> m ()+browseCmd bang m =+  case words m of+    ['*':s] | looksLikeModuleName s -> do+        md <- wantInterpretedModule s+        browseModule bang md False+    [s] | looksLikeModuleName s -> do+        md <- lookupModule s+        browseModule bang md True+    [] -> do md <- guessCurrentModule ("browse" ++ if bang then "!" else "")+             browseModule bang md True+    _ -> throwGhcException (CmdLineError "syntax:  :browse <module>")++guessCurrentModule :: GHC.GhcMonad m => String -> m Module+-- Guess which module the user wants to browse.  Pick+-- modules that are interpreted first.  The most+-- recently-added module occurs last, it seems.+guessCurrentModule cmd+  = do imports <- GHC.getContext+       when (null imports) $ throwGhcException $+          CmdLineError (':' : cmd ++ ": no current module")+       case (head imports) of+          IIModule m -> GHC.findModule m Nothing+          IIDecl d   -> GHC.findModule (unLoc (ideclName d))+                                       (fmap sl_fs $ ideclPkgQual d)++-- without bang, show items in context of their parents and omit children+-- with bang, show class methods and data constructors separately, and+--            indicate import modules, to aid qualifying unqualified names+-- with sorted, sort items alphabetically+browseModule :: GHC.GhcMonad m => Bool -> Module -> Bool -> m ()+browseModule bang modl exports_only = do+  -- :browse reports qualifiers wrt current context+  unqual <- GHC.getPrintUnqual++  mb_mod_info <- GHC.getModuleInfo modl+  case mb_mod_info of+    Nothing -> throwGhcException (CmdLineError ("unknown module: " +++                                GHC.moduleNameString (GHC.moduleName modl)))+    Just mod_info -> do+        dflags <- getDynFlags+        let names+               | exports_only = GHC.modInfoExports mod_info+               | otherwise    = GHC.modInfoTopLevelScope mod_info+                                `orElse` []++                -- sort alphabetically name, but putting locally-defined+                -- identifiers first. We would like to improve this; see #1799.+            sorted_names = loc_sort local ++ occ_sort external+                where+                (local,external) = ASSERT( all isExternalName names )+                                   partition ((==modl) . nameModule) names+                occ_sort = sortBy (compare `on` nameOccName)+                -- try to sort by src location. If the first name in our list+                -- has a good source location, then they all should.+                loc_sort ns+                      | n:_ <- ns, isGoodSrcSpan (nameSrcSpan n)+                      = sortBy (compare `on` nameSrcSpan) ns+                      | otherwise+                      = occ_sort ns++        mb_things <- mapM GHC.lookupName sorted_names+        let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)++        rdr_env <- GHC.getGRE++        let things | bang      = catMaybes mb_things+                   | otherwise = filtered_things+            pretty | bang      = pprTyThing showToHeader+                   | otherwise = pprTyThingInContext showToHeader++            labels  [] = text "-- not currently imported"+            labels  l  = text $ intercalate "\n" $ map qualifier l++            qualifier :: Maybe [ModuleName] -> String+            qualifier  = maybe "-- defined locally"+                             (("-- imported via "++) . intercalate ", "+                               . map GHC.moduleNameString)+            importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env++            modNames :: [[Maybe [ModuleName]]]+            modNames   = map (importInfo . GHC.getName) things++            -- annotate groups of imports with their import modules+            -- the default ordering is somewhat arbitrary, so we group+            -- by header and sort groups; the names themselves should+            -- really come in order of source appearance.. (trac #1799)+            annotate mts = concatMap (\(m,ts)->labels m:ts)+                         $ sortBy cmpQualifiers $ grp mts+              where cmpQualifiers =+                      compare `on` (map (fmap (map moduleNameFS)) . fst)+            grp []            = []+            grp mts@((m,_):_) = (m,map snd g) : grp ng+              where (g,ng) = partition ((==m).fst) mts++        let prettyThings, prettyThings' :: [SDoc]+            prettyThings = map pretty things+            prettyThings' | bang      = annotate $ zip modNames prettyThings+                          | otherwise = prettyThings+        liftIO $ putStrLn $ showSDocForUser dflags unqual (vcat prettyThings')+        -- ToDo: modInfoInstances currently throws an exception for+        -- package modules.  When it works, we can do this:+        --        $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))+++-----------------------------------------------------------------------------+-- :module++-- Setting the module context.  For details on context handling see+-- "remembered_ctx" and "transient_ctx" in GhciMonad.++moduleCmd :: GhciMonad m => String -> m ()+moduleCmd str+  | all sensible strs = cmd+  | otherwise = throwGhcException (CmdLineError "syntax:  :module [+/-] [*]M1 ... [*]Mn")+  where+    (cmd, strs) =+        case str of+          '+':stuff -> rest addModulesToContext   stuff+          '-':stuff -> rest remModulesFromContext stuff+          stuff     -> rest setContext            stuff++    rest op stuff = (op as bs, stuffs)+       where (as,bs) = partitionWith starred stuffs+             stuffs  = words stuff++    sensible ('*':m) = looksLikeModuleName m+    sensible m       = looksLikeModuleName m++    starred ('*':m) = Left  (GHC.mkModuleName m)+    starred m       = Right (GHC.mkModuleName m)+++-- -----------------------------------------------------------------------------+-- Four ways to manipulate the context:+--   (a) :module +<stuff>:     addModulesToContext+--   (b) :module -<stuff>:     remModulesFromContext+--   (c) :module <stuff>:      setContext+--   (d) import <module>...:   addImportToContext++addModulesToContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()+addModulesToContext starred unstarred = restoreContextOnFailure $ do+   addModulesToContext_ starred unstarred++addModulesToContext_ :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()+addModulesToContext_ starred unstarred = do+   mapM_ addII (map mkIIModule starred ++ map mkIIDecl unstarred)+   setGHCContextFromGHCiState++remModulesFromContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()+remModulesFromContext  starred unstarred = do+   -- we do *not* call restoreContextOnFailure here.  If the user+   -- is trying to fix up a context that contains errors by removing+   -- modules, we don't want GHC to silently put them back in again.+   mapM_ rm (starred ++ unstarred)+   setGHCContextFromGHCiState+ where+   rm :: GhciMonad m => ModuleName -> m ()+   rm str = do+     m <- moduleName <$> lookupModuleName str+     let filt = filter ((/=) m . iiModuleName)+     modifyGHCiState $ \st ->+        st { remembered_ctx = filt (remembered_ctx st)+           , transient_ctx  = filt (transient_ctx st) }++setContext :: GhciMonad m => [ModuleName] -> [ModuleName] -> m ()+setContext starred unstarred = restoreContextOnFailure $ do+  modifyGHCiState $ \st -> st { remembered_ctx = [], transient_ctx = [] }+                                -- delete the transient context+  addModulesToContext_ starred unstarred++addImportToContext :: GhciMonad m => String -> m ()+addImportToContext str = restoreContextOnFailure $ do+  idecl <- GHC.parseImportDecl str+  addII (IIDecl idecl)   -- #5836+  setGHCContextFromGHCiState++-- Util used by addImportToContext and addModulesToContext+addII :: GhciMonad m => InteractiveImport -> m ()+addII iidecl = do+  checkAdd iidecl+  modifyGHCiState $ \st ->+     st { remembered_ctx = addNotSubsumed iidecl (remembered_ctx st)+        , transient_ctx = filter (not . (iidecl `iiSubsumes`))+                                 (transient_ctx st)+        }++-- Sometimes we can't tell whether an import is valid or not until+-- we finally call 'GHC.setContext'.  e.g.+--+--   import System.IO (foo)+--+-- will fail because System.IO does not export foo.  In this case we+-- don't want to store the import in the context permanently, so we+-- catch the failure from 'setGHCContextFromGHCiState' and set the+-- context back to what it was.+--+-- See #6007+--+restoreContextOnFailure :: GhciMonad m => m a -> m a+restoreContextOnFailure do_this = do+  st <- getGHCiState+  let rc = remembered_ctx st; tc = transient_ctx st+  do_this `gonException` (modifyGHCiState $ \st' ->+     st' { remembered_ctx = rc, transient_ctx = tc })++-- -----------------------------------------------------------------------------+-- Validate a module that we want to add to the context++checkAdd :: GHC.GhcMonad m => InteractiveImport -> m ()+checkAdd ii = do+  dflags <- getDynFlags+  let safe = safeLanguageOn dflags+  case ii of+    IIModule modname+       | safe -> throwGhcException $ CmdLineError "can't use * imports with Safe Haskell"+       | otherwise -> wantInterpretedModuleName modname >> return ()++    IIDecl d -> do+       let modname = unLoc (ideclName d)+           pkgqual = ideclPkgQual d+       m <- GHC.lookupModule modname (fmap sl_fs pkgqual)+       when safe $ do+           t <- GHC.isModuleTrusted m+           when (not t) $ throwGhcException $ ProgramError $ ""++-- -----------------------------------------------------------------------------+-- Update the GHC API's view of the context++-- | Sets the GHC context from the GHCi state.  The GHC context is+-- always set this way, we never modify it incrementally.+--+-- We ignore any imports for which the ModuleName does not currently+-- exist.  This is so that the remembered_ctx can contain imports for+-- modules that are not currently loaded, perhaps because we just did+-- a :reload and encountered errors.+--+-- Prelude is added if not already present in the list.  Therefore to+-- override the implicit Prelude import you can say 'import Prelude ()'+-- at the prompt, just as in Haskell source.+--+setGHCContextFromGHCiState :: GhciMonad m => m ()+setGHCContextFromGHCiState = do+  st <- getGHCiState+      -- re-use checkAdd to check whether the module is valid.  If the+      -- module does not exist, we do *not* want to print an error+      -- here, we just want to silently keep the module in the context+      -- until such time as the module reappears again.  So we ignore+      -- the actual exception thrown by checkAdd, using tryBool to+      -- turn it into a Bool.+  iidecls <- filterM (tryBool.checkAdd) (transient_ctx st ++ remembered_ctx st)++  prel_iidecls <- getImplicitPreludeImports iidecls+  valid_prel_iidecls <- filterM (tryBool . checkAdd) prel_iidecls++  extra_imports <- filterM (tryBool . checkAdd) (map IIDecl (extra_imports st))++  GHC.setContext $ iidecls ++ extra_imports ++ valid_prel_iidecls+++getImplicitPreludeImports :: GhciMonad m+                          => [InteractiveImport] -> m [InteractiveImport]+getImplicitPreludeImports iidecls = do+  dflags <- GHC.getInteractiveDynFlags+     -- allow :seti to override -XNoImplicitPrelude+  st <- getGHCiState++  -- We add the prelude imports if there are no *-imports, and we also+  -- allow each prelude import to be subsumed by another explicit import+  -- of the same module.  This means that you can override the prelude import+  -- with "import Prelude hiding (map)", for example.+  let prel_iidecls =+         if xopt LangExt.ImplicitPrelude dflags && not (any isIIModule iidecls)+            then [ IIDecl imp+                 | imp <- prelude_imports st+                 , not (any (sameImpModule imp) iidecls) ]+            else []++  return prel_iidecls++-- -----------------------------------------------------------------------------+-- Utils on InteractiveImport++mkIIModule :: ModuleName -> InteractiveImport+mkIIModule = IIModule++mkIIDecl :: ModuleName -> InteractiveImport+mkIIDecl = IIDecl . simpleImportDecl++iiModules :: [InteractiveImport] -> [ModuleName]+iiModules is = [m | IIModule m <- is]++isIIModule :: InteractiveImport -> Bool+isIIModule (IIModule _) = True+isIIModule _ = False++iiModuleName :: InteractiveImport -> ModuleName+iiModuleName (IIModule m) = m+iiModuleName (IIDecl d)   = unLoc (ideclName d)++preludeModuleName :: ModuleName+preludeModuleName = GHC.mkModuleName "Prelude"++sameImpModule :: ImportDecl GhcPs -> InteractiveImport -> Bool+sameImpModule _ (IIModule _) = False -- we only care about imports here+sameImpModule imp (IIDecl d) = unLoc (ideclName d) == unLoc (ideclName imp)++addNotSubsumed :: InteractiveImport+               -> [InteractiveImport] -> [InteractiveImport]+addNotSubsumed i is+  | any (`iiSubsumes` i) is = is+  | otherwise               = i : filter (not . (i `iiSubsumes`)) is++-- | @filterSubsumed is js@ returns the elements of @js@ not subsumed+-- by any of @is@.+filterSubsumed :: [InteractiveImport] -> [InteractiveImport]+               -> [InteractiveImport]+filterSubsumed is js = filter (\j -> not (any (`iiSubsumes` j) is)) js++-- | Returns True if the left import subsumes the right one.  Doesn't+-- need to be 100% accurate, conservatively returning False is fine.+-- (EXCEPT: (IIModule m) *must* subsume itself, otherwise a panic in+-- plusProv will ensue (#5904))+--+-- Note that an IIModule does not necessarily subsume an IIDecl,+-- because e.g. a module might export a name that is only available+-- qualified within the module itself.+--+-- Note that 'import M' does not necessarily subsume 'import M(foo)',+-- because M might not export foo and we want an error to be produced+-- in that case.+--+iiSubsumes :: InteractiveImport -> InteractiveImport -> Bool+iiSubsumes (IIModule m1) (IIModule m2) = m1==m2+iiSubsumes (IIDecl d1) (IIDecl d2)      -- A bit crude+  =  unLoc (ideclName d1) == unLoc (ideclName d2)+     && ideclAs d1 == ideclAs d2+     && (not (isImportDeclQualified (ideclQualified d1)) || isImportDeclQualified (ideclQualified d2))+     && (ideclHiding d1 `hidingSubsumes` ideclHiding d2)+  where+     _                    `hidingSubsumes` Just (False,L _ []) = True+     Just (False, L _ xs) `hidingSubsumes` Just (False,L _ ys)+                                                           = all (`elem` xs) ys+     h1                   `hidingSubsumes` h2              = h1 == h2+iiSubsumes _ _ = False+++----------------------------------------------------------------------------+-- :set++-- set options in the interpreter.  Syntax is exactly the same as the+-- ghc command line, except that certain options aren't available (-C,+-- -E etc.)+--+-- This is pretty fragile: most options won't work as expected.  ToDo:+-- figure out which ones & disallow them.++setCmd :: GhciMonad m => String -> m ()+setCmd ""   = showOptions False+setCmd "-a" = showOptions True+setCmd str+  = case getCmd str of+    Right ("args",    rest) ->+        case toArgs rest of+            Left err -> liftIO (hPutStrLn stderr err)+            Right args -> setArgs args+    Right ("prog",    rest) ->+        case toArgs rest of+            Right [prog] -> setProg prog+            _ -> liftIO (hPutStrLn stderr "syntax: :set prog <progname>")++    Right ("prompt",           rest) ->+        setPromptString setPrompt (dropWhile isSpace rest)+                        "syntax: set prompt <string>"+    Right ("prompt-function",  rest) ->+        setPromptFunc setPrompt $ dropWhile isSpace rest+    Right ("prompt-cont",          rest) ->+        setPromptString setPromptCont (dropWhile isSpace rest)+                        "syntax: :set prompt-cont <string>"+    Right ("prompt-cont-function", rest) ->+        setPromptFunc setPromptCont $ dropWhile isSpace rest++    Right ("editor",  rest) -> setEditor  $ dropWhile isSpace rest+    Right ("stop",    rest) -> setStop    $ dropWhile isSpace rest+    Right ("local-config", rest) ->+        setLocalConfigBehaviour $ dropWhile isSpace rest+    _ -> case toArgs str of+         Left err -> liftIO (hPutStrLn stderr err)+         Right wds -> setOptions wds++setiCmd :: GhciMonad m => String -> m ()+setiCmd ""   = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags False+setiCmd "-a" = GHC.getInteractiveDynFlags >>= liftIO . showDynFlags True+setiCmd str  =+  case toArgs str of+    Left err -> liftIO (hPutStrLn stderr err)+    Right wds -> newDynFlags True wds++showOptions :: GhciMonad m => Bool -> m ()+showOptions show_all+  = do st <- getGHCiState+       dflags <- getDynFlags+       let opts = options st+       liftIO $ putStrLn (showSDoc dflags (+              text "options currently set: " <>+              if null opts+                   then text "none."+                   else hsep (map (\o -> char '+' <> text (optToStr o)) opts)+           ))+       getDynFlags >>= liftIO . showDynFlags show_all+++showDynFlags :: Bool -> DynFlags -> IO ()+showDynFlags show_all dflags = do+  showLanguages' show_all dflags+  putStrLn $ showSDoc dflags $+     text "GHCi-specific dynamic flag settings:" $$+         nest 2 (vcat (map (setting "-f" "-fno-" gopt) ghciFlags))+  putStrLn $ showSDoc dflags $+     text "other dynamic, non-language, flag settings:" $$+         nest 2 (vcat (map (setting "-f" "-fno-" gopt) others))+  putStrLn $ showSDoc dflags $+     text "warning settings:" $$+         nest 2 (vcat (map (setting "-W" "-Wno-" wopt) DynFlags.wWarningFlags))+  where+        setting prefix noPrefix test flag+          | quiet     = empty+          | is_on     = text prefix <> text name+          | otherwise = text noPrefix <> text name+          where name = flagSpecName flag+                f = flagSpecFlag flag+                is_on = test f dflags+                quiet = not show_all && test f default_dflags == is_on++        llvmConfig = (llvmTargets dflags, llvmPasses dflags)++        default_dflags = defaultDynFlags (settings dflags) llvmConfig++        (ghciFlags,others)  = partition (\f -> flagSpecFlag f `elem` flgs)+                                        DynFlags.fFlags+        flgs = [ Opt_PrintExplicitForalls+               , Opt_PrintExplicitKinds+               , Opt_PrintUnicodeSyntax+               , Opt_PrintBindResult+               , Opt_BreakOnException+               , Opt_BreakOnError+               , Opt_PrintEvldWithShow+               ]++setArgs, setOptions :: GhciMonad m => [String] -> m ()+setProg, setEditor, setStop :: GhciMonad m => String -> m ()+setLocalConfigBehaviour :: GhciMonad m => String -> m ()++setArgs args = do+  st <- getGHCiState+  wrapper <- mkEvalWrapper (progname st) args+  setGHCiState st { GhciMonad.args = args, evalWrapper = wrapper }++setProg prog = do+  st <- getGHCiState+  wrapper <- mkEvalWrapper prog (GhciMonad.args st)+  setGHCiState st { progname = prog, evalWrapper = wrapper }++setEditor cmd = modifyGHCiState (\st -> st { editor = cmd })++setLocalConfigBehaviour s+  | s == "source" =+      modifyGHCiState (\st -> st { localConfig = SourceLocalConfig })+  | s == "ignore" =+      modifyGHCiState (\st -> st { localConfig = IgnoreLocalConfig })+  | otherwise = throwGhcException+      (CmdLineError "syntax:  :set local-config { source | ignore }")++setStop str@(c:_) | isDigit c+  = do let (nm_str,rest) = break (not.isDigit) str+           nm = read nm_str+       st <- getGHCiState+       let old_breaks = breaks st+       if all ((/= nm) . fst) old_breaks+              then printForUser (text "Breakpoint" <+> ppr nm <+>+                                 text "does not exist")+              else do+       let new_breaks = map fn old_breaks+           fn (i,loc) | i == nm   = (i,loc { onBreakCmd = dropWhile isSpace rest })+                      | otherwise = (i,loc)+       setGHCiState st{ breaks = new_breaks }+setStop cmd = modifyGHCiState (\st -> st { stop = cmd })++setPrompt :: GhciMonad m => PromptFunction -> m ()+setPrompt v = modifyGHCiState (\st -> st {prompt = v})++setPromptCont :: GhciMonad m => PromptFunction -> m ()+setPromptCont v = modifyGHCiState (\st -> st {prompt_cont = v})++setPromptFunc :: GHC.GhcMonad m => (PromptFunction -> m ()) -> String -> m ()+setPromptFunc fSetPrompt s = do+    -- We explicitly annotate the type of the expression to ensure+    -- that unsafeCoerce# is passed the exact type necessary rather+    -- than a more general one+    let exprStr = "(" ++ s ++ ") :: [String] -> Int -> IO String"+    (HValue funValue) <- GHC.compileExpr exprStr+    fSetPrompt (convertToPromptFunction $ unsafeCoerce funValue)+    where+      convertToPromptFunction :: ([String] -> Int -> IO String)+                              -> PromptFunction+      convertToPromptFunction func = (\mods line -> liftIO $+                                       liftM text (func mods line))++setPromptString :: MonadIO m+                => (PromptFunction -> m ()) -> String -> String -> m ()+setPromptString fSetPrompt value err = do+  if null value+    then liftIO $ hPutStrLn stderr $ err+    else case value of+           ('\"':_) ->+             case reads value of+               [(value', xs)] | all isSpace xs ->+                 setParsedPromptString fSetPrompt value'+               _ -> liftIO $ hPutStrLn stderr+                             "Can't parse prompt string. Use Haskell syntax."+           _ ->+             setParsedPromptString fSetPrompt value++setParsedPromptString :: MonadIO m+                      => (PromptFunction -> m ()) ->  String -> m ()+setParsedPromptString fSetPrompt s = do+  case (checkPromptStringForErrors s) of+    Just err ->+      liftIO $ hPutStrLn stderr err+    Nothing ->+      fSetPrompt $ generatePromptFunctionFromString s++setOptions wds =+   do -- first, deal with the GHCi opts (+s, +t, etc.)+      let (plus_opts, minus_opts)  = partitionWith isPlus wds+      mapM_ setOpt plus_opts+      -- then, dynamic flags+      when (not (null minus_opts)) $ newDynFlags False minus_opts++newDynFlags :: GhciMonad m => Bool -> [String] -> m ()+newDynFlags interactive_only minus_opts = do+      let lopts = map noLoc minus_opts++      idflags0 <- GHC.getInteractiveDynFlags+      (idflags1, leftovers, warns) <- GHC.parseDynamicFlags idflags0 lopts++      liftIO $ handleFlagWarnings idflags1 warns+      when (not $ null leftovers)+           (throwGhcException . CmdLineError+            $ "Some flags have not been recognized: "+            ++ (concat . intersperse ", " $ map unLoc leftovers))++      when (interactive_only && packageFlagsChanged idflags1 idflags0) $ do+          liftIO $ hPutStrLn stderr "cannot set package flags with :seti; use :set"+      -- Load any new plugins+      hsc_env0 <- GHC.getSession+      idflags2 <- liftIO (initializePlugins hsc_env0 idflags1)+      GHC.setInteractiveDynFlags idflags2+      installInteractivePrint (interactivePrint idflags1) False++      dflags0 <- getDynFlags++      when (not interactive_only) $ do+        (dflags1, _, _) <- liftIO $ GHC.parseDynamicFlags dflags0 lopts+        new_pkgs <- GHC.setProgramDynFlags dflags1++        -- if the package flags changed, reset the context and link+        -- the new packages.+        hsc_env <- GHC.getSession+        let dflags2 = hsc_dflags hsc_env+        when (packageFlagsChanged dflags2 dflags0) $ do+          when (verbosity dflags2 > 0) $+            liftIO . putStrLn $+              "package flags have changed, resetting and loading new packages..."+          GHC.setTargets []+          _ <- GHC.load LoadAllTargets+          liftIO $ linkPackages hsc_env new_pkgs+          -- package flags changed, we can't re-use any of the old context+          setContextAfterLoad False []+          -- and copy the package state to the interactive DynFlags+          idflags <- GHC.getInteractiveDynFlags+          GHC.setInteractiveDynFlags+              idflags{ pkgState = pkgState dflags2+                     , pkgDatabase = pkgDatabase dflags2+                     , packageFlags = packageFlags dflags2 }++        let ld0length   = length $ ldInputs dflags0+            fmrk0length = length $ cmdlineFrameworks dflags0++            newLdInputs     = drop ld0length (ldInputs dflags2)+            newCLFrameworks = drop fmrk0length (cmdlineFrameworks dflags2)++            hsc_env' = hsc_env { hsc_dflags =+                         dflags2 { ldInputs = newLdInputs+                                 , cmdlineFrameworks = newCLFrameworks } }++        when (not (null newLdInputs && null newCLFrameworks)) $+          liftIO $ linkCmdLineLibs hsc_env'++      return ()+++unsetOptions :: GhciMonad m => String -> m ()+unsetOptions str+  =   -- first, deal with the GHCi opts (+s, +t, etc.)+     let opts = words str+         (minus_opts, rest1) = partition isMinus opts+         (plus_opts, rest2)  = partitionWith isPlus rest1+         (other_opts, rest3) = partition (`elem` map fst defaulters) rest2++         defaulters =+           [ ("args"   , setArgs default_args)+           , ("prog"   , setProg default_progname)+           , ("prompt"     , setPrompt default_prompt)+           , ("prompt-cont", setPromptCont default_prompt_cont)+           , ("editor" , liftIO findEditor >>= setEditor)+           , ("stop"   , setStop default_stop)+           ]++         no_flag ('-':'f':rest) = return ("-fno-" ++ rest)+         no_flag ('-':'X':rest) = return ("-XNo" ++ rest)+         no_flag f = throwGhcException (ProgramError ("don't know how to reverse " ++ f))++     in if (not (null rest3))+           then liftIO (putStrLn ("unknown option: '" ++ head rest3 ++ "'"))+           else do+             mapM_ (fromJust.flip lookup defaulters) other_opts++             mapM_ unsetOpt plus_opts++             no_flags <- mapM no_flag minus_opts+             when (not (null no_flags)) $ newDynFlags False no_flags++isMinus :: String -> Bool+isMinus ('-':_) = True+isMinus _ = False++isPlus :: String -> Either String String+isPlus ('+':opt) = Left opt+isPlus other     = Right other++setOpt, unsetOpt :: GhciMonad m => String -> m ()++setOpt str+  = case strToGHCiOpt str of+        Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+        Just o  -> setOption o++unsetOpt str+  = case strToGHCiOpt str of+        Nothing -> liftIO (putStrLn ("unknown option: '" ++ str ++ "'"))+        Just o  -> unsetOption o++strToGHCiOpt :: String -> (Maybe GHCiOption)+strToGHCiOpt "m" = Just Multiline+strToGHCiOpt "s" = Just ShowTiming+strToGHCiOpt "t" = Just ShowType+strToGHCiOpt "r" = Just RevertCAFs+strToGHCiOpt "c" = Just CollectInfo+strToGHCiOpt _   = Nothing++optToStr :: GHCiOption -> String+optToStr Multiline  = "m"+optToStr ShowTiming = "s"+optToStr ShowType   = "t"+optToStr RevertCAFs = "r"+optToStr CollectInfo = "c"+++-- ---------------------------------------------------------------------------+-- :show++showCmd :: forall m. GhciMonad m => String -> m ()+showCmd ""   = showOptions False+showCmd "-a" = showOptions True+showCmd str = do+    st <- getGHCiState+    dflags <- getDynFlags+    hsc_env <- GHC.getSession++    let lookupCmd :: String -> Maybe (m ())+        lookupCmd name = lookup name $ map (\(_,b,c) -> (b,c)) cmds++        -- (show in help?, command name, action)+        action :: String -> m () -> (Bool, String, m ())+        action name m = (True, name, m)++        hidden :: String -> m () -> (Bool, String, m ())+        hidden name m = (False, name, m)++        cmds =+            [ action "args"       $ liftIO $ putStrLn (show (GhciMonad.args st))+            , action "prog"       $ liftIO $ putStrLn (show (progname st))+            , action "editor"     $ liftIO $ putStrLn (show (editor st))+            , action "stop"       $ liftIO $ putStrLn (show (stop st))+            , action "imports"    $ showImports+            , action "modules"    $ showModules+            , action "bindings"   $ showBindings+            , action "linker"     $ getDynFlags >>= liftIO . (showLinkerState (hsc_dynLinker hsc_env))+            , action "breaks"     $ showBkptTable+            , action "context"    $ showContext+            , action "packages"   $ showPackages+            , action "paths"      $ showPaths+            , action "language"   $ showLanguages+            , hidden "languages"  $ showLanguages -- backwards compat+            , hidden "lang"       $ showLanguages -- useful abbreviation+            , action "targets"    $ showTargets+            ]++    case words str of+      [w] | Just action <- lookupCmd w -> action++      _ -> let helpCmds = [ text name | (True, name, _) <- cmds ]+           in throwGhcException $ CmdLineError $ showSDoc dflags+              $ hang (text "syntax:") 4+              $ hang (text ":show") 6+              $ brackets (fsep $ punctuate (text " |") helpCmds)++showiCmd :: GHC.GhcMonad m => String -> m ()+showiCmd str = do+  case words str of+        ["languages"]  -> showiLanguages -- backwards compat+        ["language"]   -> showiLanguages+        ["lang"]       -> showiLanguages -- useful abbreviation+        _ -> throwGhcException (CmdLineError ("syntax:  :showi language"))++showImports :: GhciMonad m => m ()+showImports = do+  st <- getGHCiState+  dflags <- getDynFlags+  let rem_ctx   = reverse (remembered_ctx st)+      trans_ctx = transient_ctx st++      show_one (IIModule star_m)+          = ":module +*" ++ moduleNameString star_m+      show_one (IIDecl imp) = showPpr dflags imp++  prel_iidecls <- getImplicitPreludeImports (rem_ctx ++ trans_ctx)++  let show_prel p = show_one p ++ " -- implicit"+      show_extra p = show_one (IIDecl p) ++ " -- fixed"++      trans_comment s = s ++ " -- added automatically" :: String+  --+  liftIO $ mapM_ putStrLn (map show_one rem_ctx +++                           map (trans_comment . show_one) trans_ctx +++                           map show_prel prel_iidecls +++                           map show_extra (extra_imports st))++showModules :: GHC.GhcMonad m => m ()+showModules = do+  loaded_mods <- getLoadedModules+        -- we want *loaded* modules only, see #1734+  let show_one ms = do m <- GHC.showModule ms; liftIO (putStrLn m)+  mapM_ show_one loaded_mods++getLoadedModules :: GHC.GhcMonad m => m [GHC.ModSummary]+getLoadedModules = do+  graph <- GHC.getModuleGraph+  filterM (GHC.isLoaded . GHC.ms_mod_name) (GHC.mgModSummaries graph)++showBindings :: GHC.GhcMonad m => m ()+showBindings = do+    bindings <- GHC.getBindings+    (insts, finsts) <- GHC.getInsts+    let idocs  = map GHC.pprInstanceHdr insts+        fidocs = map GHC.pprFamInst finsts+        binds = filter (not . isDerivedOccName . getOccName) bindings -- #12525+        -- See Note [Filter bindings]+    docs <- mapM makeDoc (reverse binds)+                  -- reverse so the new ones come last+    mapM_ printForUserPartWay (docs ++ idocs ++ fidocs)+  where+    makeDoc (AnId i) = pprTypeAndContents i+    makeDoc tt = do+        mb_stuff <- GHC.getInfo False (getName tt)+        return $ maybe (text "") pprTT mb_stuff++    pprTT :: (TyThing, Fixity, [GHC.ClsInst], [GHC.FamInst], SDoc) -> SDoc+    pprTT (thing, fixity, _cls_insts, _fam_insts, _docs)+      = pprTyThing showToHeader thing+        $$ show_fixity+      where+        show_fixity+            | fixity == GHC.defaultFixity  = empty+            | otherwise                    = ppr fixity <+> ppr (GHC.getName thing)+++printTyThing :: GHC.GhcMonad m => TyThing -> m ()+printTyThing tyth = printForUser (pprTyThing showToHeader tyth)++{-+Note [Filter bindings]+~~~~~~~~~~~~~~~~~~~~~~++If we don't filter the bindings returned by the function GHC.getBindings,+then the :show bindings command will also show unwanted bound names,+internally generated by GHC, eg:+    $tcFoo :: GHC.Types.TyCon = _+    $trModule :: GHC.Types.Module = _ .++The filter was introduced as a fix for #12525 [1]. Comment:1 [2] to this+ticket contains an analysis of the situation and suggests the solution+implemented above.++The same filter was also implemented to fix #11051 [3]. See the+Note [What to show to users] in compiler/main/InteractiveEval.hs++[1] https://gitlab.haskell.org/ghc/ghc/issues/12525+[2] https://gitlab.haskell.org/ghc/ghc/issues/12525#note_123489+[3] https://gitlab.haskell.org/ghc/ghc/issues/11051+-}+++showBkptTable :: GhciMonad m => m ()+showBkptTable = do+  st <- getGHCiState+  printForUser $ prettyLocations (breaks st)++showContext :: GHC.GhcMonad m => m ()+showContext = do+   resumes <- GHC.getResumeContext+   printForUser $ vcat (map pp_resume (reverse resumes))+  where+   pp_resume res =+        ptext (sLit "--> ") <> text (GHC.resumeStmt res)+        $$ nest 2 (pprStopped res)++pprStopped :: GHC.Resume -> SDoc+pprStopped res =+  ptext (sLit "Stopped in")+    <+> ((case mb_mod_name of+           Nothing -> empty+           Just mod_name -> text (moduleNameString mod_name) <> char '.')+         <> text (GHC.resumeDecl res))+    <> char ',' <+> ppr (GHC.resumeSpan res)+ where+  mb_mod_name = moduleName <$> GHC.breakInfo_module <$> GHC.resumeBreakInfo res++showPackages :: GHC.GhcMonad m => m ()+showPackages = do+  dflags <- getDynFlags+  let pkg_flags = packageFlags dflags+  liftIO $ putStrLn $ showSDoc dflags $+    text ("active package flags:"++if null pkg_flags then " none" else "") $$+      nest 2 (vcat (map pprFlag pkg_flags))++showPaths :: GHC.GhcMonad m => m ()+showPaths = do+  dflags <- getDynFlags+  liftIO $ do+    cwd <- getCurrentDirectory+    putStrLn $ showSDoc dflags $+      text "current working directory: " $$+        nest 2 (text cwd)+    let ipaths = importPaths dflags+    putStrLn $ showSDoc dflags $+      text ("module import search paths:"++if null ipaths then " none" else "") $$+        nest 2 (vcat (map text ipaths))++showLanguages :: GHC.GhcMonad m => m ()+showLanguages = getDynFlags >>= liftIO . showLanguages' False++showiLanguages :: GHC.GhcMonad m => m ()+showiLanguages = GHC.getInteractiveDynFlags >>= liftIO . showLanguages' False++showLanguages' :: Bool -> DynFlags -> IO ()+showLanguages' show_all dflags =+  putStrLn $ showSDoc dflags $ vcat+     [ text "base language is: " <>+         case language dflags of+           Nothing          -> text "Haskell2010"+           Just Haskell98   -> text "Haskell98"+           Just Haskell2010 -> text "Haskell2010"+     , (if show_all then text "all active language options:"+                    else text "with the following modifiers:") $$+          nest 2 (vcat (map (setting xopt) DynFlags.xFlags))+     ]+  where+   setting test flag+          | quiet     = empty+          | is_on     = text "-X" <> text name+          | otherwise = text "-XNo" <> text name+          where name = flagSpecName flag+                f = flagSpecFlag flag+                is_on = test f dflags+                quiet = not show_all && test f default_dflags == is_on++   llvmConfig = (llvmTargets dflags, llvmPasses dflags)++   default_dflags =+       defaultDynFlags (settings dflags) llvmConfig `lang_set`+         case language dflags of+           Nothing -> Just Haskell2010+           other   -> other++showTargets :: GHC.GhcMonad m => m ()+showTargets = mapM_ showTarget =<< GHC.getTargets+  where+    showTarget :: GHC.GhcMonad m => Target -> m ()+    showTarget (Target (TargetFile f _) _ _) = liftIO (putStrLn f)+    showTarget (Target (TargetModule m) _ _) =+      liftIO (putStrLn $ moduleNameString m)++-- -----------------------------------------------------------------------------+-- Completion++completeCmd :: String -> GHCi ()+completeCmd argLine0 = case parseLine argLine0 of+    Just ("repl", resultRange, left) -> do+        (unusedLine,compls) <- ghciCompleteWord (reverse left,"")+        let compls' = takeRange resultRange compls+        liftIO . putStrLn $ unwords [ show (length compls'), show (length compls), show (reverse unusedLine) ]+        forM_ (takeRange resultRange compls) $ \(Completion r _ _) -> do+            liftIO $ print r+    _ -> throwGhcException (CmdLineError "Syntax: :complete repl [<range>] <quoted-string-to-complete>")+  where+    parseLine argLine+        | null argLine = Nothing+        | null rest1   = Nothing+        | otherwise    = (,,) dom <$> resRange <*> s+      where+        (dom, rest1) = breakSpace argLine+        (rng, rest2) = breakSpace rest1+        resRange | head rest1 == '"' = parseRange ""+                 | otherwise         = parseRange rng+        s | head rest1 == '"' = readMaybe rest1 :: Maybe String+          | otherwise         = readMaybe rest2+        breakSpace = fmap (dropWhile isSpace) . break isSpace++    takeRange (lb,ub) = maybe id (drop . pred) lb . maybe id take ub++    -- syntax: [n-][m] with semantics "drop (n-1) . take m"+    parseRange :: String -> Maybe (Maybe Int,Maybe Int)+    parseRange s = case span isDigit s of+                   (_, "") ->+                       -- upper limit only+                       Just (Nothing, bndRead s)+                   (s1, '-' : s2)+                    | all isDigit s2 ->+                       Just (bndRead s1, bndRead s2)+                   _ ->+                       Nothing+      where+        bndRead x = if null x then Nothing else Just (read x)++++completeGhciCommand, completeMacro, completeIdentifier, completeModule,+    completeSetModule, completeSeti, completeShowiOptions,+    completeHomeModule, completeSetOptions, completeShowOptions,+    completeHomeModuleOrFile, completeExpression+    :: GhciMonad m => CompletionFunc m++-- | Provide completions for last word in a given string.+--+-- Takes a tuple of two strings.  First string is a reversed line to be+-- completed.  Second string is likely unused, 'completeCmd' always passes an+-- empty string as second item in tuple.+ghciCompleteWord :: CompletionFunc GHCi+ghciCompleteWord line@(left,_) = case firstWord of+    -- If given string starts with `:` colon, and there is only one following+    -- word then provide REPL command completions.  If there is more than one+    -- word complete either filename or builtin ghci commands or macros.+    ':':cmd     | null rest     -> completeGhciCommand line+                | otherwise     -> do+                        completion <- lookupCompletion cmd+                        completion line+    -- If given string starts with `import` keyword provide module name+    -- completions+    "import"    -> completeModule line+    -- otherwise provide identifier completions+    _           -> completeExpression line+  where+    (firstWord,rest) = break isSpace $ dropWhile isSpace $ reverse left+    lookupCompletion ('!':_) = return completeFilename+    lookupCompletion c = do+        maybe_cmd <- lookupCommand' c+        case maybe_cmd of+            Just cmd -> return (cmdCompletionFunc cmd)+            Nothing  -> return completeFilename++completeGhciCommand = wrapCompleter " " $ \w -> do+  macros <- ghci_macros <$> getGHCiState+  cmds   <- ghci_commands `fmap` getGHCiState+  let macro_names = map (':':) . map cmdName $ macros+  let command_names = map (':':) . map cmdName $ filter (not . cmdHidden) cmds+  let{ candidates = case w of+      ':' : ':' : _ -> map (':':) command_names+      _ -> nub $ macro_names ++ command_names }+  return $ filter (w `isPrefixOf`) candidates++completeMacro = wrapIdentCompleter $ \w -> do+  cmds <- ghci_macros <$> getGHCiState+  return (filter (w `isPrefixOf`) (map cmdName cmds))++completeIdentifier line@(left, _) =+  -- Note: `left` is a reversed input+  case left of+    (x:_) | isSymbolChar x -> wrapCompleter (specials ++ spaces) complete line+    _                      -> wrapIdentCompleter complete line+  where+    complete w = do+      rdrs <- GHC.getRdrNamesInScope+      dflags <- GHC.getSessionDynFlags+      return (filter (w `isPrefixOf`) (map (showPpr dflags) rdrs))++completeModule = wrapIdentCompleter $ \w -> do+  dflags <- GHC.getSessionDynFlags+  let pkg_mods = allVisibleModules dflags+  loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+  return $ filter (w `isPrefixOf`)+        $ map (showPpr dflags) $ loaded_mods ++ pkg_mods++completeSetModule = wrapIdentCompleterWithModifier "+-" $ \m w -> do+  dflags <- GHC.getSessionDynFlags+  modules <- case m of+    Just '-' -> do+      imports <- GHC.getContext+      return $ map iiModuleName imports+    _ -> do+      let pkg_mods = allVisibleModules dflags+      loaded_mods <- liftM (map GHC.ms_mod_name) getLoadedModules+      return $ loaded_mods ++ pkg_mods+  return $ filter (w `isPrefixOf`) $ map (showPpr dflags) modules++completeHomeModule = wrapIdentCompleter listHomeModules++listHomeModules :: GHC.GhcMonad m => String -> m [String]+listHomeModules w = do+    g <- GHC.getModuleGraph+    let home_mods = map GHC.ms_mod_name (GHC.mgModSummaries g)+    dflags <- getDynFlags+    return $ sort $ filter (w `isPrefixOf`)+            $ map (showPpr dflags) home_mods++completeSetOptions = wrapCompleter flagWordBreakChars $ \w -> do+  return (filter (w `isPrefixOf`) opts)+    where opts = "args":"prog":"prompt":"prompt-cont":"prompt-function":+                 "prompt-cont-function":"editor":"stop":flagList+          flagList = map head $ group $ sort allNonDeprecatedFlags++completeSeti = wrapCompleter flagWordBreakChars $ \w -> do+  return (filter (w `isPrefixOf`) flagList)+    where flagList = map head $ group $ sort allNonDeprecatedFlags++completeShowOptions = wrapCompleter flagWordBreakChars $ \w -> do+  return (filter (w `isPrefixOf`) opts)+    where opts = ["args", "prog", "editor", "stop",+                     "modules", "bindings", "linker", "breaks",+                     "context", "packages", "paths", "language", "imports"]++completeShowiOptions = wrapCompleter flagWordBreakChars $ \w -> do+  return (filter (w `isPrefixOf`) ["language"])++completeHomeModuleOrFile = completeWord Nothing filenameWordBreakChars+                $ unionComplete (fmap (map simpleCompletion) . listHomeModules)+                            listFiles++unionComplete :: Monad m => (a -> m [b]) -> (a -> m [b]) -> a -> m [b]+unionComplete f1 f2 line = do+  cs1 <- f1 line+  cs2 <- f2 line+  return (cs1 ++ cs2)++wrapCompleter :: Monad m => String -> (String -> m [String]) -> CompletionFunc m+wrapCompleter breakChars fun = completeWord Nothing breakChars+    $ fmap (map simpleCompletion . nubSort) . fun++wrapIdentCompleter :: Monad m => (String -> m [String]) -> CompletionFunc m+wrapIdentCompleter = wrapCompleter word_break_chars++wrapIdentCompleterWithModifier+  :: Monad m+  => String -> (Maybe Char -> String -> m [String]) -> CompletionFunc m+wrapIdentCompleterWithModifier modifChars fun = completeWordWithPrev Nothing word_break_chars+    $ \rest -> fmap (map simpleCompletion . nubSort) . fun (getModifier rest)+ where+  getModifier = find (`elem` modifChars)++-- | Return a list of visible module names for autocompletion.+-- (NB: exposed != visible)+allVisibleModules :: DynFlags -> [ModuleName]+allVisibleModules dflags = listVisibleModuleNames dflags++completeExpression = completeQuotedWord (Just '\\') "\"" listFiles+                        completeIdentifier+++-- -----------------------------------------------------------------------------+-- commands for debugger++sprintCmd, printCmd, forceCmd :: GHC.GhcMonad m => String -> m ()+sprintCmd = pprintClosureCommand False False+printCmd  = pprintClosureCommand True False+forceCmd  = pprintClosureCommand False True++stepCmd :: GhciMonad m => String -> m ()+stepCmd arg = withSandboxOnly ":step" $ step arg+  where+  step []         = doContinue (const True) GHC.SingleStep+  step expression = runStmt expression GHC.SingleStep >> return ()++stepLocalCmd :: GhciMonad m => String -> m ()+stepLocalCmd arg = withSandboxOnly ":steplocal" $ step arg+  where+  step expr+   | not (null expr) = stepCmd expr+   | otherwise = do+      mb_span <- getCurrentBreakSpan+      case mb_span of+        Nothing  -> stepCmd []+        Just loc -> do+           md <- fromMaybe (panic "stepLocalCmd") <$> getCurrentBreakModule+           current_toplevel_decl <- enclosingTickSpan md loc+           doContinue (`isSubspanOf` RealSrcSpan current_toplevel_decl) GHC.SingleStep++stepModuleCmd :: GhciMonad m => String -> m ()+stepModuleCmd arg = withSandboxOnly ":stepmodule" $ step arg+  where+  step expr+   | not (null expr) = stepCmd expr+   | otherwise = do+      mb_span <- getCurrentBreakSpan+      case mb_span of+        Nothing  -> stepCmd []+        Just pan -> do+           let f some_span = srcSpanFileName_maybe pan == srcSpanFileName_maybe some_span+           doContinue f GHC.SingleStep++-- | Returns the span of the largest tick containing the srcspan given+enclosingTickSpan :: GhciMonad m => Module -> SrcSpan -> m RealSrcSpan+enclosingTickSpan _ (UnhelpfulSpan _) = panic "enclosingTickSpan UnhelpfulSpan"+enclosingTickSpan md (RealSrcSpan src) = do+  ticks <- getTickArray md+  let line = srcSpanStartLine src+  ASSERT(inRange (bounds ticks) line) do+  let enclosing_spans = [ pan | (_,pan) <- ticks ! line+                               , realSrcSpanEnd pan >= realSrcSpanEnd src]+  return . head . sortBy leftmostLargestRealSrcSpan $ enclosing_spans+ where++leftmostLargestRealSrcSpan :: RealSrcSpan -> RealSrcSpan -> Ordering+leftmostLargestRealSrcSpan a b =+  (realSrcSpanStart a `compare` realSrcSpanStart b)+     `thenCmp`+  (realSrcSpanEnd b `compare` realSrcSpanEnd a)++traceCmd :: GhciMonad m => String -> m ()+traceCmd arg+  = withSandboxOnly ":trace" $ tr arg+  where+  tr []         = doContinue (const True) GHC.RunAndLogSteps+  tr expression = runStmt expression GHC.RunAndLogSteps >> return ()++continueCmd :: GhciMonad m => String -> m ()+continueCmd = noArgs $ withSandboxOnly ":continue" $ doContinue (const True) GHC.RunToCompletion++doContinue :: GhciMonad m => (SrcSpan -> Bool) -> SingleStep -> m ()+doContinue pre step = do+  runResult <- resume pre step+  _ <- afterRunStmt pre runResult+  return ()++abandonCmd :: GhciMonad m => String -> m ()+abandonCmd = noArgs $ withSandboxOnly ":abandon" $ do+  b <- GHC.abandon -- the prompt will change to indicate the new context+  when (not b) $ liftIO $ putStrLn "There is no computation running."++deleteCmd :: GhciMonad m => String -> m ()+deleteCmd argLine = withSandboxOnly ":delete" $ do+   deleteSwitch $ words argLine+   where+   deleteSwitch :: GhciMonad m => [String] -> m ()+   deleteSwitch [] =+      liftIO $ putStrLn "The delete command requires at least one argument."+   -- delete all break points+   deleteSwitch ("*":_rest) = discardActiveBreakPoints+   deleteSwitch idents = do+      mapM_ deleteOneBreak idents+      where+      deleteOneBreak :: GhciMonad m => String -> m ()+      deleteOneBreak str+         | all isDigit str = deleteBreak (read str)+         | otherwise = return ()++historyCmd :: GHC.GhcMonad m => String -> m ()+historyCmd arg+  | null arg        = history 20+  | all isDigit arg = history (read arg)+  | otherwise       = liftIO $ putStrLn "Syntax:  :history [num]"+  where+  history num = do+    resumes <- GHC.getResumeContext+    case resumes of+      [] -> liftIO $ putStrLn "Not stopped at a breakpoint"+      (r:_) -> do+        let hist = GHC.resumeHistory r+            (took,rest) = splitAt num hist+        case hist of+          [] -> liftIO $ putStrLn $+                   "Empty history. Perhaps you forgot to use :trace?"+          _  -> do+                 pans <- mapM GHC.getHistorySpan took+                 let nums  = map (printf "-%-3d:") [(1::Int)..]+                     names = map GHC.historyEnclosingDecls took+                 printForUser (vcat(zipWith3+                                 (\x y z -> x <+> y <+> z)+                                 (map text nums)+                                 (map (bold . hcat . punctuate colon . map text) names)+                                 (map (parens . ppr) pans)))+                 liftIO $ putStrLn $ if null rest then "<end of history>" else "..."++bold :: SDoc -> SDoc+bold c | do_bold   = text start_bold <> c <> text end_bold+       | otherwise = c++backCmd :: GhciMonad m => String -> m ()+backCmd arg+  | null arg        = back 1+  | all isDigit arg = back (read arg)+  | otherwise       = liftIO $ putStrLn "Syntax:  :back [num]"+  where+  back num = withSandboxOnly ":back" $ do+      (names, _, pan, _) <- GHC.back num+      printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr pan+      printTypeOfNames names+       -- run the command set with ":set stop <cmd>"+      st <- getGHCiState+      enqueueCommands [stop st]++forwardCmd :: GhciMonad m => String -> m ()+forwardCmd arg+  | null arg        = forward 1+  | all isDigit arg = forward (read arg)+  | otherwise       = liftIO $ putStrLn "Syntax:  :back [num]"+  where+  forward num = withSandboxOnly ":forward" $ do+      (names, ix, pan, _) <- GHC.forward num+      printForUser $ (if (ix == 0)+                        then ptext (sLit "Stopped at")+                        else ptext (sLit "Logged breakpoint at")) <+> ppr pan+      printTypeOfNames names+       -- run the command set with ":set stop <cmd>"+      st <- getGHCiState+      enqueueCommands [stop st]++-- handle the "break" command+breakCmd :: GhciMonad m => String -> m ()+breakCmd argLine = withSandboxOnly ":break" $ breakSwitch $ words argLine++breakSwitch :: GhciMonad m => [String] -> m ()+breakSwitch [] = do+   liftIO $ putStrLn "The break command requires at least one argument."+breakSwitch (arg1:rest)+   | looksLikeModuleName arg1 && not (null rest) = do+        md <- wantInterpretedModule arg1+        breakByModule md rest+   | all isDigit arg1 = do+        imports <- GHC.getContext+        case iiModules imports of+           (mn : _) -> do+              md <- lookupModuleName mn+              breakByModuleLine md (read arg1) rest+           [] -> do+              liftIO $ putStrLn "No modules are loaded with debugging support."+   | otherwise = do -- try parsing it as an identifier+        wantNameFromInterpretedModule noCanDo arg1 $ \name -> do+        maybe_info <- GHC.getModuleInfo (GHC.nameModule name)+        case maybe_info of+          Nothing -> noCanDo name (ptext (sLit "cannot get module info"))+          Just minf ->+               ASSERT( isExternalName name )+                    findBreakAndSet (GHC.nameModule name) $+                       findBreakForBind name (GHC.modInfoModBreaks minf)+       where+          noCanDo n why = printForUser $+                text "cannot set breakpoint on " <> ppr n <> text ": " <> why++breakByModule :: GhciMonad m => Module -> [String] -> m ()+breakByModule md (arg1:rest)+   | all isDigit arg1 = do  -- looks like a line number+        breakByModuleLine md (read arg1) rest+breakByModule _ _+   = breakSyntax++breakByModuleLine :: GhciMonad m => Module -> Int -> [String] -> m ()+breakByModuleLine md line args+   | [] <- args = findBreakAndSet md $ maybeToList . findBreakByLine line+   | [col] <- args, all isDigit col =+        findBreakAndSet md $ maybeToList . findBreakByCoord Nothing (line, read col)+   | otherwise = breakSyntax++breakSyntax :: a+breakSyntax = throwGhcException (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")++findBreakAndSet :: GhciMonad m+                => Module -> (TickArray -> [(Int, RealSrcSpan)]) -> m ()+findBreakAndSet md lookupTickTree = do+   tickArray <- getTickArray md+   (breakArray, _) <- getModBreak md+   case lookupTickTree tickArray of+      []  -> liftIO $ putStrLn $ "No breakpoints found at that location."+      some -> mapM_ (breakAt breakArray) some+ where+   breakAt breakArray (tick, pan) = do+         setBreakFlag True breakArray tick+         (alreadySet, nm) <-+               recordBreak $ BreakLocation+                       { breakModule = md+                       , breakLoc = RealSrcSpan pan+                       , breakTick = tick+                       , onBreakCmd = ""+                       }+         printForUser $+            text "Breakpoint " <> ppr nm <>+            if alreadySet+               then text " was already set at " <> ppr pan+               else text " activated at " <> ppr pan++-- When a line number is specified, the current policy for choosing+-- the best breakpoint is this:+--    - the leftmost complete subexpression on the specified line, or+--    - the leftmost subexpression starting on the specified line, or+--    - the rightmost subexpression enclosing the specified line+--+findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,RealSrcSpan)+findBreakByLine line arr+  | not (inRange (bounds arr) line) = Nothing+  | otherwise =+    listToMaybe (sortBy (leftmostLargestRealSrcSpan `on` snd)  comp)   `mplus`+    listToMaybe (sortBy (compare `on` snd) incomp) `mplus`+    listToMaybe (sortBy (flip compare `on` snd) ticks)+  where+        ticks = arr ! line++        starts_here = [ (ix,pan) | (ix, pan) <- ticks,+                        GHC.srcSpanStartLine pan == line ]++        (comp, incomp) = partition ends_here starts_here+            where ends_here (_,pan) = GHC.srcSpanEndLine pan == line++-- The aim is to find the breakpoints for all the RHSs of the+-- equations corresponding to a binding.  So we find all breakpoints+-- for+--   (a) this binder only (not a nested declaration)+--   (b) that do not have an enclosing breakpoint+findBreakForBind :: Name -> GHC.ModBreaks -> TickArray+                 -> [(BreakIndex,RealSrcSpan)]+findBreakForBind name modbreaks _ = filter (not . enclosed) ticks+  where+    ticks = [ (index, span)+            | (index, [n]) <- assocs (GHC.modBreaks_decls modbreaks),+              n == occNameString (nameOccName name),+              RealSrcSpan span <- [GHC.modBreaks_locs modbreaks ! index] ]+    enclosed (_,sp0) = any subspan ticks+      where subspan (_,sp) = sp /= sp0 &&+                         realSrcSpanStart sp <= realSrcSpanStart sp0 &&+                         realSrcSpanEnd sp0 <= realSrcSpanEnd sp++findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray+                 -> Maybe (BreakIndex,RealSrcSpan)+findBreakByCoord mb_file (line, col) arr+  | not (inRange (bounds arr) line) = Nothing+  | otherwise =+    listToMaybe (sortBy (flip compare `on` snd) contains +++                 sortBy (compare `on` snd) after_here)+  where+        ticks = arr ! line++        -- the ticks that span this coordinate+        contains = [ tick | tick@(_,pan) <- ticks, RealSrcSpan pan `spans` (line,col),+                            is_correct_file pan ]++        is_correct_file pan+                 | Just f <- mb_file = GHC.srcSpanFile pan == f+                 | otherwise         = True++        after_here = [ tick | tick@(_,pan) <- ticks,+                              GHC.srcSpanStartLine pan == line,+                              GHC.srcSpanStartCol pan >= col ]++-- For now, use ANSI bold on terminals that we know support it.+-- Otherwise, we add a line of carets under the active expression instead.+-- In particular, on Windows and when running the testsuite (which sets+-- TERM to vt100 for other reasons) we get carets.+-- We really ought to use a proper termcap/terminfo library.+do_bold :: Bool+do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]+    where mTerm = System.Environment.getEnv "TERM"+                  `catchIO` \_ -> return "TERM not set"++start_bold :: String+start_bold = "\ESC[1m"+end_bold :: String+end_bold   = "\ESC[0m"++-----------------------------------------------------------------------------+-- :where++whereCmd :: GHC.GhcMonad m => String -> m ()+whereCmd = noArgs $ do+  mstrs <- getCallStackAtCurrentBreakpoint+  case mstrs of+    Nothing -> return ()+    Just strs -> liftIO $ putStrLn (renderStack strs)++-----------------------------------------------------------------------------+-- :list++listCmd :: GhciMonad m => String -> m ()+listCmd "" = do+   mb_span <- getCurrentBreakSpan+   case mb_span of+      Nothing ->+          printForUser $ text "Not stopped at a breakpoint; nothing to list"+      Just (RealSrcSpan pan) ->+          listAround pan True+      Just pan@(UnhelpfulSpan _) ->+          do resumes <- GHC.getResumeContext+             case resumes of+                 [] -> panic "No resumes"+                 (r:_) ->+                     do let traceIt = case GHC.resumeHistory r of+                                      [] -> text "rerunning with :trace,"+                                      _ -> empty+                            doWhat = traceIt <+> text ":back then :list"+                        printForUser (text "Unable to list source for" <+>+                                      ppr pan+                                   $$ text "Try" <+> doWhat)+listCmd str = list2 (words str)++list2 :: GhciMonad m => [String] -> m ()+list2 [arg] | all isDigit arg = do+    imports <- GHC.getContext+    case iiModules imports of+        [] -> liftIO $ putStrLn "No module to list"+        (mn : _) -> do+          md <- lookupModuleName mn+          listModuleLine md (read arg)+list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do+        md <- wantInterpretedModule arg1+        listModuleLine md (read arg2)+list2 [arg] = do+        wantNameFromInterpretedModule noCanDo arg $ \name -> do+        let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)+        case loc of+            RealSrcLoc l ->+               do tickArray <- ASSERT( isExternalName name )+                               getTickArray (GHC.nameModule name)+                  let mb_span = findBreakByCoord (Just (GHC.srcLocFile l))+                                        (GHC.srcLocLine l, GHC.srcLocCol l)+                                        tickArray+                  case mb_span of+                    Nothing       -> listAround (realSrcLocSpan l) False+                    Just (_, pan) -> listAround pan False+            UnhelpfulLoc _ ->+                  noCanDo name $ text "can't find its location: " <>+                                 ppr loc+    where+        noCanDo n why = printForUser $+            text "cannot list source code for " <> ppr n <> text ": " <> why+list2  _other =+        liftIO $ putStrLn "syntax:  :list [<line> | <module> <line> | <identifier>]"++listModuleLine :: GHC.GhcMonad m => Module -> Int -> m ()+listModuleLine modl line = do+   graph <- GHC.getModuleGraph+   let this = GHC.mgLookupModule graph modl+   case this of+     Nothing -> panic "listModuleLine"+     Just summ -> do+           let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))+               loc = mkRealSrcLoc (mkFastString (filename)) line 0+           listAround (realSrcLocSpan loc) False++-- | list a section of a source file around a particular SrcSpan.+-- If the highlight flag is True, also highlight the span using+-- start_bold\/end_bold.++-- GHC files are UTF-8, so we can implement this by:+-- 1) read the file in as a BS and syntax highlight it as before+-- 2) convert the BS to String using utf-string, and write it out.+-- It would be better if we could convert directly between UTF-8 and the+-- console encoding, of course.+listAround :: MonadIO m => RealSrcSpan -> Bool -> m ()+listAround pan do_highlight = do+      contents <- liftIO $ BS.readFile (unpackFS file)+      -- Drop carriage returns to avoid duplicates, see #9367.+      let ls  = BS.split '\n' $ BS.filter (/= '\r') contents+          ls' = take (line2 - line1 + 1 + pad_before + pad_after) $+                        drop (line1 - 1 - pad_before) $ ls+          fst_line = max 1 (line1 - pad_before)+          line_nos = [ fst_line .. ]++          highlighted | do_highlight = zipWith highlight line_nos ls'+                      | otherwise    = [\p -> BS.concat[p,l] | l <- ls']++          bs_line_nos = [ BS.pack (show l ++ "  ") | l <- line_nos ]+          prefixed = zipWith ($) highlighted bs_line_nos+          output   = BS.intercalate (BS.pack "\n") prefixed++      let utf8Decoded = utf8DecodeByteString output+      liftIO $ putStrLn utf8Decoded+  where+        file  = GHC.srcSpanFile pan+        line1 = GHC.srcSpanStartLine pan+        col1  = GHC.srcSpanStartCol pan - 1+        line2 = GHC.srcSpanEndLine pan+        col2  = GHC.srcSpanEndCol pan - 1++        pad_before | line1 == 1 = 0+                   | otherwise  = 1+        pad_after = 1++        highlight | do_bold   = highlight_bold+                  | otherwise = highlight_carets++        highlight_bold no line prefix+          | no == line1 && no == line2+          = let (a,r) = BS.splitAt col1 line+                (b,c) = BS.splitAt (col2-col1) r+            in+            BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]+          | no == line1+          = let (a,b) = BS.splitAt col1 line in+            BS.concat [prefix, a, BS.pack start_bold, b]+          | no == line2+          = let (a,b) = BS.splitAt col2 line in+            BS.concat [prefix, a, BS.pack end_bold, b]+          | otherwise   = BS.concat [prefix, line]++        highlight_carets no line prefix+          | no == line1 && no == line2+          = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',+                                         BS.replicate (col2-col1) '^']+          | no == line1+          = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,+                                         prefix, line]+          | no == line2+          = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',+                                         BS.pack "^^"]+          | otherwise   = BS.concat [prefix, line]+         where+           indent = BS.pack ("  " ++ replicate (length (show no)) ' ')+           nl = BS.singleton '\n'+++-- --------------------------------------------------------------------------+-- Tick arrays++getTickArray :: GhciMonad m => Module -> m TickArray+getTickArray modl = do+   st <- getGHCiState+   let arrmap = tickarrays st+   case lookupModuleEnv arrmap modl of+      Just arr -> return arr+      Nothing  -> do+        (_breakArray, ticks) <- getModBreak modl+        let arr = mkTickArray (assocs ticks)+        setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}+        return arr++discardTickArrays :: GhciMonad m => m ()+discardTickArrays = modifyGHCiState (\st -> st {tickarrays = emptyModuleEnv})++mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray+mkTickArray ticks+  = accumArray (flip (:)) [] (1, max_line)+        [ (line, (nm,pan)) | (nm,RealSrcSpan pan) <- ticks, line <- srcSpanLines pan ]+    where+        max_line = foldr max 0 [ GHC.srcSpanEndLine sp | (_, RealSrcSpan sp) <- ticks ]+        srcSpanLines pan = [ GHC.srcSpanStartLine pan ..  GHC.srcSpanEndLine pan ]++-- don't reset the counter back to zero?+discardActiveBreakPoints :: GhciMonad m => m ()+discardActiveBreakPoints = do+   st <- getGHCiState+   mapM_ (turnOffBreak.snd) (breaks st)+   setGHCiState $ st { breaks = [] }++deleteBreak :: GhciMonad m => Int -> m ()+deleteBreak identity = do+   st <- getGHCiState+   let oldLocations    = breaks st+       (this,rest)     = partition (\loc -> fst loc == identity) oldLocations+   if null this+      then printForUser (text "Breakpoint" <+> ppr identity <+>+                         text "does not exist")+      else do+           mapM_ (turnOffBreak.snd) this+           setGHCiState $ st { breaks = rest }++turnOffBreak :: GHC.GhcMonad m => BreakLocation -> m ()+turnOffBreak loc = do+  (arr, _) <- getModBreak (breakModule loc)+  hsc_env <- GHC.getSession+  liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False++getModBreak :: GHC.GhcMonad m+            => Module -> m (ForeignRef BreakArray, Array Int SrcSpan)+getModBreak m = do+   mod_info      <- fromMaybe (panic "getModBreak") <$> GHC.getModuleInfo m+   let modBreaks  = GHC.modInfoModBreaks mod_info+   let arr        = GHC.modBreaks_flags modBreaks+   let ticks      = GHC.modBreaks_locs  modBreaks+   return (arr, ticks)++setBreakFlag :: GHC.GhcMonad m => Bool -> ForeignRef BreakArray -> Int -> m ()+setBreakFlag toggle arr i = do+  hsc_env <- GHC.getSession+  liftIO $ enableBreakpoint hsc_env arr i toggle++-- ---------------------------------------------------------------------------+-- User code exception handling++-- This is the exception handler for exceptions generated by the+-- user's code and exceptions coming from children sessions;+-- it normally just prints out the exception.  The+-- handler must be recursive, in case showing the exception causes+-- more exceptions to be raised.+--+-- Bugfix: if the user closed stdout or stderr, the flushing will fail,+-- raising another exception.  We therefore don't put the recursive+-- handler arond the flushing operation, so if stderr is closed+-- GHCi will just die gracefully rather than going into an infinite loop.+handler :: GhciMonad m => SomeException -> m Bool+handler exception = do+  flushInterpBuffers+  withSignalHandlers $+     ghciHandle handler (showException exception >> return False)++showException :: MonadIO m => SomeException -> m ()+showException se =+  liftIO $ case fromException se of+           -- omit the location for CmdLineError:+           Just (CmdLineError s)    -> putException s+           -- ditto:+           Just other_ghc_ex        -> putException (show other_ghc_ex)+           Nothing                  ->+               case fromException se of+               Just UserInterrupt -> putException "Interrupted."+               _                  -> putException ("*** Exception: " ++ show se)+  where+    putException = hPutStrLn stderr+++-----------------------------------------------------------------------------+-- recursive exception handlers++-- Don't forget to unblock async exceptions in the handler, or if we're+-- in an exception loop (eg. let a = error a in a) the ^C exception+-- may never be delivered.  Thanks to Marcin for pointing out the bug.++ghciHandle :: (HasDynFlags m, ExceptionMonad m) => (SomeException -> m a) -> m a -> m a+ghciHandle h m = gmask $ \restore -> do+                 -- Force dflags to avoid leaking the associated HscEnv+                 !dflags <- getDynFlags+                 gcatch (restore (GHC.prettyPrintGhcErrors dflags m)) $ \e -> restore (h e)++ghciTry :: ExceptionMonad m => m a -> m (Either SomeException a)+ghciTry m = fmap Right m `gcatch` \e -> return $ Left e++tryBool :: ExceptionMonad m => m a -> m Bool+tryBool m = do+    r <- ghciTry m+    case r of+      Left _  -> return False+      Right _ -> return True++-- ----------------------------------------------------------------------------+-- Utils++lookupModule :: GHC.GhcMonad m => String -> m Module+lookupModule mName = lookupModuleName (GHC.mkModuleName mName)++lookupModuleName :: GHC.GhcMonad m => ModuleName -> m Module+lookupModuleName mName = GHC.lookupModule mName Nothing++isHomeModule :: Module -> Bool+isHomeModule m = GHC.moduleUnitId m == mainUnitId++-- TODO: won't work if home dir is encoded.+-- (changeDirectory may not work either in that case.)+expandPath :: MonadIO m => String -> m String+expandPath = liftIO . expandPathIO++expandPathIO :: String -> IO String+expandPathIO p =+  case dropWhile isSpace p of+   ('~':d) -> do+        tilde <- getHomeDirectory -- will fail if HOME not defined+        return (tilde ++ '/':d)+   other ->+        return other++wantInterpretedModule :: GHC.GhcMonad m => String -> m Module+wantInterpretedModule str = wantInterpretedModuleName (GHC.mkModuleName str)++wantInterpretedModuleName :: GHC.GhcMonad m => ModuleName -> m Module+wantInterpretedModuleName modname = do+   modl <- lookupModuleName modname+   let str = moduleNameString modname+   dflags <- getDynFlags+   when (GHC.moduleUnitId modl /= thisPackage dflags) $+      throwGhcException (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))+   is_interpreted <- GHC.moduleIsInterpreted modl+   when (not is_interpreted) $+       throwGhcException (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))+   return modl++wantNameFromInterpretedModule :: GHC.GhcMonad m+                              => (Name -> SDoc -> m ())+                              -> String+                              -> (Name -> m ())+                              -> m ()+wantNameFromInterpretedModule noCanDo str and_then =+  handleSourceError GHC.printException $ do+   names <- GHC.parseName str+   case names of+      []    -> return ()+      (n:_) -> do+            let modl = ASSERT( isExternalName n ) GHC.nameModule n+            if not (GHC.isExternalName n)+               then noCanDo n $ ppr n <>+                                text " is not defined in an interpreted module"+               else do+            is_interpreted <- GHC.moduleIsInterpreted modl+            if not is_interpreted+               then noCanDo n $ text "module " <> ppr modl <>+                                text " is not interpreted"+               else and_then n
+ ghc/GHCi/UI/Info.hs view
@@ -0,0 +1,382 @@+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns        #-}++-- | Get information on modules, expressions, and identifiers+module GHCi.UI.Info+    ( ModInfo(..)+    , SpanInfo(..)+    , spanInfoFromRealSrcSpan+    , collectInfo+    , findLoc+    , findNameUses+    , findType+    , getModInfo+    ) where++import           Control.Exception+import           Control.Monad+import           Control.Monad.Trans.Class+import           Control.Monad.Trans.Except+import           Control.Monad.Trans.Maybe+import           Data.Data+import           Data.Function+import           Data.List+import           Data.Map.Strict   (Map)+import qualified Data.Map.Strict   as M+import           Data.Maybe+import           Data.Time+import           Prelude           hiding (mod,(<>))+import           System.Directory++import qualified CoreUtils+import           Desugar+import           DynFlags (HasDynFlags(..))+import           FastString+import           GHC+import           GhcMonad+import           Name+import           NameSet+import           Outputable+import           SrcLoc+import           TcHsSyn+import           Var++-- | Info about a module. This information is generated every time a+-- module is loaded.+data ModInfo = ModInfo+    { modinfoSummary    :: !ModSummary+      -- ^ Summary generated by GHC. Can be used to access more+      -- information about the module.+    , modinfoSpans      :: [SpanInfo]+      -- ^ Generated set of information about all spans in the+      -- module that correspond to some kind of identifier for+      -- which there will be type info and/or location info.+    , modinfoInfo       :: !ModuleInfo+      -- ^ Again, useful from GHC for accessing information+      -- (exports, instances, scope) from a module.+    , modinfoLastUpdate :: !UTCTime+      -- ^ The timestamp of the file used to generate this record.+    }++-- | Type of some span of source code. Most of these fields are+-- unboxed but Haddock doesn't show that.+data SpanInfo = SpanInfo+    { spaninfoSrcSpan   :: {-# UNPACK #-} !RealSrcSpan+      -- ^ The span we associate information with+    , spaninfoType      :: !(Maybe Type)+      -- ^ The 'Type' associated with the span+    , spaninfoVar       :: !(Maybe Id)+      -- ^ The actual 'Var' associated with the span, if+      -- any. This can be useful for accessing a variety of+      -- information about the identifier such as module,+      -- locality, definition location, etc.+    }++instance Outputable SpanInfo where+  ppr (SpanInfo s t i) = ppr s <+> ppr t <+> ppr i++-- | Test whether second span is contained in (or equal to) first span.+-- This is basically 'containsSpan' for 'SpanInfo'+containsSpanInfo :: SpanInfo -> SpanInfo -> Bool+containsSpanInfo = containsSpan `on` spaninfoSrcSpan++-- | Filter all 'SpanInfo' which are contained in 'SpanInfo'+spaninfosWithin :: [SpanInfo] -> SpanInfo -> [SpanInfo]+spaninfosWithin spans' si = filter (si `containsSpanInfo`) spans'++-- | Construct a 'SpanInfo' from a 'RealSrcSpan' and optionally a+-- 'Type' and an 'Id' (for 'spaninfoType' and 'spaninfoVar'+-- respectively)+spanInfoFromRealSrcSpan :: RealSrcSpan -> Maybe Type -> Maybe Id -> SpanInfo+spanInfoFromRealSrcSpan spn mty mvar =+    SpanInfo spn mty mvar++-- | Convenience wrapper around 'spanInfoFromRealSrcSpan' which needs+-- only a 'RealSrcSpan'+spanInfoFromRealSrcSpan' :: RealSrcSpan -> SpanInfo+spanInfoFromRealSrcSpan' s = spanInfoFromRealSrcSpan s Nothing Nothing++-- | Convenience wrapper around 'srcSpanFile' which results in a 'FilePath'+srcSpanFilePath :: RealSrcSpan -> FilePath+srcSpanFilePath = unpackFS . srcSpanFile++-- | Try to find the location of the given identifier at the given+-- position in the module.+findLoc :: GhcMonad m+        => Map ModuleName ModInfo+        -> RealSrcSpan+        -> String+        -> ExceptT SDoc m (ModInfo,Name,SrcSpan)+findLoc infos span0 string = do+    name  <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $+             guessModule infos (srcSpanFilePath span0)++    info  <- maybeToExceptT "No module info for current file! Try loading it?" $+             MaybeT $ pure $ M.lookup name infos++    name' <- findName infos span0 info string++    case getSrcSpan name' of+        UnhelpfulSpan{} -> do+            throwE ("Found a name, but no location information." <+>+                    "The module is:" <+>+                    maybe "<unknown>" (ppr . moduleName)+                          (nameModule_maybe name'))++        span' -> return (info,name',span')++-- | Find any uses of the given identifier in the codebase.+findNameUses :: (GhcMonad m)+             => Map ModuleName ModInfo+             -> RealSrcSpan+             -> String+             -> ExceptT SDoc m [SrcSpan]+findNameUses infos span0 string =+    locToSpans <$> findLoc infos span0 string+  where+    locToSpans (modinfo,name',span') =+        stripSurrounding (span' : map toSrcSpan spans)+      where+        toSrcSpan = RealSrcSpan . spaninfoSrcSpan+        spans = filter ((== Just name') . fmap getName . spaninfoVar)+                       (modinfoSpans modinfo)++-- | Filter out redundant spans which surround/contain other spans.+stripSurrounding :: [SrcSpan] -> [SrcSpan]+stripSurrounding xs = filter (not . isRedundant) xs+  where+    isRedundant x = any (x `strictlyContains`) xs++    (RealSrcSpan s1) `strictlyContains` (RealSrcSpan s2)+         = s1 /= s2 && s1 `containsSpan` s2+    _                `strictlyContains` _ = False++-- | Try to resolve the name located at the given position, or+-- otherwise resolve based on the current module's scope.+findName :: GhcMonad m+         => Map ModuleName ModInfo+         -> RealSrcSpan+         -> ModInfo+         -> String+         -> ExceptT SDoc m Name+findName infos span0 mi string =+    case resolveName (modinfoSpans mi) (spanInfoFromRealSrcSpan' span0) of+      Nothing -> tryExternalModuleResolution+      Just name ->+        case getSrcSpan name of+          UnhelpfulSpan {} -> tryExternalModuleResolution+          RealSrcSpan   {} -> return (getName name)+  where+    tryExternalModuleResolution =+      case find (matchName $ mkFastString string)+                (fromMaybe [] (modInfoTopLevelScope (modinfoInfo mi))) of+        Nothing -> throwE "Couldn't resolve to any modules."+        Just imported -> resolveNameFromModule infos imported++    matchName :: FastString -> Name -> Bool+    matchName str name =+      str ==+      occNameFS (getOccName name)++-- | Try to resolve the name from another (loaded) module's exports.+resolveNameFromModule :: GhcMonad m+                      => Map ModuleName ModInfo+                      -> Name+                      -> ExceptT SDoc m Name+resolveNameFromModule infos name = do+     modL <- maybe (throwE $ "No module for" <+> ppr name) return $+             nameModule_maybe name++     info <- maybe (throwE (ppr (moduleUnitId modL) <> ":" <>+                            ppr modL)) return $+             M.lookup (moduleName modL) infos++     maybe (throwE "No matching export in any local modules.") return $+         find (matchName name) (modInfoExports (modinfoInfo info))+  where+    matchName :: Name -> Name -> Bool+    matchName x y = occNameFS (getOccName x) ==+                    occNameFS (getOccName y)++-- | Try to resolve the type display from the given span.+resolveName :: [SpanInfo] -> SpanInfo -> Maybe Var+resolveName spans' si = listToMaybe $ mapMaybe spaninfoVar $+                        reverse spans' `spaninfosWithin` si++-- | Try to find the type of the given span.+findType :: GhcMonad m+         => Map ModuleName ModInfo+         -> RealSrcSpan+         -> String+         -> ExceptT SDoc m (ModInfo, Type)+findType infos span0 string = do+    name  <- maybeToExceptT "Couldn't guess that module name. Does it exist?" $+             guessModule infos (srcSpanFilePath span0)++    info  <- maybeToExceptT "No module info for current file! Try loading it?" $+             MaybeT $ pure $ M.lookup name infos++    case resolveType (modinfoSpans info) (spanInfoFromRealSrcSpan' span0) of+        Nothing -> (,) info <$> lift (exprType TM_Inst string)+        Just ty -> return (info, ty)+  where+    -- | Try to resolve the type display from the given span.+    resolveType :: [SpanInfo] -> SpanInfo -> Maybe Type+    resolveType spans' si = listToMaybe $ mapMaybe spaninfoType $+                            reverse spans' `spaninfosWithin` si++-- | Guess a module name from a file path.+guessModule :: GhcMonad m+            => Map ModuleName ModInfo -> FilePath -> MaybeT m ModuleName+guessModule infos fp = do+    target <- lift $ guessTarget fp Nothing+    case targetId target of+        TargetModule mn  -> return mn+        TargetFile fp' _ -> guessModule' fp'+  where+    guessModule' :: GhcMonad m => FilePath -> MaybeT m ModuleName+    guessModule' fp' = case findModByFp fp' of+        Just mn -> return mn+        Nothing -> do+            fp'' <- liftIO (makeRelativeToCurrentDirectory fp')++            target' <- lift $ guessTarget fp'' Nothing+            case targetId target' of+                TargetModule mn -> return mn+                _               -> MaybeT . pure $ findModByFp fp''++    findModByFp :: FilePath -> Maybe ModuleName+    findModByFp fp' = fst <$> find ((Just fp' ==) . mifp) (M.toList infos)+      where+        mifp :: (ModuleName, ModInfo) -> Maybe FilePath+        mifp = ml_hs_file . ms_location . modinfoSummary . snd+++-- | Collect type info data for the loaded modules.+collectInfo :: (GhcMonad m) => Map ModuleName ModInfo -> [ModuleName]+               -> m (Map ModuleName ModInfo)+collectInfo ms loaded = do+    df <- getDynFlags+    liftIO (filterM cacheInvalid loaded) >>= \case+        [] -> return ms+        invalidated -> do+            liftIO (putStrLn ("Collecting type info for " +++                              show (length invalidated) +++                              " module(s) ... "))++            foldM (go df) ms invalidated+  where+    go df m name = do { info <- getModInfo name; return (M.insert name info m) }+                   `gcatch`+                   (\(e :: SomeException) -> do+                         liftIO $ putStrLn+                                $ showSDocForUser df alwaysQualify+                                $ "Error while getting type info from" <+>+                                  ppr name <> ":" <+> text (show e)+                         return m)++    cacheInvalid name = case M.lookup name ms of+        Nothing -> return True+        Just mi -> do+            let fp = srcFilePath (modinfoSummary mi)+                last' = modinfoLastUpdate mi+            current <- getModificationTime fp+            exists <- doesFileExist fp+            if exists+                then return $ current /= last'+                else return True++-- | Get the source file path from a ModSummary.+-- If the .hs file is missing, and the .o file exists,+-- we return the .o file path.+srcFilePath :: ModSummary -> FilePath+srcFilePath modSum = fromMaybe obj_fp src_fp+    where+        src_fp = ml_hs_file ms_loc+        obj_fp = ml_obj_file ms_loc+        ms_loc = ms_location modSum++-- | Get info about the module: summary, types, etc.+getModInfo :: (GhcMonad m) => ModuleName -> m ModInfo+getModInfo name = do+    m <- getModSummary name+    p <- parseModule m+    typechecked <- typecheckModule p+    allTypes <- processAllTypeCheckedModule typechecked+    let i = tm_checked_module_info typechecked+    ts <- liftIO $ getModificationTime $ srcFilePath m+    return (ModInfo m allTypes i ts)++-- | Get ALL source spans in the module.+processAllTypeCheckedModule :: forall m . GhcMonad m => TypecheckedModule+                            -> m [SpanInfo]+processAllTypeCheckedModule tcm = do+    bts <- mapM getTypeLHsBind $ listifyAllSpans tcs+    ets <- mapM getTypeLHsExpr $ listifyAllSpans tcs+    pts <- mapM getTypeLPat    $ listifyAllSpans tcs+    return $ mapMaybe toSpanInfo+           $ sortBy cmpSpan+           $ catMaybes (bts ++ ets ++ pts)+  where+    tcs = tm_typechecked_source tcm++    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsBind's+    getTypeLHsBind :: LHsBind GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+    getTypeLHsBind (dL->L _spn FunBind{fun_id = pid,fun_matches = MG _ _ _})+        = pure $ Just (Just (unLoc pid),getLoc pid,varType (unLoc pid))+    getTypeLHsBind _ = pure Nothing++    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LHsExpr's+    getTypeLHsExpr :: LHsExpr GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+    getTypeLHsExpr e = do+        hs_env  <- getSession+        (_,mbe) <- liftIO $ deSugarExpr hs_env e+        return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe+      where+        mid :: Maybe Id+        mid | HsVar _ (dL->L _ i) <- unwrapVar (unLoc e) = Just i+            | otherwise                                  = Nothing++        unwrapVar (HsWrap _ _ var) = var+        unwrapVar e'               = e'++    -- | Extract 'Id', 'SrcSpan', and 'Type' for 'LPats's+    getTypeLPat :: LPat GhcTc -> m (Maybe (Maybe Id,SrcSpan,Type))+    getTypeLPat (dL->L spn pat) =+        pure (Just (getMaybeId pat,spn,hsPatType pat))+      where+        getMaybeId (VarPat _ (dL->L _ vid)) = Just vid+        getMaybeId _                        = Nothing++    -- | Get ALL source spans in the source.+    listifyAllSpans :: (HasSrcSpan a , Typeable a) => TypecheckedSource -> [a]+    listifyAllSpans = everythingAllSpans (++) [] ([] `mkQ` (\x -> [x | p x]))+      where+        p (dL->L spn _) = isGoodSrcSpan spn++    -- | Variant of @syb@'s @everything@ (which summarises all nodes+    -- in top-down, left-to-right order) with a stop-condition on 'NameSet's+    everythingAllSpans :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r+    everythingAllSpans k z f x+      | (False `mkQ` (const True :: NameSet -> Bool)) x = z+      | otherwise = foldl k (f x) (gmapQ (everythingAllSpans k z f) x)++    cmpSpan (_,a,_) (_,b,_)+      | a `isSubspanOf` b = LT+      | b `isSubspanOf` a = GT+      | otherwise         = EQ++    -- | Pretty print the types into a 'SpanInfo'.+    toSpanInfo :: (Maybe Id,SrcSpan,Type) -> Maybe SpanInfo+    toSpanInfo (n,RealSrcSpan spn,typ)+        = Just $ spanInfoFromRealSrcSpan spn (Just typ) n+    toSpanInfo _ = Nothing++-- helper stolen from @syb@ package+type GenericQ r = forall a. Data a => a -> r++mkQ :: (Typeable a, Typeable b) => r -> (b -> r) -> a -> r+(r `mkQ` br) a = maybe r br (cast a)
+ ghc/GHCi/UI/Monad.hs view
@@ -0,0 +1,536 @@+{-# LANGUAGE CPP, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-cse -fno-warn-orphans #-}+-- -fno-cse is needed for GLOBAL_VAR's to behave properly++-----------------------------------------------------------------------------+--+-- Monadery code used in InteractiveUI+--+-- (c) The GHC Team 2005-2006+--+-----------------------------------------------------------------------------++module GHCi.UI.Monad (+        GHCi(..), startGHCi,+        GHCiState(..), GhciMonad(..),+        GHCiOption(..), isOptionSet, setOption, unsetOption,+        Command(..), CommandResult(..), cmdSuccess,+        LocalConfigBehaviour(..),+        PromptFunction,+        BreakLocation(..),+        TickArray,+        getDynFlags,++        runStmt, runDecls, runDecls', resume, recordBreak, revertCAFs,+        ActionStats(..), runAndPrintStats, runWithStats, printStats,++        printForUserNeverQualify, printForUserModInfo,+        printForUser, printForUserPartWay, prettyLocations,++        compileGHCiExpr,+        initInterpBuffering,+        turnOffBuffering, turnOffBuffering_,+        flushInterpBuffers,+        mkEvalWrapper+    ) where++#include "HsVersions.h"++import GHCi.UI.Info (ModInfo)+import qualified GHC+import GhcMonad         hiding (liftIO)+import Outputable       hiding (printForUser, printForUserPartWay)+import qualified Outputable+import DynFlags+import FastString+import HscTypes+import SrcLoc+import Module+import GHCi+import GHCi.RemoteTypes+import HsSyn (ImportDecl, GhcPs, GhciLStmt, LHsDecl)+import Util++import Exception+import Numeric+import Data.Array+import Data.IORef+import Data.Time+import System.Environment+import System.IO+import Control.Monad+import Prelude hiding ((<>))++import System.Console.Haskeline (CompletionFunc, InputT)+import qualified System.Console.Haskeline as Haskeline+import Control.Monad.Trans.Class+import Control.Monad.IO.Class+import Data.Map.Strict (Map)+import qualified GHC.LanguageExtensions as LangExt++-----------------------------------------------------------------------------+-- GHCi monad++data GHCiState = GHCiState+     {+        progname       :: String,+        args           :: [String],+        evalWrapper    :: ForeignHValue, -- ^ of type @IO a -> IO a@+        prompt         :: PromptFunction,+        prompt_cont    :: PromptFunction,+        editor         :: String,+        stop           :: String,+        localConfig    :: LocalConfigBehaviour,+        options        :: [GHCiOption],+        line_number    :: !Int,         -- ^ input line+        break_ctr      :: !Int,+        breaks         :: ![(Int, BreakLocation)],+        tickarrays     :: ModuleEnv TickArray,+            -- ^ 'tickarrays' caches the 'TickArray' for loaded modules,+            -- so that we don't rebuild it each time the user sets+            -- a breakpoint.+        ghci_commands  :: [Command],+            -- ^ available ghci commands+        ghci_macros    :: [Command],+            -- ^ user-defined macros+        last_command   :: Maybe Command,+            -- ^ @:@ at the GHCi prompt repeats the last command, so we+            -- remember it here+        cmd_wrapper    :: InputT GHCi CommandResult -> InputT GHCi (Maybe Bool),+            -- ^ The command wrapper is run for each command or statement.+            -- The 'Bool' value denotes whether the command is successful and+            -- 'Nothing' means to exit GHCi.+        cmdqueue       :: [String],++        remembered_ctx :: [InteractiveImport],+            -- ^ The imports that the user has asked for, via import+            -- declarations and :module commands.  This list is+            -- persistent over :reloads (but any imports for modules+            -- that are not loaded are temporarily ignored).  After a+            -- :load, all the home-package imports are stripped from+            -- this list.+            --+            -- See bugs #2049, #1873, #1360++        transient_ctx  :: [InteractiveImport],+            -- ^ An import added automatically after a :load, usually of+            -- the most recently compiled module.  May be empty if+            -- there are no modules loaded.  This list is replaced by+            -- :load, :reload, and :add.  In between it may be modified+            -- by :module.++        extra_imports  :: [ImportDecl GhcPs],+            -- ^ These are "always-on" imports, added to the+            -- context regardless of what other imports we have.+            -- This is useful for adding imports that are required+            -- by setGHCiMonad.  Be careful adding things here:+            -- you can create ambiguities if these imports overlap+            -- with other things in scope.+            --+            -- NB. although this is not currently used by GHCi itself,+            -- it was added to support other front-ends that are based+            -- on the GHCi code.  Potentially we could also expose+            -- this functionality via GHCi commands.++        prelude_imports :: [ImportDecl GhcPs],+            -- ^ These imports are added to the context when+            -- -XImplicitPrelude is on and we don't have a *-module+            -- in the context.  They can also be overridden by another+            -- import for the same module, e.g.+            -- "import Prelude hiding (map)"++        ghc_e :: Bool, -- ^ True if this is 'ghc -e' (or runghc)++        short_help :: String,+            -- ^ help text to display to a user+        long_help  :: String,+        lastErrorLocations :: IORef [(FastString, Int)],++        mod_infos  :: !(Map ModuleName ModInfo),++        flushStdHandles :: ForeignHValue,+            -- ^ @hFlush stdout; hFlush stderr@ in the interpreter+        noBuffering :: ForeignHValue+            -- ^ @hSetBuffering NoBuffering@ for stdin/stdout/stderr+     }++type TickArray = Array Int [(GHC.BreakIndex,RealSrcSpan)]++-- | A GHCi command+data Command+   = Command+   { cmdName           :: String+     -- ^ Name of GHCi command (e.g. "exit")+   , cmdAction         :: String -> InputT GHCi Bool+     -- ^ The 'Bool' value denotes whether to exit GHCi+   , cmdHidden         :: Bool+     -- ^ Commands which are excluded from default completion+     -- and @:help@ summary. This is usually set for commands not+     -- useful for interactive use but rather for IDEs.+   , cmdCompletionFunc :: CompletionFunc GHCi+     -- ^ 'CompletionFunc' for arguments+   }++data CommandResult+   = CommandComplete+   { cmdInput :: String+   , cmdResult :: Either SomeException (Maybe Bool)+   , cmdStats :: ActionStats+   }+   | CommandIncomplete+     -- ^ Unterminated multiline command+   deriving Show++cmdSuccess :: Haskeline.MonadException m => CommandResult -> m (Maybe Bool)+cmdSuccess CommandComplete{ cmdResult = Left e } = liftIO $ throwIO e+cmdSuccess CommandComplete{ cmdResult = Right r } = return r+cmdSuccess CommandIncomplete = return $ Just True++type PromptFunction = [String]+                   -> Int+                   -> GHCi SDoc++data GHCiOption+        = ShowTiming            -- show time/allocs after evaluation+        | ShowType              -- show the type of expressions+        | RevertCAFs            -- revert CAFs after every evaluation+        | Multiline             -- use multiline commands+        | CollectInfo           -- collect and cache information about+                                -- modules after load+        deriving Eq++-- | Treatment of ./.ghci files.  For now we either load or+-- ignore.  But later we could implement a "safe mode" where+-- only safe operations are performed.+--+data LocalConfigBehaviour+  = SourceLocalConfig+  | IgnoreLocalConfig+  deriving (Eq)++data BreakLocation+   = BreakLocation+   { breakModule :: !GHC.Module+   , breakLoc    :: !SrcSpan+   , breakTick   :: {-# UNPACK #-} !Int+   , onBreakCmd  :: String+   }++instance Eq BreakLocation where+  loc1 == loc2 = breakModule loc1 == breakModule loc2 &&+                 breakTick loc1   == breakTick loc2++prettyLocations :: [(Int, BreakLocation)] -> SDoc+prettyLocations []   = text "No active breakpoints."+prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs++instance Outputable BreakLocation where+   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>+                if null (onBreakCmd loc)+                   then Outputable.empty+                   else doubleQuotes (text (onBreakCmd loc))++recordBreak+  :: GhciMonad m => BreakLocation -> m (Bool{- was already present -}, Int)+recordBreak brkLoc = do+   st <- getGHCiState+   let oldActiveBreaks = breaks st+   -- don't store the same break point twice+   case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of+     (nm:_) -> return (True, nm)+     [] -> do+      let oldCounter = break_ctr st+          newCounter = oldCounter + 1+      setGHCiState $ st { break_ctr = newCounter,+                          breaks = (oldCounter, brkLoc) : oldActiveBreaks+                        }+      return (False, oldCounter)++newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> Ghc a }++reflectGHCi :: (Session, IORef GHCiState) -> GHCi a -> IO a+reflectGHCi (s, gs) m = unGhc (unGHCi m gs) s++startGHCi :: GHCi a -> GHCiState -> Ghc a+startGHCi g state = do ref <- liftIO $ newIORef state; unGHCi g ref++instance Functor GHCi where+    fmap = liftM++instance Applicative GHCi where+    pure a = GHCi $ \_ -> pure a+    (<*>) = ap++instance Monad GHCi where+  (GHCi m) >>= k  =  GHCi $ \s -> m s >>= \a -> unGHCi (k a) s++class GhcMonad m => GhciMonad m where+  getGHCiState    :: m GHCiState+  setGHCiState    :: GHCiState -> m ()+  modifyGHCiState :: (GHCiState -> GHCiState) -> m ()+  reifyGHCi       :: ((Session, IORef GHCiState) -> IO a) -> m a++instance GhciMonad GHCi where+  getGHCiState      = GHCi $ \r -> liftIO $ readIORef r+  setGHCiState s    = GHCi $ \r -> liftIO $ writeIORef r s+  modifyGHCiState f = GHCi $ \r -> liftIO $ modifyIORef r f+  reifyGHCi f       = GHCi $ \r -> reifyGhc $ \s -> f (s, r)++instance GhciMonad (InputT GHCi) where+  getGHCiState    = lift getGHCiState+  setGHCiState    = lift . setGHCiState+  modifyGHCiState = lift . modifyGHCiState+  reifyGHCi       = lift . reifyGHCi++liftGhc :: Ghc a -> GHCi a+liftGhc m = GHCi $ \_ -> m++instance MonadIO GHCi where+  liftIO = liftGhc . liftIO++instance HasDynFlags GHCi where+  getDynFlags = getSessionDynFlags++instance GhcMonad GHCi where+  setSession s' = liftGhc $ setSession s'+  getSession    = liftGhc $ getSession++instance HasDynFlags (InputT GHCi) where+  getDynFlags = lift getDynFlags++instance GhcMonad (InputT GHCi) where+  setSession = lift . setSession+  getSession = lift getSession++instance ExceptionMonad GHCi where+  gcatch m h = GHCi $ \r -> unGHCi m r `gcatch` (\e -> unGHCi (h e) r)+  gmask f =+      GHCi $ \s -> gmask $ \io_restore ->+                             let+                                g_restore (GHCi m) = GHCi $ \s' -> io_restore (m s')+                             in+                                unGHCi (f g_restore) s++instance Haskeline.MonadException Ghc where+  controlIO f = Ghc $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let+                    run' = Haskeline.RunIO (fmap (Ghc . const) . run . flip unGhc s)+                    in fmap (flip unGhc s) $ f run'++instance Haskeline.MonadException GHCi where+  controlIO f = GHCi $ \s -> Haskeline.controlIO $ \(Haskeline.RunIO run) -> let+                    run' = Haskeline.RunIO (fmap (GHCi . const) . run . flip unGHCi s)+                    in fmap (flip unGHCi s) $ f run'++instance ExceptionMonad (InputT GHCi) where+  gcatch = Haskeline.catch+  gmask f = Haskeline.liftIOOp gmask (f . Haskeline.liftIOOp_)++isOptionSet :: GhciMonad m => GHCiOption -> m Bool+isOptionSet opt+ = do st <- getGHCiState+      return (opt `elem` options st)++setOption :: GhciMonad m => GHCiOption -> m ()+setOption opt+ = do st <- getGHCiState+      setGHCiState (st{ options = opt : filter (/= opt) (options st) })++unsetOption :: GhciMonad m => GHCiOption -> m ()+unsetOption opt+ = do st <- getGHCiState+      setGHCiState (st{ options = filter (/= opt) (options st) })++printForUserNeverQualify :: GhcMonad m => SDoc -> m ()+printForUserNeverQualify doc = do+  dflags <- getDynFlags+  liftIO $ Outputable.printForUser dflags stdout neverQualify doc++printForUserModInfo :: GhcMonad m => GHC.ModuleInfo -> SDoc -> m ()+printForUserModInfo info doc = do+  dflags <- getDynFlags+  mUnqual <- GHC.mkPrintUnqualifiedForModule info+  unqual <- maybe GHC.getPrintUnqual return mUnqual+  liftIO $ Outputable.printForUser dflags stdout unqual doc++printForUser :: GhcMonad m => SDoc -> m ()+printForUser doc = do+  unqual <- GHC.getPrintUnqual+  dflags <- getDynFlags+  liftIO $ Outputable.printForUser dflags stdout unqual doc++printForUserPartWay :: GhcMonad m => SDoc -> m ()+printForUserPartWay doc = do+  unqual <- GHC.getPrintUnqual+  dflags <- getDynFlags+  liftIO $ Outputable.printForUserPartWay dflags stdout (pprUserLength dflags) unqual doc++-- | Run a single Haskell expression+runStmt+  :: GhciMonad m+  => GhciLStmt GhcPs -> String -> GHC.SingleStep -> m (Maybe GHC.ExecResult)+runStmt stmt stmt_text step = do+  st <- getGHCiState+  GHC.handleSourceError (\e -> do GHC.printException e; return Nothing) $ do+    let opts = GHC.execOptions+                  { GHC.execSourceFile = progname st+                  , GHC.execLineNumber = line_number st+                  , GHC.execSingleStep = step+                  , GHC.execWrap = \fhv -> EvalApp (EvalThis (evalWrapper st))+                                                   (EvalThis fhv) }+    Just <$> GHC.execStmt' stmt stmt_text opts++runDecls :: GhciMonad m => String -> m (Maybe [GHC.Name])+runDecls decls = do+  st <- getGHCiState+  reifyGHCi $ \x ->+    withProgName (progname st) $+    withArgs (args st) $+      reflectGHCi x $ do+        GHC.handleSourceError (\e -> do GHC.printException e;+                                        return Nothing) $ do+          r <- GHC.runDeclsWithLocation (progname st) (line_number st) decls+          return (Just r)++runDecls' :: GhciMonad m => [LHsDecl GhcPs] -> m (Maybe [GHC.Name])+runDecls' decls = do+  st <- getGHCiState+  reifyGHCi $ \x ->+    withProgName (progname st) $+    withArgs (args st) $+    reflectGHCi x $+      GHC.handleSourceError+        (\e -> do GHC.printException e;+                  return Nothing)+        (Just <$> GHC.runParsedDecls decls)++resume :: GhciMonad m => (SrcSpan -> Bool) -> GHC.SingleStep -> m GHC.ExecResult+resume canLogSpan step = do+  st <- getGHCiState+  reifyGHCi $ \x ->+    withProgName (progname st) $+    withArgs (args st) $+      reflectGHCi x $ do+        GHC.resumeExec canLogSpan step++-- --------------------------------------------------------------------------+-- timing & statistics++data ActionStats = ActionStats+  { actionAllocs :: Maybe Integer+  , actionElapsedTime :: Double+  } deriving Show++runAndPrintStats+  :: GhciMonad m+  => (a -> Maybe Integer)+  -> m a+  -> m (ActionStats, Either SomeException a)+runAndPrintStats getAllocs action = do+  result <- runWithStats getAllocs action+  case result of+    (stats, Right{}) -> do+      showTiming <- isOptionSet ShowTiming+      when showTiming $ do+        dflags  <- getDynFlags+        liftIO $ printStats dflags stats+    _ -> return ()+  return result++runWithStats+  :: ExceptionMonad m+  => (a -> Maybe Integer) -> m a -> m (ActionStats, Either SomeException a)+runWithStats getAllocs action = do+  t0 <- liftIO getCurrentTime+  result <- gtry action+  let allocs = either (const Nothing) getAllocs result+  t1 <- liftIO getCurrentTime+  let elapsedTime = realToFrac $ t1 `diffUTCTime` t0+  return (ActionStats allocs elapsedTime, result)++printStats :: DynFlags -> ActionStats -> IO ()+printStats dflags ActionStats{actionAllocs = mallocs, actionElapsedTime = secs}+   = do let secs_str = showFFloat (Just 2) secs+        putStrLn (showSDoc dflags (+                 parens (text (secs_str "") <+> text "secs" <> comma <+>+                         case mallocs of+                           Nothing -> empty+                           Just allocs ->+                             text (separateThousands allocs) <+> text "bytes")))+  where+    separateThousands n = reverse . sep . reverse . show $ n+      where sep n'+              | n' `lengthAtMost` 3 = n'+              | otherwise           = take 3 n' ++ "," ++ sep (drop 3 n')++-----------------------------------------------------------------------------+-- reverting CAFs++revertCAFs :: GhciMonad m => m ()+revertCAFs = do+  hsc_env <- GHC.getSession+  liftIO $ iservCmd hsc_env RtsRevertCAFs+  s <- getGHCiState+  when (not (ghc_e s)) turnOffBuffering+     -- Have to turn off buffering again, because we just+     -- reverted stdout, stderr & stdin to their defaults.+++-----------------------------------------------------------------------------+-- To flush buffers for the *interpreted* computation we need+-- to refer to *its* stdout/stderr handles++-- | Compile "hFlush stdout; hFlush stderr" once, so we can use it repeatedly+initInterpBuffering :: Ghc (ForeignHValue, ForeignHValue)+initInterpBuffering = do+  nobuf <- compileGHCiExpr $+   "do { System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering; " +++       " System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering; " +++       " System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering }"+  flush <- compileGHCiExpr $+   "do { System.IO.hFlush System.IO.stdout; " +++       " System.IO.hFlush System.IO.stderr }"+  return (nobuf, flush)++-- | Invoke "hFlush stdout; hFlush stderr" in the interpreter+flushInterpBuffers :: GhciMonad m => m ()+flushInterpBuffers = do+  st <- getGHCiState+  hsc_env <- GHC.getSession+  liftIO $ evalIO hsc_env (flushStdHandles st)++-- | Turn off buffering for stdin, stdout, and stderr in the interpreter+turnOffBuffering :: GhciMonad m => m ()+turnOffBuffering = do+  st <- getGHCiState+  turnOffBuffering_ (noBuffering st)++turnOffBuffering_ :: GhcMonad m => ForeignHValue -> m ()+turnOffBuffering_ fhv = do+  hsc_env <- getSession+  liftIO $ evalIO hsc_env fhv++mkEvalWrapper :: GhcMonad m => String -> [String] ->  m ForeignHValue+mkEvalWrapper progname args =+  compileGHCiExpr $+    "\\m -> System.Environment.withProgName " ++ show progname +++    "(System.Environment.withArgs " ++ show args ++ " m)"++compileGHCiExpr :: GhcMonad m => String -> m ForeignHValue+compileGHCiExpr expr =+  withTempSession mkTempSession $ GHC.compileExprRemote expr+  where+    mkTempSession hsc_env = hsc_env+      { hsc_dflags = (hsc_dflags hsc_env) {+        -- Running GHCi's internal expression is incompatible with -XSafe.+          -- We temporarily disable any Safe Haskell settings while running+          -- GHCi internal expressions. (see #12509)+        safeHaskell = Sf_None+      }+        -- RebindableSyntax can wreak havoc with GHCi in several ways+          -- (see #13385 and #14342 for examples), so we temporarily+          -- disable it too.+          `xopt_unset` LangExt.RebindableSyntax+          -- We heavily depend on -fimplicit-import-qualified to compile expr+          -- with fully qualified names without imports.+          `gopt_set` Opt_ImplicitImportQualified+      }
+ ghc/GHCi/UI/Tags.hs view
@@ -0,0 +1,216 @@+-----------------------------------------------------------------------------+--+-- GHCi's :ctags and :etags commands+--+-- (c) The GHC Team 2005-2007+--+-----------------------------------------------------------------------------++{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+module GHCi.UI.Tags (+  createCTagsWithLineNumbersCmd,+  createCTagsWithRegExesCmd,+  createETagsFileCmd+) where++import Exception+import GHC+import GHCi.UI.Monad+import Outputable++-- ToDo: figure out whether we need these, and put something appropriate+-- into the GHC API instead+import Name (nameOccName)+import OccName (pprOccName)+import ConLike+import MonadUtils++import Control.Monad+import Data.Function+import Data.List+import Data.Maybe+import Data.Ord+import DriverPhases+import Panic+import Prelude+import System.Directory+import System.IO+import System.IO.Error++-----------------------------------------------------------------------------+-- create tags file for currently loaded modules.++createCTagsWithLineNumbersCmd, createCTagsWithRegExesCmd,+  createETagsFileCmd :: String -> GHCi ()++createCTagsWithLineNumbersCmd ""   =+  ghciCreateTagsFile CTagsWithLineNumbers "tags"+createCTagsWithLineNumbersCmd file =+  ghciCreateTagsFile CTagsWithLineNumbers file++createCTagsWithRegExesCmd ""   =+  ghciCreateTagsFile CTagsWithRegExes "tags"+createCTagsWithRegExesCmd file =+  ghciCreateTagsFile CTagsWithRegExes file++createETagsFileCmd ""    = ghciCreateTagsFile ETags "TAGS"+createETagsFileCmd file  = ghciCreateTagsFile ETags file++data TagsKind = ETags | CTagsWithLineNumbers | CTagsWithRegExes++ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()+ghciCreateTagsFile kind file = do+  createTagsFile kind file++-- ToDo:+--      - remove restriction that all modules must be interpreted+--        (problem: we don't know source locations for entities unless+--        we compiled the module.+--+--      - extract createTagsFile so it can be used from the command-line+--        (probably need to fix first problem before this is useful).+--+createTagsFile :: TagsKind -> FilePath -> GHCi ()+createTagsFile tagskind tagsFile = do+  graph <- GHC.getModuleGraph+  mtags <- mapM listModuleTags (map GHC.ms_mod $ GHC.mgModSummaries graph)+  either_res <- liftIO $ collateAndWriteTags tagskind tagsFile $ concat mtags+  case either_res of+    Left e  -> liftIO $ hPutStrLn stderr $ ioeGetErrorString e+    Right _ -> return ()+++listModuleTags :: GHC.Module -> GHCi [TagInfo]+listModuleTags m = do+  is_interpreted <- GHC.moduleIsInterpreted m+  -- should we just skip these?+  when (not is_interpreted) $+    let mName = GHC.moduleNameString (GHC.moduleName m) in+    throwGhcException (CmdLineError ("module '" ++ mName ++ "' is not interpreted"))+  mbModInfo <- GHC.getModuleInfo m+  case mbModInfo of+    Nothing -> return []+    Just mInfo -> do+       dflags <- getDynFlags+       mb_print_unqual <- GHC.mkPrintUnqualifiedForModule mInfo+       let unqual = fromMaybe GHC.alwaysQualify mb_print_unqual+       let names = fromMaybe [] $GHC.modInfoTopLevelScope mInfo+       let localNames = filter ((m==) . nameModule) names+       mbTyThings <- mapM GHC.lookupName localNames+       return $! [ tagInfo dflags unqual exported kind name realLoc+                     | tyThing <- catMaybes mbTyThings+                     , let name = getName tyThing+                     , let exported = GHC.modInfoIsExportedName mInfo name+                     , let kind = tyThing2TagKind tyThing+                     , let loc = srcSpanStart (nameSrcSpan name)+                     , RealSrcLoc realLoc <- [loc]+                     ]++  where+    tyThing2TagKind (AnId _)                 = 'v'+    tyThing2TagKind (AConLike RealDataCon{}) = 'd'+    tyThing2TagKind (AConLike PatSynCon{})   = 'p'+    tyThing2TagKind (ATyCon _)               = 't'+    tyThing2TagKind (ACoAxiom _)             = 'x'+++data TagInfo = TagInfo+  { tagExported :: Bool -- is tag exported+  , tagKind :: Char   -- tag kind+  , tagName :: String -- tag name+  , tagFile :: String -- file name+  , tagLine :: Int    -- line number+  , tagCol :: Int     -- column number+  , tagSrcInfo :: Maybe (String,Integer)  -- source code line and char offset+  }+++-- get tag info, for later translation into Vim or Emacs style+tagInfo :: DynFlags -> PrintUnqualified -> Bool -> Char -> Name -> RealSrcLoc+        -> TagInfo+tagInfo dflags unqual exported kind name loc+    = TagInfo exported kind+        (showSDocForUser dflags unqual $ pprOccName (nameOccName name))+        (showSDocForUser dflags unqual $ ftext (srcLocFile loc))+        (srcLocLine loc) (srcLocCol loc) Nothing++-- throw an exception when someone tries to overwrite existing source file (fix for #10989)+writeTagsSafely :: FilePath -> String -> IO ()+writeTagsSafely file str = do+    dfe <- doesFileExist file+    if dfe && isSourceFilename file+        then throwGhcException (CmdLineError (file ++ " is existing source file. " +++             "Please specify another file name to store tags data"))+        else writeFile file str++collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())+-- ctags style with the Ex expression being just the line number, Vim et al+collateAndWriteTags CTagsWithLineNumbers file tagInfos = do+  let tags = unlines $ sort $ map showCTag tagInfos+  tryIO (writeTagsSafely file tags)++-- ctags style with the Ex expression being a regex searching the line, Vim et al+collateAndWriteTags CTagsWithRegExes file tagInfos = do -- ctags style, Vim et al+  tagInfoGroups <- makeTagGroupsWithSrcInfo tagInfos+  let tags = unlines $ sort $ map showCTag $concat tagInfoGroups+  tryIO (writeTagsSafely file tags)++collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs+  tagInfoGroups <- makeTagGroupsWithSrcInfo $filter tagExported tagInfos+  let tagGroups = map processGroup tagInfoGroups+  tryIO (writeTagsSafely file $ concat tagGroups)++  where+    processGroup [] = throwGhcException (CmdLineError "empty tag file group??")+    processGroup group@(tagInfo:_) =+      let tags = unlines $ map showETag group in+      "\x0c\n" ++ tagFile tagInfo ++ "," ++ show (length tags) ++ "\n" ++ tags+++makeTagGroupsWithSrcInfo :: [TagInfo] -> IO [[TagInfo]]+makeTagGroupsWithSrcInfo tagInfos = do+  let groups = groupBy ((==) `on` tagFile) $ sortBy (comparing tagFile) tagInfos+  mapM addTagSrcInfo groups++  where+    addTagSrcInfo [] = throwGhcException (CmdLineError "empty tag file group??")+    addTagSrcInfo group@(tagInfo:_) = do+      file <- readFile $tagFile tagInfo+      let sortedGroup = sortBy (comparing tagLine) group+      return $ perFile sortedGroup 1 0 $ lines file++    perFile allTags@(tag:tags) cnt pos allLs@(l:ls)+     | tagLine tag > cnt =+         perFile allTags (cnt+1) (pos+fromIntegral(length l)) ls+     | tagLine tag == cnt =+         tag{ tagSrcInfo = Just(l,pos) } : perFile tags cnt pos allLs+    perFile _ _ _ _ = []+++-- ctags format, for Vim et al+showCTag :: TagInfo -> String+showCTag ti =+  tagName ti ++ "\t" ++ tagFile ti ++ "\t" ++ tagCmd ++ ";\"\t" +++    tagKind ti : ( if tagExported ti then "" else "\tfile:" )++  where+    tagCmd =+      case tagSrcInfo ti of+        Nothing -> show $tagLine ti+        Just (srcLine,_) -> "/^"++ foldr escapeSlashes [] srcLine ++"$/"++      where+        escapeSlashes '/' r = '\\' : '/' : r+        escapeSlashes '\\' r = '\\' : '\\' : r+        escapeSlashes c r = c : r+++-- etags format, for Emacs/XEmacs+showETag :: TagInfo -> String+showETag TagInfo{ tagName = tag, tagLine = lineNo, tagCol = colNo,+                  tagSrcInfo = Just (srcLine,charPos) }+    =  take (colNo - 1) srcLine ++ tag+    ++ "\x7f" ++ tag+    ++ "\x01" ++ show lineNo+    ++ "," ++ show charPos+showETag _ = throwGhcException (CmdLineError "missing source file info in showETag")
+ ghc/GHCi/Util.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE MagicHash, UnboxedTuples #-}++-- | Utilities for GHCi.+module GHCi.Util where++-- NOTE: Avoid importing GHC modules here, because the primary purpose+-- of this module is to not use UnboxedTuples in a module that imports+-- lots of other modules.  See issue#13101 for more info.++import GHC.Exts+import GHC.Types++anyToPtr :: a -> IO (Ptr ())+anyToPtr x =+  IO (\s -> case anyToAddr# x s of+              (# s', addr #) -> (# s', Ptr addr #)) :: IO (Ptr ())
+ ghc/Main.hs view
@@ -0,0 +1,963 @@+{-# LANGUAGE CPP, NondecreasingIndentation, TupleSections #-}+{-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}++-----------------------------------------------------------------------------+--+-- GHC Driver program+--+-- (c) The University of Glasgow 2005+--+-----------------------------------------------------------------------------++module Main (main) where++-- The official GHC API+import qualified GHC+import GHC              ( -- DynFlags(..), HscTarget(..),+                          -- GhcMode(..), GhcLink(..),+                          Ghc, GhcMonad(..),+                          LoadHowMuch(..) )+import CmdLineParser++-- Implementations of the various modes (--show-iface, mkdependHS. etc.)+import LoadIface        ( showIface )+import HscMain          ( newHscEnv )+import DriverPipeline   ( oneShot, compileFile )+import DriverMkDepend   ( doMkDependHS )+import DriverBkp   ( doBackpack )+#if defined(GHCI)+import GHCi.UI          ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings )+#endif++-- Frontend plugins+#if defined(GHCI)+import DynamicLoading   ( loadFrontendPlugin, initializePlugins  )+import Plugins+#else+import DynamicLoading   ( pluginError )+#endif+import Module           ( ModuleName )+++-- Various other random stuff that we need+import GHC.HandleEncoding+import Config+import Constants+import HscTypes+import Packages         ( pprPackages, pprPackagesSimple )+import DriverPhases+import BasicTypes       ( failed )+import DynFlags hiding (WarnReason(..))+import ErrUtils+import FastString+import Outputable+import SrcLoc+import Util+import Panic+import UniqSupply+import MonadUtils       ( liftIO )++-- Imports for --abi-hash+import LoadIface           ( loadUserInterface )+import Module              ( mkModuleName )+import Finder              ( findImportedModule, cannotFindModule )+import TcRnMonad           ( initIfaceCheck )+import Binary              ( openBinMem, put_ )+import BinFingerprint      ( fingerprintBinMem )++-- Standard Haskell libraries+import System.IO+import System.Environment+import System.Exit+import System.FilePath+import Control.Monad+import Data.Char+import Data.List+import Data.Maybe+import Prelude++-----------------------------------------------------------------------------+-- ToDo:++-- time commands when run with -v+-- user ways+-- Win32 support: proper signal handling+-- reading the package configuration file is too slow+-- -K<size>++-----------------------------------------------------------------------------+-- GHC's command-line interface++main :: IO ()+main = do+   initGCStatistics -- See Note [-Bsymbolic and hooks]+   hSetBuffering stdout LineBuffering+   hSetBuffering stderr LineBuffering++   configureHandleEncoding+   GHC.defaultErrorHandler defaultFatalMessager defaultFlushOut $ do+    -- 1. extract the -B flag from the args+    argv0 <- getArgs++    let (minusB_args, argv1) = partition ("-B" `isPrefixOf`) argv0+        mbMinusB | null minusB_args = Nothing+                 | otherwise = Just (drop 2 (last minusB_args))++    let argv2 = map (mkGeneralLocated "on the commandline") argv1++    -- 2. Parse the "mode" flags (--make, --interactive etc.)+    (mode, argv3, flagWarnings) <- parseModeFlags argv2++    -- If all we want to do is something like showing the version number+    -- then do it now, before we start a GHC session etc. This makes+    -- getting basic information much more resilient.++    -- In particular, if we wait until later before giving the version+    -- number then bootstrapping gets confused, as it tries to find out+    -- what version of GHC it's using before package.conf exists, so+    -- starting the session fails.+    case mode of+        Left preStartupMode ->+            do case preStartupMode of+                   ShowSupportedExtensions   -> showSupportedExtensions+                   ShowVersion               -> showVersion+                   ShowNumVersion            -> putStrLn cProjectVersion+                   ShowOptions isInteractive -> showOptions isInteractive+        Right postStartupMode ->+            -- start our GHC session+            GHC.runGhc mbMinusB $ do++            dflags <- GHC.getSessionDynFlags++            case postStartupMode of+                Left preLoadMode ->+                    liftIO $ do+                        case preLoadMode of+                            ShowInfo               -> showInfo dflags+                            ShowGhcUsage           -> showGhcUsage  dflags+                            ShowGhciUsage          -> showGhciUsage dflags+                            PrintWithDynFlags f    -> putStrLn (f dflags)+                Right postLoadMode ->+                    main' postLoadMode dflags argv3 flagWarnings++main' :: PostLoadMode -> DynFlags -> [Located String] -> [Warn]+      -> Ghc ()+main' postLoadMode dflags0 args flagWarnings = do+  -- set the default GhcMode, HscTarget and GhcLink.  The HscTarget+  -- can be further adjusted on a module by module basis, using only+  -- the -fvia-C and -fasm flags.  If the default HscTarget is not+  -- HscC or HscAsm, -fvia-C and -fasm have no effect.+  let dflt_target = hscTarget dflags0+      (mode, lang, link)+         = case postLoadMode of+               DoInteractive   -> (CompManager, HscInterpreted, LinkInMemory)+               DoEval _        -> (CompManager, HscInterpreted, LinkInMemory)+               DoMake          -> (CompManager, dflt_target,    LinkBinary)+               DoBackpack      -> (CompManager, dflt_target,    LinkBinary)+               DoMkDependHS    -> (MkDepend,    dflt_target,    LinkBinary)+               DoAbiHash       -> (OneShot,     dflt_target,    LinkBinary)+               _               -> (OneShot,     dflt_target,    LinkBinary)++  let dflags1 = dflags0{ ghcMode   = mode,+                         hscTarget = lang,+                         ghcLink   = link,+                         verbosity = case postLoadMode of+                                         DoEval _ -> 0+                                         _other   -> 1+                        }++      -- turn on -fimplicit-import-qualified for GHCi now, so that it+      -- can be overriden from the command-line+      -- XXX: this should really be in the interactive DynFlags, but+      -- we don't set that until later in interactiveUI+      -- We also set -fignore-optim-changes and -fignore-hpc-changes,+      -- which are program-level options. Again, this doesn't really+      -- feel like the right place to handle this, but we don't have+      -- a great story for the moment.+      dflags2  | DoInteractive <- postLoadMode = def_ghci_flags+               | DoEval _      <- postLoadMode = def_ghci_flags+               | otherwise                     = dflags1+        where def_ghci_flags = dflags1 `gopt_set` Opt_ImplicitImportQualified+                                       `gopt_set` Opt_IgnoreOptimChanges+                                       `gopt_set` Opt_IgnoreHpcChanges++        -- The rest of the arguments are "dynamic"+        -- Leftover ones are presumably files+  (dflags3, fileish_args, dynamicFlagWarnings) <-+      GHC.parseDynamicFlags dflags2 args++  let dflags4 = case lang of+                HscInterpreted | not (gopt Opt_ExternalInterpreter dflags3) ->+                    let platform = targetPlatform dflags3+                        dflags3a = updateWays $ dflags3 { ways = interpWays }+                        dflags3b = foldl gopt_set dflags3a+                                 $ concatMap (wayGeneralFlags platform)+                                             interpWays+                        dflags3c = foldl gopt_unset dflags3b+                                 $ concatMap (wayUnsetGeneralFlags platform)+                                             interpWays+                    in dflags3c+                _ ->+                    dflags3++  GHC.prettyPrintGhcErrors dflags4 $ do++  let flagWarnings' = flagWarnings ++ dynamicFlagWarnings++  handleSourceError (\e -> do+       GHC.printException e+       liftIO $ exitWith (ExitFailure 1)) $ do+         liftIO $ handleFlagWarnings dflags4 flagWarnings'++  liftIO $ showBanner postLoadMode dflags4++  let+     -- To simplify the handling of filepaths, we normalise all filepaths right+     -- away. Note the asymmetry of FilePath.normalise:+     --    Linux:   p/q -> p/q; p\q -> p\q+     --    Windows: p/q -> p\q; p\q -> p\q+     -- #12674: Filenames starting with a hypen get normalised from ./-foo.hs+     -- to -foo.hs. We have to re-prepend the current directory.+    normalise_hyp fp+        | strt_dot_sl && "-" `isPrefixOf` nfp = cur_dir ++ nfp+        | otherwise                           = nfp+        where+#if defined(mingw32_HOST_OS)+          strt_dot_sl = "./" `isPrefixOf` fp || ".\\" `isPrefixOf` fp+#else+          strt_dot_sl = "./" `isPrefixOf` fp+#endif+          cur_dir = '.' : [pathSeparator]+          nfp = normalise fp+    normal_fileish_paths = map (normalise_hyp . unLoc) fileish_args+    (srcs, objs)         = partition_args normal_fileish_paths [] []++    dflags5 = dflags4 { ldInputs = map (FileOption "") objs+                                   ++ ldInputs dflags4 }++  -- we've finished manipulating the DynFlags, update the session+  _ <- GHC.setSessionDynFlags dflags5+  dflags6 <- GHC.getSessionDynFlags+  hsc_env <- GHC.getSession++        ---------------- Display configuration -----------+  case verbosity dflags6 of+    v | v == 4 -> liftIO $ dumpPackagesSimple dflags6+      | v >= 5 -> liftIO $ dumpPackages dflags6+      | otherwise -> return ()++  liftIO $ initUniqSupply (initialUnique dflags6) (uniqueIncrement dflags6)+        ---------------- Final sanity checking -----------+  liftIO $ checkOptions postLoadMode dflags6 srcs objs++  ---------------- Do the business -----------+  handleSourceError (\e -> do+       GHC.printException e+       liftIO $ exitWith (ExitFailure 1)) $ do+    case postLoadMode of+       ShowInterface f        -> liftIO $ doShowIface dflags6 f+       DoMake                 -> doMake srcs+       DoMkDependHS           -> doMkDependHS (map fst srcs)+       StopBefore p           -> liftIO (oneShot hsc_env p srcs)+       DoInteractive          -> ghciUI hsc_env dflags6 srcs Nothing+       DoEval exprs           -> ghciUI hsc_env dflags6 srcs $ Just $+                                   reverse exprs+       DoAbiHash              -> abiHash (map fst srcs)+       ShowPackages           -> liftIO $ showPackages dflags6+       DoFrontend f           -> doFrontend f srcs+       DoBackpack             -> doBackpack (map fst srcs)++  liftIO $ dumpFinalStats dflags6++ghciUI :: HscEnv -> DynFlags -> [(FilePath, Maybe Phase)] -> Maybe [String]+       -> Ghc ()+#if !defined(GHCI)+ghciUI _ _ _ _ =+  throwGhcException (CmdLineError "not built for interactive use")+#else+ghciUI hsc_env dflags0 srcs maybe_expr = do+  dflags1 <- liftIO (initializePlugins hsc_env dflags0)+  _ <- GHC.setSessionDynFlags dflags1+  interactiveUI defaultGhciSettings srcs maybe_expr+#endif++-- -----------------------------------------------------------------------------+-- Splitting arguments into source files and object files.  This is where we+-- interpret the -x <suffix> option, and attach a (Maybe Phase) to each source+-- file indicating the phase specified by the -x option in force, if any.++partition_args :: [String] -> [(String, Maybe Phase)] -> [String]+               -> ([(String, Maybe Phase)], [String])+partition_args [] srcs objs = (reverse srcs, reverse objs)+partition_args ("-x":suff:args) srcs objs+  | "none" <- suff      = partition_args args srcs objs+  | StopLn <- phase     = partition_args args srcs (slurp ++ objs)+  | otherwise           = partition_args rest (these_srcs ++ srcs) objs+        where phase = startPhase suff+              (slurp,rest) = break (== "-x") args+              these_srcs = zip slurp (repeat (Just phase))+partition_args (arg:args) srcs objs+  | looks_like_an_input arg = partition_args args ((arg,Nothing):srcs) objs+  | otherwise               = partition_args args srcs (arg:objs)++    {-+      We split out the object files (.o, .dll) and add them+      to ldInputs for use by the linker.++      The following things should be considered compilation manager inputs:++       - haskell source files (strings ending in .hs, .lhs or other+         haskellish extension),++       - module names (not forgetting hierarchical module names),++       - things beginning with '-' are flags that were not recognised by+         the flag parser, and we want them to generate errors later in+         checkOptions, so we class them as source files (#5921)++       - and finally we consider everything without an extension to be+         a comp manager input, as shorthand for a .hs or .lhs filename.++      Everything else is considered to be a linker object, and passed+      straight through to the linker.+    -}+looks_like_an_input :: String -> Bool+looks_like_an_input m =  isSourceFilename m+                      || looksLikeModuleName m+                      || "-" `isPrefixOf` m+                      || not (hasExtension m)++-- -----------------------------------------------------------------------------+-- Option sanity checks++-- | Ensure sanity of options.+--+-- Throws 'UsageError' or 'CmdLineError' if not.+checkOptions :: PostLoadMode -> DynFlags -> [(String,Maybe Phase)] -> [String] -> IO ()+     -- Final sanity checking before kicking off a compilation (pipeline).+checkOptions mode dflags srcs objs = do+     -- Complain about any unknown flags+   let unknown_opts = [ f | (f@('-':_), _) <- srcs ]+   when (notNull unknown_opts) (unknownFlagsErr unknown_opts)++   when (notNull (filter wayRTSOnly (ways dflags))+         && isInterpretiveMode mode) $+        hPutStrLn stderr ("Warning: -debug, -threaded and -ticky are ignored by GHCi")++        -- -prof and --interactive are not a good combination+   when ((filter (not . wayRTSOnly) (ways dflags) /= interpWays)+         && isInterpretiveMode mode+         && not (gopt Opt_ExternalInterpreter dflags)) $+      do throwGhcException (UsageError+              "-fexternal-interpreter is required when using --interactive with a non-standard way (-prof, -static, or -dynamic).")+        -- -ohi sanity check+   if (isJust (outputHi dflags) &&+      (isCompManagerMode mode || srcs `lengthExceeds` 1))+        then throwGhcException (UsageError "-ohi can only be used when compiling a single source file")+        else do++        -- -o sanity checking+   if (srcs `lengthExceeds` 1 && isJust (outputFile dflags)+         && not (isLinkMode mode))+        then throwGhcException (UsageError "can't apply -o to multiple source files")+        else do++   let not_linking = not (isLinkMode mode) || isNoLink (ghcLink dflags)++   when (not_linking && not (null objs)) $+        hPutStrLn stderr ("Warning: the following files would be used as linker inputs, but linking is not being done: " ++ unwords objs)++        -- Check that there are some input files+        -- (except in the interactive case)+   if null srcs && (null objs || not_linking) && needsInputsMode mode+        then throwGhcException (UsageError "no input files")+        else do++   case mode of+      StopBefore HCc | hscTarget dflags /= HscC+        -> throwGhcException $ UsageError $+           "the option -C is only available with an unregisterised GHC"+      _ -> return ()++     -- Verify that output files point somewhere sensible.+   verifyOutputFiles dflags++-- Compiler output options++-- Called to verify that the output files point somewhere valid.+--+-- The assumption is that the directory portion of these output+-- options will have to exist by the time 'verifyOutputFiles'+-- is invoked.+--+-- We create the directories for -odir, -hidir, -outputdir etc. ourselves if+-- they don't exist, so don't check for those here (#2278).+verifyOutputFiles :: DynFlags -> IO ()+verifyOutputFiles dflags = do+  let ofile = outputFile dflags+  when (isJust ofile) $ do+     let fn = fromJust ofile+     flg <- doesDirNameExist fn+     when (not flg) (nonExistentDir "-o" fn)+  let ohi = outputHi dflags+  when (isJust ohi) $ do+     let hi = fromJust ohi+     flg <- doesDirNameExist hi+     when (not flg) (nonExistentDir "-ohi" hi)+ where+   nonExistentDir flg dir =+     throwGhcException (CmdLineError ("error: directory portion of " +++                             show dir ++ " does not exist (used with " +++                             show flg ++ " option.)"))++-----------------------------------------------------------------------------+-- GHC modes of operation++type Mode = Either PreStartupMode PostStartupMode+type PostStartupMode = Either PreLoadMode PostLoadMode++data PreStartupMode+  = ShowVersion                          -- ghc -V/--version+  | ShowNumVersion                       -- ghc --numeric-version+  | ShowSupportedExtensions              -- ghc --supported-extensions+  | ShowOptions Bool {- isInteractive -} -- ghc --show-options++showVersionMode, showNumVersionMode, showSupportedExtensionsMode, showOptionsMode :: Mode+showVersionMode             = mkPreStartupMode ShowVersion+showNumVersionMode          = mkPreStartupMode ShowNumVersion+showSupportedExtensionsMode = mkPreStartupMode ShowSupportedExtensions+showOptionsMode             = mkPreStartupMode (ShowOptions False)++mkPreStartupMode :: PreStartupMode -> Mode+mkPreStartupMode = Left++isShowVersionMode :: Mode -> Bool+isShowVersionMode (Left ShowVersion) = True+isShowVersionMode _ = False++isShowNumVersionMode :: Mode -> Bool+isShowNumVersionMode (Left ShowNumVersion) = True+isShowNumVersionMode _ = False++data PreLoadMode+  = ShowGhcUsage                           -- ghc -?+  | ShowGhciUsage                          -- ghci -?+  | ShowInfo                               -- ghc --info+  | PrintWithDynFlags (DynFlags -> String) -- ghc --print-foo++showGhcUsageMode, showGhciUsageMode, showInfoMode :: Mode+showGhcUsageMode = mkPreLoadMode ShowGhcUsage+showGhciUsageMode = mkPreLoadMode ShowGhciUsage+showInfoMode = mkPreLoadMode ShowInfo++printSetting :: String -> Mode+printSetting k = mkPreLoadMode (PrintWithDynFlags f)+    where f dflags = fromMaybe (panic ("Setting not found: " ++ show k))+                   $ lookup k (compilerInfo dflags)++mkPreLoadMode :: PreLoadMode -> Mode+mkPreLoadMode = Right . Left++isShowGhcUsageMode :: Mode -> Bool+isShowGhcUsageMode (Right (Left ShowGhcUsage)) = True+isShowGhcUsageMode _ = False++isShowGhciUsageMode :: Mode -> Bool+isShowGhciUsageMode (Right (Left ShowGhciUsage)) = True+isShowGhciUsageMode _ = False++data PostLoadMode+  = ShowInterface FilePath  -- ghc --show-iface+  | DoMkDependHS            -- ghc -M+  | StopBefore Phase        -- ghc -E | -C | -S+                            -- StopBefore StopLn is the default+  | DoMake                  -- ghc --make+  | DoBackpack              -- ghc --backpack foo.bkp+  | DoInteractive           -- ghc --interactive+  | DoEval [String]         -- ghc -e foo -e bar => DoEval ["bar", "foo"]+  | DoAbiHash               -- ghc --abi-hash+  | ShowPackages            -- ghc --show-packages+  | DoFrontend ModuleName   -- ghc --frontend Plugin.Module++doMkDependHSMode, doMakeMode, doInteractiveMode,+  doAbiHashMode, showPackagesMode :: Mode+doMkDependHSMode = mkPostLoadMode DoMkDependHS+doMakeMode = mkPostLoadMode DoMake+doInteractiveMode = mkPostLoadMode DoInteractive+doAbiHashMode = mkPostLoadMode DoAbiHash+showPackagesMode = mkPostLoadMode ShowPackages++showInterfaceMode :: FilePath -> Mode+showInterfaceMode fp = mkPostLoadMode (ShowInterface fp)++stopBeforeMode :: Phase -> Mode+stopBeforeMode phase = mkPostLoadMode (StopBefore phase)++doEvalMode :: String -> Mode+doEvalMode str = mkPostLoadMode (DoEval [str])++doFrontendMode :: String -> Mode+doFrontendMode str = mkPostLoadMode (DoFrontend (mkModuleName str))++doBackpackMode :: Mode+doBackpackMode = mkPostLoadMode DoBackpack++mkPostLoadMode :: PostLoadMode -> Mode+mkPostLoadMode = Right . Right++isDoInteractiveMode :: Mode -> Bool+isDoInteractiveMode (Right (Right DoInteractive)) = True+isDoInteractiveMode _ = False++isStopLnMode :: Mode -> Bool+isStopLnMode (Right (Right (StopBefore StopLn))) = True+isStopLnMode _ = False++isDoMakeMode :: Mode -> Bool+isDoMakeMode (Right (Right DoMake)) = True+isDoMakeMode _ = False++isDoEvalMode :: Mode -> Bool+isDoEvalMode (Right (Right (DoEval _))) = True+isDoEvalMode _ = False++#if defined(GHCI)+isInteractiveMode :: PostLoadMode -> Bool+isInteractiveMode DoInteractive = True+isInteractiveMode _             = False+#endif++-- isInterpretiveMode: byte-code compiler involved+isInterpretiveMode :: PostLoadMode -> Bool+isInterpretiveMode DoInteractive = True+isInterpretiveMode (DoEval _)    = True+isInterpretiveMode _             = False++needsInputsMode :: PostLoadMode -> Bool+needsInputsMode DoMkDependHS    = True+needsInputsMode (StopBefore _)  = True+needsInputsMode DoMake          = True+needsInputsMode _               = False++-- True if we are going to attempt to link in this mode.+-- (we might not actually link, depending on the GhcLink flag)+isLinkMode :: PostLoadMode -> Bool+isLinkMode (StopBefore StopLn) = True+isLinkMode DoMake              = True+isLinkMode DoInteractive       = True+isLinkMode (DoEval _)          = True+isLinkMode _                   = False++isCompManagerMode :: PostLoadMode -> Bool+isCompManagerMode DoMake        = True+isCompManagerMode DoInteractive = True+isCompManagerMode (DoEval _)    = True+isCompManagerMode _             = False++-- -----------------------------------------------------------------------------+-- Parsing the mode flag++parseModeFlags :: [Located String]+               -> IO (Mode,+                      [Located String],+                      [Warn])+parseModeFlags args = do+  let ((leftover, errs1, warns), (mModeFlag, errs2, flags')) =+          runCmdLine (processArgs mode_flags args)+                     (Nothing, [], [])+      mode = case mModeFlag of+             Nothing     -> doMakeMode+             Just (m, _) -> m++  -- See Note [Handling errors when parsing commandline flags]+  unless (null errs1 && null errs2) $ throwGhcException $ errorsToGhcException $+      map (("on the commandline", )) $ map (unLoc . errMsg) errs1 ++ errs2++  return (mode, flags' ++ leftover, warns)++type ModeM = CmdLineP (Maybe (Mode, String), [String], [Located String])+  -- mode flags sometimes give rise to new DynFlags (eg. -C, see below)+  -- so we collect the new ones and return them.++mode_flags :: [Flag ModeM]+mode_flags =+  [  ------- help / version ----------------------------------------------+    defFlag "?"                     (PassFlag (setMode showGhcUsageMode))+  , defFlag "-help"                 (PassFlag (setMode showGhcUsageMode))+  , defFlag "V"                     (PassFlag (setMode showVersionMode))+  , defFlag "-version"              (PassFlag (setMode showVersionMode))+  , defFlag "-numeric-version"      (PassFlag (setMode showNumVersionMode))+  , defFlag "-info"                 (PassFlag (setMode showInfoMode))+  , defFlag "-show-options"         (PassFlag (setMode showOptionsMode))+  , defFlag "-supported-languages"  (PassFlag (setMode showSupportedExtensionsMode))+  , defFlag "-supported-extensions" (PassFlag (setMode showSupportedExtensionsMode))+  , defFlag "-show-packages"        (PassFlag (setMode showPackagesMode))+  ] +++  [ defFlag k'                      (PassFlag (setMode (printSetting k)))+  | k <- ["Project version",+          "Project Git commit id",+          "Booter version",+          "Stage",+          "Build platform",+          "Host platform",+          "Target platform",+          "Have interpreter",+          "Object splitting supported",+          "Have native code generator",+          "Support SMP",+          "Unregisterised",+          "Tables next to code",+          "RTS ways",+          "Leading underscore",+          "Debug on",+          "LibDir",+          "Global Package DB",+          "C compiler flags",+          "C compiler link flags",+          "ld flags"],+    let k' = "-print-" ++ map (replaceSpace . toLower) k+        replaceSpace ' ' = '-'+        replaceSpace c   = c+  ] +++      ------- interfaces ----------------------------------------------------+  [ defFlag "-show-iface"  (HasArg (\f -> setMode (showInterfaceMode f)+                                               "--show-iface"))++      ------- primary modes ------------------------------------------------+  , defFlag "c"            (PassFlag (\f -> do setMode (stopBeforeMode StopLn) f+                                               addFlag "-no-link" f))+  , defFlag "M"            (PassFlag (setMode doMkDependHSMode))+  , defFlag "E"            (PassFlag (setMode (stopBeforeMode anyHsc)))+  , defFlag "C"            (PassFlag (setMode (stopBeforeMode HCc)))+  , defFlag "S"            (PassFlag (setMode (stopBeforeMode (As False))))+  , defFlag "-make"        (PassFlag (setMode doMakeMode))+  , defFlag "-backpack"    (PassFlag (setMode doBackpackMode))+  , defFlag "-interactive" (PassFlag (setMode doInteractiveMode))+  , defFlag "-abi-hash"    (PassFlag (setMode doAbiHashMode))+  , defFlag "e"            (SepArg   (\s -> setMode (doEvalMode s) "-e"))+  , defFlag "-frontend"    (SepArg   (\s -> setMode (doFrontendMode s) "-frontend"))+  ]++setMode :: Mode -> String -> EwM ModeM ()+setMode newMode newFlag = liftEwM $ do+    (mModeFlag, errs, flags') <- getCmdLineState+    let (modeFlag', errs') =+            case mModeFlag of+            Nothing -> ((newMode, newFlag), errs)+            Just (oldMode, oldFlag) ->+                case (oldMode, newMode) of+                    -- -c/--make are allowed together, and mean --make -no-link+                    _ |  isStopLnMode oldMode && isDoMakeMode newMode+                      || isStopLnMode newMode && isDoMakeMode oldMode ->+                      ((doMakeMode, "--make"), [])++                    -- If we have both --help and --interactive then we+                    -- want showGhciUsage+                    _ | isShowGhcUsageMode oldMode &&+                        isDoInteractiveMode newMode ->+                            ((showGhciUsageMode, oldFlag), [])+                      | isShowGhcUsageMode newMode &&+                        isDoInteractiveMode oldMode ->+                            ((showGhciUsageMode, newFlag), [])++                    -- If we have both -e and --interactive then -e always wins+                    _ | isDoEvalMode oldMode &&+                        isDoInteractiveMode newMode ->+                            ((oldMode, oldFlag), [])+                      | isDoEvalMode newMode &&+                        isDoInteractiveMode oldMode ->+                            ((newMode, newFlag), [])++                    -- Otherwise, --help/--version/--numeric-version always win+                      | isDominantFlag oldMode -> ((oldMode, oldFlag), [])+                      | isDominantFlag newMode -> ((newMode, newFlag), [])+                    -- We need to accumulate eval flags like "-e foo -e bar"+                    (Right (Right (DoEval esOld)),+                     Right (Right (DoEval [eNew]))) ->+                        ((Right (Right (DoEval (eNew : esOld))), oldFlag),+                         errs)+                    -- Saying e.g. --interactive --interactive is OK+                    _ | oldFlag == newFlag -> ((oldMode, oldFlag), errs)++                    -- --interactive and --show-options are used together+                    (Right (Right DoInteractive), Left (ShowOptions _)) ->+                      ((Left (ShowOptions True),+                        "--interactive --show-options"), errs)+                    (Left (ShowOptions _), (Right (Right DoInteractive))) ->+                      ((Left (ShowOptions True),+                        "--show-options --interactive"), errs)+                    -- Otherwise, complain+                    _ -> let err = flagMismatchErr oldFlag newFlag+                         in ((oldMode, oldFlag), err : errs)+    putCmdLineState (Just modeFlag', errs', flags')+  where isDominantFlag f = isShowGhcUsageMode   f ||+                           isShowGhciUsageMode  f ||+                           isShowVersionMode    f ||+                           isShowNumVersionMode f++flagMismatchErr :: String -> String -> String+flagMismatchErr oldFlag newFlag+    = "cannot use `" ++ oldFlag ++  "' with `" ++ newFlag ++ "'"++addFlag :: String -> String -> EwM ModeM ()+addFlag s flag = liftEwM $ do+  (m, e, flags') <- getCmdLineState+  putCmdLineState (m, e, mkGeneralLocated loc s : flags')+    where loc = "addFlag by " ++ flag ++ " on the commandline"++-- ----------------------------------------------------------------------------+-- Run --make mode++doMake :: [(String,Maybe Phase)] -> Ghc ()+doMake srcs  = do+    let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs++    hsc_env <- GHC.getSession++    -- if we have no haskell sources from which to do a dependency+    -- analysis, then just do one-shot compilation and/or linking.+    -- This means that "ghc Foo.o Bar.o -o baz" links the program as+    -- we expect.+    if (null hs_srcs)+       then liftIO (oneShot hsc_env StopLn srcs)+       else do++    o_files <- mapM (\x -> liftIO $ compileFile hsc_env StopLn x)+                 non_hs_srcs+    dflags <- GHC.getSessionDynFlags+    let dflags' = dflags { ldInputs = map (FileOption "") o_files+                                      ++ ldInputs dflags }+    _ <- GHC.setSessionDynFlags dflags'++    targets <- mapM (uncurry GHC.guessTarget) hs_srcs+    GHC.setTargets targets+    ok_flag <- GHC.load LoadAllTargets++    when (failed ok_flag) (liftIO $ exitWith (ExitFailure 1))+    return ()+++-- ---------------------------------------------------------------------------+-- --show-iface mode++doShowIface :: DynFlags -> FilePath -> IO ()+doShowIface dflags file = do+  hsc_env <- newHscEnv dflags+  showIface hsc_env file++-- ---------------------------------------------------------------------------+-- Various banners and verbosity output.++showBanner :: PostLoadMode -> DynFlags -> IO ()+showBanner _postLoadMode dflags = do+   let verb = verbosity dflags++#if defined(GHCI)+   -- Show the GHCi banner+   when (isInteractiveMode _postLoadMode && verb >= 1) $ putStrLn ghciWelcomeMsg+#endif++   -- Display details of the configuration in verbose mode+   when (verb >= 2) $+    do hPutStr stderr "Glasgow Haskell Compiler, Version "+       hPutStr stderr cProjectVersion+       hPutStr stderr ", stage "+       hPutStr stderr cStage+       hPutStr stderr " booted by GHC version "+       hPutStrLn stderr cBooterVersion++-- We print out a Read-friendly string, but a prettier one than the+-- Show instance gives us+showInfo :: DynFlags -> IO ()+showInfo dflags = do+        let sq x = " [" ++ x ++ "\n ]"+        putStrLn $ sq $ intercalate "\n ," $ map show $ compilerInfo dflags++showSupportedExtensions :: IO ()+showSupportedExtensions = mapM_ putStrLn supportedLanguagesAndExtensions++showVersion :: IO ()+showVersion = putStrLn (cProjectName ++ ", version " ++ cProjectVersion)++showOptions :: Bool -> IO ()+showOptions isInteractive = putStr (unlines availableOptions)+    where+      availableOptions = concat [+        flagsForCompletion isInteractive,+        map ('-':) (getFlagNames mode_flags)+        ]+      getFlagNames opts         = map flagName opts++showGhcUsage :: DynFlags -> IO ()+showGhcUsage = showUsage False++showGhciUsage :: DynFlags -> IO ()+showGhciUsage = showUsage True++showUsage :: Bool -> DynFlags -> IO ()+showUsage ghci dflags = do+  let usage_path = if ghci then ghciUsagePath dflags+                           else ghcUsagePath dflags+  usage <- readFile usage_path+  dump usage+  where+     dump ""          = return ()+     dump ('$':'$':s) = putStr progName >> dump s+     dump (c:s)       = putChar c >> dump s++dumpFinalStats :: DynFlags -> IO ()+dumpFinalStats dflags =+  when (gopt Opt_D_faststring_stats dflags) $ dumpFastStringStats dflags++dumpFastStringStats :: DynFlags -> IO ()+dumpFastStringStats dflags = do+  segments <- getFastStringTable+  let buckets = concat segments+      bucketsPerSegment = map length segments+      entriesPerBucket = map length buckets+      entries = sum entriesPerBucket+      hasZ = sum $ map (length . filter hasZEncoding) buckets+      msg = text "FastString stats:" $$ nest 4 (vcat+        [ text "segments:         " <+> int (length segments)+        , text "buckets:          " <+> int (sum bucketsPerSegment)+        , text "entries:          " <+> int entries+        , text "largest segment:  " <+> int (maximum bucketsPerSegment)+        , text "smallest segment: " <+> int (minimum bucketsPerSegment)+        , text "longest bucket:   " <+> int (maximum entriesPerBucket)+        , text "has z-encoding:   " <+> (hasZ `pcntOf` entries)+        ])+        -- we usually get more "has z-encoding" than "z-encoded", because+        -- when we z-encode a string it might hash to the exact same string,+        -- which is not counted as "z-encoded".  Only strings whose+        -- Z-encoding is different from the original string are counted in+        -- the "z-encoded" total.+  putMsg dflags msg+  where+   x `pcntOf` y = int ((x * 100) `quot` y) Outputable.<> char '%'++showPackages, dumpPackages, dumpPackagesSimple :: DynFlags -> IO ()+showPackages       dflags = putStrLn (showSDoc dflags (pprPackages dflags))+dumpPackages       dflags = putMsg dflags (pprPackages dflags)+dumpPackagesSimple dflags = putMsg dflags (pprPackagesSimple dflags)++-- -----------------------------------------------------------------------------+-- Frontend plugin support++doFrontend :: ModuleName -> [(String, Maybe Phase)] -> Ghc ()+#if !defined(GHCI)+doFrontend modname _ = pluginError [modname]+#else+doFrontend modname srcs = do+    hsc_env <- getSession+    frontend_plugin <- liftIO $ loadFrontendPlugin hsc_env modname+    frontend frontend_plugin+      (reverse $ frontendPluginOpts (hsc_dflags hsc_env)) srcs+#endif++-- -----------------------------------------------------------------------------+-- ABI hash support++{-+        ghc --abi-hash Data.Foo System.Bar++Generates a combined hash of the ABI for modules Data.Foo and+System.Bar.  The modules must already be compiled, and appropriate -i+options may be necessary in order to find the .hi files.++This is used by Cabal for generating the ComponentId for a+package.  The ComponentId must change when the visible ABI of+the package chagnes, so during registration Cabal calls ghc --abi-hash+to get a hash of the package's ABI.+-}++-- | Print ABI hash of input modules.+--+-- The resulting hash is the MD5 of the GHC version used (#5328,+-- see 'hiVersion') and of the existing ABI hash from each module (see+-- 'mi_mod_hash').+abiHash :: [String] -- ^ List of module names+        -> Ghc ()+abiHash strs = do+  hsc_env <- getSession+  let dflags = hsc_dflags hsc_env++  liftIO $ do++  let find_it str = do+         let modname = mkModuleName str+         r <- findImportedModule hsc_env modname Nothing+         case r of+           Found _ m -> return m+           _error    -> throwGhcException $ CmdLineError $ showSDoc dflags $+                          cannotFindModule dflags modname r++  mods <- mapM find_it strs++  let get_iface modl = loadUserInterface False (text "abiHash") modl+  ifaces <- initIfaceCheck (text "abiHash") hsc_env $ mapM get_iface mods++  bh <- openBinMem (3*1024) -- just less than a block+  put_ bh hiVersion+    -- package hashes change when the compiler version changes (for now)+    -- see #5328+  mapM_ (put_ bh . mi_mod_hash) ifaces+  f <- fingerprintBinMem bh++  putStrLn (showPpr dflags f)++-- -----------------------------------------------------------------------------+-- Util++unknownFlagsErr :: [String] -> a+unknownFlagsErr fs = throwGhcException $ UsageError $ concatMap oneError fs+  where+    oneError f =+        "unrecognised flag: " ++ f ++ "\n" +++        (case match f (nubSort allNonDeprecatedFlags) of+            [] -> ""+            suggs -> "did you mean one of:\n" ++ unlines (map ("  " ++) suggs))+    -- fixes #11789+    -- If the flag contains '=',+    -- this uses both the whole and the left side of '=' for comparing.+    match f allFlags+        | elem '=' f =+              let (flagsWithEq, flagsWithoutEq) = partition (elem '=') allFlags+                  fName = takeWhile (/= '=') f+              in (fuzzyMatch f flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq)+        | otherwise = fuzzyMatch f allFlags++{- Note [-Bsymbolic and hooks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-Bsymbolic is a flag that prevents the binding of references to global+symbols to symbols outside the shared library being compiled (see `man+ld`). When dynamically linking, we don't use -Bsymbolic on the RTS+package: that is because we want hooks to be overridden by the user,+we don't want to constrain them to the RTS package.++Unfortunately this seems to have broken somehow on OS X: as a result,+defaultHooks (in hschooks.c) is not called, which does not initialize+the GC stats. As a result, this breaks things like `:set +s` in GHCi+(#8754). As a hacky workaround, we instead call 'defaultHooks'+directly to initalize the flags in the RTS.++A byproduct of this, I believe, is that hooks are likely broken on OS+X when dynamically linking. But this probably doesn't affect most+people since we're linking GHC dynamically, but most things themselves+link statically.+-}++-- If GHC_LOADED_INTO_GHCI is not set when GHC is loaded into GHCi, then+-- running it causes an error like this:+--+-- Loading temp shared object failed:+-- /tmp/ghc13836_0/libghc_1872.so: undefined symbol: initGCStatistics+--+-- Skipping the foreign call fixes this problem, and the outer GHCi+-- should have already made this call anyway.+#if defined(GHC_LOADED_INTO_GHCI)+initGCStatistics :: IO ()+initGCStatistics = return ()+#else+foreign import ccall safe "initGCStatistics"+  initGCStatistics :: IO ()+#endif
+ includes/Cmm.h view
@@ -0,0 +1,936 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The University of Glasgow 2004-2013+ *+ * This file is included at the top of all .cmm source files (and+ * *only* .cmm files).  It defines a collection of useful macros for+ * making .cmm code a bit less error-prone to write, and a bit easier+ * on the eye for the reader.+ *+ * For the syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.+ *+ * Accessing fields of structures defined in the RTS header files is+ * done via automatically-generated macros in DerivedConstants.h.  For+ * example, where previously we used+ *+ *          CurrentTSO->what_next = x+ *+ * in C-- we now use+ *+ *          StgTSO_what_next(CurrentTSO) = x+ *+ * where the StgTSO_what_next() macro is automatically generated by+ * mkDerivedConstants.c.  If you need to access a field that doesn't+ * already have a macro, edit that file (it's pretty self-explanatory).+ *+ * -------------------------------------------------------------------------- */++#pragma once++/*+ * In files that are included into both C and C-- (and perhaps+ * Haskell) sources, we sometimes need to conditionally compile bits+ * depending on the language.  CMINUSMINUS==1 in .cmm sources:+ */+#define CMINUSMINUS 1++#include "ghcconfig.h"++/* -----------------------------------------------------------------------------+   Types++   The following synonyms for C-- types are declared here:++     I8, I16, I32, I64    MachRep-style names for convenience++     W_                   is shorthand for the word type (== StgWord)+     F_                   shorthand for float  (F_ == StgFloat == C's float)+     D_                   shorthand for double (D_ == StgDouble == C's double)++     CInt                 has the same size as an int in C on this platform+     CLong                has the same size as a long in C on this platform+     CBool                has the same size as a bool in C on this platform++  --------------------------------------------------------------------------- */++#define I8  bits8+#define I16 bits16+#define I32 bits32+#define I64 bits64+#define P_  gcptr++#if SIZEOF_VOID_P == 4+#define W_ bits32+/* Maybe it's better to include MachDeps.h */+#define TAG_BITS                2+#elif SIZEOF_VOID_P == 8+#define W_ bits64+/* Maybe it's better to include MachDeps.h */+#define TAG_BITS                3+#else+#error Unknown word size+#endif++/*+ * The RTS must sometimes UNTAG a pointer before dereferencing it.+ * See the wiki page commentary/rts/haskell-execution/pointer-tagging+ */+#define TAG_MASK ((1 << TAG_BITS) - 1)+#define UNTAG(p) (p & ~TAG_MASK)+#define GETTAG(p) (p & TAG_MASK)++#if SIZEOF_INT == 4+#define CInt bits32+#elif SIZEOF_INT == 8+#define CInt bits64+#else+#error Unknown int size+#endif++#if SIZEOF_LONG == 4+#define CLong bits32+#elif SIZEOF_LONG == 8+#define CLong bits64+#else+#error Unknown long size+#endif++#define CBool bits8++#define F_   float32+#define D_   float64+#define L_   bits64+#define V16_ bits128+#define V32_ bits256+#define V64_ bits512++#define SIZEOF_StgDouble 8+#define SIZEOF_StgWord64 8++/* -----------------------------------------------------------------------------+   Misc useful stuff+   -------------------------------------------------------------------------- */++#define ccall foreign "C"++#define NULL (0::W_)++#define STRING(name,str)                        \+  section "rodata" {                            \+        name : bits8[] str;                     \+  }                                             \++#if defined(TABLES_NEXT_TO_CODE)+#define RET_LBL(f) f##_info+#else+#define RET_LBL(f) f##_ret+#endif++#if defined(TABLES_NEXT_TO_CODE)+#define ENTRY_LBL(f) f##_info+#else+#define ENTRY_LBL(f) f##_entry+#endif++/* -----------------------------------------------------------------------------+   Byte/word macros++   Everything in C-- is in byte offsets (well, most things).  We use+   some macros to allow us to express offsets in words and to try to+   avoid byte/word confusion.+   -------------------------------------------------------------------------- */++#define SIZEOF_W  SIZEOF_VOID_P+#define W_MASK    (SIZEOF_W-1)++#if SIZEOF_W == 4+#define W_SHIFT 2+#elif SIZEOF_W == 8+#define W_SHIFT 3+#endif++/* Converting quantities of words to bytes */+#define WDS(n) ((n)*SIZEOF_W)++/*+ * Converting quantities of bytes to words+ * NB. these work on *unsigned* values only+ */+#define BYTES_TO_WDS(n) ((n) / SIZEOF_W)+#define ROUNDUP_BYTES_TO_WDS(n) (((n) + SIZEOF_W - 1) / SIZEOF_W)++/*+ * TO_W_(n) and TO_ZXW_(n) convert n to W_ type from a smaller type,+ * with and without sign extension respectively+ */+#if SIZEOF_W == 4+#define TO_I64(x) %sx64(x)+#define TO_W_(x) %sx32(x)+#define TO_ZXW_(x) %zx32(x)+#define HALF_W_(x) %lobits16(x)+#elif SIZEOF_W == 8+#define TO_I64(x) (x)+#define TO_W_(x) %sx64(x)+#define TO_ZXW_(x) %zx64(x)+#define HALF_W_(x) %lobits32(x)+#endif++#if SIZEOF_INT == 4 && SIZEOF_W == 8+#define W_TO_INT(x) %lobits32(x)+#elif SIZEOF_INT == SIZEOF_W+#define W_TO_INT(x) (x)+#endif++#if SIZEOF_LONG == 4 && SIZEOF_W == 8+#define W_TO_LONG(x) %lobits32(x)+#elif SIZEOF_LONG == SIZEOF_W+#define W_TO_LONG(x) (x)+#endif++/* -----------------------------------------------------------------------------+   Atomic memory operations.+   -------------------------------------------------------------------------- */++#if SIZEOF_W == 4+#define cmpxchgW cmpxchg32+#elif SIZEOF_W == 8+#define cmpxchgW cmpxchg64+#endif++/* -----------------------------------------------------------------------------+   Heap/stack access, and adjusting the heap/stack pointers.+   -------------------------------------------------------------------------- */++#define Sp(n)  W_[Sp + WDS(n)]+#define Hp(n)  W_[Hp + WDS(n)]++#define Sp_adj(n) Sp = Sp + WDS(n)  /* pronounced "spadge" */+#define Hp_adj(n) Hp = Hp + WDS(n)++/* -----------------------------------------------------------------------------+   Assertions and Debuggery+   -------------------------------------------------------------------------- */++#if defined(DEBUG)+#define ASSERT(predicate)                       \+        if (predicate) {                        \+            /*null*/;                           \+        } else {                                \+            foreign "C" _assertFail(__FILE__, __LINE__) never returns; \+        }+#else+#define ASSERT(p) /* nothing */+#endif++#if defined(DEBUG)+#define DEBUG_ONLY(s) s+#else+#define DEBUG_ONLY(s) /* nothing */+#endif++/*+ * The IF_DEBUG macro is useful for debug messages that depend on one+ * of the RTS debug options.  For example:+ *+ *   IF_DEBUG(RtsFlags_DebugFlags_apply,+ *      foreign "C" fprintf(stderr, stg_ap_0_ret_str));+ *+ * Note the syntax is slightly different to the C version of this macro.+ */+#if defined(DEBUG)+#define IF_DEBUG(c,s)  if (RtsFlags_DebugFlags_##c(RtsFlags) != 0::CBool) { s; }+#else+#define IF_DEBUG(c,s)  /* nothing */+#endif++/* -----------------------------------------------------------------------------+   Entering++   It isn't safe to "enter" every closure.  Functions in particular+   have no entry code as such; their entry point contains the code to+   apply the function.++   ToDo: range should end in N_CLOSURE_TYPES-1, not N_CLOSURE_TYPES,+   but switch doesn't allow us to use exprs there yet.++   If R1 points to a tagged object it points either to+   * A constructor.+   * A function with arity <= TAG_MASK.+   In both cases the right thing to do is to return.+   Note: it is rather lucky that we can use the tag bits to do this+         for both objects. Maybe it points to a brittle design?++   Indirections can contain tagged pointers, so their tag is checked.+   -------------------------------------------------------------------------- */++#if defined(PROFILING)++// When profiling, we cannot shortcut ENTER() by checking the tag,+// because LDV profiling relies on entering closures to mark them as+// "used".++#define LOAD_INFO(ret,x)                        \+    info = %INFO_PTR(UNTAG(x));++#define UNTAG_IF_PROF(x) UNTAG(x)++#else++#define LOAD_INFO(ret,x)                        \+  if (GETTAG(x) != 0) {                         \+      ret(x);                                   \+  }                                             \+  info = %INFO_PTR(x);++#define UNTAG_IF_PROF(x) (x) /* already untagged */++#endif++// We need two versions of ENTER():+//  - ENTER(x) takes the closure as an argument and uses return(),+//    for use in civilized code where the stack is handled by GHC+//+//  - ENTER_NOSTACK() where the closure is in R1, and returns are+//    explicit jumps, for use when we are doing the stack management+//    ourselves.++#if defined(PROFILING)+// See Note [Evaluating functions with profiling] in rts/Apply.cmm+#define ENTER(x) jump stg_ap_0_fast(x);+#else+#define ENTER(x) ENTER_(return,x)+#endif++#define ENTER_R1() ENTER_(RET_R1,R1)++#define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1]++#define ENTER_(ret,x)                                   \+ again:                                                 \+  W_ info;                                              \+  LOAD_INFO(ret,x)                                       \+  switch [INVALID_OBJECT .. N_CLOSURE_TYPES]            \+         (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) {       \+  case                                                  \+    IND,                                                \+    IND_STATIC:                                         \+   {                                                    \+      x = StgInd_indirectee(x);                         \+      goto again;                                       \+   }                                                    \+  case                                                  \+    FUN,                                                \+    FUN_1_0,                                            \+    FUN_0_1,                                            \+    FUN_2_0,                                            \+    FUN_1_1,                                            \+    FUN_0_2,                                            \+    FUN_STATIC,                                         \+    BCO,                                                \+    PAP:                                                \+   {                                                    \+       ret(x);                                          \+   }                                                    \+  default:                                              \+   {                                                    \+       x = UNTAG_IF_PROF(x);                            \+       jump %ENTRY_CODE(info) (x);                      \+   }                                                    \+  }++// The FUN cases almost never happen: a pointer to a non-static FUN+// should always be tagged.  This unfortunately isn't true for the+// interpreter right now, which leaves untagged FUNs on the stack.++/* -----------------------------------------------------------------------------+   Constants.+   -------------------------------------------------------------------------- */++#include "rts/Constants.h"+#include "DerivedConstants.h"+#include "rts/storage/ClosureTypes.h"+#include "rts/storage/FunTypes.h"+#include "rts/OSThreads.h"++/*+ * Need MachRegs, because some of the RTS code is conditionally+ * compiled based on REG_R1, REG_R2, etc.+ */+#include "stg/RtsMachRegs.h"++#include "rts/prof/LDV.h"++#undef BLOCK_SIZE+#undef MBLOCK_SIZE+#include "rts/storage/Block.h"  /* For Bdescr() */+++#define MyCapability()  (BaseReg - OFFSET_Capability_r)++/* -------------------------------------------------------------------------+   Info tables+   ------------------------------------------------------------------------- */++#if defined(PROFILING)+#define PROF_HDR_FIELDS(w_,hdr1,hdr2)          \+  w_ hdr1,                                     \+  w_ hdr2,+#else+#define PROF_HDR_FIELDS(w_,hdr1,hdr2) /* nothing */+#endif++/* -------------------------------------------------------------------------+   Allocation and garbage collection+   ------------------------------------------------------------------------- */++/*+ * ALLOC_PRIM is for allocating memory on the heap for a primitive+ * object.  It is used all over PrimOps.cmm.+ *+ * We make the simplifying assumption that the "admin" part of a+ * primitive closure is just the header when calculating sizes for+ * ticky-ticky.  It's not clear whether eg. the size field of an array+ * should be counted as "admin", or the various fields of a BCO.+ */+#define ALLOC_PRIM(bytes)                                       \+   HP_CHK_GEN_TICKY(bytes);                                     \+   TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0);  \+   CCCS_ALLOC(bytes);++#define HEAP_CHECK(bytes,failure)                       \+    TICK_BUMP(HEAP_CHK_ctr);                            \+    Hp = Hp + (bytes);                                  \+    if (Hp > HpLim) { HpAlloc = (bytes); failure; }     \+    TICK_ALLOC_HEAP_NOCTR(bytes);++#define ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,failure)           \+    HEAP_CHECK(bytes,failure)                                   \+    TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0); \+    CCCS_ALLOC(bytes);++#define ALLOC_PRIM_(bytes,fun)                                  \+    ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM(fun));++#define ALLOC_PRIM_P(bytes,fun,arg)                             \+    ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_P(fun,arg));++#define ALLOC_PRIM_N(bytes,fun,arg)                             \+    ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_N(fun,arg));++/* CCS_ALLOC wants the size in words, because ccs->mem_alloc is in words */+#define CCCS_ALLOC(__alloc) CCS_ALLOC(BYTES_TO_WDS(__alloc), CCCS)++#define HP_CHK_GEN_TICKY(bytes)                 \+   HP_CHK_GEN(bytes);                           \+   TICK_ALLOC_HEAP_NOCTR(bytes);++#define HP_CHK_P(bytes, fun, arg)               \+   HEAP_CHECK(bytes, GC_PRIM_P(fun,arg))++// TODO I'm not seeing where ALLOC_P_TICKY is used; can it be removed?+//         -NSF March 2013+#define ALLOC_P_TICKY(bytes, fun, arg)          \+   HP_CHK_P(bytes);                             \+   TICK_ALLOC_HEAP_NOCTR(bytes);++#define CHECK_GC()                                                      \+  (bdescr_link(CurrentNursery) == NULL ||                               \+   generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim]))++// allocate() allocates from the nursery, so we check to see+// whether the nursery is nearly empty in any function that uses+// allocate() - this includes many of the primops.+//+// HACK alert: the __L__ stuff is here to coax the common-block+// eliminator into commoning up the call stg_gc_noregs() with the same+// code that gets generated by a STK_CHK_GEN() in the same proc.  We+// also need an if (0) { goto __L__; } so that the __L__ label isn't+// optimised away by the control-flow optimiser prior to common-block+// elimination (it will be optimised away later).+//+// This saves some code in gmp-wrappers.cmm where we have lots of+// MAYBE_GC() in the same proc as STK_CHK_GEN().+//+#define MAYBE_GC(retry)                         \+    if (CHECK_GC()) {                           \+        HpAlloc = 0;                            \+        goto __L__;                             \+  __L__:                                        \+        call stg_gc_noregs();                   \+        goto retry;                             \+   }                                            \+   if (0) { goto __L__; }++#define GC_PRIM(fun)                            \+        jump stg_gc_prim(fun);++// Version of GC_PRIM for use in low-level Cmm.  We can call+// stg_gc_prim, because it takes one argument and therefore has a+// platform-independent calling convention (Note [Syntax of .cmm+// files] in CmmParse.y).+#define GC_PRIM_LL(fun)                         \+        R1 = fun;                               \+        jump stg_gc_prim [R1];++// We pass the fun as the second argument, because the arg is+// usually already in the first argument position (R1), so this+// avoids moving it to a different register / stack slot.+#define GC_PRIM_N(fun,arg)                      \+        jump stg_gc_prim_n(arg,fun);++#define GC_PRIM_P(fun,arg)                      \+        jump stg_gc_prim_p(arg,fun);++#define GC_PRIM_P_LL(fun,arg)                   \+        R1 = arg;                               \+        R2 = fun;                               \+        jump stg_gc_prim_p_ll [R1,R2];++#define GC_PRIM_PP(fun,arg1,arg2)               \+        jump stg_gc_prim_pp(arg1,arg2,fun);++#define MAYBE_GC_(fun)                          \+    if (CHECK_GC()) {                           \+        HpAlloc = 0;                            \+        GC_PRIM(fun)                            \+   }++#define MAYBE_GC_N(fun,arg)                     \+    if (CHECK_GC()) {                           \+        HpAlloc = 0;                            \+        GC_PRIM_N(fun,arg)                      \+   }++#define MAYBE_GC_P(fun,arg)                     \+    if (CHECK_GC()) {                           \+        HpAlloc = 0;                            \+        GC_PRIM_P(fun,arg)                      \+   }++#define MAYBE_GC_PP(fun,arg1,arg2)              \+    if (CHECK_GC()) {                           \+        HpAlloc = 0;                            \+        GC_PRIM_PP(fun,arg1,arg2)               \+   }++#define STK_CHK_LL(n, fun)                      \+    TICK_BUMP(STK_CHK_ctr);                     \+    if (Sp - (n) < SpLim) {                     \+        GC_PRIM_LL(fun)                         \+    }++#define STK_CHK_P_LL(n, fun, arg)               \+    TICK_BUMP(STK_CHK_ctr);                     \+    if (Sp - (n) < SpLim) {                     \+        GC_PRIM_P_LL(fun,arg)                   \+    }++#define STK_CHK_PP(n, fun, arg1, arg2)          \+    TICK_BUMP(STK_CHK_ctr);                     \+    if (Sp - (n) < SpLim) {                     \+        GC_PRIM_PP(fun,arg1,arg2)               \+    }++#define STK_CHK_ENTER(n, closure)               \+    TICK_BUMP(STK_CHK_ctr);                     \+    if (Sp - (n) < SpLim) {                     \+        jump __stg_gc_enter_1(closure);         \+    }++// A funky heap check used by AutoApply.cmm++#define HP_CHK_NP_ASSIGN_SP0(size,f)                    \+    HEAP_CHECK(size, Sp(0) = f; jump __stg_gc_enter_1 [R1];)++/* -----------------------------------------------------------------------------+   Closure headers+   -------------------------------------------------------------------------- */++/*+ * This is really ugly, since we don't do the rest of StgHeader this+ * way.  The problem is that values from DerivedConstants.h cannot be+ * dependent on the way (SMP, PROF etc.).  For SIZEOF_StgHeader we get+ * the value from GHC, but it seems like too much trouble to do that+ * for StgThunkHeader.+ */+#define SIZEOF_StgThunkHeader SIZEOF_StgHeader+SIZEOF_StgSMPThunkHeader++#define StgThunk_payload(__ptr__,__ix__) \+    W_[__ptr__+SIZEOF_StgThunkHeader+ WDS(__ix__)]++/* -----------------------------------------------------------------------------+   Closures+   -------------------------------------------------------------------------- */++/* The offset of the payload of an array */+#define BYTE_ARR_CTS(arr)  ((arr) + SIZEOF_StgArrBytes)++/* The number of words allocated in an array payload */+#define BYTE_ARR_WDS(arr) ROUNDUP_BYTES_TO_WDS(StgArrBytes_bytes(arr))++/* Getting/setting the info pointer of a closure */+#define SET_INFO(p,info) StgHeader_info(p) = info+#define GET_INFO(p) StgHeader_info(p)++/* Determine the size of an ordinary closure from its info table */+#define sizeW_fromITBL(itbl) \+  SIZEOF_StgHeader + WDS(%INFO_PTRS(itbl)) + WDS(%INFO_NPTRS(itbl))++/* NB. duplicated from InfoTables.h! */+#define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK)+#define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT)++/* Debugging macros */+#define LOOKS_LIKE_INFO_PTR(p)                                  \+   ((p) != NULL &&                                              \+    LOOKS_LIKE_INFO_PTR_NOT_NULL(p))++#define LOOKS_LIKE_INFO_PTR_NOT_NULL(p)                         \+   ( (TO_W_(%INFO_TYPE(%STD_INFO(p))) != INVALID_OBJECT) &&     \+     (TO_W_(%INFO_TYPE(%STD_INFO(p))) <  N_CLOSURE_TYPES))++#define LOOKS_LIKE_CLOSURE_PTR(p) (LOOKS_LIKE_INFO_PTR(GET_INFO(UNTAG(p))))++/*+ * The layout of the StgFunInfoExtra part of an info table changes+ * depending on TABLES_NEXT_TO_CODE.  So we define field access+ * macros which use the appropriate version here:+ */+#if defined(TABLES_NEXT_TO_CODE)+/*+ * when TABLES_NEXT_TO_CODE, slow_apply is stored as an offset+ * instead of the normal pointer.+ */++#define StgFunInfoExtra_slow_apply(fun_info)    \+        (TO_W_(StgFunInfoExtraRev_slow_apply_offset(fun_info))    \+               + (fun_info) + SIZEOF_StgFunInfoExtraRev + SIZEOF_StgInfoTable)++#define StgFunInfoExtra_fun_type(i)   StgFunInfoExtraRev_fun_type(i)+#define StgFunInfoExtra_arity(i)      StgFunInfoExtraRev_arity(i)+#define StgFunInfoExtra_bitmap(i)     StgFunInfoExtraRev_bitmap(i)+#else+#define StgFunInfoExtra_slow_apply(i) StgFunInfoExtraFwd_slow_apply(i)+#define StgFunInfoExtra_fun_type(i)   StgFunInfoExtraFwd_fun_type(i)+#define StgFunInfoExtra_arity(i)      StgFunInfoExtraFwd_arity(i)+#define StgFunInfoExtra_bitmap(i)     StgFunInfoExtraFwd_bitmap(i)+#endif++#define mutArrCardMask ((1 << MUT_ARR_PTRS_CARD_BITS) - 1)+#define mutArrPtrCardDown(i) ((i) >> MUT_ARR_PTRS_CARD_BITS)+#define mutArrPtrCardUp(i)   (((i) + mutArrCardMask) >> MUT_ARR_PTRS_CARD_BITS)+#define mutArrPtrsCardWords(n) ROUNDUP_BYTES_TO_WDS(mutArrPtrCardUp(n))++#if defined(PROFILING) || (!defined(THREADED_RTS) && defined(DEBUG))+#define OVERWRITING_CLOSURE_SIZE(c, size) foreign "C" overwritingClosureSize(c "ptr", size)+#define OVERWRITING_CLOSURE(c) foreign "C" overwritingClosure(c "ptr")+#define OVERWRITING_CLOSURE_OFS(c,n) foreign "C" overwritingClosureOfs(c "ptr", n)+#else+#define OVERWRITING_CLOSURE_SIZE(c, size) /* nothing */+#define OVERWRITING_CLOSURE(c) /* nothing */+#define OVERWRITING_CLOSURE_OFS(c,n) /* nothing */+#endif++#if defined(THREADED_RTS)+#define prim_write_barrier prim %write_barrier()+#else+#define prim_write_barrier /* nothing */+#endif++/* -----------------------------------------------------------------------------+   Ticky macros+   -------------------------------------------------------------------------- */++#if defined(TICKY_TICKY)+#define TICK_BUMP_BY(ctr,n) CLong[ctr] = CLong[ctr] + n+#else+#define TICK_BUMP_BY(ctr,n) /* nothing */+#endif++#define TICK_BUMP(ctr)      TICK_BUMP_BY(ctr,1)++#define TICK_ENT_DYN_IND()              TICK_BUMP(ENT_DYN_IND_ctr)+#define TICK_ENT_DYN_THK()              TICK_BUMP(ENT_DYN_THK_ctr)+#define TICK_ENT_VIA_NODE()             TICK_BUMP(ENT_VIA_NODE_ctr)+#define TICK_ENT_STATIC_IND()           TICK_BUMP(ENT_STATIC_IND_ctr)+#define TICK_ENT_PERM_IND()             TICK_BUMP(ENT_PERM_IND_ctr)+#define TICK_ENT_PAP()                  TICK_BUMP(ENT_PAP_ctr)+#define TICK_ENT_AP()                   TICK_BUMP(ENT_AP_ctr)+#define TICK_ENT_AP_STACK()             TICK_BUMP(ENT_AP_STACK_ctr)+#define TICK_ENT_BH()                   TICK_BUMP(ENT_BH_ctr)+#define TICK_ENT_LNE()                  TICK_BUMP(ENT_LNE_ctr)+#define TICK_UNKNOWN_CALL()             TICK_BUMP(UNKNOWN_CALL_ctr)+#define TICK_UPDF_PUSHED()              TICK_BUMP(UPDF_PUSHED_ctr)+#define TICK_CATCHF_PUSHED()            TICK_BUMP(CATCHF_PUSHED_ctr)+#define TICK_UPDF_OMITTED()             TICK_BUMP(UPDF_OMITTED_ctr)+#define TICK_UPD_NEW_IND()              TICK_BUMP(UPD_NEW_IND_ctr)+#define TICK_UPD_NEW_PERM_IND()         TICK_BUMP(UPD_NEW_PERM_IND_ctr)+#define TICK_UPD_OLD_IND()              TICK_BUMP(UPD_OLD_IND_ctr)+#define TICK_UPD_OLD_PERM_IND()         TICK_BUMP(UPD_OLD_PERM_IND_ctr)++#define TICK_SLOW_CALL_FUN_TOO_FEW()    TICK_BUMP(SLOW_CALL_FUN_TOO_FEW_ctr)+#define TICK_SLOW_CALL_FUN_CORRECT()    TICK_BUMP(SLOW_CALL_FUN_CORRECT_ctr)+#define TICK_SLOW_CALL_FUN_TOO_MANY()   TICK_BUMP(SLOW_CALL_FUN_TOO_MANY_ctr)+#define TICK_SLOW_CALL_PAP_TOO_FEW()    TICK_BUMP(SLOW_CALL_PAP_TOO_FEW_ctr)+#define TICK_SLOW_CALL_PAP_CORRECT()    TICK_BUMP(SLOW_CALL_PAP_CORRECT_ctr)+#define TICK_SLOW_CALL_PAP_TOO_MANY()   TICK_BUMP(SLOW_CALL_PAP_TOO_MANY_ctr)++#define TICK_SLOW_CALL_fast_v16()       TICK_BUMP(SLOW_CALL_fast_v16_ctr)+#define TICK_SLOW_CALL_fast_v()         TICK_BUMP(SLOW_CALL_fast_v_ctr)+#define TICK_SLOW_CALL_fast_p()         TICK_BUMP(SLOW_CALL_fast_p_ctr)+#define TICK_SLOW_CALL_fast_pv()        TICK_BUMP(SLOW_CALL_fast_pv_ctr)+#define TICK_SLOW_CALL_fast_pp()        TICK_BUMP(SLOW_CALL_fast_pp_ctr)+#define TICK_SLOW_CALL_fast_ppv()       TICK_BUMP(SLOW_CALL_fast_ppv_ctr)+#define TICK_SLOW_CALL_fast_ppp()       TICK_BUMP(SLOW_CALL_fast_ppp_ctr)+#define TICK_SLOW_CALL_fast_pppv()      TICK_BUMP(SLOW_CALL_fast_pppv_ctr)+#define TICK_SLOW_CALL_fast_pppp()      TICK_BUMP(SLOW_CALL_fast_pppp_ctr)+#define TICK_SLOW_CALL_fast_ppppp()     TICK_BUMP(SLOW_CALL_fast_ppppp_ctr)+#define TICK_SLOW_CALL_fast_pppppp()    TICK_BUMP(SLOW_CALL_fast_pppppp_ctr)+#define TICK_VERY_SLOW_CALL()           TICK_BUMP(VERY_SLOW_CALL_ctr)++/* NOTE: TICK_HISTO_BY and TICK_HISTO+   currently have no effect.+   The old code for it didn't typecheck and I+   just commented it out to get ticky to work.+   - krc 1/2007 */++#define TICK_HISTO_BY(histo,n,i) /* nothing */++#define TICK_HISTO(histo,n) TICK_HISTO_BY(histo,n,1)++/* An unboxed tuple with n components. */+#define TICK_RET_UNBOXED_TUP(n)                 \+  TICK_BUMP(RET_UNBOXED_TUP_ctr++);             \+  TICK_HISTO(RET_UNBOXED_TUP,n)++/*+ * A slow call with n arguments.  In the unevald case, this call has+ * already been counted once, so don't count it again.+ */+#define TICK_SLOW_CALL(n)                       \+  TICK_BUMP(SLOW_CALL_ctr);                     \+  TICK_HISTO(SLOW_CALL,n)++/*+ * This slow call was found to be to an unevaluated function; undo the+ * ticks we did in TICK_SLOW_CALL.+ */+#define TICK_SLOW_CALL_UNEVALD(n)               \+  TICK_BUMP(SLOW_CALL_UNEVALD_ctr);             \+  TICK_BUMP_BY(SLOW_CALL_ctr,-1);               \+  TICK_HISTO_BY(SLOW_CALL,n,-1);++/* Updating a closure with a new CON */+#define TICK_UPD_CON_IN_NEW(n)                  \+  TICK_BUMP(UPD_CON_IN_NEW_ctr);                \+  TICK_HISTO(UPD_CON_IN_NEW,n)++#define TICK_ALLOC_HEAP_NOCTR(bytes)            \+    TICK_BUMP(ALLOC_RTS_ctr);                   \+    TICK_BUMP_BY(ALLOC_RTS_tot,bytes)++/* -----------------------------------------------------------------------------+   Saving and restoring STG registers++   STG registers must be saved around a C call, just in case the STG+   register is mapped to a caller-saves machine register.  Normally we+   don't need to worry about this the code generator has already+   loaded any live STG registers into variables for us, but in+   hand-written low-level Cmm code where we don't know which registers+   are live, we might have to save them all.+   -------------------------------------------------------------------------- */++#define SAVE_STGREGS                            \+    W_ r1, r2, r3,  r4,  r5,  r6,  r7,  r8;     \+    F_ f1, f2, f3, f4, f5, f6;                  \+    D_ d1, d2, d3, d4, d5, d6;                  \+    L_ l1;                                      \+                                                \+    r1 = R1;                                    \+    r2 = R2;                                    \+    r3 = R3;                                    \+    r4 = R4;                                    \+    r5 = R5;                                    \+    r6 = R6;                                    \+    r7 = R7;                                    \+    r8 = R8;                                    \+                                                \+    f1 = F1;                                    \+    f2 = F2;                                    \+    f3 = F3;                                    \+    f4 = F4;                                    \+    f5 = F5;                                    \+    f6 = F6;                                    \+                                                \+    d1 = D1;                                    \+    d2 = D2;                                    \+    d3 = D3;                                    \+    d4 = D4;                                    \+    d5 = D5;                                    \+    d6 = D6;                                    \+                                                \+    l1 = L1;+++#define RESTORE_STGREGS                         \+    R1 = r1;                                    \+    R2 = r2;                                    \+    R3 = r3;                                    \+    R4 = r4;                                    \+    R5 = r5;                                    \+    R6 = r6;                                    \+    R7 = r7;                                    \+    R8 = r8;                                    \+                                                \+    F1 = f1;                                    \+    F2 = f2;                                    \+    F3 = f3;                                    \+    F4 = f4;                                    \+    F5 = f5;                                    \+    F6 = f6;                                    \+                                                \+    D1 = d1;                                    \+    D2 = d2;                                    \+    D3 = d3;                                    \+    D4 = d4;                                    \+    D5 = d5;                                    \+    D6 = d6;                                    \+                                                \+    L1 = l1;++/* -----------------------------------------------------------------------------+   Misc junk+   -------------------------------------------------------------------------- */++#define NO_TREC                   stg_NO_TREC_closure+#define END_TSO_QUEUE             stg_END_TSO_QUEUE_closure+#define STM_AWOKEN                stg_STM_AWOKEN_closure++#define recordMutableCap(p, gen)                                        \+  W_ __bd;                                                              \+  W_ mut_list;                                                          \+  mut_list = Capability_mut_lists(MyCapability()) + WDS(gen);           \+ __bd = W_[mut_list];                                                   \+  if (bdescr_free(__bd) >= bdescr_start(__bd) + BLOCK_SIZE) {           \+      W_ __new_bd;                                                      \+      ("ptr" __new_bd) = foreign "C" allocBlock_lock();                 \+      bdescr_link(__new_bd) = __bd;                                     \+      __bd = __new_bd;                                                  \+      W_[mut_list] = __bd;                                              \+  }                                                                     \+  W_ free;                                                              \+  free = bdescr_free(__bd);                                             \+  W_[free] = p;                                                         \+  bdescr_free(__bd) = free + WDS(1);++#define recordMutable(p)                                        \+      P_ __p;                                                   \+      W_ __bd;                                                  \+      W_ __gen;                                                 \+      __p = p;                                                  \+      __bd = Bdescr(__p);                                       \+      __gen = TO_W_(bdescr_gen_no(__bd));                       \+      if (__gen > 0) { recordMutableCap(__p, __gen); }++/* -----------------------------------------------------------------------------+   Arrays+   -------------------------------------------------------------------------- */++/* Complete function body for the clone family of (mutable) array ops.+   Defined as a macro to avoid function call overhead or code+   duplication. */+#define cloneArray(info, src, offset, n)                       \+    W_ words, size;                                            \+    gcptr dst, dst_p, src_p;                                   \+                                                               \+    again: MAYBE_GC(again);                                    \+                                                               \+    size = n + mutArrPtrsCardWords(n);                         \+    words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + size;         \+    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); \+    TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(size), 0);       \+                                                               \+    SET_HDR(dst, info, CCCS);                                  \+    StgMutArrPtrs_ptrs(dst) = n;                               \+    StgMutArrPtrs_size(dst) = size;                            \+                                                               \+    dst_p = dst + SIZEOF_StgMutArrPtrs;                        \+    src_p = src + SIZEOF_StgMutArrPtrs + WDS(offset);          \+    prim %memcpy(dst_p, src_p, n * SIZEOF_W, SIZEOF_W);        \+                                                               \+    return (dst);++#define copyArray(src, src_off, dst, dst_off, n)                  \+  W_ dst_elems_p, dst_p, src_p, dst_cards_p, bytes;               \+                                                                  \+    if ((n) != 0) {                                               \+        SET_HDR(dst, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);          \+                                                                  \+        dst_elems_p = (dst) + SIZEOF_StgMutArrPtrs;               \+        dst_p = dst_elems_p + WDS(dst_off);                       \+        src_p = (src) + SIZEOF_StgMutArrPtrs + WDS(src_off);      \+        bytes = WDS(n);                                           \+                                                                  \+        prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);              \+                                                                  \+        dst_cards_p = dst_elems_p + WDS(StgMutArrPtrs_ptrs(dst)); \+        setCards(dst_cards_p, dst_off, n);                        \+    }                                                             \+                                                                  \+    return ();++#define copyMutableArray(src, src_off, dst, dst_off, n)           \+  W_ dst_elems_p, dst_p, src_p, dst_cards_p, bytes;               \+                                                                  \+    if ((n) != 0) {                                               \+        SET_HDR(dst, stg_MUT_ARR_PTRS_DIRTY_info, CCCS);          \+                                                                  \+        dst_elems_p = (dst) + SIZEOF_StgMutArrPtrs;               \+        dst_p = dst_elems_p + WDS(dst_off);                       \+        src_p = (src) + SIZEOF_StgMutArrPtrs + WDS(src_off);      \+        bytes = WDS(n);                                           \+                                                                  \+        if ((src) == (dst)) {                                     \+            prim %memmove(dst_p, src_p, bytes, SIZEOF_W);         \+        } else {                                                  \+            prim %memcpy(dst_p, src_p, bytes, SIZEOF_W);          \+        }                                                         \+                                                                  \+        dst_cards_p = dst_elems_p + WDS(StgMutArrPtrs_ptrs(dst)); \+        setCards(dst_cards_p, dst_off, n);                        \+    }                                                             \+                                                                  \+    return ();++/*+ * Set the cards in the cards table pointed to by dst_cards_p for an+ * update to n elements, starting at element dst_off.+ */+#define setCards(dst_cards_p, dst_off, n)                      \+    W_ __start_card, __end_card, __cards;                      \+    __start_card = mutArrPtrCardDown(dst_off);                 \+    __end_card = mutArrPtrCardDown((dst_off) + (n) - 1);       \+    __cards = __end_card - __start_card + 1;                   \+    prim %memset((dst_cards_p) + __start_card, 1, __cards, 1);++/* Complete function body for the clone family of small (mutable)+   array ops. Defined as a macro to avoid function call overhead or+   code duplication. */+#define cloneSmallArray(info, src, offset, n)                  \+    W_ words, size;                                            \+    gcptr dst, dst_p, src_p;                                   \+                                                               \+    again: MAYBE_GC(again);                                    \+                                                               \+    words = BYTES_TO_WDS(SIZEOF_StgSmallMutArrPtrs) + n;       \+    ("ptr" dst) = ccall allocate(MyCapability() "ptr", words); \+    TICK_ALLOC_PRIM(SIZEOF_StgSmallMutArrPtrs, WDS(n), 0);     \+                                                               \+    SET_HDR(dst, info, CCCS);                                  \+    StgSmallMutArrPtrs_ptrs(dst) = n;                          \+                                                               \+    dst_p = dst + SIZEOF_StgSmallMutArrPtrs;                   \+    src_p = src + SIZEOF_StgSmallMutArrPtrs + WDS(offset);     \+    prim %memcpy(dst_p, src_p, n * SIZEOF_W, SIZEOF_W);        \+                                                               \+    return (dst);
+ includes/CodeGen.Platform.hs view
@@ -0,0 +1,1063 @@++import CmmExpr+#if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \+    || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc))+import Panic+#endif+import Reg++#include "ghcautoconf.h"+#include "stg/MachRegs.h"++#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64)++# if defined(MACHREGS_i386)+#  define eax 0+#  define ebx 1+#  define ecx 2+#  define edx 3+#  define esi 4+#  define edi 5+#  define ebp 6+#  define esp 7+# endif++# if defined(MACHREGS_x86_64)+#  define rax   0+#  define rbx   1+#  define rcx   2+#  define rdx   3+#  define rsi   4+#  define rdi   5+#  define rbp   6+#  define rsp   7+#  define r8    8+#  define r9    9+#  define r10   10+#  define r11   11+#  define r12   12+#  define r13   13+#  define r14   14+#  define r15   15+# endif+++-- N.B. XMM, YMM, and ZMM are all aliased to the same hardware registers hence+-- being assigned the same RegNos.+# define xmm0  16+# define xmm1  17+# define xmm2  18+# define xmm3  19+# define xmm4  20+# define xmm5  21+# define xmm6  22+# define xmm7  23+# define xmm8  24+# define xmm9  25+# define xmm10 26+# define xmm11 27+# define xmm12 28+# define xmm13 29+# define xmm14 30+# define xmm15 31++# define ymm0  16+# define ymm1  17+# define ymm2  18+# define ymm3  19+# define ymm4  20+# define ymm5  21+# define ymm6  22+# define ymm7  23+# define ymm8  24+# define ymm9  25+# define ymm10 26+# define ymm11 27+# define ymm12 28+# define ymm13 29+# define ymm14 30+# define ymm15 31++# define zmm0  16+# define zmm1  17+# define zmm2  18+# define zmm3  19+# define zmm4  20+# define zmm5  21+# define zmm6  22+# define zmm7  23+# define zmm8  24+# define zmm9  25+# define zmm10 26+# define zmm11 27+# define zmm12 28+# define zmm13 29+# define zmm14 30+# define zmm15 31++-- Note: these are only needed for ARM/ARM64 because globalRegMaybe is now used in CmmSink.hs.+-- Since it's only used to check 'isJust', the actual values don't matter, thus+-- I'm not sure if these are the correct numberings.+-- Normally, the register names are just stringified as part of the REG() macro++#elif defined(MACHREGS_powerpc) || defined(MACHREGS_arm) \+    || defined(MACHREGS_aarch64)++# define r0 0+# define r1 1+# define r2 2+# define r3 3+# define r4 4+# define r5 5+# define r6 6+# define r7 7+# define r8 8+# define r9 9+# define r10 10+# define r11 11+# define r12 12+# define r13 13+# define r14 14+# define r15 15+# define r16 16+# define r17 17+# define r18 18+# define r19 19+# define r20 20+# define r21 21+# define r22 22+# define r23 23+# define r24 24+# define r25 25+# define r26 26+# define r27 27+# define r28 28+# define r29 29+# define r30 30+# define r31 31++-- See note above. These aren't actually used for anything except satisfying the compiler for globalRegMaybe+-- so I'm unsure if they're the correct numberings, should they ever be attempted to be used in the NCG.+#if defined(MACHREGS_aarch64) || defined(MACHREGS_arm)+# define s0 32+# define s1 33+# define s2 34+# define s3 35+# define s4 36+# define s5 37+# define s6 38+# define s7 39+# define s8 40+# define s9 41+# define s10 42+# define s11 43+# define s12 44+# define s13 45+# define s14 46+# define s15 47+# define s16 48+# define s17 49+# define s18 50+# define s19 51+# define s20 52+# define s21 53+# define s22 54+# define s23 55+# define s24 56+# define s25 57+# define s26 58+# define s27 59+# define s28 60+# define s29 61+# define s30 62+# define s31 63++# define d0 32+# define d1 33+# define d2 34+# define d3 35+# define d4 36+# define d5 37+# define d6 38+# define d7 39+# define d8 40+# define d9 41+# define d10 42+# define d11 43+# define d12 44+# define d13 45+# define d14 46+# define d15 47+# define d16 48+# define d17 49+# define d18 50+# define d19 51+# define d20 52+# define d21 53+# define d22 54+# define d23 55+# define d24 56+# define d25 57+# define d26 58+# define d27 59+# define d28 60+# define d29 61+# define d30 62+# define d31 63+#endif++# if defined(MACHREGS_darwin)+#  define f0  32+#  define f1  33+#  define f2  34+#  define f3  35+#  define f4  36+#  define f5  37+#  define f6  38+#  define f7  39+#  define f8  40+#  define f9  41+#  define f10 42+#  define f11 43+#  define f12 44+#  define f13 45+#  define f14 46+#  define f15 47+#  define f16 48+#  define f17 49+#  define f18 50+#  define f19 51+#  define f20 52+#  define f21 53+#  define f22 54+#  define f23 55+#  define f24 56+#  define f25 57+#  define f26 58+#  define f27 59+#  define f28 60+#  define f29 61+#  define f30 62+#  define f31 63+# else+#  define fr0  32+#  define fr1  33+#  define fr2  34+#  define fr3  35+#  define fr4  36+#  define fr5  37+#  define fr6  38+#  define fr7  39+#  define fr8  40+#  define fr9  41+#  define fr10 42+#  define fr11 43+#  define fr12 44+#  define fr13 45+#  define fr14 46+#  define fr15 47+#  define fr16 48+#  define fr17 49+#  define fr18 50+#  define fr19 51+#  define fr20 52+#  define fr21 53+#  define fr22 54+#  define fr23 55+#  define fr24 56+#  define fr25 57+#  define fr26 58+#  define fr27 59+#  define fr28 60+#  define fr29 61+#  define fr30 62+#  define fr31 63+# endif++#elif defined(MACHREGS_sparc)++# define g0  0+# define g1  1+# define g2  2+# define g3  3+# define g4  4+# define g5  5+# define g6  6+# define g7  7++# define o0  8+# define o1  9+# define o2  10+# define o3  11+# define o4  12+# define o5  13+# define o6  14+# define o7  15++# define l0  16+# define l1  17+# define l2  18+# define l3  19+# define l4  20+# define l5  21+# define l6  22+# define l7  23++# define i0  24+# define i1  25+# define i2  26+# define i3  27+# define i4  28+# define i5  29+# define i6  30+# define i7  31++# define f0  32+# define f1  33+# define f2  34+# define f3  35+# define f4  36+# define f5  37+# define f6  38+# define f7  39+# define f8  40+# define f9  41+# define f10 42+# define f11 43+# define f12 44+# define f13 45+# define f14 46+# define f15 47+# define f16 48+# define f17 49+# define f18 50+# define f19 51+# define f20 52+# define f21 53+# define f22 54+# define f23 55+# define f24 56+# define f25 57+# define f26 58+# define f27 59+# define f28 60+# define f29 61+# define f30 62+# define f31 63++#endif++callerSaves :: GlobalReg -> Bool+#if defined(CALLER_SAVES_Base)+callerSaves BaseReg           = True+#endif+#if defined(CALLER_SAVES_R1)+callerSaves (VanillaReg 1 _)  = True+#endif+#if defined(CALLER_SAVES_R2)+callerSaves (VanillaReg 2 _)  = True+#endif+#if defined(CALLER_SAVES_R3)+callerSaves (VanillaReg 3 _)  = True+#endif+#if defined(CALLER_SAVES_R4)+callerSaves (VanillaReg 4 _)  = True+#endif+#if defined(CALLER_SAVES_R5)+callerSaves (VanillaReg 5 _)  = True+#endif+#if defined(CALLER_SAVES_R6)+callerSaves (VanillaReg 6 _)  = True+#endif+#if defined(CALLER_SAVES_R7)+callerSaves (VanillaReg 7 _)  = True+#endif+#if defined(CALLER_SAVES_R8)+callerSaves (VanillaReg 8 _)  = True+#endif+#if defined(CALLER_SAVES_R9)+callerSaves (VanillaReg 9 _)  = True+#endif+#if defined(CALLER_SAVES_R10)+callerSaves (VanillaReg 10 _) = True+#endif+#if defined(CALLER_SAVES_F1)+callerSaves (FloatReg 1)      = True+#endif+#if defined(CALLER_SAVES_F2)+callerSaves (FloatReg 2)      = True+#endif+#if defined(CALLER_SAVES_F3)+callerSaves (FloatReg 3)      = True+#endif+#if defined(CALLER_SAVES_F4)+callerSaves (FloatReg 4)      = True+#endif+#if defined(CALLER_SAVES_F5)+callerSaves (FloatReg 5)      = True+#endif+#if defined(CALLER_SAVES_F6)+callerSaves (FloatReg 6)      = True+#endif+#if defined(CALLER_SAVES_D1)+callerSaves (DoubleReg 1)     = True+#endif+#if defined(CALLER_SAVES_D2)+callerSaves (DoubleReg 2)     = True+#endif+#if defined(CALLER_SAVES_D3)+callerSaves (DoubleReg 3)     = True+#endif+#if defined(CALLER_SAVES_D4)+callerSaves (DoubleReg 4)     = True+#endif+#if defined(CALLER_SAVES_D5)+callerSaves (DoubleReg 5)     = True+#endif+#if defined(CALLER_SAVES_D6)+callerSaves (DoubleReg 6)     = True+#endif+#if defined(CALLER_SAVES_L1)+callerSaves (LongReg 1)       = True+#endif+#if defined(CALLER_SAVES_Sp)+callerSaves Sp                = True+#endif+#if defined(CALLER_SAVES_SpLim)+callerSaves SpLim             = True+#endif+#if defined(CALLER_SAVES_Hp)+callerSaves Hp                = True+#endif+#if defined(CALLER_SAVES_HpLim)+callerSaves HpLim             = True+#endif+#if defined(CALLER_SAVES_CCCS)+callerSaves CCCS              = True+#endif+#if defined(CALLER_SAVES_CurrentTSO)+callerSaves CurrentTSO        = True+#endif+#if defined(CALLER_SAVES_CurrentNursery)+callerSaves CurrentNursery    = True+#endif+callerSaves _                 = False++activeStgRegs :: [GlobalReg]+activeStgRegs = [+#if defined(REG_Base)+    BaseReg+#endif+#if defined(REG_Sp)+    ,Sp+#endif+#if defined(REG_Hp)+    ,Hp+#endif+#if defined(REG_R1)+    ,VanillaReg 1 VGcPtr+#endif+#if defined(REG_R2)+    ,VanillaReg 2 VGcPtr+#endif+#if defined(REG_R3)+    ,VanillaReg 3 VGcPtr+#endif+#if defined(REG_R4)+    ,VanillaReg 4 VGcPtr+#endif+#if defined(REG_R5)+    ,VanillaReg 5 VGcPtr+#endif+#if defined(REG_R6)+    ,VanillaReg 6 VGcPtr+#endif+#if defined(REG_R7)+    ,VanillaReg 7 VGcPtr+#endif+#if defined(REG_R8)+    ,VanillaReg 8 VGcPtr+#endif+#if defined(REG_R9)+    ,VanillaReg 9 VGcPtr+#endif+#if defined(REG_R10)+    ,VanillaReg 10 VGcPtr+#endif+#if defined(REG_SpLim)+    ,SpLim+#endif+#if MAX_REAL_XMM_REG != 0+#if defined(REG_F1)+    ,FloatReg 1+#endif+#if defined(REG_D1)+    ,DoubleReg 1+#endif+#if defined(REG_XMM1)+    ,XmmReg 1+#endif+#if defined(REG_YMM1)+    ,YmmReg 1+#endif+#if defined(REG_ZMM1)+    ,ZmmReg 1+#endif+#if defined(REG_F2)+    ,FloatReg 2+#endif+#if defined(REG_D2)+    ,DoubleReg 2+#endif+#if defined(REG_XMM2)+    ,XmmReg 2+#endif+#if defined(REG_YMM2)+    ,YmmReg 2+#endif+#if defined(REG_ZMM2)+    ,ZmmReg 2+#endif+#if defined(REG_F3)+    ,FloatReg 3+#endif+#if defined(REG_D3)+    ,DoubleReg 3+#endif+#if defined(REG_XMM3)+    ,XmmReg 3+#endif+#if defined(REG_YMM3)+    ,YmmReg 3+#endif+#if defined(REG_ZMM3)+    ,ZmmReg 3+#endif+#if defined(REG_F4)+    ,FloatReg 4+#endif+#if defined(REG_D4)+    ,DoubleReg 4+#endif+#if defined(REG_XMM4)+    ,XmmReg 4+#endif+#if defined(REG_YMM4)+    ,YmmReg 4+#endif+#if defined(REG_ZMM4)+    ,ZmmReg 4+#endif+#if defined(REG_F5)+    ,FloatReg 5+#endif+#if defined(REG_D5)+    ,DoubleReg 5+#endif+#if defined(REG_XMM5)+    ,XmmReg 5+#endif+#if defined(REG_YMM5)+    ,YmmReg 5+#endif+#if defined(REG_ZMM5)+    ,ZmmReg 5+#endif+#if defined(REG_F6)+    ,FloatReg 6+#endif+#if defined(REG_D6)+    ,DoubleReg 6+#endif+#if defined(REG_XMM6)+    ,XmmReg 6+#endif+#if defined(REG_YMM6)+    ,YmmReg 6+#endif+#if defined(REG_ZMM6)+    ,ZmmReg 6+#endif+#else /* MAX_REAL_XMM_REG == 0 */+#if defined(REG_F1)+    ,FloatReg 1+#endif+#if defined(REG_F2)+    ,FloatReg 2+#endif+#if defined(REG_F3)+    ,FloatReg 3+#endif+#if defined(REG_F4)+    ,FloatReg 4+#endif+#if defined(REG_F5)+    ,FloatReg 5+#endif+#if defined(REG_F6)+    ,FloatReg 6+#endif+#if defined(REG_D1)+    ,DoubleReg 1+#endif+#if defined(REG_D2)+    ,DoubleReg 2+#endif+#if defined(REG_D3)+    ,DoubleReg 3+#endif+#if defined(REG_D4)+    ,DoubleReg 4+#endif+#if defined(REG_D5)+    ,DoubleReg 5+#endif+#if defined(REG_D6)+    ,DoubleReg 6+#endif+#endif /* MAX_REAL_XMM_REG == 0 */+    ]++haveRegBase :: Bool+#if defined(REG_Base)+haveRegBase = True+#else+haveRegBase = False+#endif++--  | Returns 'Nothing' if this global register is not stored+-- in a real machine register, otherwise returns @'Just' reg@, where+-- reg is the machine register it is stored in.+globalRegMaybe :: GlobalReg -> Maybe RealReg+#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \+    || defined(MACHREGS_sparc) || defined(MACHREGS_powerpc) \+    || defined(MACHREGS_arm) || defined(MACHREGS_aarch64)+# if defined(REG_Base)+globalRegMaybe BaseReg                  = Just (RealRegSingle REG_Base)+# endif+# if defined(REG_R1)+globalRegMaybe (VanillaReg 1 _)         = Just (RealRegSingle REG_R1)+# endif+# if defined(REG_R2)+globalRegMaybe (VanillaReg 2 _)         = Just (RealRegSingle REG_R2)+# endif+# if defined(REG_R3)+globalRegMaybe (VanillaReg 3 _)         = Just (RealRegSingle REG_R3)+# endif+# if defined(REG_R4)+globalRegMaybe (VanillaReg 4 _)         = Just (RealRegSingle REG_R4)+# endif+# if defined(REG_R5)+globalRegMaybe (VanillaReg 5 _)         = Just (RealRegSingle REG_R5)+# endif+# if defined(REG_R6)+globalRegMaybe (VanillaReg 6 _)         = Just (RealRegSingle REG_R6)+# endif+# if defined(REG_R7)+globalRegMaybe (VanillaReg 7 _)         = Just (RealRegSingle REG_R7)+# endif+# if defined(REG_R8)+globalRegMaybe (VanillaReg 8 _)         = Just (RealRegSingle REG_R8)+# endif+# if defined(REG_R9)+globalRegMaybe (VanillaReg 9 _)         = Just (RealRegSingle REG_R9)+# endif+# if defined(REG_R10)+globalRegMaybe (VanillaReg 10 _)        = Just (RealRegSingle REG_R10)+# endif+# if defined(REG_F1)+globalRegMaybe (FloatReg 1)             = Just (RealRegSingle REG_F1)+# endif+# if defined(REG_F2)+globalRegMaybe (FloatReg 2)             = Just (RealRegSingle REG_F2)+# endif+# if defined(REG_F3)+globalRegMaybe (FloatReg 3)             = Just (RealRegSingle REG_F3)+# endif+# if defined(REG_F4)+globalRegMaybe (FloatReg 4)             = Just (RealRegSingle REG_F4)+# endif+# if defined(REG_F5)+globalRegMaybe (FloatReg 5)             = Just (RealRegSingle REG_F5)+# endif+# if defined(REG_F6)+globalRegMaybe (FloatReg 6)             = Just (RealRegSingle REG_F6)+# endif+# if defined(REG_D1)+globalRegMaybe (DoubleReg 1)            =+#  if defined(MACHREGS_sparc)+                                          Just (RealRegPair REG_D1 (REG_D1 + 1))+#  else+                                          Just (RealRegSingle REG_D1)+#  endif+# endif+# if defined(REG_D2)+globalRegMaybe (DoubleReg 2)            =+#  if defined(MACHREGS_sparc)+                                          Just (RealRegPair REG_D2 (REG_D2 + 1))+#  else+                                          Just (RealRegSingle REG_D2)+#  endif+# endif+# if defined(REG_D3)+globalRegMaybe (DoubleReg 3)            =+#  if defined(MACHREGS_sparc)+                                          Just (RealRegPair REG_D3 (REG_D3 + 1))+#  else+                                          Just (RealRegSingle REG_D3)+#  endif+# endif+# if defined(REG_D4)+globalRegMaybe (DoubleReg 4)            =+#  if defined(MACHREGS_sparc)+                                          Just (RealRegPair REG_D4 (REG_D4 + 1))+#  else+                                          Just (RealRegSingle REG_D4)+#  endif+# endif+# if defined(REG_D5)+globalRegMaybe (DoubleReg 5)            =+#  if defined(MACHREGS_sparc)+                                          Just (RealRegPair REG_D5 (REG_D5 + 1))+#  else+                                          Just (RealRegSingle REG_D5)+#  endif+# endif+# if defined(REG_D6)+globalRegMaybe (DoubleReg 6)            =+#  if defined(MACHREGS_sparc)+                                          Just (RealRegPair REG_D6 (REG_D6 + 1))+#  else+                                          Just (RealRegSingle REG_D6)+#  endif+# endif+# if MAX_REAL_XMM_REG != 0+#  if defined(REG_XMM1)+globalRegMaybe (XmmReg 1)               = Just (RealRegSingle REG_XMM1)+#  endif+#  if defined(REG_XMM2)+globalRegMaybe (XmmReg 2)               = Just (RealRegSingle REG_XMM2)+#  endif+#  if defined(REG_XMM3)+globalRegMaybe (XmmReg 3)               = Just (RealRegSingle REG_XMM3)+#  endif+#  if defined(REG_XMM4)+globalRegMaybe (XmmReg 4)               = Just (RealRegSingle REG_XMM4)+#  endif+#  if defined(REG_XMM5)+globalRegMaybe (XmmReg 5)               = Just (RealRegSingle REG_XMM5)+#  endif+#  if defined(REG_XMM6)+globalRegMaybe (XmmReg 6)               = Just (RealRegSingle REG_XMM6)+#  endif+# endif+# if defined(MAX_REAL_YMM_REG) && MAX_REAL_YMM_REG != 0+#  if defined(REG_YMM1)+globalRegMaybe (YmmReg 1)               = Just (RealRegSingle REG_YMM1)+#  endif+#  if defined(REG_YMM2)+globalRegMaybe (YmmReg 2)               = Just (RealRegSingle REG_YMM2)+#  endif+#  if defined(REG_YMM3)+globalRegMaybe (YmmReg 3)               = Just (RealRegSingle REG_YMM3)+#  endif+#  if defined(REG_YMM4)+globalRegMaybe (YmmReg 4)               = Just (RealRegSingle REG_YMM4)+#  endif+#  if defined(REG_YMM5)+globalRegMaybe (YmmReg 5)               = Just (RealRegSingle REG_YMM5)+#  endif+#  if defined(REG_YMM6)+globalRegMaybe (YmmReg 6)               = Just (RealRegSingle REG_YMM6)+#  endif+# endif+# if defined(MAX_REAL_ZMM_REG) && MAX_REAL_ZMM_REG != 0+#  if defined(REG_ZMM1)+globalRegMaybe (ZmmReg 1)               = Just (RealRegSingle REG_ZMM1)+#  endif+#  if defined(REG_ZMM2)+globalRegMaybe (ZmmReg 2)               = Just (RealRegSingle REG_ZMM2)+#  endif+#  if defined(REG_ZMM3)+globalRegMaybe (ZmmReg 3)               = Just (RealRegSingle REG_ZMM3)+#  endif+#  if defined(REG_ZMM4)+globalRegMaybe (ZmmReg 4)               = Just (RealRegSingle REG_ZMM4)+#  endif+#  if defined(REG_ZMM5)+globalRegMaybe (ZmmReg 5)               = Just (RealRegSingle REG_ZMM5)+#  endif+#  if defined(REG_ZMM6)+globalRegMaybe (ZmmReg 6)               = Just (RealRegSingle REG_ZMM6)+#  endif+# endif+# if defined(REG_Sp)+globalRegMaybe Sp                       = Just (RealRegSingle REG_Sp)+# endif+# if defined(REG_Lng1)+globalRegMaybe (LongReg 1)              = Just (RealRegSingle REG_Lng1)+# endif+# if defined(REG_Lng2)+globalRegMaybe (LongReg 2)              = Just (RealRegSingle REG_Lng2)+# endif+# if defined(REG_SpLim)+globalRegMaybe SpLim                    = Just (RealRegSingle REG_SpLim)+# endif+# if defined(REG_Hp)+globalRegMaybe Hp                       = Just (RealRegSingle REG_Hp)+# endif+# if defined(REG_HpLim)+globalRegMaybe HpLim                    = Just (RealRegSingle REG_HpLim)+# endif+# if defined(REG_CurrentTSO)+globalRegMaybe CurrentTSO               = Just (RealRegSingle REG_CurrentTSO)+# endif+# if defined(REG_CurrentNursery)+globalRegMaybe CurrentNursery           = Just (RealRegSingle REG_CurrentNursery)+# endif+# if defined(REG_MachSp)+globalRegMaybe MachSp                   = Just (RealRegSingle REG_MachSp)+# endif+globalRegMaybe _                        = Nothing+#elif defined(MACHREGS_NO_REGS)+globalRegMaybe _ = Nothing+#else+globalRegMaybe = panic "globalRegMaybe not defined for this platform"+#endif++freeReg :: RegNo -> Bool++#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64)++# if defined(MACHREGS_i386)+freeReg esp = False -- %esp is the C stack pointer+freeReg esi = False -- Note [esi/edi/ebp not allocatable]+freeReg edi = False+freeReg ebp = False+# endif+# if defined(MACHREGS_x86_64)+freeReg rsp = False  --        %rsp is the C stack pointer+# endif++{-+Note [esi/edi/ebp not allocatable]++%esi is mapped to R1, so %esi would normally be allocatable while it+is not being used for R1.  However, %esi has no 8-bit version on x86,+and the linear register allocator is not sophisticated enough to+handle this irregularity (we need more RegClasses).  The+graph-colouring allocator also cannot handle this - it was designed+with more flexibility in mind, but the current implementation is+restricted to the same set of classes as the linear allocator.++Hence, on x86 esi, edi and ebp are treated as not allocatable.+-}++-- split patterns in two functions to prevent overlaps+freeReg r         = freeRegBase r++freeRegBase :: RegNo -> Bool+# if defined(REG_Base)+freeRegBase REG_Base  = False+# endif+# if defined(REG_Sp)+freeRegBase REG_Sp    = False+# endif+# if defined(REG_SpLim)+freeRegBase REG_SpLim = False+# endif+# if defined(REG_Hp)+freeRegBase REG_Hp    = False+# endif+# if defined(REG_HpLim)+freeRegBase REG_HpLim = False+# endif+-- All other regs are considered to be "free", because we can track+-- their liveness accurately.+freeRegBase _ = True++#elif defined(MACHREGS_powerpc)++freeReg 0 = False -- Used by code setting the back chain pointer+                  -- in stack reallocations on Linux.+                  -- Moreover r0 is not usable in all insns.+freeReg 1 = False -- The Stack Pointer+-- most ELF PowerPC OSes use r2 as a TOC pointer+freeReg 2 = False+freeReg 13 = False -- reserved for system thread ID on 64 bit+-- at least linux in -fPIC relies on r30 in PLT stubs+freeReg 30 = False+{- TODO: reserve r13 on 64 bit systems only and r30 on 32 bit respectively.+   For now we use r30 on 64 bit and r13 on 32 bit as a temporary register+   in stack handling code. See compiler/nativeGen/PPC/Instr.hs.++   Later we might want to reserve r13 and r30 only where it is required.+   Then use r12 as temporary register, which is also what the C ABI does.+-}++# if defined(REG_Base)+freeReg REG_Base  = False+# endif+# if defined(REG_Sp)+freeReg REG_Sp    = False+# endif+# if defined(REG_SpLim)+freeReg REG_SpLim = False+# endif+# if defined(REG_Hp)+freeReg REG_Hp    = False+# endif+# if defined(REG_HpLim)+freeReg REG_HpLim = False+# endif+freeReg _ = True++#elif defined(MACHREGS_sparc)++-- SPARC regs used by the OS / ABI+-- %g0(r0) is always zero+freeReg g0  = False++-- %g5(r5) - %g7(r7)+--  are reserved for the OS+freeReg g5  = False+freeReg g6  = False+freeReg g7  = False++-- %o6(r14)+--  is the C stack pointer+freeReg o6  = False++-- %o7(r15)+--  holds the C return address+freeReg o7  = False++-- %i6(r30)+--  is the C frame pointer+freeReg i6  = False++-- %i7(r31)+--  is used for C return addresses+freeReg i7  = False++-- %f0(r32) - %f1(r32)+--  are C floating point return regs+freeReg f0  = False+freeReg f1  = False++{-+freeReg regNo+    -- don't release high half of double regs+    | regNo >= f0+    , regNo <  NCG_FirstFloatReg+    , regNo `mod` 2 /= 0+    = False+-}++# if defined(REG_Base)+freeReg REG_Base  = False+# endif+# if defined(REG_R1)+freeReg REG_R1    = False+# endif+# if defined(REG_R2)+freeReg REG_R2    = False+# endif+# if defined(REG_R3)+freeReg REG_R3    = False+# endif+# if defined(REG_R4)+freeReg REG_R4    = False+# endif+# if defined(REG_R5)+freeReg REG_R5    = False+# endif+# if defined(REG_R6)+freeReg REG_R6    = False+# endif+# if defined(REG_R7)+freeReg REG_R7    = False+# endif+# if defined(REG_R8)+freeReg REG_R8    = False+# endif+# if defined(REG_R9)+freeReg REG_R9    = False+# endif+# if defined(REG_R10)+freeReg REG_R10   = False+# endif+# if defined(REG_F1)+freeReg REG_F1    = False+# endif+# if defined(REG_F2)+freeReg REG_F2    = False+# endif+# if defined(REG_F3)+freeReg REG_F3    = False+# endif+# if defined(REG_F4)+freeReg REG_F4    = False+# endif+# if defined(REG_F5)+freeReg REG_F5    = False+# endif+# if defined(REG_F6)+freeReg REG_F6    = False+# endif+# if defined(REG_D1)+freeReg REG_D1    = False+# endif+# if defined(REG_D1_2)+freeReg REG_D1_2  = False+# endif+# if defined(REG_D2)+freeReg REG_D2    = False+# endif+# if defined(REG_D2_2)+freeReg REG_D2_2  = False+# endif+# if defined(REG_D3)+freeReg REG_D3    = False+# endif+# if defined(REG_D3_2)+freeReg REG_D3_2  = False+# endif+# if defined(REG_D4)+freeReg REG_D4    = False+# endif+# if defined(REG_D4_2)+freeReg REG_D4_2  = False+# endif+# if defined(REG_D5)+freeReg REG_D5    = False+# endif+# if defined(REG_D5_2)+freeReg REG_D5_2  = False+# endif+# if defined(REG_D6)+freeReg REG_D6    = False+# endif+# if defined(REG_D6_2)+freeReg REG_D6_2  = False+# endif+# if defined(REG_Sp)+freeReg REG_Sp    = False+# endif+# if defined(REG_SpLim)+freeReg REG_SpLim = False+# endif+# if defined(REG_Hp)+freeReg REG_Hp    = False+# endif+# if defined(REG_HpLim)+freeReg REG_HpLim = False+# endif+freeReg _ = True++#else++freeReg = panic "freeReg not defined for this platform"++#endif+
+ includes/HsFFI.h view
@@ -0,0 +1,141 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2000+ *+ * A mapping for Haskell types to C types, including the corresponding bounds.+ * Intended to be used in conjuction with the FFI.+ *+ * WARNING: Keep this file and StgTypes.h in synch!+ *+ * ---------------------------------------------------------------------------*/++#pragma once++#if defined(__cplusplus)+extern "C" {+#endif++/* get types from GHC's runtime system */+#include "ghcconfig.h"+#include "stg/Types.h"++/* get limits for floating point types */+#include <float.h>++typedef StgChar                 HsChar;+typedef StgInt                  HsInt;+typedef StgInt8                 HsInt8;+typedef StgInt16                HsInt16;+typedef StgInt32                HsInt32;+typedef StgInt64                HsInt64;+typedef StgWord                 HsWord;+typedef StgWord8                HsWord8;+typedef StgWord16               HsWord16;+typedef StgWord32               HsWord32;+typedef StgWord64               HsWord64;+typedef StgFloat                HsFloat;+typedef StgDouble               HsDouble;+typedef StgInt                  HsBool;+typedef void*                   HsPtr;          /* this should better match StgAddr */+typedef void                    (*HsFunPtr)(void); /* this should better match StgAddr */+typedef void*                   HsStablePtr;++/* this should correspond to the type of StgChar in StgTypes.h */+#define HS_CHAR_MIN             0+#define HS_CHAR_MAX             0x10FFFF++/* is it true or not?  */+#define HS_BOOL_FALSE           0+#define HS_BOOL_TRUE            1++#define HS_BOOL_MIN             HS_BOOL_FALSE+#define HS_BOOL_MAX             HS_BOOL_TRUE+++#define HS_INT_MIN              STG_INT_MIN+#define HS_INT_MAX              STG_INT_MAX+#define HS_WORD_MAX             STG_WORD_MAX++#define HS_INT8_MIN             STG_INT8_MIN+#define HS_INT8_MAX             STG_INT8_MAX+#define HS_INT16_MIN            STG_INT16_MIN+#define HS_INT16_MAX            STG_INT16_MAX+#define HS_INT32_MIN            STG_INT32_MIN+#define HS_INT32_MAX            STG_INT32_MAX+#define HS_INT64_MIN            STG_INT64_MIN+#define HS_INT64_MAX            STG_INT64_MAX+#define HS_WORD8_MAX            STG_WORD8_MAX+#define HS_WORD16_MAX           STG_WORD16_MAX+#define HS_WORD32_MAX           STG_WORD32_MAX+#define HS_WORD64_MAX           STG_WORD64_MAX++#define HS_FLOAT_RADIX          FLT_RADIX+#define HS_FLOAT_ROUNDS         FLT_ROUNDS+#define HS_FLOAT_EPSILON        FLT_EPSILON+#define HS_FLOAT_DIG            FLT_DIG+#define HS_FLOAT_MANT_DIG       FLT_MANT_DIG+#define HS_FLOAT_MIN            FLT_MIN+#define HS_FLOAT_MIN_EXP        FLT_MIN_EXP+#define HS_FLOAT_MIN_10_EXP     FLT_MIN_10_EXP+#define HS_FLOAT_MAX            FLT_MAX+#define HS_FLOAT_MAX_EXP        FLT_MAX_EXP+#define HS_FLOAT_MAX_10_EXP     FLT_MAX_10_EXP++#define HS_DOUBLE_RADIX         DBL_RADIX+#define HS_DOUBLE_ROUNDS        DBL_ROUNDS+#define HS_DOUBLE_EPSILON       DBL_EPSILON+#define HS_DOUBLE_DIG           DBL_DIG+#define HS_DOUBLE_MANT_DIG      DBL_MANT_DIG+#define HS_DOUBLE_MIN           DBL_MIN+#define HS_DOUBLE_MIN_EXP       DBL_MIN_EXP+#define HS_DOUBLE_MIN_10_EXP    DBL_MIN_10_EXP+#define HS_DOUBLE_MAX           DBL_MAX+#define HS_DOUBLE_MAX_EXP       DBL_MAX_EXP+#define HS_DOUBLE_MAX_10_EXP    DBL_MAX_10_EXP++extern void hs_init     (int *argc, char **argv[]);+extern void hs_exit     (void);+extern void hs_exit_nowait(void);+extern void hs_set_argv (int argc, char *argv[]);+extern void hs_thread_done (void);++extern void hs_perform_gc (void);++// Lock the stable pointer table. The table must be unlocked+// again before calling any Haskell functions, even if those+// functions do not manipulate stable pointers. The Haskell+// garbage collector will not be able to run until this lock+// is released! It is also forbidden to call hs_free_fun_ptr+// or any stable pointer-related FFI functions other than+// hs_free_stable_ptr_unsafe while the table is locked.+extern void hs_lock_stable_ptr_table (void);++// A deprecated synonym.+extern void hs_lock_stable_tables (void);++// Unlock the stable pointer table.+extern void hs_unlock_stable_ptr_table (void);++// A deprecated synonym.+extern void hs_unlock_stable_tables (void);++// Free a stable pointer assuming that the stable pointer+// table is already locked.+extern void hs_free_stable_ptr_unsafe (HsStablePtr sp);++extern void hs_free_stable_ptr (HsStablePtr sp);+extern void hs_free_fun_ptr    (HsFunPtr fp);++extern StgPtr hs_spt_lookup(StgWord64 key1, StgWord64 key2);+extern int hs_spt_keys(StgPtr keys[], int szKeys);+extern int hs_spt_key_count (void);++extern void hs_try_putmvar (int capability, HsStablePtr sp);++/* -------------------------------------------------------------------------- */++++#if defined(__cplusplus)+}+#endif
+ includes/MachDeps.h view
@@ -0,0 +1,123 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The University of Glasgow 2002+ *+ * Definitions that characterise machine specific properties of basic+ * types (C & Haskell) of a target platform.+ *+ * NB: Keep in sync with HsFFI.h and StgTypes.h.+ * NB: THIS FILE IS INCLUDED IN HASKELL SOURCE!+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++/* Don't allow stage1 (cross-)compiler embed assumptions about target+ * platform. When ghc-stage1 is being built by ghc-stage0 is should not+ * refer to target defines. A few past examples:+ *  - https://gitlab.haskell.org/ghc/ghc/issues/13491+ *  - https://phabricator.haskell.org/D3122+ *  - https://phabricator.haskell.org/D3405+ *+ * In those cases code change assumed target defines like SIZEOF_HSINT+ * are applied to host platform, not target platform.+ *+ * So what should be used instead in STAGE=1?+ *+ * To get host's equivalent of SIZEOF_HSINT you can use Bits instances:+ *    Data.Bits.finiteBitSize (0 :: Int)+ *+ * To get target's values it is preferred to use runtime target+ * configuration from 'targetPlatform :: DynFlags -> Platform'+ * record. A few wrappers are already defined and used throughout GHC:+ *    wORD_SIZE :: DynFlags -> Int+ *    wORD_SIZE dflags = pc_WORD_SIZE (sPlatformConstants (settings dflags))+ *+ * Hence we hide these macros from -DSTAGE=1+ */+#if !defined(STAGE) || STAGE >= 2++/* Sizes of C types come from here... */+#include "ghcautoconf.h"++/* Sizes of Haskell types follow.  These sizes correspond to:+ *   - the number of bytes in the primitive type (eg. Int#)+ *   - the number of bytes in the external representation (eg. HsInt)+ *   - the scale offset used by writeFooOffAddr#+ *+ * In the heap, the type may take up more space: eg. SIZEOF_INT8 == 1,+ * but it takes up SIZEOF_HSWORD (4 or 8) bytes in the heap.+ */++#define SIZEOF_HSCHAR           SIZEOF_WORD32+#define ALIGNMENT_HSCHAR        ALIGNMENT_WORD32++#define SIZEOF_HSINT            SIZEOF_VOID_P+#define ALIGNMENT_HSINT         ALIGNMENT_VOID_P++#define SIZEOF_HSWORD           SIZEOF_VOID_P+#define ALIGNMENT_HSWORD        ALIGNMENT_VOID_P++#define SIZEOF_HSDOUBLE         SIZEOF_DOUBLE+#define ALIGNMENT_HSDOUBLE      ALIGNMENT_DOUBLE++#define SIZEOF_HSFLOAT          SIZEOF_FLOAT+#define ALIGNMENT_HSFLOAT       ALIGNMENT_FLOAT++#define SIZEOF_HSPTR            SIZEOF_VOID_P+#define ALIGNMENT_HSPTR         ALIGNMENT_VOID_P++#define SIZEOF_HSFUNPTR         SIZEOF_VOID_P+#define ALIGNMENT_HSFUNPTR      ALIGNMENT_VOID_P++#define SIZEOF_HSSTABLEPTR      SIZEOF_VOID_P+#define ALIGNMENT_HSSTABLEPTR   ALIGNMENT_VOID_P++#define SIZEOF_INT8             SIZEOF_INT8_T+#define ALIGNMENT_INT8          ALIGNMENT_INT8_T++#define SIZEOF_WORD8            SIZEOF_UINT8_T+#define ALIGNMENT_WORD8         ALIGNMENT_UINT8_T++#define SIZEOF_INT16            SIZEOF_INT16_T+#define ALIGNMENT_INT16         ALIGNMENT_INT16_T++#define SIZEOF_WORD16           SIZEOF_UINT16_T+#define ALIGNMENT_WORD16        ALIGNMENT_UINT16_T++#define SIZEOF_INT32            SIZEOF_INT32_T+#define ALIGNMENT_INT32         ALIGNMENT_INT32_T++#define SIZEOF_WORD32           SIZEOF_UINT32_T+#define ALIGNMENT_WORD32        ALIGNMENT_UINT32_T++#define SIZEOF_INT64            SIZEOF_INT64_T+#define ALIGNMENT_INT64         ALIGNMENT_INT64_T++#define SIZEOF_WORD64           SIZEOF_UINT64_T+#define ALIGNMENT_WORD64        ALIGNMENT_UINT64_T++#if !defined(WORD_SIZE_IN_BITS)+#if SIZEOF_HSWORD == 4+#define WORD_SIZE_IN_BITS       32+#define WORD_SIZE_IN_BITS_FLOAT 32.0+#else+#define WORD_SIZE_IN_BITS       64+#define WORD_SIZE_IN_BITS_FLOAT 64.0+#endif+#endif++#if !defined(TAG_BITS)+#if SIZEOF_HSWORD == 4+#define TAG_BITS                2+#else+#define TAG_BITS                3+#endif+#endif++#define TAG_MASK ((1 << TAG_BITS) - 1)++#endif /* !defined(STAGE) || STAGE >= 2 */
+ includes/Rts.h view
@@ -0,0 +1,317 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * RTS external APIs.  This file declares everything that the GHC RTS+ * exposes externally.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++#if defined(__cplusplus)+extern "C" {+#endif++/* We include windows.h very early, as on Win64 the CONTEXT type has+   fields "R8", "R9" and "R10", which goes bad if we've already+   #define'd those names for our own purposes (in stg/Regs.h) */+#if defined(HAVE_WINDOWS_H)+#include <windows.h>+#endif++#if !defined(IN_STG_CODE)+#define IN_STG_CODE 0+#endif+#include "Stg.h"++#include "HsFFI.h"+#include "RtsAPI.h"++// Turn off inlining when debugging - it obfuscates things+#if defined(DEBUG)+# undef  STATIC_INLINE+# define STATIC_INLINE static+#endif++#include "rts/Types.h"+#include "rts/Time.h"++#if __GNUC__ >= 3+#define ATTRIBUTE_ALIGNED(n) __attribute__((aligned(n)))+#else+#define ATTRIBUTE_ALIGNED(n) /*nothing*/+#endif++// Symbols that are extern, but private to the RTS, are declared+// with visibility "hidden" to hide them outside the RTS shared+// library.+#if defined(HAS_VISIBILITY_HIDDEN)+#define RTS_PRIVATE  GNUC3_ATTRIBUTE(visibility("hidden"))+#else+#define RTS_PRIVATE  /* disabled: RTS_PRIVATE */+#endif++#if __GNUC__ >= 4+#define RTS_UNLIKELY(p) __builtin_expect((p),0)+#else+#define RTS_UNLIKELY(p) (p)+#endif++#if __GNUC__ >= 4+#define RTS_LIKELY(p) __builtin_expect(!!(p), 1)+#else+#define RTS_LIKELY(p) (p)+#endif++/* __builtin_unreachable is supported since GNU C 4.5 */+#if __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 5)+#define RTS_UNREACHABLE __builtin_unreachable()+#else+#define RTS_UNREACHABLE abort()+#endif++/* Fix for mingw stat problem (done here so it's early enough) */+#if defined(mingw32_HOST_OS)+#define __MSVCRT__ 1+#endif++/* Needed to get the macro version of errno on some OSs, and also to+   get prototypes for the _r versions of C library functions. */+#if !defined(_REENTRANT)+#define _REENTRANT 1+#endif++/*+ * We often want to know the size of something in units of an+ * StgWord... (rounded up, of course!)+ */+#define ROUNDUP_BYTES_TO_WDS(n) (((n) + sizeof(W_) - 1) / sizeof(W_))++#define sizeofW(t) ROUNDUP_BYTES_TO_WDS(sizeof(t))++/* -----------------------------------------------------------------------------+   Assertions and Debuggery++   CHECK(p)   evaluates p and terminates with an error if p is false+   ASSERT(p)  like CHECK(p) if DEBUG is on, otherwise a no-op+   -------------------------------------------------------------------------- */++void _assertFail(const char *filename, unsigned int linenum)+   GNUC3_ATTRIBUTE(__noreturn__);++#define CHECK(predicate)                        \+        if (predicate)                          \+            /*null*/;                           \+        else                                    \+            _assertFail(__FILE__, __LINE__)++#define CHECKM(predicate, msg, ...)             \+        if (predicate)                          \+            /*null*/;                           \+        else                                    \+            barf(msg, ##__VA_ARGS__)++#if !defined(DEBUG)+#define ASSERT(predicate) /* nothing */+#define ASSERTM(predicate,msg,...) /* nothing */+#else+#define ASSERT(predicate) CHECK(predicate)+#define ASSERTM(predicate,msg,...) CHECKM(predicate,msg,##__VA_ARGS__)+#endif /* DEBUG */++/*+ * Use this on the RHS of macros which expand to nothing+ * to make sure that the macro can be used in a context which+ * demands a non-empty statement.+ */++#define doNothing() do { } while (0)++#if defined(DEBUG)+#define USED_IF_DEBUG+#define USED_IF_NOT_DEBUG STG_UNUSED+#else+#define USED_IF_DEBUG STG_UNUSED+#define USED_IF_NOT_DEBUG+#endif++#if defined(THREADED_RTS)+#define USED_IF_THREADS+#define USED_IF_NOT_THREADS STG_UNUSED+#else+#define USED_IF_THREADS STG_UNUSED+#define USED_IF_NOT_THREADS+#endif++#define FMT_SizeT    "zu"+#define FMT_HexSizeT "zx"++/* -----------------------------------------------------------------------------+   Include everything STG-ish+   -------------------------------------------------------------------------- */++/* System headers: stdlib.h is needed so that we can use NULL.  It must+ * come after MachRegs.h, because stdlib.h might define some inline+ * functions which may only be defined after register variables have+ * been declared.+ */+#include <stdlib.h>++#include "rts/Config.h"++/* Global constraints */+#include "rts/Constants.h"++/* Profiling information */+#include "rts/prof/CCS.h"+#include "rts/prof/LDV.h"++/* Parallel information */+#include "rts/OSThreads.h"+#include "rts/SpinLock.h"++#include "rts/Messages.h"+#include "rts/Threads.h"++/* Storage format definitions */+#include "rts/storage/FunTypes.h"+#include "rts/storage/InfoTables.h"+#include "rts/storage/Closures.h"+#include "rts/storage/Heap.h"+#include "rts/storage/ClosureTypes.h"+#include "rts/storage/TSO.h"+#include "stg/MiscClosures.h" /* InfoTables, closures etc. defined in the RTS */+#include "rts/storage/Block.h"+#include "rts/storage/ClosureMacros.h"+#include "rts/storage/MBlock.h"+#include "rts/storage/GC.h"++/* Other RTS external APIs */+#include "rts/Parallel.h"+#include "rts/Signals.h"+#include "rts/BlockSignals.h"+#include "rts/Hpc.h"+#include "rts/Flags.h"+#include "rts/Adjustor.h"+#include "rts/FileLock.h"+#include "rts/GetTime.h"+#include "rts/Globals.h"+#include "rts/IOManager.h"+#include "rts/Linker.h"+#include "rts/Ticky.h"+#include "rts/Timer.h"+#include "rts/StablePtr.h"+#include "rts/StableName.h"+#include "rts/TTY.h"+#include "rts/Utils.h"+#include "rts/PrimFloat.h"+#include "rts/Main.h"+#include "rts/Profiling.h"+#include "rts/StaticPtrTable.h"+#include "rts/Libdw.h"+#include "rts/LibdwPool.h"++/* Misc stuff without a home */+DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell */+DLL_IMPORT_RTS extern int    prog_argc;+DLL_IMPORT_RTS extern char  *prog_name;++void reportStackOverflow(StgTSO* tso);+void reportHeapOverflow(void);++void stg_exit(int n) GNU_ATTRIBUTE(__noreturn__);++#if !defined(mingw32_HOST_OS)+int stg_sig_install (int, int, void *);+#endif++/* -----------------------------------------------------------------------------+   Ways+   -------------------------------------------------------------------------- */++// Returns non-zero if the RTS is a profiling version+int rts_isProfiled(void);++// Returns non-zero if the RTS is a dynamically-linked version+int rts_isDynamic(void);++/* -----------------------------------------------------------------------------+   RTS Exit codes+   -------------------------------------------------------------------------- */++/* 255 is allegedly used by dynamic linkers to report linking failure */+#define EXIT_INTERNAL_ERROR 254+#define EXIT_DEADLOCK       253+#define EXIT_INTERRUPTED    252+#define EXIT_HEAPOVERFLOW   251+#define EXIT_KILLED         250++/* -----------------------------------------------------------------------------+   Miscellaneous garbage+   -------------------------------------------------------------------------- */++#if defined(DEBUG)+#define TICK_VAR(arity) \+  extern StgInt SLOW_CALLS_##arity; \+  extern StgInt RIGHT_ARITY_##arity; \+  extern StgInt TAGGED_PTR_##arity;++extern StgInt TOTAL_CALLS;++TICK_VAR(1)+TICK_VAR(2)+#endif++/* -----------------------------------------------------------------------------+   Assertions and Debuggery+   -------------------------------------------------------------------------- */++#define IF_RTSFLAGS(c,s)  if (RtsFlags.c) { s; } doNothing()++#if defined(DEBUG)+#if IN_STG_CODE+#define IF_DEBUG(c,s)  if (RtsFlags[0].DebugFlags.c) { s; } doNothing()+#else+#define IF_DEBUG(c,s)  if (RtsFlags.DebugFlags.c) { s; } doNothing()+#endif+#else+#define IF_DEBUG(c,s)  doNothing()+#endif++#if defined(DEBUG)+#define DEBUG_ONLY(s) s+#else+#define DEBUG_ONLY(s) doNothing()+#endif++#if defined(DEBUG)+#define DEBUG_IS_ON   1+#else+#define DEBUG_IS_ON   0+#endif++/* -----------------------------------------------------------------------------+   Useful macros and inline functions+   -------------------------------------------------------------------------- */++#if defined(__GNUC__)+#define SUPPORTS_TYPEOF+#endif++#if defined(SUPPORTS_TYPEOF)+#define stg_min(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _a : _b; })+#define stg_max(a,b) ({typeof(a) _a = (a), _b = (b); _a <= _b ? _b : _a; })+#else+#define stg_min(a,b) ((a) <= (b) ? (a) : (b))+#define stg_max(a,b) ((a) <= (b) ? (b) : (a))+#endif++/* -------------------------------------------------------------------------- */++#if defined(__cplusplus)+}+#endif
+ includes/RtsAPI.h view
@@ -0,0 +1,487 @@+/* ----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2004+ *+ * API for invoking Haskell functions via the RTS+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * --------------------------------------------------------------------------*/++#pragma once++#if defined(__cplusplus)+extern "C" {+#endif++#include "HsFFI.h"+#include "rts/Time.h"+#include "rts/EventLogWriter.h"++/*+ * Running the scheduler+ */+typedef enum {+    NoStatus,    /* not finished yet */+    Success,     /* completed successfully */+    Killed,      /* uncaught exception */+    Interrupted, /* stopped in response to a call to interruptStgRts */+    HeapExhausted /* out of memory */+} SchedulerStatus;++typedef struct StgClosure_ *HaskellObj;++/*+ * An abstract type representing the token returned by rts_lock() and+ * used when allocating objects and threads in the RTS.+ */+typedef struct Capability_ Capability;++/*+ * The public view of a Capability: we can be sure it starts with+ * these two components (but it may have more private fields).+ */+typedef struct CapabilityPublic_ {+    StgFunTable f;+    StgRegTable r;+} CapabilityPublic;++/* ----------------------------------------------------------------------------+   RTS configuration settings, for passing to hs_init_ghc()+   ------------------------------------------------------------------------- */++typedef enum {+    RtsOptsNone,         // +RTS causes an error+    RtsOptsIgnore,       // Ignore command line arguments+    RtsOptsIgnoreAll,    // Ignore command line and Environment arguments+    RtsOptsSafeOnly,     // safe RTS options allowed; others cause an error+    RtsOptsAll           // all RTS options allowed+  } RtsOptsEnabledEnum;++struct GCDetails_;++// The RtsConfig struct is passed (by value) to hs_init_ghc().  The+// reason for using a struct is extensibility: we can add more+// fields to this later without breaking existing client code.+typedef struct {++    // Whether to interpret +RTS options on the command line+    RtsOptsEnabledEnum rts_opts_enabled;++    // Whether to give RTS flag suggestions+    HsBool rts_opts_suggestions;++    // additional RTS options+    const char *rts_opts;++    // True if GHC was not passed -no-hs-main+    HsBool rts_hs_main;++    // Whether to retain CAFs (default: false)+    HsBool keep_cafs;++    // Writer a for eventlog.+    const EventLogWriter *eventlog_writer;++    // Called before processing command-line flags, so that default+    // settings for RtsFlags can be provided.+    void (* defaultsHook) (void);++    // Called just before exiting+    void (* onExitHook) (void);++    // Called on a stack overflow, before exiting+    void (* stackOverflowHook) (W_ stack_size);++    // Called on heap overflow, before exiting+    void (* outOfHeapHook) (W_ request_size, W_ heap_size);++    // Called when malloc() fails, before exiting+    void (* mallocFailHook) (W_ request_size /* in bytes */, const char *msg);++    // Called for every GC+    void (* gcDoneHook) (const struct GCDetails_ *stats);++    // Called when GC sync takes too long (+RTS --long-gc-sync=<time>)+    void (* longGCSync) (uint32_t this_cap, Time time_ns);+    void (* longGCSyncEnd) (Time time_ns);+} RtsConfig;++// Clients should start with defaultRtsConfig and then customise it.+// Bah, I really wanted this to be a const struct value, but it seems+// you can't do that in C (it generates code).+extern const RtsConfig defaultRtsConfig;++/* -----------------------------------------------------------------------------+   Statistics+   -------------------------------------------------------------------------- */++//+// Stats about a single GC+//+typedef struct GCDetails_ {+    // The generation number of this GC+  uint32_t gen;+    // Number of threads used in this GC+  uint32_t threads;+    // Number of bytes allocated since the previous GC+  uint64_t allocated_bytes;+    // Total amount of live data in the heap (incliudes large + compact data).+    // Updated after every GC. Data in uncollected generations (in minor GCs)+    // are considered live.+  uint64_t live_bytes;+    // Total amount of live data in large objects+  uint64_t large_objects_bytes;+    // Total amount of live data in compact regions+  uint64_t compact_bytes;+    // Total amount of slop (wasted memory)+  uint64_t slop_bytes;+    // Total amount of memory in use by the RTS+  uint64_t mem_in_use_bytes;+    // Total amount of data copied during this GC+  uint64_t copied_bytes;+    // In parallel GC, the max amount of data copied by any one thread+  uint64_t par_max_copied_bytes;+  // In parallel GC, the amount of balanced data copied by all threads+  uint64_t par_balanced_copied_bytes;+    // The time elapsed during synchronisation before GC+  Time sync_elapsed_ns;+    // The CPU time used during GC itself+  Time cpu_ns;+    // The time elapsed during GC itself+  Time elapsed_ns;+} GCDetails;++//+// Stats about the RTS currently, and since the start of execution+//+typedef struct _RTSStats {++  // -----------------------------------+  // Cumulative stats about memory use++    // Total number of GCs+  uint32_t gcs;+    // Total number of major (oldest generation) GCs+  uint32_t major_gcs;+    // Total bytes allocated+  uint64_t allocated_bytes;+    // Maximum live data (including large objects + compact regions) in the+    // heap. Updated after a major GC.+  uint64_t max_live_bytes;+    // Maximum live data in large objects+  uint64_t max_large_objects_bytes;+    // Maximum live data in compact regions+  uint64_t max_compact_bytes;+    // Maximum slop+  uint64_t max_slop_bytes;+    // Maximum memory in use by the RTS+  uint64_t max_mem_in_use_bytes;+    // Sum of live bytes across all major GCs.  Divided by major_gcs+    // gives the average live data over the lifetime of the program.+  uint64_t cumulative_live_bytes;+    // Sum of copied_bytes across all GCs+  uint64_t copied_bytes;+    // Sum of copied_bytes across all parallel GCs+  uint64_t par_copied_bytes;+    // Sum of par_max_copied_bytes across all parallel GCs+  uint64_t cumulative_par_max_copied_bytes;+    // Sum of par_balanced_copied_byes across all parallel GCs.+  uint64_t cumulative_par_balanced_copied_bytes;++  // -----------------------------------+  // Cumulative stats about time use+  // (we use signed values here because due to inaccuracies in timers+  // the values can occasionally go slightly negative)++    // Total CPU time used by the init phase+  Time init_cpu_ns;+    // Total elapsed time used by the init phase+  Time init_elapsed_ns;+    // Total CPU time used by the mutator+  Time mutator_cpu_ns;+    // Total elapsed time used by the mutator+  Time mutator_elapsed_ns;+    // Total CPU time used by the GC+  Time gc_cpu_ns;+    // Total elapsed time used by the GC+  Time gc_elapsed_ns;+    // Total CPU time (at the previous GC)+  Time cpu_ns;+    // Total elapsed time (at the previous GC)+  Time elapsed_ns;++  // -----------------------------------+  // Stats about the most recent GC++  GCDetails gc;++  // -----------------------------------+  // Internal Counters++    // The number of times a GC thread spun on its 'gc_spin' lock.+    // Will be zero if the rts was not built with PROF_SPIN+  uint64_t gc_spin_spin;+    // The number of times a GC thread yielded on its 'gc_spin' lock.+    // Will be zero if the rts was not built with PROF_SPIN+  uint64_t gc_spin_yield;+    // The number of times a GC thread spun on its 'mut_spin' lock.+    // Will be zero if the rts was not built with PROF_SPIN+  uint64_t mut_spin_spin;+    // The number of times a GC thread yielded on its 'mut_spin' lock.+    // Will be zero if the rts was not built with PROF_SPIN+  uint64_t mut_spin_yield;+    // The number of times a GC thread has checked for work across all parallel+    // GCs+  uint64_t any_work;+    // The number of times a GC thread has checked for work and found none+    // across all parallel GCs+  uint64_t no_work;+    // The number of times a GC thread has iterated it's outer loop across all+    // parallel GCs+  uint64_t scav_find_work;+} RTSStats;++void getRTSStats (RTSStats *s);+int getRTSStatsEnabled (void);++// Returns the total number of bytes allocated since the start of the program.+// TODO: can we remove this?+uint64_t getAllocations (void);++/* ----------------------------------------------------------------------------+   Starting up and shutting down the Haskell RTS.+   ------------------------------------------------------------------------- */++/* DEPRECATED, use hs_init() or hs_init_ghc() instead  */+extern void startupHaskell         ( int argc, char *argv[],+                                     void (*init_root)(void) );++/* DEPRECATED, use hs_exit() instead  */+extern void shutdownHaskell        ( void );++/* Like hs_init(), but allows rtsopts. For more complicated usage,+ * use hs_init_ghc. */+extern void hs_init_with_rtsopts (int *argc, char **argv[]);++/*+ * GHC-specific version of hs_init() that allows specifying whether+ * +RTS ... -RTS options are allowed or not (default: only "safe"+ * options are allowed), and allows passing an option string that is+ * to be interpreted by the RTS only, not passed to the program.+ */+extern void hs_init_ghc (int *argc, char **argv[],   // program arguments+                         RtsConfig rts_config);      // RTS configuration++extern void shutdownHaskellAndExit (int exitCode, int fastExit)+    GNUC3_ATTRIBUTE(__noreturn__);++#if !defined(mingw32_HOST_OS)+extern void shutdownHaskellAndSignal (int sig, int fastExit)+     GNUC3_ATTRIBUTE(__noreturn__);+#endif++extern void getProgArgv            ( int *argc, char **argv[] );+extern void setProgArgv            ( int argc, char *argv[] );+extern void getFullProgArgv        ( int *argc, char **argv[] );+extern void setFullProgArgv        ( int argc, char *argv[] );+extern void freeFullProgArgv       ( void ) ;++/* exit() override */+extern void (*exitFn)(int);++/* ----------------------------------------------------------------------------+   Locking.++   You have to surround all access to the RtsAPI with these calls.+   ------------------------------------------------------------------------- */++// acquires a token which may be used to create new objects and+// evaluate them.+Capability *rts_lock (void);++// releases the token acquired with rts_lock().+void rts_unlock (Capability *token);++// If you are in a context where you know you have a current capability but+// do not know what it is, then use this to get it. Basically this only+// applies to "unsafe" foreign calls (as unsafe foreign calls are made with+// the capability held).+//+// WARNING: There is *no* guarantee this returns anything sensible (eg NULL)+// when there is no current capability.+Capability *rts_unsafeGetMyCapability (void);++/* ----------------------------------------------------------------------------+   Which cpu should the OS thread and Haskell thread run on?++   1. Run the current thread on the given capability:+     rts_setInCallCapability(cap, 0);++   2. Run the current thread on the given capability and set the cpu affinity+      for this thread:+     rts_setInCallCapability(cap, 1);++   3. Run the current thread on the given numa node:+     rts_pinThreadToNumaNode(node);++   4. Run the current thread on the given capability and on the given numa node:+     rts_setInCallCapability(cap, 0);+     rts_pinThreadToNumaNode(cap);+   ------------------------------------------------------------------------- */++// Specify the Capability that the current OS thread should run on when it calls+// into Haskell.  The actual capability will be calculated as the supplied+// value modulo the number of enabled Capabilities.+//+// Note that the thread may still be migrated by the RTS scheduler, but that+// will only happen if there are multiple threads running on one Capability and+// another Capability is free.+//+// If affinity is non-zero, the current thread will be bound to+// specific CPUs according to the prevailing affinity policy for the+// specified capability, set by either +RTS -qa or +RTS --numa.+void rts_setInCallCapability (int preferred_capability, int affinity);++// Specify the CPU Node that the current OS thread should run on when it calls+// into Haskell. The argument can be either a node number or capability number.+// The actual node will be calculated as the supplied value modulo the number+// of numa nodes.+void rts_pinThreadToNumaNode (int node);++/* ----------------------------------------------------------------------------+   Building Haskell objects from C datatypes.+   ------------------------------------------------------------------------- */+HaskellObj   rts_mkChar       ( Capability *, HsChar   c );+HaskellObj   rts_mkInt        ( Capability *, HsInt    i );+HaskellObj   rts_mkInt8       ( Capability *, HsInt8   i );+HaskellObj   rts_mkInt16      ( Capability *, HsInt16  i );+HaskellObj   rts_mkInt32      ( Capability *, HsInt32  i );+HaskellObj   rts_mkInt64      ( Capability *, HsInt64  i );+HaskellObj   rts_mkWord       ( Capability *, HsWord   w );+HaskellObj   rts_mkWord8      ( Capability *, HsWord8  w );+HaskellObj   rts_mkWord16     ( Capability *, HsWord16 w );+HaskellObj   rts_mkWord32     ( Capability *, HsWord32 w );+HaskellObj   rts_mkWord64     ( Capability *, HsWord64 w );+HaskellObj   rts_mkPtr        ( Capability *, HsPtr    a );+HaskellObj   rts_mkFunPtr     ( Capability *, HsFunPtr a );+HaskellObj   rts_mkFloat      ( Capability *, HsFloat  f );+HaskellObj   rts_mkDouble     ( Capability *, HsDouble f );+HaskellObj   rts_mkStablePtr  ( Capability *, HsStablePtr s );+HaskellObj   rts_mkBool       ( Capability *, HsBool   b );+HaskellObj   rts_mkString     ( Capability *, char    *s );++HaskellObj   rts_apply        ( Capability *, HaskellObj, HaskellObj );++/* ----------------------------------------------------------------------------+   Deconstructing Haskell objects+   ------------------------------------------------------------------------- */+HsChar       rts_getChar      ( HaskellObj );+HsInt        rts_getInt       ( HaskellObj );+HsInt8       rts_getInt8      ( HaskellObj );+HsInt16      rts_getInt16     ( HaskellObj );+HsInt32      rts_getInt32     ( HaskellObj );+HsInt64      rts_getInt64     ( HaskellObj );+HsWord       rts_getWord      ( HaskellObj );+HsWord8      rts_getWord8     ( HaskellObj );+HsWord16     rts_getWord16    ( HaskellObj );+HsWord32     rts_getWord32    ( HaskellObj );+HsWord64     rts_getWord64    ( HaskellObj );+HsPtr        rts_getPtr       ( HaskellObj );+HsFunPtr     rts_getFunPtr    ( HaskellObj );+HsFloat      rts_getFloat     ( HaskellObj );+HsDouble     rts_getDouble    ( HaskellObj );+HsStablePtr  rts_getStablePtr ( HaskellObj );+HsBool       rts_getBool      ( HaskellObj );++/* ----------------------------------------------------------------------------+   Evaluating Haskell expressions++   The versions ending in '_' allow you to specify an initial stack size.+   Note that these calls may cause Garbage Collection, so all HaskellObj+   references are rendered invalid by these calls.++   All of these functions take a (Capability **) - there is a+   Capability pointer both input and output.  We use an inout+   parameter because this is less error-prone for the client than a+   return value - the client could easily forget to use the return+   value, whereas incorrectly using an inout parameter will usually+   result in a type error.+   ------------------------------------------------------------------------- */++void rts_eval (/* inout */ Capability **,+               /* in    */ HaskellObj p,+               /* out */   HaskellObj *ret);++void rts_eval_ (/* inout */ Capability **,+                /* in    */ HaskellObj p,+                /* in    */ unsigned int stack_size,+                /* out   */ HaskellObj *ret);++void rts_evalIO (/* inout */ Capability **,+                 /* in    */ HaskellObj p,+                 /* out */   HaskellObj *ret);++void rts_evalStableIOMain (/* inout */ Capability **,+                           /* in    */ HsStablePtr s,+                           /* out */   HsStablePtr *ret);++void rts_evalStableIO (/* inout */ Capability **,+                       /* in    */ HsStablePtr s,+                       /* out */   HsStablePtr *ret);++void rts_evalLazyIO (/* inout */ Capability **,+                     /* in    */ HaskellObj p,+                     /* out */   HaskellObj *ret);++void rts_evalLazyIO_ (/* inout */ Capability **,+                      /* in    */ HaskellObj p,+                      /* in    */ unsigned int stack_size,+                      /* out   */ HaskellObj *ret);++void rts_checkSchedStatus (char* site, Capability *);++SchedulerStatus rts_getSchedStatus (Capability *cap);++/*+ * The RTS allocates some thread-local data when you make a call into+ * Haskell using one of the rts_eval() functions.  This data is not+ * normally freed until hs_exit().  If you want to free it earlier+ * than this, perhaps because the thread is about to exit, then call+ * rts_done() from the thread.+ *+ * It is safe to make more rts_eval() calls after calling rts_done(),+ * but the next one will cause allocation of the thread-local memory+ * again.+ */+void rts_done (void);++/* --------------------------------------------------------------------------+   Wrapper closures++   These are used by foreign export and foreign import "wrapper" stubs.+   ----------------------------------------------------------------------- */++// When producing Windows DLLs the we need to know which symbols are in the+//      local package/DLL vs external ones.+//+//      Note that RtsAPI.h is also included by foreign export stubs in+//      the base package itself.+//+#if defined(COMPILING_WINDOWS_DLL) && !defined(COMPILING_BASE_PACKAGE)+__declspec(dllimport) extern StgWord base_GHCziTopHandler_runIO_closure[];+__declspec(dllimport) extern StgWord base_GHCziTopHandler_runNonIO_closure[];+#else+extern StgWord base_GHCziTopHandler_runIO_closure[];+extern StgWord base_GHCziTopHandler_runNonIO_closure[];+#endif++#define runIO_closure     base_GHCziTopHandler_runIO_closure+#define runNonIO_closure  base_GHCziTopHandler_runNonIO_closure++/* ------------------------------------------------------------------------ */++#if defined(__cplusplus)+}+#endif
+ includes/Stg.h view
@@ -0,0 +1,599 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * Top-level include file for everything required when compiling .hc+ * code.  NOTE: in .hc files, Stg.h must be included *before* any+ * other headers, because we define some register variables which must+ * be done before any inline functions are defined (some system+ * headers have been known to define the odd inline function).+ *+ * We generally try to keep as little visible as possible when+ * compiling .hc files.  So for example the definitions of the+ * InfoTable structs, closure structs and other RTS types are not+ * visible here.  The compiler knows enough about the representations+ * of these types to generate code which manipulates them directly+ * with pointer arithmetic.+ *+ * In ordinary C code, do not #include this file directly: #include+ * "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++#if !(__STDC_VERSION__ >= 199901L) && !(__cplusplus >= 201103L)+# error __STDC_VERSION__ does not advertise C99, C++11 or later+#endif++/*+ * If we are compiling a .hc file, then we want all the register+ * variables.  This is the what happens if you #include "Stg.h" first:+ * we assume this is a .hc file, and set IN_STG_CODE==1, which later+ * causes the register variables to be enabled in stg/Regs.h.+ *+ * If instead "Rts.h" is included first, then we are compiling a+ * vanilla C file.  Everything from Stg.h is provided, except that+ * IN_STG_CODE is not defined, and the register variables will not be+ * active.+ */+#if !defined(IN_STG_CODE)+# define IN_STG_CODE 1++// Turn on C99 for .hc code.  This gives us the INFINITY and NAN+// constants from math.h, which we occasionally need to use in .hc (#1861)+# define _ISOC99_SOURCE++// We need _BSD_SOURCE so that math.h defines things like gamma+// on Linux+# define _BSD_SOURCE++// On AIX we need _BSD defined, otherwise <math.h> includes <stdlib.h>+# if defined(_AIX)+#  define _BSD 1+# endif++// '_BSD_SOURCE' is deprecated since glibc-2.20+// in favour of '_DEFAULT_SOURCE'+# define _DEFAULT_SOURCE+#endif++#if IN_STG_CODE == 0 || defined(llvm_CC_FLAVOR)+// C compilers that use an LLVM back end (clang or llvm-gcc) do not+// correctly support global register variables so we make sure that+// we do not declare them for these compilers.+# define NO_GLOBAL_REG_DECLS    /* don't define fixed registers */+#endif++/* Configuration */+#include "ghcconfig.h"++/* The code generator calls the math functions directly in .hc code.+   NB. after configuration stuff above, because this sets #defines+   that depend on config info, such as __USE_FILE_OFFSET64 */+#include <math.h>++// On Solaris, we don't get the INFINITY and NAN constants unless we+// #define _STDC_C99, and we can't do that unless we also use -std=c99,+// because _STDC_C99 causes the headers to use C99 syntax (e.g. restrict).+// We aren't ready for -std=c99 yet, so define INFINITY/NAN by hand using+// the gcc builtins.+#if !defined(INFINITY)+#if defined(__GNUC__)+#define INFINITY __builtin_inf()+#else+#error No definition for INFINITY+#endif+#endif++#if !defined(NAN)+#if defined(__GNUC__)+#define NAN __builtin_nan("")+#else+#error No definition for NAN+#endif+#endif++/* -----------------------------------------------------------------------------+   Useful definitions+   -------------------------------------------------------------------------- */++/*+ * The C backend likes to refer to labels by just mentioning their+ * names.  However, when a symbol is declared as a variable in C, the+ * C compiler will implicitly dereference it when it occurs in source.+ * So we must subvert this behaviour for .hc files by declaring+ * variables as arrays, which eliminates the implicit dereference.+ */+#if IN_STG_CODE+#define RTS_VAR(x) (x)[]+#define RTS_DEREF(x) (*(x))+#else+#define RTS_VAR(x) x+#define RTS_DEREF(x) x+#endif++/* bit macros+ */+#define BITS_PER_BYTE 8+#define BITS_IN(x) (BITS_PER_BYTE * sizeof(x))++/* Compute offsets of struct fields+ */+#define STG_FIELD_OFFSET(s_type, field) ((StgWord)&(((s_type*)0)->field))++/*+ * 'Portable' inlining:+ * INLINE_HEADER is for inline functions in header files (macros)+ * STATIC_INLINE is for inline functions in source files+ * EXTERN_INLINE is for functions that we want to inline sometimes+ * (we also compile a static version of the function; see Inlines.c)+ */++// We generally assume C99 semantics albeit these two definitions work fine even+// when gnu90 semantics are active (i.e. when __GNUC_GNU_INLINE__ is defined or+// when a GCC older than 4.2 is used)+//+// The problem, however, is with 'extern inline' whose semantics significantly+// differs between gnu90 and C99+#define INLINE_HEADER static inline+#define STATIC_INLINE static inline++// Figure out whether `__attributes__((gnu_inline))` is needed+// to force gnu90-style 'external inline' semantics.+#if defined(FORCE_GNU_INLINE)+// disable auto-detection since HAVE_GNU_INLINE has been defined externally+#elif defined(__GNUC_GNU_INLINE__) && __GNUC__ == 4 && __GNUC_MINOR__ == 2+// GCC 4.2.x didn't properly support C99 inline semantics (GCC 4.3 was the first+// release to properly support C99 inline semantics), and therefore warned when+// using 'extern inline' while in C99 mode unless `__attributes__((gnu_inline))`+// was explicitly set.+# define FORCE_GNU_INLINE 1+#endif++#if defined(FORCE_GNU_INLINE)+// Force compiler into gnu90 semantics+# if defined(KEEP_INLINES)+#  define EXTERN_INLINE inline __attribute__((gnu_inline))+# else+#  define EXTERN_INLINE extern inline __attribute__((gnu_inline))+# endif+#elif defined(__GNUC_GNU_INLINE__)+// we're currently in gnu90 inline mode by default and+// __attribute__((gnu_inline)) may not be supported, so better leave it off+# if defined(KEEP_INLINES)+#  define EXTERN_INLINE inline+# else+#  define EXTERN_INLINE extern inline+# endif+#else+// Assume C99 semantics (yes, this curiously results in swapped definitions!)+// This is the preferred branch, and at some point we may drop support for+// compilers not supporting C99 semantics altogether.+# if defined(KEEP_INLINES)+#  define EXTERN_INLINE extern inline+# else+#  define EXTERN_INLINE inline+# endif+#endif+++/*+ * GCC attributes+ */+#if defined(__GNUC__)+#define GNU_ATTRIBUTE(at) __attribute__((at))+#else+#define GNU_ATTRIBUTE(at)+#endif++#if __GNUC__ >= 3+#define GNUC3_ATTRIBUTE(at) __attribute__((at))+#else+#define GNUC3_ATTRIBUTE(at)+#endif++/* Used to mark a switch case that falls-through */+#if (defined(__GNUC__) && __GNUC__ >= 7)+// N.B. Don't enable fallthrough annotations when compiling with Clang.+// Apparently clang doesn't enable implicitly fallthrough warnings by default+// http://llvm.org/viewvc/llvm-project?revision=167655&view=revision+// when compiling C and the attribute cause warnings of their own (#16019).+#define FALLTHROUGH GNU_ATTRIBUTE(fallthrough)+#else+#define FALLTHROUGH ((void)0)+#endif /* __GNUC__ >= 7 */++#if !defined(DEBUG) && (__GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3))+#define GNUC_ATTR_HOT __attribute__((hot))+#else+#define GNUC_ATTR_HOT /* nothing */+#endif++#define STG_UNUSED    GNUC3_ATTRIBUTE(__unused__)++/* Prevent functions from being optimized.+   See Note [Windows Stack allocations] */+#if defined(__clang__)+#define STG_NO_OPTIMIZE __attribute__((optnone))+#elif defined(__GNUC__) || defined(__GNUG__)+#define STG_NO_OPTIMIZE __attribute__((optimize("O0")))+#else+#define STG_NO_OPTIMIZE /* nothing */+#endif++/* -----------------------------------------------------------------------------+   Global type definitions+   -------------------------------------------------------------------------- */++#include "MachDeps.h"+#include "stg/Types.h"++/* -----------------------------------------------------------------------------+   Shorthand forms+   -------------------------------------------------------------------------- */++typedef StgChar      C_;+typedef StgWord      W_;+typedef StgWord*  P_;+typedef StgInt    I_;+typedef StgWord StgWordArray[];+typedef StgFunPtr       F_;++/* byte arrays (and strings): */+#define EB_(X)    extern const char X[]+#define IB_(X)    static const char X[]+/* static (non-heap) closures (requires alignment for pointer tagging): */+#define EC_(X)    extern       StgWordArray (X) GNU_ATTRIBUTE(aligned (8))+#define IC_(X)    static       StgWordArray (X) GNU_ATTRIBUTE(aligned (8))+/* writable data (does not require alignment): */+#define ERW_(X)   extern       StgWordArray (X)+#define IRW_(X)   static       StgWordArray (X)+/* read-only data (does not require alignment): */+#define ERO_(X)   extern const StgWordArray (X)+#define IRO_(X)   static const StgWordArray (X)+/* stg-native functions: */+#define IF_(f)    static StgFunPtr GNUC3_ATTRIBUTE(used) f(void)+#define FN_(f)           StgFunPtr f(void)+#define EF_(f)           StgFunPtr f(void) /* External Cmm functions */+/* foreign functions: */+#define EFF_(f)   void f() /* See Note [External function prototypes] */++/* Note [External function prototypes]  See #8965, #11395+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In generated C code we need to distinct between two types+of external symbols:+1.  Cmm functions declared by 'EF_' macro (External Functions)+2.    C functions declared by 'EFF_' macro (External Foreign Functions)++Cmm functions are simple as they are internal to GHC.++C functions are trickier:++The external-function macro EFF_(F) used to be defined as+    extern StgFunPtr f(void)+i.e a function of zero arguments.  On most platforms this doesn't+matter very much: calls to these functions put the parameters in the+usual places anyway, and (with the exception of varargs) things just+work.++However, the ELFv2 ABI on ppc64 optimises stack allocation+(http://gcc.gnu.org/ml/gcc-patches/2013-11/msg01149.html): a call to a+function that has a prototype, is not varargs, and receives all parameters+in registers rather than on the stack does not require the caller to+allocate an argument save area.  The incorrect prototypes cause GCC to+believe that all functions declared this way can be called without an+argument save area, but if the callee has sufficiently many arguments then+it will expect that area to be present, and will thus corrupt the caller's+stack.  This happens in particular with calls to runInteractiveProcess in+libraries/process/cbits/runProcess.c, and led to #8965.++The simplest fix appears to be to declare these external functions with an+unspecified argument list rather than a void argument list.  This is no+worse for platforms that don't care either way, and allows a successful+bootstrap of GHC 7.8 on little-endian Linux ppc64 (which uses the ELFv2+ABI).++Another case is m68k ABI where 'void*' return type is returned by 'a0'+register while 'long' return type is returned by 'd0'. Thus we trick+external prototype return neither of these types to workaround #11395.+*/+++/* -----------------------------------------------------------------------------+   Tail calls+   -------------------------------------------------------------------------- */++#define JMP_(cont) return((StgFunPtr)(cont))++/* -----------------------------------------------------------------------------+   Other Stg stuff...+   -------------------------------------------------------------------------- */++#include "stg/DLL.h"+#include "stg/RtsMachRegs.h"+#include "stg/Regs.h"+#include "stg/Ticky.h"++#if IN_STG_CODE+/*+ * This is included later for RTS sources, after definitions of+ * StgInfoTable, StgClosure and so on.+ */+#include "stg/MiscClosures.h"+#endif++#include "stg/Prim.h" /* ghc-prim fallbacks */+#include "stg/SMP.h" // write_barrier() inline is required++/* -----------------------------------------------------------------------------+   Moving Floats and Doubles++   ASSIGN_FLT is for assigning a float to memory (usually the+              stack/heap).  The memory address is guaranteed to be+         StgWord aligned (currently == sizeof(void *)).++   PK_FLT     is for pulling a float out of memory.  The memory is+              guaranteed to be StgWord aligned.+   -------------------------------------------------------------------------- */++INLINE_HEADER void     ASSIGN_FLT (W_ [], StgFloat);+INLINE_HEADER StgFloat    PK_FLT     (W_ []);++#if ALIGNMENT_FLOAT <= ALIGNMENT_VOID_P++INLINE_HEADER void     ASSIGN_FLT(W_ p_dest[], StgFloat src) { *(StgFloat *)p_dest = src; }+INLINE_HEADER StgFloat PK_FLT    (W_ p_src[])                { return *(StgFloat *)p_src; }++#else  /* ALIGNMENT_FLOAT > ALIGNMENT_UNSIGNED_INT */++INLINE_HEADER void ASSIGN_FLT(W_ p_dest[], StgFloat src)+{+    float_thing y;+    y.f = src;+    *p_dest = y.fu;+}++INLINE_HEADER StgFloat PK_FLT(W_ p_src[])+{+    float_thing y;+    y.fu = *p_src;+    return(y.f);+}++#endif /* ALIGNMENT_FLOAT > ALIGNMENT_VOID_P */++#if ALIGNMENT_DOUBLE <= ALIGNMENT_VOID_P++INLINE_HEADER void     ASSIGN_DBL (W_ [], StgDouble);+INLINE_HEADER StgDouble   PK_DBL     (W_ []);++INLINE_HEADER void      ASSIGN_DBL(W_ p_dest[], StgDouble src) { *(StgDouble *)p_dest = src; }+INLINE_HEADER StgDouble PK_DBL    (W_ p_src[])                 { return *(StgDouble *)p_src; }++#else /* ALIGNMENT_DOUBLE > ALIGNMENT_VOID_P */++/* Sparc uses two floating point registers to hold a double.  We can+ * write ASSIGN_DBL and PK_DBL by directly accessing the registers+ * independently - unfortunately this code isn't writable in C, we+ * have to use inline assembler.+ */+#if defined(sparc_HOST_ARCH)++#define ASSIGN_DBL(dst0,src) \+    { StgPtr dst = (StgPtr)(dst0); \+      __asm__("st %2,%0\n\tst %R2,%1" : "=m" (((P_)(dst))[0]), \+   "=m" (((P_)(dst))[1]) : "f" (src)); \+    }++#define PK_DBL(src0) \+    ( { StgPtr src = (StgPtr)(src0); \+        register double d; \+      __asm__("ld %1,%0\n\tld %2,%R0" : "=f" (d) : \+   "m" (((P_)(src))[0]), "m" (((P_)(src))[1])); d; \+    } )++#else /* ! sparc_HOST_ARCH */++INLINE_HEADER void     ASSIGN_DBL (W_ [], StgDouble);+INLINE_HEADER StgDouble   PK_DBL     (W_ []);++typedef struct+  { StgWord dhi;+    StgWord dlo;+  } unpacked_double;++typedef union+  { StgDouble d;+    unpacked_double du;+  } double_thing;++INLINE_HEADER void ASSIGN_DBL(W_ p_dest[], StgDouble src)+{+    double_thing y;+    y.d = src;+    p_dest[0] = y.du.dhi;+    p_dest[1] = y.du.dlo;+}++/* GCC also works with this version, but it generates+   the same code as the previous one, and is not ANSI++#define ASSIGN_DBL( p_dest, src ) \+   *p_dest = ((double_thing) src).du.dhi; \+   *(p_dest+1) = ((double_thing) src).du.dlo \+*/++INLINE_HEADER StgDouble PK_DBL(W_ p_src[])+{+    double_thing y;+    y.du.dhi = p_src[0];+    y.du.dlo = p_src[1];+    return(y.d);+}++#endif /* ! sparc_HOST_ARCH */++#endif /* ALIGNMENT_DOUBLE > ALIGNMENT_UNSIGNED_INT */+++/* -----------------------------------------------------------------------------+   Moving 64-bit quantities around++   ASSIGN_Word64      assign an StgWord64/StgInt64 to a memory location+   PK_Word64          load an StgWord64/StgInt64 from a amemory location++   In both cases the memory location might not be 64-bit aligned.+   -------------------------------------------------------------------------- */++#if SIZEOF_HSWORD == 4++typedef struct+  { StgWord dhi;+    StgWord dlo;+  } unpacked_double_word;++typedef union+  { StgInt64 i;+    unpacked_double_word iu;+  } int64_thing;++typedef union+  { StgWord64 w;+    unpacked_double_word wu;+  } word64_thing;++INLINE_HEADER void ASSIGN_Word64(W_ p_dest[], StgWord64 src)+{+    word64_thing y;+    y.w = src;+    p_dest[0] = y.wu.dhi;+    p_dest[1] = y.wu.dlo;+}++INLINE_HEADER StgWord64 PK_Word64(W_ p_src[])+{+    word64_thing y;+    y.wu.dhi = p_src[0];+    y.wu.dlo = p_src[1];+    return(y.w);+}++INLINE_HEADER void ASSIGN_Int64(W_ p_dest[], StgInt64 src)+{+    int64_thing y;+    y.i = src;+    p_dest[0] = y.iu.dhi;+    p_dest[1] = y.iu.dlo;+}++INLINE_HEADER StgInt64 PK_Int64(W_ p_src[])+{+    int64_thing y;+    y.iu.dhi = p_src[0];+    y.iu.dlo = p_src[1];+    return(y.i);+}++#elif SIZEOF_VOID_P == 8++INLINE_HEADER void ASSIGN_Word64(W_ p_dest[], StgWord64 src)+{+   p_dest[0] = src;+}++INLINE_HEADER StgWord64 PK_Word64(W_ p_src[])+{+    return p_src[0];+}++INLINE_HEADER void ASSIGN_Int64(W_ p_dest[], StgInt64 src)+{+    p_dest[0] = src;+}++INLINE_HEADER StgInt64 PK_Int64(W_ p_src[])+{+    return p_src[0];+}++#endif /* SIZEOF_HSWORD == 4 */++/* -----------------------------------------------------------------------------+   Integer multiply with overflow+   -------------------------------------------------------------------------- */++/* Multiply with overflow checking.+ *+ * This is tricky - the usual sign rules for add/subtract don't apply.+ *+ * On 32-bit machines we use gcc's 'long long' types, finding+ * overflow with some careful bit-twiddling.+ *+ * On 64-bit machines where gcc's 'long long' type is also 64-bits,+ * we use a crude approximation, testing whether either operand is+ * larger than 32-bits; if neither is, then we go ahead with the+ * multiplication.+ *+ * Return non-zero if there is any possibility that the signed multiply+ * of a and b might overflow.  Return zero only if you are absolutely sure+ * that it won't overflow.  If in doubt, return non-zero.+ */++#if SIZEOF_VOID_P == 4++#if defined(WORDS_BIGENDIAN)+#define RTS_CARRY_IDX__ 0+#define RTS_REM_IDX__  1+#else+#define RTS_CARRY_IDX__ 1+#define RTS_REM_IDX__ 0+#endif++typedef union {+    StgInt64 l;+    StgInt32 i[2];+} long_long_u ;++#define mulIntMayOflo(a,b)       \+({                                              \+  StgInt32 r, c;           \+  long_long_u z;           \+  z.l = (StgInt64)a * (StgInt64)b;     \+  r = z.i[RTS_REM_IDX__];        \+  c = z.i[RTS_CARRY_IDX__];         \+  if (c == 0 || c == -1) {       \+    c = ((StgWord)((a^b) ^ r))         \+      >> (BITS_IN (I_) - 1);        \+  }                  \+  c;                                            \+})++/* Careful: the carry calculation above is extremely delicate.  Make sure+ * you test it thoroughly after changing it.+ */++#else++/* Approximate version when we don't have long arithmetic (on 64-bit archs) */++/* If we have n-bit words then we have n-1 bits after accounting for the+ * sign bit, so we can fit the result of multiplying 2 (n-1)/2-bit numbers */+#define HALF_POS_INT  (((I_)1) << ((BITS_IN (I_) - 1) / 2))+#define HALF_NEG_INT  (-HALF_POS_INT)++#define mulIntMayOflo(a,b)       \+({                                              \+  I_ c;              \+  if ((I_)a <= HALF_NEG_INT || a >= HALF_POS_INT    \+      || (I_)b <= HALF_NEG_INT || b >= HALF_POS_INT) {\+    c = 1;              \+  } else {              \+    c = 0;              \+  }                  \+  c;                                            \+})+#endif
+ includes/ghcconfig.h view
@@ -0,0 +1,4 @@+#pragma once++#include "ghcautoconf.h"+#include "ghcplatform.h"
+ includes/rts/Adjustor.h view
@@ -0,0 +1,22 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * Adjustor API+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * -------------------------------------------------------------------------- */++#pragma once++/* Creating and destroying an adjustor thunk */+void* createAdjustor (int cconv, +                      StgStablePtr hptr,+                      StgFunPtr wptr,+                      char *typeString);++void freeHaskellFunctionPtr (void* ptr);
+ includes/rts/BlockSignals.h view
@@ -0,0 +1,34 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * RTS signal handling + *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++/* Used by runProcess() in the process package+ */++/*+ * Function: blockUserSignals()+ *+ * Temporarily block the delivery of further console events. Needed to+ * avoid race conditions when GCing the queue of outstanding handlers or+ * when emptying the queue by running the handlers.+ * + */+void blockUserSignals(void);++/*+ * Function: unblockUserSignals()+ *+ * The inverse of blockUserSignals(); re-enable the deliver of console events.+ */+void unblockUserSignals(void);
+ includes/rts/Bytecodes.h view
@@ -0,0 +1,106 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * Bytecode definitions.+ *+ * ---------------------------------------------------------------------------*/++/* --------------------------------------------------------------------------+ * Instructions+ *+ * Notes:+ * o CASEFAIL is generated by the compiler whenever it tests an "irrefutable"+ *   pattern which fails.  If we don't see too many of these, we could+ *   optimise out the redundant test.+ * ------------------------------------------------------------------------*/++/* NOTE:++   THIS FILE IS INCLUDED IN HASKELL SOURCES (ghc/compiler/ghci/ByteCodeAsm.hs).+   DO NOT PUT C-SPECIFIC STUFF IN HERE!++   I hope that's clear :-)+*/++#define bci_STKCHECK  			1+#define bci_PUSH_L    			2+#define bci_PUSH_LL   			3+#define bci_PUSH_LLL  			4+#define bci_PUSH8                       5+#define bci_PUSH16                      6+#define bci_PUSH32                      7+#define bci_PUSH8_W                     8+#define bci_PUSH16_W                    9+#define bci_PUSH32_W                    10+#define bci_PUSH_G    			11+#define bci_PUSH_ALTS  			12+#define bci_PUSH_ALTS_P			13+#define bci_PUSH_ALTS_N			14+#define bci_PUSH_ALTS_F			15+#define bci_PUSH_ALTS_D			16+#define bci_PUSH_ALTS_L			17+#define bci_PUSH_ALTS_V			18+#define bci_PUSH_PAD8                   19+#define bci_PUSH_PAD16                  20+#define bci_PUSH_PAD32                  21+#define bci_PUSH_UBX8                   22+#define bci_PUSH_UBX16                  23+#define bci_PUSH_UBX32                  24+#define bci_PUSH_UBX  			25+#define bci_PUSH_APPLY_N		26+#define bci_PUSH_APPLY_F		27+#define bci_PUSH_APPLY_D		28+#define bci_PUSH_APPLY_L		29+#define bci_PUSH_APPLY_V		30+#define bci_PUSH_APPLY_P		31+#define bci_PUSH_APPLY_PP		32+#define bci_PUSH_APPLY_PPP		33+#define bci_PUSH_APPLY_PPPP		34+#define bci_PUSH_APPLY_PPPPP		35+#define bci_PUSH_APPLY_PPPPPP		36+/* #define bci_PUSH_APPLY_PPPPPPP		37 */+#define bci_SLIDE     			38+#define bci_ALLOC_AP   			39+#define bci_ALLOC_AP_NOUPD		40+#define bci_ALLOC_PAP  			41+#define bci_MKAP      			42+#define bci_MKPAP      			43+#define bci_UNPACK    			44+#define bci_PACK      			45+#define bci_TESTLT_I   			46+#define bci_TESTEQ_I  			47+#define bci_TESTLT_F  			48+#define bci_TESTEQ_F  			49+#define bci_TESTLT_D  			50+#define bci_TESTEQ_D  			51+#define bci_TESTLT_P  			52+#define bci_TESTEQ_P  			53+#define bci_CASEFAIL  			54+#define bci_JMP       			55+#define bci_CCALL     			56+#define bci_SWIZZLE   			57+#define bci_ENTER     			58+#define bci_RETURN    			59+#define bci_RETURN_P 			60+#define bci_RETURN_N 			61+#define bci_RETURN_F 			62+#define bci_RETURN_D 			63+#define bci_RETURN_L 			64+#define bci_RETURN_V 			65+#define bci_BRK_FUN			66+#define bci_TESTLT_W   			67+#define bci_TESTEQ_W  			68+/* If you need to go past 255 then you will run into the flags */++/* If you need to go below 0x0100 then you will run into the instructions */+#define bci_FLAG_LARGE_ARGS     0x8000++/* If a BCO definitely requires less than this many words of stack,+   don't include an explicit STKCHECK insn in it.  The interpreter+   will check for this many words of stack before running each BCO,+   rendering an explicit check unnecessary in the majority of+   cases. */+#define INTERP_STACK_CHECK_THRESH  50++/*-------------------------------------------------------------------------*/
+ includes/rts/Config.h view
@@ -0,0 +1,48 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * Rts settings.+ *+ * NOTE: assumes #include "ghcconfig.h"+ * + * NB: THIS FILE IS INCLUDED IN NON-C CODE AND DATA!  #defines only please.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++#if defined(TICKY_TICKY) && defined(THREADED_RTS)+#error TICKY_TICKY is incompatible with THREADED_RTS+#endif++/*+ * Whether the runtime system will use libbfd for debugging purposes.+ */+#if defined(DEBUG) && defined(HAVE_BFD_H) && defined(HAVE_LIBBFD) && !defined(_WIN32)+#define USING_LIBBFD 1+#endif++/* DEBUG implies TRACING and TICKY_TICKY  */+#if defined(DEBUG)+#if !defined(TRACING)+#define TRACING+#endif+#if !defined(TICKY_TICKY)+#define TICKY_TICKY+#endif+#endif+++/* -----------------------------------------------------------------------------+   Signals - supported on non-PAR versions of the runtime.  See RtsSignals.h.+   -------------------------------------------------------------------------- */++#define RTS_USER_SIGNALS 1++/* Profile spin locks */++#define PROF_SPIN
+ includes/rts/Constants.h view
@@ -0,0 +1,332 @@+/* ----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * Constants+ *+ * NOTE: this information is used by both the compiler and the RTS.+ * Some of it is tweakable, and some of it must be kept up to date+ * with various other parts of the system.+ *+ * Constants which are derived automatically from other definitions in+ * the system (eg. structure sizes) are generated into the file+ * DerivedConstants.h by a C program (mkDerivedConstantsHdr).+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * -------------------------------------------------------------------------- */++#pragma once++/* -----------------------------------------------------------------------------+   Minimum closure sizes++   This is the minimum number of words in the payload of a+   heap-allocated closure, so that the closure has enough room to be+   overwritten with a forwarding pointer during garbage collection.+   -------------------------------------------------------------------------- */++#define MIN_PAYLOAD_SIZE 1++/* -----------------------------------------------------------------------------+   Constants to do with specialised closure types.+   -------------------------------------------------------------------------- */++/* We have some pre-compiled selector thunks defined in rts/StgStdThunks.hc.+ * This constant defines the highest selectee index that we can replace with a+ * reference to the pre-compiled code.+ */++#define MAX_SPEC_SELECTEE_SIZE 15++/* Vector-apply thunks.  These thunks just push their free variables+ * on the stack and enter the first one.  They're a bit like PAPs, but+ * don't have a dynamic size.  We've pre-compiled a few to save+ * space.+ */++#define MAX_SPEC_AP_SIZE       7++/* Specialised FUN/THUNK/CONSTR closure types */++#define MAX_SPEC_THUNK_SIZE    2+#define MAX_SPEC_FUN_SIZE      2+#define MAX_SPEC_CONSTR_SIZE   2++/* Range of built-in table of static small int-like and char-like closures.+ *+ *   NB. This corresponds with the number of actual INTLIKE/CHARLIKE+ *   closures defined in rts/StgMiscClosures.cmm.+ */+#define MAX_INTLIKE             16+#define MIN_INTLIKE             (-16)++#define MAX_CHARLIKE            255+#define MIN_CHARLIKE            0++/* Each byte in the card table for an StgMutaArrPtrs covers+ * (1<<MUT_ARR_PTRS_CARD_BITS) elements in the array.  To find a good+ * value for this, I used the benchmarks nofib/gc/hash,+ * nofib/gc/graph, and nofib/gc/gc_bench.+ */+#define MUT_ARR_PTRS_CARD_BITS 7++/* -----------------------------------------------------------------------------+   STG Registers.++   Note that in MachRegs.h we define how many of these registers are+   *real* machine registers, and not just offsets in the Register Table.+   -------------------------------------------------------------------------- */++#define MAX_VANILLA_REG 10+#define MAX_FLOAT_REG   6+#define MAX_DOUBLE_REG  6+#define MAX_LONG_REG    1+#define MAX_XMM_REG     6++/* -----------------------------------------------------------------------------+   Semi-Tagging constants++   Old Comments about this stuff:++   Tags for indirection nodes and ``other'' (probably unevaluated) nodes;+   normal-form values of algebraic data types will have tags 0, 1, ...++   @INFO_IND_TAG@ is different from @INFO_OTHER_TAG@ just so we can count+   how often we bang into indirection nodes; that's all.  (WDP 95/11)++   ToDo: find out if we need any of this.+   -------------------------------------------------------------------------- */++#define INFO_OTHER_TAG          (-1)+#define INFO_IND_TAG            (-2)+#define INFO_FIRST_TAG          0++/* -----------------------------------------------------------------------------+   How much C stack to reserve for local temporaries when in the STG+   world.  Used in StgCRun.c.+   -------------------------------------------------------------------------- */++#define RESERVED_C_STACK_BYTES (2048 * SIZEOF_LONG)++/* -----------------------------------------------------------------------------+   How large is the stack frame saved by StgRun?+   world.  Used in StgCRun.c.++   The size has to be enough to save the registers (see StgCRun)+   plus padding if the result is not 16 byte aligned.+   See the Note [Stack Alignment on X86] in StgCRun.c for details.++   -------------------------------------------------------------------------- */+#if defined(x86_64_HOST_ARCH)+#  if defined(mingw32_HOST_OS)+#    define STG_RUN_STACK_FRAME_SIZE 144+#  else+#    define STG_RUN_STACK_FRAME_SIZE 48+#  endif+#endif++/* -----------------------------------------------------------------------------+   StgRun related labels shared between StgCRun.c and StgStartup.cmm.+   -------------------------------------------------------------------------- */++#if defined(LEADING_UNDERSCORE)+#define STG_RUN "_StgRun"+#define STG_RUN_JMP _StgRunJmp+#define STG_RETURN "_StgReturn"+#else+#define STG_RUN "StgRun"+#define STG_RUN_JMP StgRunJmp+#define STG_RETURN "StgReturn"+#endif++/* -----------------------------------------------------------------------------+   How much Haskell stack space to reserve for the saving of registers+   etc. in the case of a stack/heap overflow.++   This must be large enough to accommodate the largest stack frame+   pushed in one of the heap check fragments in HeapStackCheck.hc+   (ie. currently the generic heap checks - 3 words for StgRetDyn,+   18 words for the saved registers, see StgMacros.h).+   -------------------------------------------------------------------------- */++#define RESERVED_STACK_WORDS 21++/* -----------------------------------------------------------------------------+   The limit on the size of the stack check performed when we enter an+   AP_STACK, in words.  See raiseAsync() and bug #1466.+   -------------------------------------------------------------------------- */++#define AP_STACK_SPLIM 1024++/* -----------------------------------------------------------------------------+   Storage manager constants+   -------------------------------------------------------------------------- */++/* The size of a block (2^BLOCK_SHIFT bytes) */+#define BLOCK_SHIFT  12++/* The size of a megablock (2^MBLOCK_SHIFT bytes) */+#define MBLOCK_SHIFT   20++/* -----------------------------------------------------------------------------+   Bitmap/size fields (used in info tables)+   -------------------------------------------------------------------------- */++/* In a 32-bit bitmap field, we use 5 bits for the size, and 27 bits+ * for the bitmap.  If the bitmap requires more than 27 bits, then we+ * store it in a separate array, and leave a pointer in the bitmap+ * field.  On a 64-bit machine, the sizes are extended accordingly.+ */+#if SIZEOF_VOID_P == 4+#define BITMAP_SIZE_MASK     0x1f+#define BITMAP_BITS_SHIFT    5+#elif SIZEOF_VOID_P == 8+#define BITMAP_SIZE_MASK     0x3f+#define BITMAP_BITS_SHIFT    6+#else+#error unknown SIZEOF_VOID_P+#endif++/* -----------------------------------------------------------------------------+   Lag/Drag/Void constants+   -------------------------------------------------------------------------- */++/*+  An LDV word is divided into 3 parts: state bits (LDV_STATE_MASK), creation+  time bits (LDV_CREATE_MASK), and last use time bits (LDV_LAST_MASK).+ */+#if SIZEOF_VOID_P == 8+#define LDV_SHIFT               30+#define LDV_STATE_MASK          0x1000000000000000+#define LDV_CREATE_MASK         0x0FFFFFFFC0000000+#define LDV_LAST_MASK           0x000000003FFFFFFF+#define LDV_STATE_CREATE        0x0000000000000000+#define LDV_STATE_USE           0x1000000000000000+#else+#define LDV_SHIFT               15+#define LDV_STATE_MASK          0x40000000+#define LDV_CREATE_MASK         0x3FFF8000+#define LDV_LAST_MASK           0x00007FFF+#define LDV_STATE_CREATE        0x00000000+#define LDV_STATE_USE           0x40000000+#endif /* SIZEOF_VOID_P */++/* -----------------------------------------------------------------------------+   TSO related constants+   -------------------------------------------------------------------------- */++/*+ * Constants for the what_next field of a TSO, which indicates how it+ * is to be run.+ */+#define ThreadRunGHC    1       /* return to address on top of stack */+#define ThreadInterpret 2       /* interpret this thread */+#define ThreadKilled    3       /* thread has died, don't run it */+#define ThreadComplete  4       /* thread has finished */++/*+ * Constants for the why_blocked field of a TSO+ * NB. keep these in sync with GHC/Conc/Sync.hs: threadStatus+ */+#define NotBlocked          0+#define BlockedOnMVar       1+#define BlockedOnMVarRead   14 /* TODO: renumber me, see #9003 */+#define BlockedOnBlackHole  2+#define BlockedOnRead       3+#define BlockedOnWrite      4+#define BlockedOnDelay      5+#define BlockedOnSTM        6++/* Win32 only: */+#define BlockedOnDoProc     7++/* Only relevant for THREADED_RTS: */+#define BlockedOnCCall      10+#define BlockedOnCCall_Interruptible 11+   /* same as above but permit killing the worker thread */++/* Involved in a message sent to tso->msg_cap */+#define BlockedOnMsgThrowTo 12++/* The thread is not on any run queues, but can be woken up+   by tryWakeupThread() */+#define ThreadMigrating     13++/* WARNING WARNING top number is BlockedOnMVarRead 14, not 13!! */++/*+ * These constants are returned to the scheduler by a thread that has+ * stopped for one reason or another.  See typedef StgThreadReturnCode+ * in TSO.h.+ */+#define HeapOverflow   1                /* might also be StackOverflow */+#define StackOverflow  2+#define ThreadYielding 3+#define ThreadBlocked  4+#define ThreadFinished 5++/*+ * Flags for the tso->flags field.+ */++/*+ * TSO_LOCKED is set when a TSO is locked to a particular Capability.+ */+#define TSO_LOCKED  2++/*+ * TSO_BLOCKEX: the TSO is blocking exceptions+ *+ * TSO_INTERRUPTIBLE: the TSO can be interrupted if it blocks+ * interruptibly (eg. with BlockedOnMVar).+ *+ * TSO_STOPPED_ON_BREAKPOINT: the thread is currently stopped in a breakpoint+ */+#define TSO_BLOCKEX       4+#define TSO_INTERRUPTIBLE 8+#define TSO_STOPPED_ON_BREAKPOINT 16++/*+ * Used by the sanity checker to check whether TSOs are on the correct+ * mutable list.+ */+#define TSO_MARKED 64++/*+ * Used to communicate between stackSqueeze() and+ * threadStackOverflow() that a thread's stack was squeezed and the+ * stack may not need to be expanded.+ */+#define TSO_SQUEEZED 128++/*+ * Enables the AllocationLimitExceeded exception when the thread's+ * allocation limit goes negative.+ */+#define TSO_ALLOC_LIMIT 256++/*+ * The number of times we spin in a spin lock before yielding (see+ * #3758).  To tune this value, use the benchmark in #3758: run the+ * server with -N2 and the client both on a dual-core.  Also make sure+ * that the chosen value doesn't slow down any of the parallel+ * benchmarks in nofib/parallel.+ */+#define SPIN_COUNT 1000++/* -----------------------------------------------------------------------------+   Spare workers per Capability in the threaded RTS++   No more than MAX_SPARE_WORKERS will be kept in the thread pool+   associated with each Capability.+   -------------------------------------------------------------------------- */++#define MAX_SPARE_WORKERS 6++/*+ * The maximum number of NUMA nodes we support.  This is a fixed limit so that+ * we can have static arrays of this size in the RTS for speed.+ */+#define MAX_NUMA_NODES 16
+ includes/rts/EventLogFormat.h view
@@ -0,0 +1,264 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2008-2009+ *+ * Event log format+ *+ * The log format is designed to be extensible: old tools should be+ * able to parse (but not necessarily understand all of) new versions+ * of the format, and new tools will be able to understand old log+ * files.+ *+ * Each event has a specific format.  If you add new events, give them+ * new numbers: we never re-use old event numbers.+ *+ * - The format is endian-independent: all values are represented in+ *    bigendian order.+ *+ * - The format is extensible:+ *+ *    - The header describes each event type and its length.  Tools+ *      that don't recognise a particular event type can skip those events.+ *+ *    - There is room for extra information in the event type+ *      specification, which can be ignored by older tools.+ *+ *    - Events can have extra information added, but existing fields+ *      cannot be changed.  Tools should ignore extra fields at the+ *      end of the event record.+ *+ *    - Old event type ids are never re-used; just take a new identifier.+ *+ *+ * The format+ * ----------+ *+ * log : EVENT_HEADER_BEGIN+ *       EventType*+ *       EVENT_HEADER_END+ *       EVENT_DATA_BEGIN+ *       Event*+ *       EVENT_DATA_END+ *+ * EventType :+ *       EVENT_ET_BEGIN+ *       Word16         -- unique identifier for this event+ *       Int16          -- >=0  size of the event in bytes (minus the header)+ *                      -- -1   variable size+ *       Word32         -- length of the next field in bytes+ *       Word8*         -- string describing the event+ *       Word32         -- length of the next field in bytes+ *       Word8*         -- extra info (for future extensions)+ *       EVENT_ET_END+ *+ * Event :+ *       Word16         -- event_type+ *       Word64         -- time (nanosecs)+ *       [Word16]       -- length of the rest (for variable-sized events only)+ *       ... extra event-specific info ...+ *+ *+ * To add a new event+ * ------------------+ *+ *  - In this file:+ *    - give it a new number, add a new #define EVENT_XXX below+ *  - In EventLog.c+ *    - add it to the EventDesc array+ *    - emit the event type in initEventLogging()+ *    - emit the new event in postEvent_()+ *    - generate the event itself by calling postEvent() somewhere+ *  - In the Haskell code to parse the event log file:+ *    - add types and code to read the new event+ *+ * -------------------------------------------------------------------------- */++#pragma once++/*+ * Markers for begin/end of the Header.+ */+#define EVENT_HEADER_BEGIN    0x68647262 /* 'h' 'd' 'r' 'b' */+#define EVENT_HEADER_END      0x68647265 /* 'h' 'd' 'r' 'e' */++#define EVENT_DATA_BEGIN      0x64617462 /* 'd' 'a' 't' 'b' */+#define EVENT_DATA_END        0xffff++/*+ * Markers for begin/end of the list of Event Types in the Header.+ * Header, Event Type, Begin = hetb+ * Header, Event Type, End = hete+ */+#define EVENT_HET_BEGIN       0x68657462 /* 'h' 'e' 't' 'b' */+#define EVENT_HET_END         0x68657465 /* 'h' 'e' 't' 'e' */++#define EVENT_ET_BEGIN        0x65746200 /* 'e' 't' 'b' 0 */+#define EVENT_ET_END          0x65746500 /* 'e' 't' 'e' 0 */++/*+ * Types of event+ */+#define EVENT_CREATE_THREAD        0 /* (thread)               */+#define EVENT_RUN_THREAD           1 /* (thread)               */+#define EVENT_STOP_THREAD          2 /* (thread, status, blockinfo) */+#define EVENT_THREAD_RUNNABLE      3 /* (thread)               */+#define EVENT_MIGRATE_THREAD       4 /* (thread, new_cap)      */+/* 5, 6, 7 deprecated */+#define EVENT_THREAD_WAKEUP        8 /* (thread, other_cap)    */+#define EVENT_GC_START             9 /* ()                     */+#define EVENT_GC_END              10 /* ()                     */+#define EVENT_REQUEST_SEQ_GC      11 /* ()                     */+#define EVENT_REQUEST_PAR_GC      12 /* ()                     */+/* 13, 14 deprecated */+#define EVENT_CREATE_SPARK_THREAD 15 /* (spark_thread)         */+#define EVENT_LOG_MSG             16 /* (message ...)          */+/* 17 deprecated */+#define EVENT_BLOCK_MARKER        18 /* (size, end_time, capability) */+#define EVENT_USER_MSG            19 /* (message ...)          */+#define EVENT_GC_IDLE             20 /* () */+#define EVENT_GC_WORK             21 /* () */+#define EVENT_GC_DONE             22 /* () */+/* 23, 24 used by eden */+#define EVENT_CAPSET_CREATE       25 /* (capset, capset_type)  */+#define EVENT_CAPSET_DELETE       26 /* (capset)               */+#define EVENT_CAPSET_ASSIGN_CAP   27 /* (capset, cap)          */+#define EVENT_CAPSET_REMOVE_CAP   28 /* (capset, cap)          */+/* the RTS identifier is in the form of "GHC-version rts_way"  */+#define EVENT_RTS_IDENTIFIER      29 /* (capset, name_version_string) */+/* the vectors in these events are null separated strings             */+#define EVENT_PROGRAM_ARGS        30 /* (capset, commandline_vector)  */+#define EVENT_PROGRAM_ENV         31 /* (capset, environment_vector)  */+#define EVENT_OSPROCESS_PID       32 /* (capset, pid)          */+#define EVENT_OSPROCESS_PPID      33 /* (capset, parent_pid)   */+#define EVENT_SPARK_COUNTERS      34 /* (crt,dud,ovf,cnv,gcd,fiz,rem) */+#define EVENT_SPARK_CREATE        35 /* ()                     */+#define EVENT_SPARK_DUD           36 /* ()                     */+#define EVENT_SPARK_OVERFLOW      37 /* ()                     */+#define EVENT_SPARK_RUN           38 /* ()                     */+#define EVENT_SPARK_STEAL         39 /* (victim_cap)           */+#define EVENT_SPARK_FIZZLE        40 /* ()                     */+#define EVENT_SPARK_GC            41 /* ()                     */+#define EVENT_INTERN_STRING       42 /* (string, id) {not used by ghc} */+#define EVENT_WALL_CLOCK_TIME     43 /* (capset, unix_epoch_seconds, nanoseconds) */+#define EVENT_THREAD_LABEL        44 /* (thread, name_string)  */+#define EVENT_CAP_CREATE          45 /* (cap)                  */+#define EVENT_CAP_DELETE          46 /* (cap)                  */+#define EVENT_CAP_DISABLE         47 /* (cap)                  */+#define EVENT_CAP_ENABLE          48 /* (cap)                  */+#define EVENT_HEAP_ALLOCATED      49 /* (heap_capset, alloc_bytes) */+#define EVENT_HEAP_SIZE           50 /* (heap_capset, size_bytes) */+#define EVENT_HEAP_LIVE           51 /* (heap_capset, live_bytes) */+#define EVENT_HEAP_INFO_GHC       52 /* (heap_capset, n_generations,+                                         max_heap_size, alloc_area_size,+                                         mblock_size, block_size) */+#define EVENT_GC_STATS_GHC        53 /* (heap_capset, generation,+                                         copied_bytes, slop_bytes, frag_bytes,+                                         par_n_threads,+                                         par_max_copied,+                                         par_tot_copied, par_balanced_copied) */+#define EVENT_GC_GLOBAL_SYNC      54 /* ()                     */+#define EVENT_TASK_CREATE         55 /* (taskID, cap, tid)       */+#define EVENT_TASK_MIGRATE        56 /* (taskID, cap, new_cap)   */+#define EVENT_TASK_DELETE         57 /* (taskID)                 */+#define EVENT_USER_MARKER         58 /* (marker_name) */+#define EVENT_HACK_BUG_T9003      59 /* Hack: see trac #9003 */++/* Range 60 - 80 is used by eden for parallel tracing+ * see http://www.mathematik.uni-marburg.de/~eden/+ */++/* Range 100 - 139 is reserved for Mercury. */++/* Range 140 - 159 is reserved for Perf events. */++/* Range 160 - 180 is reserved for cost-centre heap profiling events. */++#define EVENT_HEAP_PROF_BEGIN              160+#define EVENT_HEAP_PROF_COST_CENTRE        161+#define EVENT_HEAP_PROF_SAMPLE_BEGIN       162+#define EVENT_HEAP_PROF_SAMPLE_COST_CENTRE 163+#define EVENT_HEAP_PROF_SAMPLE_STRING      164++#define EVENT_USER_BINARY_MSG              181++/*+ * The highest event code +1 that ghc itself emits. Note that some event+ * ranges higher than this are reserved but not currently emitted by ghc.+ * This must match the size of the EventDesc[] array in EventLog.c+ */+#define NUM_GHC_EVENT_TAGS        182++#if 0  /* DEPRECATED EVENTS: */+/* we don't actually need to record the thread, it's implicit */+#define EVENT_RUN_SPARK            5 /* (thread)               */+#define EVENT_STEAL_SPARK          6 /* (thread, victim_cap)   */+/* shutdown replaced by EVENT_CAP_DELETE */+#define EVENT_SHUTDOWN             7 /* ()                     */+/* ghc changed how it handles sparks so these are no longer applicable */+#define EVENT_CREATE_SPARK        13 /* (cap, thread) */+#define EVENT_SPARK_TO_THREAD     14 /* (cap, thread, spark_thread) */+#define EVENT_STARTUP             17 /* (num_capabilities)     */+/* these are used by eden but are replaced by new alternatives for ghc */+#define EVENT_VERSION             23 /* (version_string) */+#define EVENT_PROGRAM_INVOCATION  24 /* (commandline_string) */+#endif++/*+ * Status values for EVENT_STOP_THREAD+ *+ * 1-5 are the StgRun return values (from includes/Constants.h):+ *+ * #define HeapOverflow   1+ * #define StackOverflow  2+ * #define ThreadYielding 3+ * #define ThreadBlocked  4+ * #define ThreadFinished 5+ * #define ForeignCall                  6+ * #define BlockedOnMVar                7+ * #define BlockedOnBlackHole           8+ * #define BlockedOnRead                9+ * #define BlockedOnWrite               10+ * #define BlockedOnDelay               11+ * #define BlockedOnSTM                 12+ * #define BlockedOnDoProc              13+ * #define BlockedOnCCall               -- not used (see ForeignCall)+ * #define BlockedOnCCall_NoUnblockExc  -- not used (see ForeignCall)+ * #define BlockedOnMsgThrowTo          16+ */+#define THREAD_SUSPENDED_FOREIGN_CALL 6++/*+ * Capset type values for EVENT_CAPSET_CREATE+ */+#define CAPSET_TYPE_CUSTOM      1  /* reserved for end-user applications */+#define CAPSET_TYPE_OSPROCESS   2  /* caps belong to the same OS process */+#define CAPSET_TYPE_CLOCKDOMAIN 3  /* caps share a local clock/time      */++/*+ * Heap profile breakdown types. See EVENT_HEAP_PROF_BEGIN.+ */+typedef enum {+    HEAP_PROF_BREAKDOWN_COST_CENTRE = 0x1,+    HEAP_PROF_BREAKDOWN_MODULE,+    HEAP_PROF_BREAKDOWN_CLOSURE_DESCR,+    HEAP_PROF_BREAKDOWN_TYPE_DESCR,+    HEAP_PROF_BREAKDOWN_RETAINER,+    HEAP_PROF_BREAKDOWN_BIOGRAPHY,+    HEAP_PROF_BREAKDOWN_CLOSURE_TYPE+} HeapProfBreakdown;++#if !defined(EVENTLOG_CONSTANTS_ONLY)++typedef StgWord16 EventTypeNum;+typedef StgWord64 EventTimestamp; /* in nanoseconds */+typedef StgWord32 EventThreadID;+typedef StgWord16 EventCapNo;+typedef StgWord16 EventPayloadSize; /* variable-size events */+typedef StgWord16 EventThreadStatus; /* status for EVENT_STOP_THREAD */+typedef StgWord32 EventCapsetID;+typedef StgWord16 EventCapsetType;   /* types for EVENT_CAPSET_CREATE */+typedef StgWord64 EventTaskId;         /* for EVENT_TASK_* */+typedef StgWord64 EventKernelThreadId; /* for EVENT_TASK_CREATE */++#define EVENT_PAYLOAD_SIZE_MAX STG_WORD16_MAX+#endif
+ includes/rts/EventLogWriter.h view
@@ -0,0 +1,40 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2008-2017+ *+ * Support for fast binary event logging.+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++#include <stddef.h>+#include <stdbool.h>++/*+ *  Abstraction for writing eventlog data.+ */+typedef struct {+    // Initialize an EventLogWriter (may be NULL)+    void (* initEventLogWriter) (void);++    // Write a series of events+    bool (* writeEventLog) (void *eventlog, size_t eventlog_size);++    // Flush possibly existing buffers (may be NULL)+    void (* flushEventLog) (void);++    // Close an initialized EventLogOutput (may be NULL)+    void (* stopEventLogWriter) (void);+} EventLogWriter;++/*+ * An EventLogWriter which writes eventlogs to+ * a file `program.eventlog`.+ */+extern const EventLogWriter FileEventLogWriter;
+ includes/rts/FileLock.h view
@@ -0,0 +1,19 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2007-2009+ *+ * File locking support as required by Haskell+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++#include "Stg.h"++int  lockFile(int fd, StgWord64 dev, StgWord64 ino, int for_writing);+int  unlockFile(int fd);
+ includes/rts/Flags.h view
@@ -0,0 +1,301 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * Datatypes that holds the command-line flag settings.+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++#include <stdio.h>+#include <stdint.h>+#include <stdbool.h>+#include "stg/Types.h"+#include "Time.h"++/* For defaults, see the @initRtsFlagsDefaults@ routine. */++/* Note [Synchronization of flags and base APIs]+ *+ * We provide accessors to RTS flags in base. (GHC.RTS module)+ * The API should be updated whenever RTS flags are modified.+ */++/* See Note [Synchronization of flags and base APIs] */+typedef struct _GC_FLAGS {+    FILE   *statsFile;+    uint32_t  giveStats;+#define NO_GC_STATS	 0+#define COLLECT_GC_STATS 1+#define ONELINE_GC_STATS 2+#define SUMMARY_GC_STATS 3+#define VERBOSE_GC_STATS 4++    uint32_t     maxStkSize;         /* in *words* */+    uint32_t     initialStkSize;     /* in *words* */+    uint32_t     stkChunkSize;       /* in *words* */+    uint32_t     stkChunkBufferSize; /* in *words* */++    uint32_t     maxHeapSize;        /* in *blocks* */+    uint32_t     minAllocAreaSize;   /* in *blocks* */+    uint32_t     largeAllocLim;      /* in *blocks* */+    uint32_t     nurseryChunkSize;   /* in *blocks* */+    uint32_t     minOldGenSize;      /* in *blocks* */+    uint32_t     heapSizeSuggestion; /* in *blocks* */+    bool heapSizeSuggestionAuto;+    double  oldGenFactor;+    double  pcFreeHeap;++    uint32_t     generations;+    bool squeezeUpdFrames;++    bool compact;		/* True <=> "compact all the time" */+    double  compactThreshold;++    bool sweep;		/* use "mostly mark-sweep" instead of copying+                                 * for the oldest generation */+    bool ringBell;++    Time    idleGCDelayTime;    /* units: TIME_RESOLUTION */+    bool doIdleGC;++    Time    longGCSync;         /* units: TIME_RESOLUTION */++    StgWord heapBase;           /* address to ask the OS for memory */++    StgWord allocLimitGrace;    /* units: *blocks*+                                 * After an AllocationLimitExceeded+                                 * exception has been raised, how much+                                 * extra space is given to the thread+                                 * to handle the exception before we+                                 * raise it again.+                                 */+    StgWord heapLimitGrace;     /* units: *blocks*+                                 * After a HeapOverflow exception has+                                 * been raised, how much extra space is+                                 * given to the thread to handle the+                                 * exception before we raise it again.+                                 */++    bool numa;                   /* Use NUMA */+    StgWord numaMask;+} GC_FLAGS;++/* See Note [Synchronization of flags and base APIs] */+typedef struct _DEBUG_FLAGS {+    /* flags to control debugging output & extra checking in various subsystems */+    bool scheduler;      /* 's' */+    bool interpreter;    /* 'i' */+    bool weak;           /* 'w' */+    bool gccafs;         /* 'G' */+    bool gc;             /* 'g' */+    bool block_alloc;    /* 'b' */+    bool sanity;         /* 'S'   warning: might be expensive! */+    bool stable;         /* 't' */+    bool prof;           /* 'p' */+    bool linker;         /* 'l'   the object linker */+    bool apply;          /* 'a' */+    bool stm;            /* 'm' */+    bool squeeze;        /* 'z'  stack squeezing & lazy blackholing */+    bool hpc;            /* 'c' coverage */+    bool sparks;         /* 'r' */+    bool numa;           /* '--debug-numa' */+    bool compact;        /* 'C' */+} DEBUG_FLAGS;++/* See Note [Synchronization of flags and base APIs] */+typedef struct _COST_CENTRE_FLAGS {+    uint32_t    doCostCentres;+# define COST_CENTRES_NONE      0+# define COST_CENTRES_SUMMARY	1+# define COST_CENTRES_VERBOSE	2 /* incl. serial time profile */+# define COST_CENTRES_ALL	3+# define COST_CENTRES_JSON      4++    int	    profilerTicks;   /* derived */+    int	    msecsPerTick;    /* derived */+    char const *outputFileNameStem;+} COST_CENTRE_FLAGS;++/* See Note [Synchronization of flags and base APIs] */+typedef struct _PROFILING_FLAGS {+    uint32_t doHeapProfile;+# define NO_HEAP_PROFILING	0	/* N.B. Used as indexes into arrays */+# define HEAP_BY_CCS		1+# define HEAP_BY_MOD		2+# define HEAP_BY_DESCR		4+# define HEAP_BY_TYPE		5+# define HEAP_BY_RETAINER       6+# define HEAP_BY_LDV            7++# define HEAP_BY_CLOSURE_TYPE   8++    Time        heapProfileInterval; /* time between samples */+    uint32_t    heapProfileIntervalTicks; /* ticks between samples (derived) */+    bool        includeTSOs;+++    bool		showCCSOnException;++    uint32_t    maxRetainerSetSize;++    uint32_t    ccsLength;++    const char*         modSelector;+    const char*         descrSelector;+    const char*         typeSelector;+    const char*         ccSelector;+    const char*         ccsSelector;+    const char*         retainerSelector;+    const char*         bioSelector;++} PROFILING_FLAGS;++#define TRACE_NONE      0+#define TRACE_EVENTLOG  1+#define TRACE_STDERR    2++/* See Note [Synchronization of flags and base APIs] */+typedef struct _TRACE_FLAGS {+    int tracing;+    bool timestamp;      /* show timestamp in stderr output */+    bool scheduler;      /* trace scheduler events */+    bool gc;             /* trace GC events */+    bool sparks_sampled; /* trace spark events by a sampled method */+    bool sparks_full;    /* trace spark events 100% accurately */+    bool user;           /* trace user events (emitted from Haskell code) */+    char *trace_output;  /* output filename for eventlog */+} TRACE_FLAGS;++/* See Note [Synchronization of flags and base APIs] */+typedef struct _CONCURRENT_FLAGS {+    Time ctxtSwitchTime;         /* units: TIME_RESOLUTION */+    int ctxtSwitchTicks;         /* derived */+} CONCURRENT_FLAGS;++/*+ * The tickInterval is the time interval between "ticks", ie.+ * timer signals (see Timer.{c,h}).  It is the frequency at+ * which we sample CCCS for profiling.+ *+ * It is changed by the +RTS -V<secs> flag.+ */+#define DEFAULT_TICK_INTERVAL USToTime(10000)++/*+ * When linkerAlwaysPic is true, the runtime linker assume that all object+ * files were compiled with -fPIC -fexternal-dynamic-refs and load them+ * anywhere in the address space.+ */+#if defined(x86_64_HOST_ARCH) && defined(darwin_HOST_OS)+#define DEFAULT_LINKER_ALWAYS_PIC true+#else+#define DEFAULT_LINKER_ALWAYS_PIC false+#endif++/* See Note [Synchronization of flags and base APIs] */+typedef struct _MISC_FLAGS {+    Time    tickInterval;        /* units: TIME_RESOLUTION */+    bool install_signal_handlers;+    bool install_seh_handlers;+    bool generate_dump_file;+    bool generate_stack_trace;+    bool machineReadable;+    bool internalCounters;       /* See Note [Internal Counter Stats] */+    bool linkerAlwaysPic;        /* Assume the object code is always PIC */+    StgWord linkerMemBase;       /* address to ask the OS for memory+                                  * for the linker, NULL ==> off */+} MISC_FLAGS;++/* See Note [Synchronization of flags and base APIs] */+typedef struct _PAR_FLAGS {+  uint32_t       nCapabilities;  /* number of threads to run simultaneously */+  bool           migrate;        /* migrate threads between capabilities */+  uint32_t       maxLocalSparks;+  bool           parGcEnabled;   /* enable parallel GC */+  uint32_t       parGcGen;       /* do parallel GC in this generation+                                  * and higher only */+  bool           parGcLoadBalancingEnabled;+                                 /* enable load-balancing in the+                                  * parallel GC */+  uint32_t       parGcLoadBalancingGen;+                                 /* do load-balancing in this+                                  * generation and higher only */++  uint32_t       parGcNoSyncWithIdle;+                                 /* if a Capability has been idle for+                                  * this many GCs, do not try to wake+                                  * it up when doing a+                                  * non-load-balancing parallel GC.+                                  * (zero disables) */++  uint32_t       parGcThreads;+                                 /* Use this many threads for parallel+                                  * GC (default: use all nNodes). */++  bool           setAffinity;    /* force thread affinity with CPUs */+} PAR_FLAGS;++/* See Note [Synchronization of flags and base APIs] */+typedef struct _TICKY_FLAGS {+    bool showTickyStats;+    FILE   *tickyFile;+} TICKY_FLAGS;++/* Put them together: */++/* See Note [Synchronization of flags and base APIs] */+typedef struct _RTS_FLAGS {+    /* The first portion of RTS_FLAGS is invariant. */+    GC_FLAGS	      GcFlags;+    CONCURRENT_FLAGS  ConcFlags;+    MISC_FLAGS        MiscFlags;+    DEBUG_FLAGS	      DebugFlags;+    COST_CENTRE_FLAGS CcFlags;+    PROFILING_FLAGS   ProfFlags;+    TRACE_FLAGS       TraceFlags;+    TICKY_FLAGS	      TickyFlags;+    PAR_FLAGS	      ParFlags;+} RTS_FLAGS;++#if defined(COMPILING_RTS_MAIN)+extern DLLIMPORT RTS_FLAGS RtsFlags;+#elif IN_STG_CODE+/* Hack because the C code generator can't generate '&label'. */+extern RTS_FLAGS RtsFlags[];+#else+extern RTS_FLAGS RtsFlags;+#endif++/*+ * The printf formats are here, so we are less likely to make+ * overly-long filenames (with disastrous results).  No more than 128+ * chars, please!+ */++#define STATS_FILENAME_MAXLEN	128++#define GR_FILENAME_FMT		"%0.124s.gr"+#define HP_FILENAME_FMT		"%0.124s.hp"+#define LIFE_FILENAME_FMT	"%0.122s.life"+#define PROF_FILENAME_FMT	"%0.122s.prof"+#define PROF_FILENAME_FMT_GUM	"%0.118s.%03d.prof"+#define QP_FILENAME_FMT		"%0.124s.qp"+#define STAT_FILENAME_FMT	"%0.122s.stat"+#define TICKY_FILENAME_FMT	"%0.121s.ticky"+#define TIME_FILENAME_FMT	"%0.122s.time"+#define TIME_FILENAME_FMT_GUM	"%0.118s.%03d.time"++/* an "int" so as to match normal "argc" */+/* Now defined in Stg.h (lib/std/cbits need these too.)+extern int     prog_argc;+extern char  **prog_argv;+*/+extern int      rts_argc;  /* ditto */+extern char   **rts_argv;
+ includes/rts/GetTime.h view
@@ -0,0 +1,16 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1995-2009+ *+ * Interface to the RTS time+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++StgWord64 getMonotonicNSec (void);
+ includes/rts/Globals.h view
@@ -0,0 +1,36 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2006-2009+ *+ * The RTS stores some "global" values on behalf of libraries, so that+ * some libraries can ensure that certain top-level things are shared+ * even when multiple versions of the library are loaded.  e.g. see+ * Data.Typeable and GHC.Conc.+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++#define mkStoreAccessorPrototype(name)                                  \+    StgStablePtr                                                        \+    getOrSet##name(StgStablePtr ptr);++mkStoreAccessorPrototype(GHCConcSignalSignalHandlerStore)+mkStoreAccessorPrototype(GHCConcWindowsPendingDelaysStore)+mkStoreAccessorPrototype(GHCConcWindowsIOManagerThreadStore)+mkStoreAccessorPrototype(GHCConcWindowsProddingStore)+mkStoreAccessorPrototype(SystemEventThreadEventManagerStore)+mkStoreAccessorPrototype(SystemEventThreadIOManagerThreadStore)+mkStoreAccessorPrototype(SystemTimerThreadEventManagerStore)+mkStoreAccessorPrototype(SystemTimerThreadIOManagerThreadStore)+mkStoreAccessorPrototype(LibHSghcFastStringTable)+mkStoreAccessorPrototype(LibHSghcPersistentLinkerState)+mkStoreAccessorPrototype(LibHSghcInitLinkerDone)+mkStoreAccessorPrototype(LibHSghcGlobalDynFlags)+mkStoreAccessorPrototype(LibHSghcStaticOptions)+mkStoreAccessorPrototype(LibHSghcStaticOptionsReady)
+ includes/rts/Hpc.h view
@@ -0,0 +1,34 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2008-2009+ *+ * Haskell Program Coverage+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * -------------------------------------------------------------------------- */++#pragma once++// Simple linked list of modules+typedef struct _HpcModuleInfo {+  char *modName;                // name of module+  StgWord32 tickCount;          // number of ticks+  StgWord32 hashNo;             // Hash number for this module's mix info+  StgWord64 *tixArr;            // tix Array; local for this module+  bool from_file;               // data was read from the .tix file+  struct _HpcModuleInfo *next;+} HpcModuleInfo;++void hs_hpc_module (char *modName,+                    StgWord32 modCount,+                    StgWord32 modHashNo,+                    StgWord64 *tixArr);++HpcModuleInfo * hs_hpc_rootModule (void);++void startupHpc(void);+void exitHpc(void);
+ includes/rts/IOManager.h view
@@ -0,0 +1,43 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * IO Manager functionality in the RTS+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * -------------------------------------------------------------------------- */++#pragma once++#if defined(mingw32_HOST_OS)++int  rts_InstallConsoleEvent ( int action, StgStablePtr *handler );+void rts_ConsoleHandlerDone  ( int ev );+extern StgInt console_handler;++void *   getIOManagerEvent  (void);+HsWord32 readIOManagerEvent (void);+void     sendIOManagerEvent (HsWord32 event);++#else++void     setIOManagerControlFd   (uint32_t cap_no, int fd);+void     setTimerManagerControlFd(int fd);+void     setIOManagerWakeupFd   (int fd);++#endif++//+// Communicating with the IO manager thread (see GHC.Conc).+// Posix implementation in posix/Signals.c+// Win32 implementation in win32/ThrIOManager.c+//+void ioManagerWakeup (void);+#if defined(THREADED_RTS)+void ioManagerDie (void);+void ioManagerStart (void);+#endif
+ includes/rts/Libdw.h view
@@ -0,0 +1,97 @@+/* ---------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2014-2015+ *+ * Producing DWARF-based stacktraces with libdw.+ *+ * --------------------------------------------------------------------------*/++#pragma once++// for FILE+#include <stdio.h>++// Chunk capacity+// This is rather arbitrary+#define BACKTRACE_CHUNK_SZ 256++/*+ * Note [Chunked stack representation]+ * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ *+ * Consider the stack,+ *     main                   calls                        (bottom of stack)+ *       func1                which in turn calls+ *         func2              which calls+ *          func3             which calls+ *            func4           which calls+ *              func5         which calls+ *                func6       which calls+ *                  func7     which requests a backtrace   (top of stack)+ *+ * This would produce the Backtrace (using a smaller chunk size of three for+ * illustrative purposes),+ *+ * Backtrace     /----> Chunk         /----> Chunk         /----> Chunk+ * last --------/       next --------/       next --------/       next+ * n_frames=8           n_frames=2           n_frames=3           n_frames=3+ *                      ~~~~~~~~~~           ~~~~~~~~~~           ~~~~~~~~~~+ *                      func1                func4                func7+ *                      main                 func3                func6+ *                                           func2                func5+ *+ */++/* A chunk of code addresses from an execution stack+ *+ * The first address in this list corresponds to the stack frame+ * nearest to the "top" of the stack.+ */+typedef struct BacktraceChunk_ {+    StgWord n_frames;                      // number of frames in this chunk+    struct BacktraceChunk_ *next;          // the chunk following this one+    StgPtr frames[BACKTRACE_CHUNK_SZ];     // the code addresses from the+                                           // frames+} __attribute__((packed)) BacktraceChunk;++/* A chunked list of code addresses from an execution stack+ *+ * This structure is optimized for append operations since we append O(stack+ * depth) times yet typically only traverse the stack trace once. Consequently,+ * the "top" stack frame (that is, the one where we started unwinding) can be+ * found in the last chunk. Yes, this is a bit inconsistent with the ordering+ * within a chunk. See Note [Chunked stack representation] for a depiction.+ */+typedef struct Backtrace_ {+    StgWord n_frames;        // Total number of frames in the backtrace+    BacktraceChunk *last;    // The first chunk of frames (corresponding to the+                             // bottom of the stack)+} Backtrace;++/* Various information describing the location of an address */+typedef struct Location_ {+    const char *object_file;+    const char *function;++    // lineno and colno are only valid if source_file /= NULL+    const char *source_file;+    StgWord32 lineno;+    StgWord32 colno;+} __attribute__((packed)) Location;++struct LibdwSession_;+typedef struct LibdwSession_ LibdwSession;++/* Free a backtrace */+void backtraceFree(Backtrace *bt);++/* Request a backtrace of the current stack state.+ * May return NULL if a backtrace can't be acquired. */+Backtrace *libdwGetBacktrace(LibdwSession *session);++/* Lookup Location information for the given address.+ * Returns 0 if successful, 1 if address could not be found. */+int libdwLookupLocation(LibdwSession *session, Location *loc, StgPtr pc);++/* Pretty-print a backtrace to the given FILE */+void libdwPrintBacktrace(LibdwSession *session, FILE *file, Backtrace *bt);
+ includes/rts/LibdwPool.h view
@@ -0,0 +1,19 @@+/* ---------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2015-2016+ *+ * A pool of libdw sessions+ *+ * --------------------------------------------------------------------------*/++#pragma once++/* Claim a session from the pool */+LibdwSession *libdwPoolTake(void);++/* Return a session to the pool */+void libdwPoolRelease(LibdwSession *sess);++/* Free any sessions in the pool forcing a reload of any loaded debug+ * information */+void libdwPoolClear(void);
+ includes/rts/Linker.h view
@@ -0,0 +1,101 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2009+ *+ * RTS Object Linker+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++#if defined(mingw32_HOST_OS)+typedef wchar_t pathchar;+#define PATH_FMT "ls"+#else+typedef char    pathchar;+#define PATH_FMT "s"+#endif++/* Initialize the object linker. Equivalent to initLinker_(1). */+void initLinker (void);++/* Initialize the object linker.+ * The retain_cafs argument is:+ *+ *   non-zero => Retain CAFs unconditionally in linked Haskell code.+ *               Note that this prevents any code from being unloaded.+ *               It should not be necessary unless you are GHCi or+ *               hs-plugins, which needs to be able call any function+ *               in the compiled code.+ *+ *   zero     => Do not retain CAFs.  Everything reachable from foreign+ *               exports will be retained, due to the StablePtrs+ *               created by the module initialisation code.  unloadObj+ *               frees these StablePtrs, which will allow the CAFs to+ *               be GC'd and the code to be removed.+ */+void initLinker_ (int retain_cafs);++/* insert a symbol in the hash table */+HsInt insertSymbol(pathchar* obj_name, char* key, void* data);++/* lookup a symbol in the hash table */+void *lookupSymbol( char *lbl );++/* See Linker.c Note [runtime-linker-phases] */+typedef enum {+    OBJECT_LOADED,+    OBJECT_NEEDED,+    OBJECT_RESOLVED,+    OBJECT_UNLOADED,+    OBJECT_DONT_RESOLVE,+    OBJECT_NOT_LOADED     /* The object was either never loaded or has been+                             fully unloaded */+} OStatus;++/* check object load status */+OStatus getObjectLoadStatus( pathchar *path );++/* delete an object from the pool */+HsInt unloadObj( pathchar *path );++/* purge an object's symbols from the symbol table, but don't unload it */+HsInt purgeObj( pathchar *path );++/* add an obj (populate the global symbol table, but don't resolve yet) */+HsInt loadObj( pathchar *path );++/* add an arch (populate the global symbol table, but don't resolve yet) */+HsInt loadArchive( pathchar *path );++/* resolve all the currently unlinked objects in memory */+HsInt resolveObjs( void );++/* load a dynamic library */+const char *addDLL( pathchar* dll_name );++/* add a path to the library search path */+HsPtr addLibrarySearchPath(pathchar* dll_path);++/* removes a directory from the search path,+   path must have been added using addLibrarySearchPath */+HsBool removeLibrarySearchPath(HsPtr dll_path_index);++/* give a warning about missing Windows patches that would make+   the linker work better */+void warnMissingKBLibraryPaths( void );++/* -----------------------------------------------------------------------------+* Searches the system directories to determine if there is a system DLL that+* satisfies the given name. This prevent GHCi from linking against a static+* library if a DLL is available.+*/+pathchar* findSystemLibrary(pathchar* dll_name);++/* called by the initialization code for a module, not a user API */+StgStablePtr foreignExportStablePtr (StgPtr p);
+ includes/rts/Main.h view
@@ -0,0 +1,18 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2009+ *+ * Entry point for standalone Haskell programs.+ *+ * ---------------------------------------------------------------------------*/++#pragma once++/* -----------------------------------------------------------------------------+ * The entry point for Haskell programs that use a Haskell main function+ * -------------------------------------------------------------------------- */++int hs_main (int argc, char *argv[],     // program args+             StgClosure *main_closure,   // closure for Main.main+             RtsConfig rts_config)       // RTS configuration+   GNUC3_ATTRIBUTE(__noreturn__);
+ includes/rts/Messages.h view
@@ -0,0 +1,104 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * Message API for use inside the RTS.  All messages generated by the+ * RTS should go through one of the functions declared here, and we+ * also provide hooks so that messages from the RTS can be redirected+ * as appropriate.+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++#include <stdarg.h>++#if defined(mingw32_HOST_OS)+/* On Win64, if we say "printf" then gcc thinks we are going to use+   MS format specifiers like %I64d rather than %llu */+#define PRINTF gnu_printf+#else+/* However, on OS X, "gnu_printf" isn't recognised */+#define PRINTF printf+#endif++/* -----------------------------------------------------------------------------+ * Message generation+ * -------------------------------------------------------------------------- */++/*+ * A fatal internal error: this is for errors that probably indicate+ * bugs in the RTS or compiler.  We normally output bug reporting+ * instructions along with the error message.+ *+ * barf() invokes (*fatalInternalErrorFn)().  This function is not+ * expected to return.+ */+void barf(const char *s, ...)+   GNUC3_ATTRIBUTE(__noreturn__)+   GNUC3_ATTRIBUTE(format(PRINTF, 1, 2));++void vbarf(const char *s, va_list ap)+   GNUC3_ATTRIBUTE(__noreturn__);++// declared in Rts.h:+// extern void _assertFail(const char *filename, unsigned int linenum)+//    GNUC3_ATTRIBUTE(__noreturn__);++/*+ * An error condition which is caused by and/or can be corrected by+ * the user.+ *+ * errorBelch() invokes (*errorMsgFn)().+ */+void errorBelch(const char *s, ...)+   GNUC3_ATTRIBUTE(format (PRINTF, 1, 2));++void verrorBelch(const char *s, va_list ap);++/*+ * An error condition which is caused by and/or can be corrected by+ * the user, and which has an associated error condition reported+ * by the system (in errno on Unix, and GetLastError() on Windows).+ * The system error message is appended to the message generated+ * from the supplied format string.+ *+ * sysErrorBelch() invokes (*sysErrorMsgFn)().+ */+void sysErrorBelch(const char *s, ...)+   GNUC3_ATTRIBUTE(format (PRINTF, 1, 2));++void vsysErrorBelch(const char *s, va_list ap);++/*+ * A debugging message.  Debugging messages are generated either as a+ * virtue of having DEBUG turned on, or by being explicitly selected+ * via RTS options (eg. +RTS -Ds).+ *+ * debugBelch() invokes (*debugMsgFn)().+ */+void debugBelch(const char *s, ...)+   GNUC3_ATTRIBUTE(format (PRINTF, 1, 2));++void vdebugBelch(const char *s, va_list ap);+++/* Hooks for redirecting message generation: */++typedef void RtsMsgFunction(const char *, va_list);++extern RtsMsgFunction *fatalInternalErrorFn;+extern RtsMsgFunction *debugMsgFn;+extern RtsMsgFunction *errorMsgFn;++/* Default stdio implementation of the message hooks: */++extern RtsMsgFunction rtsFatalInternalErrorFn;+extern RtsMsgFunction rtsDebugMsgFn;+extern RtsMsgFunction rtsErrorMsgFn;+extern RtsMsgFunction rtsSysErrorMsgFn;
+ includes/rts/OSThreads.h view
@@ -0,0 +1,258 @@+/* ---------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2001-2009+ *+ * Accessing OS threads functionality in a (mostly) OS-independent+ * manner.+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * --------------------------------------------------------------------------*/++#pragma once++#if defined(HAVE_PTHREAD_H) && !defined(mingw32_HOST_OS)++#if defined(CMINUSMINUS)++#define OS_ACQUIRE_LOCK(mutex) foreign "C" pthread_mutex_lock(mutex)+#define OS_RELEASE_LOCK(mutex) foreign "C" pthread_mutex_unlock(mutex)+#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */++#else++#include <pthread.h>+#include <errno.h>++typedef pthread_cond_t  Condition;+typedef pthread_mutex_t Mutex;+typedef pthread_t       OSThreadId;+typedef pthread_key_t   ThreadLocalKey;++#define OSThreadProcAttr /* nothing */++#define INIT_COND_VAR       PTHREAD_COND_INITIALIZER++#if defined(LOCK_DEBUG)+#define LOCK_DEBUG_BELCH(what, mutex) \+  debugBelch("%s(0x%p) %s %d\n", what, mutex, __FILE__, __LINE__)+#else+#define LOCK_DEBUG_BELCH(what, mutex) /* nothing */+#endif++/* Always check the result of lock and unlock. */+#define OS_ACQUIRE_LOCK(mutex) \+  LOCK_DEBUG_BELCH("ACQUIRE_LOCK", mutex); \+  if (pthread_mutex_lock(mutex) == EDEADLK) { \+    barf("multiple ACQUIRE_LOCK: %s %d", __FILE__,__LINE__); \+  }++// Returns zero if the lock was acquired.+EXTERN_INLINE int TRY_ACQUIRE_LOCK(pthread_mutex_t *mutex);+EXTERN_INLINE int TRY_ACQUIRE_LOCK(pthread_mutex_t *mutex)+{+    LOCK_DEBUG_BELCH("TRY_ACQUIRE_LOCK", mutex);+    return pthread_mutex_trylock(mutex);+}++#define OS_RELEASE_LOCK(mutex) \+  LOCK_DEBUG_BELCH("RELEASE_LOCK", mutex); \+  if (pthread_mutex_unlock(mutex) != 0) { \+    barf("RELEASE_LOCK: I do not own this lock: %s %d", __FILE__,__LINE__); \+  }++// Note: this assertion calls pthread_mutex_lock() on a mutex that+// is already held by the calling thread.  The mutex should therefore+// have been created with PTHREAD_MUTEX_ERRORCHECK, otherwise this+// assertion will hang.  We always initialise mutexes with+// PTHREAD_MUTEX_ERRORCHECK when DEBUG is on (see rts/posix/OSThreads.h).+#define OS_ASSERT_LOCK_HELD(mutex) ASSERT(pthread_mutex_lock(mutex) == EDEADLK)++#endif // CMINUSMINUS++# elif defined(HAVE_WINDOWS_H)++#if defined(CMINUSMINUS)++/* We jump through a hoop here to get a CCall EnterCriticalSection+   and LeaveCriticalSection, as that's what C-- wants. */++#define OS_ACQUIRE_LOCK(mutex) foreign "stdcall" EnterCriticalSection(mutex)+#define OS_RELEASE_LOCK(mutex) foreign "stdcall" LeaveCriticalSection(mutex)+#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */++#else++#include <windows.h>++typedef HANDLE Condition;+typedef DWORD OSThreadId;+// don't be tempted to use HANDLE as the OSThreadId: there can be+// many HANDLES to a given thread, so comparison would not work.+typedef DWORD ThreadLocalKey;++#define OSThreadProcAttr __stdcall++#define INIT_COND_VAR  0++// We have a choice for implementing Mutexes on Windows.  Standard+// Mutexes are kernel objects that require kernel calls to+// acquire/release, whereas CriticalSections are spin-locks that block+// in the kernel after spinning for a configurable number of times.+// CriticalSections are *much* faster, so we use those.  The Mutex+// implementation is left here for posterity.+#define USE_CRITICAL_SECTIONS 1++#if USE_CRITICAL_SECTIONS++typedef CRITICAL_SECTION Mutex;++#if defined(LOCK_DEBUG)++#define OS_ACQUIRE_LOCK(mutex) \+  debugBelch("ACQUIRE_LOCK(0x%p) %s %d\n", mutex,__FILE__,__LINE__); \+  EnterCriticalSection(mutex)+#define OS_RELEASE_LOCK(mutex) \+  debugBelch("RELEASE_LOCK(0x%p) %s %d\n", mutex,__FILE__,__LINE__); \+  LeaveCriticalSection(mutex)+#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */++#else++#define OS_ACQUIRE_LOCK(mutex)      EnterCriticalSection(mutex)+#define TRY_ACQUIRE_LOCK(mutex)  (TryEnterCriticalSection(mutex) == 0)+#define OS_RELEASE_LOCK(mutex)      LeaveCriticalSection(mutex)++// I don't know how to do this.  TryEnterCriticalSection() doesn't do+// the right thing.+#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */++#endif++#else++typedef HANDLE Mutex;++// casting to (Mutex *) here required due to use in .cmm files where+// the argument has (void *) type.+#define OS_ACQUIRE_LOCK(mutex)                                     \+    if (WaitForSingleObject(*((Mutex *)mutex),INFINITE) == WAIT_FAILED) { \+        barf("WaitForSingleObject: %d", GetLastError());        \+    }++#define OS_RELEASE_LOCK(mutex)                             \+    if (ReleaseMutex(*((Mutex *)mutex)) == 0) {         \+        barf("ReleaseMutex: %d", GetLastError());       \+    }++#define OS_ASSERT_LOCK_HELD(mutex) /* nothing */+#endif++#endif // CMINUSMINUS++# elif defined(THREADED_RTS)+#  error "Threads not supported"+# endif+++#if !defined(CMINUSMINUS)+//+// General thread operations+//+extern OSThreadId osThreadId      ( void );+extern void shutdownThread        ( void )   GNUC3_ATTRIBUTE(__noreturn__);+extern void yieldThread           ( void );++typedef void* OSThreadProcAttr OSThreadProc(void *);++extern int  createOSThread        ( OSThreadId* tid, char *name,+                                    OSThreadProc *startProc, void *param);+extern bool osThreadIsAlive       ( OSThreadId id );+extern void interruptOSThread     (OSThreadId id);++//+// Condition Variables+//+extern void initCondition         ( Condition* pCond );+extern void closeCondition        ( Condition* pCond );+extern bool broadcastCondition    ( Condition* pCond );+extern bool signalCondition       ( Condition* pCond );+extern bool waitCondition         ( Condition* pCond, Mutex* pMut );++//+// Mutexes+//+extern void initMutex             ( Mutex* pMut );+extern void closeMutex            ( Mutex* pMut );++//+// Thread-local storage+//+void  newThreadLocalKey (ThreadLocalKey *key);+void *getThreadLocalVar (ThreadLocalKey *key);+void  setThreadLocalVar (ThreadLocalKey *key, void *value);+void  freeThreadLocalKey (ThreadLocalKey *key);++// Processors and affinity+void setThreadAffinity (uint32_t n, uint32_t m);+void setThreadNode (uint32_t node);+void releaseThreadNode (void);+#endif // !CMINUSMINUS++#if defined(THREADED_RTS)++#define ACQUIRE_LOCK(l) OS_ACQUIRE_LOCK(l)+#define RELEASE_LOCK(l) OS_RELEASE_LOCK(l)+#define ASSERT_LOCK_HELD(l) OS_ASSERT_LOCK_HELD(l)++#else++#define ACQUIRE_LOCK(l)+#define RELEASE_LOCK(l)+#define ASSERT_LOCK_HELD(l)++#endif /* defined(THREADED_RTS) */++#if !defined(CMINUSMINUS)+//+// Support for forkOS (defined regardless of THREADED_RTS, but does+// nothing when !THREADED_RTS).+//+int forkOS_createThread ( HsStablePtr entry );++//+// Free any global resources created in OSThreads.+//+void freeThreadingResources(void);++//+// Returns the number of processor cores in the machine+//+uint32_t getNumberOfProcessors (void);++//+// Support for getting at the kernel thread Id for tracing/profiling.+//+// This stuff is optional and only used for tracing/profiling purposes, to+// match up thread ids recorded by other tools. For example, on Linux and OSX+// the pthread_t type is not the same as the kernel thread id, and system+// profiling tools like Linux perf, and OSX's DTrace use the kernel thread Id.+// So if we want to match up RTS tasks with kernel threads recorded by these+// tools then we need to know the kernel thread Id, and this must be a separate+// type from the OSThreadId.+//+// If the feature cannot be supported on an OS, it is OK to always return 0.+// In particular it would almost certaily be meaningless on systems not using+// a 1:1 threading model.++// We use a common serialisable representation on all OSs+// This is ok for Windows, OSX and Linux.+typedef StgWord64 KernelThreadId;++// Get the current kernel thread id+KernelThreadId kernelThreadId (void);++#endif /* CMINUSMINUS */
+ includes/rts/Parallel.h view
@@ -0,0 +1,16 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * Parallelism-related functionality+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * -------------------------------------------------------------------------- */++#pragma once++StgInt newSpark (StgRegTable *reg, StgClosure *p);
+ includes/rts/PrimFloat.h view
@@ -0,0 +1,17 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * Primitive floating-point operations+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++StgDouble __int_encodeDouble (I_ j, I_ e);+StgFloat  __int_encodeFloat (I_ j, I_ e);+StgDouble __word_encodeDouble (W_ j, I_ e);+StgFloat  __word_encodeFloat (W_ j, I_ e);
+ includes/rts/Profiling.h view
@@ -0,0 +1,17 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2017-2018+ *+ * Cost-centre profiling API+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * -------------------------------------------------------------------------- */++#pragma once++void registerCcList(CostCentre **cc_list);+void registerCcsList(CostCentreStack **cc_list);
+ includes/rts/Signals.h view
@@ -0,0 +1,23 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * RTS signal handling + *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++/* NB. #included in Haskell code, no prototypes in here. */++/* arguments to stg_sig_install() */+#define STG_SIG_DFL   (-1)+#define STG_SIG_IGN   (-2)+#define STG_SIG_ERR   (-3)+#define STG_SIG_HAN   (-4)+#define STG_SIG_RST   (-5)
+ includes/rts/SpinLock.h view
@@ -0,0 +1,116 @@+/* ----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2006-2009+ *+ * Spin locks+ *+ * These are simple spin-only locks as opposed to Mutexes which+ * probably spin for a while before blocking in the kernel.  We use+ * these when we are sure that all our threads are actively running on+ * a CPU, eg. in the GC.+ *+ * TODO: measure whether we really need these, or whether Mutexes+ * would do (and be a bit safer if a CPU becomes loaded).+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * -------------------------------------------------------------------------- */++#pragma once++#if defined(THREADED_RTS)++#if defined(PROF_SPIN)+typedef struct SpinLock_+{+    StgWord   lock;+    StgWord64 spin;  // incremented every time we spin in ACQUIRE_SPIN_LOCK+    StgWord64 yield; // incremented every time we yield in ACQUIRE_SPIN_LOCK+} SpinLock;+#else+typedef StgWord SpinLock;+#endif++#if defined(PROF_SPIN)++// PROF_SPIN enables counting the number of times we spin on a lock++// acquire spin lock+INLINE_HEADER void ACQUIRE_SPIN_LOCK(SpinLock * p)+{+    StgWord32 r = 0;+    uint32_t i;+    do {+        for (i = 0; i < SPIN_COUNT; i++) {+            r = cas((StgVolatilePtr)&(p->lock), 1, 0);+            if (r != 0) return;+            p->spin++;+            busy_wait_nop();+        }+        p->yield++;+        yieldThread();+    } while (1);+}++// release spin lock+INLINE_HEADER void RELEASE_SPIN_LOCK(SpinLock * p)+{+    write_barrier();+    p->lock = 1;+}++// initialise spin lock+INLINE_HEADER void initSpinLock(SpinLock * p)+{+    write_barrier();+    p->lock = 1;+    p->spin = 0;+    p->yield = 0;+}++#else++// acquire spin lock+INLINE_HEADER void ACQUIRE_SPIN_LOCK(SpinLock * p)+{+    StgWord32 r = 0;+    uint32_t i;+    do {+        for (i = 0; i < SPIN_COUNT; i++) {+            r = cas((StgVolatilePtr)p, 1, 0);+            if (r != 0) return;+            busy_wait_nop();+        }+        yieldThread();+    } while (1);+}++// release spin lock+INLINE_HEADER void RELEASE_SPIN_LOCK(SpinLock * p)+{+    write_barrier();+    (*p) = 1;+}++// init spin lock+INLINE_HEADER void initSpinLock(SpinLock * p)+{+    write_barrier();+    (*p) = 1;+}++#endif /* PROF_SPIN */++#else /* !THREADED_RTS */++// Using macros here means we don't have to ensure the argument is in scope+#define ACQUIRE_SPIN_LOCK(p) /* nothing */+#define RELEASE_SPIN_LOCK(p) /* nothing */++INLINE_HEADER void initSpinLock(void * p STG_UNUSED)+{ /* nothing */ }++#endif /* THREADED_RTS */
+ includes/rts/StableName.h view
@@ -0,0 +1,32 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * Stable Names+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++/* -----------------------------------------------------------------------------+   PRIVATE from here.+   -------------------------------------------------------------------------- */++typedef struct {+    StgPtr  addr;        // Haskell object when entry is in use, next free+                         // entry (NULL when this is the last free entry)+                         // otherwise. May be NULL temporarily during GC (when+                         // pointee dies).++    StgPtr  old;         // Old Haskell object, used during GC++    StgClosure *sn_obj;  // The StableName object, or NULL when the entry is+                         // free+} snEntry;++extern DLL_IMPORT_RTS snEntry *stable_name_table;
+ includes/rts/StablePtr.h view
@@ -0,0 +1,35 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * Stable Pointers+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++EXTERN_INLINE StgPtr deRefStablePtr (StgStablePtr stable_ptr);+StgStablePtr getStablePtr  (StgPtr p);++/* -----------------------------------------------------------------------------+   PRIVATE from here.+   -------------------------------------------------------------------------- */++typedef struct {+    StgPtr addr;         // Haskell object when entry is in use, next free+                         // entry (NULL when this is the last free entry)+                         // otherwise.+} spEntry;++extern DLL_IMPORT_RTS spEntry *stable_ptr_table;++EXTERN_INLINE+StgPtr deRefStablePtr(StgStablePtr sp)+{+    return stable_ptr_table[(StgWord)sp].addr;+}
+ includes/rts/StaticPtrTable.h view
@@ -0,0 +1,44 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2008-2009+ *+ * Initialization of the Static Pointer Table+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * -------------------------------------------------------------------------- */++#pragma once++/** Inserts an entry in the Static Pointer Table.+ *+ * The key is a fingerprint computed from the static pointer and the spe_closure+ * is a pointer to the closure defining the table entry.+ *+ * A stable pointer to the closure is made to prevent it from being garbage+ * collected while the entry exists on the table.+ *+ * This function is called from the code generated by+ * compiler/deSugar/StaticPtrTable.sptInitCode+ *+ * */+void hs_spt_insert (StgWord64 key[2],void* spe_closure);++/** Inserts an entry for a StgTablePtr in the Static Pointer Table.+ *+ * This function is called from the GHCi interpreter to insert+ * SPT entries for bytecode objects.+ *+ * */+void hs_spt_insert_stableptr(StgWord64 key[2], StgStablePtr *entry);++/** Removes an entry from the Static Pointer Table.+ *+ * This function is called from the code generated by+ * compiler/deSugar/StaticPtrTable.sptInitCode+ *+ * */+void hs_spt_remove (StgWord64 key[2]);
+ includes/rts/TTY.h view
@@ -0,0 +1,17 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2009+ *+ * POSIX TTY-related functionality+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * -------------------------------------------------------------------------- */++#pragma once++void* __hscore_get_saved_termios(int fd);+void  __hscore_set_saved_termios(int fd, void* ts);
+ includes/rts/Threads.h view
@@ -0,0 +1,74 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team 1998-2009+ *+ * External API for the scheduler.  For most uses, the functions in+ * RtsAPI.h should be enough.+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++#if defined(HAVE_SYS_TYPES_H)+#include <sys/types.h>+#endif++//+// Creating threads+//+StgTSO *createThread (Capability *cap, W_ stack_size);++void scheduleWaitThread (/* in    */ StgTSO *tso,+                         /* out   */ HaskellObj* ret,+                         /* inout */ Capability **cap);++StgTSO *createGenThread       (Capability *cap, W_ stack_size,+                               StgClosure *closure);+StgTSO *createIOThread        (Capability *cap, W_ stack_size,+                               StgClosure *closure);+StgTSO *createStrictIOThread  (Capability *cap, W_ stack_size,+                               StgClosure *closure);++// Suspending/resuming threads around foreign calls+void *        suspendThread (StgRegTable *, bool interruptible);+StgRegTable * resumeThread  (void *);++//+// Thread operations from Threads.c+//+int     cmp_thread                       (StgPtr tso1, StgPtr tso2);+int     rts_getThreadId                  (StgPtr tso);+void    rts_enableThreadAllocationLimit  (StgPtr tso);+void    rts_disableThreadAllocationLimit (StgPtr tso);++#if !defined(mingw32_HOST_OS)+pid_t  forkProcess     (HsStablePtr *entry);+#else+pid_t  forkProcess     (HsStablePtr *entry)+    GNU_ATTRIBUTE(__noreturn__);+#endif++HsBool rtsSupportsBoundThreads (void);++// The number of Capabilities.+// ToDo: I would like this to be private to the RTS and instead expose a+// function getNumCapabilities(), but it is used in compiler/cbits/genSym.c+extern unsigned int n_capabilities;++// The number of Capabilities that are not disabled+extern uint32_t enabled_capabilities;++#if !IN_STG_CODE+extern Capability MainCapability;+#endif++//+// Change the number of capabilities (only supports increasing the+// current value at the moment).+//+extern void setNumCapabilities (uint32_t new_);
+ includes/rts/Ticky.h view
@@ -0,0 +1,32 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * TICKY_TICKY types+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++/* -----------------------------------------------------------------------------+   The StgEntCounter type - needed regardless of TICKY_TICKY+   -------------------------------------------------------------------------- */++typedef struct _StgEntCounter {+  /* Using StgWord for everything, because both the C and asm code+     generators make trouble if you try to pack things tighter */+    StgWord     registeredp;    /* 0 == no, 1 == yes */+    StgInt      arity;          /* arity (static info) */+    StgInt      allocd;         /* # allocation of this closure */+                                /* (rest of args are in registers) */+    char        *str;           /* name of the thing */+    char        *arg_kinds;     /* info about the args types */+    StgInt      entry_count;    /* Trips to fast entry code */+    StgInt      allocs;         /* number of allocations by this fun */+    struct _StgEntCounter *link;/* link to chain them all together */+} StgEntCounter;
+ includes/rts/Time.h view
@@ -0,0 +1,44 @@+/* ----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2004+ *+ * Time values in the RTS+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * --------------------------------------------------------------------------*/++#pragma once++// For most time values in the RTS we use a fixed resolution of nanoseconds,+// normalising the time we get from platform-dependent APIs to this+// resolution.+#define TIME_RESOLUTION 1000000000+typedef int64_t Time;++#define TIME_MAX HS_INT64_MAX++#if TIME_RESOLUTION == 1000000000+// I'm being lazy, but it's awkward to define fully general versions of these+#define TimeToMS(t)      ((t) / 1000000)+#define TimeToUS(t)      ((t) / 1000)+#define TimeToNS(t)      (t)+#define MSToTime(t)      ((Time)(t) * 1000000)+#define USToTime(t)      ((Time)(t) * 1000)+#define NSToTime(t)      ((Time)(t))+#else+#error Fix TimeToNS(), TimeToUS() etc.+#endif++#define SecondsToTime(t) ((Time)(t) * TIME_RESOLUTION)+#define TimeToSeconds(t) ((t) / TIME_RESOLUTION)++// Use instead of SecondsToTime() when we have a floating-point+// seconds value, to avoid truncating it.+INLINE_HEADER Time fsecondsToTime (double t)+{+    return (Time)(t * TIME_RESOLUTION);+}++Time getProcessElapsedTime (void);
+ includes/rts/Timer.h view
@@ -0,0 +1,18 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1995-2009+ *+ * Interface to the RTS timer signal (uses OS-dependent Ticker.h underneath)+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++void startTimer (void);+void stopTimer  (void);+int rtsTimerSignal (void);
+ includes/rts/Types.h view
@@ -0,0 +1,31 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * RTS-specific types.+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++#include <stddef.h>+#include <stdbool.h>++// Deprecated, use uint32_t instead.+typedef unsigned int nat __attribute__((deprecated));  /* uint32_t */++/* ullong (64|128-bit) type: only include if needed (not ANSI) */+#if defined(__GNUC__)+#define LL(x) (x##LL)+#else+#define LL(x) (x##L)+#endif++typedef struct StgClosure_   StgClosure;+typedef struct StgInfoTable_ StgInfoTable;+typedef struct StgTSO_       StgTSO;
+ includes/rts/Utils.h view
@@ -0,0 +1,16 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * RTS external APIs.  This file declares everything that the GHC RTS+ * exposes externally.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++/* Alternate to raise(3) for threaded rts, for BSD-based OSes */+int genericRaise(int sig);
+ includes/rts/prof/CCS.h view
@@ -0,0 +1,226 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2009-2012+ *+ * Macros for profiling operations in STG code+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++/* -----------------------------------------------------------------------------+ * Data Structures+ * ---------------------------------------------------------------------------*/+/*+ * Note [struct alignment]+ * NB. be careful to avoid unwanted padding between fields, by+ * putting the 8-byte fields on an 8-byte boundary.  Padding can+ * vary between C compilers, and we don't take into account any+ * possible padding when generating CCS and CC decls in the code+ * generator (compiler/codeGen/StgCmmProf.hs).+ */++typedef struct CostCentre_ {+    StgInt ccID;              // Unique Id, allocated by the RTS++    char * label;+    char * module;+    char * srcloc;++    // used for accumulating costs at the end of the run...+    StgWord64 mem_alloc;      // align 8 (Note [struct alignment])+    StgWord   time_ticks;++    StgBool is_caf;           // true <=> CAF cost centre++    struct CostCentre_ *link;+} CostCentre;++typedef struct CostCentreStack_ {+    StgInt ccsID;               // unique ID, allocated by the RTS++    CostCentre *cc;             // Cost centre at the top of the stack++    struct CostCentreStack_ *prevStack;   // parent+    struct IndexTable_      *indexTable;  // children+    struct CostCentreStack_ *root;        // root of stack+    StgWord    depth;           // number of items in the stack++    StgWord64  scc_count;       // Count of times this CCS is entered+                                // align 8 (Note [struct alignment])++    StgWord    selected;        // is this CCS shown in the heap+                                // profile? (zero if excluded via -hc+                                // -hm etc.)++    StgWord    time_ticks;      // number of time ticks accumulated by+                                // this CCS++    StgWord64  mem_alloc;       // mem allocated by this CCS+                                // align 8 (Note [struct alignment])++    StgWord64  inherited_alloc; // sum of mem_alloc over all children+                                // (calculated at the end)+                                // align 8 (Note [struct alignment])++    StgWord    inherited_ticks; // sum of time_ticks over all children+                                // (calculated at the end)+} CostCentreStack;+++/* -----------------------------------------------------------------------------+ * Start and stop the profiling timer.  These can be called from+ * Haskell to restrict the profile to portion(s) of the execution.+ * See the module GHC.Profiling.+ * ---------------------------------------------------------------------------*/++void stopProfTimer      ( void );+void startProfTimer     ( void );++/* -----------------------------------------------------------------------------+ * The rest is PROFILING only...+ * ---------------------------------------------------------------------------*/++#if defined(PROFILING)++/* -----------------------------------------------------------------------------+ * Constants+ * ---------------------------------------------------------------------------*/++#define EMPTY_STACK NULL+#define EMPTY_TABLE NULL++/* Constants used to set is_caf flag on CostCentres */+#define CC_IS_CAF      true+#define CC_NOT_CAF     false+/* -----------------------------------------------------------------------------+ * Data Structures+ * ---------------------------------------------------------------------------*/++// IndexTable is the list of children of a CCS. (Alternatively it is a+// cache of the results of pushing onto a CCS, so that the second and+// subsequent times we push a certain CC on a CCS we get the same+// result).++typedef struct IndexTable_ {+    // Just a linked list of (cc, ccs) pairs, where the `ccs` is the result of+    // pushing `cc` to the owner of the index table (another CostCentreStack).+    CostCentre *cc;+    CostCentreStack *ccs;+    struct IndexTable_ *next;+    // back_edge is true when `cc` is already in the stack, so pushing it+    // truncates or drops (see RECURSION_DROPS and RECURSION_TRUNCATES in+    // Profiling.c).+    bool back_edge;+} IndexTable;+++/* -----------------------------------------------------------------------------+   Pre-defined cost centres and cost centre stacks+   -------------------------------------------------------------------------- */++#if IN_STG_CODE++extern StgWord CC_MAIN[];+extern StgWord CCS_MAIN[];      // Top CCS++extern StgWord CC_SYSTEM[];+extern StgWord CCS_SYSTEM[];    // RTS costs++extern StgWord CC_GC[];+extern StgWord CCS_GC[];         // Garbage collector costs++extern StgWord CC_OVERHEAD[];+extern StgWord CCS_OVERHEAD[];   // Profiling overhead++extern StgWord CC_DONT_CARE[];+extern StgWord CCS_DONT_CARE[];  // CCS attached to static constructors++#else++extern CostCentre      CC_MAIN[];+extern CostCentreStack CCS_MAIN[];      // Top CCS++extern CostCentre      CC_SYSTEM[];+extern CostCentreStack CCS_SYSTEM[];    // RTS costs++extern CostCentre      CC_GC[];+extern CostCentreStack CCS_GC[];         // Garbage collector costs++extern CostCentre      CC_OVERHEAD[];+extern CostCentreStack CCS_OVERHEAD[];   // Profiling overhead++extern CostCentre      CC_DONT_CARE[];+extern CostCentreStack CCS_DONT_CARE[];  // shouldn't ever get set++extern CostCentre      CC_PINNED[];+extern CostCentreStack CCS_PINNED[];     // pinned memory++extern CostCentre      CC_IDLE[];+extern CostCentreStack CCS_IDLE[];       // capability is idle++#endif /* IN_STG_CODE */++extern unsigned int RTS_VAR(era);++/* -----------------------------------------------------------------------------+ * Functions+ * ---------------------------------------------------------------------------*/++CostCentreStack * pushCostCentre (CostCentreStack *, CostCentre *);+void              enterFunCCS    (StgRegTable *reg, CostCentreStack *);+CostCentre *mkCostCentre (char *label, char *module, char *srcloc);++extern CostCentre * RTS_VAR(CC_LIST);               // registered CC list++/* -----------------------------------------------------------------------------+ * Declaring Cost Centres & Cost Centre Stacks.+ * -------------------------------------------------------------------------- */++# define CC_DECLARE(cc_ident,name,mod,loc,caf,is_local)  \+     is_local CostCentre cc_ident[1]                     \+       = {{ .ccID       = 0,                             \+            .label      = name,                          \+            .module     = mod,                           \+            .srcloc     = loc,                           \+            .time_ticks = 0,                             \+            .mem_alloc  = 0,                             \+            .link       = 0,                             \+            .is_caf     = caf                            \+         }};++# define CCS_DECLARE(ccs_ident,cc_ident,is_local)        \+     is_local CostCentreStack ccs_ident[1]               \+       = {{ .ccsID               = 0,                    \+            .cc                  = cc_ident,             \+            .prevStack           = NULL,                 \+            .indexTable          = NULL,                 \+            .root                = NULL,                 \+            .depth               = 0,                    \+            .selected            = 0,                    \+            .scc_count           = 0,                    \+            .time_ticks          = 0,                    \+            .mem_alloc           = 0,                    \+            .inherited_ticks     = 0,                    \+            .inherited_alloc     = 0                     \+       }};++/* -----------------------------------------------------------------------------+ * Time / Allocation Macros+ * ---------------------------------------------------------------------------*/++/* eliminate profiling overhead from allocation costs */+#define CCS_ALLOC(ccs, size) (ccs)->mem_alloc += ((size)-sizeofW(StgProfHeader))+#define ENTER_CCS_THUNK(cap,p) cap->r.rCCCS = p->header.prof.ccs++#else /* !PROFILING */++#define CCS_ALLOC(ccs, amount) doNothing()+#define ENTER_CCS_THUNK(cap,p) doNothing()++#endif /* PROFILING */
+ includes/rts/prof/LDV.h view
@@ -0,0 +1,44 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The University of Glasgow, 2009+ *+ * Lag/Drag/Void profiling.+ *+ * Do not #include this file directly: #include "Rts.h" instead.+ *+ * To understand the structure of the RTS headers, see the wiki:+ *   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/source-tree/includes+ *+ * ---------------------------------------------------------------------------*/++#pragma once++#if defined(PROFILING)++/* retrieves the LDV word from closure c */+#define LDVW(c)                 (((StgClosure *)(c))->header.prof.hp.ldvw)++/*+ * Stores the creation time for closure c.+ * This macro is called at the very moment of closure creation.+ *+ * NOTE: this initializes LDVW(c) to zero, which ensures that there+ * is no conflict between retainer profiling and LDV profiling,+ * because retainer profiling also expects LDVW(c) to be initialised+ * to zero.+ */++#if defined(CMINUSMINUS)++#else++#define LDV_RECORD_CREATE(c)   \+  LDVW((c)) = ((StgWord)RTS_DEREF(era) << LDV_SHIFT) | LDV_STATE_CREATE++#endif++#else  /* !PROFILING */++#define LDV_RECORD_CREATE(c)   /* nothing */++#endif /* PROFILING */
+ includes/rts/storage/Block.h view
@@ -0,0 +1,341 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-1999+ *+ * Block structure for the storage manager+ *+ * ---------------------------------------------------------------------------*/++#pragma once++#include "ghcconfig.h"++/* The actual block and megablock-size constants are defined in+ * includes/Constants.h, all constants here are derived from these.+ */++/* Block related constants (BLOCK_SHIFT is defined in Constants.h) */++#if SIZEOF_LONG == SIZEOF_VOID_P+#define UNIT 1UL+#elif SIZEOF_LONG_LONG == SIZEOF_VOID_P+#define UNIT 1ULL+#else+#error "Size of pointer is suspicious."+#endif++#if defined(CMINUSMINUS)+#define BLOCK_SIZE   (1<<BLOCK_SHIFT)+#else+#define BLOCK_SIZE   (UNIT<<BLOCK_SHIFT)+// Note [integer overflow]+#endif++#define BLOCK_SIZE_W (BLOCK_SIZE/sizeof(W_))+#define BLOCK_MASK   (BLOCK_SIZE-1)++#define BLOCK_ROUND_UP(p)   (((W_)(p)+BLOCK_SIZE-1) & ~BLOCK_MASK)+#define BLOCK_ROUND_DOWN(p) ((void *) ((W_)(p) & ~BLOCK_MASK))++/* Megablock related constants (MBLOCK_SHIFT is defined in Constants.h) */++#if defined(CMINUSMINUS)+#define MBLOCK_SIZE    (1<<MBLOCK_SHIFT)+#else+#define MBLOCK_SIZE    (UNIT<<MBLOCK_SHIFT)+// Note [integer overflow]+#endif++#define MBLOCK_SIZE_W  (MBLOCK_SIZE/sizeof(W_))+#define MBLOCK_MASK    (MBLOCK_SIZE-1)++#define MBLOCK_ROUND_UP(p)   ((void *)(((W_)(p)+MBLOCK_SIZE-1) & ~MBLOCK_MASK))+#define MBLOCK_ROUND_DOWN(p) ((void *)((W_)(p) & ~MBLOCK_MASK ))++/* The largest size an object can be before we give it a block of its+ * own and treat it as an immovable object during GC, expressed as a+ * fraction of BLOCK_SIZE.+ */+#define LARGE_OBJECT_THRESHOLD ((uint32_t)(BLOCK_SIZE * 8 / 10))++/*+ * Note [integer overflow]+ *+ * The UL suffix in BLOCK_SIZE and MBLOCK_SIZE promotes the expression+ * to an unsigned long, which means that expressions involving these+ * will be promoted to unsigned long, which makes integer overflow+ * less likely.  Historically, integer overflow in expressions like+ *    (n * BLOCK_SIZE)+ * where n is int or unsigned int, have caused obscure segfaults in+ * programs that use large amounts of memory (e.g. #7762, #5086).+ */++/* -----------------------------------------------------------------------------+ * Block descriptor.  This structure *must* be the right length, so we+ * can do pointer arithmetic on pointers to it.+ */++/* The block descriptor is 64 bytes on a 64-bit machine, and 32-bytes+ * on a 32-bit machine.+ */++// Note: fields marked with [READ ONLY] must not be modified by the+// client of the block allocator API.  All other fields can be+// freely modified.++#if !defined(CMINUSMINUS)+typedef struct bdescr_ {++    StgPtr start;              // [READ ONLY] start addr of memory++    StgPtr free;               // First free byte of memory.+                               // allocGroup() sets this to the value of start.+                               // NB. during use this value should lie+                               // between start and start + blocks *+                               // BLOCK_SIZE.  Values outside this+                               // range are reserved for use by the+                               // block allocator.  In particular, the+                               // value (StgPtr)(-1) is used to+                               // indicate that a block is unallocated.++    struct bdescr_ *link;      // used for chaining blocks together++    union {+        struct bdescr_ *back;  // used (occasionally) for doubly-linked lists+        StgWord *bitmap;       // bitmap for marking GC+        StgPtr  scan;          // scan pointer for copying GC+    } u;++    struct generation_ *gen;   // generation++    StgWord16 gen_no;          // gen->no, cached+    StgWord16 dest_no;         // number of destination generation+    StgWord16 node;            // which memory node does this block live on?++    StgWord16 flags;           // block flags, see below++    StgWord32 blocks;          // [READ ONLY] no. of blocks in a group+                               // (if group head, 0 otherwise)++#if SIZEOF_VOID_P == 8+    StgWord32 _padding[3];+#else+    StgWord32 _padding[0];+#endif+} bdescr;+#endif++#if SIZEOF_VOID_P == 8+#define BDESCR_SIZE  0x40+#define BDESCR_MASK  0x3f+#define BDESCR_SHIFT 6+#else+#define BDESCR_SIZE  0x20+#define BDESCR_MASK  0x1f+#define BDESCR_SHIFT 5+#endif++/* Block contains objects evacuated during this GC */+#define BF_EVACUATED 1+/* Block is a large object */+#define BF_LARGE     2+/* Block is pinned */+#define BF_PINNED    4+/* Block is to be marked, not copied */+#define BF_MARKED    8+/* Block is executable */+#define BF_EXEC      32+/* Block contains only a small amount of live data */+#define BF_FRAGMENTED 64+/* we know about this block (for finding leaks) */+#define BF_KNOWN     128+/* Block was swept in the last generation */+#define BF_SWEPT     256+/* Block is part of a Compact */+#define BF_COMPACT   512+/* Maximum flag value (do not define anything higher than this!) */+#define BF_FLAG_MAX  (1 << 15)++/* Finding the block descriptor for a given block -------------------------- */++#if defined(CMINUSMINUS)++#define Bdescr(p) \+    ((((p) &  MBLOCK_MASK & ~BLOCK_MASK) >> (BLOCK_SHIFT-BDESCR_SHIFT)) \+     | ((p) & ~MBLOCK_MASK))++#else++EXTERN_INLINE bdescr *Bdescr(StgPtr p);+EXTERN_INLINE bdescr *Bdescr(StgPtr p)+{+  return (bdescr *)+    ((((W_)p &  MBLOCK_MASK & ~BLOCK_MASK) >> (BLOCK_SHIFT-BDESCR_SHIFT))+     | ((W_)p & ~MBLOCK_MASK)+     );+}++#endif++/* Useful Macros ------------------------------------------------------------ */++/* Offset of first real data block in a megablock */++#define FIRST_BLOCK_OFF \+   ((W_)BLOCK_ROUND_UP(BDESCR_SIZE * (MBLOCK_SIZE / BLOCK_SIZE)))++/* First data block in a given megablock */++#define FIRST_BLOCK(m) ((void *)(FIRST_BLOCK_OFF + (W_)(m)))++/* Last data block in a given megablock */++#define LAST_BLOCK(m)  ((void *)(MBLOCK_SIZE-BLOCK_SIZE + (W_)(m)))++/* First real block descriptor in a megablock */++#define FIRST_BDESCR(m) \+   ((bdescr *)((FIRST_BLOCK_OFF>>(BLOCK_SHIFT-BDESCR_SHIFT)) + (W_)(m)))++/* Last real block descriptor in a megablock */++#define LAST_BDESCR(m) \+  ((bdescr *)(((MBLOCK_SIZE-BLOCK_SIZE)>>(BLOCK_SHIFT-BDESCR_SHIFT)) + (W_)(m)))++/* Number of usable blocks in a megablock */++#if !defined(CMINUSMINUS) // already defined in DerivedConstants.h+#define BLOCKS_PER_MBLOCK ((MBLOCK_SIZE - FIRST_BLOCK_OFF) / BLOCK_SIZE)+#endif++/* How many blocks in this megablock group */++#define MBLOCK_GROUP_BLOCKS(n) \+   (BLOCKS_PER_MBLOCK + (n-1) * (MBLOCK_SIZE / BLOCK_SIZE))++/* Compute the required size of a megablock group */++#define BLOCKS_TO_MBLOCKS(n) \+   (1 + (W_)MBLOCK_ROUND_UP((n-BLOCKS_PER_MBLOCK) * BLOCK_SIZE) / MBLOCK_SIZE)+++#if !defined(CMINUSMINUS)+/* to the end... */++/* Double-linked block lists: --------------------------------------------- */++INLINE_HEADER void+dbl_link_onto(bdescr *bd, bdescr **list)+{+  bd->link = *list;+  bd->u.back = NULL;+  if (*list) {+    (*list)->u.back = bd; /* double-link the list */+  }+  *list = bd;+}++INLINE_HEADER void+dbl_link_remove(bdescr *bd, bdescr **list)+{+    if (bd->u.back) {+        bd->u.back->link = bd->link;+    } else {+        *list = bd->link;+    }+    if (bd->link) {+        bd->link->u.back = bd->u.back;+    }+}++INLINE_HEADER void+dbl_link_insert_after(bdescr *bd, bdescr *after)+{+    bd->link = after->link;+    bd->u.back = after;+    if (after->link) {+        after->link->u.back = bd;+    }+    after->link = bd;+}++INLINE_HEADER void+dbl_link_replace(bdescr *new_, bdescr *old, bdescr **list)+{+    new_->link = old->link;+    new_->u.back = old->u.back;+    if (old->link) {+        old->link->u.back = new_;+    }+    if (old->u.back) {+        old->u.back->link = new_;+    } else {+        *list = new_;+    }+}++/* Initialisation ---------------------------------------------------------- */++extern void initBlockAllocator(void);++/* Allocation -------------------------------------------------------------- */++bdescr *allocGroup(W_ n);++EXTERN_INLINE bdescr* allocBlock(void);+EXTERN_INLINE bdescr* allocBlock(void)+{+    return allocGroup(1);+}++bdescr *allocGroupOnNode(uint32_t node, W_ n);++EXTERN_INLINE bdescr* allocBlockOnNode(uint32_t node);+EXTERN_INLINE bdescr* allocBlockOnNode(uint32_t node)+{+    return allocGroupOnNode(node,1);+}++// versions that take the storage manager lock for you:+bdescr *allocGroup_lock(W_ n);+bdescr *allocBlock_lock(void);++bdescr *allocGroupOnNode_lock(uint32_t node, W_ n);+bdescr *allocBlockOnNode_lock(uint32_t node);++/* De-Allocation ----------------------------------------------------------- */++void freeGroup(bdescr *p);+void freeChain(bdescr *p);++// versions that take the storage manager lock for you:+void freeGroup_lock(bdescr *p);+void freeChain_lock(bdescr *p);++bdescr * splitBlockGroup (bdescr *bd, uint32_t blocks);++/* Round a value to megablocks --------------------------------------------- */++// We want to allocate an object around a given size, round it up or+// down to the nearest size that will fit in an mblock group.+INLINE_HEADER StgWord+round_to_mblocks(StgWord words)+{+    if (words > BLOCKS_PER_MBLOCK * BLOCK_SIZE_W) {+        // first, ignore the gap at the beginning of the first mblock by+        // adding it to the total words.  Then we can pretend we're+        // dealing in a uniform unit of megablocks.+        words += FIRST_BLOCK_OFF/sizeof(W_);++        if ((words % MBLOCK_SIZE_W) < (MBLOCK_SIZE_W / 2)) {+            words = (words / MBLOCK_SIZE_W) * MBLOCK_SIZE_W;+        } else {+            words = ((words / MBLOCK_SIZE_W) + 1) * MBLOCK_SIZE_W;+        }++        words -= FIRST_BLOCK_OFF/sizeof(W_);+    }+    return words;+}++#endif /* !CMINUSMINUS */
+ includes/rts/storage/ClosureMacros.h view
@@ -0,0 +1,587 @@+/* ----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2012+ *+ * Macros for building and manipulating closures+ *+ * -------------------------------------------------------------------------- */++#pragma once++/* -----------------------------------------------------------------------------+   Info tables are slammed up against the entry code, and the label+   for the info table is at the *end* of the table itself.  This+   inline function adjusts an info pointer to point to the beginning+   of the table, so we can use standard C structure indexing on it.++   Note: this works for SRT info tables as long as you don't want to+   access the SRT, since they are laid out the same with the SRT+   pointer as the first word in the table.++   NOTES ABOUT MANGLED C VS. MINI-INTERPRETER:++   A couple of definitions:++       "info pointer"    The first word of the closure.  Might point+                         to either the end or the beginning of the+                         info table, depending on whether we're using+                         the mini interpreter or not.  GET_INFO(c)+                         retrieves the info pointer of a closure.++       "info table"      The info table structure associated with a+                         closure.  This is always a pointer to the+                         beginning of the structure, so we can+                         use standard C structure indexing to pull out+                         the fields.  get_itbl(c) returns a pointer to+                         the info table for closure c.++   An address of the form xxxx_info points to the end of the info+   table or the beginning of the info table depending on whether we're+   mangling or not respectively.  So,++         c->header.info = xxx_info++   makes absolute sense, whether mangling or not.++   -------------------------------------------------------------------------- */++INLINE_HEADER void SET_INFO(StgClosure *c, const StgInfoTable *info) {+    c->header.info = info;+}+INLINE_HEADER const StgInfoTable *GET_INFO(StgClosure *c) {+    return c->header.info;+}++#define GET_ENTRY(c)  (ENTRY_CODE(GET_INFO(c)))++#if defined(TABLES_NEXT_TO_CODE)+EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info);+EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgInfoTable *)info - 1;}+EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info);+EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgRetInfoTable *)info - 1;}+INLINE_HEADER StgFunInfoTable *FUN_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgFunInfoTable *)info - 1;}+INLINE_HEADER StgThunkInfoTable *THUNK_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgThunkInfoTable *)info - 1;}+INLINE_HEADER StgConInfoTable *CON_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgConInfoTable *)info - 1;}+INLINE_HEADER StgFunInfoTable *itbl_to_fun_itbl(const StgInfoTable *i) {return (StgFunInfoTable *)(i + 1) - 1;}+INLINE_HEADER StgRetInfoTable *itbl_to_ret_itbl(const StgInfoTable *i) {return (StgRetInfoTable *)(i + 1) - 1;}+INLINE_HEADER StgThunkInfoTable *itbl_to_thunk_itbl(const StgInfoTable *i) {return (StgThunkInfoTable *)(i + 1) - 1;}+INLINE_HEADER StgConInfoTable *itbl_to_con_itbl(const StgInfoTable *i) {return (StgConInfoTable *)(i + 1) - 1;}+#else+EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info);+EXTERN_INLINE StgInfoTable *INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgInfoTable *)info;}+EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info);+EXTERN_INLINE StgRetInfoTable *RET_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgRetInfoTable *)info;}+INLINE_HEADER StgFunInfoTable *FUN_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgFunInfoTable *)info;}+INLINE_HEADER StgThunkInfoTable *THUNK_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgThunkInfoTable *)info;}+INLINE_HEADER StgConInfoTable *CON_INFO_PTR_TO_STRUCT(const StgInfoTable *info) {return (StgConInfoTable *)info;}+INLINE_HEADER StgFunInfoTable *itbl_to_fun_itbl(const StgInfoTable *i) {return (StgFunInfoTable *)i;}+INLINE_HEADER StgRetInfoTable *itbl_to_ret_itbl(const StgInfoTable *i) {return (StgRetInfoTable *)i;}+INLINE_HEADER StgThunkInfoTable *itbl_to_thunk_itbl(const StgInfoTable *i) {return (StgThunkInfoTable *)i;}+INLINE_HEADER StgConInfoTable *itbl_to_con_itbl(const StgInfoTable *i) {return (StgConInfoTable *)i;}+#endif++EXTERN_INLINE const StgInfoTable *get_itbl(const StgClosure *c);+EXTERN_INLINE const StgInfoTable *get_itbl(const StgClosure *c)+{+   return INFO_PTR_TO_STRUCT(c->header.info);+}++EXTERN_INLINE const StgRetInfoTable *get_ret_itbl(const StgClosure *c);+EXTERN_INLINE const StgRetInfoTable *get_ret_itbl(const StgClosure *c)+{+   return RET_INFO_PTR_TO_STRUCT(c->header.info);+}++INLINE_HEADER const StgFunInfoTable *get_fun_itbl(const StgClosure *c)+{+   return FUN_INFO_PTR_TO_STRUCT(c->header.info);+}++INLINE_HEADER const StgThunkInfoTable *get_thunk_itbl(const StgClosure *c)+{+   return THUNK_INFO_PTR_TO_STRUCT(c->header.info);+}++INLINE_HEADER const StgConInfoTable *get_con_itbl(const StgClosure *c)+{+   return CON_INFO_PTR_TO_STRUCT((c)->header.info);+}++INLINE_HEADER StgHalfWord GET_TAG(const StgClosure *con)+{+    return get_itbl(con)->srt;+}++/* -----------------------------------------------------------------------------+   Macros for building closures+   -------------------------------------------------------------------------- */++#if defined(PROFILING)+#if defined(DEBUG_RETAINER)+/*+  For the sake of debugging, we take the safest way for the moment. Actually, this+  is useful to check the sanity of heap before beginning retainer profiling.+  flip is defined in RetainerProfile.c, and declared as extern in RetainerProfile.h.+  Note: change those functions building Haskell objects from C datatypes, i.e.,+  all rts_mk???() functions in RtsAPI.c, as well.+ */+#define SET_PROF_HDR(c,ccs_)            \+        ((c)->header.prof.ccs = ccs_, (c)->header.prof.hp.rs = (retainerSet *)((StgWord)NULL | flip))+#else+/*+  For retainer profiling only: we do not have to set (c)->header.prof.hp.rs to+  NULL | flip (flip is defined in RetainerProfile.c) because even when flip+  is 1, rs is invalid and will be initialized to NULL | flip later when+  the closure *c is visited.+ */+/*+#define SET_PROF_HDR(c,ccs_)            \+        ((c)->header.prof.ccs = ccs_, (c)->header.prof.hp.rs = NULL)+ */+/*+  The following macro works for both retainer profiling and LDV profiling:+  for retainer profiling, ldvTime remains 0, so rs fields are initialized to 0.+  See the invariants on ldvTime.+ */+#define SET_PROF_HDR(c,ccs_)            \+        ((c)->header.prof.ccs = ccs_,   \+        LDV_RECORD_CREATE((c)))+#endif /* DEBUG_RETAINER */+#else+#define SET_PROF_HDR(c,ccs)+#endif++#define SET_HDR(c,_info,ccs)                            \+   {                                                    \+        (c)->header.info = _info;                       \+        SET_PROF_HDR((StgClosure *)(c),ccs);            \+   }++#define SET_ARR_HDR(c,info,costCentreStack,n_bytes)     \+   SET_HDR(c,info,costCentreStack);                     \+   (c)->bytes = n_bytes;++// Use when changing a closure from one kind to another+#define OVERWRITE_INFO(c, new_info)                             \+    OVERWRITING_CLOSURE((StgClosure *)(c));                     \+    SET_INFO((StgClosure *)(c), (new_info));                    \+    LDV_RECORD_CREATE(c);++/* -----------------------------------------------------------------------------+   How to get hold of the static link field for a static closure.+   -------------------------------------------------------------------------- */++/* These are hard-coded. */+#define THUNK_STATIC_LINK(p) (&(p)->payload[1])+#define IND_STATIC_LINK(p)   (&(p)->payload[1])++INLINE_HEADER StgClosure **+STATIC_LINK(const StgInfoTable *info, StgClosure *p)+{+    switch (info->type) {+    case THUNK_STATIC:+        return THUNK_STATIC_LINK(p);+    case IND_STATIC:+        return IND_STATIC_LINK(p);+    default:+        return &p->payload[info->layout.payload.ptrs ++                           info->layout.payload.nptrs];+    }+}++/* -----------------------------------------------------------------------------+   INTLIKE and CHARLIKE closures.+   -------------------------------------------------------------------------- */++INLINE_HEADER P_ CHARLIKE_CLOSURE(int n) {+    return (P_)&stg_CHARLIKE_closure[(n)-MIN_CHARLIKE];+}+INLINE_HEADER P_ INTLIKE_CLOSURE(int n) {+    return (P_)&stg_INTLIKE_closure[(n)-MIN_INTLIKE];+}++/* ----------------------------------------------------------------------------+   Macros for untagging and retagging closure pointers+   For more information look at the comments in Cmm.h+   ------------------------------------------------------------------------- */++static inline StgWord+GET_CLOSURE_TAG(const StgClosure * p)+{+    return (StgWord)p & TAG_MASK;+}++static inline StgClosure *+UNTAG_CLOSURE(StgClosure * p)+{+    return (StgClosure*)((StgWord)p & ~TAG_MASK);+}++static inline const StgClosure *+UNTAG_CONST_CLOSURE(const StgClosure * p)+{+    return (const StgClosure*)((StgWord)p & ~TAG_MASK);+}++static inline StgClosure *+TAG_CLOSURE(StgWord tag,StgClosure * p)+{+    return (StgClosure*)((StgWord)p | tag);+}++/* -----------------------------------------------------------------------------+   Forwarding pointers+   -------------------------------------------------------------------------- */++#define IS_FORWARDING_PTR(p) ((((StgWord)p) & 1) != 0)+#define MK_FORWARDING_PTR(p) (((StgWord)p) | 1)+#define UN_FORWARDING_PTR(p) (((StgWord)p) - 1)++/* -----------------------------------------------------------------------------+   DEBUGGING predicates for pointers++   LOOKS_LIKE_INFO_PTR(p)    returns False if p is definitely not an info ptr+   LOOKS_LIKE_CLOSURE_PTR(p) returns False if p is definitely not a closure ptr++   These macros are complete but not sound.  That is, they might+   return false positives.  Do not rely on them to distinguish info+   pointers from closure pointers, for example.++   We don't use address-space predicates these days, for portability+   reasons, and the fact that code/data can be scattered about the+   address space in a dynamically-linked environment.  Our best option+   is to look at the alleged info table and see whether it seems to+   make sense...+   -------------------------------------------------------------------------- */++INLINE_HEADER bool LOOKS_LIKE_INFO_PTR_NOT_NULL (StgWord p)+{+    StgInfoTable *info = INFO_PTR_TO_STRUCT((StgInfoTable *)p);+    return info->type != INVALID_OBJECT && info->type < N_CLOSURE_TYPES;+}++INLINE_HEADER bool LOOKS_LIKE_INFO_PTR (StgWord p)+{+    return p && (IS_FORWARDING_PTR(p) || LOOKS_LIKE_INFO_PTR_NOT_NULL(p));+}++INLINE_HEADER bool LOOKS_LIKE_CLOSURE_PTR (const void *p)+{+    return LOOKS_LIKE_INFO_PTR((StgWord)+            (UNTAG_CONST_CLOSURE((const StgClosure *)(p)))->header.info);+}++/* -----------------------------------------------------------------------------+   Macros for calculating the size of a closure+   -------------------------------------------------------------------------- */++EXTERN_INLINE StgOffset PAP_sizeW   ( uint32_t n_args );+EXTERN_INLINE StgOffset PAP_sizeW   ( uint32_t n_args )+{ return sizeofW(StgPAP) + n_args; }++EXTERN_INLINE StgOffset AP_sizeW   ( uint32_t n_args );+EXTERN_INLINE StgOffset AP_sizeW   ( uint32_t n_args )+{ return sizeofW(StgAP) + n_args; }++EXTERN_INLINE StgOffset AP_STACK_sizeW ( uint32_t size );+EXTERN_INLINE StgOffset AP_STACK_sizeW ( uint32_t size )+{ return sizeofW(StgAP_STACK) + size; }++EXTERN_INLINE StgOffset CONSTR_sizeW( uint32_t p, uint32_t np );+EXTERN_INLINE StgOffset CONSTR_sizeW( uint32_t p, uint32_t np )+{ return sizeofW(StgHeader) + p + np; }++EXTERN_INLINE StgOffset THUNK_SELECTOR_sizeW ( void );+EXTERN_INLINE StgOffset THUNK_SELECTOR_sizeW ( void )+{ return sizeofW(StgSelector); }++EXTERN_INLINE StgOffset BLACKHOLE_sizeW ( void );+EXTERN_INLINE StgOffset BLACKHOLE_sizeW ( void )+{ return sizeofW(StgInd); } // a BLACKHOLE is a kind of indirection++/* --------------------------------------------------------------------------+   Sizes of closures+   ------------------------------------------------------------------------*/++EXTERN_INLINE StgOffset sizeW_fromITBL( const StgInfoTable* itbl );+EXTERN_INLINE StgOffset sizeW_fromITBL( const StgInfoTable* itbl )+{ return sizeofW(StgClosure)+       + sizeofW(StgPtr)  * itbl->layout.payload.ptrs+       + sizeofW(StgWord) * itbl->layout.payload.nptrs; }++EXTERN_INLINE StgOffset thunk_sizeW_fromITBL( const StgInfoTable* itbl );+EXTERN_INLINE StgOffset thunk_sizeW_fromITBL( const StgInfoTable* itbl )+{ return sizeofW(StgThunk)+       + sizeofW(StgPtr)  * itbl->layout.payload.ptrs+       + sizeofW(StgWord) * itbl->layout.payload.nptrs; }++EXTERN_INLINE StgOffset ap_stack_sizeW( StgAP_STACK* x );+EXTERN_INLINE StgOffset ap_stack_sizeW( StgAP_STACK* x )+{ return AP_STACK_sizeW(x->size); }++EXTERN_INLINE StgOffset ap_sizeW( StgAP* x );+EXTERN_INLINE StgOffset ap_sizeW( StgAP* x )+{ return AP_sizeW(x->n_args); }++EXTERN_INLINE StgOffset pap_sizeW( StgPAP* x );+EXTERN_INLINE StgOffset pap_sizeW( StgPAP* x )+{ return PAP_sizeW(x->n_args); }++EXTERN_INLINE StgWord arr_words_words( StgArrBytes* x);+EXTERN_INLINE StgWord arr_words_words( StgArrBytes* x)+{ return ROUNDUP_BYTES_TO_WDS(x->bytes); }++EXTERN_INLINE StgOffset arr_words_sizeW( StgArrBytes* x );+EXTERN_INLINE StgOffset arr_words_sizeW( StgArrBytes* x )+{ return sizeofW(StgArrBytes) + arr_words_words(x); }++EXTERN_INLINE StgOffset mut_arr_ptrs_sizeW( StgMutArrPtrs* x );+EXTERN_INLINE StgOffset mut_arr_ptrs_sizeW( StgMutArrPtrs* x )+{ return sizeofW(StgMutArrPtrs) + x->size; }++EXTERN_INLINE StgOffset small_mut_arr_ptrs_sizeW( StgSmallMutArrPtrs* x );+EXTERN_INLINE StgOffset small_mut_arr_ptrs_sizeW( StgSmallMutArrPtrs* x )+{ return sizeofW(StgSmallMutArrPtrs) + x->ptrs; }++EXTERN_INLINE StgWord stack_sizeW ( StgStack *stack );+EXTERN_INLINE StgWord stack_sizeW ( StgStack *stack )+{ return sizeofW(StgStack) + stack->stack_size; }++EXTERN_INLINE StgWord bco_sizeW ( StgBCO *bco );+EXTERN_INLINE StgWord bco_sizeW ( StgBCO *bco )+{ return bco->size; }++EXTERN_INLINE StgWord compact_nfdata_full_sizeW ( StgCompactNFData *str );+EXTERN_INLINE StgWord compact_nfdata_full_sizeW ( StgCompactNFData *str )+{ return str->totalW; }++/*+ * TODO: Consider to switch return type from 'uint32_t' to 'StgWord' #8742+ *+ * (Also for 'closure_sizeW' below)+ */+EXTERN_INLINE uint32_t+closure_sizeW_ (const StgClosure *p, const StgInfoTable *info);+EXTERN_INLINE uint32_t+closure_sizeW_ (const StgClosure *p, const StgInfoTable *info)+{+    switch (info->type) {+    case THUNK_0_1:+    case THUNK_1_0:+        return sizeofW(StgThunk) + 1;+    case FUN_0_1:+    case CONSTR_0_1:+    case FUN_1_0:+    case CONSTR_1_0:+        return sizeofW(StgHeader) + 1;+    case THUNK_0_2:+    case THUNK_1_1:+    case THUNK_2_0:+        return sizeofW(StgThunk) + 2;+    case FUN_0_2:+    case CONSTR_0_2:+    case FUN_1_1:+    case CONSTR_1_1:+    case FUN_2_0:+    case CONSTR_2_0:+        return sizeofW(StgHeader) + 2;+    case THUNK:+        return thunk_sizeW_fromITBL(info);+    case THUNK_SELECTOR:+        return THUNK_SELECTOR_sizeW();+    case AP_STACK:+        return ap_stack_sizeW((StgAP_STACK *)p);+    case AP:+        return ap_sizeW((StgAP *)p);+    case PAP:+        return pap_sizeW((StgPAP *)p);+    case IND:+        return sizeofW(StgInd);+    case ARR_WORDS:+        return arr_words_sizeW((StgArrBytes *)p);+    case MUT_ARR_PTRS_CLEAN:+    case MUT_ARR_PTRS_DIRTY:+    case MUT_ARR_PTRS_FROZEN_CLEAN:+    case MUT_ARR_PTRS_FROZEN_DIRTY:+        return mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);+    case SMALL_MUT_ARR_PTRS_CLEAN:+    case SMALL_MUT_ARR_PTRS_DIRTY:+    case SMALL_MUT_ARR_PTRS_FROZEN_CLEAN:+    case SMALL_MUT_ARR_PTRS_FROZEN_DIRTY:+        return small_mut_arr_ptrs_sizeW((StgSmallMutArrPtrs*)p);+    case TSO:+        return sizeofW(StgTSO);+    case STACK:+        return stack_sizeW((StgStack*)p);+    case BCO:+        return bco_sizeW((StgBCO *)p);+    case TREC_CHUNK:+        return sizeofW(StgTRecChunk);+    default:+        return sizeW_fromITBL(info);+    }+}++// The definitive way to find the size, in words, of a heap-allocated closure+EXTERN_INLINE uint32_t closure_sizeW (const StgClosure *p);+EXTERN_INLINE uint32_t closure_sizeW (const StgClosure *p)+{+    return closure_sizeW_(p, get_itbl(p));+}++/* -----------------------------------------------------------------------------+   Sizes of stack frames+   -------------------------------------------------------------------------- */++EXTERN_INLINE StgWord stack_frame_sizeW( StgClosure *frame );+EXTERN_INLINE StgWord stack_frame_sizeW( StgClosure *frame )+{+    const StgRetInfoTable *info;++    info = get_ret_itbl(frame);+    switch (info->i.type) {++    case RET_FUN:+        return sizeofW(StgRetFun) + ((StgRetFun *)frame)->size;++    case RET_BIG:+        return 1 + GET_LARGE_BITMAP(&info->i)->size;++    case RET_BCO:+        return 2 + BCO_BITMAP_SIZE((StgBCO *)((P_)frame)[1]);++    default:+        return 1 + BITMAP_SIZE(info->i.layout.bitmap);+    }+}++/* -----------------------------------------------------------------------------+   StgMutArrPtrs macros++   An StgMutArrPtrs has a card table to indicate which elements are+   dirty for the generational GC.  The card table is an array of+   bytes, where each byte covers (1 << MUT_ARR_PTRS_CARD_BITS)+   elements.  The card table is directly after the array data itself.+   -------------------------------------------------------------------------- */++// The number of card bytes needed+INLINE_HEADER W_ mutArrPtrsCards (W_ elems)+{+    return (W_)((elems + (1 << MUT_ARR_PTRS_CARD_BITS) - 1)+                           >> MUT_ARR_PTRS_CARD_BITS);+}++// The number of words in the card table+INLINE_HEADER W_ mutArrPtrsCardTableSize (W_ elems)+{+    return ROUNDUP_BYTES_TO_WDS(mutArrPtrsCards(elems));+}++// The address of the card for a particular card number+INLINE_HEADER StgWord8 *mutArrPtrsCard (StgMutArrPtrs *a, W_ n)+{+    return ((StgWord8 *)&(a->payload[a->ptrs]) + n);+}++/* -----------------------------------------------------------------------------+   Replacing a closure with a different one.  We must call+   OVERWRITING_CLOSURE(p) on the old closure that is about to be+   overwritten.++   Note [zeroing slop]++   In some scenarios we write zero words into "slop"; memory that is+   left unoccupied after we overwrite a closure in the heap with a+   smaller closure.++   Zeroing slop is required for:++    - full-heap sanity checks (DEBUG, and +RTS -DS)+    - LDV profiling (PROFILING, and +RTS -hb)++   Zeroing slop must be disabled for:++    - THREADED_RTS with +RTS -N2 and greater, because we cannot+      overwrite slop when another thread might be reading it.++   Hence, slop is zeroed when either:++    - PROFILING && era <= 0 (LDV is on)+    - !THREADED_RTS && DEBUG++   And additionally:++    - LDV profiling and +RTS -N2 are incompatible+    - full-heap sanity checks are disabled for THREADED_RTS++   -------------------------------------------------------------------------- */++#if defined(PROFILING)+#define ZERO_SLOP_FOR_LDV_PROF 1+#else+#define ZERO_SLOP_FOR_LDV_PROF 0+#endif++#if defined(DEBUG) && !defined(THREADED_RTS)+#define ZERO_SLOP_FOR_SANITY_CHECK 1+#else+#define ZERO_SLOP_FOR_SANITY_CHECK 0+#endif++#if ZERO_SLOP_FOR_LDV_PROF || ZERO_SLOP_FOR_SANITY_CHECK+#define OVERWRITING_CLOSURE(c) overwritingClosure(c)+#define OVERWRITING_CLOSURE_OFS(c,n) overwritingClosureOfs(c,n)+#else+#define OVERWRITING_CLOSURE(c) /* nothing */+#define OVERWRITING_CLOSURE_OFS(c,n) /* nothing */+#endif++#if defined(PROFILING)+void LDV_recordDead (const StgClosure *c, uint32_t size);+#endif++EXTERN_INLINE void overwritingClosure_ (StgClosure *p,+                                        uint32_t offset /* in words */,+                                        uint32_t size /* closure size, in words */);+EXTERN_INLINE void overwritingClosure_ (StgClosure *p, uint32_t offset, uint32_t size)+{+#if ZERO_SLOP_FOR_LDV_PROF && !ZERO_SLOP_FOR_SANITY_CHECK+    // see Note [zeroing slop], also #8402+    if (era <= 0) return;+#endif++    // For LDV profiling, we need to record the closure as dead+#if defined(PROFILING)+    LDV_recordDead(p, size);+#endif++    for (uint32_t i = offset; i < size; i++) {+        ((StgWord *)p)[i] = 0;+    }+}++EXTERN_INLINE void overwritingClosure (StgClosure *p);+EXTERN_INLINE void overwritingClosure (StgClosure *p)+{+    overwritingClosure_(p, sizeofW(StgThunkHeader), closure_sizeW(p));+}++// Version of 'overwritingClosure' which overwrites only a suffix of a+// closure.  The offset is expressed in words relative to 'p' and shall+// be less than or equal to closure_sizeW(p), and usually at least as+// large as the respective thunk header.+//+// Note: As this calls LDV_recordDead() you have to call LDV_RECORD()+//       on the final state of the closure at the call-site+EXTERN_INLINE void overwritingClosureOfs (StgClosure *p, uint32_t offset);+EXTERN_INLINE void overwritingClosureOfs (StgClosure *p, uint32_t offset)+{+    overwritingClosure_(p, offset, closure_sizeW(p));+}++// Version of 'overwritingClosure' which takes closure size as argument.+EXTERN_INLINE void overwritingClosureSize (StgClosure *p, uint32_t size /* in words */);+EXTERN_INLINE void overwritingClosureSize (StgClosure *p, uint32_t size)+{+    overwritingClosure_(p, sizeofW(StgThunkHeader), size);+}
+ includes/rts/storage/ClosureTypes.h view
@@ -0,0 +1,86 @@+/* ----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2005+ *+ * Closure Type Constants: out here because the native code generator+ * needs to get at them.+ *+ * -------------------------------------------------------------------------- */++#pragma once++/*+ * WARNING WARNING WARNING+ *+ * If you add or delete any closure types, don't forget to update the following,+ *   - the closure flags table in rts/ClosureFlags.c+ *   - isRetainer in rts/RetainerProfile.c+ *   - the closure_type_names list in rts/Printer.c+ */++/* Object tag 0 raises an internal error */+#define INVALID_OBJECT                0+#define CONSTR                        1+#define CONSTR_1_0                    2+#define CONSTR_0_1                    3+#define CONSTR_2_0                    4+#define CONSTR_1_1                    5+#define CONSTR_0_2                    6+#define CONSTR_NOCAF                  7+#define FUN                           8+#define FUN_1_0                       9+#define FUN_0_1                       10+#define FUN_2_0                       11+#define FUN_1_1                       12+#define FUN_0_2                       13+#define FUN_STATIC                    14+#define THUNK                         15+#define THUNK_1_0                     16+#define THUNK_0_1                     17+#define THUNK_2_0                     18+#define THUNK_1_1                     19+#define THUNK_0_2                     20+#define THUNK_STATIC                  21+#define THUNK_SELECTOR                22+#define BCO                           23+#define AP                            24+#define PAP                           25+#define AP_STACK                      26+#define IND                           27+#define IND_STATIC                    28+#define RET_BCO                       29+#define RET_SMALL                     30+#define RET_BIG                       31+#define RET_FUN                       32+#define UPDATE_FRAME                  33+#define CATCH_FRAME                   34+#define UNDERFLOW_FRAME               35+#define STOP_FRAME                    36+#define BLOCKING_QUEUE                37+#define BLACKHOLE                     38+#define MVAR_CLEAN                    39+#define MVAR_DIRTY                    40+#define TVAR                          41+#define ARR_WORDS                     42+#define MUT_ARR_PTRS_CLEAN            43+#define MUT_ARR_PTRS_DIRTY            44+#define MUT_ARR_PTRS_FROZEN_DIRTY     45+#define MUT_ARR_PTRS_FROZEN_CLEAN     46+#define MUT_VAR_CLEAN                 47+#define MUT_VAR_DIRTY                 48+#define WEAK                          49+#define PRIM                          50+#define MUT_PRIM                      51+#define TSO                           52+#define STACK                         53+#define TREC_CHUNK                    54+#define ATOMICALLY_FRAME              55+#define CATCH_RETRY_FRAME             56+#define CATCH_STM_FRAME               57+#define WHITEHOLE                     58+#define SMALL_MUT_ARR_PTRS_CLEAN      59+#define SMALL_MUT_ARR_PTRS_DIRTY      60+#define SMALL_MUT_ARR_PTRS_FROZEN_DIRTY 61+#define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62+#define COMPACT_NFDATA                63+#define N_CLOSURE_TYPES               64
+ includes/rts/storage/Closures.h view
@@ -0,0 +1,470 @@+/* ----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2004+ *+ * Closures+ *+ * -------------------------------------------------------------------------- */++#pragma once++/*+ * The Layout of a closure header depends on which kind of system we're+ * compiling for: profiling, parallel, ticky, etc.+ */++/* -----------------------------------------------------------------------------+   The profiling header+   -------------------------------------------------------------------------- */++typedef struct {+  CostCentreStack *ccs;+  union {+    struct _RetainerSet *rs;  /* Retainer Set */+    StgWord ldvw;             /* Lag/Drag/Void Word */+  } hp;+} StgProfHeader;++/* -----------------------------------------------------------------------------+   The SMP header++   A thunk has a padding word to take the updated value.  This is so+   that the update doesn't overwrite the payload, so we can avoid+   needing to lock the thunk during entry and update.++   Note: this doesn't apply to THUNK_STATICs, which have no payload.++   Note: we leave this padding word in all ways, rather than just SMP,+   so that we don't have to recompile all our libraries for SMP.+   -------------------------------------------------------------------------- */++typedef struct {+    StgWord pad;+} StgSMPThunkHeader;++/* -----------------------------------------------------------------------------+   The full fixed-size closure header++   The size of the fixed header is the sum of the optional parts plus a single+   word for the entry code pointer.+   -------------------------------------------------------------------------- */++typedef struct {+    const StgInfoTable* info;+#if defined(PROFILING)+    StgProfHeader         prof;+#endif+} StgHeader;++typedef struct {+    const StgInfoTable* info;+#if defined(PROFILING)+    StgProfHeader         prof;+#endif+    StgSMPThunkHeader     smp;+} StgThunkHeader;++#define THUNK_EXTRA_HEADER_W (sizeofW(StgThunkHeader)-sizeofW(StgHeader))++/* -----------------------------------------------------------------------------+   Closure Types++   For any given closure type (defined in InfoTables.h), there is a+   corresponding structure defined below.  The name of the structure+   is obtained by concatenating the closure type with '_closure'+   -------------------------------------------------------------------------- */++/* All closures follow the generic format */++typedef struct StgClosure_ {+    StgHeader   header;+    struct StgClosure_ *payload[];+} *StgClosurePtr; // StgClosure defined in rts/Types.h++typedef struct {+    StgThunkHeader  header;+    struct StgClosure_ *payload[];+} StgThunk;++typedef struct {+    StgThunkHeader   header;+    StgClosure *selectee;+} StgSelector;++typedef struct {+    StgHeader   header;+    StgHalfWord arity;          /* zero if it is an AP */+    StgHalfWord n_args;+    StgClosure *fun;            /* really points to a fun */+    StgClosure *payload[];+} StgPAP;++typedef struct {+    StgThunkHeader   header;+    StgHalfWord arity;          /* zero if it is an AP */+    StgHalfWord n_args;+    StgClosure *fun;            /* really points to a fun */+    StgClosure *payload[];+} StgAP;++typedef struct {+    StgThunkHeader   header;+    StgWord     size;                    /* number of words in payload */+    StgClosure *fun;+    StgClosure *payload[]; /* contains a chunk of *stack* */+} StgAP_STACK;++typedef struct {+    StgHeader   header;+    StgClosure *indirectee;+} StgInd;++typedef struct {+    StgHeader     header;+    StgClosure   *indirectee;+    StgClosure   *static_link; // See Note [CAF lists]+    const StgInfoTable *saved_info;+        // `saved_info` also used for the link field for `debug_caf_list`,+        // see `newCAF` and Note [CAF lists] in rts/sm/Storage.h.+} StgIndStatic;++typedef struct StgBlockingQueue_ {+    StgHeader   header;+    struct StgBlockingQueue_ *link;+        // here so it looks like an IND, to be able to skip the queue without+        // deleting it (done in wakeBlockingQueue())+    StgClosure *bh;  // the BLACKHOLE+    StgTSO     *owner;+    struct MessageBlackHole_ *queue;+        // holds TSOs blocked on `bh`+} StgBlockingQueue;++typedef struct {+    StgHeader  header;+    StgWord    bytes;+    StgWord    payload[];+} StgArrBytes;++typedef struct {+    StgHeader   header;+    StgWord     ptrs;+    StgWord     size; // ptrs plus card table+    StgClosure *payload[];+    // see also: StgMutArrPtrs macros in ClosureMacros.h+} StgMutArrPtrs;++typedef struct {+    StgHeader   header;+    StgWord     ptrs;+    StgClosure *payload[];+} StgSmallMutArrPtrs;++typedef struct {+    StgHeader   header;+    StgClosure *var;+} StgMutVar;++typedef struct _StgUpdateFrame {+    StgHeader  header;+    StgClosure *updatee;+} StgUpdateFrame;++typedef struct {+    StgHeader  header;+    StgWord    exceptions_blocked;+    StgClosure *handler;+} StgCatchFrame;++typedef struct {+    const StgInfoTable* info;+    struct StgStack_ *next_chunk;+} StgUnderflowFrame;++typedef struct {+    StgHeader  header;+} StgStopFrame;++typedef struct {+  StgHeader header;+  StgWord data;+} StgIntCharlikeClosure;++/* statically allocated */+typedef struct {+  StgHeader  header;+} StgRetry;++typedef struct _StgStableName {+  StgHeader      header;+  StgWord        sn;+} StgStableName;++typedef struct _StgWeak {       /* Weak v */+  StgHeader header;+  StgClosure *cfinalizers;+  StgClosure *key;+  StgClosure *value;            /* v */+  StgClosure *finalizer;+  struct _StgWeak *link;+} StgWeak;++typedef struct _StgCFinalizerList {+  StgHeader header;+  StgClosure *link;+  void (*fptr)(void);+  void *ptr;+  void *eptr;+  StgWord flag; /* has environment (0 or 1) */+} StgCFinalizerList;++/* Byte code objects.  These are fixed size objects with pointers to+ * four arrays, designed so that a BCO can be easily "re-linked" to+ * other BCOs, to facilitate GHC's intelligent recompilation.  The+ * array of instructions is static and not re-generated when the BCO+ * is re-linked, but the other 3 arrays will be regenerated.+ *+ * A BCO represents either a function or a stack frame.  In each case,+ * it needs a bitmap to describe to the garbage collector the+ * pointerhood of its arguments/free variables respectively, and in+ * the case of a function it also needs an arity.  These are stored+ * directly in the BCO, rather than in the instrs array, for two+ * reasons:+ * (a) speed: we need to get at the bitmap info quickly when+ *     the GC is examining APs and PAPs that point to this BCO+ * (b) a subtle interaction with the compacting GC.  In compacting+ *     GC, the info that describes the size/layout of a closure+ *     cannot be in an object more than one level of indirection+ *     away from the current object, because of the order in+ *     which pointers are updated to point to their new locations.+ */++typedef struct {+    StgHeader      header;+    StgArrBytes   *instrs;      /* a pointer to an ArrWords */+    StgArrBytes   *literals;    /* a pointer to an ArrWords */+    StgMutArrPtrs *ptrs;        /* a pointer to a  MutArrPtrs */+    StgHalfWord   arity;        /* arity of this BCO */+    StgHalfWord   size;         /* size of this BCO (in words) */+    StgWord       bitmap[];  /* an StgLargeBitmap */+} StgBCO;++#define BCO_BITMAP(bco)      ((StgLargeBitmap *)((StgBCO *)(bco))->bitmap)+#define BCO_BITMAP_SIZE(bco) (BCO_BITMAP(bco)->size)+#define BCO_BITMAP_BITS(bco) (BCO_BITMAP(bco)->bitmap)+#define BCO_BITMAP_SIZEW(bco) ((BCO_BITMAP_SIZE(bco) + BITS_IN(StgWord) - 1) \+                                / BITS_IN(StgWord))++/* A function return stack frame: used when saving the state for a+ * garbage collection at a function entry point.  The function+ * arguments are on the stack, and we also save the function (its+ * info table describes the pointerhood of the arguments).+ *+ * The stack frame size is also cached in the frame for convenience.+ *+ * The only RET_FUN is stg_gc_fun, which is created by __stg_gc_fun,+ * both in HeapStackCheck.cmm.+ */+typedef struct {+    const StgInfoTable* info;+    StgWord        size;+    StgClosure *   fun;+    StgClosure *   payload[];+} StgRetFun;++/* Concurrent communication objects */++typedef struct StgMVarTSOQueue_ {+    StgHeader                header;+    struct StgMVarTSOQueue_ *link;+    struct StgTSO_          *tso;+} StgMVarTSOQueue;++typedef struct {+    StgHeader                header;+    struct StgMVarTSOQueue_ *head;+    struct StgMVarTSOQueue_ *tail;+    StgClosure*              value;+} StgMVar;+++/* STM data structures+ *+ *  StgTVar defines the only type that can be updated through the STM+ *  interface.+ *+ *  Note that various optimisations may be possible in order to use less+ *  space for these data structures at the cost of more complexity in the+ *  implementation:+ *+ *   - In StgTVar, current_value and first_watch_queue_entry could be held in+ *     the same field: if any thread is waiting then its expected_value for+ *     the tvar is the current value.+ *+ *   - In StgTRecHeader, it might be worthwhile having separate chunks+ *     of read-only and read-write locations.  This would save a+ *     new_value field in the read-only locations.+ *+ *   - In StgAtomicallyFrame, we could combine the waiting bit into+ *     the header (maybe a different info tbl for a waiting transaction).+ *     This means we can specialise the code for the atomically frame+ *     (it immediately switches on frame->waiting anyway).+ */++typedef struct StgTRecHeader_ StgTRecHeader;++typedef struct StgTVarWatchQueue_ {+  StgHeader                  header;+  StgClosure                *closure; // StgTSO+  struct StgTVarWatchQueue_ *next_queue_entry;+  struct StgTVarWatchQueue_ *prev_queue_entry;+} StgTVarWatchQueue;++typedef struct {+  StgHeader                  header;+  StgClosure                *volatile current_value;+  StgTVarWatchQueue         *volatile first_watch_queue_entry;+  StgInt                     volatile num_updates;+} StgTVar;++/* new_value == expected_value for read-only accesses */+/* new_value is a StgTVarWatchQueue entry when trec in state TREC_WAITING */+typedef struct {+  StgTVar                   *tvar;+  StgClosure                *expected_value;+  StgClosure                *new_value;+#if defined(THREADED_RTS)+  StgInt                     num_updates;+#endif+} TRecEntry;++#define TREC_CHUNK_NUM_ENTRIES 16++typedef struct StgTRecChunk_ {+  StgHeader                  header;+  struct StgTRecChunk_      *prev_chunk;+  StgWord                    next_entry_idx;+  TRecEntry                  entries[TREC_CHUNK_NUM_ENTRIES];+} StgTRecChunk;++typedef enum {+  TREC_ACTIVE,        /* Transaction in progress, outcome undecided */+  TREC_CONDEMNED,     /* Transaction in progress, inconsistent / out of date reads */+  TREC_COMMITTED,     /* Transaction has committed, now updating tvars */+  TREC_ABORTED,       /* Transaction has aborted, now reverting tvars */+  TREC_WAITING,       /* Transaction currently waiting */+} TRecState;++struct StgTRecHeader_ {+  StgHeader                  header;+  struct StgTRecHeader_     *enclosing_trec;+  StgTRecChunk              *current_chunk;+  TRecState                  state;+};++typedef struct {+  StgHeader   header;+  StgClosure *code;+  StgClosure *result;+} StgAtomicallyFrame;++typedef struct {+  StgHeader   header;+  StgClosure *code;+  StgClosure *handler;+} StgCatchSTMFrame;++typedef struct {+  StgHeader      header;+  StgWord        running_alt_code;+  StgClosure    *first_code;+  StgClosure    *alt_code;+} StgCatchRetryFrame;++/* ----------------------------------------------------------------------------+   Messages+   ------------------------------------------------------------------------- */++typedef struct Message_ {+    StgHeader        header;+    struct Message_ *link;+} Message;++typedef struct MessageWakeup_ {+    StgHeader header;+    Message  *link;+    StgTSO   *tso;+} MessageWakeup;++typedef struct MessageThrowTo_ {+    StgHeader   header;+    struct MessageThrowTo_ *link;+    StgTSO     *source;+    StgTSO     *target;+    StgClosure *exception;+} MessageThrowTo;++typedef struct MessageBlackHole_ {+    StgHeader   header;+    struct MessageBlackHole_ *link;+        // here so it looks like an IND, to be able to skip the message without+        // deleting it (done in throwToMsg())+    StgTSO     *tso;+    StgClosure *bh;+} MessageBlackHole;++/* ----------------------------------------------------------------------------+   Compact Regions+   ------------------------------------------------------------------------- */++//+// A compact region is a list of blocks.  Each block starts with an+// StgCompactNFDataBlock structure, and the list is chained through the next+// field of these structs.  (the link field of the bdescr is used to chain+// together multiple compact region on the compact_objects field of a+// generation).+//+// See Note [Compact Normal Forms] for details+//+typedef struct StgCompactNFDataBlock_ {+    struct StgCompactNFDataBlock_ *self;+       // the address of this block this is copied over to the+       // receiving end when serializing a compact, so the receiving+       // end can allocate the block at best as it can, and then+       // verify if pointer adjustment is needed or not by comparing+       // self with the actual address; the same data is sent over as+       // SerializedCompact metadata, but having it here simplifies+       // the fixup implementation.+    struct StgCompactNFData_ *owner;+       // the closure who owns this block (used in objectGetCompact)+    struct StgCompactNFDataBlock_ *next;+       // chain of blocks used for serialization and freeing+} StgCompactNFDataBlock;++//+// This is the Compact# primitive object.+//+typedef struct StgCompactNFData_ {+    StgHeader header;+      // for sanity and other checks in practice, nothing should ever+      // need the compact info pointer (we don't even need fwding+      // pointers because it's a large object)+    StgWord totalW;+      // Total number of words in all blocks in the compact+    StgWord autoBlockW;+      // size of automatically appended blocks+    StgPtr hp, hpLim;+      // the beginning and end of the free area in the nursery block.  This is+      // just a convenience so that we can avoid multiple indirections through+      // the nursery pointer below during compaction.+    StgCompactNFDataBlock *nursery;+      // where to (try to) allocate from when appending+    StgCompactNFDataBlock *last;+      // the last block of the chain (to know where to append new+      // blocks for resize)+    struct hashtable *hash;+      // the hash table for the current compaction, or NULL if+      // there's no (sharing-preserved) compaction in progress.+    StgClosure *result;+      // Used temporarily to store the result of compaction.  Doesn't need to be+      // a GC root.+} StgCompactNFData;
+ includes/rts/storage/FunTypes.h view
@@ -0,0 +1,54 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 2002+ *+ * Things for functions.+ *+ * ---------------------------------------------------------------------------*/++#pragma once++/* generic - function comes with a small bitmap */+#define ARG_GEN      0   ++/* generic - function comes with a large bitmap */+#define ARG_GEN_BIG  1++/* BCO - function is really a BCO */+#define ARG_BCO      2++/*+ * Specialised function types: bitmaps and calling sequences+ * for these functions are pre-generated: see ghc/utils/genapply and+ * generated code in ghc/rts/AutoApply.cmm.+ *+ *  NOTE: other places to change if you change this table:+ *       - utils/genapply/Main.hs: stackApplyTypes+ *       - compiler/codeGen/StgCmmLayout.hs: stdPattern+ */+#define ARG_NONE     3 +#define ARG_N        4  +#define ARG_P        5 +#define ARG_F        6 +#define ARG_D        7 +#define ARG_L        8 +#define ARG_V16      9 +#define ARG_V32      10+#define ARG_V64      11+#define ARG_NN       12 +#define ARG_NP       13+#define ARG_PN       14+#define ARG_PP       15+#define ARG_NNN      16+#define ARG_NNP      17+#define ARG_NPN      18+#define ARG_NPP      19+#define ARG_PNN      20+#define ARG_PNP      21+#define ARG_PPN      22+#define ARG_PPP      23+#define ARG_PPPP     24+#define ARG_PPPPP    25+#define ARG_PPPPPP   26+#define ARG_PPPPPPP  27+#define ARG_PPPPPPPP 28
+ includes/rts/storage/GC.h view
@@ -0,0 +1,248 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2004+ *+ * External Storage Manger Interface+ *+ * ---------------------------------------------------------------------------*/++#pragma once++#include <stddef.h>+#include "rts/OSThreads.h"++/* -----------------------------------------------------------------------------+ * Generational GC+ *+ * We support an arbitrary number of generations.  Notes (in no particular+ * order):+ *+ *       - Objects "age" in the nursery for one GC cycle before being promoted+ *         to the next generation.  There is no aging in other generations.+ *+ *       - generation 0 is the allocation area.  It is given+ *         a fixed set of blocks during initialisation, and these blocks+ *         normally stay in G0S0.  In parallel execution, each+ *         Capability has its own nursery.+ *+ *       - during garbage collection, each generation which is an+ *         evacuation destination (i.e. all generations except G0) is+ *         allocated a to-space.  evacuated objects are allocated into+ *         the generation's to-space until GC is finished, when the+ *         original generations's contents may be freed and replaced+ *         by the to-space.+ *+ *       - the mutable-list is per-generation.  G0 doesn't have one+ *         (since every garbage collection collects at least G0).+ *+ *       - block descriptors contain a pointer to the generation that+ *         the block belongs to, for convenience.+ *+ *       - static objects are stored in per-generation lists.  See GC.c for+ *         details of how we collect CAFs in the generational scheme.+ *+ *       - large objects are per-generation, and are promoted in the+ *         same way as small objects.+ *+ * ------------------------------------------------------------------------- */++// A count of blocks needs to store anything up to the size of memory+// divided by the block size.  The safest thing is therefore to use a+// type that can store the full range of memory addresses,+// ie. StgWord.  Note that we have had some tricky int overflows in a+// couple of cases caused by using ints rather than longs (e.g. #5086)++typedef StgWord memcount;++typedef struct nursery_ {+    bdescr *       blocks;+    memcount       n_blocks;+} nursery;++// Nursery invariants:+//+//  - cap->r.rNursery points to the nursery for this capability+//+//  - cap->r.rCurrentNursery points to the block in the nursery that we are+//    currently allocating into.  While in Haskell the current heap pointer is+//    in Hp, outside Haskell it is stored in cap->r.rCurrentNursery->free.+//+//  - the blocks *after* cap->rCurrentNursery in the chain are empty+//    (although their bd->free pointers have not been updated to+//    reflect that)+//+//  - the blocks *before* cap->rCurrentNursery have been used.  Except+//    for rCurrentAlloc.+//+//  - cap->r.rCurrentAlloc is either NULL, or it points to a block in+//    the nursery *before* cap->r.rCurrentNursery.+//+// See also Note [allocation accounting] to understand how total+// memory allocation is tracked.++typedef struct generation_ {+    uint32_t       no;                  // generation number++    bdescr *       blocks;              // blocks in this gen+    memcount       n_blocks;            // number of blocks+    memcount       n_words;             // number of used words++    bdescr *       large_objects;       // large objects (doubly linked)+    memcount       n_large_blocks;      // no. of blocks used by large objs+    memcount       n_large_words;       // no. of words used by large objs+    memcount       n_new_large_words;   // words of new large objects+                                        // (for doYouWantToGC())++    bdescr *       compact_objects;     // compact objects chain+                                        // the second block in each compact is+                                        // linked from the closure object, while+                                        // the second compact object in the+                                        // chain is linked from bd->link (like+                                        // large objects)+    memcount       n_compact_blocks;    // no. of blocks used by all compacts+    bdescr *       compact_blocks_in_import; // compact objects being imported+                                             // (not known to the GC because+                                             // potentially invalid, but we+                                             // need to keep track of them+                                             // to avoid assertions in Sanity)+                                             // this is a list shaped like compact_objects+    memcount       n_compact_blocks_in_import; // no. of blocks used by compacts+                                               // being imported++    // Max blocks to allocate in this generation before collecting it. Collect+    // this generation when+    //+    //     n_blocks + n_large_blocks + n_compact_blocks > max_blocks+    //+    memcount       max_blocks;++    StgTSO *       threads;             // threads in this gen+                                        // linked via global_link+    StgWeak *      weak_ptr_list;       // weak pointers in this gen++    struct generation_ *to;             // destination gen for live objects++    // stats information+    uint32_t collections;+    uint32_t par_collections;+    uint32_t failed_promotions;         // Currently unused++    // ------------------------------------+    // Fields below are used during GC only++#if defined(THREADED_RTS)+    char pad[128];                      // make sure the following is+                                        // on a separate cache line.+    SpinLock     sync;                  // lock for large_objects+                                        //    and scavenged_large_objects+#endif++    int          mark;                  // mark (not copy)? (old gen only)+    int          compact;               // compact (not sweep)? (old gen only)++    // During GC, if we are collecting this gen, blocks and n_blocks+    // are copied into the following two fields.  After GC, these blocks+    // are freed.+    bdescr *     old_blocks;            // bdescr of first from-space block+    memcount     n_old_blocks;         // number of blocks in from-space+    memcount     live_estimate;         // for sweeping: estimate of live data++    bdescr *     scavenged_large_objects;  // live large objs after GC (d-link)+    memcount     n_scavenged_large_blocks; // size (not count) of above++    bdescr *     live_compact_objects;  // live compact objs after GC (d-link)+    memcount     n_live_compact_blocks; // size (not count) of above++    bdescr *     bitmap;                // bitmap for compacting collection++    StgTSO *     old_threads;+    StgWeak *    old_weak_ptr_list;+} generation;++extern generation * generations;+extern generation * g0;+extern generation * oldest_gen;++/* -----------------------------------------------------------------------------+   Generic allocation++   StgPtr allocate(Capability *cap, W_ n)+                                Allocates memory from the nursery in+                                the current Capability.++   StgPtr allocatePinned(Capability *cap, W_ n)+                                Allocates a chunk of contiguous store+                                n words long, which is at a fixed+                                address (won't be moved by GC).+                                Returns a pointer to the first word.+                                Always succeeds.++                                NOTE: the GC can't in general handle+                                pinned objects, so allocatePinned()+                                can only be used for ByteArrays at the+                                moment.++                                Don't forget to TICK_ALLOC_XXX(...)+                                after calling allocate or+                                allocatePinned, for the+                                benefit of the ticky-ticky profiler.++   -------------------------------------------------------------------------- */++StgPtr  allocate          ( Capability *cap, W_ n );+StgPtr  allocateMightFail ( Capability *cap, W_ n );+StgPtr  allocatePinned    ( Capability *cap, W_ n );++/* memory allocator for executable memory */+typedef void* AdjustorWritable;+typedef void* AdjustorExecutable;++AdjustorWritable allocateExec(W_ len, AdjustorExecutable *exec_addr);+void flushExec(W_ len, AdjustorExecutable exec_addr);+#if defined(ios_HOST_OS)+AdjustorWritable execToWritable(AdjustorExecutable exec);+#endif+void             freeExec (AdjustorExecutable p);++// Used by GC checks in external .cmm code:+extern W_ large_alloc_lim;++/* -----------------------------------------------------------------------------+   Performing Garbage Collection+   -------------------------------------------------------------------------- */++void performGC(void);+void performMajorGC(void);++/* -----------------------------------------------------------------------------+   The CAF table - used to let us revert CAFs in GHCi+   -------------------------------------------------------------------------- */++StgInd *newCAF         (StgRegTable *reg, StgIndStatic *caf);+StgInd *newRetainedCAF (StgRegTable *reg, StgIndStatic *caf);+StgInd *newGCdCAF      (StgRegTable *reg, StgIndStatic *caf);+void revertCAFs (void);++// Request that all CAFs are retained indefinitely.+// (preferably use RtsConfig.keep_cafs instead)+void setKeepCAFs (void);++/* -----------------------------------------------------------------------------+   This is the write barrier for MUT_VARs, a.k.a. IORefs.  A+   MUT_VAR_CLEAN object is not on the mutable list; a MUT_VAR_DIRTY+   is.  When written to, a MUT_VAR_CLEAN turns into a MUT_VAR_DIRTY+   and is put on the mutable list.+   -------------------------------------------------------------------------- */++void dirty_MUT_VAR(StgRegTable *reg, StgClosure *p);++/* set to disable CAF garbage collection in GHCi. */+/* (needed when dynamic libraries are used). */+extern bool keepCAFs;++INLINE_HEADER void initBdescr(bdescr *bd, generation *gen, generation *dest)+{+    bd->gen     = gen;+    bd->gen_no  = gen->no;+    bd->dest_no = dest->no;+}
+ includes/rts/storage/Heap.h view
@@ -0,0 +1,18 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The University of Glasgow 2006-2017+ *+ * Introspection into GHC's heap representation+ *+ * ---------------------------------------------------------------------------*/++#pragma once++#include "rts/storage/Closures.h"++StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure);++void heap_view_closure_ptrs_in_pap_payload(StgClosure *ptrs[], StgWord *nptrs+                        , StgClosure *fun, StgClosure **payload, StgWord size);++StgWord heap_view_closureSize(StgClosure *closure);
+ includes/rts/storage/InfoTables.h view
@@ -0,0 +1,405 @@+/* ----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2002+ *+ * Info Tables+ *+ * -------------------------------------------------------------------------- */++#pragma once++/* ----------------------------------------------------------------------------+   Relative pointers++   Several pointer fields in info tables are expressed as offsets+   relative to the info pointer, so that we can generate+   position-independent code.++   Note [x86-64-relative]+   There is a complication on the x86_64 platform, where pointers are+   64 bits, but the tools don't support 64-bit relative relocations.+   However, the default memory model (small) ensures that all symbols+   have values in the lower 2Gb of the address space, so offsets all+   fit in 32 bits.  Hence we can use 32-bit offset fields.++   Somewhere between binutils-2.16.1 and binutils-2.16.91.0.6,+   support for 64-bit PC-relative relocations was added, so maybe this+   hackery can go away sometime.+   ------------------------------------------------------------------------- */++#if defined(x86_64_TARGET_ARCH)+#define OFFSET_FIELD(n) StgHalfInt n; StgHalfWord __pad_##n+#else+#define OFFSET_FIELD(n) StgInt n+#endif++/* -----------------------------------------------------------------------------+   Profiling info+   -------------------------------------------------------------------------- */++typedef struct {+#if !defined(TABLES_NEXT_TO_CODE)+    char *closure_type;+    char *closure_desc;+#else+    OFFSET_FIELD(closure_type_off);+    OFFSET_FIELD(closure_desc_off);+#endif+} StgProfInfo;++/* -----------------------------------------------------------------------------+   Closure flags+   -------------------------------------------------------------------------- */++/* The type flags provide quick access to certain properties of a closure. */++#define _HNF (1<<0)  /* head normal form?    */+#define _BTM (1<<1)  /* uses info->layout.bitmap */+#define _NS  (1<<2)  /* non-sparkable        */+#define _THU (1<<3)  /* thunk?               */+#define _MUT (1<<4)  /* mutable?             */+#define _UPT (1<<5)  /* unpointed?           */+#define _SRT (1<<6)  /* has an SRT?          */+#define _IND (1<<7)  /* is an indirection?   */++#define isMUTABLE(flags)   ((flags) &_MUT)+#define isBITMAP(flags)    ((flags) &_BTM)+#define isTHUNK(flags)     ((flags) &_THU)+#define isUNPOINTED(flags) ((flags) &_UPT)+#define hasSRT(flags)      ((flags) &_SRT)++extern StgWord16 closure_flags[];++#define closureFlags(c)         (closure_flags[get_itbl \+                                    (UNTAG_CONST_CLOSURE(c))->type])++#define closure_HNF(c)          (  closureFlags(c) & _HNF)+#define closure_BITMAP(c)       (  closureFlags(c) & _BTM)+#define closure_NON_SPARK(c)    ( (closureFlags(c) & _NS))+#define closure_SHOULD_SPARK(c) (!(closureFlags(c) & _NS))+#define closure_THUNK(c)        (  closureFlags(c) & _THU)+#define closure_MUTABLE(c)      (  closureFlags(c) & _MUT)+#define closure_UNPOINTED(c)    (  closureFlags(c) & _UPT)+#define closure_SRT(c)          (  closureFlags(c) & _SRT)+#define closure_IND(c)          (  closureFlags(c) & _IND)++/* same as above but for info-ptr rather than closure */+#define ipFlags(ip)             (closure_flags[ip->type])++#define ip_HNF(ip)               (  ipFlags(ip) & _HNF)+#define ip_BITMAP(ip)            (  ipFlags(ip) & _BTM)+#define ip_SHOULD_SPARK(ip)      (!(ipFlags(ip) & _NS))+#define ip_THUNK(ip)             (  ipFlags(ip) & _THU)+#define ip_MUTABLE(ip)           (  ipFlags(ip) & _MUT)+#define ip_UNPOINTED(ip)         (  ipFlags(ip) & _UPT)+#define ip_SRT(ip)               (  ipFlags(ip) & _SRT)+#define ip_IND(ip)               (  ipFlags(ip) & _IND)++/* -----------------------------------------------------------------------------+   Bitmaps++   These are used to describe the pointerhood of a sequence of words+   (usually on the stack) to the garbage collector.  The two primary+   uses are for stack frames, and functions (where we need to describe+   the layout of a PAP to the GC).++   In these bitmaps: 0 == ptr, 1 == non-ptr.+   -------------------------------------------------------------------------- */++/*+ * Small bitmaps:  for a small bitmap, we store the size and bitmap in+ * the same word, using the following macros.  If the bitmap doesn't+ * fit in a single word, we use a pointer to an StgLargeBitmap below.+ */+#define MK_SMALL_BITMAP(size,bits) (((bits)<<BITMAP_BITS_SHIFT) | (size))++#define BITMAP_SIZE(bitmap) ((bitmap) & BITMAP_SIZE_MASK)+#define BITMAP_BITS(bitmap) ((bitmap) >> BITMAP_BITS_SHIFT)++/*+ * A large bitmap.+ */+typedef struct {+  StgWord size;+  StgWord bitmap[];+} StgLargeBitmap;++/* ----------------------------------------------------------------------------+   Info Tables+   ------------------------------------------------------------------------- */++/*+ * Stuff describing the closure layout.  Well, actually, it might+ * contain the selector index for a THUNK_SELECTOR.  This union is one+ * word long.+ */+typedef union {+    struct {                    /* Heap closure payload layout: */+        StgHalfWord ptrs;       /* number of pointers */+        StgHalfWord nptrs;      /* number of non-pointers */+    } payload;++    StgWord bitmap;               /* word-sized bit pattern describing */+                                  /*  a stack frame: see below */++#if !defined(TABLES_NEXT_TO_CODE)+    StgLargeBitmap* large_bitmap; /* pointer to large bitmap structure */+#else+    OFFSET_FIELD(large_bitmap_offset);  /* offset from info table to large bitmap structure */+#endif++    StgWord selector_offset;      /* used in THUNK_SELECTORs */++} StgClosureInfo;+++#if defined(x86_64_TARGET_ARCH) && defined(TABLES_NEXT_TO_CODE)+// On x86_64 we can fit a pointer offset in half a word, so put the SRT offset+// in the info->srt field directly.+//+// See the section "Referring to an SRT from the info table" in+// Note [SRTs] in CmmBuildInfoTables.hs+#define USE_INLINE_SRT_FIELD+#endif++#if defined(USE_INLINE_SRT_FIELD)+// offset to the SRT / closure, or zero if there's no SRT+typedef StgHalfInt StgSRTField;+#else+// non-zero if there is an SRT, the offset is in the optional srt field.+typedef StgHalfWord StgSRTField;+#endif+++/*+ * The "standard" part of an info table.  Every info table has this bit.+ */+typedef struct StgInfoTable_ {++#if !defined(TABLES_NEXT_TO_CODE)+    StgFunPtr       entry;      /* pointer to the entry code */+#endif++#if defined(PROFILING)+    StgProfInfo     prof;+#endif++    StgClosureInfo  layout;     /* closure layout info (one word) */++    StgHalfWord     type;       /* closure type */+    StgSRTField     srt;+       /* In a CONSTR:+            - the zero-based constructor tag+          In a FUN/THUNK+            - if USE_INLINE_SRT_FIELD+              - offset to the SRT (or zero if no SRT)+            - otherwise+              - non-zero if there is an SRT, offset is in srt_offset+       */++#if defined(TABLES_NEXT_TO_CODE)+    StgCode         code[];+#endif+} *StgInfoTablePtr; // StgInfoTable defined in rts/Types.h+++/* -----------------------------------------------------------------------------+   Function info tables++   This is the general form of function info tables.  The compiler+   will omit some of the fields in common cases:++   -  If fun_type is not ARG_GEN or ARG_GEN_BIG, then the slow_apply+      and bitmap fields may be left out (they are at the end, so omitting+      them doesn't affect the layout).++   -  If has_srt (in the std info table part) is zero, then the srt+      field needn't be set.  This only applies if the slow_apply and+      bitmap fields have also been omitted.+   -------------------------------------------------------------------------- */++/*+   Note [Encoding static reference tables]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++   As static reference tables appear frequently in code, we use a special+   compact encoding for the common case of a module defining only a few CAFs: We+   produce one table containing a list of CAFs in the module and then include a+   bitmap in each info table describing which entries of this table the closure+   references.+ */++typedef struct StgFunInfoExtraRev_ {+    OFFSET_FIELD(slow_apply_offset); /* apply to args on the stack */+    union {+        StgWord bitmap;+        OFFSET_FIELD(bitmap_offset);    /* arg ptr/nonptr bitmap */+    } b;+#if !defined(USE_INLINE_SRT_FIELD)+    OFFSET_FIELD(srt_offset);   /* pointer to the SRT closure */+#endif+    StgHalfWord    fun_type;    /* function type */+    StgHalfWord    arity;       /* function arity */+} StgFunInfoExtraRev;++typedef struct StgFunInfoExtraFwd_ {+    StgHalfWord    fun_type;    /* function type */+    StgHalfWord    arity;       /* function arity */+    StgClosure    *srt;         /* pointer to the SRT closure */+    union { /* union for compat. with TABLES_NEXT_TO_CODE version */+        StgWord        bitmap;  /* arg ptr/nonptr bitmap */+    } b;+    StgFun         *slow_apply; /* apply to args on the stack */+} StgFunInfoExtraFwd;++typedef struct {+#if defined(TABLES_NEXT_TO_CODE)+    StgFunInfoExtraRev f;+    StgInfoTable i;+#else+    StgInfoTable i;+    StgFunInfoExtraFwd f;+#endif+} StgFunInfoTable;++// canned bitmap for each arg type, indexed by constants in FunTypes.h+extern const StgWord stg_arg_bitmaps[];++/* -----------------------------------------------------------------------------+   Return info tables+   -------------------------------------------------------------------------- */++/*+ * When info tables are laid out backwards, we can omit the SRT+ * pointer iff has_srt is zero.+ */++typedef struct {+#if defined(TABLES_NEXT_TO_CODE)+#if !defined(USE_INLINE_SRT_FIELD)+    OFFSET_FIELD(srt_offset);   /* offset to the SRT closure */+#endif+    StgInfoTable i;+#else+    StgInfoTable i;+    StgClosure  *srt;           /* pointer to the SRT closure */+#endif+} StgRetInfoTable;++/* -----------------------------------------------------------------------------+   Thunk info tables+   -------------------------------------------------------------------------- */++/*+ * When info tables are laid out backwards, we can omit the SRT+ * pointer iff has_srt is zero.+ */++typedef struct StgThunkInfoTable_ {+#if defined(TABLES_NEXT_TO_CODE)+#if !defined(USE_INLINE_SRT_FIELD)+    OFFSET_FIELD(srt_offset);   /* offset to the SRT closure */+#endif+    StgInfoTable i;+#else+    StgInfoTable i;+    StgClosure  *srt;           /* pointer to the SRT closure */+#endif+} StgThunkInfoTable;++/* -----------------------------------------------------------------------------+   Constructor info tables+   -------------------------------------------------------------------------- */++typedef struct StgConInfoTable_ {+#if !defined(TABLES_NEXT_TO_CODE)+    StgInfoTable i;+#endif++#if defined(TABLES_NEXT_TO_CODE)+    OFFSET_FIELD(con_desc); // the name of the data constructor+                            // as: Package:Module.Name+#else+    char *con_desc;+#endif++#if defined(TABLES_NEXT_TO_CODE)+    StgInfoTable i;+#endif+} StgConInfoTable;+++/* -----------------------------------------------------------------------------+   Accessor macros for fields that might be offsets (C version)+   -------------------------------------------------------------------------- */++/*+ * GET_SRT(info)+ * info must be a Stg[Ret|Thunk]InfoTable* (an info table that has a SRT)+ */+#if defined(TABLES_NEXT_TO_CODE)+#if defined(x86_64_TARGET_ARCH)+#define GET_SRT(info) \+  ((StgClosure*) (((StgWord) ((info)+1)) + (info)->i.srt))+#else+#define GET_SRT(info) \+  ((StgClosure*) (((StgWord) ((info)+1)) + (info)->srt_offset))+#endif+#else // !TABLES_NEXT_TO_CODE+#define GET_SRT(info) ((info)->srt)+#endif++/*+ * GET_CON_DESC(info)+ * info must be a StgConInfoTable*.+ */+#if defined(TABLES_NEXT_TO_CODE)+#define GET_CON_DESC(info) \+            ((const char *)((StgWord)((info)+1) + (info->con_desc)))+#else+#define GET_CON_DESC(info) ((const char *)(info)->con_desc)+#endif++/*+ * GET_FUN_SRT(info)+ * info must be a StgFunInfoTable*+ */+#if defined(TABLES_NEXT_TO_CODE)+#if defined(x86_64_TARGET_ARCH)+#define GET_FUN_SRT(info) \+  ((StgClosure*) (((StgWord) ((info)+1)) + (info)->i.srt))+#else+#define GET_FUN_SRT(info) \+  ((StgClosure*) (((StgWord) ((info)+1)) + (info)->f.srt_offset))+#endif+#else+#define GET_FUN_SRT(info) ((info)->f.srt)+#endif++#if defined(TABLES_NEXT_TO_CODE)+#define GET_LARGE_BITMAP(info) ((StgLargeBitmap*) (((StgWord) ((info)+1)) \+                                        + (info)->layout.large_bitmap_offset))+#else+#define GET_LARGE_BITMAP(info) ((info)->layout.large_bitmap)+#endif++#if defined(TABLES_NEXT_TO_CODE)+#define GET_FUN_LARGE_BITMAP(info) ((StgLargeBitmap*) (((StgWord) ((info)+1)) \+                                        + (info)->f.b.bitmap_offset))+#else+#define GET_FUN_LARGE_BITMAP(info) ((StgLargeBitmap*) ((info)->f.b.bitmap))+#endif++/*+ * GET_PROF_TYPE, GET_PROF_DESC+ */+#if defined(TABLES_NEXT_TO_CODE)+#define GET_PROF_TYPE(info) ((char *)((StgWord)((info)+1) + (info->prof.closure_type_off)))+#else+#define GET_PROF_TYPE(info) ((info)->prof.closure_type)+#endif+#if defined(TABLES_NEXT_TO_CODE)+#define GET_PROF_DESC(info) ((char *)((StgWord)((info)+1) + (info->prof.closure_desc_off)))+#else+#define GET_PROF_DESC(info) ((info)->prof.closure_desc)+#endif
+ includes/rts/storage/MBlock.h view
@@ -0,0 +1,32 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2008+ *+ * MegaBlock Allocator interface.+ *+ * See wiki commentary at+ *  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/heap-alloced+ *+ * ---------------------------------------------------------------------------*/++#pragma once++extern W_ peak_mblocks_allocated;+extern W_ mblocks_allocated;++extern void initMBlocks(void);+extern void * getMBlock(void);+extern void * getMBlocks(uint32_t n);+extern void * getMBlockOnNode(uint32_t node);+extern void * getMBlocksOnNode(uint32_t node, uint32_t n);+extern void freeMBlocks(void *addr, uint32_t n);+extern void releaseFreeMemory(void);+extern void freeAllMBlocks(void);++extern void *getFirstMBlock(void **state);+extern void *getNextMBlock(void **state, void *mblock);++#if defined(THREADED_RTS)+// needed for HEAP_ALLOCED below+extern SpinLock gc_alloc_block_sync;+#endif
+ includes/rts/storage/TSO.h view
@@ -0,0 +1,261 @@+/* -----------------------------------------------------------------------------+ *+ * (c) The GHC Team, 1998-2009+ *+ * The definitions for Thread State Objects.+ *+ * ---------------------------------------------------------------------------*/++#pragma once++/*+ * PROFILING info in a TSO+ */+typedef struct {+  CostCentreStack *cccs;       /* thread's current CCS */+} StgTSOProfInfo;++/*+ * There is no TICKY info in a TSO at this time.+ */++/*+ * Thread IDs are 32 bits.+ */+typedef StgWord32 StgThreadID;++#define tsoLocked(tso) ((tso)->flags & TSO_LOCKED)++/*+ * Type returned after running a thread.  Values of this type+ * include HeapOverflow, StackOverflow etc.  See Constants.h for the+ * full list.+ */+typedef unsigned int StgThreadReturnCode;++#if defined(mingw32_HOST_OS)+/* results from an async I/O request + its request ID. */+typedef struct {+  unsigned int reqID;+  int          len;+  int          errCode;+} StgAsyncIOResult;+#endif++/* Reason for thread being blocked. See comment above struct StgTso_. */+typedef union {+  StgClosure *closure;+  StgTSO *prev; // a back-link when the TSO is on the run queue (NotBlocked)+  struct MessageBlackHole_ *bh;+  struct MessageThrowTo_ *throwto;+  struct MessageWakeup_  *wakeup;+  StgInt fd;    /* StgInt instead of int, so that it's the same size as the ptrs */+#if defined(mingw32_HOST_OS)+  StgAsyncIOResult *async_result;+#endif+#if !defined(THREADED_RTS)+  StgWord target;+    // Only for the non-threaded RTS: the target time for a thread+    // blocked in threadDelay, in units of 1ms.  This is a+    // compromise: we don't want to take up much space in the TSO.  If+    // you want better resolution for threadDelay, use -threaded.+#endif+} StgTSOBlockInfo;+++/*+ * TSOs live on the heap, and therefore look just like heap objects.+ * Large TSOs will live in their own "block group" allocated by the+ * storage manager, and won't be copied during garbage collection.+ */++/*+ * Threads may be blocked for several reasons.  A blocked thread will+ * have the reason in the why_blocked field of the TSO, and some+ * further info (such as the closure the thread is blocked on, or the+ * file descriptor if the thread is waiting on I/O) in the block_info+ * field.+ */++typedef struct StgTSO_ {+    StgHeader               header;++    /* The link field, for linking threads together in lists (e.g. the+       run queue on a Capability.+    */+    struct StgTSO_*         _link;+    /*+      Currently used for linking TSOs on:+      * cap->run_queue_{hd,tl}+      * (non-THREADED_RTS); the blocked_queue+      * and pointing to the next chunk for a ThreadOldStack++       NOTE!!!  do not modify _link directly, it is subject to+       a write barrier for generational GC.  Instead use the+       setTSOLink() function.  Exceptions to this rule are:++       * setting the link field to END_TSO_QUEUE+       * setting the link field of the currently running TSO, as it+         will already be dirty.+    */++    struct StgTSO_*         global_link;    // Links threads on the+                                            // generation->threads lists++    /*+     * The thread's stack+     */+    struct StgStack_       *stackobj;++    /*+     * The tso->dirty flag indicates that this TSO's stack should be+     * scanned during garbage collection.  It also indicates that this+     * TSO is on the mutable list.+     *+     * NB. The dirty flag gets a word to itself, so that it can be set+     * safely by multiple threads simultaneously (the flags field is+     * not safe for this purpose; see #3429).  It is harmless for the+     * TSO to be on the mutable list multiple times.+     *+     * tso->dirty is set by dirty_TSO(), and unset by the garbage+     * collector (only).+     */++    StgWord16               what_next;      // Values defined in Constants.h+    StgWord16               why_blocked;    // Values defined in Constants.h+    StgWord32               flags;          // Values defined in Constants.h+    StgTSOBlockInfo         block_info;+    StgThreadID             id;+    StgWord32               saved_errno;+    StgWord32               dirty;          /* non-zero => dirty */+    struct InCall_*         bound;+    struct Capability_*     cap;++    struct StgTRecHeader_ * trec;       /* STM transaction record */++    /*+     * A list of threads blocked on this TSO waiting to throw exceptions.+    */+    struct MessageThrowTo_ * blocked_exceptions;++    /*+     * A list of StgBlockingQueue objects, representing threads+     * blocked on thunks that are under evaluation by this thread.+    */+    struct StgBlockingQueue_ *bq;++    /*+     * The allocation limit for this thread, which is updated as the+     * thread allocates.  If the value drops below zero, and+     * TSO_ALLOC_LIMIT is set in flags, we raise an exception in the+     * thread, and give the thread a little more space to handle the+     * exception before we raise the exception again.+     *+     * This is an integer, because we might update it in a place where+     * it isn't convenient to raise the exception, so we want it to+     * stay negative until we get around to checking it.+     *+     * Use only PK_Int64/ASSIGN_Int64 macros to get/set the value of alloc_limit+     * in C code otherwise you will cause alignment issues on SPARC+     */+    StgInt64  alloc_limit;     /* in bytes */++    /*+     * sum of the sizes of all stack chunks (in words), used to decide+     * whether to throw the StackOverflow exception when the stack+     * overflows, or whether to just chain on another stack chunk.+     *+     * Note that this overestimates the real stack size, because each+     * chunk will have a gap at the end, of +RTS -kb<size> words.+     * This means stack overflows are not entirely accurate, because+     * the more gaps there are, the sooner the stack will run into the+     * hard +RTS -K<size> limit.+     */+    StgWord32  tot_stack_size;++#if defined(TICKY_TICKY)+    /* TICKY-specific stuff would go here. */+#endif+#if defined(PROFILING)+    StgTSOProfInfo prof;+#endif+#if defined(mingw32_HOST_OS)+    StgWord32 saved_winerror;+#endif++} *StgTSOPtr; // StgTSO defined in rts/Types.h++typedef struct StgStack_ {+    StgHeader  header;+    StgWord32  stack_size;     // stack size in *words*+    StgWord32  dirty;          // non-zero => dirty+    StgPtr     sp;             // current stack pointer+    StgWord    stack[];+} StgStack;++// Calculate SpLim from a TSO (reads tso->stackobj, but no fields from+// the stackobj itself).+INLINE_HEADER StgPtr tso_SpLim (StgTSO* tso)+{+    return tso->stackobj->stack + RESERVED_STACK_WORDS;+}++/* -----------------------------------------------------------------------------+   functions+   -------------------------------------------------------------------------- */++void dirty_TSO  (Capability *cap, StgTSO *tso);+void setTSOLink (Capability *cap, StgTSO *tso, StgTSO *target);+void setTSOPrev (Capability *cap, StgTSO *tso, StgTSO *target);++void dirty_STACK (Capability *cap, StgStack *stack);++/* -----------------------------------------------------------------------------+   Invariants:++   An active thread has the following properties:++      tso->stack < tso->sp < tso->stack+tso->stack_size+      tso->stack_size <= tso->max_stack_size++      RESERVED_STACK_WORDS is large enough for any heap-check or+      stack-check failure.++      The size of the TSO struct plus the stack is either+        (a) smaller than a block, or+        (b) a multiple of BLOCK_SIZE++        tso->why_blocked       tso->block_info      location+        ----------------------------------------------------------------------+        NotBlocked             END_TSO_QUEUE        runnable_queue, or running++        BlockedOnBlackHole     MessageBlackHole *   TSO->bq++        BlockedOnMVar          the MVAR             the MVAR's queue++        BlockedOnSTM           END_TSO_QUEUE        STM wait queue(s)+        BlockedOnSTM           STM_AWOKEN           run queue++        BlockedOnMsgThrowTo    MessageThrowTo *     TSO->blocked_exception++        BlockedOnRead          NULL                 blocked_queue+        BlockedOnWrite         NULL                 blocked_queue+        BlockedOnDelay         NULL                 blocked_queue++      tso->link == END_TSO_QUEUE, if the thread is currently running.++   A zombie thread has the following properties:++      tso->what_next == ThreadComplete or ThreadKilled+      tso->link     ==  (could be on some queue somewhere)+      tso->sp       ==  tso->stack + tso->stack_size - 1 (i.e. top stack word)+      tso->sp[0]    ==  return value of thread, if what_next == ThreadComplete,+                        exception             , if what_next == ThreadKilled++      (tso->sp is left pointing at the top word on the stack so that+      the return value or exception will be retained by a GC).++ ---------------------------------------------------------------------------- */++/* this is the NIL ptr for a TSO queue (e.g. runnable queue) */+#define END_TSO_QUEUE  ((StgTSO *)(void*)&stg_END_TSO_QUEUE_closure)
+ libraries/ghc-boot/GHC/HandleEncoding.hs view
@@ -0,0 +1,32 @@+-- | See GHC #10762 and #15021.+module GHC.HandleEncoding (configureHandleEncoding) where++import Prelude -- See note [Why do we import Prelude here?]+import GHC.IO.Encoding (textEncodingName)+import System.Environment+import System.IO++-- | Handle GHC-specific character encoding flags, allowing us to control how+-- GHC produces output regardless of OS.+configureHandleEncoding :: IO ()+configureHandleEncoding = do+   env <- getEnvironment+   case lookup "GHC_CHARENC" env of+    Just "UTF-8" -> do+     hSetEncoding stdout utf8+     hSetEncoding stderr utf8+    _ -> do+     -- Avoid GHC erroring out when trying to display unhandled characters+     hSetTranslit stdout+     hSetTranslit stderr++-- | Change the character encoding of the given Handle to transliterate+-- on unsupported characters instead of throwing an exception+hSetTranslit :: Handle -> IO ()+hSetTranslit h = do+    menc <- hGetEncoding h+    case fmap textEncodingName menc of+        Just name | '/' `notElem` name -> do+            enc' <- mkTextEncoding $ name ++ "//TRANSLIT"+            hSetEncoding h enc'+        _ -> return ()
+ libraries/ghci/GHCi/BinaryArray.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, FlexibleContexts #-}+-- | Efficient serialisation for GHCi Instruction arrays+--+-- Author: Ben Gamari+--+module GHCi.BinaryArray(putArray, getArray) where++import Prelude+import Foreign.Ptr+import Data.Binary+import Data.Binary.Put (putBuilder)+import qualified Data.Binary.Get.Internal as Binary+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Builder.Internal as BB+import qualified Data.Array.Base as A+import qualified Data.Array.IO.Internals as A+import qualified Data.Array.Unboxed as A+import GHC.Exts+import GHC.IO++-- | An efficient serialiser of 'A.UArray'.+putArray :: Binary i => A.UArray i a -> Put+putArray (A.UArray l u _ arr#) = do+    put l+    put u+    putBuilder $ byteArrayBuilder arr#++byteArrayBuilder :: ByteArray# -> BB.Builder+byteArrayBuilder arr# = BB.builder $ go 0 (I# (sizeofByteArray# arr#))+  where+    go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a+    go !inStart !inEnd k (BB.BufferRange outStart outEnd)+      -- There is enough room in this output buffer to write all remaining array+      -- contents+      | inRemaining <= outRemaining = do+          copyByteArrayToAddr arr# inStart outStart inRemaining+          k (BB.BufferRange (outStart `plusPtr` inRemaining) outEnd)+      -- There is only enough space for a fraction of the remaining contents+      | otherwise = do+          copyByteArrayToAddr arr# inStart outStart outRemaining+          let !inStart' = inStart + outRemaining+          return $! BB.bufferFull 1 outEnd (go inStart' inEnd k)+      where+        inRemaining  = inEnd - inStart+        outRemaining = outEnd `minusPtr` outStart++    copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()+    copyByteArrayToAddr src# (I# src_off#) (Ptr dst#) (I# len#) =+        IO $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of+                     s' -> (# s', () #)++-- | An efficient deserialiser of 'A.UArray'.+getArray :: (Binary i, A.Ix i, A.MArray A.IOUArray a IO) => Get (A.UArray i a)+getArray = do+    l <- get+    u <- get+    arr@(A.IOUArray (A.STUArray _ _ _ arr#)) <-+        return $ unsafeDupablePerformIO $ A.newArray_ (l,u)+    let go 0 _ = return ()+        go !remaining !off = do+            Binary.readNWith n $ \ptr ->+              copyAddrToByteArray ptr arr# off n+            go (remaining - n) (off + n)+          where n = min chunkSize remaining+    go (I# (sizeofMutableByteArray# arr#)) 0+    return $! unsafeDupablePerformIO $ unsafeFreezeIOUArray arr+  where+    chunkSize = 10*1024++    copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld+                        -> Int -> Int -> IO ()+    copyAddrToByteArray (Ptr src#) dst# (I# dst_off#) (I# len#) =+        IO $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of+                     s' -> (# s', () #)++-- this is inexplicably not exported in currently released array versions+unsafeFreezeIOUArray :: A.IOUArray ix e -> IO (A.UArray ix e)+unsafeFreezeIOUArray (A.IOUArray marr) = stToIO (A.unsafeFreezeSTUArray marr)
+ libraries/ghci/GHCi/CreateBCO.hs view
@@ -0,0 +1,163 @@+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE RecordWildCards #-}++--+--  (c) The University of Glasgow 2002-2006+--++-- | Create real byte-code objects from 'ResolvedBCO's.+module GHCi.CreateBCO (createBCOs) where++import Prelude -- See note [Why do we import Prelude here?]+import GHCi.ResolvedBCO+import GHCi.RemoteTypes+import GHCi.BreakArray+import SizedSeq++import System.IO (fixIO)+import Control.Monad+import Data.Array.Base+import Foreign hiding (newArray)+import GHC.Arr          ( Array(..) )+import GHC.Exts+import GHC.IO+import Control.Exception ( ErrorCall(..) )++createBCOs :: [ResolvedBCO] -> IO [HValueRef]+createBCOs bcos = do+  let n_bcos = length bcos+  hvals <- fixIO $ \hvs -> do+     let arr = listArray (0, n_bcos-1) hvs+     mapM (createBCO arr) bcos+  mapM mkRemoteRef hvals++createBCO :: Array Int HValue -> ResolvedBCO -> IO HValue+createBCO _   ResolvedBCO{..} | resolvedBCOIsLE /= isLittleEndian+  = throwIO (ErrorCall $+        unlines [ "The endianness of the ResolvedBCO does not match"+                , "the systems endianness. Using ghc and iserv in a"+                , "mixed endianness setup is not supported!"+                ])+createBCO arr bco+   = do BCO bco# <- linkBCO' arr bco+        -- Why do we need mkApUpd0 here?  Otherwise top-level+        -- interpreted CAFs don't get updated after evaluation.  A+        -- top-level BCO will evaluate itself and return its value+        -- when entered, but it won't update itself.  Wrapping the BCO+        -- in an AP_UPD thunk will take care of the update for us.+        --+        -- Furthermore:+        --   (a) An AP thunk *must* point directly to a BCO+        --   (b) A zero-arity BCO *must* be wrapped in an AP thunk+        --   (c) An AP is always fully saturated, so we *can't* wrap+        --       non-zero arity BCOs in an AP thunk.+        --+        if (resolvedBCOArity bco > 0)+           then return (HValue (unsafeCoerce# bco#))+           else case mkApUpd0# bco# of { (# final_bco #) ->+                  return (HValue final_bco) }+++toWordArray :: UArray Int Word64 -> UArray Int Word+toWordArray = amap fromIntegral++linkBCO' :: Array Int HValue -> ResolvedBCO -> IO BCO+linkBCO' arr ResolvedBCO{..} = do+  let+      ptrs   = ssElts resolvedBCOPtrs+      n_ptrs = sizeSS resolvedBCOPtrs++      !(I# arity#)  = resolvedBCOArity++      !(EmptyArr empty#) = emptyArr -- See Note [BCO empty array]++      barr a = case a of UArray _lo _hi n b -> if n == 0 then empty# else b+      insns_barr = barr resolvedBCOInstrs+      bitmap_barr = barr (toWordArray resolvedBCOBitmap)+      literals_barr = barr (toWordArray resolvedBCOLits)++  PtrsArr marr <- mkPtrsArray arr n_ptrs ptrs+  IO $ \s ->+    case unsafeFreezeArray# marr s of { (# s, arr #) ->+    case newBCO insns_barr literals_barr arr arity# bitmap_barr of { IO io ->+    io s+    }}+++-- we recursively link any sub-BCOs while making the ptrs array+mkPtrsArray :: Array Int HValue -> Word -> [ResolvedBCOPtr] -> IO PtrsArr+mkPtrsArray arr n_ptrs ptrs = do+  marr <- newPtrsArray (fromIntegral n_ptrs)+  let+    fill (ResolvedBCORef n) i =+      writePtrsArrayHValue i (arr ! n) marr  -- must be lazy!+    fill (ResolvedBCOPtr r) i = do+      hv <- localRef r+      writePtrsArrayHValue i hv marr+    fill (ResolvedBCOStaticPtr r) i = do+      writePtrsArrayPtr i (fromRemotePtr r)  marr+    fill (ResolvedBCOPtrBCO bco) i = do+      BCO bco# <- linkBCO' arr bco+      writePtrsArrayBCO i bco# marr+    fill (ResolvedBCOPtrBreakArray r) i = do+      BA mba <- localRef r+      writePtrsArrayMBA i mba marr+  zipWithM_ fill ptrs [0..]+  return marr++data PtrsArr = PtrsArr (MutableArray# RealWorld HValue)++newPtrsArray :: Int -> IO PtrsArr+newPtrsArray (I# i) = IO $ \s ->+  case newArray# i undefined s of (# s', arr #) -> (# s', PtrsArr arr #)++writePtrsArrayHValue :: Int -> HValue -> PtrsArr -> IO ()+writePtrsArrayHValue (I# i) hv (PtrsArr arr) = IO $ \s ->+  case writeArray# arr i hv s of s' -> (# s', () #)++writePtrsArrayPtr :: Int -> Ptr a -> PtrsArr -> IO ()+writePtrsArrayPtr (I# i) (Ptr a#) (PtrsArr arr) = IO $ \s ->+  case writeArrayAddr# arr i a# s of s' -> (# s', () #)++-- This is rather delicate: convincing GHC to pass an Addr# as an Any but+-- without making a thunk turns out to be surprisingly tricky.+{-# NOINLINE writeArrayAddr# #-}+writeArrayAddr# :: MutableArray# s a -> Int# -> Addr# -> State# s -> State# s+writeArrayAddr# marr i addr s = unsafeCoerce# writeArray# marr i addr s++writePtrsArrayBCO :: Int -> BCO# -> PtrsArr -> IO ()+writePtrsArrayBCO (I# i) bco (PtrsArr arr) = IO $ \s ->+  case (unsafeCoerce# writeArray#) arr i bco s of s' -> (# s', () #)++data BCO = BCO BCO#++writePtrsArrayMBA :: Int -> MutableByteArray# s -> PtrsArr -> IO ()+writePtrsArrayMBA (I# i) mba (PtrsArr arr) = IO $ \s ->+  case (unsafeCoerce# writeArray#) arr i mba s of s' -> (# s', () #)++newBCO :: ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> IO BCO+newBCO instrs lits ptrs arity bitmap = IO $ \s ->+  case newBCO# instrs lits ptrs arity bitmap s of+    (# s1, bco #) -> (# s1, BCO bco #)++{- Note [BCO empty array]++Lots of BCOs have empty ptrs or nptrs, but empty arrays are not free:+they are 2-word heap objects.  So let's make a single empty array and+share it between all BCOs.+-}++data EmptyArr = EmptyArr ByteArray#++{-# NOINLINE emptyArr #-}+emptyArr :: EmptyArr+emptyArr = unsafeDupablePerformIO $ IO $ \s ->+  case newByteArray# 0# s of { (# s, arr #) ->+  case unsafeFreezeByteArray# arr s of { (# s, farr #) ->+  (# s, EmptyArr farr #)+  }}
+ libraries/ghci/GHCi/InfoTable.hsc view
@@ -0,0 +1,390 @@+{-# LANGUAGE CPP, MagicHash, ScopedTypeVariables #-}++-- Get definitions for the structs, constants & config etc.+#include "Rts.h"++-- |+-- Run-time info table support.  This module provides support for+-- creating and reading info tables /in the running program/.+-- We use the RTS data structures directly via hsc2hs.+--+module GHCi.InfoTable+  (+#ifdef GHCI+    mkConInfoTable+#endif+  ) where++import Prelude -- See note [Why do we import Prelude here?]+#ifdef GHCI+import Foreign+import Foreign.C+import GHC.Ptr+import GHC.Exts+import GHC.Exts.Heap+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+#endif++ghciTablesNextToCode :: Bool+#ifdef TABLES_NEXT_TO_CODE+ghciTablesNextToCode = True+#else+ghciTablesNextToCode = False+#endif++#ifdef GHCI /* To end */+-- NOTE: Must return a pointer acceptable for use in the header of a closure.+-- If tables_next_to_code is enabled, then it must point the the 'code' field.+-- Otherwise, it should point to the start of the StgInfoTable.+mkConInfoTable+   :: Int     -- ptr words+   -> Int     -- non-ptr words+   -> Int     -- constr tag+   -> Int     -- pointer tag+   -> ByteString  -- con desc+   -> IO (Ptr StgInfoTable)+      -- resulting info table is allocated with allocateExec(), and+      -- should be freed with freeExec().++mkConInfoTable ptr_words nonptr_words tag ptrtag con_desc =+  castFunPtrToPtr <$> newExecConItbl itbl con_desc+  where+     entry_addr = interpConstrEntry !! ptrtag+     code' = mkJumpToAddr entry_addr+     itbl  = StgInfoTable {+                 entry = if ghciTablesNextToCode+                         then Nothing+                         else Just entry_addr,+                 ptrs  = fromIntegral ptr_words,+                 nptrs = fromIntegral nonptr_words,+                 tipe  = CONSTR,+                 srtlen = fromIntegral tag,+                 code  = if ghciTablesNextToCode+                         then Just code'+                         else Nothing+              }+++-- -----------------------------------------------------------------------------+-- Building machine code fragments for a constructor's entry code++funPtrToInt :: FunPtr a -> Int+funPtrToInt (FunPtr a) = I## (addr2Int## a)++data Arch = ArchSPARC+          | ArchPPC+          | ArchX86+          | ArchX86_64+          | ArchAlpha+          | ArchARM+          | ArchARM64+          | ArchPPC64+          | ArchPPC64LE+          | ArchUnknown+ deriving Show++platform :: Arch+platform =+#if defined(sparc_HOST_ARCH)+       ArchSPARC+#elif defined(powerpc_HOST_ARCH)+       ArchPPC+#elif defined(i386_HOST_ARCH)+       ArchX86+#elif defined(x86_64_HOST_ARCH)+       ArchX86_64+#elif defined(alpha_HOST_ARCH)+       ArchAlpha+#elif defined(arm_HOST_ARCH)+       ArchARM+#elif defined(aarch64_HOST_ARCH)+       ArchARM64+#elif defined(powerpc64_HOST_ARCH)+       ArchPPC64+#elif defined(powerpc64le_HOST_ARCH)+       ArchPPC64LE+#else+#    if defined(TABLES_NEXT_TO_CODE)+#        error Unimplemented architecture+#    else+       ArchUnknown+#    endif+#endif++mkJumpToAddr :: EntryFunPtr -> ItblCodes+mkJumpToAddr a = case platform of+    ArchSPARC ->+        -- After some consideration, we'll try this, where+        -- 0x55555555 stands in for the address to jump to.+        -- According to includes/rts/MachRegs.h, %g3 is very+        -- likely indeed to be baggable.+        --+        --   0000 07155555              sethi   %hi(0x55555555), %g3+        --   0004 8610E155              or      %g3, %lo(0x55555555), %g3+        --   0008 81C0C000              jmp     %g3+        --   000c 01000000              nop++        let w32 = fromIntegral (funPtrToInt a)++            hi22, lo10 :: Word32 -> Word32+            lo10 x = x .&. 0x3FF+            hi22 x = (x `shiftR` 10) .&. 0x3FFFF++        in Right [ 0x07000000 .|. (hi22 w32),+                   0x8610E000 .|. (lo10 w32),+                   0x81C0C000,+                   0x01000000 ]++    ArchPPC ->+        -- We'll use r12, for no particular reason.+        -- 0xDEADBEEF stands for the address:+        -- 3D80DEAD lis r12,0xDEAD+        -- 618CBEEF ori r12,r12,0xBEEF+        -- 7D8903A6 mtctr r12+        -- 4E800420 bctr++        let w32 = fromIntegral (funPtrToInt a)+            hi16 x = (x `shiftR` 16) .&. 0xFFFF+            lo16 x = x .&. 0xFFFF+        in Right [ 0x3D800000 .|. hi16 w32,+                   0x618C0000 .|. lo16 w32,+                   0x7D8903A6, 0x4E800420 ]++    ArchX86 ->+        -- Let the address to jump to be 0xWWXXYYZZ.+        -- Generate   movl $0xWWXXYYZZ,%eax  ;  jmp *%eax+        -- which is+        -- B8 ZZ YY XX WW FF E0++        let w32 = fromIntegral (funPtrToInt a) :: Word32+            insnBytes :: [Word8]+            insnBytes+               = [0xB8, byte0 w32, byte1 w32,+                        byte2 w32, byte3 w32,+                  0xFF, 0xE0]+        in+            Left insnBytes++    ArchX86_64 ->+        -- Generates:+        --      jmpq *.L1(%rip)+        --      .align 8+        -- .L1:+        --      .quad <addr>+        --+        -- which looks like:+        --     8:   ff 25 02 00 00 00     jmpq   *0x2(%rip)      # 10 <f+0x10>+        -- with addr at 10.+        --+        -- We need a full 64-bit pointer (we can't assume the info table is+        -- allocated in low memory).  Assuming the info pointer is aligned to+        -- an 8-byte boundary, the addr will also be aligned.++        let w64 = fromIntegral (funPtrToInt a) :: Word64+            insnBytes :: [Word8]+            insnBytes+               = [0xff, 0x25, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00,+                  byte0 w64, byte1 w64, byte2 w64, byte3 w64,+                  byte4 w64, byte5 w64, byte6 w64, byte7 w64]+        in+            Left insnBytes++    ArchAlpha ->+        let w64 = fromIntegral (funPtrToInt a) :: Word64+        in Right [ 0xc3800000      -- br   at, .+4+                 , 0xa79c000c      -- ldq  at, 12(at)+                 , 0x6bfc0000      -- jmp  (at)    # with zero hint -- oh well+                 , 0x47ff041f      -- nop+                 , fromIntegral (w64 .&. 0x0000FFFF)+                 , fromIntegral ((w64 `shiftR` 32) .&. 0x0000FFFF) ]++    ArchARM { } ->+        -- Generates Arm sequence,+        --      ldr r1, [pc, #0]+        --      bx r1+        --+        -- which looks like:+        --     00000000 <.addr-0x8>:+        --     0:       00109fe5    ldr    r1, [pc]      ; 8 <.addr>+        --     4:       11ff2fe1    bx     r1+        let w32 = fromIntegral (funPtrToInt a) :: Word32+        in Left [ 0x00, 0x10, 0x9f, 0xe5+                , 0x11, 0xff, 0x2f, 0xe1+                , byte0 w32, byte1 w32, byte2 w32, byte3 w32]++    ArchARM64 { } ->+        -- Generates:+        --+        --      ldr     x1, label+        --      br      x1+        -- label:+        --      .quad <addr>+        --+        -- which looks like:+        --     0:       58000041        ldr     x1, <label>+        --     4:       d61f0020        br      x1+       let w64 = fromIntegral (funPtrToInt a) :: Word64+       in Right [ 0x58000041+                , 0xd61f0020+                , fromIntegral w64+                , fromIntegral (w64 `shiftR` 32) ]+    ArchPPC64 ->+        -- We use the compiler's register r12 to read the function+        -- descriptor and the linker's register r11 as a temporary+        -- register to hold the function entry point.+        -- In the medium code model the function descriptor+        -- is located in the first two gigabytes, i.e. the address+        -- of the function pointer is a non-negative 32 bit number.+        -- 0x0EADBEEF stands for the address of the function pointer:+        --    0:   3d 80 0e ad     lis     r12,0x0EAD+        --    4:   61 8c be ef     ori     r12,r12,0xBEEF+        --    8:   e9 6c 00 00     ld      r11,0(r12)+        --    c:   e8 4c 00 08     ld      r2,8(r12)+        --   10:   7d 69 03 a6     mtctr   r11+        --   14:   e9 6c 00 10     ld      r11,16(r12)+        --   18:   4e 80 04 20     bctr+       let  w32 = fromIntegral (funPtrToInt a)+            hi16 x = (x `shiftR` 16) .&. 0xFFFF+            lo16 x = x .&. 0xFFFF+       in Right [ 0x3D800000 .|. hi16 w32,+                  0x618C0000 .|. lo16 w32,+                  0xE96C0000,+                  0xE84C0008,+                  0x7D6903A6,+                  0xE96C0010,+                  0x4E800420]++    ArchPPC64LE ->+        -- The ABI requires r12 to point to the function's entry point.+        -- We use the medium code model where code resides in the first+        -- two gigabytes, so loading a non-negative32 bit address+        -- with lis followed by ori is fine.+        -- 0x0EADBEEF stands for the address:+        -- 3D800EAD lis r12,0x0EAD+        -- 618CBEEF ori r12,r12,0xBEEF+        -- 7D8903A6 mtctr r12+        -- 4E800420 bctr++        let w32 = fromIntegral (funPtrToInt a)+            hi16 x = (x `shiftR` 16) .&. 0xFFFF+            lo16 x = x .&. 0xFFFF+        in Right [ 0x3D800000 .|. hi16 w32,+                   0x618C0000 .|. lo16 w32,+                   0x7D8903A6, 0x4E800420 ]++    -- This code must not be called. You either need to+    -- add your architecture as a distinct case or+    -- use non-TABLES_NEXT_TO_CODE mode+    ArchUnknown -> error "mkJumpToAddr: ArchUnknown is unsupported"++byte0 :: (Integral w) => w -> Word8+byte0 w = fromIntegral w++byte1, byte2, byte3, byte4, byte5, byte6, byte7+       :: (Integral w, Bits w) => w -> Word8+byte1 w = fromIntegral (w `shiftR` 8)+byte2 w = fromIntegral (w `shiftR` 16)+byte3 w = fromIntegral (w `shiftR` 24)+byte4 w = fromIntegral (w `shiftR` 32)+byte5 w = fromIntegral (w `shiftR` 40)+byte6 w = fromIntegral (w `shiftR` 48)+byte7 w = fromIntegral (w `shiftR` 56)+++-- -----------------------------------------------------------------------------+-- read & write intfo tables++-- entry point for direct returns for created constr itbls+foreign import ccall "&stg_interp_constr1_entry" stg_interp_constr1_entry :: EntryFunPtr+foreign import ccall "&stg_interp_constr2_entry" stg_interp_constr2_entry :: EntryFunPtr+foreign import ccall "&stg_interp_constr3_entry" stg_interp_constr3_entry :: EntryFunPtr+foreign import ccall "&stg_interp_constr4_entry" stg_interp_constr4_entry :: EntryFunPtr+foreign import ccall "&stg_interp_constr5_entry" stg_interp_constr5_entry :: EntryFunPtr+foreign import ccall "&stg_interp_constr6_entry" stg_interp_constr6_entry :: EntryFunPtr+foreign import ccall "&stg_interp_constr7_entry" stg_interp_constr7_entry :: EntryFunPtr++interpConstrEntry :: [EntryFunPtr]+interpConstrEntry = [ error "pointer tag 0"+                    , stg_interp_constr1_entry+                    , stg_interp_constr2_entry+                    , stg_interp_constr3_entry+                    , stg_interp_constr4_entry+                    , stg_interp_constr5_entry+                    , stg_interp_constr6_entry+                    , stg_interp_constr7_entry ]++data StgConInfoTable = StgConInfoTable {+   conDesc   :: Ptr Word8,+   infoTable :: StgInfoTable+}+++pokeConItbl+  :: Ptr StgConInfoTable -> Ptr StgConInfoTable -> StgConInfoTable+  -> IO ()+pokeConItbl wr_ptr _ex_ptr itbl = do+#if defined(TABLES_NEXT_TO_CODE)+  -- Write the offset to the con_desc from the end of the standard InfoTable+  -- at the first byte.+  let con_desc_offset = conDesc itbl `minusPtr` (_ex_ptr `plusPtr` conInfoTableSizeB)+  (#poke StgConInfoTable, con_desc) wr_ptr con_desc_offset+#else+  -- Write the con_desc address after the end of the info table.+  -- Use itblSize because CPP will not pick up PROFILING when calculating+  -- the offset.+  pokeByteOff wr_ptr itblSize (conDesc itbl)+#endif+  pokeItbl (wr_ptr `plusPtr` (#offset StgConInfoTable, i)) (infoTable itbl)++sizeOfEntryCode :: Int+sizeOfEntryCode+  | not ghciTablesNextToCode = 0+  | otherwise =+     case mkJumpToAddr undefined of+       Left  xs -> sizeOf (head xs) * length xs+       Right xs -> sizeOf (head xs) * length xs++-- Note: Must return proper pointer for use in a closure+newExecConItbl :: StgInfoTable -> ByteString -> IO (FunPtr ())+newExecConItbl obj con_desc+   = alloca $ \pcode -> do+        let lcon_desc = BS.length con_desc + 1{- null terminator -}+            -- SCARY+            -- This size represents the number of bytes in an StgConInfoTable.+            sz = fromIntegral (conInfoTableSizeB + sizeOfEntryCode)+               -- Note: we need to allocate the conDesc string next to the info+               -- table, because on a 64-bit platform we reference this string+               -- with a 32-bit offset relative to the info table, so if we+               -- allocated the string separately it might be out of range.+        wr_ptr <- _allocateExec (sz + fromIntegral lcon_desc) pcode+        ex_ptr <- peek pcode+        let cinfo = StgConInfoTable { conDesc = ex_ptr `plusPtr` fromIntegral sz+                                    , infoTable = obj }+        pokeConItbl wr_ptr ex_ptr cinfo+        BS.useAsCStringLen con_desc $ \(src, len) ->+            copyBytes (castPtr wr_ptr `plusPtr` fromIntegral sz) src len+        let null_off = fromIntegral sz + fromIntegral (BS.length con_desc)+        poke (castPtr wr_ptr `plusPtr` null_off) (0 :: Word8)+        _flushExec sz ex_ptr -- Cache flush (if needed)+#if defined(TABLES_NEXT_TO_CODE)+        return (castPtrToFunPtr (ex_ptr `plusPtr` conInfoTableSizeB))+#else+        return (castPtrToFunPtr ex_ptr)+#endif++foreign import ccall unsafe "allocateExec"+  _allocateExec :: CUInt -> Ptr (Ptr a) -> IO (Ptr a)++foreign import ccall unsafe "flushExec"+  _flushExec :: CUInt -> Ptr a -> IO ()++-- -----------------------------------------------------------------------------+-- Constants and config++wORD_SIZE :: Int+wORD_SIZE = (#const SIZEOF_HSINT)++conInfoTableSizeB :: Int+conInfoTableSizeB = wORD_SIZE + itblSize+#endif /* GHCI */
+ libraries/ghci/GHCi/ObjLink.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE CPP, UnboxedTuples, MagicHash #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+--+--  (c) The University of Glasgow 2002-2006+--++-- ---------------------------------------------------------------------------+--      The dynamic linker for object code (.o .so .dll files)+-- ---------------------------------------------------------------------------++-- | Primarily, this module consists of an interface to the C-land+-- dynamic linker.+module GHCi.ObjLink+  ( initObjLinker, ShouldRetainCAFs(..)+  , loadDLL+  , loadArchive+  , loadObj+  , unloadObj+  , purgeObj+  , lookupSymbol+  , lookupClosure+  , resolveObjs+  , addLibrarySearchPath+  , removeLibrarySearchPath+  , findSystemLibrary+  )  where++import Prelude -- See note [Why do we import Prelude here?]+import GHCi.RemoteTypes+import Control.Exception (throwIO, ErrorCall(..))+import Control.Monad    ( when )+import Foreign.C+import Foreign.Marshal.Alloc ( free )+import Foreign          ( nullPtr )+import GHC.Exts+import System.Posix.Internals ( CFilePath, withFilePath, peekFilePath )+import System.FilePath  ( dropExtension, normalise )+++++-- ---------------------------------------------------------------------------+-- RTS Linker Interface+-- ---------------------------------------------------------------------------++data ShouldRetainCAFs+  = RetainCAFs+    -- ^ Retain CAFs unconditionally in linked Haskell code.+    -- Note that this prevents any code from being unloaded.+    -- It should not be necessary unless you are GHCi or+    -- hs-plugins, which needs to be able call any function+    -- in the compiled code.+  | DontRetainCAFs+    -- ^ Do not retain CAFs.  Everything reachable from foreign+    -- exports will be retained, due to the StablePtrs+    -- created by the module initialisation code.  unloadObj+    -- frees these StablePtrs, which will allow the CAFs to+    -- be GC'd and the code to be removed.++initObjLinker :: ShouldRetainCAFs -> IO ()+initObjLinker RetainCAFs = c_initLinker_ 1+initObjLinker _ = c_initLinker_ 0++lookupSymbol :: String -> IO (Maybe (Ptr a))+lookupSymbol str_in = do+   let str = prefixUnderscore str_in+   withCAString str $ \c_str -> do+     addr <- c_lookupSymbol c_str+     if addr == nullPtr+        then return Nothing+        else return (Just addr)++lookupClosure :: String -> IO (Maybe HValueRef)+lookupClosure str = do+  m <- lookupSymbol str+  case m of+    Nothing -> return Nothing+    Just (Ptr addr) -> case addrToAny# addr of+      (# a #) -> Just <$> mkRemoteRef (HValue a)++prefixUnderscore :: String -> String+prefixUnderscore+ | cLeadingUnderscore = ('_':)+ | otherwise          = id++-- | 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.+--+loadDLL :: String -> IO (Maybe String)+-- Nothing      => success+-- Just err_msg => failure+loadDLL str0 = do+  let+     -- On Windows, addDLL takes a filename without an extension, because+     -- it tries adding both .dll and .drv.  To keep things uniform in the+     -- layers above, loadDLL always takes a filename with an extension, and+     -- we drop it here on Windows only.+     str | isWindowsHost = dropExtension str0+         | otherwise     = str0+  --+  maybe_errmsg <- withFilePath (normalise str) $ \dll -> c_addDLL dll+  if maybe_errmsg == nullPtr+        then return Nothing+        else do str <- peekCString maybe_errmsg+                free maybe_errmsg+                return (Just str)++loadArchive :: String -> IO ()+loadArchive str = do+   withFilePath str $ \c_str -> do+     r <- c_loadArchive c_str+     when (r == 0) (throwIO (ErrorCall ("loadArchive " ++ show str ++ ": failed")))++loadObj :: String -> IO ()+loadObj str = do+   withFilePath str $ \c_str -> do+     r <- c_loadObj c_str+     when (r == 0) (throwIO (ErrorCall ("loadObj " ++ show str ++ ": failed")))++-- | @unloadObj@ drops the given dynamic library from the symbol table+-- as well as enables the library to be removed from memory during+-- a future major GC.+unloadObj :: String -> IO ()+unloadObj str =+   withFilePath str $ \c_str -> do+     r <- c_unloadObj c_str+     when (r == 0) (throwIO (ErrorCall ("unloadObj " ++ show str ++ ": failed")))++-- | @purgeObj@ drops the symbols for the dynamic library from the symbol+-- table. Unlike 'unloadObj', the library will not be dropped memory during+-- a future major GC.+purgeObj :: String -> IO ()+purgeObj str =+   withFilePath str $ \c_str -> do+     r <- c_purgeObj c_str+     when (r == 0) (throwIO (ErrorCall ("purgeObj " ++ show str ++ ": failed")))++addLibrarySearchPath :: String -> IO (Ptr ())+addLibrarySearchPath str =+   withFilePath str c_addLibrarySearchPath++removeLibrarySearchPath :: Ptr () -> IO Bool+removeLibrarySearchPath = c_removeLibrarySearchPath++findSystemLibrary :: String -> IO (Maybe String)+findSystemLibrary str = do+    result <- withFilePath str c_findSystemLibrary+    case result == nullPtr of+        True  -> return Nothing+        False -> do path <- peekFilePath result+                    free result+                    return $ Just path++resolveObjs :: IO Bool+resolveObjs = do+   r <- c_resolveObjs+   return (r /= 0)++-- ---------------------------------------------------------------------------+-- Foreign declarations to RTS entry points which does the real work;+-- ---------------------------------------------------------------------------++foreign import ccall unsafe "addDLL"                  c_addDLL                  :: CFilePath -> IO CString+foreign import ccall unsafe "initLinker_"             c_initLinker_             :: CInt -> IO ()+foreign import ccall unsafe "lookupSymbol"            c_lookupSymbol            :: CString -> IO (Ptr a)+foreign import ccall unsafe "loadArchive"             c_loadArchive             :: CFilePath -> IO Int+foreign import ccall unsafe "loadObj"                 c_loadObj                 :: CFilePath -> IO Int+foreign import ccall unsafe "purgeObj"                c_purgeObj                :: CFilePath -> IO Int+foreign import ccall unsafe "unloadObj"               c_unloadObj               :: CFilePath -> IO Int+foreign import ccall unsafe "resolveObjs"             c_resolveObjs             :: IO Int+foreign import ccall unsafe "addLibrarySearchPath"    c_addLibrarySearchPath    :: CFilePath -> IO (Ptr ())+foreign import ccall unsafe "findSystemLibrary"       c_findSystemLibrary       :: CFilePath -> IO CFilePath+foreign import ccall unsafe "removeLibrarySearchPath" c_removeLibrarySearchPath :: Ptr() -> IO Bool++-- -----------------------------------------------------------------------------+-- Configuration++#include "ghcautoconf.h"++cLeadingUnderscore :: Bool+#if defined(LEADING_UNDERSCORE)+cLeadingUnderscore = True+#else+cLeadingUnderscore = False+#endif++isWindowsHost :: Bool+#if defined(mingw32_HOST_OS)+isWindowsHost = True+#else+isWindowsHost = False+#endif
+ libraries/ghci/GHCi/ResolvedBCO.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving,+    BangPatterns, CPP #-}+module GHCi.ResolvedBCO+  ( ResolvedBCO(..)+  , ResolvedBCOPtr(..)+  , isLittleEndian+  ) where++import Prelude -- See note [Why do we import Prelude here?]+import SizedSeq+import GHCi.RemoteTypes+import GHCi.BreakArray++import Data.Array.Unboxed+import Data.Binary+import GHC.Generics+import GHCi.BinaryArray+++#include "MachDeps.h"++isLittleEndian :: Bool+#if defined(WORDS_BIGENDIAN)+isLittleEndian = True+#else+isLittleEndian = False+#endif++-- -----------------------------------------------------------------------------+-- ResolvedBCO++-- | A 'ResolvedBCO' is one in which all the 'Name' references have been+-- resolved to actual addresses or 'RemoteHValues'.+--+-- Note, all arrays are zero-indexed (we assume this when+-- serializing/deserializing)+data ResolvedBCO+   = ResolvedBCO {+        resolvedBCOIsLE   :: Bool,+        resolvedBCOArity  :: {-# UNPACK #-} !Int,+        resolvedBCOInstrs :: UArray Int Word16,         -- insns+        resolvedBCOBitmap :: UArray Int Word64,         -- bitmap+        resolvedBCOLits   :: UArray Int Word64,         -- non-ptrs+        resolvedBCOPtrs   :: (SizedSeq ResolvedBCOPtr)  -- ptrs+   }+   deriving (Generic, Show)++-- | The Binary instance for ResolvedBCOs.+--+-- Note, that we do encode the endianness, however there is no support for mixed+-- endianness setups.  This is primarily to ensure that ghc and iserv share the+-- same endianness.+instance Binary ResolvedBCO where+  put ResolvedBCO{..} = do+    put resolvedBCOIsLE+    put resolvedBCOArity+    putArray resolvedBCOInstrs+    putArray resolvedBCOBitmap+    putArray resolvedBCOLits+    put resolvedBCOPtrs+  get = ResolvedBCO+        <$> get <*> get <*> getArray <*> getArray <*> getArray <*> get++data ResolvedBCOPtr+  = ResolvedBCORef {-# UNPACK #-} !Int+      -- ^ reference to the Nth BCO in the current set+  | ResolvedBCOPtr {-# UNPACK #-} !(RemoteRef HValue)+      -- ^ reference to a previously created BCO+  | ResolvedBCOStaticPtr {-# UNPACK #-} !(RemotePtr ())+      -- ^ reference to a static ptr+  | ResolvedBCOPtrBCO ResolvedBCO+      -- ^ a nested BCO+  | ResolvedBCOPtrBreakArray {-# UNPACK #-} !(RemoteRef BreakArray)+      -- ^ Resolves to the MutableArray# inside the BreakArray+  deriving (Generic, Show)++instance Binary ResolvedBCOPtr
+ libraries/ghci/GHCi/Run.hs view
@@ -0,0 +1,366 @@+{-# LANGUAGE GADTs, RecordWildCards, MagicHash, ScopedTypeVariables, CPP,+    UnboxedTuples #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++-- |+-- Execute GHCi messages.+--+-- For details on Remote GHCi, see Note [Remote GHCi] in+-- compiler/ghci/GHCi.hs.+--+module GHCi.Run+  ( run, redirectInterrupts+  ) where++import Prelude -- See note [Why do we import Prelude here?]+import GHCi.CreateBCO+import GHCi.InfoTable+import GHCi.FFI+import GHCi.Message+import GHCi.ObjLink+import GHCi.RemoteTypes+import GHCi.TH+import GHCi.BreakArray+import GHCi.StaticPtrTable++import Control.Concurrent+import Control.DeepSeq+import Control.Exception+import Control.Monad+import Data.Binary+import Data.Binary.Get+import Data.ByteString (ByteString)+import qualified Data.ByteString.Unsafe as B+import GHC.Exts+import GHC.Exts.Heap+import GHC.Stack+import Foreign hiding (void)+import Foreign.C+import GHC.Conc.Sync+import GHC.IO hiding ( bracket )+import System.Mem.Weak  ( deRefWeak )+import Unsafe.Coerce++-- -----------------------------------------------------------------------------+-- Implement messages++foreign import ccall "revertCAFs" rts_revertCAFs  :: IO ()+        -- Make it "safe", just in case++run :: Message a -> IO a+run m = case m of+  InitLinker -> initObjLinker RetainCAFs+  RtsRevertCAFs -> rts_revertCAFs+  LookupSymbol str -> fmap toRemotePtr <$> lookupSymbol str+  LookupClosure str -> lookupClosure str+  LoadDLL str -> loadDLL str+  LoadArchive str -> loadArchive str+  LoadObj str -> loadObj str+  UnloadObj str -> unloadObj str+  AddLibrarySearchPath str -> toRemotePtr <$> addLibrarySearchPath str+  RemoveLibrarySearchPath ptr -> removeLibrarySearchPath (fromRemotePtr ptr)+  ResolveObjs -> resolveObjs+  FindSystemLibrary str -> findSystemLibrary str+  CreateBCOs bcos -> createBCOs (concatMap (runGet get) bcos)+  FreeHValueRefs rs -> mapM_ freeRemoteRef rs+  AddSptEntry fpr r -> localRef r >>= sptAddEntry fpr+  EvalStmt opts r -> evalStmt opts r+  ResumeStmt opts r -> resumeStmt opts r+  AbandonStmt r -> abandonStmt r+  EvalString r -> evalString r+  EvalStringToString r s -> evalStringToString r s+  EvalIO r -> evalIO r+  MkCostCentres mod ccs -> mkCostCentres mod ccs+  CostCentreStackInfo ptr -> ccsToStrings (fromRemotePtr ptr)+  NewBreakArray sz -> mkRemoteRef =<< newBreakArray sz+  EnableBreakpoint ref ix b -> do+    arr <- localRef ref+    _ <- if b then setBreakOn arr ix else setBreakOff arr ix+    return ()+  BreakpointStatus ref ix -> do+    arr <- localRef ref; r <- getBreak arr ix+    case r of+      Nothing -> return False+      Just w -> return (w /= 0)+  GetBreakpointVar ref ix -> do+    aps <- localRef ref+    mapM mkRemoteRef =<< getIdValFromApStack aps ix+  MallocData bs -> mkString bs+  MallocStrings bss -> mapM mkString0 bss+  PrepFFI conv args res -> toRemotePtr <$> prepForeignCall conv args res+  FreeFFI p -> freeForeignCallInfo (fromRemotePtr p)+  MkConInfoTable ptrs nptrs tag ptrtag desc ->+    toRemotePtr <$> mkConInfoTable ptrs nptrs tag ptrtag desc+  StartTH -> startTH+  GetClosure ref -> do+    clos <- getClosureData =<< localRef ref+    mapM (\(Box x) -> mkRemoteRef (HValue x)) clos+  Seq ref -> tryEval (void $ evaluate =<< localRef ref)+  _other -> error "GHCi.Run.run"++evalStmt :: EvalOpts -> EvalExpr HValueRef -> IO (EvalStatus [HValueRef])+evalStmt opts expr = do+  io <- mkIO expr+  sandboxIO opts $ do+    rs <- unsafeCoerce io :: IO [HValue]+    mapM mkRemoteRef rs+ where+  mkIO (EvalThis href) = localRef href+  mkIO (EvalApp l r) = do+    l' <- mkIO l+    r' <- mkIO r+    return ((unsafeCoerce l' :: HValue -> HValue) r')++evalIO :: HValueRef -> IO (EvalResult ())+evalIO r = do+  io <- localRef r+  tryEval (unsafeCoerce io :: IO ())++evalString :: HValueRef -> IO (EvalResult String)+evalString r = do+  io <- localRef r+  tryEval $ do+    r <- unsafeCoerce io :: IO String+    evaluate (force r)++evalStringToString :: HValueRef -> String -> IO (EvalResult String)+evalStringToString r str = do+  io <- localRef r+  tryEval $ do+    r <- (unsafeCoerce io :: String -> IO String) str+    evaluate (force r)++-- When running a computation, we redirect ^C exceptions to the running+-- thread.  ToDo: we might want a way to continue even if the target+-- thread doesn't die when it receives the exception... "this thread+-- is not responding".+--+-- Careful here: there may be ^C exceptions flying around, so we start the new+-- thread blocked (forkIO inherits mask from the parent, #1048), and unblock+-- only while we execute the user's code.  We can't afford to lose the final+-- putMVar, otherwise deadlock ensues. (#1583, #1922, #1946)++sandboxIO :: EvalOpts -> IO a -> IO (EvalStatus a)+sandboxIO opts io = do+  -- We are running in uninterruptibleMask+  breakMVar <- newEmptyMVar+  statusMVar <- newEmptyMVar+  withBreakAction opts breakMVar statusMVar $ do+    let runIt = measureAlloc $ tryEval $ rethrow opts $ clearCCS io+    if useSandboxThread opts+       then do+         tid <- forkIO $ do unsafeUnmask runIt >>= putMVar statusMVar+                                -- empty: can't block+         redirectInterrupts tid $ unsafeUnmask $ takeMVar statusMVar+       else+          -- GLUT on OS X needs to run on the main thread. If you+          -- try to use it from another thread then you just get a+          -- white rectangle rendered. For this, or anything else+          -- with such restrictions, you can turn the GHCi sandbox off+          -- and things will be run in the main thread.+          --+          -- BUT, note that the debugging features (breakpoints,+          -- tracing, etc.) need the expression to be running in a+          -- separate thread, so debugging is only enabled when+          -- using the sandbox.+         runIt++-- We want to turn ^C into a break when -fbreak-on-exception is on,+-- but it's an async exception and we only break for sync exceptions.+-- Idea: if we catch and re-throw it, then the re-throw will trigger+-- a break.  Great - but we don't want to re-throw all exceptions, because+-- then we'll get a double break for ordinary sync exceptions (you'd have+-- to :continue twice, which looks strange).  So if the exception is+-- not "Interrupted", we unset the exception flag before throwing.+--+rethrow :: EvalOpts -> IO a -> IO a+rethrow EvalOpts{..} io =+  catch io $ \se -> do+    -- If -fbreak-on-error, we break unconditionally,+    --  but with care of not breaking twice+    if breakOnError && not breakOnException+       then poke exceptionFlag 1+       else case fromException se of+               -- If it is a "UserInterrupt" exception, we allow+               --  a possible break by way of -fbreak-on-exception+               Just UserInterrupt -> return ()+               -- In any other case, we don't want to break+               _ -> poke exceptionFlag 0+    throwIO se++--+-- While we're waiting for the sandbox thread to return a result, if+-- the current thread receives an asynchronous exception we re-throw+-- it at the sandbox thread and continue to wait.+--+-- This is for two reasons:+--+--  * So that ^C interrupts runStmt (e.g. in GHCi), allowing the+--    computation to run its exception handlers before returning the+--    exception result to the caller of runStmt.+--+--  * clients of the GHC API can terminate a runStmt in progress+--    without knowing the ThreadId of the sandbox thread (#1381)+--+-- NB. use a weak pointer to the thread, so that the thread can still+-- be considered deadlocked by the RTS and sent a BlockedIndefinitely+-- exception.  A symptom of getting this wrong is that conc033(ghci)+-- will hang.+--+redirectInterrupts :: ThreadId -> IO a -> IO a+redirectInterrupts target wait = do+  wtid <- mkWeakThreadId target+  wait `catch` \e -> do+     m <- deRefWeak wtid+     case m of+       Nothing -> wait+       Just target -> do throwTo target (e :: SomeException); wait++measureAlloc :: IO (EvalResult a) -> IO (EvalStatus a)+measureAlloc io = do+  setAllocationCounter maxBound+  a <- io+  ctr <- getAllocationCounter+  let allocs = fromIntegral (maxBound::Int64) - fromIntegral ctr+  return (EvalComplete allocs a)++-- Exceptions can't be marshaled because they're dynamically typed, so+-- everything becomes a String.+tryEval :: IO a -> IO (EvalResult a)+tryEval io = do+  e <- try io+  case e of+    Left ex -> return (EvalException (toSerializableException ex))+    Right a -> return (EvalSuccess a)++-- This function sets up the interpreter for catching breakpoints, and+-- resets everything when the computation has stopped running.  This+-- is a not-very-good way to ensure that only the interactive+-- evaluation should generate breakpoints.+withBreakAction :: EvalOpts -> MVar () -> MVar (EvalStatus b) -> IO a -> IO a+withBreakAction opts breakMVar statusMVar act+ = bracket setBreakAction resetBreakAction (\_ -> act)+ where+   setBreakAction = do+     stablePtr <- newStablePtr onBreak+     poke breakPointIOAction stablePtr+     when (breakOnException opts) $ poke exceptionFlag 1+     when (singleStep opts) $ setStepFlag+     return stablePtr+        -- Breaking on exceptions is not enabled by default, since it+        -- might be a bit surprising.  The exception flag is turned off+        -- as soon as it is hit, or in resetBreakAction below.++   onBreak :: BreakpointCallback+   onBreak ix# uniq# is_exception apStack = do+     tid <- myThreadId+     let resume = ResumeContext+           { resumeBreakMVar = breakMVar+           , resumeStatusMVar = statusMVar+           , resumeThreadId = tid }+     resume_r <- mkRemoteRef resume+     apStack_r <- mkRemoteRef apStack+     ccs <- toRemotePtr <$> getCCSOf apStack+     putMVar statusMVar $ EvalBreak is_exception apStack_r (I# ix#) (I# uniq#) resume_r ccs+     takeMVar breakMVar++   resetBreakAction stablePtr = do+     poke breakPointIOAction noBreakStablePtr+     poke exceptionFlag 0+     resetStepFlag+     freeStablePtr stablePtr++resumeStmt+  :: EvalOpts -> RemoteRef (ResumeContext [HValueRef])+  -> IO (EvalStatus [HValueRef])+resumeStmt opts hvref = do+  ResumeContext{..} <- localRef hvref+  withBreakAction opts resumeBreakMVar resumeStatusMVar $+    mask_ $ do+      putMVar resumeBreakMVar () -- this awakens the stopped thread...+      redirectInterrupts resumeThreadId $ takeMVar resumeStatusMVar++-- when abandoning a computation we have to+--      (a) kill the thread with an async exception, so that the+--          computation itself is stopped, and+--      (b) fill in the MVar.  This step is necessary because any+--          thunks that were under evaluation will now be updated+--          with the partial computation, which still ends in takeMVar,+--          so any attempt to evaluate one of these thunks will block+--          unless we fill in the MVar.+--      (c) wait for the thread to terminate by taking its status MVar.  This+--          step is necessary to prevent race conditions with+--          -fbreak-on-exception (see #5975).+--  See test break010.+abandonStmt :: RemoteRef (ResumeContext [HValueRef]) -> IO ()+abandonStmt hvref = do+  ResumeContext{..} <- localRef hvref+  killThread resumeThreadId+  putMVar resumeBreakMVar ()+  _ <- takeMVar resumeStatusMVar+  return ()++foreign import ccall "&rts_stop_next_breakpoint" stepFlag      :: Ptr CInt+foreign import ccall "&rts_stop_on_exception"    exceptionFlag :: Ptr CInt++setStepFlag :: IO ()+setStepFlag = poke stepFlag 1+resetStepFlag :: IO ()+resetStepFlag = poke stepFlag 0++type BreakpointCallback+     = Int#    -- the breakpoint index+    -> Int#    -- the module uniq+    -> Bool    -- exception?+    -> HValue  -- the AP_STACK, or exception+    -> IO ()++foreign import ccall "&rts_breakpoint_io_action"+   breakPointIOAction :: Ptr (StablePtr BreakpointCallback)++noBreakStablePtr :: StablePtr BreakpointCallback+noBreakStablePtr = unsafePerformIO $ newStablePtr noBreakAction++noBreakAction :: BreakpointCallback+noBreakAction _ _ False _ = putStrLn "*** Ignoring breakpoint"+noBreakAction _ _ True  _ = return () -- exception: just continue++-- Malloc and copy the bytes.  We don't have any way to monitor the+-- lifetime of this memory, so it just leaks.+mkString :: ByteString -> IO (RemotePtr ())+mkString bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do+  ptr <- mallocBytes len+  copyBytes ptr cstr len+  return (castRemotePtr (toRemotePtr ptr))++mkString0 :: ByteString -> IO (RemotePtr ())+mkString0 bs = B.unsafeUseAsCStringLen bs $ \(cstr,len) -> do+  ptr <- mallocBytes (len+1)+  copyBytes ptr cstr len+  pokeElemOff (ptr :: Ptr CChar) len 0+  return (castRemotePtr (toRemotePtr ptr))++mkCostCentres :: String -> [(String,String)] -> IO [RemotePtr CostCentre]+#if defined(PROFILING)+mkCostCentres mod ccs = do+  c_module <- newCString mod+  mapM (mk_one c_module) ccs+ where+  mk_one c_module (decl_path,srcspan) = do+    c_name <- newCString decl_path+    c_srcspan <- newCString srcspan+    toRemotePtr <$> c_mkCostCentre c_name c_module c_srcspan++foreign import ccall unsafe "mkCostCentre"+  c_mkCostCentre :: Ptr CChar -> Ptr CChar -> Ptr CChar -> IO (Ptr CostCentre)+#else+mkCostCentres _ _ = return []+#endif++getIdValFromApStack :: HValue -> Int -> IO (Maybe HValue)+getIdValFromApStack apStack (I# stackDepth) = do+   case getApStackVal# apStack stackDepth of+        (# ok, result #) ->+            case ok of+              0# -> return Nothing -- AP_STACK not found+              _  -> return (Just (unsafeCoerce# result))
+ libraries/ghci/GHCi/Signals.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}+module GHCi.Signals (installSignalHandlers) where++import Prelude -- See note [Why do we import Prelude here?]+import Control.Concurrent+import Control.Exception+import System.Mem.Weak  ( deRefWeak )++#if !defined(mingw32_HOST_OS)+import System.Posix.Signals+#endif++#if defined(mingw32_HOST_OS)+import GHC.ConsoleHandler+#endif++-- | Install standard signal handlers for catching ^C, which just throw an+--   exception in the target thread.  The current target thread is the+--   thread at the head of the list in the MVar passed to+--   installSignalHandlers.+installSignalHandlers :: IO ()+installSignalHandlers = do+  main_thread <- myThreadId+  wtid <- mkWeakThreadId main_thread++  let interrupt = do+        r <- deRefWeak wtid+        case r of+          Nothing -> return ()+          Just t  -> throwTo t UserInterrupt++#if !defined(mingw32_HOST_OS)+  _ <- installHandler sigQUIT  (Catch interrupt) Nothing+  _ <- installHandler sigINT   (Catch interrupt) Nothing+#else+  -- GHC 6.3+ has support for console events on Windows+  -- NOTE: running GHCi under a bash shell for some reason requires+  -- you to press Ctrl-Break rather than Ctrl-C to provoke+  -- an interrupt.  Ctrl-C is getting blocked somewhere, I don't know+  -- why --SDM 17/12/2004+  let sig_handler ControlC = interrupt+      sig_handler Break    = interrupt+      sig_handler _        = return ()++  _ <- installHandler (Catch sig_handler)+#endif+  return ()
+ libraries/ghci/GHCi/StaticPtrTable.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE ForeignFunctionInterface #-}++module GHCi.StaticPtrTable ( sptAddEntry ) where++import Prelude -- See note [Why do we import Prelude here?]+import Data.Word+import Foreign+import GHC.Fingerprint+import GHCi.RemoteTypes++-- | Used by GHCi to add an SPT entry for a set of interactive bindings.+sptAddEntry :: Fingerprint -> HValue -> IO ()+sptAddEntry (Fingerprint a b) (HValue x) = do+    -- We own the memory holding the key (fingerprint) which gets inserted into+    -- the static pointer table and can't free it until the SPT entry is removed+    -- (which is currently never).+    fpr_ptr <- newArray [a,b]+    sptr <- newStablePtr x+    ent_ptr <- malloc+    poke ent_ptr (castStablePtrToPtr sptr)+    spt_insert_stableptr fpr_ptr ent_ptr++foreign import ccall "hs_spt_insert_stableptr"+    spt_insert_stableptr :: Ptr Word64 -> Ptr (Ptr ()) -> IO ()
+ libraries/ghci/GHCi/TH.hs view
@@ -0,0 +1,274 @@+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, DeriveGeneric,+    TupleSections, RecordWildCards, InstanceSigs, CPP #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++-- |+-- Running TH splices+--+module GHCi.TH+  ( startTH+  , runModFinalizerRefs+  , runTH+  , GHCiQException(..)+  ) where++{- Note [Remote Template Haskell]++Here is an overview of how TH works with -fexternal-interpreter.++Initialisation+~~~~~~~~~~~~~~++GHC sends a StartTH message to the server (see TcSplice.getTHState):++   StartTH :: Message (RemoteRef (IORef QState))++The server creates an initial QState object, makes an IORef to it, and+returns a RemoteRef to this to GHC. (see GHCi.TH.startTH below).++This happens once per module, the first time we need to run a TH+splice.  The reference that GHC gets back is kept in+tcg_th_remote_state in the TcGblEnv, and passed to each RunTH call+that follows.+++For each splice+~~~~~~~~~~~~~~~++1. GHC compiles a splice to byte code, and sends it to the server: in+   a CreateBCOs message:++   CreateBCOs :: [LB.ByteString] -> Message [HValueRef]++2. The server creates the real byte-code objects in its heap, and+   returns HValueRefs to GHC.  HValueRef is the same as RemoteRef+   HValue.++3. GHC sends a RunTH message to the server:++  RunTH+   :: RemoteRef (IORef QState)+        -- The state returned by StartTH in step1+   -> HValueRef+        -- The HValueRef we got in step 4, points to the code for the splice+   -> THResultType+        -- Tells us what kind of splice this is (decl, expr, type, etc.)+   -> Maybe TH.Loc+        -- Source location+   -> Message (QResult ByteString)+        -- Eventually it will return a QResult back to GHC.  The+        -- ByteString here is the (encoded) result of the splice.++4. The server runs the splice code.++5. Each time the splice code calls a method of the Quasi class, such+   as qReify, a message is sent from the server to GHC.  These+   messages are defined by the THMessage type.  GHC responds with the+   result of the request, e.g. in the case of qReify it would be the+   TH.Info for the requested entity.++6. When the splice has been fully evaluated, the server sends+   RunTHDone back to GHC.  This tells GHC that the server has finished+   sending THMessages and will send the QResult next.++8. The server then sends a QResult back to GHC, which is notionally+   the response to the original RunTH message.  The QResult indicates+   whether the splice succeeded, failed, or threw an exception.+++After typechecking+~~~~~~~~~~~~~~~~~~++GHC sends a FinishTH message to the server (see TcSplice.finishTH).+The server runs any finalizers that were added by addModuleFinalizer.+++Other Notes on TH / Remote GHCi++  * Note [Remote GHCi] in compiler/ghci/GHCi.hs+  * Note [External GHCi pointers] in compiler/ghci/GHCi.hs+  * Note [TH recover with -fexternal-interpreter] in+    compiler/typecheck/TcSplice.hs+-}++import Prelude -- See note [Why do we import Prelude here?]+import GHCi.Message+import GHCi.RemoteTypes+import GHC.Serialized++import Control.Exception+import qualified Control.Monad.Fail as Fail+import Control.Monad.IO.Class (MonadIO (..))+import Data.Binary+import Data.Binary.Put+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import Data.Data+import Data.Dynamic+import Data.Either+import Data.IORef+import Data.Map (Map)+import qualified Data.Map as M+import Data.Maybe+import GHC.Desugar+import qualified Language.Haskell.TH        as TH+import qualified Language.Haskell.TH.Syntax as TH+import Unsafe.Coerce++-- | Create a new instance of 'QState'+initQState :: Pipe -> QState+initQState p = QState M.empty Nothing p++-- | The monad in which we run TH computations on the server+newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) }++-- | The exception thrown by "fail" in the GHCiQ monad+data GHCiQException = GHCiQException QState String+  deriving Show++instance Exception GHCiQException++instance Functor GHCiQ where+  fmap f (GHCiQ s) = GHCiQ $ fmap (\(x,s') -> (f x,s')) . s++instance Applicative GHCiQ where+  f <*> a = GHCiQ $ \s ->+    do (f',s')  <- runGHCiQ f s+       (a',s'') <- runGHCiQ a s'+       return (f' a', s'')+  pure x = GHCiQ (\s -> return (x,s))++instance Monad GHCiQ where+  m >>= f = GHCiQ $ \s ->+    do (m', s')  <- runGHCiQ m s+       (a,  s'') <- runGHCiQ (f m') s'+       return (a, s'')+#if !MIN_VERSION_base(4,13,0)+  fail = Fail.fail+#endif++instance Fail.MonadFail GHCiQ where+  fail err  = GHCiQ $ \s -> throwIO (GHCiQException s err)++getState :: GHCiQ QState+getState = GHCiQ $ \s -> return (s,s)++noLoc :: TH.Loc+noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)++-- | Send a 'THMessage' to GHC and return the result.+ghcCmd :: Binary a => THMessage (THResult a) -> GHCiQ a+ghcCmd m = GHCiQ $ \s -> do+  r <- remoteTHCall (qsPipe s) m+  case r of+    THException str -> throwIO (GHCiQException s str)+    THComplete res -> return (res, s)++instance MonadIO GHCiQ where+  liftIO m = GHCiQ $ \s -> fmap (,s) m++instance TH.Quasi GHCiQ where+  qNewName str = ghcCmd (NewName str)+  qReport isError msg = ghcCmd (Report isError msg)++  -- See Note [TH recover with -fexternal-interpreter] in TcSplice+  qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do+    remoteTHCall (qsPipe s) StartRecover+    e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s+    remoteTHCall (qsPipe s) (EndRecover (isLeft e))+    case e of+      Left GHCiQException{} -> h s+      Right r -> return r+  qLookupName isType occ = ghcCmd (LookupName isType occ)+  qReify name = ghcCmd (Reify name)+  qReifyFixity name = ghcCmd (ReifyFixity name)+  qReifyInstances name tys = ghcCmd (ReifyInstances name tys)+  qReifyRoles name = ghcCmd (ReifyRoles name)++  -- To reify annotations, we send GHC the AnnLookup and also the+  -- TypeRep of the thing we're looking for, to avoid needing to+  -- serialize irrelevant annotations.+  qReifyAnnotations :: forall a . Data a => TH.AnnLookup -> GHCiQ [a]+  qReifyAnnotations lookup =+    map (deserializeWithData . B.unpack) <$>+      ghcCmd (ReifyAnnotations lookup typerep)+    where typerep = typeOf (undefined :: a)++  qReifyModule m = ghcCmd (ReifyModule m)+  qReifyConStrictness name = ghcCmd (ReifyConStrictness name)+  qLocation = fromMaybe noLoc . qsLocation <$> getState+  qAddDependentFile file = ghcCmd (AddDependentFile file)+  qAddTempFile suffix = ghcCmd (AddTempFile suffix)+  qAddTopDecls decls = ghcCmd (AddTopDecls decls)+  qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)+  qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=+                         ghcCmd . AddModFinalizer+  qAddCorePlugin str = ghcCmd (AddCorePlugin str)+  qGetQ = GHCiQ $ \s ->+    let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a+        lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m+    in return (lookup (qsMap s), s)+  qPutQ k = GHCiQ $ \s ->+    return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })+  qIsExtEnabled x = ghcCmd (IsExtEnabled x)+  qExtsEnabled = ghcCmd ExtsEnabled++-- | The implementation of the 'StartTH' message: create+-- a new IORef QState, and return a RemoteRef to it.+startTH :: IO (RemoteRef (IORef QState))+startTH = do+  r <- newIORef (initQState (error "startTH: no pipe"))+  mkRemoteRef r++-- | Runs the mod finalizers.+--+-- The references must be created on the caller process.+runModFinalizerRefs :: Pipe -> RemoteRef (IORef QState)+                    -> [RemoteRef (TH.Q ())]+                    -> IO ()+runModFinalizerRefs pipe rstate qrefs = do+  qs <- mapM localRef qrefs+  qstateref <- localRef rstate+  qstate <- readIORef qstateref+  _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe }+  return ()++-- | The implementation of the 'RunTH' message+runTH+  :: Pipe+  -> RemoteRef (IORef QState)+      -- ^ The TH state, created by 'startTH'+  -> HValueRef+      -- ^ The splice to run+  -> THResultType+      -- ^ What kind of splice it is+  -> Maybe TH.Loc+      -- ^ The source location+  -> IO ByteString+      -- ^ Returns an (encoded) result that depends on the THResultType++runTH pipe rstate rhv ty mb_loc = do+  hv <- localRef rhv+  case ty of+    THExp -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Exp)+    THPat -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Pat)+    THType -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q TH.Type)+    THDec -> runTHQ pipe rstate mb_loc (unsafeCoerce hv :: TH.Q [TH.Dec])+    THAnnWrapper -> do+      hv <- unsafeCoerce <$> localRef rhv+      case hv :: AnnotationWrapper of+        AnnotationWrapper thing -> return $!+          LB.toStrict (runPut (put (toSerialized serializeWithData thing)))++-- | Run a Q computation.+runTHQ+  :: Binary a => Pipe -> RemoteRef (IORef QState) -> Maybe TH.Loc -> TH.Q a+  -> IO ByteString+runTHQ pipe rstate mb_loc ghciq = do+  qstateref <- localRef rstate+  qstate <- readIORef qstateref+  let st = qstate { qsLocation = mb_loc, qsPipe = pipe }+  (r,new_state) <- runGHCiQ (TH.runQ ghciq) st+  writeIORef qstateref new_state+  return $! LB.toStrict (runPut (put r))
+ libraries/template-haskell/Language/Haskell/TH/Quote.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}+{- |+Module : Language.Haskell.TH.Quote+Description : Quasi-quoting support for Template Haskell++Template Haskell supports quasiquoting, which permits users to construct+program fragments by directly writing concrete syntax.  A quasiquoter is+essentially a function with takes a string to a Template Haskell AST.+This module defines the 'QuasiQuoter' datatype, which specifies a+quasiquoter @q@ which can be invoked using the syntax+@[q| ... string to parse ... |]@ when the @QuasiQuotes@ language+extension is enabled, and some utility functions for manipulating+quasiquoters.  Nota bene: this package does not define any parsers,+that is up to you.+-}+module Language.Haskell.TH.Quote(+        QuasiQuoter(..),+        quoteFile,+        -- * For backwards compatibility+        dataToQa, dataToExpQ, dataToPatQ+    ) where++import Language.Haskell.TH.Syntax+import Prelude++-- | The 'QuasiQuoter' type, a value @q@ of this type can be used+-- in the syntax @[q| ... string to parse ...|]@.  In fact, for+-- convenience, a 'QuasiQuoter' actually defines multiple quasiquoters+-- to be used in different splice contexts; if you are only interested+-- in defining a quasiquoter to be used for expressions, you would+-- define a 'QuasiQuoter' with only 'quoteExp', and leave the other+-- fields stubbed out with errors.+data QuasiQuoter = QuasiQuoter {+    -- | Quasi-quoter for expressions, invoked by quotes like @lhs = $[q|...]@+    quoteExp  :: String -> Q Exp,+    -- | Quasi-quoter for patterns, invoked by quotes like @f $[q|...] = rhs@+    quotePat  :: String -> Q Pat,+    -- | Quasi-quoter for types, invoked by quotes like @f :: $[q|...]@+    quoteType :: String -> Q Type,+    -- | Quasi-quoter for declarations, invoked by top-level quotes+    quoteDec  :: String -> Q [Dec]+    }++-- | 'quoteFile' takes a 'QuasiQuoter' and lifts it into one that read+-- the data out of a file.  For example, suppose @asmq@ is an+-- assembly-language quoter, so that you can write [asmq| ld r1, r2 |]+-- as an expression. Then if you define @asmq_f = quoteFile asmq@, then+-- the quote [asmq_f|foo.s|] will take input from file @"foo.s"@ instead+-- of the inline text+quoteFile :: QuasiQuoter -> QuasiQuoter+quoteFile (QuasiQuoter { quoteExp = qe, quotePat = qp, quoteType = qt, quoteDec = qd }) +  = QuasiQuoter { quoteExp = get qe, quotePat = get qp, quoteType = get qt, quoteDec = get qd }+  where+   get :: (String -> Q a) -> String -> Q a+   get old_quoter file_name = do { file_cts <- runIO (readFile file_name) +                                 ; addDependentFile file_name+                                 ; old_quoter file_cts }